Merge remote-tracking branch 'origin/wip/refactor-cli' into wip/refactor-cli

parser-typechecker/src/Unison/Runtime/ANF.hs

@@ -6,7 +6,7 @@
 {-# Language PatternSynonyms #-}
 {-# Language ScopedTypeVariables #-}
 
-module Unison.Runtime.ANF (optimize, fromTerm, fromTerm', term) where
+module Unison.Runtime.ANF (optimize, fromTerm, fromTerm', term, minimizeCyclesOrCrash) where
 
 import Data.Bifunctor (second)
 import Data.Foldable hiding (and,or)
@@ -90,17 +90,17 @@ isLeaf (Boolean' _) = True
 isLeaf (Constructor' _ _) = True
 isLeaf _ = False
 
-fromTerm' :: (Monoid a, Var v) => (v -> v) -> AnnotatedTerm v a -> AnnotatedTerm v a
-fromTerm' liftVar t = term (fromTerm liftVar t)
-
 minimizeCyclesOrCrash :: Var v => AnnotatedTerm v a -> AnnotatedTerm v a
 minimizeCyclesOrCrash t = case minimize' t of
   Right t -> t
   Left e -> error $ "tried to minimize let rec with duplicate definitions: "
                  ++ show (fst <$> toList e)
 
+fromTerm' :: (Monoid a, Var v) => (v -> v) -> AnnotatedTerm v a -> AnnotatedTerm v a
+fromTerm' liftVar t = term (fromTerm liftVar t)
+
 fromTerm :: forall a v . (Monoid a, Var v) => (v -> v) -> AnnotatedTerm v a -> ANF v a
-fromTerm liftVar t = ANF_ (go $ lambdaLift liftVar (minimizeCyclesOrCrash t)) where
+fromTerm liftVar t = ANF_ (go $ lambdaLift liftVar t) where
   ann = ABT.annotation
   isRef (Ref' _) = True
   isRef _ = False

parser-typechecker/src/Unison/Runtime/IR.hs

@@ -15,7 +15,6 @@ module Unison.Runtime.IR where
 
 import Control.Monad.State.Strict (StateT, gets, modify, runStateT, lift)
 import Data.Bifunctor (first, second)
-import Debug.Trace
 import Data.Foldable
 import Data.Functor (void)
 import Data.IORef
@@ -26,12 +25,11 @@ import Data.Set (Set)
 import Data.Text (Text)
 import Data.Vector (Vector)
 import Data.Word (Word64)
+import Debug.Trace
 import Unison.Symbol (Symbol)
 import Unison.Term (AnnotatedTerm)
 import Unison.Util.Monoid (intercalateMap)
 import Unison.Var (Var)
-import qualified Unison.Util.Pretty as P
-import qualified Unison.TermPrinter as TP
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Unison.ABT as ABT
@@ -39,7 +37,9 @@ import qualified Unison.Pattern as Pattern
 import qualified Unison.Reference as R
 import qualified Unison.Runtime.ANF as ANF
 import qualified Unison.Term as Term
+import qualified Unison.TermPrinter as TP
 import qualified Unison.Type as Type
+import qualified Unison.Util.Pretty as P
 import qualified Unison.Var as Var
 
 type Pos = Int
@@ -244,7 +244,8 @@ specializeIR env ir = let
   in go <$> ir'
 
 compile :: Show e => CompilationEnv e -> Term Symbol -> IR e
-compile env t = compile0 env [] (Term.vmap toSymbolC t)
+compile env t = compile0 env []
+  (ABT.rewriteDown ANF.minimizeCyclesOrCrash $ Term.vmap toSymbolC t)
 
 freeVars :: [(SymbolC,a)] -> Term SymbolC -> Set SymbolC
 freeVars bound t =

parser-typechecker/src/Unison/Runtime/Rt1.hs

@@ -51,14 +51,6 @@ instance External ExternalFunction where
 
 type Stack = MV.IOVector Value
 
--- compile :: Show e => CompilationEnv e -> Term Symbol -> IR e
--- compilationEnv :: Monad m
---   => CL.CodeLookup m Symbol a
---   -> Term Symbol
---   -> m CompilationEnv
--- run :: CompilationEnv -> IR -> IO Result
-
-
 -- This function converts `Z` to a `Value`.
 -- A bunch of variants follow.
 at :: Size -> Z -> Stack -> IO Value
@@ -441,6 +433,10 @@ run ioHandler env ir = do
             in done $ Lam (arity - nargs)
                        (FormClosure tm pushedArgs')
                        (specializeIR bound body)
+    call size m (Cont ir) [arg] = do
+      v <- at size arg m
+      m <- push size v m
+      go (size + 1) m ir
     call _ _ fn args =
       error $ "type error - tried to apply a non-function: " <> show (fn, args)
 
@@ -458,9 +454,11 @@ run ioHandler env ir = do
       (Sequence args, PatternSequence pats) ->
         join <$> traverse tryCase (zip (toList args) (toList pats))
       (Pure v, PatternPure p) -> tryCase (v, p)
+      (Pure _, PatternBind _ _ _ _) -> Nothing
       (Requested (Req r cid args k), PatternBind r2 cid2 pats kpat) ->
         when' (r == r2 && cid == cid2) $
           join <$> traverse tryCase (zip (args ++ [Cont k]) (pats ++ [kpat]))
+      (Requested _, PatternPure _) -> Nothing
       (v, PatternAs p) -> (v:) <$> tryCase (v,p)
       (_, PatternIgnore) -> Just []
       (v, PatternVar) -> Just [v]

unison-src/tests/state4a.u

@@ -0,0 +1,25 @@
+effect State s where
+  put : s -> {State s} ()
+  get : {State s} s
+
+state : s -> Effect (State s) a -> s
+state s eff = case eff of
+  { State.get -> k } -> handle (state s) in k s
+  { State.put snew -> k } -> handle (state snew) in k ()
+  { a } -> s
+
+modify : (s -> s) -> {State s} ()
+modify f = State.put (f State.get)
+
+increment : '{State Nat} ()
+increment = '(modify ((+) 1))
+
+ex : Nat
+ex = handle (state 10) in
+  State.put (11 + 1)
+  -- !increment
+  -- !increment
+  -- !increment
+  State.get -- should be 15, amirite??
+
+> ex

unison-src/tests/state4a.ur

@@ -0,0 +1 @@
+12