diff --git a/src/Telomare.hs b/src/Telomare.hs index 87b9642..26eee6c 100644 --- a/src/Telomare.hs +++ b/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) diff --git a/src/Telomare/Eval.hs b/src/Telomare/Eval.hs index 543ae49..f783e78 100644 --- a/src/Telomare/Eval.hs +++ b/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 diff --git a/src/Telomare/RunTime.hs b/src/Telomare/RunTime.hs index 6dd32c4..236f58d 100644 --- a/src/Telomare/RunTime.hs +++ b/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 <> (" <> " <> 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 <> (" <> " <> 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) diff --git a/test/ResolverTests.hs b/test/ResolverTests.hs index dc21c5c..c407f60 100644 --- a/test/ResolverTests.hs +++ b/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 diff --git a/test/Spec.hs b/test/Spec.hs index 805ce83..3edfb3f 100644 --- a/test/Spec.hs +++ b/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