Merge pull request #127 from hhefesto/eval-sans-io-and-either

Make TelomareLike's eval not use IO nor ExceptT

src/Telomare.hs

@@ -362,14 +362,14 @@ instance Show RunTimeError where
   show (GenericRunTimeError s i) = "Generic Runtime Error: " <> s <> " -- " <> show i
   show (ResultConversionError s) = "Couldn't convert runtime result to IExpr: " <> s
 
-type RunResult = ExceptT RunTimeError IO
+-- type RunResult = ExceptT RunTimeError IO
 
 class TelomareLike a where
   fromTelomare :: IExpr -> a
   toTelomare :: a -> Maybe IExpr
 
 class TelomareLike a => AbstractRunTime a where
-  eval :: a -> RunResult a
+  eval :: a -> a
 
 rootFrag :: Map FragIndex a -> a
 rootFrag = (Map.! FragIndex 0)

src/Telomare/Eval.hs

@@ -91,23 +91,23 @@ annotateEnv (PLeft x) = LeftP <$> annotateEnv x
 annotateEnv (PRight x) = RightP <$> annotateEnv x
 annotateEnv Trace = (False, TraceP)
 
-fromFullEnv :: Applicative a => (ExpP -> a IExpr) -> ExpP -> a IExpr
-fromFullEnv _ ZeroP         = pure Zero
-fromFullEnv f (PairP a b)   = Pair <$> f a <*> f b
-fromFullEnv _ VarP          = pure Env
-fromFullEnv f (SetEnvP x _) = SetEnv <$> f x
-fromFullEnv f (DeferP x)    = Defer <$> f x
-fromFullEnv f (GateP a b)   = Gate <$> f a <*> f b
-fromFullEnv f (LeftP x)     = PLeft <$> f x
-fromFullEnv f (RightP x)    = PRight <$> f x
-fromFullEnv _ TraceP        = pure Trace
+fromFullEnv :: (ExpP -> IExpr) -> ExpP -> IExpr
+fromFullEnv _ ZeroP         = Zero
+fromFullEnv f (PairP a b)   = Pair (f a) (f b)
+fromFullEnv _ VarP          = Env
+fromFullEnv f (SetEnvP x _) = SetEnv (f x)
+fromFullEnv f (DeferP x)    = Defer (f x)
+fromFullEnv f (GateP a b)   = Gate (f a) (f b)
+fromFullEnv f (LeftP x)     = PLeft (f x)
+fromFullEnv f (RightP x)    = PRight (f x)
+fromFullEnv _ TraceP        = Trace
 
 instance TelomareLike ExpP where
   fromTelomare = snd . annotateEnv
-  toTelomare = fix fromFullEnv
+  toTelomare = pure . fix fromFullEnv
 
-partiallyEvaluate :: ExpP -> Either RunTimeError IExpr
-partiallyEvaluate se@(SetEnvP _ True) = Defer <$> (fix fromFullEnv se >>= pureEval . optimize)
+partiallyEvaluate :: ExpP -> IExpr
+partiallyEvaluate se@(SetEnvP _ True) = Defer (pureEval . optimize $ fix fromFullEnv se)
 partiallyEvaluate x = fromFullEnv partiallyEvaluate x
 
 convertPT :: (UnsizedRecursionToken -> Int) -> Term3 -> Term4
@@ -196,8 +196,8 @@ compile staticCheck t = debugTrace ("compiling term3:\n" <> prettyPrint t)
       Left e         -> Left e
 
 -- 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 =
+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
@@ -206,16 +206,6 @@ funWrap' eval fun inp =
     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)]
@@ -248,10 +238,11 @@ evalLoopCore :: IExpr
              -> [String]
              -> IO String
 evalLoopCore iexpr accumFn initAcc manualInput =
-  let wrappedEval = funWrap eval iexpr
+  let wrappedEval :: Maybe (String, IExpr) -> (String, Maybe IExpr)
+      wrappedEval = funWrap eval iexpr
       mainLoop :: String -> [String] -> Maybe (String, IExpr) -> IO String
       mainLoop acc strInput s = do
-        (out, nextState) <- wrappedEval s
+        let (out, nextState) = wrappedEval s
         newAcc <- accumFn acc out
         case nextState of
           Nothing -> pure acc
@@ -315,7 +306,7 @@ eval2IExpr prelude str = bimap errorBundlePretty (\x -> DummyLoc :< LetUPF prelu
                            >>= process prelude
                            >>= first show . compileUnitTest
 
-tagIExprWithEval :: IExpr -> Cofree IExprF (Int, Either RunTimeError IExpr)
+tagIExprWithEval :: IExpr -> Cofree IExprF (Int, IExpr)
 tagIExprWithEval iexpr = evalState (para alg iexpr) 0 where
   statePlus1 :: State Int Int
   statePlus1 = do
@@ -324,9 +315,9 @@ tagIExprWithEval iexpr = evalState (para alg iexpr) 0 where
       pure i
   alg :: Base IExpr
               ( IExpr
-              , State Int (Cofree IExprF (Int, Either RunTimeError IExpr))
+              , State Int (Cofree IExprF (Int, IExpr))
               )
-      -> State Int (Cofree IExprF (Int, Either RunTimeError IExpr))
+      -> State Int (Cofree IExprF (Int, IExpr))
   alg = \case
     ZeroF -> do
       i <- statePlus1

src/Telomare/RunTime.hs

@@ -20,10 +20,7 @@ import PrettyPrint (PrettyIExpr (PrettyIExpr), showNExprs)
 import System.IO (hGetContents)
 import System.Process (CreateProcess (std_out), StdStream (CreatePipe),
                        createProcess, shell)
-import Telomare (AbstractRunTime (eval), DataType (..), FragIndex (FragIndex),
-                 IExpr (..), IExprF (..), RunResult, RunTimeError (..),
-                 TelomareLike (fromTelomare, toTelomare))
-
+import Telomare
 import Text.Read (readMaybe)
 
 debug :: Bool
@@ -37,91 +34,89 @@ cPlus :: ((a -> a) -> a -> a) -> ((a -> a) -> a -> a) -> (a -> a) -> a -> a
 -- cPlus m n f x = m f (n f x)
 cPlus m n f = m f . n f
 
-nEval :: NExprs -> RunResult NExpr
+nEval :: NExprs -> NExpr
 nEval (NExprs m) =
-  let eval :: NExpr -> NExpr -> RunResult NExpr
+  let eval :: NExpr -> NExpr -> NExpr
       eval env frag = let recur = eval env in case frag of
-        (NPair a b) -> NPair <$> recur a <*> recur b
-        NEnv -> pure env
-        (NLeft x) -> recur x >>= \case
-          (NPair l _) -> pure l
-          NZero       -> pure NZero
-          z           -> error ("nleft on " <> show z <> (" before " <> show x))
-        (NRight x) -> recur x >>= \case
-          (NPair _ r) -> pure r
-          NZero       -> pure NZero
+        (NPair a b) -> NPair (recur a) (recur b)
+        NEnv -> env
+        (NLeft x) -> case recur x of
+          (NPair l _) -> l
+          NZero       -> NZero
+          z           -> error ("nEval: nleft on " <> show z <> (" before " <> show x))
+        (NRight x) -> case recur x of
+          (NPair _ r) -> r
+          NZero       -> NZero
           z           -> error ("nright on " <> show z)
         (NDefer ind) -> case Map.lookup ind m of
-          (Just x) -> pure x
-          _ -> throwError $ GenericRunTimeError ("nEval bad index for function: " <> show ind) Zero
-        NTrace -> pure $ trace (show env) env
-        (NSetEnv x) -> recur x >>= \case
+          (Just x) -> x
+          _ -> error . show $ GenericRunTimeError ("nEval bad index for function: " <> show ind) Zero
+        NTrace -> trace (show env) env
+        (NSetEnv x) -> case recur x of
           (NPair c i) -> case c of
             NGate a b -> case i of
               NZero -> recur a
               _     -> recur b
             _ -> eval i c
-          z -> error ("nEval nsetenv - not pair - " <> show z)
+          z -> error ("nEval: nsetenv - not pair - " <> show z)
         (NApp c i) -> do
-          nc <- recur c
-          ni <- recur i
-          let appl (NPair c e) i = eval (NPair i e) c
-              appl y z = error ("nEval napp appl no pair " <> show y <> (" --- " <> show z))
+          let nc = recur c
+              ni = recur i
+              appl (NPair c e) i = eval (NPair i e) c
+              appl y z = error ("nEval: napp appl no pair " <> show y <> (" --- " <> show z))
           case nc of
             p@(NPair _ _) -> appl p ni
-            (NLamNum n e) -> pure $ case ni of
+            (NLamNum n e) -> case ni of
               (NLamNum m _)     -> NPair (NPair (NNum (n ^ m)) NEnv) e
               (NPartialNum m f) -> NPair (NNum (n * m)) f
-            NToNum -> pure $ NApp NToNum ni
+            NToNum -> NApp NToNum ni
             (NApp NToNum (NPair (NPair (NNum nn) NEnv) nenv)) ->
               let fStep 0 _ = 0
                   fStep _ NZero = 0
                   fStep x (NPair pr NZero) = 1 + fStep (x - 1) pr
                   fStep _ z = error ("napp ntonum fstep bad pair: " <> show z)
-              in pure $ NPair (NPair (NNum $ fStep nn ni) NEnv) nenv
-            z -> error ("nEval napp error - non pair c - " <> show z <> (" <<from>> " <> show c))
-        (NOldDefer x) -> pure x
+              in NPair (NPair (NNum $ fStep nn ni) NEnv) nenv
+            z -> error ("nEval: napp error - non pair c - " <> show z <> (" <<from>> " <> show c))
+        (NOldDefer x) -> x
         (NNum x) -> let buildF 0 = NLeft NEnv
                         buildF x = NApp (NLeft (NRight NEnv)) (buildF (x - 1))
-                    in pure $ buildF x
-        (NTwiddle x) -> recur x >>= \case
-          (NPair (NPair c e) i) -> pure $ NPair c (NPair i e)
-          z -> error ("neval ntwiddle not pairpair: " <> show z)
-        z -> pure z
+                    in buildF x
+        (NTwiddle x) -> case recur x of
+          (NPair (NPair c e) i) -> NPair c (NPair i e)
+          z -> error ("nEval: ntwiddle not pairpair: " <> show z)
+        z -> z
   in case Map.lookup (FragIndex 0) m of
     (Just f) -> eval NZero f
-    _        -> throwError $ GenericRunTimeError "nEval: no root frag" Zero
+    _        -> error $ "nEval: " <> show (GenericRunTimeError "nEval: no root frag" Zero)
 
 -- |IExpr evaluation with a given enviroment `e`
 -- (as in the second element of a closure).
-rEval :: (MonadError RunTimeError m)
-      => IExpr -- ^ The enviroment.
+rEval :: IExpr -- ^ The enviroment.
       -> IExpr -- ^ IExpr to be evaluated.
-      -> m IExpr
+      -> IExpr
 rEval e = para alg where
-  alg :: (MonadError RunTimeError m)
-      => (Base IExpr) (IExpr, m IExpr)
-      -> m IExpr
+  alg :: (Base IExpr) (IExpr, IExpr)
+      -> IExpr
   alg = \case
-    ZeroF -> pure Zero
-    EnvF -> pure e
-    (DeferF (ie, _)) -> pure . Defer $ ie
-    TraceF -> pure $ trace (show e) e
-    (GateF (ie1, _) (ie2, _)) -> pure $ Gate ie1 ie2
-    (PairF (_, l) (_, r)) -> Pair <$> l <*> r
-    (PRightF (_, x)) -> x >>= \case
-      (Pair _ r) -> pure r
-      _          -> pure Zero
-    (PLeftF (_, x)) -> x >>= \case
-      (Pair l _) -> pure l
-      _          -> pure Zero
-    (SetEnvF (_, x)) -> x >>= \case
+    ZeroF -> Zero
+    EnvF -> e
+    (DeferF (ie, _)) -> Defer ie
+    TraceF -> trace (show e) e
+    (GateF (ie1, _) (ie2, _)) -> Gate ie1 ie2
+    (PairF (_, l) (_, r)) -> Pair l r
+    (PRightF (_, x)) -> case x of
+      (Pair _ r) -> r
+      _          -> Zero
+    (PLeftF (_, x)) -> case x of
+      (Pair l _) -> l
+      _          -> Zero
+    (SetEnvF (_, x)) -> case x of
       Pair (Defer c) nenv  -> rEval nenv c
       Pair (Gate a _) Zero -> rEval e a
       Pair (Gate _ b) _    -> rEval e b
       -- The next case should never actually occur,
       -- because it should be caught by `typeCheck`.
-      z                    -> throwError $ SetEnvError z
+      z                    -> error $ "rEval: " <> show (SetEnvError z)
 
 -- |The fix point combinator of this function (of type `IExpr -> IExpr -> m IExpr`) yields a function that
 -- evaluates an `IExpr` with a given enviroment (another `IExpr`).
@@ -201,14 +196,13 @@ instance TelomareLike NExprs where
           _             -> Nothing
     in Map.lookup resultIndex m >>= fromNExpr
 instance AbstractRunTime NExprs where
-  eval x@(NExprs m) = (\r -> NExprs $ Map.insert resultIndex r m) <$> nEval x
+  eval x@(NExprs m) = NExprs $ Map.insert resultIndex (nEval x) m
 
-evalAndConvert :: (Show a, AbstractRunTime a) => a -> RunResult IExpr
-evalAndConvert x = let ar = eval x in (ar >>= (\case
-  Nothing -> do
-    ar' <- ar
-    throwError . ResultConversionError $ show ar'
-  Just ir -> pure ir) . toTelomare)
+evalAndConvert :: (Show a, AbstractRunTime a) => a -> IExpr
+evalAndConvert x = case toTelomare ar of
+  Nothing -> error . show . ResultConversionError $ show ar
+  Just ir -> ir
+ where ar = eval x
 
 -- |Evaluation with hvm backend
 hvmEval :: IExpr -> IO IExpr
@@ -226,19 +220,17 @@ hvmEval x = do
     Nothing -> error $ "Error: hvm failed to produce output. \nIExpr fed to hvm:\n" <> show x
 
 simpleEval :: IExpr -> IO IExpr
-simpleEval x = runExceptT (eval x) >>= \case
-  Left e  -> fail (show e)
-  Right i -> pure i
+simpleEval = pure . eval
 
 fastInterpretEval :: IExpr -> IO IExpr
 fastInterpretEval e = do
   let traceShow x = if debug then trace ("toNExpr\n" <> showNExprs x) x else x
       nExpr :: NExprs
       nExpr = traceShow $ fromTelomare e
-  result <- runExceptT $ evalAndConvert nExpr
-  case result of
-    Left e  -> error ("runtime error: " <> show e)
-    Right r -> pure r
+  pure . evalAndConvert $ nExpr
+  -- case result of
+  --   Left e  -> error ("runtime error: " <> show e)
+  --   Right r -> pure r
 
 {- commenting out until fixed
 llvmEval :: NExpr -> IO LLVM.RunResult
@@ -262,7 +254,7 @@ optimizedEval = fastInterpretEval
 pureIEval :: IExpr -> Either RunTimeError IExpr
 pureIEval g = runIdentity . runExceptT $ fix iEval Zero g -- this is the original version
 
-pureEval :: IExpr -> Either RunTimeError IExpr
+pureEval :: IExpr -> IExpr
 pureEval = rEval Zero
 
 showPass :: (Show a, MonadIO m) => m a -> m a
@@ -287,15 +279,14 @@ fullEval typeCheck i = typedEval typeCheck i print
 
 prettyEval typeCheck i = typedEval typeCheck i (print . PrettyIExpr)
 
-verifyEval :: IExpr -> IO (Maybe (Either RunTimeError IExpr, Either RunTimeError IExpr))
+verifyEval :: IExpr -> IO (Maybe (IExpr, IExpr))
 verifyEval expr =
   let nexpr :: NExprs
       nexpr = fromTelomare expr
-  in do
-    iResult <- runExceptT $ evalAndConvert expr
-    nResult <- runExceptT $ evalAndConvert nexpr
-    if iResult == nResult
+      iResult = evalAndConvert expr
+      nResult = evalAndConvert nexpr
+  in if iResult == nResult
      then pure Nothing
-     else pure $ pure (iResult, nResult)
+     else pure $ Just (iResult, nResult)
 
-testNEval = runExceptT . eval . (fromTelomare :: IExpr -> NExprs)
+testNEval = eval . (fromTelomare :: IExpr -> NExprs)

test/ResolverTests.hs

@@ -350,9 +350,9 @@ showAllTransformations input = do
 
 stepIEval :: IExpr -> IO IExpr
 stepIEval =
-  let wio :: IExpr -> WrappedIO IExpr
+  let wio :: IExpr -> IExpr
       wio = rEval Zero
-  in wioIO . wio
+  in pure . wio
 
 newtype WrappedIO a = WrappedIO
   { wioIO :: IO a

test/Spec.hs

@@ -319,9 +319,8 @@ unitTest name expected iexpr = it name $ if allowedTypeCheck (typeCheck ZeroType
 unitTestRefinement :: String -> Bool -> IExpr -> Spec
 unitTestRefinement name shouldSucceed iexpr = it name $ case inferType (fromTelomare iexpr) of
   Right t -> case (pureEval iexpr, shouldSucceed) of
-    (Left err, True) -> expectationFailure $ concat [name, ": failed refinement type -- ", show err]
-    (Right _, False) -> expectationFailure $ name <> ": expected refinement failure, but passed"
-    _ -> pure ()
+    (err, True) -> expectationFailure $ concat [name, ": failed refinement type -- ", show err]
+    (_, False) -> expectationFailure $ name <> ": expected refinement failure, but passed"
   Left err -> expectationFailure $ concat ["refinement test failed typecheck: ", name, " ", show err]
 
 unitTestQC :: Testable p => String -> Int -> p -> Spec