{-# 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(..), newFunctorInst )
import Cryptol.ModuleSystem.Name
( Name, Supply, SupplyT, runSupplyT, 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 = Map Name ResolvedLocal
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 -> ModName
-> ResolvedLocal
-> CurState
-> (Map (ImpName Name) ResolvedLocal, Supply)
forall {a}.
ModName
-> ResolvedLocal
-> CurState' a
-> (Map (ImpName Name) ResolvedLocal, Supply)
add ModName
m ResolvedLocal
r CurState
newS
Maybe ResolvedLocal
Nothing -> ModName
-> ResolvedLocal
-> CurState
-> (Map (ImpName Name) ResolvedLocal, Supply)
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 = Map Name ResolvedLocal
forall a. Monoid a => a
mempty
, nameSupply :: Supply
nameSupply = Supply
su
, changes :: Bool
changes = Bool
False
}
case CurState' ()
-> ImpName Name
-> (ImpName PName, ModuleInstanceArgs PName)
-> Maybe (ResolvedLocal, CurState' ())
forall a.
HasCurScope a =>
CurState' a
-> ImpName Name
-> (ImpName PName, ModuleInstanceArgs PName)
-> Maybe (ResolvedLocal, CurState' a)
tryInstanceMaybe CurState' ()
s (ModName -> ImpName Name
forall name. ModName -> ImpName name
ImpTop ModName
m) (ImpName PName
f,ModuleInstanceArgs PName
as) of
Just (ResolvedLocal
r,CurState' ()
newS) -> ModName
-> ResolvedLocal
-> CurState' ()
-> (Map (ImpName Name) ResolvedLocal, Supply)
forall {a}.
ModName
-> ResolvedLocal
-> CurState' a
-> (Map (ImpName Name) ResolvedLocal, Supply)
add ModName
m ResolvedLocal
r CurState' ()
newS
Maybe (ResolvedLocal, CurState' ())
Nothing -> (ImpName Name -> ResolvedLocal -> Map (ImpName Name) ResolvedLocal
forall k a. k -> a -> Map k a
Map.singleton (ModName -> ImpName Name
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 = [(ImpName name, a)] -> Map (ImpName name) a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (name -> ImpName name
forall name. name -> ImpName name
ImpNested name
k, a
v) | (name
k,a
v) <- Map name a -> [(name, a)]
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 = ( ImpName Name
-> ResolvedLocal
-> Map (ImpName Name) ResolvedLocal
-> Map (ImpName Name) ResolvedLocal
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (ModName -> ImpName Name
forall name. ModName -> ImpName name
ImpTop ModName
m) ResolvedLocal
r (Map Name ResolvedLocal -> Map (ImpName Name) ResolvedLocal
forall {name} {a}. Ord name => Map name a -> Map (ImpName name) a
toNest (CurState' a -> Map Name ResolvedLocal
forall a. CurState' a -> Map Name ResolvedLocal
doneModules CurState' a
s))
, CurState' a -> Supply
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 = (() -> ModState) -> Mod () -> Todo
forall a b. (a -> b) -> Mod a -> Mod b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ModState -> () -> ModState
forall a b. a -> b -> a
const ModState
emptyModState)
where
emptyModState :: ModState
emptyModState =
ModState
{ modOuter :: NamingEnv
modOuter = NamingEnv
forall a. Monoid a => a
mempty
, modImported :: NamingEnv
modImported = NamingEnv
forall a. Monoid a => a
mempty
}
isDone :: Todo -> Bool
isDone :: Todo -> Bool
isDone Todo
m = [ImportG (ImpName PName)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Todo -> [ImportG (ImpName PName)]
forall a. Mod a -> [ImportG (ImpName PName)]
modImports Todo
m) Bool -> Bool -> Bool
&&
Map Name (ImpName PName, ModuleInstanceArgs PName) -> Bool
forall k a. Map k a -> Bool
Map.null (Todo -> Map Name (ImpName PName, ModuleInstanceArgs PName)
forall a.
Mod a -> Map Name (ImpName PName, ModuleInstanceArgs PName)
modInstances Todo
m) Bool -> Bool -> Bool
&&
Map Name Todo -> Bool
forall k a. Map k a -> Bool
Map.null (Todo -> Map Name Todo
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 = CurState -> Todo
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.insert k v (doneModules s) }
s1 :: CurState
s1 = (CurState -> Name -> CurState) -> CurState -> [Name] -> CurState
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\CurState
s Name
k -> Name -> ResolvedLocal -> CurState -> CurState
forall {a}. Name -> ResolvedLocal -> CurState' a -> CurState' a
add Name
k ResolvedLocal
forceResolveInst CurState
s) CurState
s0
(Map Name (ImpName PName, ModuleInstanceArgs PName) -> [Name]
forall k a. Map k a -> [k]
Map.keys (Todo -> Map Name (ImpName PName, ModuleInstanceArgs PName)
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 = m }
in Name -> ResolvedLocal -> CurState -> CurState
forall {a}. Name -> ResolvedLocal -> CurState' a -> CurState' a
add Name
k ResolvedLocal
r CurState
s'
in ( Todo -> ResolvedLocal
forceResolveMod Todo
this
, (CurState -> (Name, Todo) -> CurState)
-> CurState -> [(Name, Todo)] -> CurState
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' CurState -> (Name, Todo) -> CurState
forall {a}. CurState' a -> (Name, Todo) -> CurState
doNestMod CurState
s1 (Map Name Todo -> [(Name, Todo)]
forall k a. Map k a -> [(k, a)]
Map.toList (Todo -> Map Name Todo
forall a. Mod a -> Map Name (Mod a)
modMods Todo
this))
)
forceResolveInst :: ResolvedLocal
forceResolveInst :: ResolvedLocal
forceResolveInst =
ResolvedModule
{ rmodDefines :: NamingEnv
rmodDefines = NamingEnv
forall a. Monoid a => a
mempty
, rmodPublic :: Set Name
rmodPublic = Set Name
forall a. Monoid a => a
mempty
, rmodKind :: ModKind
rmodKind = ModKind
AModule
, rmodNested :: Set Name
rmodNested = Set Name
forall a. Set a
Set.empty
, rmodImports :: NamingEnv
rmodImports = NamingEnv
forall a. Monoid a => a
mempty
}
forceResolveMod :: Todo -> ResolvedLocal
forceResolveMod :: Todo -> ResolvedLocal
forceResolveMod Todo
todo =
ResolvedModule
{ rmodDefines :: NamingEnv
rmodDefines = Todo -> NamingEnv
forall a. Mod a -> NamingEnv
modDefines Todo
todo
, rmodPublic :: Set Name
rmodPublic = Todo -> Set Name
forall a. Mod a -> Set Name
modPublic Todo
todo
, rmodKind :: ModKind
rmodKind = Todo -> ModKind
forall a. Mod a -> ModKind
modKind Todo
todo
, rmodNested :: Set Name
rmodNested = Map Name Todo -> Set Name
forall k a. Map k a -> Set k
Map.keysSet (Todo -> Map Name Todo
forall a. Mod a -> Map Name (Mod a)
modMods Todo
todo)
, rmodImports :: NamingEnv
rmodImports = ModState -> NamingEnv
modImported (Todo -> ModState
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 = i : modImports 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.insert k v (modInstances m) }
pushMod :: Name -> Todo -> Todo -> Todo
pushMod :: Name -> Todo -> Todo -> Todo
pushMod Name
k Todo
v Todo
m = Todo
m { modMods = Map.insert k v (modMods m) }
updMS :: (ModState -> ModState) -> Todo -> Todo
updMS :: (ModState -> ModState) -> Todo -> Todo
updMS ModState -> ModState
f Todo
m = Todo
m { modState = f (modState m) }
externalMod :: Mod () -> ResolvedExt
externalMod :: Mod () -> ResolvedExt
externalMod Mod ()
m = ResolvedModule
{ rmodDefines :: NamingEnv
rmodDefines = Mod () -> NamingEnv
forall a. Mod a -> NamingEnv
modDefines Mod ()
m
, rmodPublic :: Set Name
rmodPublic = Mod () -> Set Name
forall a. Mod a -> Set Name
modPublic Mod ()
m
, rmodKind :: ModKind
rmodKind = Mod () -> ModKind
forall a. Mod a -> ModKind
modKind Mod ()
m
, rmodNested :: Set Name
rmodNested = Mod () -> Set Name
forall a. Mod a -> Set Name
modNested Mod ()
m
, rmodImports :: ()
rmodImports = ()
}
forget :: ResolvedLocal -> ResolvedExt
forget :: ResolvedLocal -> ResolvedExt
forget ResolvedLocal
r = ResolvedLocal
r { 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 = f (curMod 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' ()
_ = NamingEnv
forall a. Monoid a => a
mempty
instance HasCurScope Todo where
curScope :: CurState -> NamingEnv
curScope CurState
s = Todo -> NamingEnv
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 = CurState -> Todo
forall a. CurState' a -> a
curMod CurState
s
ms :: ModState
ms = Todo -> ModState
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 (CurState -> Bool
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 = False }
in if CurState -> Bool
forall a. CurState' a -> Bool
changes CurState
s1
then Bool -> CurState -> CurState
go Bool
True CurState
s1
else CurState
s { changes = 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 (CurState' a -> NamingEnv
forall a. HasCurScope a => CurState' a -> NamingEnv
curScope CurState' a
s)
case Names
ns of
One Name
n -> Name -> Maybe Name
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
Ambig {} -> Maybe Name
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 -> ImpName Name -> Maybe (ImpName Name)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ModName -> ImpName Name
forall name. ModName -> ImpName name
ImpTop ModName
m)
ImpNested PName
m -> Name -> ImpName Name
forall name. name -> ImpName name
ImpNested (Name -> ImpName Name) -> Maybe Name -> Maybe (ImpName Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CurState' a -> PName -> Maybe Name
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 ModName -> ModName -> Bool
forall a. Eq a => a -> a -> Bool
== CurState' a -> ModName
forall a. CurState' a -> ModName
curTop CurState' a
s =
case ImpName Name
x of
ImpNested Name
y -> ResolvedLocal -> ResolvedExt
forget (ResolvedLocal -> ResolvedExt)
-> Maybe ResolvedLocal -> Maybe ResolvedExt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Map Name ResolvedLocal -> Maybe ResolvedLocal
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
y (CurState' a -> Map Name ResolvedLocal
forall a. CurState' a -> Map Name ResolvedLocal
doneModules CurState' a
s)
ImpTop {} -> Maybe ResolvedExt
forall a. Maybe a
Nothing
| Bool
otherwise = ResolvedExt -> Maybe ResolvedExt
forall a. a -> Maybe a
Just (Mod () -> ResolvedExt
externalMod (CurState' a -> ImpName Name -> Mod ()
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 =
CurState -> Maybe CurState -> CurState
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 = ImportG (ImpName PName) -> ImpName PName
forall mname. ImportG mname -> mname
iModule ImportG (ImpName PName)
imp
ImpName Name
mname <- CurState -> ImpName PName -> Maybe (ImpName Name)
forall a.
HasCurScope a =>
CurState' a -> ImpName PName -> Maybe (ImpName Name)
knownImpName CurState
s ImpName PName
srcName
ResolvedExt
ext <- CurState -> ImpName Name -> Maybe ResolvedExt
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 Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` ResolvedExt -> Set Name
forall imps. ResolvedModule imps -> Set Name
rmodPublic ResolvedExt
ext
new :: NamingEnv
new = case ResolvedExt -> ModKind
forall imps. ResolvedModule imps -> ModKind
rmodKind ResolvedExt
ext of
ModKind
AModule -> ImportG (ImpName PName) -> NamingEnv -> NamingEnv
forall name. ImportG name -> NamingEnv -> NamingEnv
interpImportEnv ImportG (ImpName PName)
imp
((Name -> Bool) -> NamingEnv -> NamingEnv
filterUNames Name -> Bool
isPub (ResolvedExt -> NamingEnv
forall imps. ResolvedModule imps -> NamingEnv
rmodDefines ResolvedExt
ext))
ModKind
AFunctor -> NamingEnv
forall a. Monoid a => a
mempty
ModKind
ASignature -> NamingEnv
forall a. Monoid a => a
mempty
CurState -> Maybe CurState
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CurState -> Maybe CurState) -> CurState -> Maybe CurState
forall a b. (a -> b) -> a -> b
$ CurState -> (ModState -> ModState) -> CurState
updCurMS CurState
s { changes = True }
\ModState
ms -> ModState
ms { modImported = new <> modImported ms }
doImportStep :: CurState -> CurState
doImportStep :: CurState -> CurState
doImportStep CurState
s = (CurState -> ImportG (ImpName PName) -> CurState)
-> CurState -> [ImportG (ImpName PName)] -> CurState
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' CurState -> ImportG (ImpName PName) -> CurState
tryImport CurState
s1 (Todo -> [ImportG (ImpName PName)]
forall a. Mod a -> [ImportG (ImpName PName)]
modImports (CurState -> Todo
forall a. CurState' a -> a
curMod CurState
s))
where
s1 :: CurState
s1 = CurState -> (Todo -> Todo) -> CurState
updCur CurState
s \Todo
m -> Todo
m { 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 <- CurState' a -> ImpName PName -> Maybe (ImpName Name)
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 ->
String -> [String] -> ModPath
forall a. HasCallStack => String -> [String] -> a
panic String
"tryInstanceMaybe" [ String
"Not a top-level name" ]
Bool
-> ModPath
-> ImpName Name
-> CurState' a
-> Maybe (ResolvedLocal, CurState' a)
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 CurState
-> ImpName Name
-> (ImpName PName, ModuleInstanceArgs PName)
-> Maybe (ResolvedLocal, CurState)
forall a.
HasCurScope a =>
CurState' a
-> ImpName Name
-> (ImpName PName, ModuleInstanceArgs PName)
-> Maybe (ResolvedLocal, CurState' a)
tryInstanceMaybe CurState
s (Name -> ImpName Name
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 = True
, doneModules = Map.insert mn def (doneModules 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 <- CurState' a -> ImpName Name -> Maybe ResolvedExt
forall a.
HasCurScope a =>
CurState' a -> ImpName Name -> Maybe ResolvedExt
knownModule CurState' a
s ImpName Name
fname
(ResolvedLocal, CurState' a) -> Maybe (ResolvedLocal, CurState' a)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
-> ModPath
-> ResolvedExt
-> CurState' a
-> (ResolvedLocal, CurState' a)
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, (CurState' a -> (Name, Name) -> CurState' a)
-> CurState' a -> Set (Name, Name) -> CurState' a
forall a b. (a -> b -> a) -> a -> Set b -> a
Set.foldl' CurState' a -> (Name, Name) -> CurState' a
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) =
Id ((NamingEnv, Supply), Set (Name, Name))
-> ((NamingEnv, Supply), Set (Name, Name))
forall a. Id a -> a
M.runId
(Id ((NamingEnv, Supply), Set (Name, Name))
-> ((NamingEnv, Supply), Set (Name, Name)))
-> Id ((NamingEnv, Supply), Set (Name, Name))
-> ((NamingEnv, Supply), Set (Name, Name))
forall a b. (a -> b) -> a -> b
$ Set (Name, Name)
-> StateT (Set (Name, Name)) Id (NamingEnv, Supply)
-> Id ((NamingEnv, Supply), Set (Name, Name))
forall i (m :: * -> *) a. i -> StateT i m a -> m (a, i)
M.runStateT Set (Name, Name)
forall a. Set a
Set.empty
(StateT (Set (Name, Name)) Id (NamingEnv, Supply)
-> Id ((NamingEnv, Supply), Set (Name, Name)))
-> StateT (Set (Name, Name)) Id (NamingEnv, Supply)
-> Id ((NamingEnv, Supply), Set (Name, Name))
forall a b. (a -> b) -> a -> b
$ Supply
-> SupplyT (StateT (Set (Name, Name)) Id) NamingEnv
-> StateT (Set (Name, Name)) Id (NamingEnv, Supply)
forall (m :: * -> *) a.
Monad m =>
Supply -> SupplyT m a -> m (a, Supply)
runSupplyT (CurState' a -> Supply
forall a. CurState' a -> Supply
nameSupply CurState' a
s)
(SupplyT (StateT (Set (Name, Name)) Id) NamingEnv
-> StateT (Set (Name, Name)) Id (NamingEnv, Supply))
-> SupplyT (StateT (Set (Name, Name)) Id) NamingEnv
-> StateT (Set (Name, Name)) Id (NamingEnv, Supply)
forall a b. (a -> b) -> a -> b
$ (Name -> SupplyT (StateT (Set (Name, Name)) Id) Name)
-> NamingEnv -> SupplyT (StateT (Set (Name, Name)) Id) NamingEnv
forall (f :: * -> *).
Applicative f =>
(Name -> f Name) -> NamingEnv -> f NamingEnv
travNamingEnv Name -> SupplyT (StateT (Set (Name, Name)) Id) Name
instName
(NamingEnv -> SupplyT (StateT (Set (Name, Name)) Id) NamingEnv)
-> NamingEnv -> SupplyT (StateT (Set (Name, Name)) Id) NamingEnv
forall a b. (a -> b) -> a -> b
$ ResolvedExt -> NamingEnv
forall imps. ResolvedModule imps -> NamingEnv
rmodDefines ResolvedExt
def
newS :: CurState' a
newS = CurState' a
s { nameSupply = newNameSupply }
pub :: Set Name
pub = let inst :: Map Name Name
inst = NamingEnv -> NamingEnv -> Map Name Name
zipByTextName (ResolvedExt -> NamingEnv
forall imps. ResolvedModule imps -> NamingEnv
rmodDefines ResolvedExt
def) NamingEnv
newEnv
in [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList [ case Name -> Map Name Name -> Maybe Name
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 -> String -> [String] -> Name
forall a. HasCallStack => String -> [String] -> a
panic String
"doInstantiate.pub"
[ String
"Lost a name", Name -> String
forall a. Show a => a -> String
show Name
og ]
| Name
og <- Set Name -> [Name]
forall a. Set a -> [a]
Set.toList (ResolvedExt -> Set Name
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 ResolvedExt -> ModKind
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 = ((Name, Name) -> Name) -> Set (Name, Name) -> Set Name
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (Name, Name) -> Name
forall a b. (a, b) -> b
snd Set (Name, Name)
nestedToDo
, rmodImports :: NamingEnv
rmodImports = NamingEnv
forall a. Monoid a => a
mempty
}
doSub :: CurState' a -> (Name, Name) -> CurState' a
doSub CurState' a
st (Name
oldSubName,Name
newSubName) =
case Bool
-> ModPath
-> ImpName Name
-> CurState' a
-> Maybe (ResolvedLocal, CurState' a)
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))
(Name -> ImpName Name
forall name. name -> ImpName name
ImpNested Name
oldSubName) CurState' a
st of
Just (ResolvedLocal
idef,CurState' a
st1) -> CurState' a
st1 { doneModules = Map.insert newSubName idef
(doneModules st1) }
Maybe (ResolvedLocal, CurState' a)
Nothing -> String -> [String] -> CurState' a
forall a. HasCallStack => String -> [String] -> a
panic String
"doInstantiate.doSub"
[ String
"Missing nested module:", Doc -> String
forall a. Show a => a -> String
show (Name -> Doc
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 <- ModPath -> Name -> SupplyT (StateT (Set (Name, Name)) Id) Name
forall (m :: * -> *). FreshM m => ModPath -> Name -> m Name
newFunctorInst ModPath
mpath Name
x
Bool
-> SupplyT (StateT (Set (Name, Name)) Id) ()
-> SupplyT (StateT (Set (Name, Name)) Id) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
x Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` ResolvedExt -> Set Name
forall imps. ResolvedModule imps -> Set Name
rmodNested ResolvedExt
def)
(StateT (Set (Name, Name)) Id ()
-> SupplyT (StateT (Set (Name, Name)) Id) ()
forall (m :: * -> *) a. Monad m => m a -> SupplyT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadT t, Monad m) =>
m a -> t m a
M.lift ((Set (Name, Name) -> Set (Name, Name))
-> StateT (Set (Name, Name)) Id ()
forall (m :: * -> *) s. StateM m s => (s -> s) -> m ()
M.sets_ ((Name, Name) -> Set (Name, Name) -> Set (Name, Name)
forall a. Ord a => a -> Set a -> Set a
Set.insert (Name
x,Name
y))))
Name -> SupplyT (StateT (Set (Name, Name)) Id) Name
forall a. a -> SupplyT (StateT (Set (Name, Name)) Id) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
y
doInstancesStep :: CurState -> CurState
doInstancesStep :: CurState -> CurState
doInstancesStep CurState
s = (CurState
-> Name -> (ImpName PName, ModuleInstanceArgs PName) -> CurState)
-> CurState
-> Map Name (ImpName PName, ModuleInstanceArgs PName)
-> CurState
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 (Todo -> Map Name (ImpName PName, ModuleInstanceArgs PName)
forall a.
Mod a -> Map Name (ImpName PName, ModuleInstanceArgs PName)
modInstances (CurState -> Todo
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.empty }
tryFinishCurMod :: Todo -> CurState -> Maybe ResolvedLocal
tryFinishCurMod :: Todo -> CurState -> Maybe ResolvedLocal
tryFinishCurMod Todo
m CurState
newS
| Todo -> Bool
isDone Todo
newM =
ResolvedLocal -> Maybe ResolvedLocal
forall a. a -> Maybe a
Just ResolvedModule
{ rmodDefines :: NamingEnv
rmodDefines = Todo -> NamingEnv
forall a. Mod a -> NamingEnv
modDefines Todo
m
, rmodPublic :: Set Name
rmodPublic = Todo -> Set Name
forall a. Mod a -> Set Name
modPublic Todo
m
, rmodKind :: ModKind
rmodKind = Todo -> ModKind
forall a. Mod a -> ModKind
modKind Todo
m
, rmodNested :: Set Name
rmodNested = [Set Name] -> Set Name
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions
[ Map Name (ImpName PName, ModuleInstanceArgs PName) -> Set Name
forall k a. Map k a -> Set k
Map.keysSet (Todo -> Map Name (ImpName PName, ModuleInstanceArgs PName)
forall a.
Mod a -> Map Name (ImpName PName, ModuleInstanceArgs PName)
modInstances Todo
m)
, Map Name Todo -> Set Name
forall k a. Map k a -> Set k
Map.keysSet (Todo -> Map Name Todo
forall a. Mod a -> Map Name (Mod a)
modMods Todo
m)
]
, rmodImports :: NamingEnv
rmodImports = ModState -> NamingEnv
modImported (Todo -> ModState
forall a. Mod a -> a
modState Todo
newM)
}
| Bool
otherwise = Maybe ResolvedLocal
forall a. Maybe a
Nothing
where newM :: Todo
newM = CurState -> Todo
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 = curMod s
, doneModules = Map.insert nm rMod (doneModules newS)
, changes = True
}
Maybe ResolvedLocal
Nothing -> CurState
newS { curMod = pushMod nm newM (curMod s) }
where
s1 :: CurState
s1 = CurState -> (Todo -> Todo) -> CurState
updCur CurState
s \Todo
_ -> (ModState -> ModState) -> Todo -> Todo
updMS (\ModState
ms -> ModState
ms { modOuter = curScope s }) Todo
m
newS :: CurState
newS = CurState -> CurState
doModuleStep CurState
s1
newM :: Todo
newM = CurState -> Todo
forall a. CurState' a -> a
curMod CurState
newS
doModulesStep :: CurState -> CurState
doModulesStep :: CurState -> CurState
doModulesStep CurState
s = (CurState -> Name -> Todo -> CurState)
-> CurState -> Map Name Todo -> CurState
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' CurState -> Name -> Todo -> CurState
tryModule CurState
s0 (Todo -> Map Name Todo
forall a. Mod a -> Map Name (Mod a)
modMods Todo
m)
where
m :: Todo
m = CurState -> Todo
forall a. CurState' a -> a
curMod CurState
s
s0 :: CurState
s0 = CurState
s { curMod = m { modMods = 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
(CurState -> CurState)
-> (CurState -> CurState) -> CurState -> CurState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CurState -> CurState) -> CurState -> CurState
doStep CurState -> CurState
doInstancesStep
(CurState -> CurState)
-> (CurState -> CurState) -> CurState -> CurState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CurState -> CurState) -> CurState -> CurState
doStep CurState -> CurState
doImportStep