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