Clean up

bootstrap/src/Compiler/Backend/LLVM.hs

@@ -11,7 +11,7 @@ import qualified LLVM.IRBuilder as Builder
 import qualified LLVM.AST as IR
 import qualified LLVM.AST.Global as IR
 import qualified LLVM.AST.Constant as IR
-import LLVM.IRBuilder.Internal.SnocList (getSnocList, snoc)
+import LLVM.IRBuilder.Internal.SnocList (snoc)
 
 import Control.Monad (forM, forM_)
 import Control.Monad.State (modify)

bootstrap/src/Compiler/CodeGen/LLVM.hs

@@ -23,13 +23,12 @@ import Language.Core hiding (Type, Constraint)
 import Tlang.Generic ((:+:) (..))
 import Language.Core.Extension
 
-import Data.Text (Text)
+import Data.Text (Text, unpack)
 import Data.Kind (Constraint, Type)
 import Data.Functor.Foldable (cata)
 import Capability.Reader (HasReader, asks, ask, local)
 import Capability.State (HasState, gets, modify, get)
 import Control.Monad (when, foldM, forM, join)
-import Data.Text (unpack)
 import qualified Data.Map as Map
 
 class LLVMIRGen m f where
@@ -173,7 +172,7 @@ instance LLVMIRGen m lit => LLVMIRGen m (Pattern lit ext label name) where
             Right t -> return t
             Left err -> fail $ "LLVM: " <> err
           local @"destruct" (const [(t, v)]) mend
-        return (join $ fst <$> res, ret 1)
+        return (fst =<< res, ret 1)
       go _ = error "not yet defined pattern code"
 
 instance LLVMIRGen m (Record Label) where

bootstrap/src/Driver/Parser.hs

@@ -160,8 +160,8 @@ instance ( MonadFail m, MonadParsec e Text m
            (Expr f name) m
          , MonadParsecDbg e Text m
          )
-  => ParserDSL (WholeExpr e m (pat :- bpat :- typ)) (Expr f name) m where
-  syntax _ end =
+  => Rule (WholeExpr e m (pat :- bpat :- typ)) (Expr f name) m where
+  rule _ end =
     pratt @(ExprLang e m typ pat bpat (TypeLang e m)
             (PatLang e m typ (Expr f name) (TypeLang e m) (WholeExpr e m (pat :- bpat :- typ))))
           (lookAhead end) Go <* end

bootstrap/src/Driver/Unification.hs

@@ -15,7 +15,7 @@ import Control.Monad.State (StateT (..))
 import Data.Text (Text)
 
 import Tlang.Unification.Graph
-import Tlang.Graph.Core
+import Tlang.Graph.Core ( CoreG, Hole )
 import Language.Core (Label, Name)
 
 import Capability.Sink (HasSink)

bootstrap/src/EvalLoop/Util/Parser.hs

@@ -15,4 +15,4 @@ import Data.Void (Void)
 parseSurfaceExpr
   :: Monad m => String -> OperatorStore -> Text
   -> m (Either (ParseErrorBundle Text Void) (ExprSurface TypSurface), OperatorStore)
-parseSurfaceExpr prompt ops = driveParser ops (runDSL @(PredefExprLang _) @(ExprSurface TypSurface) eof) prompt
+parseSurfaceExpr prompt ops = driveParser ops (parseRule @(PredefExprLang _) @(ExprSurface TypSurface) eof) prompt

bootstrap/src/Language/Core/Term.hs

@@ -11,7 +11,14 @@
   at the same time. Some high level type wrapper tricks are needed to resolve this one.
   -}
 module Language.Core.Term
-
+  (
+    Term (..)
+  , Plain (..)
+  , (:++:) (..)
+  , App (..)
+  , App2 (..)
+  , Bound (..)
+  )
 where
 
 -- | This is a `Free` monad

bootstrap/src/Language/Parser/Class.hs

@@ -7,9 +7,9 @@ module Language.Parser.Class
   , Power (..)
   , PrattToken (..)
 
-  -- ** parser DSL
-  , ParserDSL (..)
-  , runDSL
+  -- ** parser DSL, with hand written non recursive rule
+  , Rule (..)
+  , parseRule
 
   -- ** tag helper, used for defing DSL
   , (:-)
@@ -48,15 +48,76 @@ class Monad m => PrattToken (tag :: any) (a :: Type) (m :: Type -> Type) | tag a
   tokenize :: Proxy tag -> (m () -> Power -> m a)
            -> m () -> m (Semantic m a)
 
--- | the class where to define syntax of type level parser DSL
+-- | This is the class where we define syntax of type level parser DSL.
 --
--- TODO: find a better name for it
-class ParserDSL (lang :: any) (target :: Type) (m :: Type -> Type) | lang target -> m where
-  syntax :: Proxy lang -> m () -> m target
-
--- | a short hand of `syntax`
-runDSL :: forall lang a m. ParserDSL lang a m => m () -> m a
-runDSL = syntax (Proxy @lang)
+-- Let's say we have following simple syntax definition:
+--
+-- @
+-- integer := (0..9)+
+-- float := integer {"." integer}
+-- target := float | integer
+-- @
+--
+-- and we have primitive rule for digit 0..9. Then, we can then try to define our
+-- type level syntax as:
+--
+-- @
+-- import GHC.TypeLits (Symbol)
+-- data Token (a :: Symbol) (m :: Type -> Type) -- to hold our rule name and environment
+-- data Combine (a :: k1) (b :: k2) (m :: Type -> Type) -- i will use this to provide a way of abstraction
+-- @
+--
+-- and we can assign semantic to these syntax by writing parsing target and Rule instance:
+--
+-- @
+-- data Target = GetInteger Integer | GetFloat Float deriving (Show, Eq, Ord)
+--
+-- -- The simple integer rule, with rule name `Token "integer"` and Integer as parse Target
+-- instance (Monad m) => Rule (Token "integer" m) Integer m where
+--   rule _ _ = do
+--     nums :: [Int] <- some digit
+--     integer <- {logic to convert "nums" into Integer}
+--     return integer
+--
+-- -- This indicates rule (Token "float" m) rely on (Token "integer" m) and it requires
+-- -- that rule (Token "integer" m) needs return Integer as result.
+-- instance (Rule (Token "integer" m) Integer m)
+--   => Rule (Token "float" m) Float m where
+--  rule _ e = do
+--    let integer = rule (Proxy :: Proxy (Token "integer")) e :: m Integer
+--    (deci, frac'maybe) \<- (,) \<$\> integer \<*\> optional (string "." *\> integer)
+--    number :: Float <- {logic to convert "decimal" and optional "fractional part" into Float}
+--    return number
+--
+-- -- Here, we define a shorthand to combine two rules. Since we have only
+-- -- two syntax rules, we don't need abstraction here and can provide a concrete
+-- -- syntax to user.
+-- --
+-- -- e.g. rule @@(Combine "integer" "float") @@Target endCondition
+-- --
+-- -- If user provides wrong syntax like @@(Combine "int" "float"), GHC will
+-- -- complain no instance for (Rule (Token "int" m).
+-- instance
+--   ( Rule (Token a m) Integer m
+--   , Rule (Token b m) Float m
+--   )
+--   => Rule (Combine a b m) Target m where
+--   rule _ e = do
+--     let floatPart = rule (Proxy :: Proxy (Token b)) e
+--         integerPart = rule (Proxy :: Proxy (Token a)) e
+--     GetFloat <$> floatPart <|> GetInteger <$> integerPart
+-- @
+class Rule (rule :: r) (target :: Type) (m :: Type -> Type) | rule target -> m where
+  -- | rule is the place to put a direct style definition for syntax
+  rule :: Proxy rule -> m () -> m target
+
+-- | a shorthand for `rule`.
+--
+-- @
+-- parseRule @(full rule to apply) end
+-- @
+parseRule :: forall rule a m. Rule rule a m => m () -> m a
+parseRule = rule (Proxy @rule)
 
 -- | semantic token, this is the way how do we interprete the token we find.
 data Semantic m a = Semantic
@@ -89,7 +150,8 @@ pratt' sel end rbp = do
                    (end $> left') <|> loop left'
            else return left
 
--- | if language defined `PrattToken`, then it has a pratt parser automatically.
+-- | if language defined `PrattToken`, then it has a pratt parser automatically
+-- built from this "token".
 --
 -- To use this parser, you need to feed it with following type level things:
 --
@@ -121,7 +183,7 @@ data (info :: Symbol) ?- (a :: k)
 data Layer (name :: k) (proxy :: any) (e :: Type)
 -- data Parse (val :: any)
 
--- | use to hold arbitrary info
+-- | use to hold arbitrary info where a `Type` is required.
 data Hint (a :: k)
 
 -- | effect expression, not useful for now

bootstrap/src/Language/Parser/Decl.hs

@@ -46,14 +46,14 @@ type ParserM e m =
 data WithDecl (e :: Type) (m :: Type -> Type) (a :: k)
 
 -- | define sequence operator
-instance (ParserM e m, ParserDSL (WithDecl e m a) (Decl decl info) m, ParserDSL (WithDecl e m b) (Decl decl info) m)
-  => ParserDSL (WithDecl e m (a :- b)) (Decl decl info) m where
-  syntax _ end = try (runDSL @(WithDecl e m a) end) <|> runDSL @(WithDecl e m b) end
+instance (ParserM e m, Rule (WithDecl e m a) (Decl decl info) m, Rule (WithDecl e m b) (Decl decl info) m)
+  => Rule (WithDecl e m (a :- b)) (Decl decl info) m where
+  rule _ end = try (parseRule @(WithDecl e m a) end) <|> parseRule @(WithDecl e m b) end
 
 -- | foreign interface
 instance (ParserM e m, PrattToken proxy typ m, info ~ Name, Item (FFI typ Name) :<: decl)
-  => ParserDSL (WithDecl e m (Layer "ffi" proxy typ)) (Decl decl info) m where
-  syntax _ end = do
+  => Rule (WithDecl e m (Layer "ffi" proxy typ)) (Decl decl info) m where
+  rule _ end = do
     void $ reserved "foreign"
     attrs <- optional $ brackets (commaSep attr)
     name <- Name <$> identifier
@@ -72,22 +72,22 @@ instance (ParserM e m, PrattToken proxy typ m, info ~ Name, Item (FFI typ Name)
              in braces $ AttrP <$> commaSep field
 
 -- | top level definition
-instance (ParserM e m, PrattToken tProxy typ m, ParserDSL eProxy expr m, info ~ Name, UserValue expr (Maybe typ) :<: decl)
-  => ParserDSL (WithDecl e m (Layer "define" (tProxy :- eProxy) (typ :- expr))) (Decl decl info) m where
-  syntax _ end = do
+instance (ParserM e m, PrattToken tProxy typ m, Rule eProxy expr m, info ~ Name, UserValue expr (Maybe typ) :<: decl)
+  => Rule (WithDecl e m (Layer "define" (tProxy :- eProxy) (typ :- expr))) (Decl decl info) m where
+  rule _ end = do
     void $ reserved "let"
     name <- fmap Name $ identifier <|> operator
     sig <- optional $ reservedOp ":" *> pratt @tProxy @typ ((void . lookAhead $ reservedOp "=") <|> end) Go
     void $ reservedOp "=" <|> fail "let declaration requires a value definition"
-    expr <- runDSL @eProxy @expr (lookAhead end)
+    expr <- parseRule @eProxy @expr (lookAhead end)
     end $> declare (UserValue expr sig name)
 
 instance ( ParserM e m, PrattToken proxy typ m
          , info ~ Name, typ ~ AST.Type tbind trep Name Name
          , Item (AliasType DataPrefix typ Name) :<: decl
          )
-  => ParserDSL (WithDecl e m (Layer "type" proxy typ)) (Decl decl info) m where
-  syntax _ end = do
+  => Rule (WithDecl e m (Layer "type" proxy typ)) (Decl decl info) m where
+  rule _ end = do
     void $ reserved "type"
     alias <- name
     vars <- manyTill typVar (void $ reservedOp "=")
@@ -106,8 +106,8 @@ instance ( ParserM e m, PrattToken proxy typ m
 data WithDataDef (e :: Type) (m :: Type -> Type) (a :: k)
 
 instance (ParserM e m, PrattToken proxy typ m, label ~ Label, DataStruct label :<: x)
-  => ParserDSL (WithDataDef e m (Layer "struct" proxy typ)) (DataBody x typ) m where
-  syntax _ _ = braces do
+  => Rule (WithDataDef e m (Layer "struct" proxy typ)) (DataBody x typ) m where
+  rule _ _ = braces do
     let fieldName = identifier <|> operator <&> Label
         field = do
           constructor <- fieldName <* reservedOp ":"
@@ -118,43 +118,43 @@ instance (ParserM e m, PrattToken proxy typ m, label ~ Label, DataStruct label :
     return $ DataBody (inj $ DataStruct cs1 css)
 
 instance (ParserM e m, PrattToken proxy typ m, field ~ Label, typ ~ AST.Type tbind trep name a, a ~ Name, DataEnum field :<: x)
-  => ParserDSL (WithDataDef e m (Layer "enum" proxy typ)) (DataBody x typ) m where
-  syntax _ end = do
+  => Rule (WithDataDef e m (Layer "enum" proxy typ)) (DataBody x typ) m where
+  rule _ end = do
     let fieldName = identifier <|> operator <&> Label
         field = TypVar . Name <$> identifier
             <|> parens (pratt @proxy @typ (void . lookAhead $ reservedOp ")") Go)
         dataEnum = reservedOp "|" >> (,) <$> fieldName <*> many field
     DataEnum <$> dataEnum <*> dataEnum `manyTill` end <&> DataBody . inj
 
 instance (ParserM e m, PrattToken proxy typ m, Identity :<: x)
-  => ParserDSL (WithDataDef e m (Layer "coerce" proxy typ)) (DataBody x typ) m where
-  syntax _ end = do
+  => Rule (WithDataDef e m (Layer "coerce" proxy typ)) (DataBody x typ) m where
+  rule _ end = do
     val <- reservedOp "=" *> pratt @proxy @typ (lookAhead end $> ()) Go <&> DataBody . inj . Identity
     end $> val
 
 instance (ParserM e m, PrattToken proxy typ m, DataNone :<: x)
-  => ParserDSL (WithDataDef e m (Layer "phantom" proxy typ)) (DataBody x typ) m where
-  syntax _ end = end $> DataBody (inj $ DataNone @typ)
+  => Rule (WithDataDef e m (Layer "phantom" proxy typ)) (DataBody x typ) m where
+  rule _ end = end $> DataBody (inj $ DataNone @typ)
 
 -- | sequence parsing
 instance ( ParserM e m
-         , ParserDSL (WithDataDef e m a) (DataBody x typ) m
-         , ParserDSL (WithDataDef e m b) (DataBody x typ) m
+         , Rule (WithDataDef e m a) (DataBody x typ) m
+         , Rule (WithDataDef e m b) (DataBody x typ) m
          )
-  => ParserDSL (WithDataDef e m (a :- b)) (DataBody x typ) m where
-  syntax _ end = runDSL @(WithDataDef e m a) end
-           <|> runDSL @(WithDataDef e m b) end
+  => Rule (WithDataDef e m (a :- b)) (DataBody x typ) m where
+  rule _ end = parseRule @(WithDataDef e m a) end
+           <|> parseRule @(WithDataDef e m b) end
 
 instance ( ParserM e m
          , info ~ Name, typ ~ AST.Type tbind trep name a
          , Item (DataType DataPrefix xt typ Name) :<: decl
-         , ParserDSL proxy def m, def ~ (xt typ)
+         , Rule proxy def m, def ~ (xt typ)
          )
-  => ParserDSL (WithDecl e m (Layer ("data" :- typ) proxy def)) (Decl decl info) m where
-  syntax _ end = do
+  => Rule (WithDecl e m (Layer ("data" :- typ) proxy def)) (Decl decl info) m where
+  rule _ end = do
     dataName <- reserved "data" *> name
     vars :: [Prefix Name typ] <- manyTill typVar (lookAhead . choice . (end:) $ void . reservedOp <$> ["|", "{", "="])
-    body <- runDSL @proxy @def (lookAhead end)
+    body <- parseRule @proxy @def (lookAhead end)
     let item = DataType (DataPrefix $ Prefixes vars) (toInteger $ length vars) body dataName
     end $> declare (Item item dataName)
     where
@@ -168,8 +168,8 @@ instance ( ParserM e m
 instance ( ParserM e m, info ~ Name, Item (UserOperator Text) :<: decl
          , HasState "OperatorStore" OperatorStore m
          )
-  => ParserDSL (WithDecl e m "fixity") (Decl decl info) m where
-  syntax _ end = do
+  => Rule (WithDecl e m "fixity") (Decl decl info) m where
+  rule _ end = do
     type'maybe <- reserved "operator" >> optional (reserved "type")
     prefix <- case type'maybe of
       Just _ -> return TypeOperator
@@ -204,7 +204,7 @@ defOperator end = do
 declaration'
   :: ( ParserM e m
      , HasState "OperatorStore" OperatorStore m
-     , ParserDSL proxy (Decl decl Name) m
+     , Rule proxy (Decl decl Name) m
      )
   => Proxy proxy -> m () -> m (Decl decl Name)
 declaration' wit end = do
@@ -214,13 +214,13 @@ declaration' wit end = do
   local @"TypeOperator" (const typeOp)
     $ local @"TermOperator" (const termOp)
     $ local @"PatternOperator" (const termOp)
-    $ syntax wit end
+    $ rule wit end
 
 declaration
   :: forall proxy decl e m
    . ( ParserM e m
      , HasState "OperatorStore" OperatorStore m
-     , ParserDSL proxy (Decl decl Name) m
+     , Rule proxy (Decl decl Name) m
      )
   => m () -> m (Decl decl Name)
 declaration = declaration' (Proxy @proxy)

bootstrap/src/Language/Parser/Expr.hs

@@ -52,17 +52,17 @@ instance ( PrattToken (WithExpr e m a) (Expr f name) m
   tokenize _ parser end = dbg' (symbolVal $ Proxy @msg)
                         $ tokenize (Proxy @(WithExpr e m a)) parser end
 
-instance ( ParserDSL (WithExpr e m a) (Expr f name) m
+instance ( Rule (WithExpr e m a) (Expr f name) m
          , KnownSymbol msg, ExprC e m, MonadParsecDbg e Text m)
-  => ParserDSL (WithExpr e m (msg ?- a)) (Expr f name) m where
-  syntax _ end = dbg' (symbolVal $ Proxy @msg)
-               $ syntax (Proxy @(WithExpr e m a)) end
+  => Rule (WithExpr e m (msg ?- a)) (Expr f name) m where
+  rule _ end = dbg' (symbolVal $ Proxy @msg)
+               $ rule (Proxy @(WithExpr e m a)) end
 
-instance ( ParserDSL (WithExpr e m (msg ?- a)) (Expr f name) m
+instance ( Rule (WithExpr e m (msg ?- a)) (Expr f name) m
          , KnownSymbol msg, ExprC e m, MonadParsecDbg e Text m)
-  => ParserDSL (msg ?- WithExpr e m a) (Expr f name) m where
-  syntax _ end = dbg' (symbolVal $ Proxy @msg)
-               $ syntax (Proxy @(WithExpr e m (msg ?- a))) end
+  => Rule (msg ?- WithExpr e m a) (Expr f name) m where
+  rule _ end = dbg' (symbolVal $ Proxy @msg)
+               $ rule (Proxy @(WithExpr e m (msg ?- a))) end
 
 -- | expression identifier
 instance (ExprC e m, name ~ Name, Apply :<: f)