{-# 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)
data ModuleEnv = ModuleEnv
{ ModuleEnv -> LoadedModules
meLoadedModules :: LoadedModules
, ModuleEnv -> NameSeeds
meNameSeeds :: T.NameSeeds
, ModuleEnv -> EvalEnv
meEvalEnv :: EvalEnv
, ModuleEnv -> CoreLint
meCoreLint :: CoreLint
, ModuleEnv -> Bool
meMonoBinds :: !Bool
, ModuleEnv -> Maybe ModName
meFocusedModule :: Maybe ModName
, ModuleEnv -> [[Char]]
meSearchPath :: [FilePath]
, ModuleEnv -> DynamicEnv
meDynEnv :: DynamicEnv
, ModuleEnv -> Supply
meSupply :: !Supply
, ModuleEnv -> EvalForeignPolicy
meEvalForeignPolicy :: EvalForeignPolicy
} 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` ()
data CoreLint = NoCoreLint
| CoreLint
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)
data EvalForeignPolicy
= AlwaysEvalForeign
| PreferEvalForeign
| 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
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
, [Char]
userDir
#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
, instDir </> "cryptol"
#else
, [Char]
instDir [Char] -> [Char] -> [Char]
</> [Char]
"share" [Char] -> [Char] -> [Char]
</> [Char]
"cryptol"
#endif
#ifndef RELOCATABLE
, 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
, 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
}
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 }
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
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))
]
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
data ModContext = ModContext
{ ModContext -> ModContextParams
mctxParams :: ModContextParams
, ModContext -> Set Name
mctxExported :: Set Name
, ModContext -> IfaceDecls
mctxDecls :: IfaceDecls
, ModContext -> NamingEnv
mctxNames :: R.NamingEnv
, ModContext -> NameDisp
mctxNameDisp :: NameDisp
}
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
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
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)
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) ]
data ModulePath = InFile FilePath
| InMem String ByteString
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)
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
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)
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]
, LoadedModules -> [LoadedModule]
lmLoadedParamModules :: [LoadedModule]
, 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
(<>)
data LoadedModuleG a = LoadedModule
{ forall a. LoadedModuleG a -> ModName
lmName :: ModName
, forall a. LoadedModuleG a -> ModulePath
lmFilePath :: ModulePath
, forall a. LoadedModuleG a -> [Char]
lmModuleId :: String
, forall a. LoadedModuleG a -> NamingEnv
lmNamingEnv :: !R.NamingEnv
, 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
, LoadedModuleData -> Module
lmdModule :: T.Module
, LoadedModuleData -> Maybe ForeignSrc
lmForeignSrc :: Maybe ForeignSrc
} 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
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
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)
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) }
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
}
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
}
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)
}
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
}
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
(<>)
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
]