{-# Language BlockArguments #-}
{-# Language TypeSynonymInstances, FlexibleInstances #-}
module Cryptol.ModuleSystem.Renamer.Imports
( resolveImports
, ResolvedModule(..)
, ModKind(..)
, ResolvedLocal
, ResolvedExt
)
where
import Data.Maybe(fromMaybe)
import Data.Set(Set)
import qualified Data.Set as Set
import Data.Map (Map)
import qualified Data.Map as Map
import Data.List(foldl')
import Control.Monad(when)
import qualified MonadLib as M
import Cryptol.Utils.PP(pp)
import Cryptol.Utils.Panic(panic)
import Cryptol.Utils.Ident(ModName,ModPath(..),Namespace(..),OrigName(..))
import Cryptol.Parser.AST
( ImportG(..),PName, ModuleInstanceArgs(..), ImpName(..) )
import Cryptol.ModuleSystem.Binds (Mod(..), TopDef(..), modNested, ModKind(..))
import Cryptol.ModuleSystem.Name
( Name, Supply, SupplyT, runSupplyT, liftSupply, freshNameFor
, asOrigName, nameIdent, nameTopModule )
import Cryptol.ModuleSystem.Names(Names(..))
import Cryptol.ModuleSystem.NamingEnv
( NamingEnv(..), lookupNS, shadowing, travNamingEnv
, interpImportEnv, zipByTextName, filterUNames )
data ResolvedModule imps = ResolvedModule
{ forall imps. ResolvedModule imps -> NamingEnv
rmodDefines :: NamingEnv
, forall imps. ResolvedModule imps -> Set Name
rmodPublic :: !(Set Name)
, forall imps. ResolvedModule imps -> ModKind
rmodKind :: ModKind
, forall imps. ResolvedModule imps -> Set Name
rmodNested :: Set Name
, forall imps. ResolvedModule imps -> imps
rmodImports :: imps
}
type ResolvedLocal = ResolvedModule NamingEnv
type ResolvedExt = ResolvedModule ()
resolveImports ::
(ImpName Name -> Mod ()) ->
TopDef ->
Supply ->
(Map (ImpName Name) ResolvedLocal, Supply)
resolveImports :: (ImpName Name -> Mod ())
-> TopDef -> Supply -> (Map (ImpName Name) ResolvedLocal, Supply)
resolveImports ImpName Name -> Mod ()
ext TopDef
def Supply
su =
case TopDef
def of
TopMod ModName
m Mod ()
mo ->
do let cur :: Todo
cur = Mod () -> Todo
todoModule Mod ()
mo
newS :: CurState
newS = CurState -> CurState
doModuleStep CurState
{ curMod :: Todo
curMod = Todo
cur
, curTop :: ModName
curTop = ModName
m
, externalModules :: ImpName Name -> Mod ()
externalModules = ImpName Name -> Mod ()
ext
, doneModules :: Map Name ResolvedLocal
doneModules = forall a. Monoid a => a
mempty
, nameSupply :: Supply
nameSupply = Supply
su
, changes :: Bool
changes = Bool
False
}
case Todo -> CurState -> Maybe ResolvedLocal
tryFinishCurMod Todo
cur CurState
newS of
Just ResolvedLocal
r -> forall {a}.
ModName
-> ResolvedLocal
-> CurState' a
-> (Map (ImpName Name) ResolvedLocal, Supply)
add ModName
m ResolvedLocal
r CurState
newS
Maybe ResolvedLocal
Nothing -> forall {a}.
ModName
-> ResolvedLocal
-> CurState' a
-> (Map (ImpName Name) ResolvedLocal, Supply)
add ModName
m ResolvedLocal
r CurState
s1
where (ResolvedLocal
r,CurState
s1) = CurState -> (ResolvedLocal, CurState)
forceFinish CurState
newS
TopInst ModName
m ImpName PName
f ModuleInstanceArgs PName
as ->
do let s :: CurState' ()
s = CurState
{ curMod :: ()
curMod = ()
, curTop :: ModName
curTop = ModName
m
, externalModules :: ImpName Name -> Mod ()
externalModules = ImpName Name -> Mod ()
ext
, doneModules :: Map Name ResolvedLocal
doneModules = forall a. Monoid a => a
mempty
, nameSupply :: Supply
nameSupply = Supply
su
, changes :: Bool
changes = Bool
False
}
case forall a.
HasCurScope a =>
CurState' a
-> ImpName Name
-> (ImpName PName, ModuleInstanceArgs PName)
-> Maybe (ResolvedLocal, CurState' a)
tryInstanceMaybe CurState' ()
s (forall name. ModName -> ImpName name
ImpTop ModName
m) (ImpName PName
f,ModuleInstanceArgs PName
as) of
Just (ResolvedLocal
r,CurState' ()
newS) -> forall {a}.
ModName
-> ResolvedLocal
-> CurState' a
-> (Map (ImpName Name) ResolvedLocal, Supply)
add ModName
m ResolvedLocal
r CurState' ()
newS
Maybe (ResolvedLocal, CurState' ())
Nothing -> (forall k a. k -> a -> Map k a
Map.singleton (forall name. ModName -> ImpName name
ImpTop ModName
m) ResolvedLocal
forceResolveInst, Supply
su)
where
toNest :: Map name a -> Map (ImpName name) a
toNest Map name a
m = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (forall name. name -> ImpName name
ImpNested name
k, a
v) | (name
k,a
v) <- forall k a. Map k a -> [(k, a)]
Map.toList Map name a
m ]
add :: ModName
-> ResolvedLocal
-> CurState' a
-> (Map (ImpName Name) ResolvedLocal, Supply)
add ModName
m ResolvedLocal
r CurState' a
s = ( forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (forall name. ModName -> ImpName name
ImpTop ModName
m) ResolvedLocal
r (forall {name} {a}. Ord name => Map name a -> Map (ImpName name) a
toNest (forall a. CurState' a -> Map Name ResolvedLocal
doneModules CurState' a
s))
, forall a. CurState' a -> Supply
nameSupply CurState' a
s
)
type Todo = Mod ModState
data ModState = ModState
{ ModState -> NamingEnv
modOuter :: NamingEnv
, ModState -> NamingEnv
modImported :: NamingEnv
}
todoModule :: Mod () -> Todo
todoModule :: Mod () -> Todo
todoModule = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const ModState
emptyModState)
where
emptyModState :: ModState
emptyModState =
ModState
{ modOuter :: NamingEnv
modOuter = forall a. Monoid a => a
mempty
, modImported :: NamingEnv
modImported = forall a. Monoid a => a
mempty
}
isDone :: Todo -> Bool
isDone :: Todo -> Bool
isDone Todo
m = forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall a. Mod a -> [ImportG (ImpName PName)]
modImports Todo
m) Bool -> Bool -> Bool
&&
forall k a. Map k a -> Bool
Map.null (forall a.
Mod a -> Map Name (ImpName PName, ModuleInstanceArgs PName)
modInstances Todo
m) Bool -> Bool -> Bool
&&
forall k a. Map k a -> Bool
Map.null (forall a. Mod a -> Map Name (Mod a)
modMods Todo
m)
forceFinish :: CurState -> (ResolvedLocal,CurState)
forceFinish :: CurState -> (ResolvedLocal, CurState)
forceFinish CurState
s0 =
let this :: Todo
this = forall a. CurState' a -> a
curMod CurState
s0
add :: Name -> ResolvedLocal -> CurState' a -> CurState' a
add Name
k ResolvedLocal
v CurState' a
s = CurState' a
s { doneModules :: Map Name ResolvedLocal
doneModules = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
k ResolvedLocal
v (forall a. CurState' a -> Map Name ResolvedLocal
doneModules CurState' a
s) }
s1 :: CurState
s1 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\CurState
s Name
k -> forall {a}. Name -> ResolvedLocal -> CurState' a -> CurState' a
add Name
k ResolvedLocal
forceResolveInst CurState
s) CurState
s0
(forall k a. Map k a -> [k]
Map.keys (forall a.
Mod a -> Map Name (ImpName PName, ModuleInstanceArgs PName)
modInstances Todo
this))
doNestMod :: CurState' a -> (Name, Todo) -> CurState
doNestMod CurState' a
s (Name
k,Todo
m) =
let (ResolvedLocal
r,CurState
s') = CurState -> (ResolvedLocal, CurState)
forceFinish CurState' a
s { curMod :: Todo
curMod = Todo
m }
in forall {a}. Name -> ResolvedLocal -> CurState' a -> CurState' a
add Name
k ResolvedLocal
r CurState
s'
in ( Todo -> ResolvedLocal
forceResolveMod Todo
this
, forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {a}. CurState' a -> (Name, Todo) -> CurState
doNestMod CurState
s1 (forall k a. Map k a -> [(k, a)]
Map.toList (forall a. Mod a -> Map Name (Mod a)
modMods Todo
this))
)
forceResolveInst :: ResolvedLocal
forceResolveInst :: ResolvedLocal
forceResolveInst =
ResolvedModule
{ rmodDefines :: NamingEnv
rmodDefines = forall a. Monoid a => a
mempty
, rmodPublic :: Set Name
rmodPublic = forall a. Monoid a => a
mempty
, rmodKind :: ModKind
rmodKind = ModKind
AModule
, rmodNested :: Set Name
rmodNested = forall a. Set a
Set.empty
, rmodImports :: NamingEnv
rmodImports = forall a. Monoid a => a
mempty
}
forceResolveMod :: Todo -> ResolvedLocal
forceResolveMod :: Todo -> ResolvedLocal
forceResolveMod Todo
todo =
ResolvedModule
{ rmodDefines :: NamingEnv
rmodDefines = forall a. Mod a -> NamingEnv
modDefines Todo
todo
, rmodPublic :: Set Name
rmodPublic = forall a. Mod a -> Set Name
modPublic Todo
todo
, rmodKind :: ModKind
rmodKind = forall a. Mod a -> ModKind
modKind Todo
todo
, rmodNested :: Set Name
rmodNested = forall k a. Map k a -> Set k
Map.keysSet (forall a. Mod a -> Map Name (Mod a)
modMods Todo
todo)
, rmodImports :: NamingEnv
rmodImports = ModState -> NamingEnv
modImported (forall a. Mod a -> a
modState Todo
todo)
}
pushImport :: ImportG (ImpName PName) -> Todo -> Todo
pushImport :: ImportG (ImpName PName) -> Todo -> Todo
pushImport ImportG (ImpName PName)
i Todo
m = Todo
m { modImports :: [ImportG (ImpName PName)]
modImports = ImportG (ImpName PName)
i forall a. a -> [a] -> [a]
: forall a. Mod a -> [ImportG (ImpName PName)]
modImports Todo
m }
pushInst :: Name -> (ImpName PName, ModuleInstanceArgs PName) -> Todo -> Todo
pushInst :: Name -> (ImpName PName, ModuleInstanceArgs PName) -> Todo -> Todo
pushInst Name
k (ImpName PName, ModuleInstanceArgs PName)
v Todo
m = Todo
m { modInstances :: Map Name (ImpName PName, ModuleInstanceArgs PName)
modInstances = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
k (ImpName PName, ModuleInstanceArgs PName)
v (forall a.
Mod a -> Map Name (ImpName PName, ModuleInstanceArgs PName)
modInstances Todo
m) }
pushMod :: Name -> Todo -> Todo -> Todo
pushMod :: Name -> Todo -> Todo -> Todo
pushMod Name
k Todo
v Todo
m = Todo
m { modMods :: Map Name Todo
modMods = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
k Todo
v (forall a. Mod a -> Map Name (Mod a)
modMods Todo
m) }
updMS :: (ModState -> ModState) -> Todo -> Todo
updMS :: (ModState -> ModState) -> Todo -> Todo
updMS ModState -> ModState
f Todo
m = Todo
m { modState :: ModState
modState = ModState -> ModState
f (forall a. Mod a -> a
modState Todo
m) }
externalMod :: Mod () -> ResolvedExt
externalMod :: Mod () -> ResolvedExt
externalMod Mod ()
m = ResolvedModule
{ rmodDefines :: NamingEnv
rmodDefines = forall a. Mod a -> NamingEnv
modDefines Mod ()
m
, rmodPublic :: Set Name
rmodPublic = forall a. Mod a -> Set Name
modPublic Mod ()
m
, rmodKind :: ModKind
rmodKind = forall a. Mod a -> ModKind
modKind Mod ()
m
, rmodNested :: Set Name
rmodNested = forall a. Mod a -> Set Name
modNested Mod ()
m
, rmodImports :: ()
rmodImports = ()
}
forget :: ResolvedLocal -> ResolvedExt
forget :: ResolvedLocal -> ResolvedExt
forget ResolvedLocal
r = ResolvedLocal
r { rmodImports :: ()
rmodImports = () }
type CurState = CurState' Todo
data CurState' a = CurState
{ forall a. CurState' a -> a
curMod :: a
, forall a. CurState' a -> ModName
curTop :: !ModName
, forall a. CurState' a -> ImpName Name -> Mod ()
externalModules :: ImpName Name -> Mod ()
, forall a. CurState' a -> Map Name ResolvedLocal
doneModules :: Map Name ResolvedLocal
, forall a. CurState' a -> Supply
nameSupply :: Supply
, forall a. CurState' a -> Bool
changes :: Bool
}
updCur :: CurState -> (Todo -> Todo) -> CurState
updCur :: CurState -> (Todo -> Todo) -> CurState
updCur CurState
m Todo -> Todo
f = CurState
m { curMod :: Todo
curMod = Todo -> Todo
f (forall a. CurState' a -> a
curMod CurState
m) }
updCurMS :: CurState -> (ModState -> ModState) -> CurState
updCurMS :: CurState -> (ModState -> ModState) -> CurState
updCurMS CurState
s ModState -> ModState
f = CurState -> (Todo -> Todo) -> CurState
updCur CurState
s ((ModState -> ModState) -> Todo -> Todo
updMS ModState -> ModState
f)
class HasCurScope a where
curScope :: CurState' a -> NamingEnv
instance HasCurScope () where
curScope :: CurState' () -> NamingEnv
curScope CurState' ()
_ = forall a. Monoid a => a
mempty
instance HasCurScope Todo where
curScope :: CurState -> NamingEnv
curScope CurState
s = forall a. Mod a -> NamingEnv
modDefines Todo
m NamingEnv -> NamingEnv -> NamingEnv
`shadowing` ModState -> NamingEnv
modImported ModState
ms NamingEnv -> NamingEnv -> NamingEnv
`shadowing` ModState -> NamingEnv
modOuter ModState
ms
where
m :: Todo
m = forall a. CurState' a -> a
curMod CurState
s
ms :: ModState
ms = forall a. Mod a -> a
modState Todo
m
doStep :: (CurState -> CurState) -> (CurState -> CurState)
doStep :: (CurState -> CurState) -> CurState -> CurState
doStep CurState -> CurState
f CurState
s0 = Bool -> CurState -> CurState
go (forall a. CurState' a -> Bool
changes CurState
s0) CurState
s0
where
go :: Bool -> CurState -> CurState
go Bool
ch CurState
s = let s1 :: CurState
s1 = CurState -> CurState
f CurState
s { changes :: Bool
changes = Bool
False }
in if forall a. CurState' a -> Bool
changes CurState
s1
then Bool -> CurState -> CurState
go Bool
True CurState
s1
else CurState
s { changes :: Bool
changes = Bool
ch }
knownPName :: HasCurScope a => CurState' a -> PName -> Maybe Name
knownPName :: forall a. HasCurScope a => CurState' a -> PName -> Maybe Name
knownPName CurState' a
s PName
x =
do Names
ns <- Namespace -> PName -> NamingEnv -> Maybe Names
lookupNS Namespace
NSModule PName
x (forall a. HasCurScope a => CurState' a -> NamingEnv
curScope CurState' a
s)
case Names
ns of
One Name
n -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
Ambig {} -> forall a. Maybe a
Nothing
knownImpName ::
HasCurScope a => CurState' a -> ImpName PName -> Maybe (ImpName Name)
knownImpName :: forall a.
HasCurScope a =>
CurState' a -> ImpName PName -> Maybe (ImpName Name)
knownImpName CurState' a
s ImpName PName
i =
case ImpName PName
i of
ImpTop ModName
m -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall name. ModName -> ImpName name
ImpTop ModName
m)
ImpNested PName
m -> forall name. name -> ImpName name
ImpNested forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. HasCurScope a => CurState' a -> PName -> Maybe Name
knownPName CurState' a
s PName
m
knownModule ::
HasCurScope a => CurState' a -> ImpName Name -> Maybe ResolvedExt
knownModule :: forall a.
HasCurScope a =>
CurState' a -> ImpName Name -> Maybe ResolvedExt
knownModule CurState' a
s ImpName Name
x
| ModName
root forall a. Eq a => a -> a -> Bool
== forall a. CurState' a -> ModName
curTop CurState' a
s =
case ImpName Name
x of
ImpNested Name
y -> ResolvedLocal -> ResolvedExt
forget forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
y (forall a. CurState' a -> Map Name ResolvedLocal
doneModules CurState' a
s)
ImpTop {} -> forall a. Maybe a
Nothing
| Bool
otherwise = forall a. a -> Maybe a
Just (Mod () -> ResolvedExt
externalMod (forall a. CurState' a -> ImpName Name -> Mod ()
externalModules CurState' a
s ImpName Name
x))
where
root :: ModName
root = case ImpName Name
x of
ImpTop ModName
r -> ModName
r
ImpNested Name
n -> Name -> ModName
nameTopModule Name
n
tryImport :: CurState -> ImportG (ImpName PName) -> CurState
tryImport :: CurState -> ImportG (ImpName PName) -> CurState
tryImport CurState
s ImportG (ImpName PName)
imp =
forall a. a -> Maybe a -> a
fromMaybe (CurState -> (Todo -> Todo) -> CurState
updCur CurState
s (ImportG (ImpName PName) -> Todo -> Todo
pushImport ImportG (ImpName PName)
imp))
do let srcName :: ImpName PName
srcName = forall mname. ImportG mname -> mname
iModule ImportG (ImpName PName)
imp
ImpName Name
mname <- forall a.
HasCurScope a =>
CurState' a -> ImpName PName -> Maybe (ImpName Name)
knownImpName CurState
s ImpName PName
srcName
ResolvedExt
ext <- forall a.
HasCurScope a =>
CurState' a -> ImpName Name -> Maybe ResolvedExt
knownModule CurState
s ImpName Name
mname
let isPub :: Name -> Bool
isPub Name
x = Name
x forall a. Ord a => a -> Set a -> Bool
`Set.member` forall imps. ResolvedModule imps -> Set Name
rmodPublic ResolvedExt
ext
new :: NamingEnv
new = case forall imps. ResolvedModule imps -> ModKind
rmodKind ResolvedExt
ext of
ModKind
AModule -> forall name. ImportG name -> NamingEnv -> NamingEnv
interpImportEnv ImportG (ImpName PName)
imp
((Name -> Bool) -> NamingEnv -> NamingEnv
filterUNames Name -> Bool
isPub (forall imps. ResolvedModule imps -> NamingEnv
rmodDefines ResolvedExt
ext))
ModKind
AFunctor -> forall a. Monoid a => a
mempty
ModKind
ASignature -> forall a. Monoid a => a
mempty
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ CurState -> (ModState -> ModState) -> CurState
updCurMS CurState
s { changes :: Bool
changes = Bool
True }
\ModState
ms -> ModState
ms { modImported :: NamingEnv
modImported = NamingEnv
new forall a. Semigroup a => a -> a -> a
<> ModState -> NamingEnv
modImported ModState
ms }
doImportStep :: CurState -> CurState
doImportStep :: CurState -> CurState
doImportStep CurState
s = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' CurState -> ImportG (ImpName PName) -> CurState
tryImport CurState
s1 (forall a. Mod a -> [ImportG (ImpName PName)]
modImports (forall a. CurState' a -> a
curMod CurState
s))
where
s1 :: CurState
s1 = CurState -> (Todo -> Todo) -> CurState
updCur CurState
s \Todo
m -> Todo
m { modImports :: [ImportG (ImpName PName)]
modImports = [] }
tryInstanceMaybe ::
HasCurScope a =>
CurState' a ->
ImpName Name ->
(ImpName PName, ModuleInstanceArgs PName)
->
Maybe (ResolvedLocal,CurState' a)
tryInstanceMaybe :: forall a.
HasCurScope a =>
CurState' a
-> ImpName Name
-> (ImpName PName, ModuleInstanceArgs PName)
-> Maybe (ResolvedLocal, CurState' a)
tryInstanceMaybe CurState' a
s ImpName Name
mn (ImpName PName
f,ModuleInstanceArgs PName
_xs) =
do ImpName Name
fn <- forall a.
HasCurScope a =>
CurState' a -> ImpName PName -> Maybe (ImpName Name)
knownImpName CurState' a
s ImpName PName
f
let path :: ModPath
path = case ImpName Name
mn of
ImpTop ModName
m -> ModName -> ModPath
TopModule ModName
m
ImpNested Name
m ->
case Name -> Maybe OrigName
asOrigName Name
m of
Just OrigName
og -> ModPath -> Ident -> ModPath
Nested (OrigName -> ModPath
ogModule OrigName
og) (OrigName -> Ident
ogName OrigName
og)
Maybe OrigName
Nothing ->
forall a. HasCallStack => String -> [String] -> a
panic String
"tryInstanceMaybe" [ String
"Not a top-level name" ]
forall a.
HasCurScope a =>
Bool
-> ModPath
-> ImpName Name
-> CurState' a
-> Maybe (ResolvedLocal, CurState' a)
doInstantiateByName Bool
False ModPath
path ImpName Name
fn CurState' a
s
tryInstance ::
CurState ->
Name ->
(ImpName PName, ModuleInstanceArgs PName) ->
CurState
tryInstance :: CurState
-> Name -> (ImpName PName, ModuleInstanceArgs PName) -> CurState
tryInstance CurState
s Name
mn (ImpName PName
f,ModuleInstanceArgs PName
xs) =
case forall a.
HasCurScope a =>
CurState' a
-> ImpName Name
-> (ImpName PName, ModuleInstanceArgs PName)
-> Maybe (ResolvedLocal, CurState' a)
tryInstanceMaybe CurState
s (forall name. name -> ImpName name
ImpNested Name
mn) (ImpName PName
f,ModuleInstanceArgs PName
xs) of
Maybe (ResolvedLocal, CurState)
Nothing -> CurState -> (Todo -> Todo) -> CurState
updCur CurState
s (Name -> (ImpName PName, ModuleInstanceArgs PName) -> Todo -> Todo
pushInst Name
mn (ImpName PName
f,ModuleInstanceArgs PName
xs))
Just (ResolvedLocal
def,CurState
s1) -> CurState
s1 { changes :: Bool
changes = Bool
True
, doneModules :: Map Name ResolvedLocal
doneModules = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
mn ResolvedLocal
def (forall a. CurState' a -> Map Name ResolvedLocal
doneModules CurState
s1)
}
doInstantiateByName ::
HasCurScope a =>
Bool
->
ModPath ->
ImpName Name ->
CurState' a -> Maybe (ResolvedLocal,CurState' a)
doInstantiateByName :: forall a.
HasCurScope a =>
Bool
-> ModPath
-> ImpName Name
-> CurState' a
-> Maybe (ResolvedLocal, CurState' a)
doInstantiateByName Bool
keepArgs ModPath
mpath ImpName Name
fname CurState' a
s =
do ResolvedExt
def <- forall a.
HasCurScope a =>
CurState' a -> ImpName Name -> Maybe ResolvedExt
knownModule CurState' a
s ImpName Name
fname
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a.
HasCurScope a =>
Bool
-> ModPath
-> ResolvedExt
-> CurState' a
-> (ResolvedLocal, CurState' a)
doInstantiate Bool
keepArgs ModPath
mpath ResolvedExt
def CurState' a
s)
doInstantiate ::
HasCurScope a =>
Bool ->
ModPath ->
ResolvedExt ->
CurState' a -> (ResolvedLocal,CurState' a)
doInstantiate :: forall a.
HasCurScope a =>
Bool
-> ModPath
-> ResolvedExt
-> CurState' a
-> (ResolvedLocal, CurState' a)
doInstantiate Bool
keepArgs ModPath
mpath ResolvedExt
def CurState' a
s = (ResolvedLocal
newDef, forall a b. (a -> b -> a) -> a -> Set b -> a
Set.foldl' forall {a}.
HasCurScope a =>
CurState' a -> (Name, Name) -> CurState' a
doSub CurState' a
newS Set (Name, Name)
nestedToDo)
where
((NamingEnv
newEnv,Supply
newNameSupply),Set (Name, Name)
nestedToDo) =
forall a. Id a -> a
M.runId
forall a b. (a -> b) -> a -> b
$ forall i (m :: * -> *) a. i -> StateT i m a -> m (a, i)
M.runStateT forall a. Set a
Set.empty
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
Supply -> SupplyT m a -> m (a, Supply)
runSupplyT (forall a. CurState' a -> Supply
nameSupply CurState' a
s)
forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *).
Applicative f =>
(Name -> f Name) -> NamingEnv -> f NamingEnv
travNamingEnv Name -> SupplyT (StateT (Set (Name, Name)) Id) Name
instName
forall a b. (a -> b) -> a -> b
$ forall imps. ResolvedModule imps -> NamingEnv
rmodDefines ResolvedExt
def
newS :: CurState' a
newS = CurState' a
s { nameSupply :: Supply
nameSupply = Supply
newNameSupply }
pub :: Set Name
pub = let inst :: Map Name Name
inst = NamingEnv -> NamingEnv -> Map Name Name
zipByTextName (forall imps. ResolvedModule imps -> NamingEnv
rmodDefines ResolvedExt
def) NamingEnv
newEnv
in forall a. Ord a => [a] -> Set a
Set.fromList [ case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
og Map Name Name
inst of
Just Name
newN -> Name
newN
Maybe Name
Nothing -> forall a. HasCallStack => String -> [String] -> a
panic String
"doInstantiate.pub"
[ String
"Lost a name", forall a. Show a => a -> String
show Name
og ]
| Name
og <- forall a. Set a -> [a]
Set.toList (forall imps. ResolvedModule imps -> Set Name
rmodPublic ResolvedExt
def)
]
newDef :: ResolvedLocal
newDef = ResolvedModule { rmodDefines :: NamingEnv
rmodDefines = NamingEnv
newEnv
, rmodPublic :: Set Name
rmodPublic = Set Name
pub
, rmodKind :: ModKind
rmodKind = case forall imps. ResolvedModule imps -> ModKind
rmodKind ResolvedExt
def of
ModKind
AFunctor ->
if Bool
keepArgs then ModKind
AFunctor
else ModKind
AModule
ModKind
ASignature -> ModKind
ASignature
ModKind
AModule -> ModKind
AModule
, rmodNested :: Set Name
rmodNested = forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall a b. (a, b) -> b
snd Set (Name, Name)
nestedToDo
, rmodImports :: NamingEnv
rmodImports = forall a. Monoid a => a
mempty
}
doSub :: CurState' a -> (Name, Name) -> CurState' a
doSub CurState' a
st (Name
oldSubName,Name
newSubName) =
case forall a.
HasCurScope a =>
Bool
-> ModPath
-> ImpName Name
-> CurState' a
-> Maybe (ResolvedLocal, CurState' a)
doInstantiateByName Bool
True (ModPath -> Ident -> ModPath
Nested ModPath
mpath (Name -> Ident
nameIdent Name
newSubName))
(forall name. name -> ImpName name
ImpNested Name
oldSubName) CurState' a
st of
Just (ResolvedLocal
idef,CurState' a
st1) -> CurState' a
st1 { doneModules :: Map Name ResolvedLocal
doneModules = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
newSubName ResolvedLocal
idef
(forall a. CurState' a -> Map Name ResolvedLocal
doneModules CurState' a
st1) }
Maybe (ResolvedLocal, CurState' a)
Nothing -> forall a. HasCallStack => String -> [String] -> a
panic String
"doInstantiate.doSub"
[ String
"Missing nested module:", forall a. Show a => a -> String
show (forall a. PP a => a -> Doc
pp Name
oldSubName) ]
instName :: Name -> SupplyT (M.StateT (Set (Name,Name)) M.Id) Name
instName :: Name -> SupplyT (StateT (Set (Name, Name)) Id) Name
instName Name
x =
do Name
y <- forall (m :: * -> *) a. FreshM m => (Supply -> (a, Supply)) -> m a
liftSupply (ModPath -> Name -> Supply -> (Name, Supply)
freshNameFor ModPath
mpath Name
x)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
x forall a. Ord a => a -> Set a -> Bool
`Set.member` forall imps. ResolvedModule imps -> Set Name
rmodNested ResolvedExt
def)
(forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadT t, Monad m) =>
m a -> t m a
M.lift (forall (m :: * -> *) s. StateM m s => (s -> s) -> m ()
M.sets_ (forall a. Ord a => a -> Set a -> Set a
Set.insert (Name
x,Name
y))))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
y
doInstancesStep :: CurState -> CurState
doInstancesStep :: CurState -> CurState
doInstancesStep CurState
s = forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' CurState
-> Name -> (ImpName PName, ModuleInstanceArgs PName) -> CurState
tryInstance CurState
s0 (forall a.
Mod a -> Map Name (ImpName PName, ModuleInstanceArgs PName)
modInstances (forall a. CurState' a -> a
curMod CurState
s))
where
s0 :: CurState
s0 = CurState -> (Todo -> Todo) -> CurState
updCur CurState
s \Todo
m' -> Todo
m' { modInstances :: Map Name (ImpName PName, ModuleInstanceArgs PName)
modInstances = forall k a. Map k a
Map.empty }
tryFinishCurMod :: Todo -> CurState -> Maybe ResolvedLocal
tryFinishCurMod :: Todo -> CurState -> Maybe ResolvedLocal
tryFinishCurMod Todo
m CurState
newS
| Todo -> Bool
isDone Todo
newM =
forall a. a -> Maybe a
Just ResolvedModule
{ rmodDefines :: NamingEnv
rmodDefines = forall a. Mod a -> NamingEnv
modDefines Todo
m
, rmodPublic :: Set Name
rmodPublic = forall a. Mod a -> Set Name
modPublic Todo
m
, rmodKind :: ModKind
rmodKind = forall a. Mod a -> ModKind
modKind Todo
m
, rmodNested :: Set Name
rmodNested = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions
[ forall k a. Map k a -> Set k
Map.keysSet (forall a.
Mod a -> Map Name (ImpName PName, ModuleInstanceArgs PName)
modInstances Todo
m)
, forall k a. Map k a -> Set k
Map.keysSet (forall a. Mod a -> Map Name (Mod a)
modMods Todo
m)
]
, rmodImports :: NamingEnv
rmodImports = ModState -> NamingEnv
modImported (forall a. Mod a -> a
modState Todo
newM)
}
| Bool
otherwise = forall a. Maybe a
Nothing
where newM :: Todo
newM = forall a. CurState' a -> a
curMod CurState
newS
tryModule :: CurState -> Name -> Todo -> CurState
tryModule :: CurState -> Name -> Todo -> CurState
tryModule CurState
s Name
nm Todo
m =
case Todo -> CurState -> Maybe ResolvedLocal
tryFinishCurMod Todo
m CurState
newS of
Just ResolvedLocal
rMod ->
CurState
newS { curMod :: Todo
curMod = forall a. CurState' a -> a
curMod CurState
s
, doneModules :: Map Name ResolvedLocal
doneModules = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
nm ResolvedLocal
rMod (forall a. CurState' a -> Map Name ResolvedLocal
doneModules CurState
newS)
, changes :: Bool
changes = Bool
True
}
Maybe ResolvedLocal
Nothing -> CurState
newS { curMod :: Todo
curMod = Name -> Todo -> Todo -> Todo
pushMod Name
nm Todo
newM (forall a. CurState' a -> a
curMod CurState
s) }
where
s1 :: CurState
s1 = CurState -> (Todo -> Todo) -> CurState
updCur CurState
s \Todo
_ -> (ModState -> ModState) -> Todo -> Todo
updMS (\ModState
ms -> ModState
ms { modOuter :: NamingEnv
modOuter = forall a. HasCurScope a => CurState' a -> NamingEnv
curScope CurState
s }) Todo
m
newS :: CurState
newS = CurState -> CurState
doModuleStep CurState
s1
newM :: Todo
newM = forall a. CurState' a -> a
curMod CurState
newS
doModulesStep :: CurState -> CurState
doModulesStep :: CurState -> CurState
doModulesStep CurState
s = forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' CurState -> Name -> Todo -> CurState
tryModule CurState
s0 (forall a. Mod a -> Map Name (Mod a)
modMods Todo
m)
where
m :: Todo
m = forall a. CurState' a -> a
curMod CurState
s
s0 :: CurState
s0 = CurState
s { curMod :: Todo
curMod = Todo
m { modMods :: Map Name Todo
modMods = forall a. Monoid a => a
mempty } }
doModuleStep :: CurState -> CurState
doModuleStep :: CurState -> CurState
doModuleStep = (CurState -> CurState) -> CurState -> CurState
doStep CurState -> CurState
step
where
step :: CurState -> CurState
step = (CurState -> CurState) -> CurState -> CurState
doStep CurState -> CurState
doModulesStep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CurState -> CurState) -> CurState -> CurState
doStep CurState -> CurState
doInstancesStep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CurState -> CurState) -> CurState -> CurState
doStep CurState -> CurState
doImportStep