1-- | 2-- Module : Cryptol.ModuleSystem.NamingEnv 3-- Copyright : (c) 2013-2016 Galois, Inc. 4-- License : BSD3 5-- Maintainer : cryptol@galois.com 6-- Stability : provisional 7-- Portability : portable 8 9{-# LANGUAGE DeriveAnyClass #-} 10{-# LANGUAGE DeriveFoldable #-} 11{-# LANGUAGE DeriveFunctor #-} 12{-# LANGUAGE DeriveGeneric #-} 13{-# LANGUAGE DeriveTraversable #-} 14{-# LANGUAGE FlexibleContexts #-} 15{-# LANGUAGE FlexibleInstances #-} 16{-# LANGUAGE PatternGuards #-} 17{-# LANGUAGE RecordWildCards #-} 18module Cryptol.ModuleSystem.NamingEnv where 19 20import Cryptol.ModuleSystem.Interface 21import Cryptol.ModuleSystem.Name 22import Cryptol.Parser.AST 23import Cryptol.Parser.Name(isGeneratedName) 24import Cryptol.Parser.Position 25import qualified Cryptol.TypeCheck.AST as T 26import Cryptol.Utils.PP 27import Cryptol.Utils.Panic (panic) 28 29import Data.List (nub) 30import Data.Maybe (fromMaybe) 31import qualified Data.Map.Strict as Map 32import qualified Data.Set as Set 33import Data.Semigroup 34import MonadLib (runId,Id) 35 36import GHC.Generics (Generic) 37import Control.DeepSeq 38 39import Prelude () 40import Prelude.Compat 41 42 43-- Naming Environment ---------------------------------------------------------- 44 45-- | The 'NamingEnv' is used by the renamer to determine what 46-- identifiers refer to. 47data NamingEnv = NamingEnv { neExprs :: !(Map.Map PName [Name]) 48 -- ^ Expr renaming environment 49 , neTypes :: !(Map.Map PName [Name]) 50 -- ^ Type renaming environment 51 } deriving (Show, Generic, NFData) 52 53-- | Return a list of value-level names to which this parsed name may refer. 54lookupValNames :: PName -> NamingEnv -> [Name] 55lookupValNames qn ro = Map.findWithDefault [] qn (neExprs ro) 56 57-- | Return a list of type-level names to which this parsed name may refer. 58lookupTypeNames :: PName -> NamingEnv -> [Name] 59lookupTypeNames qn ro = Map.findWithDefault [] qn (neTypes ro) 60 61 62 63instance Semigroup NamingEnv where 64 l <> r = 65 NamingEnv { neExprs = Map.unionWith merge (neExprs l) (neExprs r) 66 , neTypes = Map.unionWith merge (neTypes l) (neTypes r) } 67 68instance Monoid NamingEnv where 69 mempty = 70 NamingEnv { neExprs = Map.empty 71 , neTypes = Map.empty } 72 73 mappend l r = l <> r 74 75 mconcat envs = 76 NamingEnv { neExprs = Map.unionsWith merge (map neExprs envs) 77 , neTypes = Map.unionsWith merge (map neTypes envs) } 78 79 {-# INLINE mempty #-} 80 {-# INLINE mappend #-} 81 {-# INLINE mconcat #-} 82 83 84-- | Merge two name maps, collapsing cases where the entries are the same, and 85-- producing conflicts otherwise. 86merge :: [Name] -> [Name] -> [Name] 87merge xs ys | xs == ys = xs 88 | otherwise = nub (xs ++ ys) 89 90-- | Generate a mapping from 'PrimIdent' to 'Name' for a 91-- given naming environment. 92toPrimMap :: NamingEnv -> PrimMap 93toPrimMap NamingEnv { .. } = PrimMap { .. } 94 where 95 entry n = case asPrim n of 96 Just p -> (p,n) 97 Nothing -> panic "toPrimMap" [ "Not a declared name?" 98 , show n 99 ] 100 101 primDecls = Map.fromList [ entry n | ns <- Map.elems neExprs, n <- ns ] 102 primTypes = Map.fromList [ entry n | ns <- Map.elems neTypes, n <- ns ] 103 104-- | Generate a display format based on a naming environment. 105toNameDisp :: NamingEnv -> NameDisp 106toNameDisp NamingEnv { .. } = NameDisp display 107 where 108 display mn ident = Map.lookup (mn,ident) names 109 110 -- only format declared names, as parameters don't need any special 111 -- formatting. 112 names = Map.fromList 113 $ [ mkEntry (mn, nameIdent n) pn | (pn,ns) <- Map.toList neExprs 114 , n <- ns 115 , Declared mn _ <- [nameInfo n] ] 116 117 ++ [ mkEntry (mn, nameIdent n) pn | (pn,ns) <- Map.toList neTypes 118 , n <- ns 119 , Declared mn _ <- [nameInfo n] ] 120 121 mkEntry key pn = (key,fmt) 122 where fmt = case getModName pn of 123 Just ns -> Qualified ns 124 Nothing -> UnQualified 125 126 127-- | Produce sets of visible names for types and declarations. 128-- 129-- NOTE: if entries in the NamingEnv would have produced a name clash, they will 130-- be omitted from the resulting sets. 131visibleNames :: NamingEnv -> ({- types -} Set.Set Name 132 ,{- decls -} Set.Set Name) 133 134visibleNames NamingEnv { .. } = (types,decls) 135 where 136 types = Set.fromList [ n | [n] <- Map.elems neTypes ] 137 decls = Set.fromList [ n | [n] <- Map.elems neExprs ] 138 139-- | Qualify all symbols in a 'NamingEnv' with the given prefix. 140qualify :: ModName -> NamingEnv -> NamingEnv 141qualify pfx NamingEnv { .. } = 142 NamingEnv { neExprs = Map.mapKeys toQual neExprs 143 , neTypes = Map.mapKeys toQual neTypes 144 } 145 146 where 147 -- XXX we don't currently qualify fresh names 148 toQual (Qual _ n) = Qual pfx n 149 toQual (UnQual n) = Qual pfx n 150 toQual n@NewName{} = n 151 152filterNames :: (PName -> Bool) -> NamingEnv -> NamingEnv 153filterNames p NamingEnv { .. } = 154 NamingEnv { neExprs = Map.filterWithKey check neExprs 155 , neTypes = Map.filterWithKey check neTypes 156 } 157 where 158 check :: PName -> a -> Bool 159 check n _ = p n 160 161 162-- | Singleton type renaming environment. 163singletonT :: PName -> Name -> NamingEnv 164singletonT qn tn = mempty { neTypes = Map.singleton qn [tn] } 165 166-- | Singleton expression renaming environment. 167singletonE :: PName -> Name -> NamingEnv 168singletonE qn en = mempty { neExprs = Map.singleton qn [en] } 169 170-- | Like mappend, but when merging, prefer values on the lhs. 171shadowing :: NamingEnv -> NamingEnv -> NamingEnv 172shadowing l r = NamingEnv 173 { neExprs = Map.union (neExprs l) (neExprs r) 174 , neTypes = Map.union (neTypes l) (neTypes r) } 175 176travNamingEnv :: Applicative f => (Name -> f Name) -> NamingEnv -> f NamingEnv 177travNamingEnv f ne = NamingEnv <$> neExprs' <*> neTypes' 178 where 179 neExprs' = traverse (traverse f) (neExprs ne) 180 neTypes' = traverse (traverse f) (neTypes ne) 181 182 183data InModule a = InModule !ModName a 184 deriving (Functor,Traversable,Foldable,Show) 185 186 187-- | Generate a 'NamingEnv' using an explicit supply. 188namingEnv' :: BindsNames a => a -> Supply -> (NamingEnv,Supply) 189namingEnv' a supply = runId (runSupplyT supply (runBuild (namingEnv a))) 190 191newTop :: FreshM m => ModName -> PName -> Maybe Fixity -> Range -> m Name 192newTop ns thing fx rng = liftSupply (mkDeclared ns src (getIdent thing) fx rng) 193 where src = if isGeneratedName thing then SystemName else UserName 194 195newLocal :: FreshM m => PName -> Range -> m Name 196newLocal thing rng = liftSupply (mkParameter (getIdent thing) rng) 197 198newtype BuildNamingEnv = BuildNamingEnv { runBuild :: SupplyT Id NamingEnv } 199 200instance Semigroup BuildNamingEnv where 201 BuildNamingEnv a <> BuildNamingEnv b = BuildNamingEnv $ 202 do x <- a 203 y <- b 204 return (mappend x y) 205 206instance Monoid BuildNamingEnv where 207 mempty = BuildNamingEnv (pure mempty) 208 209 mappend = (<>) 210 211 mconcat bs = BuildNamingEnv $ 212 do ns <- sequence (map runBuild bs) 213 return (mconcat ns) 214 215-- | Things that define exported names. 216class BindsNames a where 217 namingEnv :: a -> BuildNamingEnv 218 219instance BindsNames NamingEnv where 220 namingEnv env = BuildNamingEnv (return env) 221 {-# INLINE namingEnv #-} 222 223instance BindsNames a => BindsNames (Maybe a) where 224 namingEnv = foldMap namingEnv 225 {-# INLINE namingEnv #-} 226 227instance BindsNames a => BindsNames [a] where 228 namingEnv = foldMap namingEnv 229 {-# INLINE namingEnv #-} 230 231-- | Generate a type renaming environment from the parameters that are bound by 232-- this schema. 233instance BindsNames (Schema PName) where 234 namingEnv (Forall ps _ _ _) = foldMap namingEnv ps 235 {-# INLINE namingEnv #-} 236 237 238-- | Interpret an import in the context of an interface, to produce a name 239-- environment for the renamer, and a 'NameDisp' for pretty-printing. 240interpImport :: Import {- ^ The import declarations -} -> 241 IfaceDecls {- ^ Declarations of imported module -} -> 242 NamingEnv 243interpImport imp publicDecls = qualified 244 where 245 246 -- optionally qualify names based on the import 247 qualified | Just pfx <- iAs imp = qualify pfx restricted 248 | otherwise = restricted 249 250 -- restrict or hide imported symbols 251 restricted 252 | Just (Hiding ns) <- iSpec imp = 253 filterNames (\qn -> not (getIdent qn `elem` ns)) public 254 255 | Just (Only ns) <- iSpec imp = 256 filterNames (\qn -> getIdent qn `elem` ns) public 257 258 | otherwise = public 259 260 -- generate the initial environment from the public interface, where no names 261 -- are qualified 262 public = unqualifiedEnv publicDecls 263 264 265-- | Generate a naming environment from a declaration interface, where none of 266-- the names are qualified. 267unqualifiedEnv :: IfaceDecls -> NamingEnv 268unqualifiedEnv IfaceDecls { .. } = 269 mconcat [ exprs, tySyns, ntTypes, absTys, ntExprs ] 270 where 271 toPName n = mkUnqual (nameIdent n) 272 273 exprs = mconcat [ singletonE (toPName n) n | n <- Map.keys ifDecls ] 274 tySyns = mconcat [ singletonT (toPName n) n | n <- Map.keys ifTySyns ] 275 ntTypes = mconcat [ singletonT (toPName n) n | n <- Map.keys ifNewtypes ] 276 absTys = mconcat [ singletonT (toPName n) n | n <- Map.keys ifAbstractTypes ] 277 ntExprs = mconcat [ singletonE (toPName n) n | n <- Map.keys ifNewtypes ] 278 279 280-- | Compute an unqualified naming environment, containing the various module 281-- parameters. 282modParamsNamingEnv :: IfaceParams -> NamingEnv 283modParamsNamingEnv IfaceParams { .. } = 284 NamingEnv { neExprs = Map.fromList $ map fromFu $ Map.keys ifParamFuns 285 , neTypes = Map.fromList $ map fromTy $ Map.elems ifParamTypes 286 } 287 288 where 289 toPName n = mkUnqual (nameIdent n) 290 291 fromTy tp = let nm = T.mtpName tp 292 in (toPName nm, [nm]) 293 294 fromFu f = (toPName f, [f]) 295 296 297 298data ImportIface = ImportIface Import Iface 299 300-- | Produce a naming environment from an interface file, that contains a 301-- mapping only from unqualified names to qualified ones. 302instance BindsNames ImportIface where 303 namingEnv (ImportIface imp Iface { .. }) = BuildNamingEnv $ 304 return (interpImport imp ifPublic) 305 {-# INLINE namingEnv #-} 306 307-- | Introduce the name 308instance BindsNames (InModule (Bind PName)) where 309 namingEnv (InModule ns b) = BuildNamingEnv $ 310 do let Located { .. } = bName b 311 n <- newTop ns thing (bFixity b) srcRange 312 313 return (singletonE thing n) 314 315-- | Generate the naming environment for a type parameter. 316instance BindsNames (TParam PName) where 317 namingEnv TParam { .. } = BuildNamingEnv $ 318 do let range = fromMaybe emptyRange tpRange 319 n <- newLocal tpName range 320 return (singletonT tpName n) 321 322-- | The naming environment for a single module. This is the mapping from 323-- unqualified names to fully qualified names with uniques. 324instance BindsNames (Module PName) where 325 namingEnv Module { .. } = foldMap (namingEnv . InModule ns) mDecls 326 where 327 ns = thing mName 328 329instance BindsNames (InModule (TopDecl PName)) where 330 namingEnv (InModule ns td) = 331 case td of 332 Decl d -> namingEnv (InModule ns (tlValue d)) 333 DPrimType d -> namingEnv (InModule ns (tlValue d)) 334 TDNewtype d -> namingEnv (InModule ns (tlValue d)) 335 DParameterType d -> namingEnv (InModule ns d) 336 DParameterConstraint {} -> mempty 337 DParameterFun d -> namingEnv (InModule ns d) 338 Include _ -> mempty 339 340instance BindsNames (InModule (PrimType PName)) where 341 namingEnv (InModule ns PrimType { .. }) = 342 BuildNamingEnv $ 343 do let Located { .. } = primTName 344 nm <- newTop ns thing primTFixity srcRange 345 pure (singletonT thing nm) 346 347instance BindsNames (InModule (ParameterFun PName)) where 348 namingEnv (InModule ns ParameterFun { .. }) = BuildNamingEnv $ 349 do let Located { .. } = pfName 350 ntName <- newTop ns thing pfFixity srcRange 351 return (singletonE thing ntName) 352 353instance BindsNames (InModule (ParameterType PName)) where 354 namingEnv (InModule ns ParameterType { .. }) = BuildNamingEnv $ 355 -- XXX: we don't seem to have a fixity environment at the type level 356 do let Located { .. } = ptName 357 ntName <- newTop ns thing Nothing srcRange 358 return (singletonT thing ntName) 359 360-- NOTE: we use the same name at the type and expression level, as there's only 361-- ever one name introduced in the declaration. The names are only ever used in 362-- different namespaces, so there's no ambiguity. 363instance BindsNames (InModule (Newtype PName)) where 364 namingEnv (InModule ns Newtype { .. }) = BuildNamingEnv $ 365 do let Located { .. } = nName 366 ntName <- newTop ns thing Nothing srcRange 367 return (singletonT thing ntName `mappend` singletonE thing ntName) 368 369-- | The naming environment for a single declaration. 370instance BindsNames (InModule (Decl PName)) where 371 namingEnv (InModule pfx d) = case d of 372 DBind b -> BuildNamingEnv $ 373 do n <- mkName (bName b) (bFixity b) 374 return (singletonE (thing (bName b)) n) 375 376 DSignature ns _sig -> foldMap qualBind ns 377 DPragma ns _p -> foldMap qualBind ns 378 DType syn -> qualType (tsName syn) (tsFixity syn) 379 DProp syn -> qualType (psName syn) (psFixity syn) 380 DLocated d' _ -> namingEnv (InModule pfx d') 381 DPatBind _pat _e -> panic "ModuleSystem" ["Unexpected pattern binding"] 382 DFixity{} -> panic "ModuleSystem" ["Unexpected fixity declaration"] 383 384 where 385 386 mkName ln fx = newTop pfx (thing ln) fx (srcRange ln) 387 388 qualBind ln = BuildNamingEnv $ 389 do n <- mkName ln Nothing 390 return (singletonE (thing ln) n) 391 392 qualType ln f = BuildNamingEnv $ 393 do n <- mkName ln f 394 return (singletonT (thing ln) n) 395