-- |
-- 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 Cryptol.ModuleSystem.Fingerprint
import Cryptol.ModuleSystem.Interface
import Cryptol.ModuleSystem.Name (Name,Supply,emptySupply)
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 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 ModName
meFocusedModule     :: Maybe ModName
    -- ^ The "current" module.  Used to decide how to print names, for example.

  , ModuleEnv -> [[Char]]
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
  [Char]
curDir <- IO [Char]
getCurrentDirectory
#ifndef RELOCATABLE
  dataDir <- getDataDir
#endif
  [Char]
binDir <- [Char] -> [Char]
takeDirectory ([Char] -> [Char]) -> IO [Char] -> IO [Char]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` IO [Char]
getExecutablePath
  let instDir :: [Char]
instDir = [Char] -> [Char]
normalise ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [Char]
joinPath ([[Char]] -> [Char]) -> ([Char] -> [[Char]]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [[Char]]
forall a. HasCallStack => [a] -> [a]
init ([[Char]] -> [[Char]])
-> ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
splitPath ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
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 [Char]
handle IOException
_e = [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
""
  [Char]
userDir <- IO [Char] -> (IOException -> IO [Char]) -> IO [Char]
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
X.catch ([Char] -> IO [Char]
getAppUserDataDirectory [Char]
"cryptol") IOException -> IO [Char]
handle
  let searchPath :: [[Char]]
searchPath = [ [Char]
curDir
                   -- something like $HOME/.cryptol
                   , [Char]
userDir
#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
                   -- ../cryptol on win32
                   , instDir </> "cryptol"
#else
                   -- ../share/cryptol on others
                   , [Char]
instDir [Char] -> [Char] -> [Char]
</> [Char]
"share" [Char] -> [Char] -> [Char]
</> [Char]
"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 ModName
meFocusedModule     = Maybe ModName
forall a. Maybe a
Nothing
      -- we search these in order, taking the first match
    , meSearchPath :: [[Char]]
meSearchPath        = [[Char]]
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 :: ModName -> ModuleEnv -> Maybe ModuleEnv
focusModule :: ModName -> ModuleEnv -> Maybe ModuleEnv
focusModule ModName
n ModuleEnv
me = do
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ModName -> LoadedModules -> Bool
isLoaded ModName
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)
_ -> [Char] -> [[Char]] -> ModContextParams
forall a. HasCallStack => [Char] -> [[Char]] -> a
panic [Char]
"(<>) @ ModContext" [[Char]
"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
                      }



modContextOf :: ModName -> ModuleEnv -> Maybe ModContext
modContextOf :: ModName -> ModuleEnv -> Maybe ModContext
modContextOf 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 ModName
meFocusedModule ModuleEnv
me of
    Maybe ModName
Nothing -> ModuleEnv -> ModContext
dynModContext ModuleEnv
me
    Just ModName
fm -> case ModName -> ModuleEnv -> Maybe ModContext
modContextOf ModName
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 -> [Char] -> [[Char]] -> ModContext
forall a. HasCallStack => [Char] -> [[Char]] -> a
panic [Char]
"focusedEnv"
                              [ [Char]
"Focused modules not loaded: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Doc -> [Char]
forall a. Show a => a -> [Char]
show (ModName -> Doc
forall a. PP a => a -> Doc
pp ModName
fm) ]


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

-- | The location of a module
data ModulePath = InFile FilePath
                | InMem String ByteString -- ^ Label, content
    deriving (Int -> ModulePath -> [Char] -> [Char]
[ModulePath] -> [Char] -> [Char]
ModulePath -> [Char]
(Int -> ModulePath -> [Char] -> [Char])
-> (ModulePath -> [Char])
-> ([ModulePath] -> [Char] -> [Char])
-> Show ModulePath
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> ModulePath -> [Char] -> [Char]
showsPrec :: Int -> ModulePath -> [Char] -> [Char]
$cshow :: ModulePath -> [Char]
show :: ModulePath -> [Char]
$cshowList :: [ModulePath] -> [Char] -> [Char]
showList :: [ModulePath] -> [Char] -> [Char]
Show, (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 [Char]
x, InFile [Char]
y) -> [Char]
x [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
y
      (InMem [Char]
a ByteString
_, InMem [Char]
b ByteString
_) -> [Char]
a [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
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 [Char]
x, InFile [Char]
y)   -> [Char] -> [Char] -> Ordering
forall a. Ord a => a -> a -> Ordering
compare [Char]
x [Char]
y
      (InMem [Char]
a ByteString
_, InMem [Char]
b ByteString
_) -> [Char] -> [Char] -> Ordering
forall a. Ord a => a -> a -> Ordering
compare [Char]
a [Char]
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 [Char]
p  -> [Char] -> Doc
text [Char]
p
      InMem [Char]
l ByteString
_ -> Doc -> Doc
parens ([Char] -> Doc
text [Char]
l)



-- | The name of the content---either the file path, or the provided label.
modulePathLabel :: ModulePath -> String
modulePathLabel :: ModulePath -> [Char]
modulePathLabel ModulePath
p =
  case ModulePath
p of
    InFile [Char]
path -> [Char]
path
    InMem [Char]
lab ByteString
_ -> [Char]
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 -> [Char] -> [Char]
[LoadedModules] -> [Char] -> [Char]
LoadedModules -> [Char]
(Int -> LoadedModules -> [Char] -> [Char])
-> (LoadedModules -> [Char])
-> ([LoadedModules] -> [Char] -> [Char])
-> Show LoadedModules
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> LoadedModules -> [Char] -> [Char]
showsPrec :: Int -> LoadedModules -> [Char] -> [Char]
$cshow :: LoadedModules -> [Char]
show :: LoadedModules -> [Char]
$cshowList :: [LoadedModules] -> [Char] -> [Char]
showList :: [LoadedModules] -> [Char] -> [Char]
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

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

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 a. LoadedModuleG a -> [Char]
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 -> [Char] -> [Char]
[LoadedModuleG a] -> [Char] -> [Char]
LoadedModuleG a -> [Char]
(Int -> LoadedModuleG a -> [Char] -> [Char])
-> (LoadedModuleG a -> [Char])
-> ([LoadedModuleG a] -> [Char] -> [Char])
-> Show (LoadedModuleG a)
forall a. Show a => Int -> LoadedModuleG a -> [Char] -> [Char]
forall a. Show a => [LoadedModuleG a] -> [Char] -> [Char]
forall a. Show a => LoadedModuleG a -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: forall a. Show a => Int -> LoadedModuleG a -> [Char] -> [Char]
showsPrec :: Int -> LoadedModuleG a -> [Char] -> [Char]
$cshow :: forall a. Show a => LoadedModuleG a -> [Char]
show :: LoadedModuleG a -> [Char]
$cshowList :: forall a. Show a => [LoadedModuleG a] -> [Char] -> [Char]
showList :: [LoadedModuleG a] -> [Char] -> [Char]
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 -> [Char] -> [Char]
[LoadedModuleData] -> [Char] -> [Char]
LoadedModuleData -> [Char]
(Int -> LoadedModuleData -> [Char] -> [Char])
-> (LoadedModuleData -> [Char])
-> ([LoadedModuleData] -> [Char] -> [Char])
-> Show LoadedModuleData
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> LoadedModuleData -> [Char] -> [Char]
showsPrec :: Int -> LoadedModuleData -> [Char] -> [Char]
$cshow :: LoadedModuleData -> [Char]
show :: LoadedModuleData -> [Char]
$cshowList :: [LoadedModuleData] -> [Char] -> [Char]
showList :: [LoadedModuleData] -> [Char] -> [Char]
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 :: ModName -> LoadedModules -> Bool
isLoaded :: ModName -> LoadedModules -> Bool
isLoaded 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

-- | Is this a loaded parameterized module.
isLoadedParamMod :: ModName -> LoadedModules -> Bool
isLoadedParamMod :: ModName -> LoadedModules -> Bool
isLoadedParamMod ModName
mn LoadedModules
ln = (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
ln)

-- | Is this a loaded interface module.
isLoadedInterface :: ModName -> LoadedModules -> Bool
isLoadedInterface :: ModName -> LoadedModules -> Bool
isLoadedInterface 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)



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 ModuleEnv
me = (LoadedModules -> [LoadedModule]) -> Maybe LoadedModule
forall {t :: * -> *} {a}.
Foldable t =>
(LoadedModules -> t (LoadedModuleG a)) -> Maybe (LoadedModuleG a)
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 :: * -> *} {a}.
Foldable t =>
(LoadedModules -> t (LoadedModuleG a)) -> Maybe (LoadedModuleG a)
search LoadedModules -> [LoadedModule]
lmLoadedParamModules
  where
  search :: (LoadedModules -> t (LoadedModuleG a)) -> Maybe (LoadedModuleG a)
search LoadedModules -> t (LoadedModuleG a)
how = (LoadedModuleG a -> Bool)
-> t (LoadedModuleG a) -> Maybe (LoadedModuleG a)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((ModName
mn ModName -> ModName -> Bool
forall a. Eq a => a -> a -> Bool
==) (ModName -> Bool)
-> (LoadedModuleG a -> ModName) -> LoadedModuleG a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoadedModuleG a -> ModName
forall a. LoadedModuleG a -> ModName
lmName) (LoadedModules -> t (LoadedModuleG a)
how (ModuleEnv -> LoadedModules
meLoadedModules ModuleEnv
me))

lookupSignature :: ModName -> ModuleEnv -> Maybe LoadedSignature
lookupSignature :: ModName -> ModuleEnv -> Maybe LoadedSignature
lookupSignature ModName
mn ModuleEnv
me =
  (LoadedSignature -> Bool)
-> [LoadedSignature] -> Maybe LoadedSignature
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((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 (ModuleEnv -> LoadedModules
meLoadedModules ModuleEnv
me))

addLoadedSignature ::
  ModulePath -> String ->
  FileInfo ->
  R.NamingEnv ->
  ModName -> T.ModParamNames ->
  LoadedModules -> LoadedModules
addLoadedSignature :: ModulePath
-> [Char]
-> FileInfo
-> NamingEnv
-> ModName
-> ModParamNames
-> LoadedModules
-> LoadedModules
addLoadedSignature ModulePath
path [Char]
ident FileInfo
fi NamingEnv
nameEnv ModName
nm ModParamNames
si LoadedModules
lm
  | ModName -> LoadedModules -> Bool
isLoaded ModName
nm 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 :: [Char]
lmModuleId    = [Char]
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
-> [Char]
-> FileInfo
-> NamingEnv
-> Maybe ForeignSrc
-> Module
-> LoadedModules
-> LoadedModules
addLoadedModule ModulePath
path [Char]
ident FileInfo
fi NamingEnv
nameEnv Maybe ForeignSrc
fsrc Module
tm LoadedModules
lm
  | ModName -> LoadedModules -> Bool
isLoaded (Module -> ModName
forall mname. ModuleG mname -> mname
T.mName Module
tm) LoadedModules
lm  = LoadedModules
lm
  | Module -> Bool
forall mname. ModuleG mname -> 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 :: [Char]
lmModuleId        = [Char]
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 -> Set [Char]
fiIncludeDeps :: Set FilePath
  , FileInfo -> Set ModName
fiImportDeps  :: Set ModName
  , FileInfo -> Map [Char] Bool
fiForeignDeps :: Map FilePath Bool
  } deriving (Int -> FileInfo -> [Char] -> [Char]
[FileInfo] -> [Char] -> [Char]
FileInfo -> [Char]
(Int -> FileInfo -> [Char] -> [Char])
-> (FileInfo -> [Char])
-> ([FileInfo] -> [Char] -> [Char])
-> Show FileInfo
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> FileInfo -> [Char] -> [Char]
showsPrec :: Int -> FileInfo -> [Char] -> [Char]
$cshow :: FileInfo -> [Char]
show :: FileInfo -> [Char]
$cshowList :: [FileInfo] -> [Char] -> [Char]
showList :: [FileInfo] -> [Char] -> [Char]
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 ->
  Set FilePath ->
  Set ModName ->
  Maybe ForeignSrc ->
  FileInfo
fileInfo :: Fingerprint
-> Set [Char] -> Set ModName -> Maybe ForeignSrc -> FileInfo
fileInfo Fingerprint
fp Set [Char]
incDeps Set ModName
impDeps Maybe ForeignSrc
fsrc =
  FileInfo
    { fiFingerprint :: Fingerprint
fiFingerprint = Fingerprint
fp
    , fiIncludeDeps :: Set [Char]
fiIncludeDeps = Set [Char]
incDeps
    , fiImportDeps :: Set ModName
fiImportDeps  = Set ModName
impDeps
    , fiForeignDeps :: Map [Char] Bool
fiForeignDeps = Map [Char] Bool -> Maybe (Map [Char] Bool) -> Map [Char] Bool
forall a. a -> Maybe a -> a
fromMaybe Map [Char] Bool
forall k a. Map k a
Map.empty
                      do ForeignSrc
src <- Maybe ForeignSrc
fsrc
                         [Char]
fpath <- ForeignSrc -> Maybe [Char]
getForeignSrcPath ForeignSrc
src
                         Map [Char] Bool -> Maybe (Map [Char] Bool)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map [Char] Bool -> Maybe (Map [Char] Bool))
-> Map [Char] Bool -> Maybe (Map [Char] Bool)
forall a b. (a -> b) -> a -> b
$ [Char] -> Bool -> Map [Char] Bool
forall k a. k -> a -> Map k a
Map.singleton [Char]
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
      ]