feat: Great progress on the REPL

compiler/main/Driver/Rules.hs

@@ -382,7 +382,11 @@ rules options (Rock.Writer (Rock.Writer query)) = case query of
     case optTarget options of
       TLLVM -> do
         coreAst <- astToCore False monomorphicAST
-        let sortedAST = SortExpressions.sortASTExpressions coreAst
+
+        -- Only runs for the REPL
+        let coreAst' = SortExpressions.keepLastMainExpAndDeps coreAst
+
+        let sortedAST = SortExpressions.sortASTExpressions coreAst'
         let renamedAst       = Rename.renameAST sortedAST
             reducedAst       =
               if optLevel > O1 then
@@ -405,7 +409,11 @@ rules options (Rock.Writer (Rock.Writer query)) = case query of
 
       _ -> do
         coreAst <- astToCore (optOptimized options) monomorphicAST
-        let renamedAst       = Rename.renameAST coreAst
+
+        -- Only runs for the REPL
+        let coreAst' = SortExpressions.keepLastMainExpAndDeps coreAst
+
+        let renamedAst       = Rename.renameAST coreAst'
             reducedAst       =
               if optLevel > O1 then
                 SimplifyCalls.reduceAST renamedAst

compiler/main/Optimize/SortExpressions.hs

@@ -5,6 +5,8 @@ module Optimize.SortExpressions where
 import AST.Core
 import qualified Data.Maybe as Maybe
 import Data.Graph
+import Debug.Trace
+import Text.Show.Pretty (ppShow)
 
 
 sortASTExpressions :: AST -> AST
@@ -15,12 +17,61 @@ sortASTExpressions ast =
   in ast { aexps = sortedExps }
 
 
+-- Used for the REPL
+keepLastMainExpAndDeps :: AST -> AST
+keepLastMainExpAndDeps ast =
+  if apath ast == Just "__REPL__.mad" then
+    let Typed qt area metadata (Assignment n (Typed qt' area' metadata' (Definition params body))) =
+          last $ aexps ast
+    in  if length body > 1 then
+          let allLocalNames = Maybe.mapMaybe getExpName body
+              deps = buildDependenciesForMain 0 allLocalNames [] (init body)
+              (graph, findNode, findVertex) = graphFromEdges deps
+              (_, key, _) = last deps
+              Just lastVertex = findVertex key
+              reachedVertices = reachable graph lastVertex
+              reachedNodes = map findNode reachedVertices
+              newBody = concat $ map (\(exps, _, _) -> exps) reachedNodes
+              newBody' = filter (`elem` newBody) body
+              newBodyWithReturn = (trace ("localNames: " <> ppShow allLocalNames <> "\ndeps: " <> ppShow deps <> "\nreached: " <> ppShow reachedNodes) newBody') ++ [last body]
+              newMainFunction = Typed qt area metadata (Assignment n (Typed qt' area' metadata' (Definition params newBodyWithReturn)))
+          in  ast { aexps = init (aexps ast) ++ [newMainFunction] }
+        else
+          ast
+  else
+    ast
+
+
 buildDependenciesForAllExps :: [Exp] -> [([Exp], String, [String])]
 buildDependenciesForAllExps exps =
   let allLocalNames = Maybe.mapMaybe getExpName exps
   in  buildDependencies allLocalNames [] exps
 
 
+buildDependenciesForMain :: Int -> [String] -> [Exp] -> [Exp] -> [([Exp], String, [String])]
+buildDependenciesForMain expIndex localNames cachedExps exps = case exps of
+  e : es ->
+    case getExpName e of
+      Just n ->
+        let deps = buildDependencies' localNames n e
+        in  (cachedExps ++ [e], n, deps) : buildDependenciesForMain (expIndex + 1) localNames [] es
+
+      Nothing ->
+        let expName = "exp__" <> show expIndex
+            deps = buildDependencies' localNames expName e
+        in  (cachedExps ++ [e], expName, deps) : buildDependenciesForMain (expIndex + 1) localNames [] es
+    -- case getExpName e of
+    --   Just n ->
+    --     let deps = buildDependencies' localNames n e
+    --     in  (cachedExps ++ [e], n, deps) : buildDependencies localNames [] es
+
+    --   Nothing ->
+    --     buildDependencies localNames (cachedExps ++ [e]) es
+
+  [] ->
+    []
+
+
 buildDependencies :: [String] -> [Exp] -> [Exp] -> [([Exp], String, [String])]
 buildDependencies localNames cachedExps exps = case exps of
   e : es ->

compiler/main/Run/Repl.hs

@@ -30,10 +30,17 @@ import           System.IO.Silently
 import           System.Exit (ExitCode)
 import           Control.Exception (try)
 import           System.Process
+import qualified System.Console.Haskeline         as Haskeline
+import Control.Monad.Catch (handle)
+import GHC.IO.Exception (IOException(IOError))
+import Infer.Type
+import           Paths_madlib                   ( version )
+import           Data.Version                   ( showVersion )
+-- import qualified System.Console.Haskeline.Prefs   as HaskelinePrefs
 
 
 -- TODO: consider this lib
--- https://hackage.haskell.org/package/haskeline-0.8.1.1/docs/System-Console-Haskeline.html
+-- Look into https://github.com/judah/haskeline/issues/162
 
 type State = Driver.State CompilationError
 
@@ -57,9 +64,11 @@ options :: Options.Options
 options =
   Options.Options
     { Options.optEntrypoint = replModulePath
-    , Options.optTarget = TLLVM
+    , Options.optTarget = TNode
+    -- , Options.optTarget = TLLVM
     , Options.optRootPath = "./"
-    , Options.optOutputPath = ".repl/run"
+    , Options.optOutputPath = ".repl/"
+    -- , Options.optOutputPath = ".repl/run"
     , Options.optOptimized = False
     , Options.optPathUtils = PathUtils.defaultPathUtils
     , Options.optBundle = False
@@ -92,27 +101,12 @@ src a =
   Src.Source emptyArea Src.TargetAll a
 
 
-start :: IO ()
-start = do
-  state <- Driver.initialState
-
-  -- load initial module and fill caches for external modules like IO
-  hSilence [stdout, stderr] $ runTask state options Driver.Don'tPrune (Map.singleton replModulePath startCode) $ do
-    Rock.fetch $ Query.BuiltTarget replModulePath
-  loop state
-  return ()
-
-
 addNewCode :: String -> String -> String
 addNewCode newCode previousCode =
   let previousLines = List.init $ lines previousCode
   in  unlines $ previousLines ++ [newCode, "}"]
 
 
-read :: IO String
-read = liftIO Prelude.getLine
-
-
 addExpToAST :: Src.AST -> Src.Exp -> Src.AST
 addExpToAST ast exp =
   if Src.isTopLevelFunction exp then
@@ -161,32 +155,50 @@ addLogToLastExp ast =
         ast
 
 
+findType :: Slv.AST -> Maybe (Qual Type)
+findType ast =
+  let (Slv.Typed _ _ (Slv.Assignment n (
+          Slv.Typed _ _ (Slv.Abs _ body)
+          ))) = last $ Slv.aexps ast
+  in  if length body > 1 then
+        case last $ init body of
+          Slv.Typed _ _ (Slv.App _ (Slv.Typed qt _ _) _) ->
+            Just qt
+
+          _ ->
+            Nothing
+      else
+        Nothing
+
+
 shouldRun :: Src.AST -> Bool
 shouldRun ast =
   not (null $ Src.aexps ast) && not (Src.isTopLevelFunction (last (Src.aexps ast)))
 
 
-evalMadlibExp :: State -> String -> IO String
-evalMadlibExp state code = case parse code of
+evalMadlibCode :: State -> String -> Haskeline.InputT IO CommandResult
+evalMadlibCode state code = case parse code of
   Right parsedNewCode -> do
-    (currentAST, _, _) <- runTask state options Driver.Don'tPrune mempty $ do
+    (currentAST, _, _) <- liftIO $ runTask state options Driver.Don'tPrune mempty $ do
       Rock.fetch $ Query.ParsedAST replModulePath
     let newAST = foldl addExpToAST currentAST (Src.aexps parsedNewCode)
     let newASTWithImports = foldl addImportToAST newAST (Src.aimports parsedNewCode)
     let newASTWithTypeDecls = foldl addTypeDeclToAST newASTWithImports (Src.atypedecls parsedNewCode)
     let newASTWithLogAdded = addLogToLastExp newASTWithTypeDecls
     let newCodeWithLogAdded = Format.astToSource 80 newASTWithLogAdded []
-    ((typed, _), _, errs) <- runTask state options Driver.Don'tPrune (Map.singleton replModulePath newCodeWithLogAdded) $ do
+    ((typed, _), _, errs) <- liftIO $ runTask state options Driver.Don'tPrune (Map.singleton replModulePath newCodeWithLogAdded) $ do
       Rock.fetch $ Query.SolvedASTWithEnv replModulePath
 
-    formattedErrs <- forM errs $ simpleFormatError False
+    let maybeType = findType typed
+
+    formattedErrs <- liftIO $ forM errs $ simpleFormatError False
     if null formattedErrs then do
       -- TODO: compile & run the AST with the newly added __IO__.log call for the last exp of main
 
-      hSilence [stdout, stderr] $ runTask state options Driver.Don'tPrune mempty $ do
+      liftIO $ hSilence [stdout, stderr] $ runTask state options Driver.Don'tPrune mempty $ do
         Rock.fetch $ Query.BuiltTarget replModulePath
 
-      runResult <- try $ readProcessWithExitCode ".repl/run" [] ""
+      runResult <- liftIO $ try $ readProcessWithExitCode "node" [".repl/__REPL__.mjs"] ""
       let output = case (runResult :: Either IOError (ExitCode, String, String)) of
             Right (_, result, _) | shouldRun parsedNewCode ->
               result
@@ -196,20 +208,52 @@ evalMadlibExp state code = case parse code of
 
       -- then reset to newAST
       let newValidCode = Format.astToSource 80 newASTWithTypeDecls []
-      runTask state options Driver.Don'tPrune (Map.singleton replModulePath newValidCode) $ do
-        Rock.fetch $ Query.SolvedASTWithEnv replModulePath
+      let resetValidCode = do
+            runTask state options Driver.Don'tPrune (Map.singleton replModulePath newValidCode) $ do
+              Rock.fetch $ Query.ParsedAST replModulePath
+            return ()
 
       let output' = List.dropWhileEnd Char.isSpace output
-      return output'
+
+      if null output' then
+        return $ Continue resetValidCode
+      else
+        return $ Output output' maybeType resetValidCode
     else do
       let previousCode = Format.astToSource 80 currentAST []
       -- We need this to reset the code to the previous state
-      runTask state options Driver.Don'tPrune (Map.singleton replModulePath previousCode) $ do
+      liftIO $ runTask state options Driver.Don'tPrune (Map.singleton replModulePath previousCode) $ do
         Rock.fetch $ Query.ParsedAST replModulePath
-      return $ List.intercalate "\n" formattedErrs
+      return $ ErrorResult $ List.intercalate "\n" formattedErrs
+
+  _ ->
+    return $ ErrorResult "Grammar error"
+
+
+data CommandResult
+  = Exit
+  | CommandNotFound String
+  | Output String (Maybe (Qual Type)) (IO ())
+  | CommandResult String
+  | ErrorResult String
+  | Continue (IO ())
+
+
+evalCmd :: String -> Haskeline.InputT IO CommandResult
+evalCmd cmd = case cmd of
+  "exit" ->
+    return Exit
+
+  "help" ->
+    return $ CommandResult "help text TBD"
 
   _ ->
-    return "Grammar error"
+    return $ CommandNotFound cmd
+
+
+
+read :: Haskeline.InputT IO (Maybe String)
+read = Haskeline.getInputLine "> "
 
 
 -- should return a type other than String
@@ -219,24 +263,88 @@ evalMadlibExp state code = case parse code of
 --   | EvaluatedCode String
 --   | ImportedModule FilePath String
 --   | TypeDefined ...
-eval :: State -> String -> IO String
-eval state code = do
-  evalMadlibExp state code
+eval :: State -> String -> Haskeline.InputT IO CommandResult
+eval state code =
+  case code of
+    ':' : cmd ->
+      evalCmd cmd
 
+    _ ->
+      evalMadlibCode state code
 
-print :: String -> IO ()
-print "" = return ()
-print result = do
-  putStrLn result
 
+print :: CommandResult -> Haskeline.InputT IO ()
+print result = case result of
+  Output output maybeType _ -> do
+    let output' = color Yellow output
+    let output'' = case maybeType of
+          Just (_ :=> t) ->
+            output' <> color Grey (" :: " <> prettyPrintType True t)
+
+          _ ->
+            output'
+    liftIO $ putStrLn output''
+
+  ErrorResult err ->
+    liftIO $ putStrLn err
+
+  CommandResult toShow ->
+    liftIO $ putStrLn toShow
+
+  _ ->
+    return ()
 
-loop :: State -> IO ()
-loop state = do
-  putStr "> "
-  hFlush stdout
 
+loop :: State -> Haskeline.InputT IO ()
+loop state = do
+  -- code <- Haskeline.handleInterrupt (return (Just "")) (Haskeline.withInterrupt read)
   code <- read
-  evaluated <- eval state code
-  print evaluated
+  case code of
+    Just "" ->
+      loop state
+
+    Just c -> do
+      evaluated <- eval state c
+      print evaluated
+      case evaluated of
+        Exit ->
+          return ()
+
+        Continue postAction -> do
+          liftIO postAction
+          loop state
+
+        Output _ _ postAction -> do
+          liftIO postAction
+          loop state
+
+        _ -> do
+          loop state
 
-  loop state
+    _ ->
+      return ()
+
+
+introduction :: String
+introduction =
+  unlines
+    [ color Grey "------ " <> (color Yellow ("Madlib@" <> showVersion version)) <> color Grey " -----------------------------------"
+    , "Welcome to the repl!"
+    , color Grey "The command :help will assist you"
+    , color Grey "The command :exit will exit the REPL"
+    , color Grey "--------------------------------------------------------"
+    ]
+
+
+start :: IO ()
+start = do
+  state <- Driver.initialState
+
+  putStrLn introduction
+  -- load initial module and fill caches for external modules like IO
+  hSilence [stdout, stderr] $ liftIO $ runTask state options Driver.Don'tPrune (Map.singleton replModulePath startCode) $ do
+    Rock.fetch $ Query.BuiltTarget replModulePath
+
+  Haskeline.runInputT Haskeline.defaultSettings $ loop state
+  -- Haskeline.runInputT Haskeline.defaultSettings $ Haskeline.withInterrupt $ loop state
+  return ()