Institute parser for Core.

docs/core-grammar.md

@@ -0,0 +1,30 @@
+# Semantic Core grammar
+
+This is an EBNF grammar for the (experimental) core IR language.
+
+```
+expr ::= expr '.' expr
+       | expr ' '+ expr
+       | '{' expr (';' expr)* ';'? '}'
+       | 'if' expr 'then' expr 'else' expr
+       | ('lexical' | 'import' | 'load') expr
+       | lit
+       | 'let'? lvalue '=' expr
+       | '(' expr ')'
+
+lvalue ::= ident
+         | parens expr
+
+lit ::= '#true'
+      | '#false'
+      | 'unit'
+      | 'frame'
+      | lambda
+      | ident
+
+lambda ::= ('λ' | '\') ident ('->' | '→') expr
+
+ident ::= [A-z_] ([A-z0-9_])*
+        | '#{' [^{}]+ '}'
+        | '"' [^"]+ '"'
+```

semantic-core/semantic-core.cabal

@@ -26,22 +26,29 @@ library
                      , Analysis.Typecheck
                      , Control.Effect.Readline
                      , Data.Core
+                     , Data.Core.Parser
+                     , Data.Core.Pretty
                      , Data.File
                      , Data.Loc
                      , Data.Name
                      , Data.Stack
   -- other-modules:
   -- other-extensions:
-  build-depends:       algebraic-graphs ^>= 0.3
-                     , base             >= 4.11 && < 5
-                     , containers       ^>= 0.6
-                     , directory        ^>= 1.3
-                     , filepath         ^>= 1.4
-                     , fused-effects    ^>= 0.4
-                     , haskeline        ^>= 0.7.5
-                     , prettyprinter    ^>= 1.2.1
-                     , semigroupoids    ^>= 5.3
-                     , transformers     ^>= 0.5.6
+  build-depends:       algebraic-graphs            ^>= 0.3
+                     , base                         >= 4.11 && < 5
+                     , containers                  ^>= 0.6
+                     , directory                   ^>= 1.3
+                     , filepath                    ^>= 1.4
+                     , fused-effects               ^>= 0.4
+                     , haskeline                   ^>= 0.7.5
+                     , parsers                     ^>= 0.12.10
+                     , prettyprinter               ^>= 1.2.1
+                     , prettyprinter-ansi-terminal ^>= 1.1.1
+                     , recursion-schemes           ^>= 5.1
+                     , semigroupoids               ^>= 5.3
+                     , transformers                ^>= 0.5.6
+                     , trifecta                    ^>= 2
+                     , unordered-containers        ^>= 0.2.10
   hs-source-dirs:      src
   default-language:    Haskell2010
   ghc-options:         -Weverything -Wno-missing-local-signatures -Wno-missing-import-lists -Wno-implicit-prelude -Wno-safe -Wno-unsafe -Wno-name-shadowing -Wno-monomorphism-restriction -Wno-missed-specialisations -Wno-all-missed-specialisations
@@ -57,3 +64,17 @@ test-suite doctest
                      , semantic-core
   hs-source-dirs:      test
   default-language:    Haskell2010
+
+test-suite spec
+  type:                exitcode-stdio-1.0
+  main-is:             Spec.hs
+  other-modules:       Generators
+  build-depends:       base
+                     , semantic-core
+                     , hedgehog >= 0.6 && <1
+                     , tasty >= 1.2 && <2
+                     , tasty-hedgehog >= 0.2 && <1
+                     , tasty-hunit >= 0.10 && <1
+                     , trifecta
+  hs-source-dirs:      test
+  default-language:    Haskell2010

semantic-core/src/Analysis/Eval.hs

@@ -119,7 +119,7 @@ prog6 =
       ]
     ]
   , File (Loc "main" (locSpan (fromJust here))) $ block
-    [ Load (String "dep")
+    [ Load (Var (Path "dep"))
     , Let (User "thing") := Var (Path "dep") :. Var (User "var")
     ]
   ]

semantic-core/src/Data/Core.hs

@@ -1,27 +1,30 @@
-{-# LANGUAGE DeriveTraversable, FlexibleContexts, LambdaCase, OverloadedStrings, RecordWildCards #-}
+{-# LANGUAGE DeriveTraversable, FlexibleContexts, LambdaCase, OverloadedStrings, RecordWildCards, TemplateHaskell, TypeFamilies #-}
 module Data.Core
 ( Core(..)
+, CoreF(..)
 , Edge(..)
-, showCore
 , lams
 , ($$*)
 , unapply
 , unapplies
 , block
 , ann
 , annWith
+, stripAnnotations
 ) where
 
 import           Control.Applicative (Alternative (..))
+import           Data.Functor.Foldable hiding (ListF(..))
+import           Data.Functor.Foldable.TH
 import           Data.Foldable (foldl')
 import           Data.Loc
 import           Data.Name
 import           Data.Stack
-import           Data.Text.Prettyprint.Doc (Pretty (..), (<+>), vsep)
-import qualified Data.Text.Prettyprint.Doc as Pretty
-import qualified Data.Text.Prettyprint.Doc.Render.String as Pretty
 import           GHC.Stack
 
+data Edge = Lexical | Import
+  deriving (Eq, Ord, Show)
+
 data Core
   = Var Name
   | Let Name
@@ -50,52 +53,16 @@ infixr 1 :>>
 infix  3 :=
 infixl 4 :.
 
-data Edge = Lexical | Import
-  deriving (Eq, Ord, Show)
+makeBaseFunctor ''Core
 
-instance Pretty Edge where
-  pretty = pretty . show
+infixl 2 :$$
+infixr 1 :>>$
+infix  3 :=$
+infixl 4 :.$
 
 instance Semigroup Core where
   (<>) = (:>>)
 
-softsemi :: Pretty.Doc a
-softsemi = Pretty.flatAlt mempty ";"
-
-showCore :: Core -> String
-showCore = Pretty.renderString . Pretty.layoutPretty Pretty.defaultLayoutOptions . pretty
-
-instance Pretty Core where
-  pretty = \case
-    Var a    -> pretty a
-    Let a    -> "let" <+> pretty a
-    a :>>  b -> vsep [pretty a <> softsemi, pretty b]
-
-    Lam x f  -> vsep [ Pretty.nest 2 $ vsep [ "λ" <> pretty x <+> "-> {"
-                                            , pretty f
-                                            ]
-                     , "}"
-                     ]
-
-    f :$ x   -> pretty f <> "." <> pretty x
-    Unit     -> Pretty.parens mempty
-    Bool b   -> pretty b
-    If c x y -> Pretty.sep [ "if" <+> pretty c
-                           , "then" <+> pretty x
-                           , "else" <+> pretty y
-                           ]
-
-    String s -> pretty (show s)
-
-    Frame    -> Pretty.braces mempty
-
-    Load p   -> "load" <+> pretty p
-    Edge e n -> pretty e <+> pretty n
-    a :. b   -> "push" <+> Pretty.parens (pretty a) <+> Pretty.brackets (pretty b)
-    var := x -> pretty var <+> "=" <+> pretty x
-    Ann (Loc p s) c  -> pretty c <> Pretty.brackets (pretty p <> ":" <> pretty s)
-
-
 lams :: Foldable t => t Name -> Core -> Core
 lams names body = foldr Lam body names
 
@@ -124,3 +91,8 @@ ann = annWith callStack
 
 annWith :: CallStack -> Core -> Core
 annWith callStack c = maybe c (flip Ann c) (stackLoc callStack)
+
+stripAnnotations :: Core -> Core
+stripAnnotations = cata go where
+  go (AnnF _ item) = item
+  go item          = embed item

semantic-core/src/Data/Core/Parser.hs

@@ -0,0 +1,115 @@
+module Data.Core.Parser
+  ( module Text.Trifecta
+  , core
+  , lit
+  , expr
+  , lvalue
+  ) where
+
+-- Consult @doc/grammar.md@ for an EBNF grammar.
+
+import           Control.Applicative
+import qualified Data.Char as Char
+import           Data.Core
+import           Data.Name
+import           Data.Semigroup
+import           Data.String
+import qualified Text.Parser.Token as Token
+import qualified Text.Parser.Token.Highlight as Highlight
+import           Text.Trifecta hiding (ident)
+
+-- * Identifier styles and derived parsers
+
+validIdentifierStart :: Char -> Bool
+validIdentifierStart c = not (Char.isDigit c) && isSimpleCharacter c
+
+coreIdents :: TokenParsing m => IdentifierStyle m
+coreIdents = Token.IdentifierStyle
+  { _styleName              = "core"
+  , _styleStart             = satisfy validIdentifierStart
+  , _styleLetter            = satisfy isSimpleCharacter
+  , _styleReserved          = reservedNames
+  , _styleHighlight         = Highlight.Identifier
+  , _styleReservedHighlight = Highlight.ReservedIdentifier
+  }
+
+reserved :: (TokenParsing m, Monad m) => String -> m ()
+reserved = Token.reserve coreIdents
+
+identifier :: (TokenParsing m, Monad m, IsString s) => m s
+identifier = choice [quote, plain] <?> "identifier" where
+  plain = Token.ident coreIdents
+  quote = between (string "#{") (symbol "}") (fromString <$> some (noneOf "{}"))
+
+-- * Parsers (corresponding to EBNF)
+
+core :: (TokenParsing m, Monad m) => m Core
+core = expr
+
+expr :: (TokenParsing m, Monad m) => m Core
+expr = atom `chainl1` go where
+  go = choice [ (:.) <$ dot
+              , (:$) <$ notFollowedBy dot
+              ]
+
+atom :: (TokenParsing m, Monad m) => m Core
+atom = choice
+  [ comp
+  , ifthenelse
+  , edge
+  , lit
+  , ident
+  , assign
+  , parens expr
+  ]
+
+comp :: (TokenParsing m, Monad m) => m Core
+comp = braces (sconcat <$> sepEndByNonEmpty expr semi) <?> "compound statement"
+
+ifthenelse :: (TokenParsing m, Monad m) => m Core
+ifthenelse = If
+  <$ reserved "if"   <*> core
+  <* reserved "then" <*> core
+  <* reserved "else" <*> core
+  <?> "if-then-else statement"
+
+assign :: (TokenParsing m, Monad m) => m Core
+assign = (:=) <$> try (lvalue <* symbolic '=') <*> core <?> "assignment"
+
+edge :: (TokenParsing m, Monad m) => m Core
+edge = kw <*> expr where kw = choice [ Edge Lexical <$ reserved "lexical"
+                                     , Edge Import  <$ reserved "import"
+                                     , Load         <$ reserved "load"
+                                     ]
+
+lvalue :: (TokenParsing m, Monad m) => m Core
+lvalue = choice
+  [ Let <$ reserved "let" <*> name
+  , ident
+  , parens expr
+  ]
+
+-- * Literals
+
+name :: (TokenParsing m, Monad m) => m Name
+name = choice [regular, strpath] <?> "name" where
+  regular = User <$> identifier
+  strpath = Path <$> between (symbolic '"') (symbolic '"') (some $ noneOf "\"")
+
+lit :: (TokenParsing m, Monad m) => m Core
+lit = let x `given` n = x <$ reserved n in choice
+  [ Bool True  `given` "#true"
+  , Bool False `given` "#false"
+  , Unit       `given` "#unit"
+  , Frame      `given` "#frame"
+  , lambda
+  ] <?> "literal"
+
+lambda :: (TokenParsing m, Monad m) => m Core
+lambda = Lam <$ lambduh <*> name <* arrow <*> core <?> "lambda" where
+  lambduh = symbolic 'λ' <|> symbolic '\\'
+  arrow   = symbol "→"   <|> symbol "->"
+
+ident :: (Monad m, TokenParsing m) => m Core
+ident = Var <$> name <?> "identifier"
+