{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NamedFieldPuns #-}

module Inferno.Module
  ( Module (..),
    PinnedModule,
    BuiltinModuleHash (..),
    BuiltinFunHash (..),
    BuiltinEnumHash (..),
    buildPinnedQQModules,
    combineTermEnvs,
    pinnedModuleNameToHash,
    pinnedModuleHashToTy,
    pinnedModuleTerms,
    ToValue (..),
  )
where

import Control.Monad (foldM)
import Control.Monad.Except (MonadError)
import Data.Bifunctor (bimap)
import Data.Foldable (foldl')
import qualified Data.IntMap as IntMap
import qualified Data.Map as Map
import qualified Data.Set as Set
import Inferno.Eval (TermEnv, eval)
import Inferno.Eval.Error (EvalError)
import Inferno.Infer (inferExpr)
import Inferno.Infer.Env (Namespace (..), TypeMetadata (..))
import Inferno.Infer.Pinned (pinExpr)
import qualified Inferno.Infer.Pinned as Pinned
import Inferno.Module.Cast (ToValue (..))
import Inferno.Parse (OpsTable, TopLevelDefn (..))
import Inferno.Types.Module
  ( BuiltinEnumHash (..),
    BuiltinFunHash (..),
    BuiltinModuleHash (..),
    Module (..),
    PinnedModule,
    pinnedModuleHashToTy,
    pinnedModuleNameToHash,
    pinnedModuleTerms,
  )
import Inferno.Types.Syntax
  ( Expr (..),
    ExtIdent (..),
    Ident (..),
    ImplExpl (..),
    ModuleName,
    Scoped (..),
    SigVar (..),
    sigVarToExpr,
  )
import Inferno.Types.Type
  ( BaseType (TEnum),
    ImplType (..),
    InfernoType (TBase),
    TCScheme (..),
  )
import Inferno.Types.Value (ImplEnvM, Value)
import Inferno.Types.VersionControl (Pinned (..), VCObjectHash, pinnedToMaybe, vcHash)
import Prettyprinter (Pretty)
import Text.Megaparsec (SourcePos)

combineTermEnvs ::
  MonadError EvalError m =>
  Map.Map ModuleName (PinnedModule (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))) ->
  ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))
combineTermEnvs :: forall (m :: * -> *) c.
MonadError EvalError m =>
Map
  ModuleName
  (PinnedModule
     (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))))
-> ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))
combineTermEnvs Map
  ModuleName
  (PinnedModule
     (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))))
modules = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\TermEnv VCObjectHash c (ImplEnvM m c)
env PinnedModule (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))
m -> (TermEnv VCObjectHash c (ImplEnvM m c)
env forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall m. PinnedModule m -> m
pinnedModuleTerms PinnedModule (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))
m) forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems Map
  ModuleName
  (PinnedModule
     (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))))
modules

buildPinnedQQModules ::
  (MonadError EvalError m, Pretty c) =>
  [(ModuleName, OpsTable, [TopLevelDefn (Either (TCScheme, ImplEnvM m c (Value c (ImplEnvM m c))) (Maybe TCScheme, Expr () SourcePos))])] ->
  Map.Map ModuleName (PinnedModule (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))))
buildPinnedQQModules :: forall (m :: * -> *) c.
(MonadError EvalError m, Pretty c) =>
[(ModuleName, OpsTable,
  [TopLevelDefn
     (Either
        (TCScheme, ImplEnvM m c (Value c (ImplEnvM m c)))
        (Maybe TCScheme, Expr () SourcePos))])]
-> Map
     ModuleName
     (PinnedModule
        (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))))
buildPinnedQQModules [(ModuleName, OpsTable,
  [TopLevelDefn
     (Either
        (TCScheme, ImplEnvM m c (Value c (ImplEnvM m c)))
        (Maybe TCScheme, Expr () SourcePos))])]
modules =
  forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
      ( \(Map (Scoped ModuleName) (Map Namespace (Pinned VCObjectHash))
alreadyPinnedModulesMap, Map
  ModuleName
  (PinnedModule
     (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))))
alreadyBuiltModules) (ModuleName
moduleNm, OpsTable
opsTable, [TopLevelDefn
   (Either
      (TCScheme, ImplEnvM m c (Value c (ImplEnvM m c)))
      (Maybe TCScheme, Expr () SourcePos))]
sigs) ->
          -- first build the new module
          let newMod :: PinnedModule (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))
newMod =
                forall (m :: * -> *) c.
(MonadError EvalError m, Pretty c) =>
Map (Scoped ModuleName) (Map Namespace (Pinned VCObjectHash))
-> Map
     ModuleName
     (PinnedModule
        (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))))
-> [TopLevelDefn
      (Either
         (TCScheme, ImplEnvM m c (Value c (ImplEnvM m c)))
         (Maybe TCScheme, Expr () SourcePos))]
-> PinnedModule
     (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))
-> PinnedModule
     (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))
buildModule Map (Scoped ModuleName) (Map Namespace (Pinned VCObjectHash))
alreadyPinnedModulesMap Map
  ModuleName
  (PinnedModule
     (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))))
alreadyBuiltModules [TopLevelDefn
   (Either
      (TCScheme, ImplEnvM m c (Value c (ImplEnvM m c)))
      (Maybe TCScheme, Expr () SourcePos))]
sigs forall a b. (a -> b) -> a -> b
$
                  Module
                    { moduleName :: ModuleName
moduleName = ModuleName
moduleNm,
                      moduleOpsTable :: OpsTable
moduleOpsTable = OpsTable
opsTable,
                      moduleTypeClasses :: Set TypeClass
moduleTypeClasses = forall a. Monoid a => a
mempty,
                      moduleObjects :: (Map Namespace VCObjectHash,
 Map VCObjectHash (TypeMetadata TCScheme),
 ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))
moduleObjects = (forall k a. k -> a -> Map k a
Map.singleton (ModuleName -> Namespace
ModuleNamespace ModuleName
moduleNm) forall a b. (a -> b) -> a -> b
$ forall obj. VCHashUpdate obj => obj -> VCObjectHash
vcHash forall a b. (a -> b) -> a -> b
$ ModuleName -> BuiltinModuleHash
BuiltinModuleHash ModuleName
moduleNm, forall a. Monoid a => a
mempty, forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty)
                    }
           in -- then insert it into the temporary module pin map as well as the final module map
              ( forall a.
ModuleName
-> Map Namespace (Pinned a)
-> Map (Scoped ModuleName) (Map Namespace (Pinned a))
-> Map (Scoped ModuleName) (Map Namespace (Pinned a))
Pinned.insertHardcodedModule ModuleName
moduleNm (forall a b k. (a -> b) -> Map k a -> Map k b
Map.map forall a. VCObjectHash -> Pinned a
Builtin forall a b. (a -> b) -> a -> b
$ forall m. PinnedModule m -> Map Namespace VCObjectHash
pinnedModuleNameToHash PinnedModule (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))
newMod) Map (Scoped ModuleName) (Map Namespace (Pinned VCObjectHash))
alreadyPinnedModulesMap,
                forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ModuleName
moduleNm PinnedModule (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))
newMod Map
  ModuleName
  (PinnedModule
     (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))))
alreadyBuiltModules
              )
      )
      forall a. Monoid a => a
mempty
      [(ModuleName, OpsTable,
  [TopLevelDefn
     (Either
        (TCScheme, ImplEnvM m c (Value c (ImplEnvM m c)))
        (Maybe TCScheme, Expr () SourcePos))])]
modules
  where
    buildModule ::
      (MonadError EvalError m, Pretty c) =>
      Map.Map (Scoped ModuleName) (Map.Map Namespace (Pinned VCObjectHash)) ->
      Map.Map ModuleName (PinnedModule (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))) ->
      [TopLevelDefn (Either (TCScheme, ImplEnvM m c (Value c (ImplEnvM m c))) (Maybe TCScheme, Expr () SourcePos))] ->
      PinnedModule (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))) ->
      PinnedModule (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))
    buildModule :: forall (m :: * -> *) c.
(MonadError EvalError m, Pretty c) =>
Map (Scoped ModuleName) (Map Namespace (Pinned VCObjectHash))
-> Map
     ModuleName
     (PinnedModule
        (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))))
-> [TopLevelDefn
      (Either
         (TCScheme, ImplEnvM m c (Value c (ImplEnvM m c)))
         (Maybe TCScheme, Expr () SourcePos))]
-> PinnedModule
     (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))
-> PinnedModule
     (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))
buildModule Map (Scoped ModuleName) (Map Namespace (Pinned VCObjectHash))
_ Map
  ModuleName
  (PinnedModule
     (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))))
_ [] PinnedModule (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))
m = PinnedModule (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))
m
    buildModule Map (Scoped ModuleName) (Map Namespace (Pinned VCObjectHash))
alreadyPinnedModulesMap Map
  ModuleName
  (PinnedModule
     (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))))
alreadyBuiltModules (Signature {Maybe Text
Either
  (TCScheme, ImplEnvM m c (Value c (ImplEnvM m c)))
  (Maybe TCScheme, Expr () SourcePos)
SigVar
def :: forall def. TopLevelDefn def -> def
name :: forall def. TopLevelDefn def -> SigVar
documentation :: forall def. TopLevelDefn def -> Maybe Text
def :: Either
  (TCScheme, ImplEnvM m c (Value c (ImplEnvM m c)))
  (Maybe TCScheme, Expr () SourcePos)
name :: SigVar
documentation :: Maybe Text
..} : [TopLevelDefn
   (Either
      (TCScheme, ImplEnvM m c (Value c (ImplEnvM m c)))
      (Maybe TCScheme, Expr () SourcePos))]
xs) m :: PinnedModule (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))
m@Module {ModuleName
moduleName :: ModuleName
moduleName :: forall objs. Module objs -> ModuleName
moduleName, moduleObjects :: forall objs. Module objs -> objs
moduleObjects = (Map Namespace VCObjectHash
nsMap, Map VCObjectHash (TypeMetadata TCScheme)
tyMap, ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))
mTrmEnv)} =
      let sigVarToNamespace :: SigVar -> Namespace
sigVarToNamespace = \case
            SigVar Text
n -> Ident -> Namespace
FunNamespace forall a b. (a -> b) -> a -> b
$ Text -> Ident
Ident Text
n
            SigOpVar Text
n -> Ident -> Namespace
OpNamespace forall a b. (a -> b) -> a -> b
$ Text -> Ident
Ident Text
n
          (TCScheme
sig, Namespace
ns, VCObjectHash
hsh, ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))
mTrmEnv') = case Either
  (TCScheme, ImplEnvM m c (Value c (ImplEnvM m c)))
  (Maybe TCScheme, Expr () SourcePos)
def of
            Left (TCScheme
sig', ImplEnvM m c (Value c (ImplEnvM m c))
mVal) ->
              let ns' :: Namespace
ns' = SigVar -> Namespace
sigVarToNamespace SigVar
name
                  hsh' :: VCObjectHash
hsh' = forall obj. VCHashUpdate obj => obj -> VCObjectHash
vcHash forall a b. (a -> b) -> a -> b
$ (Expr () (), TCScheme) -> BuiltinFunHash
BuiltinFunHash (Scoped ModuleName -> SigVar -> Expr () ()
sigVarToExpr forall a. Scoped a
LocalScope SigVar
name, TCScheme
sig)
               in (TCScheme
sig', Namespace
ns', VCObjectHash
hsh', (\Value c (ImplEnvM m c)
val (Map ExtIdent (Value c (ImplEnvM m c))
local, Map VCObjectHash (Value c (ImplEnvM m c))
pinned) -> (Map ExtIdent (Value c (ImplEnvM m c))
local, forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert VCObjectHash
hsh Value c (ImplEnvM m c)
val Map VCObjectHash (Value c (ImplEnvM m c))
pinned)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImplEnvM m c (Value c (ImplEnvM m c))
mVal forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))
mTrmEnv)
            Right (Maybe TCScheme
_mSig, Expr () SourcePos
expr) ->
              let pinMap :: Map (Scoped ModuleName) (Map Namespace (Pinned VCObjectHash))
pinMap =
                    forall a.
ModuleName
-> Map (Scoped ModuleName) (Map Namespace (Pinned a))
-> Map (Scoped ModuleName) (Map Namespace (Pinned a))
Pinned.openModule ModuleName
moduleName forall a b. (a -> b) -> a -> b
$
                      forall a.
ModuleName
-> Map Namespace (Pinned a)
-> Map (Scoped ModuleName) (Map Namespace (Pinned a))
-> Map (Scoped ModuleName) (Map Namespace (Pinned a))
Pinned.insertHardcodedModule
                        ModuleName
moduleName
                        (forall a b k. (a -> b) -> Map k a -> Map k b
Map.map forall a. VCObjectHash -> Pinned a
Builtin Map Namespace VCObjectHash
nsMap)
                        Map (Scoped ModuleName) (Map Namespace (Pinned VCObjectHash))
alreadyPinnedModulesMap
                  pinnedExpr :: Expr (Pinned VCObjectHash) SourcePos
pinnedExpr = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => [Char] -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a h.
(MonadError [TypeError SourcePos] m, Eq a) =>
Map (Scoped ModuleName) (Map Namespace (Pinned a))
-> Expr h SourcePos -> m (Expr (Pinned a) SourcePos)
pinExpr Map (Scoped ModuleName) (Map Namespace (Pinned VCObjectHash))
pinMap Expr () SourcePos
expr
                  inferEnv :: Map
  ModuleName
  (PinnedModule
     (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))))
inferEnv = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ModuleName
moduleName PinnedModule (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))
m forall a b. (a -> b) -> a -> b
$ Map
  ModuleName
  (PinnedModule
     (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))))
alreadyBuiltModules
                  (Expr (Pinned VCObjectHash) SourcePos
pinnedExpr', TCScheme
sig') =
                    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\[TypeError SourcePos]
err -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Could not infer the type of this expression: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show [TypeError SourcePos]
err) (\(Expr (Pinned VCObjectHash) SourcePos
e, TCScheme
typ, Map (Location SourcePos) (TypeMetadata TCScheme)
_) -> (Expr (Pinned VCObjectHash) SourcePos
e, TCScheme
typ)) forall a b. (a -> b) -> a -> b
$
                      forall m.
Map ModuleName (PinnedModule m)
-> Expr (Pinned VCObjectHash) SourcePos
-> Either
     [TypeError SourcePos]
     (Expr (Pinned VCObjectHash) SourcePos, TCScheme,
      Map (Location SourcePos) (TypeMetadata TCScheme))
inferExpr Map
  ModuleName
  (PinnedModule
     (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))))
inferEnv forall a b. (a -> b) -> a -> b
$ Expr (Pinned VCObjectHash) SourcePos
pinnedExpr
                  ns' :: Namespace
ns' = SigVar -> Namespace
sigVarToNamespace SigVar
name
                  hsh' :: VCObjectHash
hsh' = forall obj. VCHashUpdate obj => obj -> VCObjectHash
vcHash forall a b. (a -> b) -> a -> b
$ (Expr () (), TCScheme) -> BuiltinFunHash
BuiltinFunHash (Scoped ModuleName -> SigVar -> Expr () ()
sigVarToExpr forall a. Scoped a
LocalScope SigVar
name, TCScheme
sig)
                  mVal :: ImplEnvM m c (Value c (ImplEnvM m c))
mVal =
                    forall (m :: * -> *) c.
MonadError EvalError m =>
Map
  ModuleName
  (PinnedModule
     (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))))
-> ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))
combineTermEnvs Map
  ModuleName
  (PinnedModule
     (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))))
alreadyBuiltModules forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TermEnv VCObjectHash c (ImplEnvM m c)
env ->
                      ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))
mTrmEnv forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TermEnv VCObjectHash c (ImplEnvM m c)
env' -> forall (m :: * -> *) c a.
(MonadError EvalError m, MonadError EvalError (ImplEnvM m c),
 Pretty c) =>
TermEnv VCObjectHash c (ImplEnvM m c)
-> Expr (Maybe VCObjectHash) a
-> ImplEnvM m c (Value c (ImplEnvM m c))
eval (TermEnv VCObjectHash c (ImplEnvM m c)
env forall a. Semigroup a => a -> a -> a
<> TermEnv VCObjectHash c (ImplEnvM m c)
env') forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Pinned VCObjectHash -> Maybe VCObjectHash
pinnedToMaybe forall a. a -> a
id Expr (Pinned VCObjectHash) SourcePos
pinnedExpr'
               in (TCScheme
sig', Namespace
ns', VCObjectHash
hsh', (\Value c (ImplEnvM m c)
val (Map ExtIdent (Value c (ImplEnvM m c))
local, Map VCObjectHash (Value c (ImplEnvM m c))
pinned) -> (Map ExtIdent (Value c (ImplEnvM m c))
local, forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert VCObjectHash
hsh Value c (ImplEnvM m c)
val Map VCObjectHash (Value c (ImplEnvM m c))
pinned)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImplEnvM m c (Value c (ImplEnvM m c))
mVal forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))
mTrmEnv)
       in forall (m :: * -> *) c.
(MonadError EvalError m, Pretty c) =>
Map (Scoped ModuleName) (Map Namespace (Pinned VCObjectHash))
-> Map
     ModuleName
     (PinnedModule
        (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))))
-> [TopLevelDefn
      (Either
         (TCScheme, ImplEnvM m c (Value c (ImplEnvM m c)))
         (Maybe TCScheme, Expr () SourcePos))]
-> PinnedModule
     (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))
-> PinnedModule
     (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))
buildModule Map (Scoped ModuleName) (Map Namespace (Pinned VCObjectHash))
alreadyPinnedModulesMap Map
  ModuleName
  (PinnedModule
     (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))))
alreadyBuiltModules [TopLevelDefn
   (Either
      (TCScheme, ImplEnvM m c (Value c (ImplEnvM m c)))
      (Maybe TCScheme, Expr () SourcePos))]
xs forall a b. (a -> b) -> a -> b
$
            PinnedModule (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))
m
              { moduleObjects :: (Map Namespace VCObjectHash,
 Map VCObjectHash (TypeMetadata TCScheme),
 ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))
moduleObjects =
                  ( forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Namespace
ns VCObjectHash
hsh Map Namespace VCObjectHash
nsMap,
                    forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert
                      VCObjectHash
hsh
                      TypeMetadata
                        { identExpr :: Expr () ()
identExpr = Scoped ModuleName -> SigVar -> Expr () ()
sigVarToExpr (forall a. a -> Scoped a
Scope ModuleName
moduleName) SigVar
name,
                          docs :: Maybe Text
docs = Maybe Text
documentation,
                          ty :: TCScheme
ty = TCScheme
sig
                        }
                      Map VCObjectHash (TypeMetadata TCScheme)
tyMap,
                    ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))
mTrmEnv'
                  )
              }
    buildModule Map (Scoped ModuleName) (Map Namespace (Pinned VCObjectHash))
alreadyPinnedModulesMap Map
  ModuleName
  (PinnedModule
     (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))))
alreadyBuiltModules (TypeClassInstance TypeClass
tCl : [TopLevelDefn
   (Either
      (TCScheme, ImplEnvM m c (Value c (ImplEnvM m c)))
      (Maybe TCScheme, Expr () SourcePos))]
xs) m :: PinnedModule (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))
m@Module {moduleTypeClasses :: forall objs. Module objs -> Set TypeClass
moduleTypeClasses = Set TypeClass
tCls} =
      forall (m :: * -> *) c.
(MonadError EvalError m, Pretty c) =>
Map (Scoped ModuleName) (Map Namespace (Pinned VCObjectHash))
-> Map
     ModuleName
     (PinnedModule
        (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))))
-> [TopLevelDefn
      (Either
         (TCScheme, ImplEnvM m c (Value c (ImplEnvM m c)))
         (Maybe TCScheme, Expr () SourcePos))]
-> PinnedModule
     (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))
-> PinnedModule
     (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))
buildModule Map (Scoped ModuleName) (Map Namespace (Pinned VCObjectHash))
alreadyPinnedModulesMap Map
  ModuleName
  (PinnedModule
     (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))))
alreadyBuiltModules [TopLevelDefn
   (Either
      (TCScheme, ImplEnvM m c (Value c (ImplEnvM m c)))
      (Maybe TCScheme, Expr () SourcePos))]
xs PinnedModule (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))
m {moduleTypeClasses :: Set TypeClass
moduleTypeClasses = forall a. Ord a => a -> Set a -> Set a
Set.insert TypeClass
tCl Set TypeClass
tCls}
    buildModule Map (Scoped ModuleName) (Map Namespace (Pinned VCObjectHash))
alreadyPinnedModulesMap Map
  ModuleName
  (PinnedModule
     (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))))
alreadyBuiltModules (Export ModuleName
modNm : [TopLevelDefn
   (Either
      (TCScheme, ImplEnvM m c (Value c (ImplEnvM m c)))
      (Maybe TCScheme, Expr () SourcePos))]
xs) Module {ModuleName
moduleName :: ModuleName
moduleName :: forall objs. Module objs -> ModuleName
moduleName, moduleOpsTable :: forall objs. Module objs -> OpsTable
moduleOpsTable = OpsTable
opsTable, moduleTypeClasses :: forall objs. Module objs -> Set TypeClass
moduleTypeClasses = Set TypeClass
tyCls, moduleObjects :: forall objs. Module objs -> objs
moduleObjects = (Map Namespace VCObjectHash
nsMap, Map VCObjectHash (TypeMetadata TCScheme)
tyMap, ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))
mTrmEnv)} =
      case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ModuleName
modNm Map
  ModuleName
  (PinnedModule
     (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))))
alreadyBuiltModules of
        Maybe
  (PinnedModule
     (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))))
Nothing -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"buildModule: Module " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show ModuleName
modNm forall a. Semigroup a => a -> a -> a
<> [Char]
" does not exist."
        Just Module {moduleOpsTable :: forall objs. Module objs -> OpsTable
moduleOpsTable = OpsTable
opsTable', moduleTypeClasses :: forall objs. Module objs -> Set TypeClass
moduleTypeClasses = Set TypeClass
tyCls', moduleObjects :: forall objs. Module objs -> objs
moduleObjects = (Map Namespace VCObjectHash
nsMap', Map VCObjectHash (TypeMetadata TCScheme)
tyMap', ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))
mTrmEnv')} ->
          forall (m :: * -> *) c.
(MonadError EvalError m, Pretty c) =>
Map (Scoped ModuleName) (Map Namespace (Pinned VCObjectHash))
-> Map
     ModuleName
     (PinnedModule
        (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))))
-> [TopLevelDefn
      (Either
         (TCScheme, ImplEnvM m c (Value c (ImplEnvM m c)))
         (Maybe TCScheme, Expr () SourcePos))]
-> PinnedModule
     (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))
-> PinnedModule
     (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))
buildModule
            Map (Scoped ModuleName) (Map Namespace (Pinned VCObjectHash))
alreadyPinnedModulesMap
            Map
  ModuleName
  (PinnedModule
     (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))))
alreadyBuiltModules
            [TopLevelDefn
   (Either
      (TCScheme, ImplEnvM m c (Value c (ImplEnvM m c)))
      (Maybe TCScheme, Expr () SourcePos))]
xs
            Module
              { ModuleName
moduleName :: ModuleName
moduleName :: ModuleName
moduleName,
                moduleOpsTable :: OpsTable
moduleOpsTable = forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IntMap.unionWith forall a. Semigroup a => a -> a -> a
(<>) OpsTable
opsTable OpsTable
opsTable',
                moduleTypeClasses :: Set TypeClass
moduleTypeClasses = Set TypeClass
tyCls forall a. Semigroup a => a -> a -> a
<> Set TypeClass
tyCls',
                moduleObjects :: (Map Namespace VCObjectHash,
 Map VCObjectHash (TypeMetadata TCScheme),
 ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))
moduleObjects = (Map Namespace VCObjectHash
nsMap forall a. Semigroup a => a -> a -> a
<> Map Namespace VCObjectHash
nsMap', Map VCObjectHash (TypeMetadata TCScheme)
tyMap forall a. Semigroup a => a -> a -> a
<> Map VCObjectHash (TypeMetadata TCScheme)
tyMap', ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))
mTrmEnv forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TermEnv VCObjectHash c (ImplEnvM m c)
x -> ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))
mTrmEnv' forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TermEnv VCObjectHash c (ImplEnvM m c)
y -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ TermEnv VCObjectHash c (ImplEnvM m c)
x forall a. Semigroup a => a -> a -> a
<> TermEnv VCObjectHash c (ImplEnvM m c)
y)
              }
    buildModule Map (Scoped ModuleName) (Map Namespace (Pinned VCObjectHash))
alreadyPinnedModulesMap Map
  ModuleName
  (PinnedModule
     (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))))
alreadyBuiltModules (EnumDef Maybe Text
doc Text
nm [Ident]
cs : [TopLevelDefn
   (Either
      (TCScheme, ImplEnvM m c (Value c (ImplEnvM m c)))
      (Maybe TCScheme, Expr () SourcePos))]
xs) m :: PinnedModule (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))
m@Module {moduleObjects :: forall objs. Module objs -> objs
moduleObjects = (Map Namespace VCObjectHash
nsMap, Map VCObjectHash (TypeMetadata TCScheme)
tyMap, ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))
mTrmEnv)} =
      let enumTy :: TCScheme
enumTy = [TV] -> Set TypeClass -> ImplType -> TCScheme
ForallTC [] forall a. Set a
Set.empty forall a b. (a -> b) -> a -> b
$ Map ExtIdent InfernoType -> InfernoType -> ImplType
ImplType forall k a. Map k a
Map.empty forall a b. (a -> b) -> a -> b
$ BaseType -> InfernoType
TBase forall a b. (a -> b) -> a -> b
$ Text -> Set Ident -> BaseType
TEnum Text
nm forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [Ident]
cs
          hsh :: VCObjectHash
hsh = forall obj. VCHashUpdate obj => obj -> VCObjectHash
vcHash forall a b. (a -> b) -> a -> b
$ TCScheme -> BuiltinEnumHash
BuiltinEnumHash TCScheme
enumTy
          nms :: [Namespace]
nms = Ident -> Namespace
TypeNamespace (Text -> Ident
Ident Text
nm) forall a. a -> [a] -> [a]
: [Ident -> Namespace
EnumNamespace Ident
c | Ident
c <- [Ident]
cs]
       in forall (m :: * -> *) c.
(MonadError EvalError m, Pretty c) =>
Map (Scoped ModuleName) (Map Namespace (Pinned VCObjectHash))
-> Map
     ModuleName
     (PinnedModule
        (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))))
-> [TopLevelDefn
      (Either
         (TCScheme, ImplEnvM m c (Value c (ImplEnvM m c)))
         (Maybe TCScheme, Expr () SourcePos))]
-> PinnedModule
     (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))
-> PinnedModule
     (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))
buildModule Map (Scoped ModuleName) (Map Namespace (Pinned VCObjectHash))
alreadyPinnedModulesMap Map
  ModuleName
  (PinnedModule
     (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))))
alreadyBuiltModules [TopLevelDefn
   (Either
      (TCScheme, ImplEnvM m c (Value c (ImplEnvM m c)))
      (Maybe TCScheme, Expr () SourcePos))]
xs forall a b. (a -> b) -> a -> b
$
            PinnedModule (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))
m
              { moduleObjects :: (Map Namespace VCObjectHash,
 Map VCObjectHash (TypeMetadata TCScheme),
 ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))
moduleObjects =
                  ( forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Namespace
n, VCObjectHash
hsh) | Namespace
n <- [Namespace]
nms] forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map Namespace VCObjectHash
nsMap,
                    forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert
                      VCObjectHash
hsh
                      TypeMetadata
                        { identExpr :: Expr () ()
identExpr = forall hash pos.
pos -> hash -> Scoped ModuleName -> ImplExpl -> Expr hash pos
Var () () forall a. Scoped a
LocalScope (ExtIdent -> ImplExpl
Expl forall a b. (a -> b) -> a -> b
$ Either Int Text -> ExtIdent
ExtIdent forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Text
"_"),
                          docs :: Maybe Text
docs = Maybe Text
doc,
                          ty :: TCScheme
ty = TCScheme
enumTy
                        }
                      Map VCObjectHash (TypeMetadata TCScheme)
tyMap,
                    ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))
mTrmEnv
                  )
              }