Refactor EvalLoop

README.md

@@ -13,12 +13,15 @@ This repository has the `bootstrap` directory (which is the only meaningful dire
 switch into the bootstrap directory and using stack tool to build the project by `stack build`.
 Then you are free to try `stack run repl` command, which brings up an interpreter with following commands:
 
-1. `:gen` : to show generated llvm ir code for expression
-2. `:def` : to define global structures like a type declaration or value definition or FFI
-3. `:load` : to load a source file and parse it, then print raw AST structure
-4. `:mods` : to show modules available in scope. The names can be used for command `:showm`.
-5. `:showm` : to show contents of a module.
-6. it defaults to print out parsed AST of your typing
+1. `:dump` : to show generated llvm ir code for expression.
+2. `:def` : to define global structures like a type declaration or value definition or FFI.
+3. `:load` : to load a source file and parse it, then print raw AST structure.
+4. `:list` : list definitions available for current repl session after `:def` command.
+5. `:list module` : to show modules available in scope. The names can be used for command `:showm`.
+6. `:list source` : to print original source file names for modules.
+7. `:source` : to print original source file content for a module.
+8. `:showm` : to show contents of a module.
+9. it defaults to print out parsed AST of your typing.
 
 > You are guaranteed to get a successful running on the `main` branch.
 

bootstrap/README.md

@@ -1 +1,5 @@
-# t-lang bootstrap compiler
+# bootstrap compiler from GHC
+
+Please see ./src/Compiler/README.md for design of compiler pipeline.
+
+Documents are under construction.

bootstrap/src/Compiler/Backend/LLVM.hs → bootstrap/src/Compiler/Backend/LLVM/Definition.hs

@@ -1,9 +1,14 @@
-module Compiler.Backend.LLVM
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
+module Compiler.Backend.LLVM.Definition
   (
     globalDefine
   , globalFunction
   , externFunction
   , globalNamedType
+
+  , MonadLLVMBuilder
+  , Builder.MonadModuleBuilder
+  , Builder.MonadIRBuilder
   )
 where
 
@@ -22,6 +27,9 @@ import qualified Data.Map as Map
 
 import Compiler.Backend.LLVM.IR
 
+-- | a shorthand for ModuleBuilder and IRBuilder
+type MonadLLVMBuilder m = (Builder.MonadModuleBuilder m, Builder.MonadIRBuilder m)
+
 globalDefine :: Builder.MonadModuleBuilder m => IR.Definition -> m ()
 globalDefine def = Builder.liftModuleState $ modify \s ->
   s { Builder.builderDefs = Builder.builderDefs s `snoc` def }

bootstrap/src/Compiler/Backend/LLVM/Runtime.hs

@@ -0,0 +1,29 @@
+{- | a helper module which provides many common codegen pattern with
+-- carefully designed environment.
+--
+-}
+module Compiler.Backend.LLVM.Runtime
+  (
+    wrapMain
+  )
+where
+
+import Compiler.Backend.LLVM.Definition
+import Compiler.Backend.LLVM.IR (ensureNamedBlock, ensureBlockEndWith)
+import qualified LLVM.AST as LLVM
+import qualified LLVM.AST.Type as LLVM
+import qualified LLVM.AST.Typed as LLVM
+import qualified LLVM.AST.Constant as LLVM
+import Data.String (IsString)
+
+-- | make a main function as execution environment for generated code.
+wrapMain :: (MonadLLVMBuilder m, IsString name) => ([(name, (LLVM.Type, LLVM.Operand))] -> m LLVM.Operand) -> m LLVM.Operand
+wrapMain make = globalFunction "main" [(LLVM.i32, Just "argc"), (LLVM.ptr, Just "argv")] LLVM.i32 \case
+  [argc, argv] -> do
+    ensureNamedBlock "main.start" -- create start block
+    r <- make [("argc", (LLVM.i32, argc)), ("argv", (LLVM.ptr, argv))]
+    -- create ending block
+    LLVM.typeOf r >>= \case
+      Right (LLVM.IntegerType 32) -> ensureBlockEndWith (LLVM.Do $ LLVM.Ret (Just r) [])
+      _ -> ensureBlockEndWith . LLVM.Do $ LLVM.Ret (Just $ LLVM.ConstantOperand $ LLVM.Int 32 0) []
+  _ -> error "impossible when building wrapper for main function"

bootstrap/src/Compiler/NameChecking.hs

@@ -0,0 +1,21 @@
+{- | name checking stage
+--
+-- this module provides functionality of converting raw surface module into
+-- wellformed surface module, which can be used as inputs in the next compiler pipeline.
+--
+-- generally speaking, we will check validity of names in source code and rename them to
+-- avoid name collision.
+-}
+module Compiler.NameChecking
+  (
+    NamePrefix (..)
+  )
+where
+
+data NamePrefix
+  -- | variable in type level
+  = NameTypeVariable
+  -- | variable in term level, consumed
+  | NameTermVariable
+  -- | variable in pattern, introduced
+  | NameBindingVariable

bootstrap/src/Compiler/SourceParsing.hs

@@ -1,16 +1,29 @@
+{-# LANGUAGE RankNTypes #-}
+{- | source parsing stage
+--
+-- this module provides functionality of parsing and also some common
+-- utilities for dealing with raw surface language.
+-}
 module Compiler.SourceParsing
   (
 
+  -- ** general utility
+    prettyShowSurfaceModule
+
   -- ** parsing modules
-    loadModuleFromFile
+  , loadModuleFromFile
   , loadModuleFromText
 
   -- ** parsing items from text
   , getSurfaceExpr
   , getSurfaceType
+  , mapSurfaceDecl
 
   , getSurfaceDecl
-  , getSurfaceDecls
+  , getSurfaceDeclEof
+
+  -- ** querying item
+  , lookupSurfaceModule
 
   -- ** re-export builtin parser
   , driveParser -- ^ driver
@@ -20,32 +33,50 @@ module Compiler.SourceParsing
   )
 where
 
-import Language.Core ( ModuleSurface, TypSurface, ExprSurface, DeclSurface, OperatorStore, builtinStore, fuseModuleName, Module (_moduleHeader))
-import Compiler.Store ( HasCompilerStore, UseCompilerStore, stageSourceParsing, spSources, spFiles )
+import Language.Core ( ModuleSurface, TypSurface, ExprSurface, DeclSurface, OperatorStore, builtinStore, fuseModuleName, Module (..), Name, moduleHeader, Decls (getDecls))
+import Compiler.Store ( HasCompilerStore, UseCompilerStore, stageSourceParsing, spSources, spFiles, AccessCompilerStore )
 import Data.Text (Text)
+import Data.List (intercalate)
 import Control.Monad.IO.Class (MonadIO (liftIO))
 import Driver.Parser (driveParser, surfaceDecl, surfaceType, surfaceExpr, surfaceModule)
 
 import Language.Parser.Lexer ( reservedOp )
-import Text.Megaparsec (eof, ParseErrorBundle, MonadParsec (lookAhead), sepBy1, (<|>))
+import Text.Megaparsec (eof, ParseErrorBundle, MonadParsec (lookAhead))
 import Data.Void (Void)
 import Data.Functor ( ($>) )
-import Control.Lens ( (<&>), (%~), (^.) )
+import Control.Lens ( (<&>), (%~), _2, (^..), (^.) )
 import Capability.State ( modify, gets )
 import qualified Data.Map as Map
 import qualified Data.Text.IO as Text
+import Capability.Reader (asks)
+
+-- ** general methods for surface module
+
+-- | show basic information of a module
+prettyShowSurfaceModule :: ModuleSurface -> String
+prettyShowSurfaceModule (Module header impts decls) = intercalate "\n" (headerDoc <> imptsDoc <> declsDoc)
+  where
+    headerDoc = [show $ fuseModuleName header <> " :"]
+    imptsDoc = "imports:":"":(impts <&> show)
+    declsDoc = "definitions:":"":(getDecls decls <&> show)
+
+-- ** actions for source file
 
 loadModuleFromFile
   :: (HasCompilerStore m, MonadFail m, MonadIO m) => FilePath -> m ModuleSurface
 loadModuleFromFile path = liftIO (Text.readFile path) >>= loadModuleFromText path
 {-# INLINE loadModuleFromFile #-}
 
--- | TOOD: consider outdated files
+-- | load a module from a source file.
+--
+-- It updates compiler store.
+--
+-- TOOD: consider outdated files
 loadModuleFromText
   :: (HasCompilerStore m, MonadFail m) => String -> Text -> m ModuleSurface
 loadModuleFromText path content = do
-  sources <- gets @UseCompilerStore (^. (stageSourceParsing . spSources))
-  (m'either, _) <- driveParser builtinStore (surfaceModule (snd <$> sources) (reservedOp ";;" $> ()) eof) path content
+  sources <- gets @UseCompilerStore (^.. (stageSourceParsing . spSources . traverse . _2))
+  (m'either, _) <- driveParser builtinStore (surfaceModule sources (reservedOp ";;" $> ()) eof) path content
   m <- case m'either of
     Right m -> return m
     Left _ -> fail "" -- TOOD: complete error message
@@ -67,18 +98,32 @@ getSurfaceType ops prompt content =
   driveParser ops (surfaceType eof) prompt content
   <&> fst
 
--- | declaration may modify operator environment.
+-- | consume input till `end` and parse declaration.
 getSurfaceDecl :: Monad m
-  => OperatorStore -> String -> Text
-  -> m ( Either (ParseErrorBundle Text Void) DeclSurface
-       , OperatorStore
-       )
-getSurfaceDecl ops = driveParser ops (surfaceDecl eof)
+  => OperatorStore -> (forall e f. MonadParsec e Text f => f ()) -> String -> Text
+  -> m (Either (ParseErrorBundle Text Void) DeclSurface, OperatorStore)
+getSurfaceDecl ops end = driveParser ops (surfaceDecl (lookAhead end) <* end)
+
+-- | map surfaceDecl parser to something else. It is recommended to use parser combinator
+-- to get reasonable results.
+mapSurfaceDecl :: Monad m
+  => OperatorStore
+  -> (forall e f. MonadParsec e Text f => f ())
+  -> (forall e f. MonadParsec e Text f => f DeclSurface -> f res)
+  -> String -> Text
+  -> m (Either (ParseErrorBundle Text Void) res, OperatorStore)
+mapSurfaceDecl ops end f = driveParser ops (f $ surfaceDecl (lookAhead end) <* end)
 
-getSurfaceDecls :: Monad m
+-- | comsume whole inputs to parse declaration and abandon modified operator store.
+getSurfaceDeclEof :: Monad m
   => OperatorStore -> String -> Text
-  -> m ( Either (ParseErrorBundle Text Void) [DeclSurface]
-       , OperatorStore
-       )
-getSurfaceDecls ops = driveParser ops
-  $ surfaceDecl (lookAhead $ reservedOp ";;" $> () <|> eof) `sepBy1` reservedOp ";;"
+  -> m (Either (ParseErrorBundle Text Void) DeclSurface)
+getSurfaceDeclEof ops prompt content = driveParser ops (surfaceDecl eof) prompt content <&> fst
+
+-- ** methods available for store
+
+-- | lookup module with its canonical name
+lookupSurfaceModule :: AccessCompilerStore m => Name -> m (Maybe ModuleSurface)
+lookupSurfaceModule name =
+  asks @UseCompilerStore (^. (stageSourceParsing . spSources))
+  <&> lookup name . (traverse %~ \(_, m) -> (fuseModuleName (m ^. moduleHeader), m))

bootstrap/src/Driver/Compiler/CodeGen/LLVM.hs

@@ -7,6 +7,7 @@ module Driver.Compiler.CodeGen.LLVM
   , runBasicBlock
   , runDefinition
   , runModule
+  , runWithDefaultMain
   , withEntry
   , withEntryTop
 
@@ -33,7 +34,7 @@ import LLVM.IRBuilder.Module (ModuleBuilderT (..), MonadModuleBuilder, runModule
 import LLVM.IRBuilder.Monad (IRBuilderT (..), runIRBuilderT, MonadIRBuilder, IRBuilderState, emptyIRBuilder)
 
 import Capability.Accessors
-import Capability.Reader (HasReader, MonadReader (..))
+import Capability.Reader (HasReader, MonadReader (..), local)
 import Capability.State (HasState, MonadState (..))
 import Capability.Sink (HasSink)
 import Capability.Source (HasSource)
@@ -46,6 +47,7 @@ import Control.Monad (void)
 import Control.Monad.State (StateT (..))
 import Control.Monad.Reader (ReaderT (..))
 import GHC.Generics (Generic)
+import Compiler.Backend.LLVM.Runtime (wrapMain)
 
 data CodeGenData m name = CodeGenData
   { localval :: [(name, (LLVM.Type, Operand))]
@@ -128,6 +130,12 @@ runModule name stat m = buildModuleT name (runBasicBlock stat m)
 liftLLVM :: Monad m => LLVM m a -> CodeGenT m name a
 liftLLVM = CodeGenT . lift . lift
 
+runWithDefaultMain :: (IsString name, Monad m) =>
+  ShortByteString -> CodeGenT m name Operand -> m LLVM.Module
+runWithDefaultMain name m =
+  runModule name emptyIRBuilder . runCodeGen emptyState emptyData $
+  wrapMain \names -> local @"local" (<> names) m
+
 withEntry :: (IsString name, Monad m) => CodeGenT m name Operand -> LLVM m Operand
 withEntry m = do
   LLVM . IRBuilderT . lift
@@ -144,5 +152,21 @@ withEntry m = do
       void $ runLLVM (runCodeGen emptyState preData (start >> m >>= end))
     _ -> error "impossible in Driver.CodeGen"
 
+-- withEntry :: (IsString name, Monad m) => CodeGenT m name Operand -> LLVM m Operand
+-- withEntry m = do
+--   LLVM . IRBuilderT . lift
+--     $ LLVM.function "main" [(LLVM.i32, LLVM.ParameterName "argc"), (LLVM.ptr, LLVM.ParameterName "argv")] LLVM.i32
+--     \case
+--     [argc, argv] -> do
+--       let start = LLVM.fresh `LLVM.named` "start" >>= LLVM.emitBlockStart
+--           end a = do
+--             v <- LLVM.typeOf a
+--             case v of
+--               Right (LLVM.IntegerType _) -> LLVM.ret a
+--               _ -> LLVM.ret (LLVMC.int32 0)
+--           preData = emptyData { localval = [("argc", (LLVM.i32, argc)), ("argv", (LLVM.ptr, argv))]}
+--       void $ runLLVM (runCodeGen emptyState preData (start >> m >>= end))
+--     _ -> error "impossible in Driver.CodeGen"
+
 withEntryTop :: (Monad m, IsString name1) => CodeGenT m name1 Operand -> CodeGenT m name2 Operand
 withEntryTop m = liftLLVM (withEntry m)

bootstrap/src/Driver/Inference.hs

@@ -3,10 +3,8 @@ module Driver.Inference
   )
 where
 
--- import Tlang.Inference.Kind (NormalKind)
-import Language.Core (type (@:) (..), Kind (..))
-
 -- defaultEnv :: [NormalKind :@ Symbol]
+defaultEnv :: a
 defaultEnv = undefined
 --   [ Op "->" :@ (KindType ::> KindType ::> KindType)
 --   , Symbol "maybe" :@ (KindType ::> KindType)

bootstrap/src/Driver/Parser.hs

@@ -7,6 +7,7 @@ module Driver.Parser
 
   -- ** core driver
   , driveParser
+  , driveParserFail
 
   -- *** available parser for core driver
   , surfaceDecl
@@ -47,7 +48,7 @@ import Data.Functor ((<&>))
 import Data.Text (Text)
 import Data.Void (Void)
 
-import Text.Megaparsec (MonadParsec, ParseErrorBundle, ParsecT, runParserT, lookAhead)
+import Text.Megaparsec (MonadParsec, ParseErrorBundle, ParsecT, runParserT, lookAhead, errorBundlePretty, ShowErrorComponent)
 import Text.Megaparsec.Debug (MonadParsecDbg)
 import Control.Monad.IO.Class (MonadIO)
 
@@ -81,6 +82,21 @@ driveParser store parser prompt text =
         TermOperator t -> ([t], [])
    in runStateT (runReaderT (runParserT (runParserMonad parser) prompt text) openv) store
 
+-- | allow automatic failing for parser
+driveParserFail :: (MonadFail m, ShowErrorComponent e)
+  => OperatorStore
+  -> ParserMonad e m a
+  -> String -> Text
+  -> m (a, OperatorStore)
+driveParserFail store parser prompt text = do
+  let openv = mconcat $ store <&> \case
+        TypeOperator t -> ([], [t])
+        TermOperator t -> ([t], [])
+  (res'either , s) <- runStateT (runReaderT (runParserT (runParserMonad parser) prompt text) openv) store
+  case res'either of
+    Right a -> return (a, s)
+    Left e -> fail $ errorBundlePretty e
+
 -- | declaration
 type DeclLang e m pExpr pType expr typ = WithDecl e m
   (  Layer "define" (pType :- pExpr) (typ :- expr)

bootstrap/src/Driver/Unification.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE NoMonomorphismRestriction #-}
+{-# OPTIONS_GHC -Wno-missing-signatures #-}
 {- | ** unification driver code
 -}
 module Driver.Unification