Merge pull request #134 from hhefesto/modules-2

Modules

Author: sfultong

app/Evaluare.hs

@@ -20,7 +20,7 @@ import qualified System.IO.Strict as Strict
 import qualified Telomare as Tel
 import Telomare (IExpr (..), IExprF (..))
 import qualified Telomare.Eval as TE
-import Telomare.Parser (AnnotatedUPT, parsePrelude)
+import Telomare.Parser (AnnotatedUPT, parseModule)
 import Text.Read (readMaybe)
 
 type VtyExample t m =
@@ -64,7 +64,7 @@ node n0 = do
     tile ( fixed . pure . (+1) . T.length . _node_label $ n0) $ do
       grout flex . text . pure . _node_label $ n0
       pure ()
-    value :: Dynamic t Bool <- tile (fixed 4) $ checkbox def $ _node_selected n0
+    value :: Dynamic t Bool <- tile (fixed 4) . checkbox def $ _node_selected n0
     pure $ NodeOutput
       { _nodeOutput_node = Node (_node_label n0) (_node_eval n0) <$> value
       , _nodeOutput_expand = updated value
@@ -148,26 +148,29 @@ nodify = removeExtraNumbers . fmap go . allNodes 0 where
            -> Cofree IExprF (Int, IExpr)
            -> [(Int, Cofree IExprF (Int, IExpr))]
   allNodes i = \case
-    x@(_ :< ZeroF) -> (i, x) : []
-    x@(_ :< EnvF) -> (i, x) : []
-    x@(_ :< TraceF) -> (i, x) : []
+    x@(_ :< ZeroF) -> [(i, x)]
+    x@(_ :< EnvF) -> [(i, x)]
+    x@(_ :< TraceF) -> [(i, x)]
     x@(_ :< (SetEnvF a)) -> (i, x) : allNodes (i + 1) a
     x@(_ :< (DeferF a)) -> (i, x) : allNodes (i + 1) a
     x@(_ :< (PLeftF a)) -> (i, x) : allNodes (i + 1) a
     x@(_ :< (PRightF a)) -> (i, x) : allNodes (i + 1) a
     x@(_ :< (PairF a b)) -> (i, x) : allNodes (i + 1) a <> allNodes (i + 1) b
     x@(_ :< (GateF a b)) -> (i, x) : allNodes (i + 1) a <> allNodes (i + 1) b
 
-loadFiles :: [String] -> IO [(String, AnnotatedUPT)]
-loadFiles filenames = do
-  filesStrings <- mapM Strict.readFile filenames
-  case parsePrelude . unlines $ filesStrings of
-    Right p -> pure p
+
+-- parseModule :: String -> Either String [Either AnnotatedUPT (String, AnnotatedUPT)]
+-- TODO: Load modules qualifed
+loadModules :: [String] -> IO [(String, [Either AnnotatedUPT (String, AnnotatedUPT)])]
+loadModules filenames = do
+  filesStrings :: [String] <- mapM Strict.readFile filenames
+  case sequence $ parseModule <$> filesStrings of
+    Right p -> pure $ zip filesStrings p
     Left pe -> error pe
 
 main :: IO ()
 main = do
-  prelude :: [(String, AnnotatedUPT)] <- getArgs >>= loadFiles
+  modules :: [(String, [Either AnnotatedUPT (String, AnnotatedUPT)])] <- getArgs >>= loadModules
   let go :: Text -> IO ()
       go textErr =
         mainWidget $ initManager_ $ do
@@ -191,7 +194,7 @@ main = do
             rec
               eEitherIExpr :: Event t (Either String IExpr) <- grout flex $ col $ do
                 telomareTextInput :: TextInput t <- grout flex textBox
-                pure . updated $ TE.eval2IExpr prelude . T.unpack <$> _textInput_value telomareTextInput
+                pure . updated $ TE.eval2IExpr modules . T.unpack <$> _textInput_value telomareTextInput
               grout (fixed 2) . col . text $ ""
               let -- telomareNodes :: Event t (Either String [Node])
                   telomareNodes = fmap (nodify . TE.tagIExprWithEval) <$> eEitherIExpr

app/Main.hs

@@ -1,30 +1,36 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
 module Main where
 
 import qualified Options.Applicative as O
+import System.Directory (listDirectory)
+import System.FilePath (takeBaseName, takeExtension)
 import qualified System.IO.Strict as Strict
 import Telomare.Eval (runMain)
 
-data TelomareOpts = TelomareOpts
-  { telomareFile :: String
-  , preludeFile  :: String
-  } deriving Show
+newtype TelomareOpts
+  = TelomareOpts {telomareFile :: String}
+  deriving Show
 
 telomareOpts :: O.Parser TelomareOpts
 telomareOpts = TelomareOpts
   <$> O.argument O.str (O.metavar "TELOMARE-FILE")
-  <*> O.strOption
-      ( O.long "prelude"
-        <> O.metavar "PRELUDE-FILE"
-        <> O.showDefault
-        <> O.value "./Prelude.tel"
-        <> O.short 'p'
-        <> O.help "Telomare prelude file" )
+
+getAllModules :: IO [(String, String)]
+getAllModules = do
+  allEntries <- listDirectory "."
+  let telFiles = filter (\f -> takeExtension f == ".tel") allEntries
+      readTelFile :: FilePath -> IO (String, String)
+      readTelFile file = do
+          content <- readFile file
+          return (takeBaseName file, content)
+  mapM readTelFile telFiles
 
 main :: IO ()
 main = do
   let opts = O.info (telomareOpts O.<**> O.helper)
         ( O.fullDesc
           <> O.progDesc "A simple but robust virtual machine" )
   topts <- O.execParser opts
-  preludeString <- Strict.readFile $ preludeFile topts
-  Strict.readFile (telomareFile topts) >>= runMain preludeString
+  allModules :: [(String, String)] <- getAllModules
+  runMain allModules . takeBaseName . telomareFile $ topts

src/Telomare.hs

@@ -26,7 +26,7 @@ import qualified Control.Monad.State as State
 import Data.Bool (bool)
 import Data.Char (chr, ord)
 import Data.Eq.Deriving (deriveEq1)
-import Data.Functor.Classes (Eq1 (..), Eq2 (..), Show1 (..), Show2 (..))
+import Data.Functor.Classes (Eq1 (..), Eq2 (..), Show1 (..), Show2 (..), eq1)
 import Data.Functor.Foldable (Base, Corecursive (embed),
                               Recursive (cata, project))
 import Data.Functor.Foldable.TH (MakeBaseFunctor (makeBaseFunctor))
@@ -973,10 +973,58 @@ data UnprocessedParsedTerm
   | CheckUP UnprocessedParsedTerm UnprocessedParsedTerm
   | HashUP UnprocessedParsedTerm -- ^ On ad hoc user defined types, this term will be substitued to a unique Int.
   | CaseUP UnprocessedParsedTerm [(Pattern, UnprocessedParsedTerm)]
+  -- TODO: check if adding this doesn't create partial functions
+  | ImportQualifiedUP String String
+  | ImportUP String
   deriving (Eq, Ord, Show)
 makeBaseFunctor ''UnprocessedParsedTerm -- Functorial version UnprocessedParsedTerm
 makePrisms ''UnprocessedParsedTerm
 
+instance Eq a => Eq (UnprocessedParsedTermF a) where
+  (==) = eq1
+
+instance Eq1 UnprocessedParsedTermF where
+  liftEq eq (VarUPF s1) (VarUPF s2) = s1 == s2
+  liftEq eq (ITEUPF c1 t1 e1) (ITEUPF c2 t2 e2) =
+    eq c1 c2 && eq t1 t2 && eq e1 e2
+  liftEq eq (LetUPF binds1 body1) (LetUPF binds2 body2) =
+    liftEq (\(s1, t1) (s2, t2) -> s1 == s2 && eq t1 t2) binds1 binds2 && eq body1 body2
+  liftEq eq (ListUPF items1) (ListUPF items2) =
+    liftEq eq items1 items2
+  liftEq eq (IntUPF n1) (IntUPF n2) =
+    n1 == n2
+  liftEq eq (StringUPF s1) (StringUPF s2) =
+    s1 == s2
+  liftEq eq (PairUPF a1 b1) (PairUPF a2 b2) =
+    eq a1 a2 && eq b1 b2
+  liftEq eq (AppUPF f1 x1) (AppUPF f2 x2) =
+    eq f1 f2 && eq x1 x2
+  liftEq eq (LamUPF var1 body1) (LamUPF var2 body2) =
+    var1 == var2 && eq body1 body2
+  liftEq eq (ChurchUPF n1) (ChurchUPF n2) =
+    n1 == n2
+  liftEq eq (UnsizedRecursionUPF a1 b1 c1) (UnsizedRecursionUPF a2 b2 c2) =
+    eq a1 a2 && eq b1 b2 && eq c1 c2
+  liftEq eq (LeftUPF x1) (LeftUPF x2) =
+    eq x1 x2
+  liftEq eq (RightUPF x1) (RightUPF x2) =
+    eq x1 x2
+  liftEq eq (TraceUPF x1) (TraceUPF x2) =
+    eq x1 x2
+  liftEq eq (CheckUPF a1 b1) (CheckUPF a2 b2) =
+    eq a1 a2 && eq b1 b2
+  liftEq eq (HashUPF x1) (HashUPF x2) =
+    eq x1 x2
+  liftEq eq (CaseUPF scrutinee1 patterns1) (CaseUPF scrutinee2 patterns2) =
+    eq scrutinee1 scrutinee2 &&
+    liftEq (\(pat1, expr1) (pat2, expr2) -> pat1 == pat2 && eq expr1 expr2) patterns1 patterns2
+  liftEq eq (ImportQualifiedUPF mod1 alias1) (ImportQualifiedUPF mod2 alias2) =
+    mod1 == mod2 && alias1 == alias2
+  liftEq eq (ImportUPF mod1) (ImportUPF mod2) =
+    mod1 == mod2
+  liftEq _ _ _ = False
+
+
 instance (Show a) => Show (UnprocessedParsedTermF a) where
   show (VarUPF s) = "VarUPF " <> show s
   show (ITEUPF c t e) = "ITEUPF " <> show c <> " " <> show t <> " " <> show e
@@ -998,6 +1046,8 @@ instance (Show a) => Show (UnprocessedParsedTermF a) where
 
 instance Show1 UnprocessedParsedTermF where
   liftShowsPrec showsPrecFunc showList d term = case term of
+    ImportQualifiedUPF s1 s2 -> showString "ImportQualifedUPF " . shows s1 . showString " " . shows s2
+    ImportUPF s -> showString "ImportUPF " . shows s
     VarUPF s -> showString "VarUPF " . shows s
     ITEUPF c t e -> showString "ITEUPF " . showsPrecFunc 11 c . showChar ' '
                     . showsPrecFunc 11 t . showChar ' ' . showsPrecFunc 11 e

src/Telomare/Eval.hs

@@ -22,10 +22,10 @@ import System.Process (CreateProcess (std_out), StdStream (CreatePipe),
                        createProcess, shell)
 import Telomare
 import Telomare.Optimizer (optimize)
-import Telomare.Parser (AnnotatedUPT, parseOneExprOrTopLevelDefs, parsePrelude)
+import Telomare.Parser (AnnotatedUPT, parseModule, parseOneExprOrTopLevelDefs)
 import Telomare.Possible (AbortExpr, abortExprToTerm4, evalA, sizeTerm,
                           term3ToUnsizedExpr)
-import Telomare.Resolver (parseMain, process)
+import Telomare.Resolver (main2Term3, process, resolveAllImports)
 import Telomare.RunTime (pureEval, rEval)
 import Telomare.TypeChecker (TypeCheckError (..), typeCheck)
 import Text.Megaparsec (errorBundlePretty, runParser)
@@ -207,24 +207,45 @@ funWrap eval fun inp =
     Pair disp newState -> (g2s disp, Just newState)
     z                  -> ("runtime error, dumped:\n" <> show z, Nothing)
 
-runMainCore :: String -> String -> (IExpr -> IO a) -> IO a
-runMainCore preludeString s e =
-  let prelude :: [(String, AnnotatedUPT)]
-      prelude =
-        case parsePrelude preludeString of
-          Right p -> p
-          Left pe -> error pe
+runMainCore :: [(String, String)] -> String -> (IExpr -> IO a) -> IO a
+runMainCore modulesStrings s e =
+  let parsedModules :: [(String, Either String [Either AnnotatedUPT (String, AnnotatedUPT)])]
+      parsedModules = (fmap . fmap) parseModule modulesStrings
+      parsedModulesErrors :: [(String, Either String [Either AnnotatedUPT (String, AnnotatedUPT)])]
+      parsedModulesErrors = filter (\(moduleStr, parsed) -> case parsed of
+                                      Left _  -> True
+                                      Right _ -> False)
+                                   parsedModules
+      flattenLeft = \case
+        Left a -> a
+        Right a -> error "flattenLeft error: got a Right when it should be Left"
+      flattenRight = \case
+        Right a -> a
+        Left a -> error "flattenRight error: got a Left when it should be Right"
+      modules :: [(String, [Either AnnotatedUPT (String, AnnotatedUPT)])]
+      modules =
+        case parsedModulesErrors of
+          [] -> (fmap . fmap) flattenRight parsedModules
+          errors -> let moduleWithError :: [(String, String)]
+                        moduleWithError = (fmap . fmap) flattenLeft parsedModulesErrors
+                        joinModuleError :: (String, String) -> String
+                        joinModuleError (moduleName, errorStr) = "Error in module " <> moduleName <> ":\n" <> errorStr
+                    in error . unlines $ joinModuleError <$> moduleWithError
+
   in
-    case compileMain <$> parseMain prelude s of
+    case compileMain <$> main2Term3 modules s of
       Left e -> error $ concat ["failed to parse ", s, " ", e]
       Right (Right g) -> e g
       Right z -> error $ "compilation failed somehow, with result " <> show z
 
-runMain_ :: String -> String -> IO String
-runMain_ preludeString s = runMainCore preludeString s evalLoop_
+runMain_ :: [(String, String)] -> String -> IO String
+runMain_ modulesStrings s = runMainCore modulesStrings s evalLoop_
+
+runMain :: [(String, String)] -> String -> IO ()
+runMain modulesStrings s = runMainCore modulesStrings s evalLoop
 
-runMain :: String -> String -> IO ()
-runMain preludeString s = runMainCore preludeString s evalLoop
+runMainWithInput :: [String] -> [(String, String)] -> String -> IO String
+runMainWithInput inputList modulesStrings s = runMainCore modulesStrings s (evalLoopWithInput inputList)
 
 schemeEval :: IExpr -> IO ()
 schemeEval iexpr = do
@@ -270,19 +291,6 @@ evalLoopWithInput inputList iexpr = evalLoopCore iexpr printAcc "" inputList
                        then pure out
                        else pure (acc <> "\n" <> out)
 
-runMainWithInput :: [String] -> String -> String -> IO String
-runMainWithInput inputList preludeString s =
-  let prelude :: [(String, AnnotatedUPT)]
-      prelude =
-        case parsePrelude preludeString of
-          Right p -> p
-          Left pe -> error pe
-  in
-    case compileMain <$> parseMain prelude s of
-      Left e -> pure $ concat ["failed to parse ", s, " ", e]
-      Right (Right g) -> evalLoopWithInput inputList g
-      Right z -> pure $ "compilation failed somehow, with result " <> show z
-
 -- |Same as `evalLoop`, but keeping what was displayed.
 evalLoop_ :: IExpr -> IO String
 evalLoop_ iexpr = evalLoopCore iexpr printAcc "" []
@@ -302,10 +310,14 @@ calculateRecursionLimits t3 =
       Left a  -> Left . StaticCheckError . convertAbortMessage $ a
       Right t -> pure t
 
-eval2IExpr :: [(String, AnnotatedUPT)] -> String -> Either String IExpr
-eval2IExpr prelude str = bimap errorBundlePretty (\x -> DummyLoc :< LetUPF prelude x) (runParser (parseOneExprOrTopLevelDefs prelude) "" str)
-                           >>= process
-                           >>= first show . compileUnitTest
+eval2IExpr :: [(String, [Either AnnotatedUPT (String, AnnotatedUPT)])] -> String -> Either String IExpr
+eval2IExpr extraModuleBindings str =
+  first errorBundlePretty (runParser (parseOneExprOrTopLevelDefs resolved) "" str)
+  >>= process
+  >>= first show . compileUnitTest
+    where
+      aux = (\str -> Left (DummyLoc :< ImportQualifiedUPF str str)) . fst <$> extraModuleBindings
+      resolved = resolveAllImports extraModuleBindings aux
 
 tagIExprWithEval :: IExpr -> Cofree IExprF (Int, IExpr)
 tagIExprWithEval iexpr = evalState (para alg iexpr) 0 where

src/Telomare/Parser.hs

@@ -98,14 +98,14 @@ reserved w = (lexeme . try) (string w *> notFollowedBy alphaNumChar)
 
 -- |List of reserved words
 rws :: [String]
-rws = ["let", "in", "if", "then", "else", "case", "of" ]
+rws = ["let", "in", "if", "then", "else", "case", "of", "import"]
 
 -- |Variable identifiers can consist of alphanumeric characters, underscore,
 -- and must start with an English alphabet letter
 identifier :: TelomareParser String
 identifier = lexeme . try $ p >>= check
   where
-    p = (:) <$> letterChar <*> many (alphaNumChar <|> char '_' <?> "variable")
+    p = (:) <$> letterChar <*> many (alphaNumChar <|> char '_' <|> char '.' <?> "variable")
     check x = if x `elem` rws
               then fail ("keyword " <> (show x <> " cannot be an identifier"))
               else pure x
@@ -324,12 +324,29 @@ parseAssignment = do
 
 -- |Parse top level expressions.
 parseTopLevel :: TelomareParser AnnotatedUPT
-parseTopLevel = parseTopLevelWithPrelude []
+parseTopLevel = parseTopLevelWithExtraModuleBindings []
+
+parseImport :: TelomareParser AnnotatedUPT
+parseImport = do
+  x <- getLineColumn
+  reserved "import" <* scn
+  var <- identifier <* scn
+  pure $ x :< ImportUPF var
+
+parseImportQualified :: TelomareParser AnnotatedUPT
+parseImportQualified = do
+  x <- getLineColumn
+  reserved "import" <* scn
+  reserved "qualified" <* scn
+  m <- identifier <* scn
+  reserved "as" <* scn
+  qualifier <- identifier <* scn
+  pure $ x :< ImportQualifiedUPF qualifier m
 
 -- |Parse top level expressions.
-parseTopLevelWithPrelude :: [(String, AnnotatedUPT)]    -- ^Prelude
-                         -> TelomareParser AnnotatedUPT
-parseTopLevelWithPrelude lst = do
+parseTopLevelWithExtraModuleBindings :: [(String, AnnotatedUPT)]
+                                     -> TelomareParser AnnotatedUPT
+parseTopLevelWithExtraModuleBindings lst = do
   x <- getLineColumn
   bindingList <- scn *> many parseAssignment <* eof
   pure $ x :< LetUPF (lst <> bindingList) (fromJust $ lookup "main" bindingList)
@@ -372,15 +389,31 @@ parsePrelude :: String -> Either String [(String, AnnotatedUPT)]
 parsePrelude str = let result = runParser (scn *> many parseAssignment <* eof) "" str
                     in first errorBundlePretty result
 
--- |Parse either a single expression or top level definitions defaulting to the `main` definition.
---  This function is useful and was made for telomare-evaluare
-parseOneExprOrTopLevelDefs :: [(String, AnnotatedUPT)] -> TelomareParser AnnotatedUPT
-parseOneExprOrTopLevelDefs prelude = choice $ try <$> [ parseTopLevelWithPrelude prelude
-                                                      , parseLongExpr
-                                                      ]
+parseImportOrAssignment :: TelomareParser (Either AnnotatedUPT (String, AnnotatedUPT))
+parseImportOrAssignment = do
+  x <- getLineColumn
+  maybeImport <- optional $ scn *> (try parseImportQualified <|> try parseImport) <* scn
+  case maybeImport of
+    Nothing -> do
+      maybeAssignment <- optional $ scn *> try parseAssignment <* scn
+      case maybeAssignment of
+        Nothing -> fail "Expected either an import statement or an assignment"
+        Just a  -> pure $ Right a
+    Just imp -> pure $ Left imp
 
--- |Parse with specified prelude
 parseWithPrelude :: [(String, AnnotatedUPT)]   -- ^Prelude
                  -> String                     -- ^Raw string to be parsed
                  -> Either String AnnotatedUPT -- ^Error on Left
-parseWithPrelude prelude str = first errorBundlePretty $ runParser (parseTopLevelWithPrelude prelude) "" str
+parseWithPrelude prelude str = first errorBundlePretty $ runParser (parseTopLevelWithExtraModuleBindings prelude) "" str
+
+parseModule :: String -> Either String [Either AnnotatedUPT (String, AnnotatedUPT)]
+parseModule str = let result = runParser (scn *> many parseImportOrAssignment <* eof) "" str
+                  in first errorBundlePretty result
+
+-- |Parse either a single expression or top level definitions defaulting to the `main` definition.
+--  This function was made for telomare-evaluare
+parseOneExprOrTopLevelDefs :: [(String, AnnotatedUPT)] -> TelomareParser AnnotatedUPT
+parseOneExprOrTopLevelDefs extraModuleBindings =
+  choice $ try <$> [ parseTopLevelWithExtraModuleBindings extraModuleBindings
+                   , parseLongExpr
+                   ]