Property and unit tests success. Also cleanup.

Author: hhefesto

app/Evaluare.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE RecursiveDo #-}
-
 module Main where
 
 import Control.Comonad.Cofree (Cofree ((:<)))
@@ -66,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
@@ -150,9 +148,9 @@ 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

app/Main.hs

@@ -3,26 +3,18 @@
 module Main where
 
 import qualified Options.Applicative as O
-import qualified System.IO.Strict as Strict
-import Telomare.Eval (runMain)
 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
@@ -41,5 +33,4 @@ main = do
           <> O.progDesc "A simple but robust virtual machine" )
   topts <- O.execParser opts
   allModules :: [(String, String)] <- getAllModules
-  -- putStrLn . show $ fst <$> allModules
   runMain allModules . takeBaseName . telomareFile $ topts

src/Telomare.hs

@@ -15,7 +15,6 @@
 
 module Telomare where
 
-import Data.Functor.Classes (eq1)
 import Control.Applicative (Applicative (liftA2), liftA, liftA3)
 import Control.Comonad.Cofree (Cofree ((:<)))
 import qualified Control.Comonad.Trans.Cofree as CofreeT (CofreeF (..))
@@ -27,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))

src/Telomare/Eval.hs

@@ -22,7 +22,7 @@ import System.Process (CreateProcess (std_out), StdStream (CreatePipe),
                        createProcess, shell)
 import Telomare
 import Telomare.Optimizer (optimize)
-import Telomare.Parser (AnnotatedUPT, parseOneExprOrTopLevelDefs, parseModule)
+import Telomare.Parser (AnnotatedUPT, parseModule, parseOneExprOrTopLevelDefs)
 import Telomare.Possible (AbortExpr, abortExprToTerm4, evalA, sizeTerm,
                           term3ToUnsizedExpr)
 import Telomare.Resolver (main2Term3, process, resolveAllImports)
@@ -213,7 +213,7 @@ runMainCore modulesStrings s e =
       parsedModules = (fmap . fmap) parseModule modulesStrings
       parsedModulesErrors :: [(String, Either String [Either AnnotatedUPT (String, AnnotatedUPT)])]
       parsedModulesErrors = filter (\(moduleStr, parsed) -> case parsed of
-                                      Left _ -> True
+                                      Left _  -> True
                                       Right _ -> False)
                                    parsedModules
       flattenLeft = \case
@@ -233,15 +233,10 @@ runMainCore modulesStrings s e =
                     in error . unlines $ joinModuleError <$> moduleWithError
 
   in
-    -- do
-    --   putStrLn . show $ lookup "Prelude" modules
-    --   putStrLn "--------------------------------------------------"
-    --   putStrLn "--------------------------------------------------"
-    --   putStrLn "--------------------------------------------------"
-      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
+    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)] -> String -> IO String
 runMain_ modulesStrings s = runMainCore modulesStrings s evalLoop_
@@ -315,11 +310,6 @@ calculateRecursionLimits t3 =
       Left a  -> Left . StaticCheckError . convertAbortMessage $ a
       Right t -> pure t
 
--- resolveAllImports :: [(String, [Either AnnotatedUPT (String, AnnotatedUPT)])]
---                   -> [Either AnnotatedUPT (String, AnnotatedUPT)]
---                   -> [(String, AnnotatedUPT)]
-
-
 eval2IExpr :: [(String, [Either AnnotatedUPT (String, AnnotatedUPT)])] -> String -> Either String IExpr
 eval2IExpr extraModuleBindings str =
   first errorBundlePretty (runParser (parseOneExprOrTopLevelDefs resolved) "" str)

src/Telomare/Parser.hs

@@ -343,11 +343,6 @@ parseImportQualified = do
   qualifier <- identifier <* scn
   pure $ x :< ImportQualifiedUPF qualifier m
 
--- resolveMain :: [(String, [Either AnnotatedUPT (String, AnnotatedUPT)])] -- ^Modules: [(ModuleName, [Either Import (VariableName, BindedUPT)])]
---             -> String -- ^Module name with main
---             -> Either String AnnotatedUPT
-
-
 -- |Parse top level expressions.
 parseTopLevelWithExtraModuleBindings :: [(String, AnnotatedUPT)]
                                      -> TelomareParser AnnotatedUPT
@@ -356,17 +351,6 @@ parseTopLevelWithExtraModuleBindings lst = do
   bindingList <- scn *> many parseAssignment <* eof
   pure $ x :< LetUPF (lst <> bindingList) (fromJust $ lookup "main" bindingList)
 
-
--- -- |Parse top level expressions.
--- parseTopLevelWithExtraModuleBindings :: [(String, AnnotatedUPT)]    -- ^Extra Module Bindings
---                                      -> TelomareParser AnnotatedUPT
--- parseTopLevelWithExtraModuleBindings mb = do
---   x <- getLineColumn
---   importList' <- scn *> many (try parseImportQualified <|> try parseImport) <* scn
---   let importList = undefined -- concat $ resolveImports mb <$> importList'
---   bindingList <- scn *> many parseAssignment <* eof
---   pure $ x :< LetUPF (importList <> bindingList) (fromJust $ lookup "main" bindingList)
-
 parseDefinitions :: TelomareParser (AnnotatedUPT -> AnnotatedUPT)
 parseDefinitions = do
   x <- getLineColumn
@@ -381,10 +365,6 @@ runTelomareParser_ parser str = runTelomareParser parser str >>= print
 runTelomareParserWDebug :: Show a => TelomareParser a -> String -> IO ()
 runTelomareParserWDebug parser str = runTelomareParser (dbg "debug" parser) str >>= print
 
--- modulesAux :: [(String, [(String, AnnotatedUPT)])]
--- modulesAux = [("Prelude",[("id", DummyLoc :< LamUPF "x" (DummyLoc :< VarUPF "x")), ("id2", DummyLoc :< LamUPF "x2" (DummyLoc :< VarUPF "x2"))])]
--- parseImportOrAssignment
-
 -- |Helper function to test Telomare parsers with any result.
 runTelomareParser :: Monad m => TelomareParser a -> String -> m a
 runTelomareParser parser str =
@@ -421,18 +401,6 @@ parseImportOrAssignment = do
         Just a  -> pure $ Right a
     Just imp -> pure $ Left imp
 
-input = unlines
-  [ "import Prelude"
-  , "foo = bar"
-  , "baz = wee"
-  , "import Foo"
-  , "main = id"
-  ]
-aux = runTelomareParserWDebug (scn *> many parseImportOrAssignment <* eof) input
-
--- parseTopLevelWithExtraModuleBindings :: [(String, AnnotatedUPT)]
---                                      -> TelomareParser AnnotatedUPT
-
 parseWithPrelude :: [(String, AnnotatedUPT)]   -- ^Prelude
                  -> String                     -- ^Raw string to be parsed
                  -> Either String AnnotatedUPT -- ^Error on Left

src/Telomare/Resolver.hs

@@ -446,20 +446,6 @@ runTelomareParser2Term2 :: TelomareParser AnnotatedUPT -- ^Parser to run
 runTelomareParser2Term2 parser str =
   first errorBundlePretty (runParser parser "" str) >>= process2Term2
 
--- resolveImport :: [(String, [Either AnnotatedUPT (String, AnnotatedUPT)])]
---               -> AnnotatedUPT -- ^Import UPT ----- REMOVE!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
---               -> [Either AnnotatedUPT (String, AnnotatedUPT)] -- List with just Right
--- resolveImport modules = \case
---   (_ :< (ImportUPF var)) ->
---     case lookup var modules of
---       Nothing -> error $ "Import error from " <> var
---       Just x -> x
---   (_ :< (ImportQualifiedUPF q v)) ->
---     case lookup v modules of
---       Nothing -> error $ "Import error from " <> v
---       Just x->  (fmap . fmap . first) (\str -> q <> "." <> str) x
---   _ -> error "Expected import statement"
-
 resolveImports' :: [(String, [Either AnnotatedUPT (String, AnnotatedUPT)])]
                 -> [Either AnnotatedUPT (String, AnnotatedUPT)] -- ^Main module with both Import and Assignment
                 -> [Either AnnotatedUPT (String, AnnotatedUPT)]
@@ -472,17 +458,17 @@ resolveImports' modules xs = lefts <> rights
         (Left (_ :< (ImportUPF var))) ->
           case lookup var modules of
             Nothing -> error $ "Import error from " <> var
-            Just x -> x
+            Just x  -> x
         (Left (_ :< (ImportQualifiedUPF q v))) ->
           case lookup v modules of
             Nothing -> error $ "Import error from " <> v
-            Just x->  (fmap . fmap . first) (\str -> q <> "." <> str) x
+            Just x  -> (fmap . fmap . first) (\str -> q <> "." <> str) x
         e -> error $ "Expected import statement. Got:\n" <> show e
     rights = filter isRight xs
     isLeft (Left _) = True
-    isLeft _ = False
+    isLeft _        = False
     isRight (Right _) = True
-    isRight _ = False
+    isRight _         = False
 
 resolveAllImports' :: [(String, [Either AnnotatedUPT (String, AnnotatedUPT)])]
                    -> [Either AnnotatedUPT (String, AnnotatedUPT)]
@@ -509,7 +495,7 @@ resolveImports modules moduleName = resolveAllImports modules principal
   where
     principal = case lookup moduleName modules of
       Nothing -> error $ "resolveImports: Module " <> moduleName <> " not found"
-      Just x -> x
+      Just x  -> x
 
 resolveMain :: [(String, [Either AnnotatedUPT (String, AnnotatedUPT)])] -- ^Modules: [(ModuleName, [Either Import (VariableName, BindedUPT)])]
             -> String -- ^Module name with main
@@ -518,13 +504,10 @@ resolveMain allModules mainModule = case lookup mainModule allModules of
   Nothing -> Left $ "Module " <> mainModule <> " not found"
   Just lst -> let resolved :: [(String, AnnotatedUPT)]
                   resolved = resolveImports allModules mainModule
-                  -- resolvedPretty :: [(String, UnprocessedParsedTerm)]
-                  -- resolvedPretty = (fmap . fmap) forget resolved
                   maybeMain = lookup "main" resolved
               in case maybeMain of
                    Nothing -> Left $ "No main function found in " <> mainModule
-                   Just x -> Right $ DummyLoc :< LetUPF resolved x
-                   -- Just x -> Right $ DummyLoc :< LetUPF (trace ("!!!!!!@@@@@@@!!!!!!!! " <> (show resolvedPretty)) resolved) x
+                   Just x  -> Right $ DummyLoc :< LetUPF resolved x
 
 main2Term3 :: [(String, [Either AnnotatedUPT (String, AnnotatedUPT)])] -- ^Modules: [(ModuleName, [Either Import (VariableName, BindedUPT)])]
            -> String -- ^Module name with main

test/ResolverTests.hs

@@ -55,11 +55,14 @@ qcProps = testGroup "Property tests (QuickCheck)"
   , QC.testProperty "Check recursive imports work" $
       \() -> withMaxSuccess 16 . QC.idempotentIOProperty $ do
         modules <- generate genRecursiveImports
-        let expectedValue = "bla"
+        let expectedValue = recursiveImportsResult modules <> "\ndone"
         result <- runMain_ modules "Main"
         pure $ result === expectedValue
   ]
 
+recursiveImportsResult :: [(String, String)] -> String
+recursiveImportsResult = init . tail . drop 2 . dropWhile (/= '=') . snd . last
+
 -- Variable and Import str generator
 genName :: Gen String
 genName = do
@@ -78,7 +81,7 @@ genInteger = choose (0, 100)
 genAssignment :: Gen (String, String)
 genAssignment = do
   varName <- genName
-  value <- genInteger
+  value <- genName
   pure (varName, varName <> " = " <> show value)
 
 genImport :: Gen String
@@ -92,8 +95,8 @@ genRecursiveImports = do
   moduleNames              <- vectorOf numModules genName
   (varName, assignmentStr) <- genAssignment
   let
-    assignments = map ( "import " <> ) (tail moduleNames) <> [assignmentStr]
-    mainModule  = ("Main", "import " <> head moduleNames <> "\nmain = " <> varName)
+    assignments = fmap ( "import " <> ) (tail moduleNames) <> [assignmentStr]
+    mainModule  = ("Main", "import " <> head moduleNames <> "\nmain = \\input -> (" <> varName <> ",0)")
   pure $ mainModule : zip moduleNames assignments
 
 aux222 =
@@ -212,6 +215,9 @@ unitTests = testGroup "Unit tests"
   , testCase "test tictactoe.tel" $ do
       res <- tictactoe
       res @?= fullRunTicTacToeString
+  , testCase "test recursive imports" $ do
+      res <- runMain_ aux222 "Main"
+      res @?= "whattt\ndone"
   ]
 
 tictactoe :: IO String

test/Spec.hs

@@ -798,12 +798,6 @@ unitTestSameResult' parse a b = it ("comparing to " <> a) $ case (parse a, parse
   _ -> expectationFailure "unitTestSameResult failed parsing somewhere"
 -}
 
--- main2Term3 :: [(String, [Either AnnotatedUPT (String, AnnotatedUPT)])] -- ^Modules: [(ModuleName, [Either Import (VariableName, BindedUPT)])]
---           -> String -- ^Module name with main
---           -> Either String Term3 -- ^Error on Left
-
--- parseModule :: String -> Either String [Either AnnotatedUPT (String, AnnotatedUPT)]
-
 main = do
   preludeFile <- Strict.readFile "Prelude.tel"
 
@@ -816,7 +810,7 @@ main = do
     parseAuxModule :: String -> (String, [Either AnnotatedUPT (String, AnnotatedUPT)])
     parseAuxModule str =
       case sequence ("AuxModule", parseModule ("import Prelude\n" <> str)) of
-        Left e -> error $ show e
+        Left e    -> error $ show e
         Right pam -> pam
     parse :: String -> Either String Term3
     parse str = main2Term3 (parseAuxModule str:prelude) "AuxModule"