Merge pull request #126 from hhefesto/fix-fork-IO-testing

Fix fork io testing

app/Main.hs

@@ -1,13 +1,8 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-
 module Main where
 
-import Data.Char
 import qualified Options.Applicative as O
 import qualified System.IO.Strict as Strict
-import Telomare.Eval (compileMain, evalLoop, runMain, schemeEval)
-import Telomare.Resolver (parseMain)
-import Telomare.TypeChecker (inferType, typeCheck)
+import Telomare.Eval (runMain)
 
 data TelomareOpts = TelomareOpts
   { telomareFile :: String

src/Telomare/Eval.hs

@@ -1,37 +1,31 @@
 {-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections       #-}
 
 module Telomare.Eval where
 
 import Control.Comonad.Cofree (Cofree ((:<)), hoistCofree)
-import Control.Lens.Plated hiding (para)
-import Control.Monad.Except
-import Control.Monad.Reader (Reader, runReader)
+import Control.Lens.Plated (Plated (..), transform, transformM)
+import Control.Monad.Except (fix, runExceptT, void)
 import Control.Monad.State (State, StateT, evalState)
 import qualified Control.Monad.State as State
-import Control.Monad.Trans.Accum (AccumT)
-import qualified Control.Monad.Trans.Accum as Accum
 import Data.Bifunctor (bimap, first)
-import Data.DList (DList)
-import Data.Functor.Foldable (Base, cata, embed, para, project)
+import Data.Functor.Foldable (Base, para)
 import Data.Map (Map)
 import qualified Data.Map as Map
-import Data.Set (Set)
-import qualified Data.Set as Set
-import Data.Void
-import Debug.Trace
-import System.IO
+import Debug.Trace (trace)
+import PrettyPrint (prettyPrint)
+import System.IO (hGetContents)
 import qualified System.IO.Strict as Strict
-import System.Process
-
-import PrettyPrint
+import System.Process (CreateProcess (std_out), StdStream (CreatePipe),
+                       createProcess, shell)
 import Telomare
 import Telomare.Optimizer (optimize)
 import Telomare.Parser (AnnotatedUPT, parseOneExprOrTopLevelDefs, parsePrelude)
-import Telomare.Possible (AbortExpr, VoidF, abortExprToTerm4, evalA, sizeTerm,
+import Telomare.Possible (AbortExpr, abortExprToTerm4, evalA, sizeTerm,
                           term3ToUnsizedExpr)
 import Telomare.Resolver (parseMain, process)
-import Telomare.RunTime (hvmEval, optimizedEval, pureEval, rEval, simpleEval)
+import Telomare.RunTime (pureEval, rEval)
 import Telomare.TypeChecker (TypeCheckError (..), typeCheck)
 import Text.Megaparsec (errorBundlePretty, runParser)
 
@@ -201,18 +195,45 @@ compile staticCheck t = debugTrace ("compiling term3:\n" <> prettyPrint t)
       Right Nothing  -> Left CompileConversionError
       Left e         -> Left e
 
-runMain :: String -> String -> IO ()
-runMain preludeString s =
+-- converts between easily understood Haskell types and untyped IExprs around an iteration of a Telomare expression
+funWrap' :: (IExpr -> IExpr) -> IExpr -> Maybe (String, IExpr) -> (String, Maybe IExpr)
+funWrap' eval fun inp =
+  let iexpInp = case inp of
+        Nothing                  -> Zero
+        Just (userInp, oldState) -> Pair (s2g userInp) oldState
+  in case eval (app fun iexpInp) of
+    Zero               -> ("aborted", Nothing)
+    Pair disp newState -> (g2s disp, Just newState)
+    z                  -> ("runtime error, dumped:\n" <> show z, Nothing)
+
+funWrap :: (IExpr -> RunResult IExpr) -> IExpr -> Maybe (String, IExpr) -> IO (String, Maybe IExpr)
+funWrap eval fun inp =
+  let iexpInp = case inp of
+        Nothing                  -> Zero
+        Just (userInp, oldState) -> Pair (s2g userInp) oldState
+  in runExceptT (eval (app fun iexpInp)) >>= \case
+    Right Zero -> pure ("aborted", Nothing)
+    Right (Pair disp newState) -> pure (g2s disp, Just newState)
+    z -> pure ("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
   in
     case compileMain <$> parseMain prelude s of
-      Left e -> putStrLn $ concat ["failed to parse ", s, " ", e]
-      Right (Right g) -> evalLoop g
-      Right z -> putStrLn $ "compilation failed somehow, with result " <> show z
+      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 -> IO ()
+runMain preludeString s = runMainCore preludeString s evalLoop
 
 schemeEval :: IExpr -> IO ()
 schemeEval iexpr = do
@@ -221,42 +242,62 @@ schemeEval iexpr = do
   scheme <- hGetContents mhout
   putStrLn scheme
 
+evalLoopCore :: IExpr
+             -> (String -> String -> IO String)
+             -> String
+             -> [String]
+             -> IO String
+evalLoopCore iexpr accumFn initAcc manualInput =
+  let wrappedEval = funWrap eval iexpr
+      mainLoop :: String -> [String] -> Maybe (String, IExpr) -> IO String
+      mainLoop acc strInput s = do
+        (out, nextState) <- wrappedEval s
+        newAcc <- accumFn acc out
+        case nextState of
+          Nothing -> pure acc
+          Just Zero -> pure $ newAcc <> "\n" <> "done"
+          Just ns -> do
+            (inp, rest) <-
+              if null strInput
+              then (, []) <$> getLine
+              else pure (head strInput, tail strInput)
+            mainLoop newAcc rest $ pure (inp, ns)
+  in mainLoop initAcc manualInput Nothing
 
 evalLoop :: IExpr -> IO ()
-evalLoop iexpr =
-  let mainLoop s = do
-        result <- simpleEval $ app iexpr s
-        case result of
-          Zero -> putStrLn "aborted"
-          (Pair disp newState) -> do
-            putStrLn . g2s $ disp
-            case newState of
-              Zero -> putStrLn "done"
-              _ -> do
-                inp <- s2g <$> getLine
-                mainLoop $ Pair inp newState
-          r -> putStrLn ("runtime error, dumped " <> show r)
-  in mainLoop Zero
+evalLoop iexpr = void $ evalLoopCore iexpr printAcc "" []
+  where
+    printAcc _ out = do
+      putStrLn out
+      pure ""
+
+evalLoopWithInput :: [String] -> IExpr -> IO String
+evalLoopWithInput inputList iexpr = evalLoopCore iexpr printAcc "" inputList
+  where
+    printAcc acc out = if acc == ""
+                       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.
--- TODO: make evalLoop and evalLoop always share eval method (i.e. simpleEval, hvmEval)
 evalLoop_ :: IExpr -> IO String
-evalLoop_ iexpr =
-  let mainLoop prev s = do
-        -- result <- optimizedEval (app peExp s)
-        result <- simpleEval (app iexpr s)
-        --result <- simpleEval $ traceShowId $ app peExp s
-        case result of
-          Zero -> pure $ prev <> "\n" <> "aborted"
-          (Pair disp newState) -> do
-            let d = g2s disp
-            case newState of
-              Zero -> pure $ prev <> "\n" <> d <> "\ndone"
-              _ -> do
-                inp <- s2g <$> getLine
-                mainLoop (prev <> "\n" <> d) $ Pair inp newState
-          r -> pure ("runtime error, dumped " <> show r)
-  in mainLoop "" Zero
+evalLoop_ iexpr = evalLoopCore iexpr printAcc "" []
+  where
+    printAcc acc out = if acc == ""
+                       then pure out
+                       else pure (acc <> "\n" <> out)
 
 calculateRecursionLimits :: Term3 -> Either EvalError Term4
 calculateRecursionLimits t3 =
@@ -269,13 +310,6 @@ calculateRecursionLimits t3 =
       Left a  -> Left . StaticCheckError . convertAbortMessage $ a
       Right t -> pure t
 
-prelude :: IO [(String, AnnotatedUPT)]
-prelude = do
-  preludeString <- Strict.readFile "Prelude.tel"
-  case parsePrelude preludeString of
-    Right p -> pure p
-    Left pe -> error pe
-
 eval2IExpr :: [(String, AnnotatedUPT)] -> String -> Either String IExpr
 eval2IExpr prelude str = bimap errorBundlePretty (\x -> DummyLoc :< LetUPF prelude x) (runParser (parseOneExprOrTopLevelDefs prelude) "" str)
                            >>= process prelude

src/Telomare/Resolver.hs

@@ -31,7 +31,7 @@ import Telomare.Parser (AnnotatedUPT, TelomareParser, parseWithPrelude)
 import Text.Megaparsec (errorBundlePretty, runParser)
 
 debug :: Bool
-debug = True
+debug = False
 
 debugTrace :: String -> a -> a
 debugTrace s x = if debug then trace s x else x

test/CaseTests.hs

@@ -7,7 +7,9 @@ import Control.Comonad.Cofree (Cofree ((:<)))
 import qualified Control.Monad.State as State
 import Data.Functor.Foldable (Base, Recursive (cata))
 import PrettyPrint
+import qualified System.IO.Strict as Strict
 import Telomare
+import Telomare.Eval (runMainWithInput)
 import Telomare.Parser
 import Telomare.Resolver (pattern2UPT)
 import Test.Tasty
@@ -54,31 +56,33 @@ qcPropsCase = testGroup "Property tests on case expressions (QuickCheck)"
       \x -> withMaxSuccess 16 . QC.idempotentIOProperty $ (do
         res <- runCaseExpWithPattern caseExprStrWithPattern x
         case res of
-          "True\ndone\n" -> pure True
-          _              -> pure False)
+          "True\ndone" -> pure True
+          _            -> pure False)
   , QC.testProperty "Ignore pattern accpets any pattern" $
       \x -> withMaxSuccess 16 . QC.idempotentIOProperty $ (do
         res <- runCaseExpWithPattern caseExprStrWithPatternIgnore x
         case res of
-          "True\ndone\n" -> pure True
-          _              -> pure False)
+          "True\ndone" -> pure True
+          _            -> pure False)
   ]
 
 unitTestsCase :: TestTree
 unitTestsCase = testGroup "Unit tests on case expressions"
   [ testCase "test case with int leaves" $ do
       res <- runTelomareStr caseExprIntLeavesStr
-      "True\ndone\n" `compare` res  @?= EQ
+      res @?= "True\ndone"
   , testCase "test case with string leaves" $ do
       res <- runTelomareStr caseExprStringLeavesStr
-      "True\ndone\n" `compare` res  @?= EQ
+      res @?= "True\ndone"
   , testCase "test case with all leaves" $ do
       res <- runTelomareStr caseExprAllLeavesStr
-      "Hi, sam!\ndone\n" `compare` res  @?= EQ
+      res @?= "Hi, sam!\ndone"
   ]
 
 runTelomareStr :: String -> IO String
-runTelomareStr str = runTelomare str $ \(_,_,_,_) -> pure ()
+runTelomareStr str = do
+  preludeStr <- Strict.readFile "Prelude.tel"
+  runMainWithInput [] preludeStr str
 
 caseExprIntLeavesStr :: String
 caseExprIntLeavesStr = unlines
@@ -143,8 +147,11 @@ instance Arbitrary Pattern where
         ]
 
   shrink = \case
+    PatternVar str -> case str of
+      "" -> []
+      _  -> pure . PatternVar $ tail str
     PatternString s -> case s of
-      [] -> []
+      "" -> []
       _  -> pure . PatternString $ tail s
     PatternInt i -> case i of
       0 -> []

test/Common.hs

@@ -10,12 +10,10 @@ import Control.Comonad.Cofree (Cofree ((:<)))
 import Data.Bifunctor
 import qualified Data.Map as Map
 import System.IO
-import qualified System.IO.Strict as Strict
 import System.Posix.IO
 import System.Posix.Process
 import System.Posix.Types (ProcessID)
 import Telomare
-import Telomare.Eval (runMain)
 import Telomare.Parser
 import Telomare.Resolver
 import Telomare.TypeChecker
@@ -383,29 +381,3 @@ instance Arbitrary Term2 where
     anno :< TITEF i t e -> i : t : e : [anno :< TITEF ni nt ne | (ni, nt, ne) <- shrink (i,t,e)]
     anno :< TPairF a b -> a : b : [anno :< TPairF na nb | (na, nb) <- shrink (a,b)]
     anno :< TAppF f i -> f : i : [anno :< TAppF nf ni | (nf, ni) <- shrink (f,i)]
-
-runTelomare :: String
-            -> ((ProcessID, Handle, Handle, Handle) -> IO a)
-            -> IO String
-runTelomare str action = do
-  preludeString <- Strict.readFile "Prelude.tel"
-  (pid, hIn, hOut, hErr) <- forkWithStandardFds $ runMain preludeString str
-  a <- action (pid, hIn, hOut, hErr)
-  hGetContents hOut
-
-forkWithStandardFds :: IO () -> IO (ProcessID, Handle, Handle, Handle)
-forkWithStandardFds act = do
-    (r0, w0) <- createPipe
-    (r1, w1) <- createPipe
-    (r2, w2) <- createPipe
-    pid <- forkProcess $ do
-      -- the six closeFd's aren't strictly speaking necessary,
-      -- but they're good hygiene
-      closeFd w0 >> dupTo r0 stdInput
-      closeFd r1 >> dupTo w1 stdOutput
-      closeFd r2 >> dupTo w2 stdError
-      act
-    hIn  <- closeFd r0 >> fdToHandle w0
-    hOut <- closeFd w1 >> fdToHandle r1
-    hErr <- closeFd w2 >> fdToHandle r2
-    pure (pid, hIn, hOut, hErr)

test/ResolverTests.hs

@@ -135,10 +135,10 @@ unitTests = testGroup "Unit tests"
      res1 @?= res2
   , testCase "Ad hoc user defined types success" $ do
       res <- testUserDefAdHocTypes userDefAdHocTypesSuccess
-      res @?= "\a\ndone\n"
+      res @?= "\a\ndone"
   , testCase "Ad hoc user defined types failure" $ do
       res <- testUserDefAdHocTypes userDefAdHocTypesFailure
-      res @?= "MyInt must not be 0\ndone\n"
+      res @?= "MyInt must not be 0\ndone"
   , testCase "test automatic open close lambda" $ do
       res <- runTelomareParser (parseLambda <* scn <* eof) "\\x -> \\y -> (x, y)"
       (forget <$> validateVariables [] res) @?= Right closedLambdaPair
@@ -162,25 +162,16 @@ unitTests = testGroup "Unit tests"
       (forget <$> validateVariables [] res) @?= Right expr2
   , testCase "test tictactoe.tel" $ do
       res <- tictactoe
-      fullRunTicTacToeString @?= res
+      res @?= fullRunTicTacToeString
   ]
 
 tictactoe :: IO String
 tictactoe = do
-  telomareString <- Strict.readFile "tictactoe.tel"
-  runTelomare telomareString $ \(pid, hIn, hOut, hErr) -> do
-      hPutStrLn hIn "1"
-      hFlush hIn
-      hPutStrLn hIn "9"
-      hFlush hIn
-      hPutStrLn hIn "2"
-      hFlush hIn
-      hPutStrLn hIn "8"
-      hFlush hIn
-      hPutStrLn hIn "3"
-      hFlush hIn
-
-fullRunTicTacToeString = unlines
+  telStr <- Strict.readFile "tictactoe.tel"
+  preludeStr <- Strict.readFile "Prelude.tel"
+  runMainWithInput ["1", "9", "2", "8", "3"] preludeStr telStr
+
+fullRunTicTacToeString = init . unlines $
   [ "1|2|3"
   , "-+-+-"
   , "4|5|6"
@@ -265,8 +256,7 @@ closedLambdaPair = TLam (Closed "x") (TLam (Open "y") (TPair (TVar "x") (TVar "y
 testUserDefAdHocTypes :: String -> IO String
 testUserDefAdHocTypes input = do
   preludeString <- Strict.readFile "Prelude.tel"
-  (_, _, hOut, _) <- forkWithStandardFds $ runMain preludeString input
-  hGetContents hOut
+  runMain_ preludeString input
 
 userDefAdHocTypesSuccess = unlines
   [ "MyInt = let wrapper = \\h -> ( \\i -> if not i"