diff --git a/parser-typechecker/src/Unison/ABT.hs b/parser-typechecker/src/Unison/ABT.hs index dcd2adb7c..02ebbd780 100644 --- a/parser-typechecker/src/Unison/ABT.hs +++ b/parser-typechecker/src/Unison/ABT.hs @@ -104,7 +104,7 @@ bound' t = case out t of Tm f -> Foldable.toList f >>= bound' _ -> [] -annotateBound' :: (Ord v, Functor f, Foldable f) => Term f v () -> Term f v [v] +annotateBound' :: (Ord v, Functor f, Foldable f) => Term f v a0 -> Term f v [v] annotateBound' t = go [] t where go env t = case out t of Abs v body -> abs' env v (go (v : env) body) diff --git a/parser-typechecker/src/Unison/Runtime/Rt0.hs b/parser-typechecker/src/Unison/Runtime/Rt0.hs index 5a1593ced..d5751a12e 100644 --- a/parser-typechecker/src/Unison/Runtime/Rt0.hs +++ b/parser-typechecker/src/Unison/Runtime/Rt0.hs @@ -1,6 +1,7 @@ {-# Language OverloadedStrings #-} {-# Language ScopedTypeVariables #-} {-# Language StrictData #-} +{-# Language TupleSections #-} {-# Language UnicodeSyntax #-} module Unison.Runtime.Rt0 where @@ -13,6 +14,7 @@ import Data.Word (Word64) import Data.List import Unison.Symbol (Symbol) import Unison.Term (AnnotatedTerm) +import qualified Unison.Builtin as B import qualified Unison.ABT as ABT import qualified Unison.Reference as R import qualified Unison.Term as Term @@ -28,7 +30,13 @@ data V e = I Int64 | F Double | U Word64 | B Bool | T Text | Lam Arity (Term Symbol) (IR e) | Data R.Reference ConstructorId [V e] + | Requested (Req e) | Ext e deriving (Eq,Show) +-- +-- Contains the effect ref and ctor id, the args, and the continuation +-- which expects the result at the top of the stack +data Req e = Req e Int [V e] (IR e) + deriving (Eq,Show) data IR e = Var Pos @@ -42,18 +50,19 @@ data IR e | Construct R.Reference Int [Pos] | Request R.Reference Int [Pos] | Handle Pos (IR e) - | If Pos (IR e) (IR e) deriving (Eq,Show) + | If Pos (IR e) (IR e) + | And Pos (IR e) + | Or Pos (IR e) + deriving (Eq,Show) type Rt = Machine -> V R.Reference type Machine = [V R.Reference] -- a stack of values --- change `run` Rt to return `Either Req` or `V` - push :: V R.Reference -> Machine -> Machine push = (:) pushes :: [V R.Reference] -> Machine -> Machine -pushes s m = s <> m +pushes s m = reverse s <> m at :: Int -> Machine -> V R.Reference at i m = m !! i @@ -83,19 +92,20 @@ att i m = case at i m of T t -> t _ -> error "type error" --- Contains the effect ref and ctor id, the args, and the continuation --- which expects the result at the top of the stack -data Req = Req R.Reference Int [V R.Reference] (IR R.Reference) - deriving Show - -appendCont :: Req -> IR R.Reference -> Req +appendCont :: Req e -> IR e -> Req e appendCont (Req r cid args k) k2 = Req r cid args (Let k k2) -type Result = Either Req (V R.Reference) +type Result = Either (Req R.Reference) (V R.Reference) run :: IR R.Reference -> Machine -> Result run ir m = case ir of If c t f -> if atb c m then run t m else run f m + And i j -> case at i m of + b@(B False) -> Right b + _ -> run j m + Or i j -> case at i m of + b@(B True) -> Right b + _ -> run j m Let b body -> case run b m of Left req -> Left $ req `appendCont` body Right v -> run body (v : m) @@ -107,6 +117,9 @@ run ir m = case ir of in run body m' Apply fnPos args -> call (at fnPos m) args m Request r cid args -> Left (Req r cid ((`at` m) <$> args) (Var 0)) + Handle handler body -> case run body m of + Left req -> call (at handler m) [0] (Requested req `push` m) + r -> r ir -> pure $ case ir of Var i -> at i m V v -> v @@ -130,7 +143,7 @@ call (Lam arity term body) args m = let nargs = length args in case nargs of _ | nargs == arity -> run body (map (`at` m) args `pushes` m) _ | nargs > arity -> - case run body (map (`at` m) args `pushes` m) of + case run body (map (`at` m) (take arity args) `pushes` m) of Left req -> Left $ req `appendCont` error "todo" Right fn' -> call fn' (drop arity args) m -- nargs < arity @@ -151,6 +164,9 @@ decompile v = case v of T t -> Term.text () t Lam _ f _ -> f Data r cid args -> Term.apps' (Term.constructor() r cid) (toList $ fmap decompile args) + Requested (Req r cid args _) -> + let req = Term.apps (Term.request() r cid) (((),) . decompile <$> args) + in req Ext r -> Term.ref () r compile :: Term Symbol -> IR R.Reference @@ -165,6 +181,9 @@ compile0 bound t = go ((++ bound) <$> ABT.annotateBound' (Term.anf t)) where fvs = toList $ ABT.freeVars t lifted = Term.lam'() (fvs ++ vs) (void body) in compile0 (ABT.annotation t) (Term.apps' lifted (Term.var() <$> fvs)) + Term.And' x y -> And (ind t x) (go y) + Term.Or' x y -> Or (ind t x) (go y) + Term.If' cond ifT ifF -> If (ind t cond) (go ifT) (go ifF) Term.Int64' n -> V (I n) Term.UInt64' n -> V (U n) Term.Float' n -> V (F n) @@ -179,8 +198,8 @@ compile0 bound t = go ((++ bound) <$> ABT.annotateBound' (Term.anf t)) where Term.Request' r cid -> Request r cid (ind t <$> args) Term.Constructor' r cid -> Construct r cid (ind t <$> args) _ -> Apply (ind t f) (map (ind t) args) where - Term.Handle' _h _body -> - error "todo - make Machine model a bit richer, push and pop stack o' handlers" + Term.Handle' h body -> Handle (ind t h) (go body) + Term.Ann' e _ -> go e _ -> error $ "TODO - don't know how to compile " ++ show t where unknown v = error $ "free variable during compilation: " ++ show v @@ -188,3 +207,14 @@ compile0 bound t = go ((++ bound) <$> ABT.annotateBound' (Term.anf t)) where Nothing -> error $ "free variable during compilation: " ++ show v Just i -> i ind _ _ = error "ANF should eliminate any non-var arguments to apply" + +normalize :: AnnotatedTerm Symbol a -> Term Symbol +normalize t = + let v = case run (compile $ Term.unannotate t) [] of + Left e -> Requested e + Right a -> a + in decompile v + +parseAndNormalize :: String -> Term Symbol +parseAndNormalize s = normalize (Term.unannotate $ B.tm s) + diff --git a/parser-typechecker/src/Unison/Term.hs b/parser-typechecker/src/Unison/Term.hs index e72f2037f..a31ef2d4d 100644 --- a/parser-typechecker/src/Unison/Term.hs +++ b/parser-typechecker/src/Unison/Term.hs @@ -14,6 +14,7 @@ module Unison.Term where import Prelude hiding (and,or) import qualified Control.Monad.Writer.Strict as Writer +import Data.Functor (void) import Data.Foldable (traverse_, toList) import Data.Int (Int64) import Data.List (foldl') @@ -141,6 +142,21 @@ typeMap f t = go t where -- otherwise we'd have to manually match on every non-`Ann` ctor ABT.Tm ts -> unsafeCoerce $ ABT.Tm (fmap go ts) +unannotate :: ∀ vt at ap v a . Ord v => AnnotatedTerm2 vt at ap v a -> Term' vt v +unannotate t = go t where + go :: AnnotatedTerm2 vt at ap v a -> Term' vt v + go (ABT.out -> ABT.Abs v body) = ABT.abs v (go body) + go (ABT.out -> ABT.Cycle body) = ABT.cycle (go body) + go (ABT.Var' v) = ABT.var v + go (ABT.Tm' f) = + case go <$> f of + Ann e t -> ABT.tm (Ann e (void t)) + Match scrutinee branches -> + let unann (MatchCase pat guard body) = MatchCase (void pat) guard body + in ABT.tm (Match scrutinee (unann <$> branches)) + f' -> ABT.tm (unsafeCoerce f') + go _ = error "unpossible" + wrapV :: Ord v => AnnotatedTerm v a -> AnnotatedTerm (ABT.V v) a wrapV = vmap ABT.Bound