module Cryptol.ModuleSystem.NamingEnv where
import Cryptol.ModuleSystem.Interface
import Cryptol.ModuleSystem.Name
import Cryptol.Parser.AST
import Cryptol.Parser.Position
import Cryptol.Utils.PP
import Cryptol.Utils.Panic (panic)
import Data.List (nub)
import Data.Maybe (catMaybes,fromMaybe)
import qualified Data.Map as Map
import qualified Data.Set as Set
import GHC.Generics (Generic)
import Control.DeepSeq.Generics
import Prelude ()
import Prelude.Compat
data NamingEnv = NamingEnv { neExprs :: Map.Map PName [Name]
, neTypes :: Map.Map PName [Name]
, neFixity:: Map.Map Name Fixity
} deriving (Show, Generic)
instance NFData NamingEnv where rnf = genericRnf
instance Monoid NamingEnv where
mempty =
NamingEnv { neExprs = Map.empty
, neTypes = Map.empty
, neFixity = Map.empty }
mappend l r =
NamingEnv { neExprs = Map.unionWith merge (neExprs l) (neExprs r)
, neTypes = Map.unionWith merge (neTypes l) (neTypes r)
, neFixity = Map.union (neFixity l) (neFixity r) }
mconcat envs =
NamingEnv { neExprs = Map.unionsWith merge (map neExprs envs)
, neTypes = Map.unionsWith merge (map neTypes envs)
, neFixity = Map.unions (map neFixity envs) }
merge :: [Name] -> [Name] -> [Name]
merge xs ys | xs == ys = xs
| otherwise = nub (xs ++ ys)
toPrimMap :: NamingEnv -> PrimMap
toPrimMap NamingEnv { .. } = PrimMap { .. }
where
primDecls = Map.fromList [ (nameIdent n,n) | ns <- Map.elems neExprs
, n <- ns ]
primTypes = Map.fromList [ (nameIdent n,n) | ns <- Map.elems neTypes
, n <- ns ]
toNameDisp :: NamingEnv -> NameDisp
toNameDisp NamingEnv { .. } = NameDisp display
where
display mn ident = Map.lookup (mn,ident) names
names = Map.fromList
$ [ mkEntry pn mn (nameIdent n) | (pn,ns) <- Map.toList neExprs
, n <- ns
, Declared mn <- [nameInfo n] ]
++ [ mkEntry pn mn (nameIdent n) | (pn,ns) <- Map.toList neTypes
, n <- ns
, Declared mn <- [nameInfo n] ]
mkEntry pn mn i = ((mn,i),fmt)
where
fmt = case getModName pn of
Just ns -> Qualified ns
Nothing -> UnQualified
visibleNames :: NamingEnv -> ( Set.Set Name
, Set.Set Name)
visibleNames NamingEnv { .. } = (types,decls)
where
types = Set.fromList [ n | [n] <- Map.elems neTypes ]
decls = Set.fromList [ n | [n] <- Map.elems neExprs ]
qualify :: ModName -> NamingEnv -> NamingEnv
qualify pfx NamingEnv { .. } =
NamingEnv { neExprs = Map.mapKeys toQual neExprs
, neTypes = Map.mapKeys toQual neTypes
, .. }
where
toQual (Qual _ n) = Qual pfx n
toQual (UnQual n) = Qual pfx n
toQual n@NewName{} = n
filterNames :: (PName -> Bool) -> NamingEnv -> NamingEnv
filterNames p NamingEnv { .. } =
NamingEnv { neExprs = Map.filterWithKey check neExprs
, neTypes = Map.filterWithKey check neTypes
, .. }
where
check :: PName -> a -> Bool
check n _ = p n
singletonT :: PName -> Name -> NamingEnv
singletonT qn tn = mempty { neTypes = Map.singleton qn [tn] }
singletonE :: PName -> Name -> NamingEnv
singletonE qn en = mempty { neExprs = Map.singleton qn [en] }
shadowing :: NamingEnv -> NamingEnv -> NamingEnv
shadowing l r = NamingEnv
{ neExprs = Map.union (neExprs l) (neExprs r)
, neTypes = Map.union (neTypes l) (neTypes r)
, neFixity = Map.union (neFixity l) (neFixity r) }
travNamingEnv :: Applicative f => (Name -> f Name) -> NamingEnv -> f NamingEnv
travNamingEnv f ne = NamingEnv <$> neExprs' <*> neTypes' <*> pure (neFixity ne)
where
neExprs' = traverse (traverse f) (neExprs ne)
neTypes' = traverse (traverse f) (neTypes ne)
data InModule a = InModule !ModName a
deriving (Functor,Traversable,Foldable,Show)
namingEnv' :: BindsNames a => a -> Supply -> (NamingEnv,Supply)
namingEnv' a supply = runSupplyM supply (namingEnv a)
class BindsNames a where
namingEnv :: a -> SupplyM NamingEnv
instance BindsNames NamingEnv where
namingEnv = return
instance BindsNames a => BindsNames (Maybe a) where
namingEnv = foldMap namingEnv
instance BindsNames a => BindsNames [a] where
namingEnv = foldMap namingEnv
instance BindsNames (Schema PName) where
namingEnv (Forall ps _ _ _) = foldMap namingEnv ps
interpImport :: Import -> IfaceDecls -> NamingEnv
interpImport imp publicDecls = qualified
where
qualified | Just pfx <- iAs imp = qualify pfx restricted
| otherwise = restricted
restricted
| Just (Hiding ns) <- iSpec imp =
filterNames (\qn -> not (getIdent qn `elem` ns)) public
| Just (Only ns) <- iSpec imp =
filterNames (\qn -> getIdent qn `elem` ns) public
| otherwise = public
public = unqualifiedEnv publicDecls
unqualifiedEnv :: IfaceDecls -> NamingEnv
unqualifiedEnv IfaceDecls { .. } =
mconcat [ exprs, tySyns, ntTypes, ntExprs
, mempty { neFixity = Map.fromList fixity } ]
where
toPName n = mkUnqual (nameIdent n)
exprs = mconcat [ singletonE (toPName n) n | n <- Map.keys ifDecls ]
tySyns = mconcat [ singletonT (toPName n) n | n <- Map.keys ifTySyns ]
ntTypes = mconcat [ singletonT (toPName n) n | n <- Map.keys ifNewtypes ]
ntExprs = mconcat [ singletonE (toPName n) n | n <- Map.keys ifNewtypes ]
fixity =
catMaybes [ do f <- ifDeclFixity d; return (ifDeclName d,f)
| d <- Map.elems ifDecls ]
data ImportIface = ImportIface Import Iface
instance BindsNames ImportIface where
namingEnv (ImportIface imp Iface { .. }) =
return (interpImport imp ifPublic)
instance BindsNames (InModule (Bind PName)) where
namingEnv (InModule ns b) =
do let Located { .. } = bName b
n <- liftSupply (mkDeclared ns (getIdent thing) srcRange)
let fixity = case bFixity b of
Just f -> mempty { neFixity = Map.singleton n f }
Nothing -> mempty
return (singletonE thing n `mappend` fixity)
instance BindsNames (TParam PName) where
namingEnv TParam { .. } =
do let range = fromMaybe emptyRange tpRange
n <- liftSupply (mkParameter (getIdent tpName) range)
return (singletonT tpName n)
instance BindsNames (Module PName) where
namingEnv Module { .. } = foldMap (namingEnv . InModule ns) mDecls
where
ns = thing mName
instance BindsNames (InModule (TopDecl PName)) where
namingEnv (InModule ns td) =
case td of
Decl d -> namingEnv (InModule ns (tlValue d))
TDNewtype d -> namingEnv (InModule ns (tlValue d))
Include _ -> return mempty
instance BindsNames (InModule (Newtype PName)) where
namingEnv (InModule ns Newtype { .. }) =
do let Located { .. } = nName
tyName <- liftSupply (mkDeclared ns (getIdent thing) srcRange)
eName <- liftSupply (mkDeclared ns (getIdent thing) srcRange)
return (singletonT thing tyName `mappend` singletonE thing eName)
instance BindsNames (InModule (Decl PName)) where
namingEnv (InModule pfx d) = case d of
DBind b ->
do n <- mkName (bName b)
return (singletonE (thing (bName b)) n `mappend` fixity n b)
DSignature ns _sig -> foldMap qualBind ns
DPragma ns _p -> foldMap qualBind ns
DType (TySyn lqn _ _) -> qualType lqn
DLocated d' _ -> namingEnv (InModule pfx d')
DPatBind _pat _e -> panic "ModuleSystem" ["Unexpected pattern binding"]
DFixity{} -> panic "ModuleSystem" ["Unexpected fixity declaration"]
where
mkName ln =
liftSupply (mkDeclared pfx (getIdent (thing ln)) (srcRange ln))
qualBind ln =
do n <- mkName ln
return (singletonE (thing ln) n)
qualType ln =
do n <- mkName ln
return (singletonT (thing ln) n)
fixity n b =
case bFixity b of
Just f -> mempty { neFixity = Map.singleton n f }
Nothing -> mempty