{-# LANGUAGE PartialTypeSignatures #-}

-- | Find a computation of type '{IO} () in the codebase.
module Unison.Codebase.MainTerm where

import Data.List.NonEmpty qualified as NEList
import Data.Set.NonEmpty (NESet)
import Data.Set.NonEmpty qualified as NESet
import Unison.Builtin.Decls qualified as DD
import Unison.HashQualified qualified as HQ
import Unison.Name (Name)
import Unison.Names qualified as Names
import Unison.NamesWithHistory qualified as Names
import Unison.Parser.Ann (Ann)
import Unison.Parser.Ann qualified as Parser.Ann
import Unison.Prelude
import Unison.Reference (Reference)
import Unison.Referent qualified as Referent
import Unison.Term (Term)
import Unison.Term qualified as Term
import Unison.Type (Type)
import Unison.Type qualified as Type
import Unison.Typechecker qualified as Typechecker
import Unison.Var (Var)
import Unison.Var qualified as Var

data MainTerm v
  = NotFound (HQ.HashQualified Name)
  | BadType (HQ.HashQualified Name) (Maybe (Type v Ann))
  | Success (HQ.HashQualified Name) (Term v Ann) (Type v Ann)

getMainTerm ::
  (Monad m, Var v) =>
  (Reference -> m (Maybe (Type v Ann))) ->
  Names.Names ->
  HQ.HashQualified Name ->
  Type.Type v Ann ->
  m (MainTerm v)
getMainTerm :: forall (m :: * -> *) v.
(Monad m, Var v) =>
(Reference -> m (Maybe (Type v Ann)))
-> Names -> HashQualified Name -> Type v Ann -> m (MainTerm v)
getMainTerm Reference -> m (Maybe (Type v Ann))
loadTypeOfTerm Names
parseNames HashQualified Name
mainName Type v Ann
mainType = do
  let refs :: Set Referent
refs = SearchType -> HashQualified Name -> Names -> Set Referent
Names.lookupHQTerm SearchType
Names.IncludeSuffixes HashQualified Name
mainName Names
parseNames
  let a :: Ann
a = Ann
Parser.Ann.External
  case Set Referent -> [Referent]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set Referent
refs of
    [] -> MainTerm v -> m (MainTerm v)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashQualified Name -> MainTerm v
forall v. HashQualified Name -> MainTerm v
NotFound HashQualified Name
mainName)
    [Referent.Ref Reference
ref] -> do
      Maybe (Type v Ann)
typ <- Reference -> m (Maybe (Type v Ann))
loadTypeOfTerm Reference
ref
      case Maybe (Type v Ann)
typ of
        Just Type v Ann
typ ->
          if Type v Ann -> Type v Ann -> Bool
forall v loc. Var v => Type v loc -> Type v loc -> Bool
Typechecker.fitsScheme Type v Ann
typ Type v Ann
mainType
            then do
              let tm :: Term v Ann
tm = Ann -> Ann -> Term v Ann -> Term v Ann
forall v a. Var v => a -> a -> Term v a -> Term v a
DD.forceTerm Ann
a Ann
a (Ann -> Reference -> Term v Ann
forall v a vt at ap. Ord v => a -> Reference -> Term2 vt at ap v a
Term.ref Ann
a Reference
ref)
              MainTerm v -> m (MainTerm v)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
return (HashQualified Name -> Term v Ann -> Type v Ann -> MainTerm v
forall v.
HashQualified Name -> Term v Ann -> Type v Ann -> MainTerm v
Success HashQualified Name
mainName Term v Ann
tm Type v Ann
typ)
            else MainTerm v -> m (MainTerm v)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashQualified Name -> Maybe (Type v Ann) -> MainTerm v
forall v. HashQualified Name -> Maybe (Type v Ann) -> MainTerm v
BadType HashQualified Name
mainName (Maybe (Type v Ann) -> MainTerm v)
-> Maybe (Type v Ann) -> MainTerm v
forall a b. (a -> b) -> a -> b
$ Type v Ann -> Maybe (Type v Ann)
forall a. a -> Maybe a
Just Type v Ann
typ)
        Maybe (Type v Ann)
_ -> MainTerm v -> m (MainTerm v)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashQualified Name -> Maybe (Type v Ann) -> MainTerm v
forall v. HashQualified Name -> Maybe (Type v Ann) -> MainTerm v
BadType HashQualified Name
mainName Maybe (Type v Ann)
forall a. Maybe a
Nothing)
    [Referent]
_ -> MainTerm v -> m (MainTerm v)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> MainTerm v
forall a. HasCallStack => [Char] -> a
error [Char]
"multiple matching refs") -- TODO: make a real exception

-- forall x. '{ io2.IO, Exception } x
builtinMain :: (Var v) => a -> Type.Type v a
builtinMain :: forall v a. Var v => a -> Type v a
builtinMain a
a =
  let result :: v
result = Text -> v
forall v. Var v => Text -> v
Var.named Text
"result"
   in a -> v -> Type v a -> Type v a
forall v a. Ord v => a -> v -> Type v a -> Type v a
Type.forAll a
a v
result (a -> Type v a -> Type v a
forall v a. Var v => a -> Type v a -> Type v a
builtinMainWithResultType a
a (a -> v -> Type v a
forall v a. Ord v => a -> v -> Type v a
Type.var a
a v
result))

-- '{io2.IO, Exception} res
builtinMainWithResultType :: (Var v) => a -> Type.Type v a -> Type.Type v a
builtinMainWithResultType :: forall v a. Var v => a -> Type v a -> Type v a
builtinMainWithResultType a
a Type v a
res = a -> Type v a -> Type v a -> Type v a
forall v a. Ord v => a -> Type v a -> Type v a -> Type v a
Type.arrow a
a (a -> Reference -> Type v a
forall v a. Ord v => a -> Reference -> Type v a
Type.ref a
a Reference
DD.unitRef) Type v a
io
  where
    io :: Type v a
io = a -> [Type v a] -> Type v a -> Type v a
forall v a. Ord v => a -> [Type v a] -> Type v a -> Type v a
Type.effect a
a [a -> Type v a
forall v a. Ord v => a -> Type v a
Type.builtinIO a
a, a -> Type v a
forall v a. Ord v => a -> Type v a
DD.exceptionType a
a] Type v a
res

-- | All possible IO'ish test types, e.g.
-- '{IO, Exception} [Result]
-- '{IO} [Result]
builtinIOTestTypes :: forall v a. (Ord v, Var v) => a -> NESet (Type.Type v a)
builtinIOTestTypes :: forall v a. (Ord v, Var v) => a -> NESet (Type v a)
builtinIOTestTypes a
a =
  NonEmpty (Type v a) -> NESet (Type v a)
forall a. Ord a => NonEmpty a -> NESet a
NESet.fromList
    ( [Type v a] -> Type v a
delayedResultWithEffects ([a -> Type v a
forall v a. Ord v => a -> Type v a
Type.builtinIO a
a, a -> Type v a
forall v a. Ord v => a -> Type v a
DD.exceptionType a
a])
        Type v a -> [Type v a] -> NonEmpty (Type v a)
forall a. a -> [a] -> NonEmpty a
NEList.:| [[Type v a] -> Type v a
delayedResultWithEffects ([a -> Type v a
forall v a. Ord v => a -> Type v a
Type.builtinIO a
a])]
    )
  where
    delayed :: Type v a -> Type v a
delayed = a -> Type v a -> Type v a -> Type v a
forall v a. Ord v => a -> Type v a -> Type v a -> Type v a
Type.arrow a
a (a -> Reference -> Type v a
forall v a. Ord v => a -> Reference -> Type v a
Type.ref a
a Reference
DD.unitRef)
    delayedResultWithEffects :: [Type v a] -> Type v a
delayedResultWithEffects [Type v a]
es = Type v a -> Type v a
delayed (a -> [Type v a] -> Type v a -> Type v a
forall v a. Ord v => a -> [Type v a] -> Type v a -> Type v a
Type.effect a
a [Type v a]
es (a -> Type v a
forall v a. Ord v => a -> Type v a
DD.testResultListType a
a))