{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Telomare.RunTime where

-- import Control.Exception
import Control.Monad.Except
import Control.Monad.Fix
import Data.Foldable
import Data.Functor.Foldable hiding (fold)
import Data.Functor.Identity
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Debug.Trace
import GHC.Exts (fromList)
import Naturals hiding (debug, debugTrace)
import PrettyPrint (PrettyIExpr (PrettyIExpr), showNExprs)
import System.IO (hGetContents)
import System.Process (CreateProcess (std_out), StdStream (CreatePipe),
                       createProcess, shell)
import Telomare
import Text.Read (readMaybe)

debug :: Bool
debug :: Bool
debug = Bool
False

debugTrace :: String -> a -> a
debugTrace :: forall a. String -> a -> a
debugTrace String
s a
x = if Bool
debug then forall a. String -> a -> a
trace String
s a
x else a
x

-- cPlus :: (t3 -> t2 -> t1) -> (t3 -> t -> t2) -> t3 -> t -> t1
cPlus :: ((a -> a) -> a -> a) -> ((a -> a) -> a -> a) -> (a -> a) -> a -> a
-- cPlus m n f x = m f (n f x)
cPlus :: forall a.
((a -> a) -> a -> a) -> ((a -> a) -> a -> a) -> (a -> a) -> a -> a
cPlus (a -> a) -> a -> a
m (a -> a) -> a -> a
n a -> a
f = (a -> a) -> a -> a
m a -> a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a) -> a -> a
n a -> a
f

nEval :: NExprs -> NExpr
nEval :: NExprs -> NExpr
nEval (NExprs Map FragIndex NExpr
m) =
  let eval :: NExpr -> NExpr -> NExpr
      eval :: NExpr -> NExpr -> NExpr
eval NExpr
env NExpr
frag = let recur :: NExpr -> NExpr
recur = NExpr -> NExpr -> NExpr
eval NExpr
env in case NExpr
frag of
        (NPair NExpr
a NExpr
b) -> NExpr -> NExpr -> NExpr
NPair (NExpr -> NExpr
recur NExpr
a) (NExpr -> NExpr
recur NExpr
b)
        NExpr
NEnv -> NExpr
env
        (NLeft NExpr
x) -> case NExpr -> NExpr
recur NExpr
x of
          (NPair NExpr
l NExpr
_) -> NExpr
l
          NExpr
NZero       -> NExpr
NZero
          NExpr
z           -> forall a. HasCallStack => String -> a
error (String
"nEval: nleft on " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show NExpr
z forall a. Semigroup a => a -> a -> a
<> (String
" before " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show NExpr
x))
        (NRight NExpr
x) -> case NExpr -> NExpr
recur NExpr
x of
          (NPair NExpr
_ NExpr
r) -> NExpr
r
          NExpr
NZero       -> NExpr
NZero
          NExpr
z           -> forall a. HasCallStack => String -> a
error (String
"nright on " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show NExpr
z)
        (NDefer FragIndex
ind) -> case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FragIndex
ind Map FragIndex NExpr
m of
          (Just NExpr
x) -> NExpr
x
          Maybe NExpr
_ -> forall a. HasCallStack => String -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ String -> IExpr -> RunTimeError
GenericRunTimeError (String
"nEval bad index for function: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show FragIndex
ind) IExpr
Zero
        NExpr
NTrace -> forall a. String -> a -> a
trace (forall a. Show a => a -> String
show NExpr
env) NExpr
env
        (NSetEnv NExpr
x) -> case NExpr -> NExpr
recur NExpr
x of
          (NPair NExpr
c NExpr
i) -> case NExpr
c of
            NGate NExpr
a NExpr
b -> case NExpr
i of
              NExpr
NZero -> NExpr -> NExpr
recur NExpr
a
              NExpr
_     -> NExpr -> NExpr
recur NExpr
b
            NExpr
_ -> NExpr -> NExpr -> NExpr
eval NExpr
i NExpr
c
          NExpr
z -> forall a. HasCallStack => String -> a
error (String
"nEval: nsetenv - not pair - " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show NExpr
z)
        (NApp NExpr
c NExpr
i) -> do
          let nc :: NExpr
nc = NExpr -> NExpr
recur NExpr
c
              ni :: NExpr
ni = NExpr -> NExpr
recur NExpr
i
              appl :: NExpr -> NExpr -> NExpr
appl (NPair NExpr
c NExpr
e) NExpr
i = NExpr -> NExpr -> NExpr
eval (NExpr -> NExpr -> NExpr
NPair NExpr
i NExpr
e) NExpr
c
              appl NExpr
y NExpr
z = forall a. HasCallStack => String -> a
error (String
"nEval: napp appl no pair " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show NExpr
y forall a. Semigroup a => a -> a -> a
<> (String
" --- " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show NExpr
z))
          case NExpr
nc of
            p :: NExpr
p@(NPair NExpr
_ NExpr
_) -> NExpr -> NExpr -> NExpr
appl NExpr
p NExpr
ni
            (NLamNum Int64
n NExpr
e) -> case NExpr
ni of
              (NLamNum Int64
m NExpr
_)     -> NExpr -> NExpr -> NExpr
NPair (NExpr -> NExpr -> NExpr
NPair (Int64 -> NExpr
NNum (Int64
n forall a b. (Num a, Integral b) => a -> b -> a
^ Int64
m)) NExpr
NEnv) NExpr
e
              (NPartialNum Int64
m NExpr
f) -> NExpr -> NExpr -> NExpr
NPair (Int64 -> NExpr
NNum (Int64
n forall a. Num a => a -> a -> a
* Int64
m)) NExpr
f
            NExpr
NToNum -> NExpr -> NExpr -> NExpr
NApp NExpr
NToNum NExpr
ni
            (NApp NExpr
NToNum (NPair (NPair (NNum Int64
nn) NExpr
NEnv) NExpr
nenv)) ->
              let fStep :: t -> NExpr -> a
fStep t
0 NExpr
_ = a
0
                  fStep t
_ NExpr
NZero = a
0
                  fStep t
x (NPair NExpr
pr NExpr
NZero) = a
1 forall a. Num a => a -> a -> a
+ t -> NExpr -> a
fStep (t
x forall a. Num a => a -> a -> a
- t
1) NExpr
pr
                  fStep t
_ NExpr
z = forall a. HasCallStack => String -> a
error (String
"napp ntonum fstep bad pair: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show NExpr
z)
              in NExpr -> NExpr -> NExpr
NPair (NExpr -> NExpr -> NExpr
NPair (Int64 -> NExpr
NNum forall a b. (a -> b) -> a -> b
$ forall {t} {a}. (Eq t, Num t, Num a) => t -> NExpr -> a
fStep Int64
nn NExpr
ni) NExpr
NEnv) NExpr
nenv
            NExpr
z -> forall a. HasCallStack => String -> a
error (String
"nEval: napp error - non pair c - " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show NExpr
z forall a. Semigroup a => a -> a -> a
<> (String
" <<from>> " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show NExpr
c))
        (NOldDefer NExpr
x) -> NExpr
x
        (NNum Int64
x) -> let buildF :: t -> NExpr
buildF t
0 = NExpr -> NExpr
NLeft NExpr
NEnv
                        buildF t
x = NExpr -> NExpr -> NExpr
NApp (NExpr -> NExpr
NLeft (NExpr -> NExpr
NRight NExpr
NEnv)) (t -> NExpr
buildF (t
x forall a. Num a => a -> a -> a
- t
1))
                    in forall {t}. (Eq t, Num t) => t -> NExpr
buildF Int64
x
        (NTwiddle NExpr
x) -> case NExpr -> NExpr
recur NExpr
x of
          (NPair (NPair NExpr
c NExpr
e) NExpr
i) -> NExpr -> NExpr -> NExpr
NPair NExpr
c (NExpr -> NExpr -> NExpr
NPair NExpr
i NExpr
e)
          NExpr
z -> forall a. HasCallStack => String -> a
error (String
"nEval: ntwiddle not pairpair: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show NExpr
z)
        NExpr
z -> NExpr
z
  in case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Int -> FragIndex
FragIndex Int
0) Map FragIndex NExpr
m of
    (Just NExpr
f) -> NExpr -> NExpr -> NExpr
eval NExpr
NZero NExpr
f
    Maybe NExpr
_        -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"nEval: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (String -> IExpr -> RunTimeError
GenericRunTimeError String
"nEval: no root frag" IExpr
Zero)

-- |IExpr evaluation with a given enviroment `e`
-- (as in the second element of a closure).
rEval :: IExpr -- ^ The enviroment.
      -> IExpr -- ^ IExpr to be evaluated.
      -> IExpr
rEval :: IExpr -> IExpr -> IExpr
rEval IExpr
e = forall t a. Recursive t => (Base t (t, a) -> a) -> t -> a
para Base IExpr (IExpr, IExpr) -> IExpr
alg where
  alg :: (Base IExpr) (IExpr, IExpr)
      -> IExpr
  alg :: Base IExpr (IExpr, IExpr) -> IExpr
alg = \case
    Base IExpr (IExpr, IExpr)
IExprF (IExpr, IExpr)
ZeroF -> IExpr
Zero
    Base IExpr (IExpr, IExpr)
IExprF (IExpr, IExpr)
EnvF -> IExpr
e
    (DeferF (IExpr
ie, IExpr
_)) -> IExpr -> IExpr
Defer IExpr
ie
    Base IExpr (IExpr, IExpr)
IExprF (IExpr, IExpr)
TraceF -> forall a. String -> a -> a
trace (forall a. Show a => a -> String
show IExpr
e) IExpr
e
    (GateF (IExpr
ie1, IExpr
_) (IExpr
ie2, IExpr
_)) -> IExpr -> IExpr -> IExpr
Gate IExpr
ie1 IExpr
ie2
    (PairF (IExpr
_, IExpr
l) (IExpr
_, IExpr
r)) -> IExpr -> IExpr -> IExpr
Pair IExpr
l IExpr
r
    (PRightF (IExpr
_, IExpr
x)) -> case IExpr
x of
      (Pair IExpr
_ IExpr
r) -> IExpr
r
      IExpr
_          -> IExpr
Zero
    (PLeftF (IExpr
_, IExpr
x)) -> case IExpr
x of
      (Pair IExpr
l IExpr
_) -> IExpr
l
      IExpr
_          -> IExpr
Zero
    (SetEnvF (IExpr
_, IExpr
x)) -> case IExpr
x of
      Pair (Defer IExpr
c) IExpr
nenv  -> IExpr -> IExpr -> IExpr
rEval IExpr
nenv IExpr
c
      Pair (Gate IExpr
a IExpr
_) IExpr
Zero -> IExpr -> IExpr -> IExpr
rEval IExpr
e IExpr
a
      Pair (Gate IExpr
_ IExpr
b) IExpr
_    -> IExpr -> IExpr -> IExpr
rEval IExpr
e IExpr
b
      -- The next case should never actually occur,
      -- because it should be caught by `typeCheck`.
      IExpr
z                    -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"rEval: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (IExpr -> RunTimeError
SetEnvError IExpr
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`).
iEval :: MonadError RunTimeError m => (IExpr -> IExpr -> m IExpr) -> IExpr -> IExpr -> m IExpr
iEval :: forall (m :: * -> *).
MonadError RunTimeError m =>
(IExpr -> IExpr -> m IExpr) -> IExpr -> IExpr -> m IExpr
iEval IExpr -> IExpr -> m IExpr
f IExpr
env IExpr
g = let f' :: IExpr -> m IExpr
f' = IExpr -> IExpr -> m IExpr
f IExpr
env in case IExpr
g of
  IExpr
Trace -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. String -> a -> a
trace (forall a. Show a => a -> String
show IExpr
env) IExpr
env
  IExpr
Zero -> forall (f :: * -> *) a. Applicative f => a -> f a
pure IExpr
Zero
  -- Abort -> pure Abort
  Defer IExpr
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ IExpr -> IExpr
Defer IExpr
x
  Pair IExpr
a IExpr
b -> IExpr -> IExpr -> IExpr
Pair forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IExpr -> m IExpr
f' IExpr
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IExpr -> m IExpr
f' IExpr
b
  Gate IExpr
a IExpr
b -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ IExpr -> IExpr -> IExpr
Gate IExpr
a IExpr
b
  IExpr
Env -> forall (f :: * -> *) a. Applicative f => a -> f a
pure IExpr
env
  SetEnv IExpr
x -> (IExpr -> m IExpr
f' IExpr
x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=) forall a b. (a -> b) -> a -> b
$ \case
    Pair IExpr
cf IExpr
nenv -> case IExpr
cf of
      Defer IExpr
c -> IExpr -> IExpr -> m IExpr
f IExpr
nenv IExpr
c
      -- do we change env in evaluation of a/b, or leave it same? change seems more consistent, leave more convenient
      Gate IExpr
a IExpr
b -> case IExpr
nenv of
        IExpr
Zero -> IExpr -> m IExpr
f' IExpr
a
        IExpr
_    -> IExpr -> m IExpr
f' IExpr
b
      IExpr
z -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ IExpr -> RunTimeError
SetEnvError IExpr
z -- This should never actually occur, because it should be caught by typecheck
    IExpr
bx -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ IExpr -> RunTimeError
SetEnvError IExpr
bx -- This should never actually occur, because it should be caught by typecheck
  PLeft IExpr
g -> IExpr -> m IExpr
f' IExpr
g forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    (Pair IExpr
a IExpr
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure IExpr
a
    IExpr
_          -> forall (f :: * -> *) a. Applicative f => a -> f a
pure IExpr
Zero
  PRight IExpr
g -> IExpr -> m IExpr
f' IExpr
g forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    (Pair IExpr
_ IExpr
x) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure IExpr
x
    IExpr
_          -> forall (f :: * -> *) a. Applicative f => a -> f a
pure IExpr
Zero

-- iEval' :: (IExpr -> IExpr -> Either RunTimeError IExpr) -> IExpr -> IExpr -> Either RunTimeError IExpr
-- iEval' f env g = let f' = f env in case g of
--   Trace -> pure $ trace (show env) env
--   Zero -> pure Zero
--   -- Abort -> pure Abort
--   Defer x -> pure $ Defer x
--   Pair a b -> Pair <$> f' a <*> f' b
--   Gate a b -> pure $ Gate a b
--   Env -> pure env
--   SetEnv x -> (f' x >>=) $ \case
--     Pair cf nenv -> case cf of
--       Defer c -> f nenv c
--       -- do we change env in evaluation of a/b, or leave it same? change seems more consistent, leave more convenient
--       Gate a b -> case nenv of
--         Zero -> f' a
--         _    -> f' b
--       z -> throwError $ SetEnvError z -- This should never actually occur, because it should be caught by typecheck
--     bx -> throwError $ SetEnvError bx -- This should never actually occur, because it should be caught by typecheck
--   PLeft g -> f' g >>= \case
--     (Pair a _) -> pure a
--     _          -> pure Zero
--   PRight g -> f' g >>= \case
--     (Pair _ x) -> pure x
--     _          -> pure Zero

instance TelomareLike IExpr where
  fromTelomare :: IExpr -> IExpr
fromTelomare = forall a. a -> a
id
  toTelomare :: IExpr -> Maybe IExpr
toTelomare = forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance AbstractRunTime IExpr where
  -- eval = fix iEval Zero
  eval :: IExpr -> IExpr
eval = IExpr -> IExpr -> IExpr
rEval IExpr
Zero

resultIndex :: FragIndex
resultIndex = Int -> FragIndex
FragIndex (-Int
1)
instance TelomareLike NExprs where
  fromTelomare :: IExpr -> NExprs
fromTelomare = (Map FragIndex NExpr -> NExprs
NExprs forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map FragIndex ExprFrag -> Map FragIndex NExpr
fragsToNExpr) forall b c a. (b -> c) -> (a -> b) -> a -> c
. IExpr -> Map FragIndex ExprFrag
fragmentExpr
  toTelomare :: NExprs -> Maybe IExpr
toTelomare (NExprs Map FragIndex NExpr
m) =
    let fromNExpr :: NExpr -> Maybe IExpr
fromNExpr NExpr
x = case NExpr
x of
          NExpr
NZero         -> forall (f :: * -> *) a. Applicative f => a -> f a
pure IExpr
Zero
          (NPair NExpr
a NExpr
b)   -> IExpr -> IExpr -> IExpr
Pair forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NExpr -> Maybe IExpr
fromNExpr NExpr
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NExpr -> Maybe IExpr
fromNExpr NExpr
b
          NExpr
NEnv          -> forall (f :: * -> *) a. Applicative f => a -> f a
pure IExpr
Env
          (NSetEnv NExpr
x)   -> IExpr -> IExpr
SetEnv forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NExpr -> Maybe IExpr
fromNExpr NExpr
x
          NGate NExpr
a NExpr
b     -> IExpr -> IExpr -> IExpr
Gate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NExpr -> Maybe IExpr
fromNExpr NExpr
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NExpr -> Maybe IExpr
fromNExpr NExpr
b
          (NLeft NExpr
x)     -> IExpr -> IExpr
PLeft forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NExpr -> Maybe IExpr
fromNExpr NExpr
x
          (NRight NExpr
x)    -> IExpr -> IExpr
PRight forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NExpr -> Maybe IExpr
fromNExpr NExpr
x
          NExpr
NTrace        -> forall (f :: * -> *) a. Applicative f => a -> f a
pure IExpr
Trace
          (NDefer FragIndex
i)    -> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FragIndex
i Map FragIndex NExpr
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IExpr -> IExpr
Defer forall b c a. (b -> c) -> (a -> b) -> a -> c
. NExpr -> Maybe IExpr
fromNExpr
          (NOldDefer NExpr
x) -> IExpr -> IExpr
Defer forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NExpr -> Maybe IExpr
fromNExpr NExpr
x
          NExpr
_             -> forall a. Maybe a
Nothing
    in forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FragIndex
resultIndex Map FragIndex NExpr
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NExpr -> Maybe IExpr
fromNExpr
instance AbstractRunTime NExprs where
  eval :: NExprs -> NExprs
eval x :: NExprs
x@(NExprs Map FragIndex NExpr
m) = Map FragIndex NExpr -> NExprs
NExprs forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FragIndex
resultIndex (NExprs -> NExpr
nEval NExprs
x) Map FragIndex NExpr
m

evalAndConvert :: (Show a, AbstractRunTime a) => a -> IExpr
evalAndConvert :: forall a. (Show a, AbstractRunTime a) => a -> IExpr
evalAndConvert a
x = case forall a. TelomareLike a => a -> Maybe IExpr
toTelomare a
ar of
  Maybe IExpr
Nothing -> forall a. HasCallStack => String -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> RunTimeError
ResultConversionError forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show a
ar
  Just IExpr
ir -> IExpr
ir
 where ar :: a
ar = forall a. AbstractRunTime a => a -> a
eval a
x

-- |Evaluation with hvm backend
hvmEval :: IExpr -> IO IExpr
hvmEval :: IExpr -> IO IExpr
hvmEval IExpr
x = do
  (Maybe Handle
_, Maybe Handle
mhout, Maybe Handle
_, ProcessHandle
_) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (String -> CreateProcess
shell (String
"hvm r ./hvm/backend \"(" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show IExpr
x forall a. Semigroup a => a -> a -> a
<> String
")\"")) { std_out :: StdStream
std_out = StdStream
CreatePipe }
  case Maybe Handle
mhout of
    Just Handle
hout -> do
      String
hvmOutput <- Handle -> IO String
hGetContents Handle
hout
      if (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines forall a b. (a -> b) -> a -> b
$ String
hvmOutput) forall a. Ord a => a -> a -> Bool
> Int
2 then
        case (forall a. Read a => String -> Maybe a
readMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines forall a b. (a -> b) -> a -> b
$ String
hvmOutput) :: Maybe IExpr of
          Just IExpr
res -> forall (f :: * -> *) a. Applicative f => a -> f a
pure IExpr
res
          Maybe IExpr
Nothing  -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Error: fail to read hvm output. \nhvm output:\n" forall a. Semigroup a => a -> a -> a
<> String
hvmOutput
      else forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Error: hvm output is not what was expected. \nhvm output: " forall a. Semigroup a => a -> a -> a
<> String
hvmOutput
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> a
read forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines forall a b. (a -> b) -> a -> b
$ String
hvmOutput
    Maybe Handle
Nothing -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Error: hvm failed to produce output. \nIExpr fed to hvm:\n" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show IExpr
x

simpleEval :: IExpr -> IO IExpr
simpleEval :: IExpr -> IO IExpr
simpleEval = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. AbstractRunTime a => a -> a
eval

fastInterpretEval :: IExpr -> IO IExpr
fastInterpretEval :: IExpr -> IO IExpr
fastInterpretEval IExpr
e = do
  let traceShow :: NExprs -> NExprs
traceShow NExprs
x = if Bool
debug then forall a. String -> a -> a
trace (String
"toNExpr\n" forall a. Semigroup a => a -> a -> a
<> NExprs -> String
showNExprs NExprs
x) NExprs
x else NExprs
x
      nExpr :: NExprs
      nExpr :: NExprs
nExpr = NExprs -> NExprs
traceShow forall a b. (a -> b) -> a -> b
$ forall a. TelomareLike a => IExpr -> a
fromTelomare IExpr
e
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Show a, AbstractRunTime a) => a -> IExpr
evalAndConvert forall a b. (a -> b) -> a -> b
$ NExprs
nExpr
  -- case result of
  --   Left e  -> error ("runtime error: " <> show e)
  --   Right r -> pure r

{- commenting out until fixed
llvmEval :: NExpr -> IO LLVM.RunResult
llvmEval nexpr = do
  let lmod = LLVM.makeModule nexpr
  when debug $ do
    print $ LLVM.DebugModule lmod
    putStrLn . concat . replicate 100 $ "                                                                     \n"
  result <- catch (LLVM.evalJIT LLVM.defaultJITConfig lmod) $ \(e :: SomeException) -> pure . Left $ show e
  case result of
    Left s -> do
      hPrint stderr nexpr
      hPutStrLn stderr $ "failed llvmEval: " ++ s
      fail s
    Right x -> pure x
-}

optimizedEval :: IExpr -> IO IExpr
optimizedEval :: IExpr -> IO IExpr
optimizedEval = IExpr -> IO IExpr
fastInterpretEval

pureIEval :: IExpr -> Either RunTimeError IExpr
pureIEval :: IExpr -> Either RunTimeError IExpr
pureIEval IExpr
g = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ forall a. (a -> a) -> a
fix forall (m :: * -> *).
MonadError RunTimeError m =>
(IExpr -> IExpr -> m IExpr) -> IExpr -> IExpr -> m IExpr
iEval IExpr
Zero IExpr
g -- this is the original version

pureEval :: IExpr -> IExpr
pureEval :: IExpr -> IExpr
pureEval = IExpr -> IExpr -> IExpr
rEval IExpr
Zero

showPass :: (Show a, MonadIO m) => m a -> m a
showPass :: forall a (m :: * -> *). (Show a, MonadIO m) => m a -> m a
showPass m a
a = m a
a forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> IO ()
print forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m a
a

tEval :: IExpr -> IO IExpr
tEval :: IExpr -> IO IExpr
tEval IExpr
x = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (forall a. (a -> a) -> a
fix (\IExpr -> IExpr -> ExceptT RunTimeError IO IExpr
f IExpr
e IExpr
g -> forall a (m :: * -> *). (Show a, MonadIO m) => m a -> m a
showPass forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadError RunTimeError m =>
(IExpr -> IExpr -> m IExpr) -> IExpr -> IExpr -> m IExpr
iEval IExpr -> IExpr -> ExceptT RunTimeError IO IExpr
f IExpr
e IExpr
g) IExpr
Zero IExpr
x) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Left RunTimeError
e  -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail (forall a. Show a => a -> String
show RunTimeError
e)
  Right IExpr
i -> forall (f :: * -> *) a. Applicative f => a -> f a
pure IExpr
i

typedEval :: (IExpr -> DataType -> Bool) -> IExpr -> (IExpr -> IO ()) -> IO ()
typedEval :: (IExpr -> DataType -> Bool) -> IExpr -> (IExpr -> IO ()) -> IO ()
typedEval IExpr -> DataType -> Bool
typeCheck IExpr
iexpr IExpr -> IO ()
prettyPrint = if IExpr -> DataType -> Bool
typeCheck IExpr
iexpr DataType
ZeroType
  then IExpr -> IO IExpr
simpleEval IExpr
iexpr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IExpr -> IO ()
prettyPrint
  else String -> IO ()
putStrLn String
"failed typecheck"

debugEval :: (IExpr -> DataType -> Bool) -> IExpr -> IO ()
debugEval :: (IExpr -> DataType -> Bool) -> IExpr -> IO ()
debugEval IExpr -> DataType -> Bool
typeCheck IExpr
iexpr = if IExpr -> DataType -> Bool
typeCheck IExpr
iexpr DataType
ZeroType
  then IExpr -> IO IExpr
tEval IExpr
iexpr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Show a => a -> IO ()
print forall b c a. (b -> c) -> (a -> b) -> a -> c
. IExpr -> PrettyIExpr
PrettyIExpr
  else String -> IO ()
putStrLn String
"failed typecheck"

fullEval :: (IExpr -> DataType -> Bool) -> IExpr -> IO ()
fullEval IExpr -> DataType -> Bool
typeCheck IExpr
i = (IExpr -> DataType -> Bool) -> IExpr -> (IExpr -> IO ()) -> IO ()
typedEval IExpr -> DataType -> Bool
typeCheck IExpr
i forall a. Show a => a -> IO ()
print

prettyEval :: (IExpr -> DataType -> Bool) -> IExpr -> IO ()
prettyEval IExpr -> DataType -> Bool
typeCheck IExpr
i = (IExpr -> DataType -> Bool) -> IExpr -> (IExpr -> IO ()) -> IO ()
typedEval IExpr -> DataType -> Bool
typeCheck IExpr
i (forall a. Show a => a -> IO ()
print forall b c a. (b -> c) -> (a -> b) -> a -> c
. IExpr -> PrettyIExpr
PrettyIExpr)

verifyEval :: IExpr -> IO (Maybe (IExpr, IExpr))
verifyEval :: IExpr -> IO (Maybe (IExpr, IExpr))
verifyEval IExpr
expr =
  let nexpr :: NExprs
      nexpr :: NExprs
nexpr = forall a. TelomareLike a => IExpr -> a
fromTelomare IExpr
expr
      iResult :: IExpr
iResult = forall a. (Show a, AbstractRunTime a) => a -> IExpr
evalAndConvert IExpr
expr
      nResult :: IExpr
nResult = forall a. (Show a, AbstractRunTime a) => a -> IExpr
evalAndConvert NExprs
nexpr
  in if IExpr
iResult forall a. Eq a => a -> a -> Bool
== IExpr
nResult
     then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
     else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (IExpr
iResult, IExpr
nResult)

testNEval :: IExpr -> NExprs
testNEval = forall a. AbstractRunTime a => a -> a
eval forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. TelomareLike a => IExpr -> a
fromTelomare :: IExpr -> NExprs)