Add a parser and use it for reading rules and queries
This commit is contained in:
parent
545416fce0
commit
930a05c951
|
@ -12,8 +12,10 @@ to generate this file without the comments in this block.
|
||||||
-}
|
-}
|
||||||
{ name = "bergamot"
|
{ name = "bergamot"
|
||||||
, dependencies =
|
, dependencies =
|
||||||
[ "bifunctors"
|
[ "arrays"
|
||||||
|
, "bifunctors"
|
||||||
, "control"
|
, "control"
|
||||||
|
, "either"
|
||||||
, "foldable-traversable"
|
, "foldable-traversable"
|
||||||
, "lazy"
|
, "lazy"
|
||||||
, "lists"
|
, "lists"
|
||||||
|
@ -21,7 +23,9 @@ to generate this file without the comments in this block.
|
||||||
, "maybe"
|
, "maybe"
|
||||||
, "newtype"
|
, "newtype"
|
||||||
, "ordered-collections"
|
, "ordered-collections"
|
||||||
|
, "parsing"
|
||||||
, "prelude"
|
, "prelude"
|
||||||
|
, "strings"
|
||||||
, "transformers"
|
, "transformers"
|
||||||
, "tuples"
|
, "tuples"
|
||||||
, "unifyt"
|
, "unifyt"
|
||||||
|
|
|
@ -0,0 +1,57 @@
|
||||||
|
module Language.Bergamot.Parser where
|
||||||
|
|
||||||
|
import Prelude
|
||||||
|
|
||||||
|
|
||||||
|
import Language.Bergamot.Syntax (Expr(..))
|
||||||
|
import Language.Bergamot.Rules (Rule(..), Metavariable)
|
||||||
|
|
||||||
|
import Control.Apply (lift2)
|
||||||
|
import Control.Lazy (defer)
|
||||||
|
import Parsing (Parser, runParser)
|
||||||
|
import Parsing.String (char, eof, string)
|
||||||
|
import Parsing.String.Basic (digit, letter, space)
|
||||||
|
import Parsing.Combinators (many, many1, sepBy, (<|>))
|
||||||
|
import Data.Array (fromFoldable)
|
||||||
|
import Data.Either (hush)
|
||||||
|
import Data.List (List(..))
|
||||||
|
import Data.List.NonEmpty (NonEmptyList)
|
||||||
|
import Data.Maybe (Maybe)
|
||||||
|
import Data.String (codePointFromChar, fromCodePointArray)
|
||||||
|
|
||||||
|
charsToString :: NonEmptyList Char -> String
|
||||||
|
charsToString = fromCodePointArray <<< fromFoldable <<< map codePointFromChar
|
||||||
|
|
||||||
|
whitespace :: Parser String Unit
|
||||||
|
whitespace = void $ many space
|
||||||
|
|
||||||
|
identifier :: Parser String String
|
||||||
|
identifier = (charsToString <$> many1 (letter <|> digit <|> char '_')) <* whitespace
|
||||||
|
|
||||||
|
expr :: Parser String (Expr Metavariable)
|
||||||
|
expr = (defer $ \_ -> atom) <|> (defer $ \_ -> metavariable)
|
||||||
|
|
||||||
|
atom :: Parser String (Expr Metavariable)
|
||||||
|
atom = lift2 Atom (identifier <* whitespace) (args <|> pure Nil)
|
||||||
|
where args = char '(' *> sepBy (defer $ \_ -> expr) (char ',' *> whitespace) <* char ')' <* whitespace
|
||||||
|
|
||||||
|
metavariable :: Parser String (Expr Metavariable)
|
||||||
|
metavariable = Var <$> (char '?' *> identifier <* whitespace)
|
||||||
|
|
||||||
|
rule :: Parser String (Rule Metavariable)
|
||||||
|
rule = map MkRule $ pure { head: _, tail: _ } <*> expr <*> (args <|> pure Nil) <* char ';' <* whitespace
|
||||||
|
where
|
||||||
|
arrow = (void (char '←') <|> void (string "<-")) <* whitespace
|
||||||
|
args = arrow *> sepBy expr (char ',' *> whitespace) <* whitespace
|
||||||
|
|
||||||
|
rules :: Parser String (List (Rule Metavariable))
|
||||||
|
rules = many rule
|
||||||
|
|
||||||
|
parseRule :: String -> Maybe (Rule Metavariable)
|
||||||
|
parseRule s = hush $ runParser s (rule <* eof)
|
||||||
|
|
||||||
|
parseRules :: String -> Maybe (List (Rule Metavariable))
|
||||||
|
parseRules s = hush $ runParser s (rules <* eof)
|
||||||
|
|
||||||
|
parseQuery :: String -> Maybe (Expr Metavariable)
|
||||||
|
parseQuery s = hush $ runParser s (expr <* eof)
|
|
@ -16,7 +16,7 @@ import Data.Tuple (fst)
|
||||||
import Data.Newtype (class Newtype)
|
import Data.Newtype (class Newtype)
|
||||||
import Data.Maybe (Maybe(..))
|
import Data.Maybe (Maybe(..))
|
||||||
|
|
||||||
newtype Rule k = MkRule { name :: String, head :: Expr k, tail :: List (Expr k) }
|
newtype Rule k = MkRule { head :: Expr k, tail :: List (Expr k) }
|
||||||
derive instance Newtype (Rule k) _
|
derive instance Newtype (Rule k) _
|
||||||
derive instance Functor Rule
|
derive instance Functor Rule
|
||||||
derive instance Foldable Rule
|
derive instance Foldable Rule
|
||||||
|
@ -26,6 +26,7 @@ type Metavariable = String
|
||||||
type Metavariables k = Map Metavariable k
|
type Metavariables k = Map Metavariable k
|
||||||
|
|
||||||
newtype ProofTree k = MkProofTree { claim :: Expr k, rule :: Rule Metavariable, witnesses :: List (ProofTree k) }
|
newtype ProofTree k = MkProofTree { claim :: Expr k, rule :: Rule Metavariable, witnesses :: List (ProofTree k) }
|
||||||
|
derive instance Functor ProofTree
|
||||||
|
|
||||||
metavariable :: forall k f m. MonadState (Metavariables k) m => MonadUnify k f m => Metavariable -> m k
|
metavariable :: forall k f m. MonadState (Metavariables k) m => MonadUnify k f m => Metavariable -> m k
|
||||||
metavariable s = do
|
metavariable s = do
|
||||||
|
|
|
@ -4,37 +4,17 @@ import Prelude
|
||||||
import Language.Bergamot.Syntax
|
import Language.Bergamot.Syntax
|
||||||
import Language.Bergamot.Rules
|
import Language.Bergamot.Rules
|
||||||
import Language.Bergamot.Unifier
|
import Language.Bergamot.Unifier
|
||||||
|
import Language.Bergamot.Parser
|
||||||
|
import Control.Apply
|
||||||
import Control.Monad.Logic.Trans
|
import Control.Monad.Logic.Trans
|
||||||
import Control.Monad.Logic.Class
|
import Control.Monad.Logic.Class
|
||||||
import Control.Monad.Unify.Trans
|
import Control.Monad.Unify.Trans
|
||||||
import Control.Monad.Unify.Class
|
import Control.Monad.Unify.Class
|
||||||
import Data.List
|
import Data.List (List(..), (:))
|
||||||
|
import Data.Array (fromFoldable)
|
||||||
|
import Data.Foldable
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
|
|
||||||
rules :: Array (Rule Metavariable)
|
|
||||||
rules =
|
|
||||||
[ MkRule { name: "TInt", head: tType tIntExpr tInt, tail: Nil }
|
|
||||||
, MkRule { name: "TString", head: tType tStringExpr tString, tail: Nil }
|
|
||||||
, MkRule { name: "TPlusInt", head: tType (tPlusExpr (Var "e1") (Var "e2")) tInt, tail: fromFoldable
|
|
||||||
[ tType (Var "e1") tInt
|
|
||||||
, tType (Var "e2") tInt
|
|
||||||
] }
|
|
||||||
, MkRule { name: "TPlusString", head: tType (tPlusExpr (Var "e1") (Var "e2")) tString, tail: fromFoldable
|
|
||||||
[ tType (Var "e1") tString
|
|
||||||
, tType (Var "e2") tString
|
|
||||||
] }
|
|
||||||
, MkRule { name: "TPair", head: tType (tProdExpr (Var "e1") (Var "e2")) (tProd (Var "t1") (Var "t2")), tail: fromFoldable
|
|
||||||
[ tType (Var "e1") (Var "t1")
|
|
||||||
, tType (Var "e2") (Var "t2")
|
|
||||||
] }
|
|
||||||
, MkRule { name: "TFst", head: tType (tFstExpr (Var "e")) (Var "t1"), tail: fromFoldable
|
|
||||||
[ tType (Var "e") (tProd (Var "t1") (Var "t2"))
|
|
||||||
] }
|
|
||||||
, MkRule { name: "TSnd", head: tType (tSndExpr (Var "e")) (Var "t2"), tail: fromFoldable
|
|
||||||
[ tType (Var "e") (tProd (Var "t1") (Var "t2"))
|
|
||||||
] }
|
|
||||||
]
|
|
||||||
|
|
||||||
tType et tt = Atom "type" $ et : tt : Nil
|
tType et tt = Atom "type" $ et : tt : Nil
|
||||||
tInt = Atom "int" Nil
|
tInt = Atom "int" Nil
|
||||||
tString = Atom "string" Nil
|
tString = Atom "string" Nil
|
||||||
|
@ -46,11 +26,11 @@ tProdExpr et1 et2 = Atom "pair" $ et1 : et2 : Nil
|
||||||
tFstExpr et = Atom "fst" $ et : Nil
|
tFstExpr et = Atom "fst" $ et : Nil
|
||||||
tSndExpr et = Atom "snd" $ et : Nil
|
tSndExpr et = Atom "snd" $ et : Nil
|
||||||
|
|
||||||
toLatexExpr :: Expr IntVar -> String
|
toLatexExpr :: Expr String -> String
|
||||||
toLatexExpr (Atom "type" (t1 : t2 : Nil)) = toLatexExpr t1 <> " : " <> toLatexExpr t2
|
toLatexExpr (Atom "type" (t1 : t2 : Nil)) = toLatexExpr t1 <> " : " <> toLatexExpr t2
|
||||||
toLatexExpr (Atom "int" Nil) = "\\text{int}"
|
toLatexExpr (Atom "int" Nil) = "\\text{int}"
|
||||||
toLatexExpr (Atom "string" Nil) = "\\text{string}"
|
toLatexExpr (Atom "string" Nil) = "\\text{string}"
|
||||||
toLatexExpr (Atom "prod" (t1 : t2 : Nil)) = toLatexExpr t1 <> "\\times" <> toLatexExpr t2
|
toLatexExpr (Atom "prod" (t1 : t2 : Nil)) = toLatexExpr t1 <> "\\times " <> toLatexExpr t2
|
||||||
toLatexExpr (Atom "n" Nil) = "n"
|
toLatexExpr (Atom "n" Nil) = "n"
|
||||||
toLatexExpr (Atom "s" Nil) = "s"
|
toLatexExpr (Atom "s" Nil) = "s"
|
||||||
toLatexExpr (Atom "plus" (t1 : t2 : Nil)) = toLatexExpr t1 <> " + " <> toLatexExpr t2
|
toLatexExpr (Atom "plus" (t1 : t2 : Nil)) = toLatexExpr t1 <> " + " <> toLatexExpr t2
|
||||||
|
@ -58,11 +38,14 @@ toLatexExpr (Atom "pair" (t1 : t2 : Nil)) = "(" <> toLatexExpr t1 <> ", " <> toL
|
||||||
toLatexExpr (Atom "fst" (t : Nil)) = "\\text{fst}\\ " <> toLatexExpr t
|
toLatexExpr (Atom "fst" (t : Nil)) = "\\text{fst}\\ " <> toLatexExpr t
|
||||||
toLatexExpr (Atom "snd" (t : Nil)) = "\\text{snd}\\ " <> toLatexExpr t
|
toLatexExpr (Atom "snd" (t : Nil)) = "\\text{snd}\\ " <> toLatexExpr t
|
||||||
toLatexExpr (Atom s xs) = "\\text{" <> s <> "}(" <> intercalate ", " (toLatexExpr <$> xs) <> ")"
|
toLatexExpr (Atom s xs) = "\\text{" <> s <> "}(" <> intercalate ", " (toLatexExpr <$> xs) <> ")"
|
||||||
toLatexExpr (Var _) = "?"
|
toLatexExpr (Var x) = x
|
||||||
|
|
||||||
toLatexProofTree :: ProofTree IntVar -> String
|
toLatexRule :: Rule String -> String
|
||||||
toLatexProofTree (MkProofTree {claim, witnesses}) = "\\cfrac{" <> intercalate "\\quad" (toLatexProofTree <$> witnesses) <> "}{" <> toLatexExpr claim <> "}"
|
toLatexRule (MkRule {head, tail}) = "\\cfrac{" <> intercalate "\\quad " (toLatexExpr <$> tail) <> "}{" <> toLatexExpr head <> "}"
|
||||||
|
|
||||||
main :: Maybe String
|
toLatexProofTree :: ProofTree String -> String
|
||||||
main = map toLatexProofTree $ runUnifier rules $ query $ tType (Var "e") (tProd tInt (tProd tInt tString))
|
toLatexProofTree (MkProofTree {claim, witnesses}) = "\\cfrac{" <> intercalate "\\quad " (toLatexProofTree <$> witnesses) <> "}{" <> toLatexExpr claim <> "}"
|
||||||
|
|
||||||
|
main :: String -> String -> Maybe String
|
||||||
|
main rs q = map (toLatexProofTree <<< map (const "?")) $ join $ lift2 runUnifier (fromFoldable <$> parseRules rs) (query <$> parseQuery q)
|
||||||
-- main = map toLatexProofTree $ runUnifier rules $ query $ tType (tSndExpr (tProdExpr tStringExpr (tPlusExpr tIntExpr tIntExpr))) (Var "T")
|
-- main = map toLatexProofTree $ runUnifier rules $ query $ tType (tSndExpr (tProdExpr tStringExpr (tPlusExpr tIntExpr tIntExpr))) (Var "T")
|
||||||
|
|
Loading…
Reference in New Issue