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
runtime :: Env -> Runtime Symbol
runtime, Runtime Symbol
sandboxedRuntime :: Runtime Symbol
sandboxedRuntime :: 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
Literal (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

-- | Evaluate a single closed definition.
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} <- Cli Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  theRuntime <- selectRuntime mode
  let prof = EvalMode -> ProfileSpec
modeProfSpec EvalMode
mode

  let watchCache :: Reference.Id -> IO (Maybe (Term Symbol ()))
      watchCache Id
ref = do
        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)
        pure (Term.amap (\(Ann
_ :: Ann) -> ()) <$> maybeTerm)

  let 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
  r <- liftIO (Runtime.evaluateTerm' (Codebase.codebaseToCodeLookup codebase) cache ppe prof theRuntime tm)
  when useCache do
    case r of
      Right (Runtime.DecompErrs [DecompError]
errs, Term Symbol ()
_)
        -- don't cache when there were errors
        | 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 ()
  pure $ r <&> Term.amap (\() -> Ann
Ann.External) . 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
Literal 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 ()

-- | Evaluate a single closed definition.
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"