Extending the syntax of GRIN

grin/grin.cabal

@@ -66,6 +66,13 @@ library
     Grin.PrimOpsPrelude
     Grin.Nametable
     Grin.Research
+    Grin.Syntax.Extended
+    Grin.ExtendedSyntax.Grin
+    Grin.ExtendedSyntax.Parse.AST
+    Grin.ExtendedSyntax.Parse.Basic
+    Grin.ExtendedSyntax.Parse.TypeEnv
+    Grin.ExtendedSyntax.Pretty
+    Grin.ExtendedSyntax.TypeEnv
     Pipeline.Eval
     Pipeline.Optimizations
     Pipeline.Pipeline
@@ -85,13 +92,16 @@ library
     Test.IO
     Test.Test
     Test.Util
+    Test.ExtendedSyntax.Grammar
+    Test.ExtendedSyntax.Test
     Transformations.BindNormalisation
     Transformations.CountVariableUse
     Transformations.EffectMap
     Transformations.GenerateEval
     Transformations.MangleNames
     Transformations.Names
     Transformations.StaticSingleAssignment
+    Transformations.Syntax
     Transformations.UnitPropagation
     Transformations.Util
     Transformations.Optimising.ArityRaising
@@ -253,6 +263,7 @@ test-suite grin-test
                      Transformations.Optimising.DeadParameterEliminationSpec
                      Transformations.Optimising.DeadVariableEliminationSpec
                      Transformations.StaticSingleAssignmentSpec
+                     Transformations.SyntaxSpec
                      Transformations.BindNormalisationSpec
                      Transformations.ConfluenceSpec
                      Transformations.MangleNamesSpec

grin/src/Grin/ExtendedSyntax/Grin.hs

@@ -0,0 +1,110 @@
+{-# LANGUAGE FlexibleInstances, DeriveFunctor, RankNTypes, LambdaCase #-}
+module Grin.ExtendedSyntax.Grin
+  ( module Grin.ExtendedSyntax.Grin
+  , module Grin.Syntax.Extended
+  ) where
+
+import Data.Functor.Foldable as Foldable
+import Debug.Trace (trace)
+import Lens.Micro.Platform
+import Data.Maybe
+import Data.Text (pack, unpack)
+import Data.List (nub)
+
+import Grin.Syntax.Extended
+import Grin.TypeEnvDefs
+
+class FoldNames n where
+  foldNames :: (Monoid m) => (Name -> m) -> n -> m
+
+instance FoldNames Val where
+  foldNames f = \case
+    ConstTagNode  _tag vals -> foldMap f vals
+    Var name                -> f name
+    _                       -> mempty
+
+instance FoldNames BPat where
+  foldNames f = \case
+    VarPat v    -> f v
+    AsPat v val -> f v <> foldNames f val
+
+
+instance FoldNames CPat where
+  foldNames f = \case
+    NodePat _ names -> foldMap f names
+    TagPat _        -> mempty
+    LitPat _        -> mempty
+    DefaultPat      -> mempty
+
+instance FoldNames n => FoldNames [n] where
+  foldNames f = foldMap (foldNames f)
+
+dCoAlg :: (a -> String) -> (a -> ExpF b) -> (a -> ExpF b)
+dCoAlg dbg f = f . (\x -> trace (dbg x) x)
+
+dAlg :: (b -> String) -> (ExpF a -> b) -> (ExpF a -> b)
+dAlg dbg f = (\x -> trace (dbg x) x) . f
+
+match :: Traversal' a b -> a -> Bool
+match t x = isJust $ x ^? t
+
+isLit :: Val -> Bool
+isLit = match _Lit
+
+_Lit :: Traversal' Val Lit
+_Lit f (Lit l) = Lit <$> f l
+_Lit _ rest    = pure rest
+
+_Var :: Traversal' Val Name
+_Var f (Var name) = Var <$> f name
+_Var _ rest       = pure rest
+
+_CNode :: Traversal' Val (Tag, [Name])
+_CNode f (ConstTagNode tag params) = uncurry ConstTagNode <$> f (tag, params)
+_CNode _ rest = pure rest
+
+isBasicCPat :: CPat -> Bool
+isBasicCPat = \case
+  TagPat _ -> True
+  LitPat _ -> True
+  _        -> False
+
+isBasicValue :: Val -> Bool
+isBasicValue Unit{}   = True
+isBasicValue Lit{}    = True
+isBasicValue _'       = True
+
+isPrimitiveExp :: Exp -> Bool
+isPrimitiveExp = \case
+  SApp    _ _ -> True
+  SReturn _   -> True
+  SStore  _   -> True
+  SFetch  _   -> True
+  SUpdate _ _ -> True
+  _           -> False
+
+isSimpleExp :: Exp -> Bool
+isSimpleExp e | isPrimitiveExp e = True
+isSimpleExp e = case e of
+  SBlock  _   -> True
+  _           -> False
+
+unpackName :: Name -> String
+unpackName (NM name) = unpack name
+
+packName :: String -> Name
+packName = NM . pack
+
+showTS :: Show a => a -> Name
+showTS = packName . show
+
+concatPrograms :: [Program] -> Program
+concatPrograms prgs = Program (nub $ concat exts) (concat defs) where
+  (exts, defs) = unzip [(e, d) | Program e d <- prgs]
+
+-- indetifier rules for parser and pretty printer
+allowedSpecial :: String
+allowedSpecial = "._':!@-"
+
+allowedInitial :: String
+allowedInitial = "._" ++ ['a'..'z'] ++ ['A'..'Z']

grin/src/Grin/ExtendedSyntax/Parse/AST.hs

@@ -0,0 +1,153 @@
+{-# LANGUAGE TupleSections, LambdaCase, OverloadedStrings #-}
+
+module Grin.ExtendedSyntax.Parse.AST
+  ( parseGrin
+  , parseProg
+  , parseDef
+  , parseExpr
+  ) where
+
+import Data.Char
+import Data.Void
+import Data.Text (Text)
+import qualified Data.Text as T
+
+import Control.Applicative (empty)
+import Control.Monad (void, mzero)
+import Text.Megaparsec
+import qualified Text.Megaparsec.Char.Lexer as L
+import Text.Megaparsec.Char as C
+import qualified Data.Set as Set
+
+import Grin.ExtendedSyntax.Grin
+import Grin.Parse.Basic
+import Grin.Parse.TypeEnv
+
+-- grin syntax
+
+def :: Parser Def
+def = Def <$> try (L.indentGuard sc EQ pos1 *> var) <*> many var <* op "=" <*> (L.indentGuard sc GT pos1 >>= expr)
+
+expr :: Pos -> Parser Exp
+expr i = L.indentGuard sc EQ i >>
+  try ((\pat e b -> EBind e pat b) <$> try (bindingPat <* op "<-") <*> simpleExp i <*> expr i ) <|>
+  ifThenElse i <|>
+  simpleExp i
+
+ifThenElse :: Pos -> Parser Exp
+ifThenElse i = do
+  kw "if"
+  b <- var
+  kw "then"
+  t <- (L.indentGuard sc GT i >>= expr)
+  L.indentGuard sc EQ i
+  kw "else"
+  e <- (L.indentGuard sc GT i >>= expr)
+  return $ ECase b [ Alt (LitPat (LBool True))  t
+                   , Alt (LitPat (LBool False)) e
+                   ]
+
+simpleExp :: Pos -> Parser SimpleExp
+simpleExp i = SReturn <$ kw "pure" <*> value <|>
+              ECase <$ kw "case" <*> var <* kw "of" <*> (L.indentGuard sc GT i >>= some . alternative) <|>
+              SStore <$ kw "store" <*> var <|>
+              SFetch <$ kw "fetch" <*> var <|>
+              SUpdate <$ kw "update" <*> var <*> var <|>
+              SBlock <$ kw "do" <*> (L.indentGuard sc GT i >>= expr) <|>
+
+              -- FIXME: remove '$' from app syntax, fix 'value' parser with using 'lineFold' instead
+              SApp <$> primNameOrDefName <* (optional $ op "$") <*> many var
+
+primNameOrDefName :: Parser Name
+primNameOrDefName = nMap ("_"<>) <$ char '_' <*> var <|> var
+
+alternative :: Pos -> Parser Alt
+alternative i = Alt <$> try (L.indentGuard sc EQ i *> altPat) <* op "->" <*> (L.indentGuard sc GT i >>= expr)
+
+bindingPat :: Parser BPat
+bindingPat = AsPat  <$> (var <* char '@') <*> parens value <|>
+             VarPat <$> var
+
+altPat :: Parser CPat
+altPat = parens (NodePat <$> tag <*> many var) <|>
+         DefaultPat <$ kw "#default" <|>
+         TagPat <$> tag <|>
+         LitPat <$> literal
+
+-- #undefined can hold simple types as well as node types
+value :: Parser Val
+value = Lit <$> literal <|>
+        Var <$> var <|>
+        Unit <$ op "()" <|>
+        Undefined <$> parens (kw "#undefined" *> op "::" *> typeAnnot)
+
+literal :: Parser Lit
+literal = (try $ LFloat . realToFrac <$> signedFloat) <|>
+          (try $ LWord64 . fromIntegral <$> lexeme (L.decimal <* C.char 'u')) <|>
+          (try $ LInt64 . fromIntegral <$> signedInteger) <|>
+          (try $ LBool <$> (True <$ kw "#True" <|> False <$ kw "#False")) <|>
+          (try $ LString <$> lexeme (C.char '#' *> quotedString)) <|>
+          (try $ LChar <$> lexeme (C.string "#'" *> (escaped <|> anyChar) <* C.char '\''))
+
+satisfyM :: (a -> Bool) -> Parser a -> Parser a
+satisfyM pred parser = do
+  x <- parser
+  if pred x
+    then pure x
+    else mzero
+
+-- externals
+
+externalBlock = do
+  L.indentGuard sc EQ pos1
+  ext <- const PrimOp <$> kw "primop" <|> const FFI <$> kw "ffi"
+  eff <- const False <$> kw "pure" <|> const True <$> kw "effectful"
+  i <- L.indentGuard sc GT pos1
+  some $ try (external ext eff i)
+
+external :: ExternalKind -> Bool -> Pos -> Parser External
+external ext eff i = do
+  L.indentGuard sc EQ i
+  name <- var
+  L.indentGuard sc GT i >> op "::"
+  ty <- reverse <$> sepBy1 (L.indentGuard sc GT i >> L.lexeme sc tyP ) (L.indentGuard sc GT i >> op "->")
+  let (retTy:argTyRev) = ty
+  pure External
+    { eName       = name
+    , eRetType    = retTy
+    , eArgsType   = reverse argTyRev
+    , eEffectful  = eff
+    , eKind       = ext
+    }
+
+tyP :: Parser Ty
+tyP =
+  TyVar <$ C.char '%' <*> var <|>
+  braces (TyCon <$> var <*> many tyP) <|>
+  TySimple <$> try simpleType
+
+-- top-level API
+
+grinModule :: Parser Exp
+grinModule = Program <$> (concat <$> many (try externalBlock)) <*> many def <* sc <* eof
+
+parseGrin :: String -> Text -> Either (ParseError Char Void) Exp
+parseGrin filename content = runParser grinModule filename (withoutTypeAnnots content)
+
+parseProg :: Text -> Exp
+parseProg src = either (error . parseErrorPretty' src) id . parseGrin "" $ withoutTypeAnnots src
+
+parseDef :: Text -> Exp
+parseDef src = either (error . parseErrorPretty' src) id . runParser def "" $ withoutTypeAnnots src
+
+parseExpr :: Text -> Exp
+parseExpr src = either (error . parseErrorPretty' src) id . runParser (expr pos1) "" $ withoutTypeAnnots src
+
+
+withoutTypeAnnots :: Text -> Text
+withoutTypeAnnots = T.unlines
+                  . map skipIfAnnot
+                  . T.lines
+  where skipIfAnnot line
+          | Just ('%',_) <- T.uncons . T.dropWhile isSpace $ line = ""
+          | otherwise = line