-- | Execute a computation of type '{IO} () that has been previously added to
-- the codebase, without setting up an interactive environment.
--
-- This allows one to run standalone applications implemented in the Unison
-- language.
module Unison.Codebase.Execute
  ( execute,
    codebaseToCodeLookup,
  )
where

import Control.Exception (finally)
import Control.Monad.Except
import U.Codebase.Sqlite.Project (Project (..))
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
import U.Codebase.Sqlite.Queries qualified as Q
import Unison.Builtin qualified as Builtin
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Branch.Names qualified as Branch
import Unison.Codebase.CodeLookup qualified as CL
import Unison.Codebase.MainTerm (getMainTerm)
import Unison.Codebase.MainTerm qualified as MainTerm
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.ProjectPath (ProjectPathG (..))
import Unison.Codebase.ProjectPath qualified as PP
import Unison.Codebase.Runtime (Runtime)
import Unison.Codebase.Runtime qualified as Runtime
import Unison.Codebase.Type (Codebase (..))
import Unison.HashQualified qualified as HQ
import Unison.Parser.Ann (Ann)
import Unison.Parser.Ann qualified as Parser
import Unison.Prelude
import Unison.PrettyPrintEnv qualified as PPE
import Unison.Runtime.IOSource qualified as IOSource
import Unison.Symbol (Symbol)
import Unison.Syntax.HashQualified qualified as HQ (toText)
import Unison.Util.Pretty qualified as P

execute ::
  Codebase.Codebase IO Symbol Ann ->
  Runtime Symbol ->
  PP.ProjectPathNames ->
  IO (Either Runtime.Error ())
execute :: Codebase IO Symbol Ann
-> Runtime Symbol -> ProjectPathNames -> IO (Either Error ())
execute Codebase IO Symbol Ann
codebase Runtime Symbol
runtime ProjectPathNames
mainPath =
  (IO (Either Error ()) -> IO () -> IO (Either Error ())
forall a b. IO a -> IO b -> IO a
`finally` Runtime Symbol -> IO ()
forall v. Runtime v -> IO ()
Runtime.terminate Runtime Symbol
runtime) (IO (Either Error ()) -> IO (Either Error ()))
-> (ExceptT Error IO () -> IO (Either Error ()))
-> ExceptT Error IO ()
-> IO (Either Error ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT Error IO () -> IO (Either Error ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Error IO () -> IO (Either Error ()))
-> ExceptT Error IO () -> IO (Either Error ())
forall a b. (a -> b) -> a -> b
$ do
    (Project
project, ProjectBranch
branch) <- IO (Either Error (Project, ProjectBranch))
-> ExceptT Error IO (Project, ProjectBranch)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either Error (Project, ProjectBranch))
 -> ExceptT Error IO (Project, ProjectBranch))
-> IO (Either Error (Project, ProjectBranch))
-> ExceptT Error IO (Project, ProjectBranch)
forall a b. (a -> b) -> a -> b
$ (Codebase IO Symbol Ann
-> ((forall void.
     Either Error (Project, ProjectBranch) -> Transaction void)
    -> Transaction (Either Error (Project, ProjectBranch)))
-> IO (Either Error (Project, ProjectBranch))
forall (m :: * -> *) v a b.
MonadIO m =>
Codebase m v a
-> ((forall void. b -> Transaction void) -> Transaction b) -> m b
Codebase.runTransactionWithRollback Codebase IO Symbol Ann
codebase) \forall void.
Either Error (Project, ProjectBranch) -> Transaction void
rollback -> do
      Project
project <- ProjectName -> Transaction (Maybe Project)
Q.loadProjectByName ProjectPathNames
mainPath.project Transaction (Maybe Project)
-> Transaction Project -> Transaction Project
forall (m :: * -> *) a. Monad m => m (Maybe a) -> m a -> m a
`whenNothingM` Either Error (Project, ProjectBranch) -> Transaction Project
forall void.
Either Error (Project, ProjectBranch) -> Transaction void
rollback (Error -> Either Error (Project, ProjectBranch)
forall a b. a -> Either a b
Left (Error -> Either Error (Project, ProjectBranch))
-> (Text -> Error) -> Text -> Either Error (Project, ProjectBranch)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Error
forall s. IsString s => Text -> Pretty s
P.text (Text -> Either Error (Project, ProjectBranch))
-> Text -> Either Error (Project, ProjectBranch)
forall a b. (a -> b) -> a -> b
$ (Text
"Project not found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> forall target source. From source target => source -> target
into @Text ProjectPathNames
mainPath.project))
      ProjectBranch
branch <- ProjectId -> ProjectBranchName -> Transaction (Maybe ProjectBranch)
Q.loadProjectBranchByName Project
project.projectId ProjectPathNames
mainPath.branch Transaction (Maybe ProjectBranch)
-> Transaction ProjectBranch -> Transaction ProjectBranch
forall (m :: * -> *) a. Monad m => m (Maybe a) -> m a -> m a
`whenNothingM` Either Error (Project, ProjectBranch) -> Transaction ProjectBranch
forall void.
Either Error (Project, ProjectBranch) -> Transaction void
rollback (Error -> Either Error (Project, ProjectBranch)
forall a b. a -> Either a b
Left (Error -> Either Error (Project, ProjectBranch))
-> (Text -> Error) -> Text -> Either Error (Project, ProjectBranch)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Error
forall s. IsString s => Text -> Pretty s
P.text (Text -> Either Error (Project, ProjectBranch))
-> Text -> Either Error (Project, ProjectBranch)
forall a b. (a -> b) -> a -> b
$ (Text
"Branch not found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> forall target source. From source target => source -> target
into @Text ProjectPathNames
mainPath.branch))
      Either Error (Project, ProjectBranch)
-> Transaction (Either Error (Project, ProjectBranch))
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error (Project, ProjectBranch)
 -> Transaction (Either Error (Project, ProjectBranch)))
-> ((Project, ProjectBranch)
    -> Either Error (Project, ProjectBranch))
-> (Project, ProjectBranch)
-> Transaction (Either Error (Project, ProjectBranch))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Project, ProjectBranch) -> Either Error (Project, ProjectBranch)
forall a b. b -> Either a b
Right ((Project, ProjectBranch)
 -> Transaction (Either Error (Project, ProjectBranch)))
-> (Project, ProjectBranch)
-> Transaction (Either Error (Project, ProjectBranch))
forall a b. (a -> b) -> a -> b
$ (Project
project, ProjectBranch
branch)
    Names
projectRootNames <- (Branch IO -> Names)
-> ExceptT Error IO (Branch IO) -> ExceptT Error IO Names
forall a b. (a -> b) -> ExceptT Error IO a -> ExceptT Error IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Branch0 IO -> Names
forall (m :: * -> *). Branch0 m -> Names
Branch.toNames (Branch0 IO -> Names)
-> (Branch IO -> Branch0 IO) -> Branch IO -> Names
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Branch IO -> Branch0 IO
forall (m :: * -> *). Branch m -> Branch0 m
Branch.head) (ExceptT Error IO (Branch IO) -> ExceptT Error IO Names)
-> (IO (Branch IO) -> ExceptT Error IO (Branch IO))
-> IO (Branch IO)
-> ExceptT Error IO Names
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Branch IO) -> ExceptT Error IO (Branch IO)
forall a. IO a -> ExceptT Error IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Branch IO) -> ExceptT Error IO Names)
-> IO (Branch IO) -> ExceptT Error IO Names
forall a b. (a -> b) -> a -> b
$ Codebase IO Symbol Ann
-> ProjectId -> ProjectBranchId -> IO (Branch IO)
forall (m :: * -> *) v a.
MonadIO m =>
Codebase m v a -> ProjectId -> ProjectBranchId -> m (Branch m)
Codebase.expectProjectBranchRoot Codebase IO Symbol Ann
codebase Project
project.projectId ProjectBranch
branch.branchId
    let loadTypeOfTerm :: Reference -> Transaction (Maybe (Type Symbol Ann))
loadTypeOfTerm = Codebase IO Symbol Ann
-> Reference -> Transaction (Maybe (Type Symbol Ann))
forall a (m :: * -> *).
BuiltinAnnotation a =>
Codebase m Symbol a
-> Reference -> Transaction (Maybe (Type Symbol a))
Codebase.getTypeOfTerm Codebase IO Symbol Ann
codebase
    let mainType :: Type Symbol Ann
mainType = Runtime Symbol -> Type Symbol Ann
forall v. Runtime v -> Type v Ann
Runtime.mainType Runtime Symbol
runtime
    HashQualified Name
mainName <- case Path -> Maybe Name
Path.toName (ProjectPathNames
mainPath ProjectPathNames -> Getting Path ProjectPathNames Path -> Path
forall s a. s -> Getting a s a -> a
^. Getting Path ProjectPathNames Path
forall p b (f :: * -> *).
Functor f =>
(Path -> f Path) -> ProjectPathG p b -> f (ProjectPathG p b)
PP.path_) of
      Just Name
n -> HashQualified Name -> ExceptT Error IO (HashQualified Name)
forall a. a -> ExceptT Error IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> HashQualified Name
forall n. n -> HashQualified n
HQ.NameOnly Name
n)
      Maybe Name
Nothing -> Error -> ExceptT Error IO (HashQualified Name)
forall a. Error -> ExceptT Error IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error
"Path must lead to an executable term: " Error -> Error -> Error
forall a. Semigroup a => a -> a -> a
<> Text -> Error
forall s. IsString s => Text -> Pretty s
P.text (Path -> Text
Path.toText (ProjectPathNames -> Path
forall p b. ProjectPathG p b -> Path
PP.path ProjectPathNames
mainPath)))

    MainTerm Symbol
mt <- IO (MainTerm Symbol) -> ExceptT Error IO (MainTerm Symbol)
forall a. IO a -> ExceptT Error IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MainTerm Symbol) -> ExceptT Error IO (MainTerm Symbol))
-> IO (MainTerm Symbol) -> ExceptT Error IO (MainTerm Symbol)
forall a b. (a -> b) -> a -> b
$ Codebase IO Symbol Ann
-> Transaction (MainTerm Symbol) -> IO (MainTerm Symbol)
forall (m :: * -> *) v a b.
MonadIO m =>
Codebase m v a -> Transaction b -> m b
Codebase.runTransaction Codebase IO Symbol Ann
codebase (Transaction (MainTerm Symbol) -> IO (MainTerm Symbol))
-> Transaction (MainTerm Symbol) -> IO (MainTerm Symbol)
forall a b. (a -> b) -> a -> b
$ (Reference -> Transaction (Maybe (Type Symbol Ann)))
-> Names
-> HashQualified Name
-> Type Symbol Ann
-> Transaction (MainTerm Symbol)
forall (m :: * -> *) v.
(Monad m, Var v) =>
(Reference -> m (Maybe (Type v Ann)))
-> Names -> HashQualified Name -> Type v Ann -> m (MainTerm v)
getMainTerm Reference -> Transaction (Maybe (Type Symbol Ann))
loadTypeOfTerm Names
projectRootNames HashQualified Name
mainName Type Symbol Ann
mainType
    case MainTerm Symbol
mt of
      MainTerm.NotFound HashQualified Name
s -> Error -> ExceptT Error IO ()
forall a. Error -> ExceptT Error IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error
"Not found: " Error -> Error -> Error
forall a. Semigroup a => a -> a -> a
<> Text -> Error
forall s. IsString s => Text -> Pretty s
P.text (HashQualified Name -> Text
HQ.toText HashQualified Name
s))
      MainTerm.BadType HashQualified Name
s Maybe (Type Symbol Ann)
_ -> Error -> ExceptT Error IO ()
forall a. Error -> ExceptT Error IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> Error
forall s. IsString s => Text -> Pretty s
P.text (HashQualified Name -> Text
HQ.toText HashQualified Name
s) Error -> Error -> Error
forall a. Semigroup a => a -> a -> a
<> Error
" is not of type '{IO} ()")
      MainTerm.Success HashQualified Name
_ Term Symbol Ann
tm Type Symbol Ann
_ -> do
        let codeLookup :: CodeLookup Symbol IO Ann
codeLookup = Codebase IO Symbol Ann -> CodeLookup Symbol IO Ann
forall (m :: * -> *).
MonadIO m =>
Codebase m Symbol Ann -> CodeLookup Symbol m Ann
codebaseToCodeLookup Codebase IO Symbol Ann
codebase
            ppe :: PrettyPrintEnv
ppe = PrettyPrintEnv
PPE.empty
        (IO (Either Error ([Error], Term Symbol))
-> ExceptT Error IO (Either Error ([Error], Term Symbol))
forall a. IO a -> ExceptT Error IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Error ([Error], Term Symbol))
 -> ExceptT Error IO (Either Error ([Error], Term Symbol)))
-> IO (Either Error ([Error], Term Symbol))
-> ExceptT Error IO (Either Error ([Error], Term Symbol))
forall a b. (a -> b) -> a -> b
$ CodeLookup Symbol IO Ann
-> PrettyPrintEnv
-> Runtime Symbol
-> Term Symbol Ann
-> IO (Either Error ([Error], Term Symbol))
forall v a.
(Var v, Monoid a) =>
CodeLookup v IO a
-> PrettyPrintEnv
-> Runtime v
-> Term v a
-> IO (Either Error ([Error], Term v))
Runtime.evaluateTerm CodeLookup Symbol IO Ann
codeLookup PrettyPrintEnv
ppe Runtime Symbol
runtime Term Symbol Ann
tm) ExceptT Error IO (Either Error ([Error], Term Symbol))
-> (Either Error ([Error], Term Symbol) -> ExceptT Error IO ())
-> ExceptT Error IO ()
forall a b.
ExceptT Error IO a
-> (a -> ExceptT Error IO b) -> ExceptT Error IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Left Error
err -> Error -> ExceptT Error IO ()
forall a. Error -> ExceptT Error IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Error
err
          Right ([Error], Term Symbol)
_ -> () -> ExceptT Error IO ()
forall a. a -> ExceptT Error IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

codebaseToCodeLookup :: (MonadIO m) => Codebase m Symbol Parser.Ann -> CL.CodeLookup Symbol m Parser.Ann
codebaseToCodeLookup :: forall (m :: * -> *).
MonadIO m =>
Codebase m Symbol Ann -> CodeLookup Symbol m Ann
codebaseToCodeLookup Codebase m Symbol Ann
c =
  (Id -> m (Maybe (Term Symbol Ann)))
-> (Id -> m (Maybe (Decl Symbol Ann))) -> CodeLookup Symbol m Ann
forall v (m :: * -> *) a.
(Id -> m (Maybe (Term v a)))
-> (Id -> m (Maybe (Decl v a))) -> CodeLookup v m a
CL.CodeLookup (Codebase m Symbol Ann
-> Transaction (Maybe (Term Symbol Ann))
-> m (Maybe (Term Symbol Ann))
forall (m :: * -> *) v a b.
MonadIO m =>
Codebase m v a -> Transaction b -> m b
Codebase.runTransaction Codebase m Symbol Ann
c (Transaction (Maybe (Term Symbol Ann))
 -> m (Maybe (Term Symbol Ann)))
-> (Id -> Transaction (Maybe (Term Symbol Ann)))
-> Id
-> m (Maybe (Term Symbol Ann))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Codebase m Symbol Ann
-> Id -> Transaction (Maybe (Term Symbol Ann))
forall (m :: * -> *) v a.
Codebase m v a -> Id -> Transaction (Maybe (Term v a))
getTerm Codebase m Symbol Ann
c) (Codebase m Symbol Ann
-> Transaction (Maybe (Decl Symbol Ann))
-> m (Maybe (Decl Symbol Ann))
forall (m :: * -> *) v a b.
MonadIO m =>
Codebase m v a -> Transaction b -> m b
Codebase.runTransaction Codebase m Symbol Ann
c (Transaction (Maybe (Decl Symbol Ann))
 -> m (Maybe (Decl Symbol Ann)))
-> (Id -> Transaction (Maybe (Decl Symbol Ann)))
-> Id
-> m (Maybe (Decl Symbol Ann))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Codebase m Symbol Ann
-> Id -> Transaction (Maybe (Decl Symbol Ann))
forall (m :: * -> *) v a.
Codebase m v a -> Id -> Transaction (Maybe (Decl v a))
getTypeDeclaration Codebase m Symbol Ann
c)
    CodeLookup Symbol m Ann
-> CodeLookup Symbol m Ann -> CodeLookup Symbol m Ann
forall a. Semigroup a => a -> a -> a
<> CodeLookup Symbol m Ann
forall (m :: * -> *). Applicative m => CodeLookup Symbol m Ann
Builtin.codeLookup
    CodeLookup Symbol m Ann
-> CodeLookup Symbol m Ann -> CodeLookup Symbol m Ann
forall a. Semigroup a => a -> a -> a
<> CodeLookup Symbol m Ann
forall (m :: * -> *). Applicative m => CodeLookup Symbol m Ann
IOSource.codeLookupM