mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-24 08:47:19 +03:00
Hooked IO up to runtime
This commit is contained in:
Runar Bjarnason
parent
caecff92bc
commit
9d0f4f7339
@ -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
|
||||
. (MonadIO m, Monoid a)
|
||||
=> CL.CodeLookup m v a
|
||||
:: forall a
|
||||
. Monoid 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)
|
||||
=> CL.CodeLookup m v a
|
||||
-> (Reference -> m (Maybe (Term v)))
|
||||
-> Runtime v
|
||||
-> UnisonFile v a
|
||||
-- Map watchName (loc, hash, expression, value, isHit)
|
||||
-> m ([(v, Term v)]
|
||||
, Map v (a, Reference, Term v, Term v, IsCacheHit))
|
||||
-- m (bindings :: [v,Term v], map :: ^^^)
|
||||
evaluateWatches
|
||||
:: forall v a
|
||||
. Var v
|
||||
=> CL.CodeLookup IO v a
|
||||
-> (Reference -> IO (Maybe (Term v)))
|
||||
-> Runtime v
|
||||
-> UnisonFile v a
|
||||
-> IO
|
||||
( [(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
|
||||
m :: Map v (Reference, AnnotatedTerm v a)
|
||||
m = Term.hashComponents (Map.fromList (UF.terms uf <> UF.watches uf))
|
||||
watches = Set.fromList (fst <$> UF.watches uf)
|
||||
unann = Term.amap (const ())
|
||||
let m :: Map v (Reference, AnnotatedTerm v a)
|
||||
m = Term.hashComponents (Map.fromList (UF.terms uf <> UF.watches uf))
|
||||
watches = Set.fromList (fst <$> UF.watches uf)
|
||||
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))
|
||||
Just t' -> pure (v, (r, ABT.annotation t, t', True))
|
||||
case o of
|
||||
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
|
||||
rv :: Map Reference v
|
||||
rv = Map.fromList [(r,v) | (v, (r,_)) <- Map.toList m ]
|
||||
bindings :: [(v, Term v)]
|
||||
bindings = [ (v, unref rv b) | (v, (_,_,b,_)) <- Map.toList m' ]
|
||||
watchVars = [ Term.var() v | v <- toList watches ]
|
||||
bigOl'LetRec = Term.letRec' True bindings (Term.tuple watchVars)
|
||||
cl = void $ CL.fromUnisonFile uf <> code
|
||||
let rv :: Map Reference v
|
||||
rv = Map.fromList [ (r, v) | (v, (r, _)) <- Map.toList m ]
|
||||
bindings :: [(v, Term v)]
|
||||
bindings = [ (v, unref rv b) | (v, (_, _, b, _)) <- Map.toList m' ]
|
||||
watchVars = [ Term.var () v | v <- toList watches ]
|
||||
bigOl'LetRec = Term.letRec' True bindings (Term.tuple watchVars)
|
||||
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
|
||||
Term.Tuple' results -> (mempty, results)
|
||||
Term.LetRecNamed' bs (Term.Tuple' results) -> (bs, results)
|
||||
_ -> fail $ "Evaluation should produce a tuple, but gave: " ++ show out
|
||||
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'
|
||||
let
|
||||
(bindings, results) = case out of
|
||||
Term.Tuple' results -> (mempty, results)
|
||||
Term.LetRecNamed' bs (Term.Tuple' results) -> (bs, results)
|
||||
_ -> fail $ "Evaluation should produce a tuple, but gave: " ++ show out
|
||||
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
|
||||
where
|
||||
go t@(Term.Ref' r@(Reference.DerivedId _)) = case Map.lookup r rv of
|
||||
Nothing -> Nothing
|
||||
Just v -> Just (Term.var (ABT.annotation t) v)
|
||||
go _ = Nothing
|
||||
unref rv t = ABT.visitPure go t
|
||||
where
|
||||
go t@(Term.Ref' r@(Reference.DerivedId _)) = case Map.lookup r rv of
|
||||
Nothing -> Nothing
|
||||
Just v -> Just (Term.var (ABT.annotation t) v)
|
||||
go _ = Nothing
|
||||
|
||||
@ -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
|
||||
= Req R.Reference ConstructorId [Value e] (IR e)
|
||||
data Req e = Req R.Reference ConstructorId [Value e] (IR e)
|
||||
deriving (Eq,Show)
|
||||
|
||||
-- Appends `k2` to the end of the `k` continuation
|
||||
|
||||
@ -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 env ir = do
|
||||
run :: (R.Reference -> ConstructorId -> [Value] -> IO Value)
|
||||
-> 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"
|
||||
|
||||
@ -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
|
||||
, _size :: RT.Size
|
||||
, _stack :: RT.Stack
|
||||
, _codeLookup :: CL.CodeLookup IO Symbol a
|
||||
}
|
||||
|
||||
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
|
||||
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 :: R.Id -> IR.ConstructorId -> UIO a 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
|
||||
fp <- atText filePath
|
||||
(_, mode, _) <- atData ioMode
|
||||
n <- constructorName ioModeHash mode
|
||||
h <- liftIO . openFile (Text.unpack fp) $ haskellMode n
|
||||
go "IO.openFile" [IR.T filePath, IR.Data _ mode _] = do
|
||||
n <- constructorName ioModeHash mode
|
||||
h <- liftIO . openFile (Text.unpack filePath) $ haskellMode n
|
||||
newUnisonHandle h
|
||||
go "IO.closeFile" [handle] = do
|
||||
h <- atText handle
|
||||
hh <- getHaskellHandle h
|
||||
liftIO $ maybe (fail . Text.unpack $ "Missing file handle " <> h) hClose hh
|
||||
deleteUnisonHandle h
|
||||
go "IO.closeFile" [IR.T handle] = do
|
||||
hh <- getHaskellHandle handle
|
||||
liftIO $ maybe (pure ()) hClose hh
|
||||
deleteUnisonHandle handle
|
||||
pure IR.unit
|
||||
go "IO.printLine" [string] = do
|
||||
t <- atText string
|
||||
liftIO . putStrLn $ Text.unpack t
|
||||
go "IO.printLine" [IR.T string] = do
|
||||
liftIO . putStrLn $ Text.unpack string
|
||||
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
|
||||
|
||||
@ -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 )
|
||||
|
||||
Loading…
Reference in New Issue
Block a user