-- |
-- Module      :  Cryptol.ModuleSystem.Env
-- Copyright   :  (c) 2013-2016 Galois, Inc.
-- License     :  BSD3
-- Maintainer  :  cryptol@galois.com
-- Stability   :  provisional
-- Portability :  portable

{-# LANGUAGE CPP #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Cryptol.ModuleSystem.Env where

#ifndef RELOCATABLE
import Paths_cryptol (getDataDir)
#endif

import Cryptol.Backend.FFI (ForeignSrc, unloadForeignSrc, getForeignSrcPath)
import Cryptol.Eval (EvalEnv)
import qualified Cryptol.IR.FreeVars as T
import Cryptol.ModuleSystem.Fingerprint
import Cryptol.ModuleSystem.Interface
import Cryptol.ModuleSystem.Name (Name,NameInfo(..),Supply,emptySupply,nameInfo,nameTopModuleMaybe)
import qualified Cryptol.ModuleSystem.NamingEnv as R
import Cryptol.Parser.AST
import qualified Cryptol.TypeCheck as T
import qualified Cryptol.TypeCheck.Interface as T
import qualified Cryptol.TypeCheck.AST as T
import qualified Cryptol.Utils.Ident as I
import Cryptol.Utils.PP (PP(..),text,parens,NameDisp)

import Data.ByteString(ByteString)
import Control.Monad (guard,mplus)
import qualified Control.Exception as X
import Data.Function (on)
import Data.Set(Set)
import qualified Data.Set as Set
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Semigroup
import Data.Maybe(fromMaybe)
import System.Directory (getAppUserDataDirectory, getCurrentDirectory)
import System.Environment(getExecutablePath)
import System.FilePath ((</>), normalise, joinPath, splitPath, takeDirectory)
import qualified Data.List as List
import Data.Foldable

import GHC.Generics (Generic)
import Control.DeepSeq

import Prelude ()
import Prelude.Compat

import Cryptol.Utils.Panic(panic)
import Cryptol.Utils.PP(pp)

-- Module Environment ----------------------------------------------------------

-- | This is the current state of the interpreter.
data ModuleEnv = ModuleEnv
  { ModuleEnv -> LoadedModules
meLoadedModules     :: LoadedModules
    -- ^ Information about all loaded modules.  See 'LoadedModule'.
    -- Contains information such as the file where the module was loaded
    -- from, as well as the module's interface, used for type checking.

  , ModuleEnv -> NameSeeds
meNameSeeds         :: T.NameSeeds
    -- ^ A source of new names for the type checker.

  , ModuleEnv -> EvalEnv
meEvalEnv           :: EvalEnv
    -- ^ The evaluation environment.  Contains the values for all loaded
    -- modules, both public and private.

  , ModuleEnv -> CoreLint
meCoreLint          :: CoreLint
    -- ^ Should we run the linter to ensure sanity.

  , ModuleEnv -> Bool
meMonoBinds         :: !Bool
    -- ^ Are we assuming that local bindings are monomorphic.
    -- XXX: We should probably remove this flag, and set it to 'True'.



  , ModuleEnv -> Maybe (ImpName Name)
meFocusedModule     :: Maybe (ImpName Name)
    -- ^ The "current" module.  Used to decide how to print names, for example.

  , ModuleEnv -> [String]
meSearchPath        :: [FilePath]
    -- ^ Where we look for things.

  , ModuleEnv -> DynamicEnv
meDynEnv            :: DynamicEnv
    -- ^ This contains additional definitions that were made at the command
    -- line, and so they don't reside in any module.

  , ModuleEnv -> Supply
meSupply            :: !Supply
    -- ^ Name source for the renamer

  , ModuleEnv -> EvalForeignPolicy
meEvalForeignPolicy :: EvalForeignPolicy
    -- ^ How to evaluate @foreign@ bindings.

  } deriving (forall x. ModuleEnv -> Rep ModuleEnv x)
-> (forall x. Rep ModuleEnv x -> ModuleEnv) -> Generic ModuleEnv
forall x. Rep ModuleEnv x -> ModuleEnv
forall x. ModuleEnv -> Rep ModuleEnv x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ModuleEnv -> Rep ModuleEnv x
from :: forall x. ModuleEnv -> Rep ModuleEnv x
$cto :: forall x. Rep ModuleEnv x -> ModuleEnv
to :: forall x. Rep ModuleEnv x -> ModuleEnv
Generic

instance NFData ModuleEnv where
  rnf :: ModuleEnv -> ()
rnf ModuleEnv
x = ModuleEnv -> LoadedModules
meLoadedModules ModuleEnv
x LoadedModules -> () -> ()
forall a b. a -> b -> b
`seq` ModuleEnv -> EvalEnv
meEvalEnv ModuleEnv
x EvalEnv -> () -> ()
forall a b. a -> b -> b
`seq` ModuleEnv -> DynamicEnv
meDynEnv ModuleEnv
x DynamicEnv -> () -> ()
forall a b. a -> b -> b
`seq` ()

-- | Should we run the linter?
data CoreLint = NoCoreLint        -- ^ Don't run core lint
              | CoreLint          -- ^ Run core lint
  deriving ((forall x. CoreLint -> Rep CoreLint x)
-> (forall x. Rep CoreLint x -> CoreLint) -> Generic CoreLint
forall x. Rep CoreLint x -> CoreLint
forall x. CoreLint -> Rep CoreLint x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CoreLint -> Rep CoreLint x
from :: forall x. CoreLint -> Rep CoreLint x
$cto :: forall x. Rep CoreLint x -> CoreLint
to :: forall x. Rep CoreLint x -> CoreLint
Generic, CoreLint -> ()
(CoreLint -> ()) -> NFData CoreLint
forall a. (a -> ()) -> NFData a
$crnf :: CoreLint -> ()
rnf :: CoreLint -> ()
NFData)

-- | How to evaluate @foreign@ bindings.
data EvalForeignPolicy
  -- | Use foreign implementation and report an error at module load time if it
  -- is unavailable.
  = AlwaysEvalForeign
  -- | Use foreign implementation by default, and when unavailable, fall back to cryptol implementation if present and report runtime error otherwise.
  | PreferEvalForeign
  -- | Always use cryptol implementation if present, and report runtime error
  -- otherwise.
  | NeverEvalForeign
  deriving EvalForeignPolicy -> EvalForeignPolicy -> Bool
(EvalForeignPolicy -> EvalForeignPolicy -> Bool)
-> (EvalForeignPolicy -> EvalForeignPolicy -> Bool)
-> Eq EvalForeignPolicy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EvalForeignPolicy -> EvalForeignPolicy -> Bool
== :: EvalForeignPolicy -> EvalForeignPolicy -> Bool
$c/= :: EvalForeignPolicy -> EvalForeignPolicy -> Bool
/= :: EvalForeignPolicy -> EvalForeignPolicy -> Bool
Eq

defaultEvalForeignPolicy :: EvalForeignPolicy
defaultEvalForeignPolicy :: EvalForeignPolicy
defaultEvalForeignPolicy =
#ifdef FFI_ENABLED
  EvalForeignPolicy
PreferEvalForeign
#else
  NeverEvalForeign
#endif

resetModuleEnv :: ModuleEnv -> IO ModuleEnv
resetModuleEnv :: ModuleEnv -> IO ModuleEnv
resetModuleEnv ModuleEnv
env = do
  [LoadedModule] -> (LoadedModule -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (LoadedModules -> [LoadedModule]
getLoadedModules (LoadedModules -> [LoadedModule])
-> LoadedModules -> [LoadedModule]
forall a b. (a -> b) -> a -> b
$ ModuleEnv -> LoadedModules
meLoadedModules ModuleEnv
env) ((LoadedModule -> IO ()) -> IO ())
-> (LoadedModule -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \LoadedModule
lm ->
    case LoadedModuleData -> Maybe ForeignSrc
lmForeignSrc (LoadedModule -> LoadedModuleData
forall a. LoadedModuleG a -> a
lmData LoadedModule
lm) of
      Just ForeignSrc
fsrc -> ForeignSrc -> IO ()
unloadForeignSrc ForeignSrc
fsrc
      Maybe ForeignSrc
_         -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  ModuleEnv -> IO ModuleEnv
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModuleEnv
env
    { meLoadedModules = mempty
    , meNameSeeds     = T.nameSeeds
    , meEvalEnv       = mempty
    , meFocusedModule = Nothing
    , meDynEnv        = mempty
    }

initialModuleEnv :: IO ModuleEnv
initialModuleEnv :: IO ModuleEnv
initialModuleEnv = do
  String
curDir <- IO String
getCurrentDirectory
#ifndef RELOCATABLE
  dataDir <- getDataDir
#endif
  String
binDir <- String -> String
takeDirectory (String -> String) -> IO String -> IO String
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` IO String
getExecutablePath
  let instDir :: String
instDir = String -> String
normalise (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
joinPath ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. HasCallStack => [a] -> [a]
init ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
splitPath (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
binDir
  -- looking up this directory can fail if no HOME is set, as in some
  -- CI settings
  let handle :: X.IOException -> IO String
      handle :: IOException -> IO String
handle IOException
_e = String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
  String
userDir <- IO String -> (IOException -> IO String) -> IO String
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
X.catch (String -> IO String
getAppUserDataDirectory String
"cryptol") IOException -> IO String
handle
  let searchPath :: [String]
searchPath = [ String
curDir
                   -- something like $HOME/.cryptol
                   , String
userDir
#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
                   -- ../cryptol on win32
                   , instDir </> "cryptol"
#else
                   -- ../share/cryptol on others
                   , String
instDir String -> String -> String
</> String
"share" String -> String -> String
</> String
"cryptol"
#endif

#ifndef RELOCATABLE
                   -- Cabal-defined data directory. Since this
                   -- is usually a global location like
                   -- /usr/local, search this one last in case
                   -- someone has multiple Cryptols
                   , dataDir
#endif
                   ]

  ModuleEnv -> IO ModuleEnv
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ModuleEnv
    { meLoadedModules :: LoadedModules
meLoadedModules     = LoadedModules
forall a. Monoid a => a
mempty
    , meNameSeeds :: NameSeeds
meNameSeeds         = NameSeeds
T.nameSeeds
    , meEvalEnv :: EvalEnv
meEvalEnv           = EvalEnv
forall a. Monoid a => a
mempty
    , meFocusedModule :: Maybe (ImpName Name)
meFocusedModule     = Maybe (ImpName Name)
forall a. Maybe a
Nothing
      -- we search these in order, taking the first match
    , meSearchPath :: [String]
meSearchPath        = [String]
searchPath
    , meDynEnv :: DynamicEnv
meDynEnv            = DynamicEnv
forall a. Monoid a => a
mempty
    , meMonoBinds :: Bool
meMonoBinds         = Bool
True
    , meCoreLint :: CoreLint
meCoreLint          = CoreLint
NoCoreLint
    , meSupply :: Supply
meSupply            = Supply
emptySupply
    , meEvalForeignPolicy :: EvalForeignPolicy
meEvalForeignPolicy = EvalForeignPolicy
defaultEvalForeignPolicy
    }

-- | Try to focus a loaded module in the module environment.
focusModule :: ImpName Name -> ModuleEnv -> Maybe ModuleEnv
focusModule :: ImpName Name -> ModuleEnv -> Maybe ModuleEnv
focusModule ImpName Name
n ModuleEnv
me = do
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ImpName Name -> LoadedModules -> Bool
isLoaded ImpName Name
n (ModuleEnv -> LoadedModules
meLoadedModules ModuleEnv
me))
  ModuleEnv -> Maybe ModuleEnv
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ModuleEnv
me { meFocusedModule = Just n }

-- | Get a list of all the loaded modules. Each module in the
-- resulting list depends only on other modules that precede it.
-- Note that this includes parameterized modules.
loadedModules :: ModuleEnv -> [T.Module]
loadedModules :: ModuleEnv -> [Module]
loadedModules = (LoadedModule -> Module) -> [LoadedModule] -> [Module]
forall a b. (a -> b) -> [a] -> [b]
map LoadedModule -> Module
lmModule ([LoadedModule] -> [Module])
-> (ModuleEnv -> [LoadedModule]) -> ModuleEnv -> [Module]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoadedModules -> [LoadedModule]
getLoadedModules (LoadedModules -> [LoadedModule])
-> (ModuleEnv -> LoadedModules) -> ModuleEnv -> [LoadedModule]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleEnv -> LoadedModules
meLoadedModules

-- | Get a list of all the loaded non-parameterized modules.
-- These are the modules that can be used for evaluation, proving etc.
loadedNonParamModules :: ModuleEnv -> [T.Module]
loadedNonParamModules :: ModuleEnv -> [Module]
loadedNonParamModules = (LoadedModule -> Module) -> [LoadedModule] -> [Module]
forall a b. (a -> b) -> [a] -> [b]
map LoadedModule -> Module
lmModule ([LoadedModule] -> [Module])
-> (ModuleEnv -> [LoadedModule]) -> ModuleEnv -> [Module]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoadedModules -> [LoadedModule]
lmLoadedModules (LoadedModules -> [LoadedModule])
-> (ModuleEnv -> LoadedModules) -> ModuleEnv -> [LoadedModule]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleEnv -> LoadedModules
meLoadedModules

loadedNominalTypes :: ModuleEnv -> Map Name T.NominalType
loadedNominalTypes :: ModuleEnv -> Map Name NominalType
loadedNominalTypes ModuleEnv
menv = [Map Name NominalType] -> Map Name NominalType
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions
   [ IfaceDecls -> Map Name NominalType
ifNominalTypes (IfaceG ModName -> IfaceDecls
forall name. IfaceG name -> IfaceDecls
ifDefines IfaceG ModName
i) Map Name NominalType
-> Map Name NominalType -> Map Name NominalType
forall a. Semigroup a => a -> a -> a
<> IfaceDecls -> Map Name NominalType
ifNominalTypes (IfaceG ModName -> IfaceDecls
forall name. IfaceG name -> IfaceDecls
ifDefines IfaceG ModName
i)
   | IfaceG ModName
i <- (LoadedModule -> IfaceG ModName)
-> [LoadedModule] -> [IfaceG ModName]
forall a b. (a -> b) -> [a] -> [b]
map LoadedModule -> IfaceG ModName
lmInterface (LoadedModules -> [LoadedModule]
getLoadedModules (ModuleEnv -> LoadedModules
meLoadedModules ModuleEnv
menv))
   ]

-- | Are any parameterized modules loaded?
hasParamModules :: ModuleEnv -> Bool
hasParamModules :: ModuleEnv -> Bool
hasParamModules = Bool -> Bool
not (Bool -> Bool) -> (ModuleEnv -> Bool) -> ModuleEnv -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LoadedModule] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([LoadedModule] -> Bool)
-> (ModuleEnv -> [LoadedModule]) -> ModuleEnv -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoadedModules -> [LoadedModule]
lmLoadedParamModules (LoadedModules -> [LoadedModule])
-> (ModuleEnv -> LoadedModules) -> ModuleEnv -> [LoadedModule]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleEnv -> LoadedModules
meLoadedModules

allDeclGroups :: ModuleEnv -> [T.DeclGroup]
allDeclGroups :: ModuleEnv -> [DeclGroup]
allDeclGroups = (Module -> [DeclGroup]) -> [Module] -> [DeclGroup]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Module -> [DeclGroup]
forall mname. ModuleG mname -> [DeclGroup]
T.mDecls ([Module] -> [DeclGroup])
-> (ModuleEnv -> [Module]) -> ModuleEnv -> [DeclGroup]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleEnv -> [Module]
loadedNonParamModules

data ModContextParams =
    InterfaceParams T.ModParamNames
  | FunctorParams T.FunctorParams
  | NoParams

modContextParamNames :: ModContextParams -> T.ModParamNames
modContextParamNames :: ModContextParams -> ModParamNames
modContextParamNames ModContextParams
mp =
  case ModContextParams
mp of
    InterfaceParams ModParamNames
ps -> ModParamNames
ps
    FunctorParams FunctorParams
ps   -> FunctorParams -> ModParamNames
T.allParamNames FunctorParams
ps
    ModContextParams
NoParams           -> FunctorParams -> ModParamNames
T.allParamNames FunctorParams
forall a. Monoid a => a
mempty

-- | Contains enough information to browse what's in scope,
-- or type check new expressions.
data ModContext = ModContext
  { ModContext -> ModContextParams
mctxParams          :: ModContextParams -- T.FunctorParams
  , ModContext -> Set Name
mctxExported        :: Set Name
  , ModContext -> IfaceDecls
mctxDecls           :: IfaceDecls
    -- ^ Should contain at least names in NamingEnv, but may have more
  , ModContext -> NamingEnv
mctxNames           :: R.NamingEnv
    -- ^ What's in scope inside the module
  , ModContext -> NameDisp
mctxNameDisp        :: NameDisp
  }

-- This instance is a bit bogus.  It is mostly used to add the dynamic
-- environemnt to an existing module, and it makes sense for that use case.
instance Semigroup ModContext where
  ModContext
x <> :: ModContext -> ModContext -> ModContext
<> ModContext
y = ModContext { mctxParams :: ModContextParams
mctxParams   = ModContextParams -> ModContextParams -> ModContextParams
jnPs (ModContext -> ModContextParams
mctxParams ModContext
x) (ModContext -> ModContextParams
mctxParams ModContext
y)
                      , mctxExported :: Set Name
mctxExported = ModContext -> Set Name
mctxExported ModContext
x Set Name -> Set Name -> Set Name
forall a. Semigroup a => a -> a -> a
<> ModContext -> Set Name
mctxExported ModContext
y
                      , mctxDecls :: IfaceDecls
mctxDecls    = ModContext -> IfaceDecls
mctxDecls ModContext
x  IfaceDecls -> IfaceDecls -> IfaceDecls
forall a. Semigroup a => a -> a -> a
<> ModContext -> IfaceDecls
mctxDecls  ModContext
y
                      , mctxNames :: NamingEnv
mctxNames    = NamingEnv
names
                      , mctxNameDisp :: NameDisp
mctxNameDisp = NamingEnv -> NameDisp
R.toNameDisp NamingEnv
names
                      }

      where
      names :: NamingEnv
names = ModContext -> NamingEnv
mctxNames ModContext
x NamingEnv -> NamingEnv -> NamingEnv
`R.shadowing` ModContext -> NamingEnv
mctxNames ModContext
y
      jnPs :: ModContextParams -> ModContextParams -> ModContextParams
jnPs ModContextParams
as ModContextParams
bs =
        case (ModContextParams
as,ModContextParams
bs) of
          (ModContextParams
NoParams,ModContextParams
_) -> ModContextParams
bs
          (ModContextParams
_,ModContextParams
NoParams) -> ModContextParams
as
          (FunctorParams FunctorParams
xs, FunctorParams FunctorParams
ys) -> FunctorParams -> ModContextParams
FunctorParams (FunctorParams
xs FunctorParams -> FunctorParams -> FunctorParams
forall a. Semigroup a => a -> a -> a
<> FunctorParams
ys)
          (ModContextParams, ModContextParams)
_ -> String -> [String] -> ModContextParams
forall a. HasCallStack => String -> [String] -> a
panic String
"(<>) @ ModContext" [String
"Can't combine parameters"]

instance Monoid ModContext where
  mempty :: ModContext
mempty = ModContext { mctxParams :: ModContextParams
mctxParams   = ModContextParams
NoParams
                      , mctxDecls :: IfaceDecls
mctxDecls    = IfaceDecls
forall a. Monoid a => a
mempty
                      , mctxExported :: Set Name
mctxExported = Set Name
forall a. Monoid a => a
mempty
                      , mctxNames :: NamingEnv
mctxNames    = NamingEnv
forall a. Monoid a => a
mempty
                      , mctxNameDisp :: NameDisp
mctxNameDisp = NamingEnv -> NameDisp
R.toNameDisp NamingEnv
forall a. Monoid a => a
mempty
                      }

findEnv :: Name -> Iface -> T.ModuleG a -> Maybe (R.NamingEnv, Set Name)
findEnv :: forall a.
Name -> IfaceG ModName -> ModuleG a -> Maybe (NamingEnv, Set Name)
findEnv Name
n IfaceG ModName
iface ModuleG a
m
  | Just Submodule
sm <- Name -> Map Name Submodule -> Maybe Submodule
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n (ModuleG a -> Map Name Submodule
forall mname. ModuleG mname -> Map Name Submodule
T.mSubmodules ModuleG a
m) = (NamingEnv, Set Name) -> Maybe (NamingEnv, Set Name)
forall a. a -> Maybe a
Just (Submodule -> NamingEnv
T.smInScope Submodule
sm, IfaceNames Name -> Set Name
forall name. IfaceNames name -> Set Name
ifsPublic (Submodule -> IfaceNames Name
T.smIface Submodule
sm))
  | Just ModuleG Name
fn <- Name -> Map Name (ModuleG Name) -> Maybe (ModuleG Name)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n (ModuleG a -> Map Name (ModuleG Name)
forall mname. ModuleG mname -> Map Name (ModuleG Name)
T.mFunctors ModuleG a
m) =
      case Name -> Map Name (IfaceG Name) -> Maybe (IfaceG Name)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n (IfaceDecls -> Map Name (IfaceG Name)
ifFunctors (IfaceG ModName -> IfaceDecls
forall name. IfaceG name -> IfaceDecls
ifDefines IfaceG ModName
iface)) of
        Maybe (IfaceG Name)
Nothing -> String -> [String] -> Maybe (NamingEnv, Set Name)
forall a. HasCallStack => String -> [String] -> a
panic String
"findEnv" [String
"Submodule functor not present in interface"]
        Just IfaceG Name
d -> (NamingEnv, Set Name) -> Maybe (NamingEnv, Set Name)
forall a. a -> Maybe a
Just (ModuleG Name -> NamingEnv
forall mname. ModuleG mname -> NamingEnv
T.mInScope ModuleG Name
fn, IfaceNames Name -> Set Name
forall name. IfaceNames name -> Set Name
ifsPublic (IfaceG Name -> IfaceNames Name
forall name. IfaceG name -> IfaceNames name
ifNames IfaceG Name
d))
  | Bool
otherwise = [Maybe (NamingEnv, Set Name)] -> Maybe (NamingEnv, Set Name)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum ((ModuleG Name -> Maybe (NamingEnv, Set Name))
-> [ModuleG Name] -> [Maybe (NamingEnv, Set Name)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name
-> IfaceG ModName -> ModuleG Name -> Maybe (NamingEnv, Set Name)
forall a.
Name -> IfaceG ModName -> ModuleG a -> Maybe (NamingEnv, Set Name)
findEnv Name
n IfaceG ModName
iface) (Map Name (ModuleG Name) -> [ModuleG Name]
forall k a. Map k a -> [a]
Map.elems (ModuleG a -> Map Name (ModuleG Name)
forall mname. ModuleG mname -> Map Name (ModuleG Name)
T.mFunctors ModuleG a
m)))

modContextOf :: ImpName Name -> ModuleEnv -> Maybe ModContext
modContextOf :: ImpName Name -> ModuleEnv -> Maybe ModContext
modContextOf (ImpNested Name
name) ModuleEnv
me =
  do ModName
mname <- Name -> Maybe ModName
nameTopModuleMaybe Name
name
     LoadedModule
lm <- ModName -> ModuleEnv -> Maybe LoadedModule
lookupModule ModName
mname ModuleEnv
me
     (NamingEnv
localNames, Set Name
exported) <- Name -> IfaceG ModName -> Module -> Maybe (NamingEnv, Set Name)
forall a.
Name -> IfaceG ModName -> ModuleG a -> Maybe (NamingEnv, Set Name)
findEnv Name
name (LoadedModule -> IfaceG ModName
lmInterface LoadedModule
lm) (LoadedModule -> Module
lmModule LoadedModule
lm)
     let -- XXX: do we want only public ones here?
         loadedDecls :: [IfaceDecls]
loadedDecls = (LoadedModule -> IfaceDecls) -> [LoadedModule] -> [IfaceDecls]
forall a b. (a -> b) -> [a] -> [b]
map (IfaceG ModName -> IfaceDecls
forall name. IfaceG name -> IfaceDecls
ifDefines (IfaceG ModName -> IfaceDecls)
-> (LoadedModule -> IfaceG ModName) -> LoadedModule -> IfaceDecls
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoadedModule -> IfaceG ModName
lmInterface)
                     ([LoadedModule] -> [IfaceDecls]) -> [LoadedModule] -> [IfaceDecls]
forall a b. (a -> b) -> a -> b
$ LoadedModules -> [LoadedModule]
getLoadedModules (ModuleEnv -> LoadedModules
meLoadedModules ModuleEnv
me)
     ModContext -> Maybe ModContext
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModContext
       { mctxParams :: ModContextParams
mctxParams   = ModContextParams
NoParams
       , mctxExported :: Set Name
mctxExported = Set Name
exported
       , mctxDecls :: IfaceDecls
mctxDecls    = [IfaceDecls] -> IfaceDecls
forall a. Monoid a => [a] -> a
mconcat (IfaceG ModName -> IfaceDecls
forall name. IfaceG name -> IfaceDecls
ifDefines (LoadedModule -> IfaceG ModName
lmInterface LoadedModule
lm) IfaceDecls -> [IfaceDecls] -> [IfaceDecls]
forall a. a -> [a] -> [a]
: [IfaceDecls]
loadedDecls)
       , mctxNames :: NamingEnv
mctxNames    = NamingEnv
localNames
       , mctxNameDisp :: NameDisp
mctxNameDisp = NamingEnv -> NameDisp
R.toNameDisp NamingEnv
localNames
       }
  -- TODO: support focusing inside a submodule signature to support browsing?

modContextOf (ImpTop ModName
mname) ModuleEnv
me =
  do LoadedModule
lm <- ModName -> ModuleEnv -> Maybe LoadedModule
lookupModule ModName
mname ModuleEnv
me
     let localIface :: IfaceG ModName
localIface  = LoadedModule -> IfaceG ModName
lmInterface LoadedModule
lm
         localNames :: NamingEnv
localNames  = LoadedModule -> NamingEnv
forall a. LoadedModuleG a -> NamingEnv
lmNamingEnv LoadedModule
lm

         -- XXX: do we want only public ones here?
         loadedDecls :: [IfaceDecls]
loadedDecls = (LoadedModule -> IfaceDecls) -> [LoadedModule] -> [IfaceDecls]
forall a b. (a -> b) -> [a] -> [b]
map (IfaceG ModName -> IfaceDecls
forall name. IfaceG name -> IfaceDecls
ifDefines (IfaceG ModName -> IfaceDecls)
-> (LoadedModule -> IfaceG ModName) -> LoadedModule -> IfaceDecls
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoadedModule -> IfaceG ModName
lmInterface)
                     ([LoadedModule] -> [IfaceDecls]) -> [LoadedModule] -> [IfaceDecls]
forall a b. (a -> b) -> a -> b
$ LoadedModules -> [LoadedModule]
getLoadedModules (ModuleEnv -> LoadedModules
meLoadedModules ModuleEnv
me)

         params :: FunctorParams
params = IfaceG ModName -> FunctorParams
forall name. IfaceG name -> FunctorParams
ifParams IfaceG ModName
localIface
     ModContext -> Maybe ModContext
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModContext
       { mctxParams :: ModContextParams
mctxParams   = if FunctorParams -> Bool
forall k a. Map k a -> Bool
Map.null FunctorParams
params then ModContextParams
NoParams
                                           else FunctorParams -> ModContextParams
FunctorParams FunctorParams
params
       , mctxExported :: Set Name
mctxExported = IfaceNames ModName -> Set Name
forall name. IfaceNames name -> Set Name
ifsPublic (IfaceG ModName -> IfaceNames ModName
forall name. IfaceG name -> IfaceNames name
ifNames IfaceG ModName
localIface)
       , mctxDecls :: IfaceDecls
mctxDecls    = [IfaceDecls] -> IfaceDecls
forall a. Monoid a => [a] -> a
mconcat (IfaceG ModName -> IfaceDecls
forall name. IfaceG name -> IfaceDecls
ifDefines IfaceG ModName
localIface IfaceDecls -> [IfaceDecls] -> [IfaceDecls]
forall a. a -> [a] -> [a]
: [IfaceDecls]
loadedDecls)
       , mctxNames :: NamingEnv
mctxNames    = NamingEnv
localNames
       , mctxNameDisp :: NameDisp
mctxNameDisp = NamingEnv -> NameDisp
R.toNameDisp NamingEnv
localNames
       }
  Maybe ModContext -> Maybe ModContext -> Maybe ModContext
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
  do LoadedSignature
lm <- ModName -> ModuleEnv -> Maybe LoadedSignature
lookupSignature ModName
mname ModuleEnv
me
     let localNames :: NamingEnv
localNames  = LoadedSignature -> NamingEnv
forall a. LoadedModuleG a -> NamingEnv
lmNamingEnv LoadedSignature
lm
         -- XXX: do we want only public ones here?
         loadedDecls :: [IfaceDecls]
loadedDecls = (LoadedModule -> IfaceDecls) -> [LoadedModule] -> [IfaceDecls]
forall a b. (a -> b) -> [a] -> [b]
map (IfaceG ModName -> IfaceDecls
forall name. IfaceG name -> IfaceDecls
ifDefines (IfaceG ModName -> IfaceDecls)
-> (LoadedModule -> IfaceG ModName) -> LoadedModule -> IfaceDecls
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoadedModule -> IfaceG ModName
lmInterface)
                     ([LoadedModule] -> [IfaceDecls]) -> [LoadedModule] -> [IfaceDecls]
forall a b. (a -> b) -> a -> b
$ LoadedModules -> [LoadedModule]
getLoadedModules (ModuleEnv -> LoadedModules
meLoadedModules ModuleEnv
me)
     ModContext -> Maybe ModContext
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModContext
       { mctxParams :: ModContextParams
mctxParams   = ModParamNames -> ModContextParams
InterfaceParams (LoadedSignature -> ModParamNames
forall a. LoadedModuleG a -> a
lmData LoadedSignature
lm)
       , mctxExported :: Set Name
mctxExported = Set Name
forall a. Set a
Set.empty
       , mctxDecls :: IfaceDecls
mctxDecls    = [IfaceDecls] -> IfaceDecls
forall a. Monoid a => [a] -> a
mconcat [IfaceDecls]
loadedDecls
       , mctxNames :: NamingEnv
mctxNames    = NamingEnv
localNames
       , mctxNameDisp :: NameDisp
mctxNameDisp = NamingEnv -> NameDisp
R.toNameDisp NamingEnv
localNames
       }



dynModContext :: ModuleEnv -> ModContext
dynModContext :: ModuleEnv -> ModContext
dynModContext ModuleEnv
me = ModContext
forall a. Monoid a => a
mempty { mctxNames    = dynNames
                          , mctxNameDisp = R.toNameDisp dynNames
                          , mctxDecls    = deIfaceDecls (meDynEnv me)
                          }
  where dynNames :: NamingEnv
dynNames = DynamicEnv -> NamingEnv
deNames (ModuleEnv -> DynamicEnv
meDynEnv ModuleEnv
me)




-- | Given the state of the environment, compute information about what's
-- in scope on the REPL.  This includes what's in the focused module, plus any
-- additional definitions from the REPL (e.g., let bound names, and @it@).
focusedEnv :: ModuleEnv -> ModContext
focusedEnv :: ModuleEnv -> ModContext
focusedEnv ModuleEnv
me =
  case ModuleEnv -> Maybe (ImpName Name)
meFocusedModule ModuleEnv
me of
    Maybe (ImpName Name)
Nothing -> ModuleEnv -> ModContext
dynModContext ModuleEnv
me
    Just ImpName Name
fm -> case ImpName Name -> ModuleEnv -> Maybe ModContext
modContextOf ImpName Name
fm ModuleEnv
me of
                 Just ModContext
c -> ModuleEnv -> ModContext
dynModContext ModuleEnv
me ModContext -> ModContext -> ModContext
forall a. Semigroup a => a -> a -> a
<> ModContext
c
                 Maybe ModContext
Nothing -> String -> [String] -> ModContext
forall a. HasCallStack => String -> [String] -> a
panic String
"focusedEnv"
                              [ String
"Focused modules not loaded: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
forall a. Show a => a -> String
show (ImpName Name -> Doc
forall a. PP a => a -> Doc
pp ImpName Name
fm) ]


-- Loaded Modules --------------------------------------------------------------

-- | The location of a module
data ModulePath = InFile FilePath
                | InMem String ByteString -- ^ Label, content
    deriving (Int -> ModulePath -> String -> String
[ModulePath] -> String -> String
ModulePath -> String
(Int -> ModulePath -> String -> String)
-> (ModulePath -> String)
-> ([ModulePath] -> String -> String)
-> Show ModulePath
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ModulePath -> String -> String
showsPrec :: Int -> ModulePath -> String -> String
$cshow :: ModulePath -> String
show :: ModulePath -> String
$cshowList :: [ModulePath] -> String -> String
showList :: [ModulePath] -> String -> String
Show, ReadPrec [ModulePath]
ReadPrec ModulePath
Int -> ReadS ModulePath
ReadS [ModulePath]
(Int -> ReadS ModulePath)
-> ReadS [ModulePath]
-> ReadPrec ModulePath
-> ReadPrec [ModulePath]
-> Read ModulePath
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS ModulePath
readsPrec :: Int -> ReadS ModulePath
$creadList :: ReadS [ModulePath]
readList :: ReadS [ModulePath]
$creadPrec :: ReadPrec ModulePath
readPrec :: ReadPrec ModulePath
$creadListPrec :: ReadPrec [ModulePath]
readListPrec :: ReadPrec [ModulePath]
Read, (forall x. ModulePath -> Rep ModulePath x)
-> (forall x. Rep ModulePath x -> ModulePath) -> Generic ModulePath
forall x. Rep ModulePath x -> ModulePath
forall x. ModulePath -> Rep ModulePath x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ModulePath -> Rep ModulePath x
from :: forall x. ModulePath -> Rep ModulePath x
$cto :: forall x. Rep ModulePath x -> ModulePath
to :: forall x. Rep ModulePath x -> ModulePath
Generic, ModulePath -> ()
(ModulePath -> ()) -> NFData ModulePath
forall a. (a -> ()) -> NFData a
$crnf :: ModulePath -> ()
rnf :: ModulePath -> ()
NFData)

-- | In-memory things are compared by label.
instance Eq ModulePath where
  ModulePath
p1 == :: ModulePath -> ModulePath -> Bool
== ModulePath
p2 =
    case (ModulePath
p1,ModulePath
p2) of
      (InFile String
x, InFile String
y) -> String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
y
      (InMem String
a ByteString
_, InMem String
b ByteString
_) -> String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
b
      (ModulePath, ModulePath)
_ -> Bool
False

-- | In-memory things are compared by label.
instance Ord ModulePath where
  compare :: ModulePath -> ModulePath -> Ordering
compare ModulePath
p1 ModulePath
p2 =
    case (ModulePath
p1,ModulePath
p2) of
      (InFile String
x, InFile String
y)   -> String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
compare String
x String
y
      (InMem String
a ByteString
_, InMem String
b ByteString
_) -> String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
compare String
a String
b
      (InMem {}, InFile {})  -> Ordering
LT
      (InFile {}, InMem {})  -> Ordering
GT



instance PP ModulePath where
  ppPrec :: Int -> ModulePath -> Doc
ppPrec Int
_ ModulePath
e =
    case ModulePath
e of
      InFile String
p  -> String -> Doc
text String
p
      InMem String
l ByteString
_ -> Doc -> Doc
parens (String -> Doc
text String
l)



-- | The name of the content---either the file path, or the provided label.
modulePathLabel :: ModulePath -> String
modulePathLabel :: ModulePath -> String
modulePathLabel ModulePath
p =
  case ModulePath
p of
    InFile String
path -> String
path
    InMem String
lab ByteString
_ -> String
lab



data LoadedModules = LoadedModules
  { LoadedModules -> [LoadedModule]
lmLoadedModules      :: [LoadedModule]
    -- ^ Invariants:
    -- 1) All the dependencies of any module `m` must precede `m` in the list.
    -- 2) Does not contain any parameterized modules.

  , LoadedModules -> [LoadedModule]
lmLoadedParamModules :: [LoadedModule]
    -- ^ Loaded parameterized modules.

  , LoadedModules -> [LoadedSignature]
lmLoadedSignatures :: ![LoadedSignature]

  } deriving (Int -> LoadedModules -> String -> String
[LoadedModules] -> String -> String
LoadedModules -> String
(Int -> LoadedModules -> String -> String)
-> (LoadedModules -> String)
-> ([LoadedModules] -> String -> String)
-> Show LoadedModules
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> LoadedModules -> String -> String
showsPrec :: Int -> LoadedModules -> String -> String
$cshow :: LoadedModules -> String
show :: LoadedModules -> String
$cshowList :: [LoadedModules] -> String -> String
showList :: [LoadedModules] -> String -> String
Show, (forall x. LoadedModules -> Rep LoadedModules x)
-> (forall x. Rep LoadedModules x -> LoadedModules)
-> Generic LoadedModules
forall x. Rep LoadedModules x -> LoadedModules
forall x. LoadedModules -> Rep LoadedModules x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. LoadedModules -> Rep LoadedModules x
from :: forall x. LoadedModules -> Rep LoadedModules x
$cto :: forall x. Rep LoadedModules x -> LoadedModules
to :: forall x. Rep LoadedModules x -> LoadedModules
Generic, LoadedModules -> ()
(LoadedModules -> ()) -> NFData LoadedModules
forall a. (a -> ()) -> NFData a
$crnf :: LoadedModules -> ()
rnf :: LoadedModules -> ()
NFData)

data LoadedEntity =
    ALoadedModule LoadedModule
  | ALoadedFunctor LoadedModule
  | ALoadedInterface LoadedSignature

getLoadedEntities ::
  LoadedModules -> Map ModName LoadedEntity
getLoadedEntities :: LoadedModules -> Map ModName LoadedEntity
getLoadedEntities LoadedModules
lm =
  [(ModName, LoadedEntity)] -> Map ModName LoadedEntity
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ModName, LoadedEntity)] -> Map ModName LoadedEntity)
-> [(ModName, LoadedEntity)] -> Map ModName LoadedEntity
forall a b. (a -> b) -> a -> b
$ [ (LoadedModule -> ModName
forall a. LoadedModuleG a -> ModName
lmName LoadedModule
x, LoadedModule -> LoadedEntity
ALoadedModule LoadedModule
x) | LoadedModule
x <- LoadedModules -> [LoadedModule]
lmLoadedModules LoadedModules
lm ] [(ModName, LoadedEntity)]
-> [(ModName, LoadedEntity)] -> [(ModName, LoadedEntity)]
forall a. [a] -> [a] -> [a]
++
                 [ (LoadedModule -> ModName
forall a. LoadedModuleG a -> ModName
lmName LoadedModule
x, LoadedModule -> LoadedEntity
ALoadedFunctor LoadedModule
x) | LoadedModule
x <- LoadedModules -> [LoadedModule]
lmLoadedParamModules LoadedModules
lm ] [(ModName, LoadedEntity)]
-> [(ModName, LoadedEntity)] -> [(ModName, LoadedEntity)]
forall a. [a] -> [a] -> [a]
++
                 [ (LoadedSignature -> ModName
forall a. LoadedModuleG a -> ModName
lmName LoadedSignature
x, LoadedSignature -> LoadedEntity
ALoadedInterface LoadedSignature
x) | LoadedSignature
x <- LoadedModules -> [LoadedSignature]
lmLoadedSignatures LoadedModules
lm ]

getLoadedModules :: LoadedModules -> [LoadedModule]
getLoadedModules :: LoadedModules -> [LoadedModule]
getLoadedModules LoadedModules
x = LoadedModules -> [LoadedModule]
lmLoadedParamModules LoadedModules
x [LoadedModule] -> [LoadedModule] -> [LoadedModule]
forall a. [a] -> [a] -> [a]
++ LoadedModules -> [LoadedModule]
lmLoadedModules LoadedModules
x

getLoadedField :: Ord a =>
  (forall b. LoadedModuleG b -> a) -> LoadedModules -> Set a
getLoadedField :: forall a.
Ord a =>
(forall b. LoadedModuleG b -> a) -> LoadedModules -> Set a
getLoadedField forall b. LoadedModuleG b -> a
f LoadedModules
lm = [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList
                    ([a] -> Set a) -> [a] -> Set a
forall a b. (a -> b) -> a -> b
$ (LoadedModule -> a) -> [LoadedModule] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map LoadedModule -> a
forall b. LoadedModuleG b -> a
f (LoadedModules -> [LoadedModule]
lmLoadedModules LoadedModules
lm)
                   [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ (LoadedModule -> a) -> [LoadedModule] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map LoadedModule -> a
forall b. LoadedModuleG b -> a
f (LoadedModules -> [LoadedModule]
lmLoadedParamModules LoadedModules
lm)
                   [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ (LoadedSignature -> a) -> [LoadedSignature] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map LoadedSignature -> a
forall b. LoadedModuleG b -> a
f (LoadedModules -> [LoadedSignature]
lmLoadedSignatures LoadedModules
lm)

getLoadedNames :: LoadedModules -> Set ModName
getLoadedNames :: LoadedModules -> Set ModName
getLoadedNames = (forall a. LoadedModuleG a -> ModName)
-> LoadedModules -> Set ModName
forall a.
Ord a =>
(forall b. LoadedModuleG b -> a) -> LoadedModules -> Set a
getLoadedField LoadedModuleG b -> ModName
forall a. LoadedModuleG a -> ModName
lmName

getLoadedIds :: LoadedModules -> Set String
getLoadedIds :: LoadedModules -> Set String
getLoadedIds = (forall b. LoadedModuleG b -> String)
-> LoadedModules -> Set String
forall a.
Ord a =>
(forall b. LoadedModuleG b -> a) -> LoadedModules -> Set a
getLoadedField LoadedModuleG b -> String
forall b. LoadedModuleG b -> String
lmModuleId

instance Semigroup LoadedModules where
  LoadedModules
l <> :: LoadedModules -> LoadedModules -> LoadedModules
<> LoadedModules
r = LoadedModules
    { lmLoadedModules :: [LoadedModule]
lmLoadedModules = (LoadedModule -> LoadedModule -> Bool)
-> [LoadedModule] -> [LoadedModule] -> [LoadedModule]
forall a. (a -> a -> Bool) -> [a] -> [a] -> [a]
List.unionBy (ModName -> ModName -> Bool
forall a. Eq a => a -> a -> Bool
(==) (ModName -> ModName -> Bool)
-> (LoadedModule -> ModName)
-> LoadedModule
-> LoadedModule
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` LoadedModule -> ModName
forall a. LoadedModuleG a -> ModName
lmName)
                                      (LoadedModules -> [LoadedModule]
lmLoadedModules LoadedModules
l) (LoadedModules -> [LoadedModule]
lmLoadedModules LoadedModules
r)
    , lmLoadedParamModules :: [LoadedModule]
lmLoadedParamModules = LoadedModules -> [LoadedModule]
lmLoadedParamModules LoadedModules
l [LoadedModule] -> [LoadedModule] -> [LoadedModule]
forall a. [a] -> [a] -> [a]
++ LoadedModules -> [LoadedModule]
lmLoadedParamModules LoadedModules
r
    , lmLoadedSignatures :: [LoadedSignature]
lmLoadedSignatures   = LoadedModules -> [LoadedSignature]
lmLoadedSignatures LoadedModules
l [LoadedSignature] -> [LoadedSignature] -> [LoadedSignature]
forall a. [a] -> [a] -> [a]
++ LoadedModules -> [LoadedSignature]
lmLoadedSignatures LoadedModules
r
    }

instance Monoid LoadedModules where
  mempty :: LoadedModules
mempty = LoadedModules { lmLoadedModules :: [LoadedModule]
lmLoadedModules = []
                         , lmLoadedParamModules :: [LoadedModule]
lmLoadedParamModules = []
                         , lmLoadedSignatures :: [LoadedSignature]
lmLoadedSignatures = []
                         }
  mappend :: LoadedModules -> LoadedModules -> LoadedModules
mappend = LoadedModules -> LoadedModules -> LoadedModules
forall a. Semigroup a => a -> a -> a
(<>)

-- | A generic type for loaded things.
-- The things can be either modules or signatures.
data LoadedModuleG a = LoadedModule
  { forall a. LoadedModuleG a -> ModName
lmName              :: ModName
    -- ^ The name of this module.  Should match what's in 'lmModule'

  , forall a. LoadedModuleG a -> ModulePath
lmFilePath          :: ModulePath
    -- ^ The file path used to load this module (may not be canonical)

  , forall b. LoadedModuleG b -> String
lmModuleId          :: String
    -- ^ An identifier used to identify the source of the bytes for the module.
    -- For files we just use the cononical path, for in memory things we
    -- use their label.

  , forall a. LoadedModuleG a -> NamingEnv
lmNamingEnv         :: !R.NamingEnv
    -- ^ What's in scope in this module

  , forall a. LoadedModuleG a -> FileInfo
lmFileInfo          :: !FileInfo

  , forall a. LoadedModuleG a -> a
lmData              :: a
  } deriving (Int -> LoadedModuleG a -> String -> String
[LoadedModuleG a] -> String -> String
LoadedModuleG a -> String
(Int -> LoadedModuleG a -> String -> String)
-> (LoadedModuleG a -> String)
-> ([LoadedModuleG a] -> String -> String)
-> Show (LoadedModuleG a)
forall a. Show a => Int -> LoadedModuleG a -> String -> String
forall a. Show a => [LoadedModuleG a] -> String -> String
forall a. Show a => LoadedModuleG a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: forall a. Show a => Int -> LoadedModuleG a -> String -> String
showsPrec :: Int -> LoadedModuleG a -> String -> String
$cshow :: forall a. Show a => LoadedModuleG a -> String
show :: LoadedModuleG a -> String
$cshowList :: forall a. Show a => [LoadedModuleG a] -> String -> String
showList :: [LoadedModuleG a] -> String -> String
Show, (forall x. LoadedModuleG a -> Rep (LoadedModuleG a) x)
-> (forall x. Rep (LoadedModuleG a) x -> LoadedModuleG a)
-> Generic (LoadedModuleG a)
forall x. Rep (LoadedModuleG a) x -> LoadedModuleG a
forall x. LoadedModuleG a -> Rep (LoadedModuleG a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (LoadedModuleG a) x -> LoadedModuleG a
forall a x. LoadedModuleG a -> Rep (LoadedModuleG a) x
$cfrom :: forall a x. LoadedModuleG a -> Rep (LoadedModuleG a) x
from :: forall x. LoadedModuleG a -> Rep (LoadedModuleG a) x
$cto :: forall a x. Rep (LoadedModuleG a) x -> LoadedModuleG a
to :: forall x. Rep (LoadedModuleG a) x -> LoadedModuleG a
Generic, LoadedModuleG a -> ()
(LoadedModuleG a -> ()) -> NFData (LoadedModuleG a)
forall a. NFData a => LoadedModuleG a -> ()
forall a. (a -> ()) -> NFData a
$crnf :: forall a. NFData a => LoadedModuleG a -> ()
rnf :: LoadedModuleG a -> ()
NFData)

type LoadedModule = LoadedModuleG LoadedModuleData

lmModule :: LoadedModule -> T.Module
lmModule :: LoadedModule -> Module
lmModule = LoadedModuleData -> Module
lmdModule (LoadedModuleData -> Module)
-> (LoadedModule -> LoadedModuleData) -> LoadedModule -> Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoadedModule -> LoadedModuleData
forall a. LoadedModuleG a -> a
lmData

lmInterface :: LoadedModule -> Iface
lmInterface :: LoadedModule -> IfaceG ModName
lmInterface = LoadedModuleData -> IfaceG ModName
lmdInterface (LoadedModuleData -> IfaceG ModName)
-> (LoadedModule -> LoadedModuleData)
-> LoadedModule
-> IfaceG ModName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoadedModule -> LoadedModuleData
forall a. LoadedModuleG a -> a
lmData

data LoadedModuleData = LoadedModuleData
  { LoadedModuleData -> IfaceG ModName
lmdInterface         :: Iface
    -- ^ The module's interface.

  , LoadedModuleData -> Module
lmdModule            :: T.Module
    -- ^ The actual type-checked module

  , LoadedModuleData -> Maybe ForeignSrc
lmForeignSrc        :: Maybe ForeignSrc
    -- ^ The dynamically loaded source for any foreign functions in the module
  } deriving (Int -> LoadedModuleData -> String -> String
[LoadedModuleData] -> String -> String
LoadedModuleData -> String
(Int -> LoadedModuleData -> String -> String)
-> (LoadedModuleData -> String)
-> ([LoadedModuleData] -> String -> String)
-> Show LoadedModuleData
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> LoadedModuleData -> String -> String
showsPrec :: Int -> LoadedModuleData -> String -> String
$cshow :: LoadedModuleData -> String
show :: LoadedModuleData -> String
$cshowList :: [LoadedModuleData] -> String -> String
showList :: [LoadedModuleData] -> String -> String
Show, (forall x. LoadedModuleData -> Rep LoadedModuleData x)
-> (forall x. Rep LoadedModuleData x -> LoadedModuleData)
-> Generic LoadedModuleData
forall x. Rep LoadedModuleData x -> LoadedModuleData
forall x. LoadedModuleData -> Rep LoadedModuleData x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. LoadedModuleData -> Rep LoadedModuleData x
from :: forall x. LoadedModuleData -> Rep LoadedModuleData x
$cto :: forall x. Rep LoadedModuleData x -> LoadedModuleData
to :: forall x. Rep LoadedModuleData x -> LoadedModuleData
Generic, LoadedModuleData -> ()
(LoadedModuleData -> ()) -> NFData LoadedModuleData
forall a. (a -> ()) -> NFData a
$crnf :: LoadedModuleData -> ()
rnf :: LoadedModuleData -> ()
NFData)

type LoadedSignature = LoadedModuleG T.ModParamNames


-- | Has this module been loaded already.
isLoaded :: ImpName Name -> LoadedModules -> Bool
isLoaded :: ImpName Name -> LoadedModules -> Bool
isLoaded (ImpTop ModName
mn) LoadedModules
lm = ModName
mn ModName -> Set ModName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` LoadedModules -> Set ModName
getLoadedNames LoadedModules
lm
isLoaded (ImpNested Name
nn) LoadedModules
lm = (LoadedModule -> Bool) -> [LoadedModule] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Module -> Bool
forall a. ModuleG a -> Bool
check (Module -> Bool)
-> (LoadedModule -> Module) -> LoadedModule -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoadedModule -> Module
lmModule) (LoadedModules -> [LoadedModule]
getLoadedModules LoadedModules
lm)
  where
    check :: T.ModuleG a -> Bool
    check :: forall a. ModuleG a -> Bool
check ModuleG a
m =
      Name -> Map Name Submodule -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Name
nn (ModuleG a -> Map Name Submodule
forall mname. ModuleG mname -> Map Name Submodule
T.mSubmodules ModuleG a
m) Bool -> Bool -> Bool
||
      Name -> Map Name ModParamNames -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Name
nn (ModuleG a -> Map Name ModParamNames
forall mname. ModuleG mname -> Map Name ModParamNames
T.mSignatures ModuleG a
m) Bool -> Bool -> Bool
||
      Name -> Map Name Submodule -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Name
nn (ModuleG a -> Map Name Submodule
forall mname. ModuleG mname -> Map Name Submodule
T.mSubmodules ModuleG a
m) Bool -> Bool -> Bool
||
      (ModuleG Name -> Bool) -> Map Name (ModuleG Name) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ModuleG Name -> Bool
forall a. ModuleG a -> Bool
check (ModuleG a -> Map Name (ModuleG Name)
forall mname. ModuleG mname -> Map Name (ModuleG Name)
T.mFunctors ModuleG a
m)

isLoadedStrict :: ImpName Name -> String -> LoadedModules -> Bool
isLoadedStrict :: ImpName Name -> String -> LoadedModules -> Bool
isLoadedStrict ImpName Name
mn String
modId LoadedModules
lm =
  ImpName Name -> LoadedModules -> Bool
isLoaded ImpName Name
mn LoadedModules
lm Bool -> Bool -> Bool
&& String
modId String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` LoadedModules -> Set String
getLoadedIds LoadedModules
lm

-- | Is this a loaded parameterized module.
isLoadedParamMod :: ImpName Name -> LoadedModules -> Bool
isLoadedParamMod :: ImpName Name -> LoadedModules -> Bool
isLoadedParamMod (ImpTop ModName
mn) LoadedModules
lm = (LoadedModule -> Bool) -> [LoadedModule] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((ModName
mn ModName -> ModName -> Bool
forall a. Eq a => a -> a -> Bool
==) (ModName -> Bool)
-> (LoadedModule -> ModName) -> LoadedModule -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoadedModule -> ModName
forall a. LoadedModuleG a -> ModName
lmName) (LoadedModules -> [LoadedModule]
lmLoadedParamModules LoadedModules
lm)
isLoadedParamMod (ImpNested Name
n) LoadedModules
lm =
  (LoadedModule -> Bool) -> [LoadedModule] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Module -> Bool
forall a. ModuleG a -> Bool
check1 (Module -> Bool)
-> (LoadedModule -> Module) -> LoadedModule -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoadedModule -> Module
lmModule) (LoadedModules -> [LoadedModule]
lmLoadedModules LoadedModules
lm) Bool -> Bool -> Bool
||
  (LoadedModule -> Bool) -> [LoadedModule] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Module -> Bool
forall a. ModuleG a -> Bool
check2 (Module -> Bool)
-> (LoadedModule -> Module) -> LoadedModule -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoadedModule -> Module
lmModule) (LoadedModules -> [LoadedModule]
lmLoadedParamModules LoadedModules
lm)
  where
    -- We haven't crossed into a parameterized functor yet
    check1 :: ModuleG mname -> Bool
check1 ModuleG mname
m = Name -> Map Name (ModuleG Name) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Name
n (ModuleG mname -> Map Name (ModuleG Name)
forall mname. ModuleG mname -> Map Name (ModuleG Name)
T.mFunctors ModuleG mname
m)
            Bool -> Bool -> Bool
|| (ModuleG Name -> Bool) -> Map Name (ModuleG Name) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ModuleG Name -> Bool
forall a. ModuleG a -> Bool
check2 (ModuleG mname -> Map Name (ModuleG Name)
forall mname. ModuleG mname -> Map Name (ModuleG Name)
T.mFunctors ModuleG mname
m)

    -- We're inside a parameterized module and are finished as soon as we have containment
    check2 :: T.ModuleG a -> Bool
    check2 :: forall a. ModuleG a -> Bool
check2 ModuleG a
m =
      Name -> Map Name Submodule -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Name
n (ModuleG a -> Map Name Submodule
forall mname. ModuleG mname -> Map Name Submodule
T.mSubmodules ModuleG a
m) Bool -> Bool -> Bool
||
      Name -> Map Name ModParamNames -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Name
n (ModuleG a -> Map Name ModParamNames
forall mname. ModuleG mname -> Map Name ModParamNames
T.mSignatures ModuleG a
m) Bool -> Bool -> Bool
||
      Name -> Map Name (ModuleG Name) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Name
n (ModuleG a -> Map Name (ModuleG Name)
forall mname. ModuleG mname -> Map Name (ModuleG Name)
T.mFunctors ModuleG a
m) Bool -> Bool -> Bool
||
      (ModuleG Name -> Bool) -> Map Name (ModuleG Name) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ModuleG Name -> Bool
forall a. ModuleG a -> Bool
check2 (ModuleG a -> Map Name (ModuleG Name)
forall mname. ModuleG mname -> Map Name (ModuleG Name)
T.mFunctors ModuleG a
m)

-- | Is this a loaded interface module.
isLoadedInterface :: ImpName Name -> LoadedModules -> Bool
isLoadedInterface :: ImpName Name -> LoadedModules -> Bool
isLoadedInterface (ImpTop ModName
mn) LoadedModules
ln = (LoadedSignature -> Bool) -> [LoadedSignature] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((ModName
mn ModName -> ModName -> Bool
forall a. Eq a => a -> a -> Bool
==) (ModName -> Bool)
-> (LoadedSignature -> ModName) -> LoadedSignature -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoadedSignature -> ModName
forall a. LoadedModuleG a -> ModName
lmName) (LoadedModules -> [LoadedSignature]
lmLoadedSignatures LoadedModules
ln)
isLoadedInterface (ImpNested Name
nn) LoadedModules
ln = (LoadedModule -> Bool) -> [LoadedModule] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Module -> Bool
forall a. ModuleG a -> Bool
check (Module -> Bool)
-> (LoadedModule -> Module) -> LoadedModule -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoadedModule -> Module
lmModule) (LoadedModules -> [LoadedModule]
getLoadedModules LoadedModules
ln)
  where
    check :: T.ModuleG a -> Bool
    check :: forall a. ModuleG a -> Bool
check ModuleG a
m =
      Name -> Map Name ModParamNames -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Name
nn (ModuleG a -> Map Name ModParamNames
forall mname. ModuleG mname -> Map Name ModParamNames
T.mSignatures ModuleG a
m) Bool -> Bool -> Bool
||
      (ModuleG Name -> Bool) -> Map Name (ModuleG Name) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ModuleG Name -> Bool
forall a. ModuleG a -> Bool
check (ModuleG a -> Map Name (ModuleG Name)
forall mname. ModuleG mname -> Map Name (ModuleG Name)
T.mFunctors ModuleG a
m)

-- | Return the set of type parameters (@'Set' 'T.TParam'@) and definitions
-- (@'Set' 'Name'@) from the supplied 'LoadedModules' value that another
-- definition (of type @a@) depends on.
loadedParamModDeps ::
  T.FreeVars a =>
  LoadedModules ->
  a ->
  (Set T.TParam, Set Name)
loadedParamModDeps :: forall a.
FreeVars a =>
LoadedModules -> a -> (Set TParam, Set Name)
loadedParamModDeps LoadedModules
lm a
a = (Set TParam
badTs, Set Name
bad)
  where
    ds :: Deps
ds      = a -> Deps
forall e. FreeVars e => e -> Deps
T.freeVars a
a
    badVals :: Set Name
badVals = (Name -> Set Name -> Set Name) -> Set Name -> Set Name -> Set Name
forall a b. (a -> b -> b) -> b -> Set a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Name -> Set Name -> Set Name
badName Set Name
forall a. Set a
Set.empty (Deps -> Set Name
T.valDeps Deps
ds)
    bad :: Set Name
bad     = (Name -> Set Name -> Set Name) -> Set Name -> Set Name -> Set Name
forall a b. (a -> b -> b) -> b -> Set a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Name -> Set Name -> Set Name
badName Set Name
badVals (Deps -> Set Name
T.tyDeps Deps
ds)
    badTs :: Set TParam
badTs   = Deps -> Set TParam
T.tyParams Deps
ds

    badName :: Name -> Set Name -> Set Name
badName Name
nm Set Name
bs =
      case Name -> NameInfo
nameInfo Name
nm of

        -- XXX: Changes if focusing on nested modules
        GlobalName NameSource
_ I.OrigName { ogModule :: OrigName -> ModPath
ogModule = I.TopModule ModName
m }
          | ImpName Name -> LoadedModules -> Bool
isLoadedParamMod (ModName -> ImpName Name
forall name. ModName -> ImpName name
ImpTop ModName
m) LoadedModules
lm -> Name -> Set Name -> Set Name
forall a. Ord a => a -> Set a -> Set a
Set.insert Name
nm Set Name
bs
          | ImpName Name -> LoadedModules -> Bool
isLoadedInterface (ModName -> ImpName Name
forall name. ModName -> ImpName name
ImpTop ModName
m) LoadedModules
lm -> Name -> Set Name -> Set Name
forall a. Ord a => a -> Set a -> Set a
Set.insert Name
nm Set Name
bs

        NameInfo
_ -> Set Name
bs


lookupTCEntity :: ModName -> ModuleEnv -> Maybe (LoadedModuleG T.TCTopEntity)
lookupTCEntity :: ModName -> ModuleEnv -> Maybe (LoadedModuleG TCTopEntity)
lookupTCEntity ModName
m ModuleEnv
env =
  case ModName -> ModuleEnv -> Maybe LoadedModule
lookupModule ModName
m ModuleEnv
env of
    Just LoadedModule
lm -> LoadedModuleG TCTopEntity -> Maybe (LoadedModuleG TCTopEntity)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoadedModule
lm { lmData = T.TCTopModule (lmModule lm) }
    Maybe LoadedModule
Nothing ->
      do LoadedSignature
lm <- ModName -> ModuleEnv -> Maybe LoadedSignature
lookupSignature ModName
m ModuleEnv
env
         LoadedModuleG TCTopEntity -> Maybe (LoadedModuleG TCTopEntity)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoadedSignature
lm { lmData = T.TCTopSignature m (lmData lm) }

-- | Try to find a previously loaded module
lookupModule :: ModName -> ModuleEnv -> Maybe LoadedModule
lookupModule :: ModName -> ModuleEnv -> Maybe LoadedModule
lookupModule ModName
mn = (LoadedModule -> Bool) -> ModuleEnv -> Maybe LoadedModule
lookupModuleWith ((ModName
mn ModName -> ModName -> Bool
forall a. Eq a => a -> a -> Bool
==) (ModName -> Bool)
-> (LoadedModule -> ModName) -> LoadedModule -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoadedModule -> ModName
forall a. LoadedModuleG a -> ModName
lmName)

lookupModuleWith :: (LoadedModule -> Bool) -> ModuleEnv -> Maybe LoadedModule
lookupModuleWith :: (LoadedModule -> Bool) -> ModuleEnv -> Maybe LoadedModule
lookupModuleWith LoadedModule -> Bool
p ModuleEnv
me =
  (LoadedModules -> [LoadedModule]) -> Maybe LoadedModule
forall {t :: * -> *}.
Foldable t =>
(LoadedModules -> t LoadedModule) -> Maybe LoadedModule
search LoadedModules -> [LoadedModule]
lmLoadedModules Maybe LoadedModule -> Maybe LoadedModule -> Maybe LoadedModule
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (LoadedModules -> [LoadedModule]) -> Maybe LoadedModule
forall {t :: * -> *}.
Foldable t =>
(LoadedModules -> t LoadedModule) -> Maybe LoadedModule
search LoadedModules -> [LoadedModule]
lmLoadedParamModules
  where
  search :: (LoadedModules -> t LoadedModule) -> Maybe LoadedModule
search LoadedModules -> t LoadedModule
how = (LoadedModule -> Bool) -> t LoadedModule -> Maybe LoadedModule
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find LoadedModule -> Bool
p (LoadedModules -> t LoadedModule
how (ModuleEnv -> LoadedModules
meLoadedModules ModuleEnv
me))

lookupSignature :: ModName -> ModuleEnv -> Maybe LoadedSignature
lookupSignature :: ModName -> ModuleEnv -> Maybe LoadedSignature
lookupSignature ModName
mn = (LoadedSignature -> Bool) -> ModuleEnv -> Maybe LoadedSignature
lookupSignatureWith ((ModName
mn ModName -> ModName -> Bool
forall a. Eq a => a -> a -> Bool
==) (ModName -> Bool)
-> (LoadedSignature -> ModName) -> LoadedSignature -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoadedSignature -> ModName
forall a. LoadedModuleG a -> ModName
lmName)

lookupSignatureWith ::
  (LoadedSignature -> Bool) -> ModuleEnv -> Maybe LoadedSignature
lookupSignatureWith :: (LoadedSignature -> Bool) -> ModuleEnv -> Maybe LoadedSignature
lookupSignatureWith LoadedSignature -> Bool
p ModuleEnv
me = (LoadedSignature -> Bool)
-> [LoadedSignature] -> Maybe LoadedSignature
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find LoadedSignature -> Bool
p (LoadedModules -> [LoadedSignature]
lmLoadedSignatures (ModuleEnv -> LoadedModules
meLoadedModules ModuleEnv
me))

addLoadedSignature ::
  ModulePath -> String ->
  FileInfo ->
  R.NamingEnv ->
  ModName -> T.ModParamNames ->
  LoadedModules -> LoadedModules
addLoadedSignature :: ModulePath
-> String
-> FileInfo
-> NamingEnv
-> ModName
-> ModParamNames
-> LoadedModules
-> LoadedModules
addLoadedSignature ModulePath
path String
ident FileInfo
fi NamingEnv
nameEnv ModName
nm ModParamNames
si LoadedModules
lm
  | ImpName Name -> String -> LoadedModules -> Bool
isLoadedStrict (ModName -> ImpName Name
forall name. ModName -> ImpName name
ImpTop ModName
nm) String
ident LoadedModules
lm = LoadedModules
lm
  | Bool
otherwise = LoadedModules
lm { lmLoadedSignatures = loaded : lmLoadedSignatures lm }
  where
  loaded :: LoadedSignature
loaded = LoadedModule
            { lmName :: ModName
lmName        = ModName
nm
            , lmFilePath :: ModulePath
lmFilePath    = ModulePath
path
            , lmModuleId :: String
lmModuleId    = String
ident
            , lmNamingEnv :: NamingEnv
lmNamingEnv   = NamingEnv
nameEnv
            , lmData :: ModParamNames
lmData        = ModParamNames
si
            , lmFileInfo :: FileInfo
lmFileInfo    = FileInfo
fi
            }

-- | Add a freshly loaded module.  If it was previously loaded, then
-- the new version is ignored.
addLoadedModule ::
  ModulePath ->
  String ->
  FileInfo ->
  R.NamingEnv ->
  Maybe ForeignSrc ->
  T.Module -> LoadedModules -> LoadedModules
addLoadedModule :: ModulePath
-> String
-> FileInfo
-> NamingEnv
-> Maybe ForeignSrc
-> Module
-> LoadedModules
-> LoadedModules
addLoadedModule ModulePath
path String
ident FileInfo
fi NamingEnv
nameEnv Maybe ForeignSrc
fsrc Module
tm LoadedModules
lm
  | ImpName Name -> String -> LoadedModules -> Bool
isLoadedStrict (ModName -> ImpName Name
forall name. ModName -> ImpName name
ImpTop (Module -> ModName
forall mname. ModuleG mname -> mname
T.mName Module
tm)) String
ident LoadedModules
lm = LoadedModules
lm
  | Module -> Bool
forall a. ModuleG a -> Bool
T.isParametrizedModule Module
tm = LoadedModules
lm { lmLoadedParamModules = loaded :
                                                lmLoadedParamModules lm }
  | Bool
otherwise                = LoadedModules
lm { lmLoadedModules =
                                          lmLoadedModules lm ++ [loaded] }
  where
  loaded :: LoadedModule
loaded = LoadedModule
    { lmName :: ModName
lmName            = Module -> ModName
forall mname. ModuleG mname -> mname
T.mName Module
tm
    , lmFilePath :: ModulePath
lmFilePath        = ModulePath
path
    , lmModuleId :: String
lmModuleId        = String
ident
    , lmNamingEnv :: NamingEnv
lmNamingEnv       = NamingEnv
nameEnv
    , lmData :: LoadedModuleData
lmData            = LoadedModuleData
                             { lmdInterface :: IfaceG ModName
lmdInterface = Module -> IfaceG ModName
forall name. ModuleG name -> IfaceG name
T.genIface Module
tm
                             , lmdModule :: Module
lmdModule    = Module
tm
                             , lmForeignSrc :: Maybe ForeignSrc
lmForeignSrc = Maybe ForeignSrc
fsrc
                             }
    , lmFileInfo :: FileInfo
lmFileInfo        = FileInfo
fi
    }

-- | Remove a previously loaded module.
-- Note that this removes exactly the modules specified by the predicate.
-- One should be carfule to preserve the invariant on 'LoadedModules'.
removeLoadedModule ::
  (forall a. LoadedModuleG a -> Bool) -> LoadedModules -> LoadedModules
removeLoadedModule :: (forall a. LoadedModuleG a -> Bool)
-> LoadedModules -> LoadedModules
removeLoadedModule forall a. LoadedModuleG a -> Bool
rm LoadedModules
lm =
  LoadedModules
    { lmLoadedModules :: [LoadedModule]
lmLoadedModules       = (LoadedModule -> Bool) -> [LoadedModule] -> [LoadedModule]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (LoadedModule -> Bool) -> LoadedModule -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoadedModule -> Bool
forall a. LoadedModuleG a -> Bool
rm) (LoadedModules -> [LoadedModule]
lmLoadedModules LoadedModules
lm)
    , lmLoadedParamModules :: [LoadedModule]
lmLoadedParamModules  = (LoadedModule -> Bool) -> [LoadedModule] -> [LoadedModule]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (LoadedModule -> Bool) -> LoadedModule -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoadedModule -> Bool
forall a. LoadedModuleG a -> Bool
rm) (LoadedModules -> [LoadedModule]
lmLoadedParamModules LoadedModules
lm)
    , lmLoadedSignatures :: [LoadedSignature]
lmLoadedSignatures    = (LoadedSignature -> Bool) -> [LoadedSignature] -> [LoadedSignature]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (LoadedSignature -> Bool) -> LoadedSignature -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoadedSignature -> Bool
forall a. LoadedModuleG a -> Bool
rm) (LoadedModules -> [LoadedSignature]
lmLoadedSignatures LoadedModules
lm)
    }

-- FileInfo --------------------------------------------------------------------

data FileInfo = FileInfo
  { FileInfo -> Fingerprint
fiFingerprint :: Fingerprint
  , FileInfo -> Map String Fingerprint
fiIncludeDeps :: Map FilePath Fingerprint
  , FileInfo -> Set ModName
fiImportDeps  :: Set ModName
  , FileInfo -> Map String Bool
fiForeignDeps :: Map FilePath Bool
    -- ^ The bool indicates if the library for the foreign import exists.
  } deriving (Int -> FileInfo -> String -> String
[FileInfo] -> String -> String
FileInfo -> String
(Int -> FileInfo -> String -> String)
-> (FileInfo -> String)
-> ([FileInfo] -> String -> String)
-> Show FileInfo
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> FileInfo -> String -> String
showsPrec :: Int -> FileInfo -> String -> String
$cshow :: FileInfo -> String
show :: FileInfo -> String
$cshowList :: [FileInfo] -> String -> String
showList :: [FileInfo] -> String -> String
Show,(forall x. FileInfo -> Rep FileInfo x)
-> (forall x. Rep FileInfo x -> FileInfo) -> Generic FileInfo
forall x. Rep FileInfo x -> FileInfo
forall x. FileInfo -> Rep FileInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. FileInfo -> Rep FileInfo x
from :: forall x. FileInfo -> Rep FileInfo x
$cto :: forall x. Rep FileInfo x -> FileInfo
to :: forall x. Rep FileInfo x -> FileInfo
Generic,FileInfo -> ()
(FileInfo -> ()) -> NFData FileInfo
forall a. (a -> ()) -> NFData a
$crnf :: FileInfo -> ()
rnf :: FileInfo -> ()
NFData)


fileInfo ::
  Fingerprint ->
  Map FilePath Fingerprint ->
  Set ModName ->
  Maybe ForeignSrc ->
  FileInfo
fileInfo :: Fingerprint
-> Map String Fingerprint
-> Set ModName
-> Maybe ForeignSrc
-> FileInfo
fileInfo Fingerprint
fp Map String Fingerprint
incDeps Set ModName
impDeps Maybe ForeignSrc
fsrc =
  FileInfo
    { fiFingerprint :: Fingerprint
fiFingerprint = Fingerprint
fp
    , fiIncludeDeps :: Map String Fingerprint
fiIncludeDeps = Map String Fingerprint
incDeps
    , fiImportDeps :: Set ModName
fiImportDeps  = Set ModName
impDeps
    , fiForeignDeps :: Map String Bool
fiForeignDeps = Map String Bool -> Maybe (Map String Bool) -> Map String Bool
forall a. a -> Maybe a -> a
fromMaybe Map String Bool
forall k a. Map k a
Map.empty
                      do ForeignSrc
src <- Maybe ForeignSrc
fsrc
                         String
fpath <- ForeignSrc -> Maybe String
getForeignSrcPath ForeignSrc
src
                         Map String Bool -> Maybe (Map String Bool)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map String Bool -> Maybe (Map String Bool))
-> Map String Bool -> Maybe (Map String Bool)
forall a b. (a -> b) -> a -> b
$ String -> Bool -> Map String Bool
forall k a. k -> a -> Map k a
Map.singleton String
fpath Bool
True
    }


-- Dynamic Environments --------------------------------------------------------

-- | Extra information we need to carry around to dynamically extend
-- an environment outside the context of a single module. Particularly
-- useful when dealing with interactive declarations as in @let@ or
-- @it@.
data DynamicEnv = DEnv
  { DynamicEnv -> NamingEnv
deNames :: R.NamingEnv
  , DynamicEnv -> [DeclGroup]
deDecls :: [T.DeclGroup]
  , DynamicEnv -> Map Name TySyn
deTySyns :: Map Name T.TySyn
  , DynamicEnv -> EvalEnv
deEnv   :: EvalEnv
  } deriving (forall x. DynamicEnv -> Rep DynamicEnv x)
-> (forall x. Rep DynamicEnv x -> DynamicEnv) -> Generic DynamicEnv
forall x. Rep DynamicEnv x -> DynamicEnv
forall x. DynamicEnv -> Rep DynamicEnv x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. DynamicEnv -> Rep DynamicEnv x
from :: forall x. DynamicEnv -> Rep DynamicEnv x
$cto :: forall x. Rep DynamicEnv x -> DynamicEnv
to :: forall x. Rep DynamicEnv x -> DynamicEnv
Generic

instance Semigroup DynamicEnv where
  DynamicEnv
de1 <> :: DynamicEnv -> DynamicEnv -> DynamicEnv
<> DynamicEnv
de2 = DEnv
    { deNames :: NamingEnv
deNames  = DynamicEnv -> NamingEnv
deNames DynamicEnv
de1  NamingEnv -> NamingEnv -> NamingEnv
forall a. Semigroup a => a -> a -> a
<> DynamicEnv -> NamingEnv
deNames DynamicEnv
de2
    , deDecls :: [DeclGroup]
deDecls  = DynamicEnv -> [DeclGroup]
deDecls DynamicEnv
de1  [DeclGroup] -> [DeclGroup] -> [DeclGroup]
forall a. Semigroup a => a -> a -> a
<> DynamicEnv -> [DeclGroup]
deDecls DynamicEnv
de2
    , deTySyns :: Map Name TySyn
deTySyns = DynamicEnv -> Map Name TySyn
deTySyns DynamicEnv
de1 Map Name TySyn -> Map Name TySyn -> Map Name TySyn
forall a. Semigroup a => a -> a -> a
<> DynamicEnv -> Map Name TySyn
deTySyns DynamicEnv
de2
    , deEnv :: EvalEnv
deEnv    = DynamicEnv -> EvalEnv
deEnv   DynamicEnv
de1  EvalEnv -> EvalEnv -> EvalEnv
forall a. Semigroup a => a -> a -> a
<> DynamicEnv -> EvalEnv
deEnv   DynamicEnv
de2
    }

instance Monoid DynamicEnv where
  mempty :: DynamicEnv
mempty = DEnv
    { deNames :: NamingEnv
deNames  = NamingEnv
forall a. Monoid a => a
mempty
    , deDecls :: [DeclGroup]
deDecls  = [DeclGroup]
forall a. Monoid a => a
mempty
    , deTySyns :: Map Name TySyn
deTySyns = Map Name TySyn
forall a. Monoid a => a
mempty
    , deEnv :: EvalEnv
deEnv    = EvalEnv
forall a. Monoid a => a
mempty
    }
  mappend :: DynamicEnv -> DynamicEnv -> DynamicEnv
mappend = DynamicEnv -> DynamicEnv -> DynamicEnv
forall a. Semigroup a => a -> a -> a
(<>)

-- | Build 'IfaceDecls' that correspond to all of the bindings in the
-- dynamic environment.
--
-- XXX: if we add newtypes, etc. at the REPL, revisit
-- this.
deIfaceDecls :: DynamicEnv -> IfaceDecls
deIfaceDecls :: DynamicEnv -> IfaceDecls
deIfaceDecls DEnv { deDecls :: DynamicEnv -> [DeclGroup]
deDecls = [DeclGroup]
dgs, deTySyns :: DynamicEnv -> Map Name TySyn
deTySyns = Map Name TySyn
tySyns } =
    IfaceDecls { ifTySyns :: Map Name TySyn
ifTySyns = Map Name TySyn
tySyns
               , ifNominalTypes :: Map Name NominalType
ifNominalTypes = Map Name NominalType
forall k a. Map k a
Map.empty
               , ifDecls :: Map Name IfaceDecl
ifDecls = Map Name IfaceDecl
decls
               , ifModules :: Map Name (IfaceNames Name)
ifModules = Map Name (IfaceNames Name)
forall k a. Map k a
Map.empty
               , ifFunctors :: Map Name (IfaceG Name)
ifFunctors = Map Name (IfaceG Name)
forall k a. Map k a
Map.empty
               , ifSignatures :: Map Name ModParamNames
ifSignatures = Map Name ModParamNames
forall k a. Map k a
Map.empty
               }
  where
    decls :: Map Name IfaceDecl
decls = [Map Name IfaceDecl] -> Map Name IfaceDecl
forall a. Monoid a => [a] -> a
mconcat
      [ Name -> IfaceDecl -> Map Name IfaceDecl
forall k a. k -> a -> Map k a
Map.singleton (IfaceDecl -> Name
ifDeclName IfaceDecl
ifd) IfaceDecl
ifd
      | Decl
decl <- (DeclGroup -> [Decl]) -> [DeclGroup] -> [Decl]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DeclGroup -> [Decl]
T.groupDecls [DeclGroup]
dgs
      , let ifd :: IfaceDecl
ifd = Decl -> IfaceDecl
T.mkIfaceDecl Decl
decl
      ]