{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
module Cryptol.ModuleSystem.Env where
#ifndef RELOCATABLE
import Paths_cryptol (getDataDir)
#endif
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 Data.Map (Map)
import qualified Data.Map as Map
import Data.Semigroup
import System.Directory (getAppUserDataDirectory, getCurrentDirectory)
import System.Environment(getExecutablePath)
import System.FilePath ((</>), normalise, joinPath, splitPath, takeDirectory)
import qualified Data.List as List
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 -> [FilePath]
meSearchPath :: [FilePath]
, ModuleEnv -> DynamicEnv
meDynEnv :: DynamicEnv
, ModuleEnv -> Supply
meSupply :: !Supply
} 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
$cto :: forall x. Rep ModuleEnv x -> ModuleEnv
$cfrom :: forall x. ModuleEnv -> Rep ModuleEnv x
Generic
instance NFData ModuleEnv where
rnf :: ModuleEnv -> ()
rnf ModuleEnv
x = ModuleEnv -> LoadedModules
meLoadedModules ModuleEnv
x LoadedModules -> () -> ()
`seq` ModuleEnv -> EvalEnv
meEvalEnv ModuleEnv
x EvalEnv -> () -> ()
`seq` ModuleEnv -> DynamicEnv
meDynEnv ModuleEnv
x DynamicEnv -> () -> ()
`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
$cto :: forall x. Rep CoreLint x -> CoreLint
$cfrom :: forall x. CoreLint -> Rep CoreLint x
Generic, CoreLint -> ()
(CoreLint -> ()) -> NFData CoreLint
forall a. (a -> ()) -> NFData a
rnf :: CoreLint -> ()
$crnf :: CoreLint -> ()
NFData)
resetModuleEnv :: ModuleEnv -> ModuleEnv
resetModuleEnv :: ModuleEnv -> ModuleEnv
resetModuleEnv ModuleEnv
env = ModuleEnv
env
{ 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
, meDynEnv :: DynamicEnv
meDynEnv = DynamicEnv
forall a. Monoid a => a
mempty
}
initialModuleEnv :: IO ModuleEnv
initialModuleEnv :: IO ModuleEnv
initialModuleEnv = do
FilePath
curDir <- IO FilePath
getCurrentDirectory
#ifndef RELOCATABLE
dataDir <- getDataDir
#endif
FilePath
binDir <- FilePath -> FilePath
takeDirectory (FilePath -> FilePath) -> IO FilePath -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` IO FilePath
getExecutablePath
let instDir :: FilePath
instDir = FilePath -> FilePath
normalise (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> FilePath
joinPath ([FilePath] -> FilePath)
-> (FilePath -> [FilePath]) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> [FilePath]
forall a. [a] -> [a]
init ([FilePath] -> [FilePath])
-> (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
splitPath (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
binDir
let handle :: X.IOException -> IO String
handle :: IOException -> IO FilePath
handle IOException
_e = FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
""
FilePath
userDir <- IO FilePath -> (IOException -> IO FilePath) -> IO FilePath
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
X.catch (FilePath -> IO FilePath
getAppUserDataDirectory FilePath
"cryptol") IOException -> IO FilePath
handle
let searchPath :: [FilePath]
searchPath = [ FilePath
curDir
, FilePath
userDir
#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
, instDir </> "cryptol"
#else
, FilePath
instDir FilePath -> FilePath -> FilePath
</> FilePath
"share" FilePath -> FilePath -> FilePath
</> FilePath
"cryptol"
#endif
#ifndef RELOCATABLE
, dataDir
#endif
]
ModuleEnv -> IO ModuleEnv
forall (m :: * -> *) a. Monad m => a -> m a
return ModuleEnv :: LoadedModules
-> NameSeeds
-> EvalEnv
-> CoreLint
-> Bool
-> Maybe ModName
-> [FilePath]
-> DynamicEnv
-> Supply
-> ModuleEnv
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 :: [FilePath]
meSearchPath = [FilePath]
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
}
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 (m :: * -> *) a. Monad m => a -> m a
return ModuleEnv
me { meFocusedModule :: Maybe ModName
meFocusedModule = ModName -> Maybe ModName
forall a. a -> Maybe a
Just ModName
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
loadedNewtypes :: ModuleEnv -> Map Name IfaceNewtype
loadedNewtypes :: ModuleEnv -> Map Name IfaceNewtype
loadedNewtypes ModuleEnv
menv = [Map Name IfaceNewtype] -> Map Name IfaceNewtype
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions
[ IfaceDecls -> Map Name IfaceNewtype
ifNewtypes (IfaceG ModName -> IfaceDecls
forall mname. IfaceG mname -> IfaceDecls
ifPublic IfaceG ModName
i) Map Name IfaceNewtype
-> Map Name IfaceNewtype -> Map Name IfaceNewtype
forall a. Semigroup a => a -> a -> a
<> IfaceDecls -> Map Name IfaceNewtype
ifNewtypes (IfaceG ModName -> IfaceDecls
forall mname. IfaceG mname -> IfaceDecls
ifPrivate 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 (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 ModContext = ModContext
{ ModContext -> IfaceParams
mctxParams :: IfaceParams
, 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 :: IfaceParams
-> Set Name -> IfaceDecls -> NamingEnv -> NameDisp -> ModContext
ModContext { mctxParams :: IfaceParams
mctxParams = IfaceParams -> IfaceParams -> IfaceParams
jnParams (ModContext -> IfaceParams
mctxParams ModContext
x) (ModContext -> IfaceParams
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
jnParams :: IfaceParams -> IfaceParams -> IfaceParams
jnParams IfaceParams
a IfaceParams
b
| IfaceParams -> Bool
isEmptyIfaceParams IfaceParams
a = IfaceParams
b
| IfaceParams -> Bool
isEmptyIfaceParams IfaceParams
b = IfaceParams
a
| Bool
otherwise =
FilePath -> [FilePath] -> IfaceParams
forall a. HasCallStack => FilePath -> [FilePath] -> a
panic FilePath
"ModContext" [ FilePath
"Cannot combined 2 parameterized contexts" ]
instance Monoid ModContext where
mempty :: ModContext
mempty = ModContext :: IfaceParams
-> Set Name -> IfaceDecls -> NamingEnv -> NameDisp -> ModContext
ModContext { mctxParams :: IfaceParams
mctxParams = IfaceParams
noIfaceParams
, 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
lmNamingEnv LoadedModule
lm
loadedDecls :: [IfaceDecls]
loadedDecls = (LoadedModule -> IfaceDecls) -> [LoadedModule] -> [IfaceDecls]
forall a b. (a -> b) -> [a] -> [b]
map (IfaceG ModName -> IfaceDecls
forall mname. IfaceG mname -> IfaceDecls
ifPublic (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 (f :: * -> *) a. Applicative f => a -> f a
pure ModContext :: IfaceParams
-> Set Name -> IfaceDecls -> NamingEnv -> NameDisp -> ModContext
ModContext
{ mctxParams :: IfaceParams
mctxParams = IfaceG ModName -> IfaceParams
forall mname. IfaceG mname -> IfaceParams
ifParams IfaceG ModName
localIface
, mctxExported :: Set Name
mctxExported = IfaceDecls -> Set Name
ifaceDeclsNames (IfaceG ModName -> IfaceDecls
forall mname. IfaceG mname -> IfaceDecls
ifPublic IfaceG ModName
localIface)
, mctxDecls :: IfaceDecls
mctxDecls = [IfaceDecls] -> IfaceDecls
forall a. Monoid a => [a] -> a
mconcat (IfaceG ModName -> IfaceDecls
forall mname. IfaceG mname -> IfaceDecls
ifPrivate 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
}
dynModContext :: ModuleEnv -> ModContext
dynModContext :: ModuleEnv -> ModContext
dynModContext ModuleEnv
me = ModContext
forall a. Monoid a => a
mempty { mctxNames :: NamingEnv
mctxNames = NamingEnv
dynNames
, mctxNameDisp :: NameDisp
mctxNameDisp = NamingEnv -> NameDisp
R.toNameDisp NamingEnv
dynNames
, mctxDecls :: IfaceDecls
mctxDecls = DynamicEnv -> IfaceDecls
deIfaceDecls (ModuleEnv -> DynamicEnv
meDynEnv ModuleEnv
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 -> FilePath -> [FilePath] -> ModContext
forall a. HasCallStack => FilePath -> [FilePath] -> a
panic FilePath
"focusedEnv"
[ FilePath
"Focused modules not loaded: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Doc -> FilePath
forall a. Show a => a -> FilePath
show (ModName -> Doc
forall a. PP a => a -> Doc
pp ModName
fm) ]
data ModulePath = InFile FilePath
| InMem String ByteString
deriving (Int -> ModulePath -> FilePath -> FilePath
[ModulePath] -> FilePath -> FilePath
ModulePath -> FilePath
(Int -> ModulePath -> FilePath -> FilePath)
-> (ModulePath -> FilePath)
-> ([ModulePath] -> FilePath -> FilePath)
-> Show ModulePath
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [ModulePath] -> FilePath -> FilePath
$cshowList :: [ModulePath] -> FilePath -> FilePath
show :: ModulePath -> FilePath
$cshow :: ModulePath -> FilePath
showsPrec :: Int -> ModulePath -> FilePath -> FilePath
$cshowsPrec :: Int -> ModulePath -> FilePath -> FilePath
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
$cto :: forall x. Rep ModulePath x -> ModulePath
$cfrom :: forall x. ModulePath -> Rep ModulePath x
Generic, ModulePath -> ()
(ModulePath -> ()) -> NFData ModulePath
forall a. (a -> ()) -> NFData a
rnf :: ModulePath -> ()
$crnf :: ModulePath -> ()
NFData)
instance Eq ModulePath where
ModulePath
p1 == :: ModulePath -> ModulePath -> Bool
== ModulePath
p2 =
case (ModulePath
p1,ModulePath
p2) of
(InFile FilePath
x, InFile FilePath
y) -> FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
y
(InMem FilePath
a ByteString
_, InMem FilePath
b ByteString
_) -> FilePath
a FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
b
(ModulePath, ModulePath)
_ -> Bool
False
instance PP ModulePath where
ppPrec :: Int -> ModulePath -> Doc
ppPrec Int
_ ModulePath
e =
case ModulePath
e of
InFile FilePath
p -> FilePath -> Doc
text FilePath
p
InMem FilePath
l ByteString
_ -> Doc -> Doc
parens (FilePath -> Doc
text FilePath
l)
modulePathLabel :: ModulePath -> String
modulePathLabel :: ModulePath -> FilePath
modulePathLabel ModulePath
p =
case ModulePath
p of
InFile FilePath
path -> FilePath
path
InMem FilePath
lab ByteString
_ -> FilePath
lab
data LoadedModules = LoadedModules
{ LoadedModules -> [LoadedModule]
lmLoadedModules :: [LoadedModule]
, LoadedModules -> [LoadedModule]
lmLoadedParamModules :: [LoadedModule]
} deriving (Int -> LoadedModules -> FilePath -> FilePath
[LoadedModules] -> FilePath -> FilePath
LoadedModules -> FilePath
(Int -> LoadedModules -> FilePath -> FilePath)
-> (LoadedModules -> FilePath)
-> ([LoadedModules] -> FilePath -> FilePath)
-> Show LoadedModules
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [LoadedModules] -> FilePath -> FilePath
$cshowList :: [LoadedModules] -> FilePath -> FilePath
show :: LoadedModules -> FilePath
$cshow :: LoadedModules -> FilePath
showsPrec :: Int -> LoadedModules -> FilePath -> FilePath
$cshowsPrec :: Int -> LoadedModules -> FilePath -> FilePath
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
$cto :: forall x. Rep LoadedModules x -> LoadedModules
$cfrom :: forall x. LoadedModules -> Rep LoadedModules x
Generic, LoadedModules -> ()
(LoadedModules -> ()) -> NFData LoadedModules
forall a. (a -> ()) -> NFData a
rnf :: LoadedModules -> ()
$crnf :: LoadedModules -> ()
NFData)
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
instance Semigroup LoadedModules where
LoadedModules
l <> :: LoadedModules -> LoadedModules -> LoadedModules
<> LoadedModules
r = LoadedModules :: [LoadedModule] -> [LoadedModule] -> LoadedModules
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
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 }
instance Monoid LoadedModules where
mempty :: LoadedModules
mempty = LoadedModules :: [LoadedModule] -> [LoadedModule] -> LoadedModules
LoadedModules { lmLoadedModules :: [LoadedModule]
lmLoadedModules = []
, lmLoadedParamModules :: [LoadedModule]
lmLoadedParamModules = []
}
mappend :: LoadedModules -> LoadedModules -> LoadedModules
mappend = LoadedModules -> LoadedModules -> LoadedModules
forall a. Semigroup a => a -> a -> a
(<>)
data LoadedModule = LoadedModule
{ LoadedModule -> ModName
lmName :: ModName
, LoadedModule -> ModulePath
lmFilePath :: ModulePath
, LoadedModule -> FilePath
lmModuleId :: String
, LoadedModule -> NamingEnv
lmNamingEnv :: !R.NamingEnv
, LoadedModule -> IfaceG ModName
lmInterface :: Iface
, LoadedModule -> Module
lmModule :: T.Module
, LoadedModule -> Fingerprint
lmFingerprint :: Fingerprint
} deriving (Int -> LoadedModule -> FilePath -> FilePath
[LoadedModule] -> FilePath -> FilePath
LoadedModule -> FilePath
(Int -> LoadedModule -> FilePath -> FilePath)
-> (LoadedModule -> FilePath)
-> ([LoadedModule] -> FilePath -> FilePath)
-> Show LoadedModule
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [LoadedModule] -> FilePath -> FilePath
$cshowList :: [LoadedModule] -> FilePath -> FilePath
show :: LoadedModule -> FilePath
$cshow :: LoadedModule -> FilePath
showsPrec :: Int -> LoadedModule -> FilePath -> FilePath
$cshowsPrec :: Int -> LoadedModule -> FilePath -> FilePath
Show, (forall x. LoadedModule -> Rep LoadedModule x)
-> (forall x. Rep LoadedModule x -> LoadedModule)
-> Generic LoadedModule
forall x. Rep LoadedModule x -> LoadedModule
forall x. LoadedModule -> Rep LoadedModule x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep LoadedModule x -> LoadedModule
$cfrom :: forall x. LoadedModule -> Rep LoadedModule x
Generic, LoadedModule -> ()
(LoadedModule -> ()) -> NFData LoadedModule
forall a. (a -> ()) -> NFData a
rnf :: LoadedModule -> ()
$crnf :: LoadedModule -> ()
NFData)
isLoaded :: ModName -> LoadedModules -> Bool
isLoaded :: ModName -> LoadedModules -> Bool
isLoaded ModName
mn LoadedModules
lm = (LoadedModule -> Bool) -> [LoadedModule] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((ModName
mn ModName -> ModName -> Bool
forall a. Eq a => a -> a -> Bool
==) (ModName -> Bool)
-> (LoadedModule -> ModName) -> LoadedModule -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoadedModule -> ModName
lmName) (LoadedModules -> [LoadedModule]
getLoadedModules 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
lmName) (LoadedModules -> [LoadedModule]
lmLoadedParamModules LoadedModules
ln)
lookupModule :: ModName -> ModuleEnv -> Maybe LoadedModule
lookupModule :: ModName -> ModuleEnv -> Maybe LoadedModule
lookupModule ModName
mn ModuleEnv
me = (LoadedModules -> [LoadedModule]) -> Maybe LoadedModule
forall (t :: * -> *).
Foldable t =>
(LoadedModules -> t LoadedModule) -> Maybe LoadedModule
search LoadedModules -> [LoadedModule]
lmLoadedModules Maybe LoadedModule -> Maybe LoadedModule -> Maybe LoadedModule
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (LoadedModules -> [LoadedModule]) -> Maybe LoadedModule
forall (t :: * -> *).
Foldable t =>
(LoadedModules -> t LoadedModule) -> Maybe LoadedModule
search LoadedModules -> [LoadedModule]
lmLoadedParamModules
where
search :: (LoadedModules -> t LoadedModule) -> Maybe LoadedModule
search LoadedModules -> t LoadedModule
how = (LoadedModule -> Bool) -> t LoadedModule -> Maybe LoadedModule
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((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
lmName) (LoadedModules -> t LoadedModule
how (ModuleEnv -> LoadedModules
meLoadedModules ModuleEnv
me))
addLoadedModule ::
ModulePath -> String -> Fingerprint -> R.NamingEnv -> T.Module ->
LoadedModules -> LoadedModules
addLoadedModule :: ModulePath
-> FilePath
-> Fingerprint
-> NamingEnv
-> Module
-> LoadedModules
-> LoadedModules
addLoadedModule ModulePath
path FilePath
ident Fingerprint
fp NamingEnv
nameEnv 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 :: [LoadedModule]
lmLoadedParamModules = LoadedModule
loaded LoadedModule -> [LoadedModule] -> [LoadedModule]
forall a. a -> [a] -> [a]
:
LoadedModules -> [LoadedModule]
lmLoadedParamModules LoadedModules
lm }
| Bool
otherwise = LoadedModules
lm { lmLoadedModules :: [LoadedModule]
lmLoadedModules =
LoadedModules -> [LoadedModule]
lmLoadedModules LoadedModules
lm [LoadedModule] -> [LoadedModule] -> [LoadedModule]
forall a. [a] -> [a] -> [a]
++ [LoadedModule
loaded] }
where
loaded :: LoadedModule
loaded = LoadedModule :: ModName
-> ModulePath
-> FilePath
-> NamingEnv
-> IfaceG ModName
-> Module
-> Fingerprint
-> LoadedModule
LoadedModule
{ lmName :: ModName
lmName = Module -> ModName
forall mname. ModuleG mname -> mname
T.mName Module
tm
, lmFilePath :: ModulePath
lmFilePath = ModulePath
path
, lmModuleId :: FilePath
lmModuleId = FilePath
ident
, lmNamingEnv :: NamingEnv
lmNamingEnv = NamingEnv
nameEnv
, lmInterface :: IfaceG ModName
lmInterface = Module -> IfaceG ModName
forall mname. ModuleG mname -> IfaceG mname
T.genIface Module
tm
, lmModule :: Module
lmModule = Module
tm
, lmFingerprint :: Fingerprint
lmFingerprint = Fingerprint
fp
}
removeLoadedModule :: (LoadedModule -> Bool) -> LoadedModules -> LoadedModules
removeLoadedModule :: (LoadedModule -> Bool) -> LoadedModules -> LoadedModules
removeLoadedModule LoadedModule -> Bool
rm LoadedModules
lm =
LoadedModules :: [LoadedModule] -> [LoadedModule] -> LoadedModules
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
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
rm) (LoadedModules -> [LoadedModule]
lmLoadedParamModules LoadedModules
lm)
}
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
$cto :: forall x. Rep DynamicEnv x -> DynamicEnv
$cfrom :: forall x. DynamicEnv -> Rep DynamicEnv x
Generic
instance Semigroup DynamicEnv where
DynamicEnv
de1 <> :: DynamicEnv -> DynamicEnv -> DynamicEnv
<> DynamicEnv
de2 = DEnv :: NamingEnv -> [DeclGroup] -> Map Name TySyn -> EvalEnv -> DynamicEnv
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 :: NamingEnv -> [DeclGroup] -> Map Name TySyn -> EvalEnv -> DynamicEnv
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 :: Map Name TySyn
-> Map Name IfaceNewtype
-> Map Name IfaceAbstractType
-> Map Name IfaceDecl
-> Map Name (IfaceG Name)
-> IfaceDecls
IfaceDecls { ifTySyns :: Map Name TySyn
ifTySyns = Map Name TySyn
tySyns
, ifNewtypes :: Map Name IfaceNewtype
ifNewtypes = Map Name IfaceNewtype
forall k a. Map k a
Map.empty
, ifAbstractTypes :: Map Name IfaceAbstractType
ifAbstractTypes = Map Name IfaceAbstractType
forall k a. Map k a
Map.empty
, ifDecls :: Map Name IfaceDecl
ifDecls = Map Name IfaceDecl
decls
, ifModules :: Map Name (IfaceG Name)
ifModules = Map Name (IfaceG Name)
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
]