Hooked IO up to runtime

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

@@ -10,7 +10,6 @@ import           Data.Functor                   ( void )
 import           Data.Map                       ( Map )
 import qualified Data.Map                      as Map
 import qualified Data.Set                      as Set
-import           Control.Monad.IO.Class         ( MonadIO )
 import qualified Unison.Codebase.CodeLookup    as CL
 import           Unison.UnisonFile              ( UnisonFile )
 import qualified Unison.Term                   as Term
@@ -23,13 +22,13 @@ import qualified Unison.Reference              as Reference
 import qualified Unison.UnisonFile             as UF
 
 data Runtime v = Runtime
-  { terminate :: forall m. MonadIO m => m ()
+  { terminate :: IO ()
   , evaluate
-      :: forall a m
+      :: forall a
-      .  (MonadIO m, Monoid a)
+      .  Monoid a
-      => CL.CodeLookup m v a
+      => CL.CodeLookup IO v a
       -> AnnotatedTerm v a
-      -> m (Term v)
+      -> IO (Term v)
   }
 
 type IsCacheHit = Bool
@@ -42,51 +41,57 @@ type IsCacheHit = Bool
 -- Note: The definitions in the file are hashed and looked up in
 -- `evaluationCache`. If that returns a result, evaluation of that definition
 -- can be skipped.
-evaluateWatches :: forall m v a . (Var v, MonadIO m)
+evaluateWatches
-                => CL.CodeLookup m v a
+  :: forall v a
-                -> (Reference -> m (Maybe (Term v)))
+   . Var v
-                -> Runtime v
+  => CL.CodeLookup IO v a
-                -> UnisonFile v a
+  -> (Reference -> IO (Maybe (Term v)))
-                -- Map watchName (loc, hash, expression, value, isHit)
+  -> Runtime v
-                -> m ([(v, Term v)]
+  -> UnisonFile v a
-                     , Map v (a, Reference, Term v, Term v, IsCacheHit))
+  -> IO
-                -- m (bindings :: [v,Term v], map :: ^^^)
+       ( [(v, Term v)]
+         -- Map watchName (loc, hash, expression, value, isHit)
+       , Map v (a, Reference, Term v, Term v, IsCacheHit)
+       )
+  -- IO (bindings :: [v,Term v], map :: ^^^)
 evaluateWatches code evaluationCache rt uf = do
   -- 1. compute hashes for everything in the file
-  let
+  let m :: Map v (Reference, AnnotatedTerm v a)
-    m :: Map v (Reference, AnnotatedTerm v a)
+      m = Term.hashComponents (Map.fromList (UF.terms uf <> UF.watches uf))
-    m = Term.hashComponents (Map.fromList (UF.terms uf <> UF.watches uf))
+      watches = Set.fromList (fst <$> UF.watches uf)
-    watches = Set.fromList (fst <$> UF.watches uf)
+      unann = Term.amap (const ())
-    unann = Term.amap (const ())
   -- 2. use the cache to lookup things already computed
   m' <- fmap Map.fromList . for (Map.toList m) $ \(v, (r, t)) -> do
     o <- evaluationCache r
-    case o of Nothing -> pure (v, (r, ABT.annotation t, unann t, False))
+    case o of
-              Just t'  -> pure (v, (r, ABT.annotation t, t', True))
+      Nothing -> pure (v, (r, ABT.annotation t, unann t, False))
+      Just t' -> pure (v, (r, ABT.annotation t, t', True))
   -- 3. create a big ol' let rec whose body is a big tuple of all watches
-  let
+  let rv :: Map Reference v
-    rv :: Map Reference v
+      rv = Map.fromList [ (r, v) | (v, (r, _)) <- Map.toList m ]
-    rv = Map.fromList [(r,v) | (v, (r,_)) <- Map.toList m ]
+      bindings :: [(v, Term v)]
-    bindings :: [(v, Term v)]
+      bindings     = [ (v, unref rv b) | (v, (_, _, b, _)) <- Map.toList m' ]
-    bindings = [ (v, unref rv b) | (v, (_,_,b,_)) <- Map.toList m' ]
+      watchVars    = [ Term.var () v | v <- toList watches ]
-    watchVars = [ Term.var() v | v <- toList watches ]
+      bigOl'LetRec = Term.letRec' True bindings (Term.tuple watchVars)
-    bigOl'LetRec = Term.letRec' True bindings (Term.tuple watchVars)
+      cl           = void $ CL.fromUnisonFile uf <> code
-    cl = void $ CL.fromUnisonFile uf <> code
   -- 4. evaluate it and get all the results out of the tuple, then
   -- create the result Map
   out <- evaluate rt cl bigOl'LetRec
-  let (bindings, results) = case out of
+  let
-        Term.Tuple' results -> (mempty, results)
+    (bindings, results) = case out of
-        Term.LetRecNamed' bs (Term.Tuple' results) -> (bs, results)
+      Term.Tuple' results -> (mempty, results)
-        _ -> fail $ "Evaluation should produce a tuple, but gave: " ++ show out
+      Term.LetRecNamed' bs (Term.Tuple' results) -> (bs, results)
-  let go eval (ref, a, uneval, isHit) = (a, ref, uneval, Term.etaNormalForm eval, isHit)
+      _ -> fail $ "Evaluation should produce a tuple, but gave: " ++ show out
-      watchMap = Map.intersectionWith go (Map.fromList (toList watches `zip` results)) m'
+  let go eval (ref, a, uneval, isHit) =
+        (a, ref, uneval, Term.etaNormalForm eval, isHit)
+      watchMap =
+        Map.intersectionWith go (Map.fromList (toList watches `zip` results)) m'
   pure (bindings, watchMap)
-  where
+ where
     -- unref :: Map Reference v -> AnnotatedTerm v a -> AnnotatedTerm v a
-    unref rv t = ABT.visitPure go t
+  unref rv t = ABT.visitPure go t
-     where
+   where
-      go t@(Term.Ref' r@(Reference.DerivedId _)) = case Map.lookup r rv of
+    go t@(Term.Ref' r@(Reference.DerivedId _)) = case Map.lookup r rv of
-        Nothing -> Nothing
+      Nothing -> Nothing
-        Just v -> Just (Term.var (ABT.annotation t) v)
+      Just v  -> Just (Term.var (ABT.annotation t) v)
-      go _ = Nothing
+    go _ = Nothing

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

@@ -196,8 +196,7 @@ data IR' z
 
 -- 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
+data Req e = Req R.Reference ConstructorId [Value e] (IR e)
-  = Req R.Reference ConstructorId [Value e] (IR e)
   deriving (Eq,Show)
 
 -- Appends `k2` to the end of the `k` continuation

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

@@ -13,7 +13,6 @@ module Unison.Runtime.Rt1 where
 
 import Data.Bifunctor (second)
 import Control.Monad (foldM, join)
-import Control.Monad.IO.Class (MonadIO, liftIO)
 import Data.Foldable (for_, toList)
 import Data.IORef
 import Data.Int (Int64)
@@ -22,11 +21,9 @@ import Data.Text (Text)
 import Data.Traversable (for)
 import Data.Word (Word64)
 import Data.Vector (Vector)
-import Unison.Codebase.Runtime (Runtime(Runtime))
 import Unison.Runtime.IR (pattern CompilationEnv, pattern Req)
 import Unison.Runtime.IR hiding (CompilationEnv, IR, Req, Value, Z)
 import Unison.Symbol (Symbol)
-import Unison.TermPrinter (prettyTop)
 import qualified Data.Map as Map
 import qualified Data.Text as Text
 import qualified Data.Vector as Vector
@@ -36,7 +33,6 @@ import qualified Unison.DataDeclaration as DD
 import qualified Unison.Reference as R
 import qualified Unison.Runtime.IR as IR
 import qualified Unison.Term as Term
-import qualified Unison.Util.Pretty as Pretty
 import qualified Unison.Var as Var
 import Debug.Trace
 
@@ -53,21 +49,6 @@ instance External ExternalFunction where
 
 type Stack = MV.IOVector Value
 
-runtime :: Runtime Symbol
-runtime = Runtime terminate eval
-  where
-  terminate :: forall m. MonadIO m => m ()
-  terminate = pure ()
-  eval :: (MonadIO m, Monoid a) => CL.CodeLookup m Symbol a -> Term.AnnotatedTerm Symbol a -> m (Term Symbol)
-  eval cl term = do
-    liftIO . putStrLn $ Pretty.render 80 (prettyTop mempty term)
-    cenv <- compilationEnv cl term -- in `m`
-    RDone result <- liftIO $
-      run cenv (compile cenv $ Term.amap (const ()) term)
-    decompiled <- liftIO $ decompile result
-    pure decompiled
-
-
 -- compile :: Show e => CompilationEnv e -> Term Symbol -> IR e
 -- compilationEnv :: Monad m
 --   => CL.CodeLookup m Symbol a
@@ -292,8 +273,11 @@ builtinCompilationEnv = CompilationEnv (builtinsMap <> IR.builtins) mempty
       mkC $ f a b
     )
 
-run :: CompilationEnv -> IR -> IO Result
+run :: (R.Reference -> ConstructorId -> [Value] -> IO Value)
-run env ir = do
+    -> CompilationEnv
+    -> IR
+    -> IO Result
+run ioHandler env ir = do
   supply <- newIORef 0
   m0 <- MV.new 256
   MV.set m0 (T "uninitialized")
@@ -301,6 +285,8 @@ run env ir = do
     fresh :: IO Int
     fresh = atomicModifyIORef' supply (\n -> (n + 1, n))
 
+    -- TODO:
+    -- go :: (MonadReader Size m, MonadState Stack m, MonadIO m) => IR -> m Result
     go :: Size -> Stack -> IR -> IO Result
     go size m ir = do
      stackStuff <- traverse (MV.read m) [0..size-1]
@@ -507,7 +493,13 @@ run env ir = do
         writeIORef r result
       go size' m body
 
-  go 0 m0 ir
+  r <- go 0 m0 ir
+  case r of
+    RRequest (Req ref cid vs k) -> do
+      ioResult <- ioHandler ref cid vs
+      s <- push 0 ioResult m0
+      go 1 s k
+    a -> pure a
 
 instance Show ExternalFunction where
   show _ = "ExternalFunction"

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE Rank2Types #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -8,9 +9,13 @@ import           Control.Lens
 import           Control.Concurrent.MVar        ( MVar
                                                 , modifyMVar_
                                                 , readMVar
+                                                , newMVar
+                                                )
+import           Control.Monad.Trans            ( lift )
+import           Control.Monad.IO.Class         ( liftIO )
+import           Control.Monad.Reader           ( ReaderT
+                                                , runReaderT
                                                 )
-import           Control.Monad.IO.Class         ( liftIO, MonadIO )
-import           Control.Monad.Reader           ( ReaderT, ask, MonadReader )
 import           Data.GUID                      ( genText )
 import           Data.List                      ( genericIndex )
 import           Data.Map                       ( Map )
@@ -24,26 +29,27 @@ import           System.IO                      ( Handle
                                                 )
 import           Unison.Symbol
 import qualified Unison.Reference              as R
-import           Unison.Parser                  ( Ann )
 import qualified Unison.Runtime.Rt1            as RT
 import qualified Unison.Runtime.IR             as IR
+import qualified Unison.Term                   as Term
 import qualified Unison.Codebase.CodeLookup    as CL
 import           Unison.DataDeclaration
 import qualified Unison.Var                    as Var
 import           Unison.Var                     ( Var )
 import qualified Unison.Hash                   as Hash
+import qualified Unison.Util.Pretty            as Pretty
+import           Unison.TermPrinter             ( prettyTop )
+import           Unison.Codebase.Runtime        ( Runtime(Runtime) )
 
 type GUID = Text
 type IOState = MVar HandleMap
 
-type UIO a = ReaderT S IO a
+type UIO ann a = ReaderT (S ann) IO a
 type HandleMap = Map GUID Handle
 
-data S = S
+data S a = S
   { _ioState :: IOState
-  , _codeLookup :: CL.CodeLookup IO Symbol Ann
+  , _codeLookup :: CL.CodeLookup IO Symbol a
-  , _size :: RT.Size
-  , _stack :: RT.Stack
   }
 
 makeLenses 'S
@@ -54,39 +60,30 @@ haskellMode mode = case mode of
   "IOMode.Write"     -> WriteMode
   "IOMode.Append"    -> AppendMode
   "IOMode.ReadWrite" -> ReadWriteMode
-  _ -> error . Text.unpack $ "Unknown IO mode " <> mode
+  _                  -> error . Text.unpack $ "Unknown IO mode " <> mode
 
-newUnisonHandle :: Handle -> UIO RT.Value
+newUnisonHandle :: Handle -> UIO a RT.Value
 newUnisonHandle h = do
   t <- liftIO $ genText
   m <- view ioState
   liftIO . modifyMVar_ m $ pure . Map.insert t h
   pure $ IR.T t
 
-deleteUnisonHandle :: Text -> UIO ()
+deleteUnisonHandle :: Text -> UIO a ()
 deleteUnisonHandle h = do
   m <- view ioState
   liftIO . modifyMVar_ m $ pure . Map.delete h
 
-getHaskellHandle :: Text -> UIO (Maybe Handle)
+getHaskellHandle :: Text -> UIO a (Maybe Handle)
 getHaskellHandle h = do
   m <- view ioState
   v <- liftIO $ readMVar m
   pure $ Map.lookup h v
 
-atText :: (MonadIO m, MonadReader S m) => RT.Z -> m Text
+constructorName :: R.Id -> IR.ConstructorId -> UIO a Text
-atText z = ask >>= \t -> liftIO $ RT.att (view size t) z (view stack t)
-
-atData
-  :: (MonadIO m, MonadReader S m)
-  => RT.Z
-  -> m (R.Reference, IR.ConstructorId, [RT.Value])
-atData z = ask >>= \t -> liftIO $ RT.atd (view size t) z (view stack t)
-
-constructorName :: R.Id -> IR.ConstructorId -> UIO Text
 constructorName hash cid = do
   cl <- view codeLookup
-  liftIO $ constructorName' cl hash cid
+  lift $ constructorName' cl hash cid
 
 constructorName'
   :: (Var v, Monad m)
@@ -111,24 +108,44 @@ ioHash = R.Id (Hash.unsafeFromBase58 "abracadabra") 0 1
 ioModeHash :: R.Id
 ioModeHash = R.Id (Hash.unsafeFromBase58 "abracadabra1") 0 1
 
-handleIO :: IR.ConstructorId -> [RT.Z] -> UIO RT.Value
+handleIO' :: S a -> R.Reference -> IR.ConstructorId -> [RT.Value] -> IO RT.Value
+handleIO' s rid cid vs = case rid of
+  R.DerivedId x | x == ioHash -> runReaderT (handleIO cid vs) s
+  _ -> fail $ "This ability is not an I/O ability: " <> show rid
+
+handleIO :: IR.ConstructorId -> [RT.Value] -> UIO a RT.Value
 handleIO cid = (constructorName ioHash cid >>=) . flip go
  where
-  go "IO.openFile" [filePath, ioMode] = do
+  go "IO.openFile" [IR.T filePath, IR.Data _ mode _] = do
-    fp           <- atText filePath
+    n <- constructorName ioModeHash mode
-    (_, mode, _) <- atData ioMode
+    h <- liftIO . openFile (Text.unpack filePath) $ haskellMode n
-    n            <- constructorName ioModeHash mode
-    h            <- liftIO . openFile (Text.unpack fp) $ haskellMode n
     newUnisonHandle h
-  go "IO.closeFile" [handle] = do
+  go "IO.closeFile" [IR.T handle] = do
-    h  <- atText handle
+    hh <- getHaskellHandle handle
-    hh <- getHaskellHandle h
+    liftIO $ maybe (pure ()) hClose hh
-    liftIO $ maybe (fail . Text.unpack $ "Missing file handle " <> h) hClose hh
+    deleteUnisonHandle handle
-    deleteUnisonHandle h
     pure IR.unit
-  go "IO.printLine" [string] = do
+  go "IO.printLine" [IR.T string] = do
-    t <- atText string
+    liftIO . putStrLn $ Text.unpack string
-    liftIO . putStrLn $ Text.unpack t
     pure IR.unit
   go _ _ = undefined
 
+runtime :: Runtime Symbol
+runtime = Runtime terminate eval
+ where
+  terminate :: IO ()
+  terminate = pure ()
+  eval
+    :: (Monoid a)
+    => CL.CodeLookup IO Symbol a
+    -> Term.AnnotatedTerm Symbol a
+    -> IO (Term.Term Symbol)
+  eval cl term = do
+    putStrLn $ Pretty.render 80 (prettyTop mempty term)
+    cenv            <- RT.compilationEnv cl term -- in `m`
+    mmap            <- newMVar mempty
+    RT.RDone result <- RT.run (handleIO' $ S mmap cl)
+                              cenv
+                              (IR.compile cenv $ Term.amap (const ()) term)
+    decompiled <- IR.decompile result
+    pure decompiled

parser-typechecker/tests/Unison/Test/Typechecker.hs

@@ -24,7 +24,7 @@ import qualified Unison.PrettyPrintEnv  as PPE
 import qualified Unison.PrintError      as PrintError
 import           Unison.Result          (pattern Result, Result)
 import qualified Unison.Result          as Result
-import qualified Unison.Runtime.Rt1     as RT
+import qualified Unison.Runtime.Rt1IO   as RT
 import           Unison.Symbol          (Symbol)
 import qualified Unison.Term            as Term
 import           Unison.Term            ( amap )