{- |

This module deals with imports of nested modules (@import submodule@).
This is more complex than it might seem at first because to resolve a
declaration like @import submodule X@ we need to resolve what @X@
referes to before we know what it will import.

Even triciker is the case for functor instantiations:

  module M = F { X }
  import M

In this case, even if we know what `M` referes to, we first need to
resolve `F`, so that we can generate the instantiation and generate
fresh names for names defined by `M`.

If we want to support applicative semantics, then before instantiation
`M` we also need to resolve `X` so that we know if this instantiation has
already been generated.

An overall guiding principle of the design is that we assume that declarations
can be ordered in dependency order, and submodules can be processed one
at a time. In particular, this does not allow recursion across modules,
or functor instantiations depending on their arguments.

Thus, the following is OK:

module A where
  x = 0x2

  submodule B where
    y = x

  z = B::y


However, this is not OK:

  submodule A = F X
  submodule F where
    import A
-}

{-# 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 )


{- | This represents a resolved module or signaure.
The type parameter helps us distinguish between two types of resolved modules:

  1. Resolved modules that are *inputs* to the algorithm (i.e., they are
     defined outside the current module).  For such modules the type
     parameter is @imps@ is ()

  2. Resolved modules that are *outputs* of the algorithm (i.e., they
     are defined within the current module).  For such modules the type
     parameter @imps@ contains the naming environment for things
     that came in through the import.

Note that signaures are never "imported", however we do need to keep them
here so that signatures in a functor are properly instantiated when
the functor is instantiated.
-}
data ResolvedModule imps = ResolvedModule
  { forall imps. ResolvedModule imps -> NamingEnv
rmodDefines   :: NamingEnv    -- ^ Things defined by the module/signature.
  , forall imps. ResolvedModule imps -> Set Name
rmodPublic    :: !(Set Name)  -- ^ Exported names
  , forall imps. ResolvedModule imps -> ModKind
rmodKind      :: ModKind      -- ^ What sort of thing are we
  , forall imps. ResolvedModule imps -> Set Name
rmodNested    :: Set Name     -- ^ Modules and signatures nested in this one
  , forall imps. ResolvedModule imps -> imps
rmodImports   :: imps
    {- ^ Resolved imports. External modules need not specify this field,
    it is just part of the thing we compute for local modules. -}
  }


-- | A resolved module that's defined in (or is) the current top-level module
type ResolvedLocal = ResolvedModule NamingEnv

-- | A resolved module that's not defined in the current top-level module
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
               )




--------------------------------------------------------------------------------


-- | This keeps track of the current state of resolution of a module.
type Todo = Mod ModState

data ModState = ModState
  { ModState -> NamingEnv
modOuter        :: NamingEnv
    -- ^ Things which come in scope from outer modules

  , ModState -> NamingEnv
modImported     :: NamingEnv
    -- ^ Things which come in scope via imports.  These shadow outer names.
  }


-- | Initial state of a module that needs processing.
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
      }

{- | A module is fully processed when we are done with all its:

  * submodule imports
  * instantiations
  * nested things (signatures and modules)
-}
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)


-- | Finish up all unfinished modules as best as we can
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))
     )


-- | A place-holder entry for instnatitations we couldn't resolve.
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
    }

-- | Finish up unresolved modules as well as we can, in situations where
-- the program contains an error.
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  = ()
  }

{- | This is used when we need to use a local resolved module as an input
     to another module. -}
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
    -- ^ This is what needs to be done

  , forall a. CurState' a -> ModName
curTop      :: !ModName
    {- ^ The top-level module we are working on.  This does not change
       throught the algorithm, it is just convenient to pass it here with 
       all the other stuff. -}

  , forall a. CurState' a -> ImpName Name -> Mod ()
externalModules :: ImpName Name -> Mod ()
    -- ^ Modules defined outside the current top-level modules

  , forall a. CurState' a -> Map Name ResolvedLocal
doneModules :: Map Name ResolvedLocal
    {- ^ Nested modules/signatures in the current top-level modules.
         These may be either defined locally, or be the result of
         instantiating a functor.  Note that the functor itself may be
         either local or external.
    -}

  , forall a. CurState' a -> Supply
nameSupply :: Supply
    -- ^ Use this to instantiate functors

  , forall a. CurState' a -> Bool
changes :: Bool
    -- ^ True if something changed on the last iteration
  }

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


-- | Keep applying a transformation while things are changing
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 }

-- | Is this a known name for a module in the current scope?
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
       {- NOTE: since we build up what's in scope incrementally,
          it is possible that this would eventually be ambiguous,
          which we'll detect during actual renaming. -}

       Ambig {} -> Maybe Name
forall a. Maybe a
Nothing
       {- We treat ambiguous imports as undefined, which may lead to
          spurious "undefined X" errors.  To avoid this we should prioritize
          reporting "ambiguous X" errors. -}

-- | Is the module mentioned in this import known in the current scope?
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

-- | Is the module mentioned in the import already resolved?
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   -- or panic? recursive import

  | 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

--------------------------------------------------------------------------------


{- | Try to resolve an import. If the imported module can be resolved,
and it refers to a module that's already been resolved, then we do the
import and extend the current scoping environment.  Otherwise, we just
queue the import back on the @modImports@ of the current module to be tried
again later.-}
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))   -- not ready, put it back on the q
  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 }

-- | Resolve all imports in the current modules
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 = [] }


{- | Try to instantiate a functor.  This succeeds if we can resolve the functor
and the arguments and the both refer to already resolved names.
Note: at the moment we ignore the arguments, but we'd have to do that in
order to implment applicative behavior with caching. -}
tryInstanceMaybe ::
  HasCurScope a =>
  CurState' a ->
  ImpName Name ->
  (ImpName PName, ModuleInstanceArgs PName)
  {- ^ Functor and arguments -}  ->
  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

{- | Try to instantiate a functor.  If successful, then the newly instantiated
module (and all things nested in it) are going to be added to the
@doneModules@ field.  Otherwise, we queue up the instantiatation in
@curMod@ for later processing -}
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)
                        }

{- | Generate a fresh instance for the functor with the given name. -}
doInstantiateByName ::
  HasCurScope a =>
  Bool
  {- ^ This indicates if the result is a functor or not.  When instantiating
    a functor applied to some arguments the result is not a functor.  However,
    if we are instantiating a functor nested within some functor that's being
    instantiated, then the result is still a functor. -} ->
  ModPath {- ^ Path for instantiated names -} ->
  ImpName Name {- ^ Name of the functor/module being instantiated -} ->
  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)



{- | Generate a new instantiation of the given module/signature.
Note that the module might not be a functor itself (e.g., if we are
instantiating something nested in a functor -}
doInstantiate ::
  HasCurScope a =>
  Bool               {- ^ See `doInstantiateByName` -} ->
  ModPath            {- ^ Path for instantiated names -} ->
  ResolvedExt        {- ^ The thing being instantiated -} ->
  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
                            {- we don't do name resolution on the instantiation
                               the usual way: instead the functor and the
                               arguments are renamed separately, then we
                               we do a pass where we replace:
                                  defined names of functor by instantiations
                                  parameter by actual names in arguments.
                            -}
                          }

  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


-- | Try to make progress on all instantiations.
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


-- | Try to resolve the "normal" module with the given name.
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

-- | Process all submodules of a module.
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 } }



-- | All steps involved in processing a module.
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