module Unison.Codebase.Editor.HandleInput.RuntimeUtils
( evalUnisonTerm,
evalUnisonTermE,
evalPureUnison,
displayDecompileErrors,
displayResponse,
selectRuntime,
EvalMode (..),
modeProfSpec,
)
where
import Control.Lens
import Control.Monad.Reader (ask)
import Unison.ABT qualified as ABT
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Editor.Output
import Unison.Codebase.Execute qualified as Codebase
import Unison.Codebase.Runtime qualified as Runtime
import Unison.Codebase.Runtime.Profile (ProfileSpec (..))
import Unison.Hashing.V2.Convert qualified as Hashing
import Unison.Parser.Ann (Ann (..))
import Unison.Parser.Ann qualified as Ann
import Unison.Prelude
import Unison.PrettyPrintEnv qualified as PPE
import Unison.Reference qualified as Reference
import Unison.Referent qualified as Referent
import Unison.Runtime (Error)
import Unison.Runtime.Decompile (DecompError)
import Unison.Runtime.Interface (Runtime, renderDecompError)
import Unison.Symbol (Symbol)
import Unison.Term (Term)
import Unison.Term qualified as Term
import Unison.Util.Pretty qualified as P
import Unison.WatchKind qualified as WK
data EvalMode = Sandboxed | Permissive ProfileSpec
selectRuntime :: EvalMode -> Cli (Runtime Symbol)
selectRuntime :: EvalMode -> Cli (Runtime Symbol)
selectRuntime EvalMode
mode =
Cli Env
forall r (m :: * -> *). MonadReader r m => m r
ask Cli Env -> (Env -> Runtime Symbol) -> Cli (Runtime Symbol)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Cli.Env {Runtime Symbol
runtime :: Runtime Symbol
$sel:runtime:Env :: Env -> Runtime Symbol
runtime, Runtime Symbol
sandboxedRuntime :: Runtime Symbol
$sel:sandboxedRuntime:Env :: Env -> Runtime Symbol
sandboxedRuntime} -> case EvalMode
mode of
Permissive ProfileSpec
_ -> Runtime Symbol
runtime
EvalMode
Sandboxed -> Runtime Symbol
sandboxedRuntime
modeProfSpec :: EvalMode -> ProfileSpec
modeProfSpec :: EvalMode -> ProfileSpec
modeProfSpec EvalMode
Sandboxed = ProfileSpec
NoProf
modeProfSpec (Permissive ProfileSpec
prof) = ProfileSpec
prof
displayDecompileErrors :: [DecompError] -> Cli ()
displayDecompileErrors :: [DecompError] -> Cli ()
displayDecompileErrors =
Output -> Cli ()
Cli.respond (Output -> Cli ())
-> ([DecompError] -> Output) -> [DecompError] -> Cli ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pretty ColorText -> Output
PrintMessage (Pretty ColorText -> Output)
-> ([DecompError] -> Pretty ColorText) -> [DecompError] -> Output
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pretty ColorText] -> Pretty ColorText
forall {s}.
(Item s ~ Char, IsString s, ListLike s Char) =>
[Pretty s] -> Pretty s
msg ([Pretty ColorText] -> Pretty ColorText)
-> ([DecompError] -> [Pretty ColorText])
-> [DecompError]
-> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DecompError -> Pretty ColorText)
-> [DecompError] -> [Pretty ColorText]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Pretty ColorText -> Pretty ColorText)
-> (DecompError -> Pretty ColorText)
-> DecompError
-> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Pretty ColorText -> Pretty ColorText)
-> (DecompError -> Pretty ColorText)
-> DecompError
-> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecompError -> Pretty ColorText
renderDecompError)
where
msg :: [Pretty s] -> Pretty s
msg [Pretty s]
em = do
[Pretty s] -> Pretty s
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines ([Pretty s] -> Pretty s) -> [Pretty s] -> Pretty s
forall a b. (a -> b) -> a -> b
$
[ Pretty s -> Pretty s
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.warnCallout Pretty s
"I had trouble decompiling some results.",
Pretty s
"",
Pretty s
"The following errors were encountered:"
]
[Pretty s] -> [Pretty s] -> [Pretty s]
forall a. [a] -> [a] -> [a]
++ [Pretty s]
em
evalUnisonTermE ::
EvalMode ->
PPE.PrettyPrintEnv ->
Bool ->
Term Symbol Ann ->
Cli (Either Error (Term Symbol Ann))
evalUnisonTermE :: EvalMode
-> PrettyPrintEnv
-> Bool
-> Term Symbol Ann
-> Cli (Either Error (Term Symbol Ann))
evalUnisonTermE EvalMode
mode PrettyPrintEnv
ppe Bool
useCache Term Symbol Ann
tm = do
Cli.Env {Codebase IO Symbol Ann
codebase :: Codebase IO Symbol Ann
$sel:codebase:Env :: Env -> Codebase IO Symbol Ann
codebase} <- Cli Env
forall r (m :: * -> *). MonadReader r m => m r
ask
Runtime Symbol
theRuntime <- EvalMode -> Cli (Runtime Symbol)
selectRuntime EvalMode
mode
let prof :: ProfileSpec
prof = EvalMode -> ProfileSpec
modeProfSpec EvalMode
mode
let watchCache :: Reference.Id -> IO (Maybe (Term Symbol ()))
watchCache :: Id -> IO (Maybe (Term Symbol ()))
watchCache Id
ref = do
Maybe (Term Symbol Ann)
maybeTerm <- Codebase IO Symbol Ann
-> Transaction (Maybe (Term Symbol Ann))
-> IO (Maybe (Term Symbol Ann))
forall (m :: * -> *) v a b.
MonadIO m =>
Codebase m v a -> Transaction b -> m b
Codebase.runTransaction Codebase IO Symbol Ann
codebase (Codebase IO Symbol Ann
-> Id -> Transaction (Maybe (Term Symbol Ann))
forall (m :: * -> *) v a.
Codebase m v a -> Id -> Transaction (Maybe (Term v a))
Codebase.lookupWatchCache Codebase IO Symbol Ann
codebase Id
ref)
Maybe (Term Symbol ()) -> IO (Maybe (Term Symbol ()))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Ann -> ()) -> Term Symbol Ann -> Term Symbol ()
forall v a a2. Ord v => (a -> a2) -> Term v a -> Term v a2
Term.amap (\(Ann
_ :: Ann) -> ()) (Term Symbol Ann -> Term Symbol ())
-> Maybe (Term Symbol Ann) -> Maybe (Term Symbol ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Term Symbol Ann)
maybeTerm)
let cache :: Id -> IO (Maybe (Term Symbol ()))
cache = if Bool
useCache then Id -> IO (Maybe (Term Symbol ()))
watchCache else Id -> IO (Maybe (Term Symbol ()))
forall v. Id -> IO (Maybe (Term v))
Runtime.noCache
Either Error (Response DecompError, Term Symbol ())
r <- IO (Either Error (Response DecompError, Term Symbol ()))
-> Cli (Either Error (Response DecompError, Term Symbol ()))
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (CodeLookup Symbol IO Ann
-> (Id -> IO (Maybe (Term Symbol ())))
-> PrettyPrintEnv
-> ProfileSpec
-> Runtime Symbol
-> Term Symbol Ann
-> IO (Either Error (Response DecompError, Term Symbol ()))
forall v a e e'.
(Var v, Monoid a) =>
CodeLookup v IO a
-> (Id -> IO (Maybe (Term v)))
-> PrettyPrintEnv
-> ProfileSpec
-> Runtime e e' v
-> Term v a
-> IO (Either e (Response e', Term v))
Runtime.evaluateTerm' (Codebase IO Symbol Ann -> CodeLookup Symbol IO Ann
forall (m :: * -> *).
MonadIO m =>
Codebase m Symbol Ann -> CodeLookup Symbol m Ann
Codebase.codebaseToCodeLookup Codebase IO Symbol Ann
codebase) Id -> IO (Maybe (Term Symbol ()))
cache PrettyPrintEnv
ppe ProfileSpec
prof Runtime Symbol
theRuntime Term Symbol Ann
tm)
Bool -> Cli () -> Cli ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
useCache do
case Either Error (Response DecompError, Term Symbol ())
r of
Right (Runtime.DecompErrs [DecompError]
errs, Term Symbol ()
_)
| Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [DecompError] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DecompError]
errs -> [DecompError] -> Cli ()
displayDecompileErrors [DecompError]
errs
Right (Response DecompError
resp, Term Symbol ()
tmr) -> do
Transaction () -> Cli ()
forall a. Transaction a -> Cli a
Cli.runTransaction do
WatchKind -> Id -> Term Symbol Ann -> Transaction ()
Codebase.putWatch
WatchKind
forall a. (Eq a, IsString a) => a
WK.RegularWatch
(Term Symbol Ann -> Id
forall v a. Var v => Term v a -> Id
Hashing.hashClosedTerm Term Symbol Ann
tm)
((() -> Ann) -> Term Symbol () -> Term Symbol Ann
forall v a a2. Ord v => (a -> a2) -> Term v a -> Term v a2
Term.amap (Ann -> () -> Ann
forall a b. a -> b -> a
const Ann
Ann.External) Term Symbol ()
tmr)
Response DecompError -> Cli ()
displayResponse Response DecompError
resp
Left Error
_ -> () -> Cli ()
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Either Error (Term Symbol Ann)
-> Cli (Either Error (Term Symbol Ann))
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error (Term Symbol Ann)
-> Cli (Either Error (Term Symbol Ann)))
-> Either Error (Term Symbol Ann)
-> Cli (Either Error (Term Symbol Ann))
forall a b. (a -> b) -> a -> b
$ Either Error (Response DecompError, Term Symbol ())
r Either Error (Response DecompError, Term Symbol ())
-> ((Response DecompError, Term Symbol ()) -> Term Symbol Ann)
-> Either Error (Term Symbol Ann)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (() -> Ann) -> Term Symbol () -> Term Symbol Ann
forall v a a2. Ord v => (a -> a2) -> Term v a -> Term v a2
Term.amap (\() -> Ann
Ann.External) (Term Symbol () -> Term Symbol Ann)
-> ((Response DecompError, Term Symbol ()) -> Term Symbol ())
-> (Response DecompError, Term Symbol ())
-> Term Symbol Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Response DecompError, Term Symbol ()) -> Term Symbol ()
forall a b. (a, b) -> b
snd
displayResponse :: Runtime.Response DecompError -> Cli ()
displayResponse :: Response DecompError -> Cli ()
displayResponse (Runtime.DecompErrs [DecompError]
errs)
| Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [DecompError] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DecompError]
errs = [DecompError] -> Cli ()
displayDecompileErrors [DecompError]
errs
displayResponse (Runtime.Profile Pretty ColorText
prof) = Output -> Cli ()
Cli.respond (Pretty ColorText -> Output
PrintMessage Pretty ColorText
msg)
where
msg :: Pretty ColorText
msg = [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines [Pretty ColorText
"Profile Results:", Pretty ColorText
""] Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
prof
displayResponse Response DecompError
_ = () -> Cli ()
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
evalUnisonTerm ::
EvalMode ->
PPE.PrettyPrintEnv ->
Bool ->
Term Symbol Ann ->
Cli (Term Symbol Ann)
evalUnisonTerm :: EvalMode
-> PrettyPrintEnv
-> Bool
-> Term Symbol Ann
-> Cli (Term Symbol Ann)
evalUnisonTerm EvalMode
mode PrettyPrintEnv
ppe Bool
useCache Term Symbol Ann
tm =
EvalMode
-> PrettyPrintEnv
-> Bool
-> Term Symbol Ann
-> Cli (Either Error (Term Symbol Ann))
evalUnisonTermE EvalMode
mode PrettyPrintEnv
ppe Bool
useCache Term Symbol Ann
tm Cli (Either Error (Term Symbol Ann))
-> (Cli (Either Error (Term Symbol Ann)) -> Cli (Term Symbol Ann))
-> Cli (Term Symbol Ann)
forall a b. a -> (a -> b) -> b
& (Error -> Cli (Term Symbol Ann))
-> Cli (Either Error (Term Symbol Ann)) -> Cli (Term Symbol Ann)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> m (Either a b) -> m b
onLeftM (Output -> Cli (Term Symbol Ann)
forall a. Output -> Cli a
Cli.returnEarly (Output -> Cli (Term Symbol Ann))
-> (Error -> Output) -> Error -> Cli (Term Symbol Ann)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pretty ColorText -> Pretty ColorText) -> Error -> Output
EvaluationFailure Pretty ColorText -> Pretty ColorText
forall a. a -> a
id)
evalPureUnison ::
PPE.PrettyPrintEnv ->
Bool ->
Term Symbol Ann ->
Cli (Either Error (Term Symbol Ann))
evalPureUnison :: PrettyPrintEnv
-> Bool -> Term Symbol Ann -> Cli (Either Error (Term Symbol Ann))
evalPureUnison PrettyPrintEnv
ppe Bool
useCache Term Symbol Ann
tm =
EvalMode
-> PrettyPrintEnv
-> Bool
-> Term Symbol Ann
-> Cli (Either Error (Term Symbol Ann))
evalUnisonTermE EvalMode
mode PrettyPrintEnv
ppe Bool
useCache Term Symbol Ann
tm'
where
mode :: EvalMode
mode = ProfileSpec -> EvalMode
Permissive ProfileSpec
NoProf
tm' :: Term Symbol Ann
tm' =
Ann
-> Term Symbol Ann
-> Term Symbol Ann
-> Term Symbol Ann
-> Term Symbol Ann
forall v a vt at ap.
Ord v =>
a
-> Term2 vt at ap v a
-> Term2 vt at ap v a
-> Term2 vt at ap v a
-> Term2 vt at ap v a
Term.iff
Ann
a
(Term Symbol Ann -> [Term Symbol Ann] -> Term Symbol Ann
forall v a vt at ap.
(Ord v, Semigroup a) =>
Term2 vt at ap v a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
Term.apps' (Ann -> Text -> Term Symbol Ann
forall v a vt at ap. Ord v => a -> Text -> Term2 vt at ap v a
Term.builtin Ann
a Text
"validateSandboxed") [Term Symbol Ann
allow, Ann -> Term Symbol Ann -> Term Symbol Ann
forall v a vt at ap.
Var v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.delay Ann
a Term Symbol Ann
tm])
Term Symbol Ann
tm
(Ann -> Term Symbol Ann -> Term Symbol Ann -> Term Symbol Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app Ann
a (Ann -> Text -> Term Symbol Ann
forall v a vt at ap. Ord v => a -> Text -> Term2 vt at ap v a
Term.builtin Ann
a Text
"bug") (Ann -> Text -> Term Symbol Ann
forall v a vt at ap. Ord v => a -> Text -> Term2 vt at ap v a
Term.text Ann
a Text
msg))
a :: Ann
a = Term Symbol Ann -> Ann
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term Symbol Ann
tm
allow :: Term Symbol Ann
allow =
Ann -> [Term Symbol Ann] -> Term Symbol Ann
forall v a vt at ap.
Ord v =>
a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
Term.list
Ann
a
[ Ann -> Referent -> Term Symbol Ann
forall v a vt at ap. Ord v => a -> Referent -> Term2 vt at ap v a
Term.termLink Ann
a (TermReference -> Referent
Referent.Ref (Text -> TermReference
forall t h. t -> Reference' t h
Reference.Builtin Text
"Debug.toText")),
Ann -> Referent -> Term Symbol Ann
forall v a vt at ap. Ord v => a -> Referent -> Term2 vt at ap v a
Term.termLink Ann
a (TermReference -> Referent
Referent.Ref (Text -> TermReference
forall t h. t -> Reference' t h
Reference.Builtin Text
"Value.value"))
]
msg :: Text
msg = Text
"pure code can't perform I/O"