+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-%
-\section[RnBinds4]{Renaming and dependency analysis of bindings}
-
-This module does renaming and dependency analysis on value bindings in
-the abstract syntax. It does {\em not} do cycle-checks on class or
-type-synonym declarations; those cannot be done at this stage because
-they may be affected by renaming (which isn't fully worked out yet).
-
-\begin{code}
-#include "HsVersions.h"
-
-module RnBinds4 (
- rnTopBinds, rnMethodBinds,
- rnBinds,
- FreeVars(..), DefinedVars(..)
- ) where
-
-import Ubiq{-uitous-}
-import RnLoop -- break the RnPass4/RnExpr4/RnBinds4 loops
-
-import HsSyn
-import RdrHsSyn
-import RnHsSyn
-import HsPragmas ( noGenPragmas )
-import RnMonad4
-
--- others:
-import CmdLineOpts ( opt_SigsRequired )
-import Digraph ( stronglyConnComp )
-import ErrUtils ( addErrLoc, addShortErrLocLine )
-import Maybes ( catMaybes )
-import Name ( isUnboundName, Name{-instances-} )
-import Pretty
-import ProtoName ( elemByLocalNames, eqByLocalName, ProtoName{-instances-} )
-import RnExpr4 -- OK to look here; but not the other way 'round
-import UniqSet ( emptyUniqSet, unitUniqSet, mkUniqSet,
- unionUniqSets, unionManyUniqSets,
- elementOfUniqSet, addOneToUniqSet,
- uniqSetToList,
- UniqSet(..)
- )
-import Util ( isIn, removeDups, panic, panic# )
-\end{code}
-
--- ToDo: Put the annotations into the monad, so that they arrive in the proper
--- place and can be used when complaining.
-
-The code tree received by the function @rnBinds@ contains definitions
-in where-clauses which are all apparently mutually recursive, but which may
-not really depend upon each other. For example, in the top level program
-\begin{verbatim}
-f x = y where a = x
- y = x
-\end{verbatim}
-the definitions of @a@ and @y@ do not depend on each other at all.
-Unfortunately, the typechecker cannot always check such definitions.
-\footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive
-definitions. In Proceedings of the International Symposium on Programming,
-Toulouse, pp. 217-39. LNCS 167. Springer Verlag.}
-However, the typechecker usually can check definitions in which only the
-strongly connected components have been collected into recursive bindings.
-This is precisely what the function @rnBinds@ does.
-
-ToDo: deal with case where a single monobinds binds the same variable
-twice.
-
-Sets of variable names are represented as sets explicitly, rather than lists.
-
-\begin{code}
-type DefinedVars = UniqSet Name
-type FreeVars = UniqSet Name
-\end{code}
-
-i.e., binders.
-
-The vertag tag is a unique @Int@; the tags only need to be unique
-within one @MonoBinds@, so that unique-Int plumbing is done explicitly
-(heavy monad machinery not needed).
-
-\begin{code}
-type VertexTag = Int
-type Cycle = [VertexTag]
-type Edge = (VertexTag, VertexTag)
-\end{code}
-
-%************************************************************************
-%* *
-%* naming conventions *
-%* *
-%************************************************************************
-\subsection[name-conventions]{Name conventions}
-
-The basic algorithm involves walking over the tree and returning a tuple
-containing the new tree plus its free variables. Some functions, such
-as those walking polymorphic bindings (HsBinds) and qualifier lists in
-list comprehensions (@Quals@), return the variables bound in local
-environments. These are then used to calculate the free variables of the
-expression evaluated in these environments.
-
-Conventions for variable names are as follows:
-\begin{itemize}
-\item
-new code is given a prime to distinguish it from the old.
-
-\item
-a set of variables defined in @Exp@ is written @dvExp@
-
-\item
-a set of variables free in @Exp@ is written @fvExp@
-\end{itemize}
-
-%************************************************************************
-%* *
-%* analysing polymorphic bindings (HsBinds, Bind, MonoBinds) *
-%* *
-%************************************************************************
-\subsubsection[dep-HsBinds]{Polymorphic bindings}
-
-Non-recursive expressions are reconstructed without any changes at top
-level, although their component expressions may have to be altered.
-However, non-recursive expressions are currently not expected as
-\Haskell{} programs, and this code should not be executed.
-
-Monomorphic bindings contain information that is returned in a tuple
-(a @FlatMonoBindsInfo@) containing:
-
-\begin{enumerate}
-\item
-a unique @Int@ that serves as the ``vertex tag'' for this binding.
-
-\item
-the name of a function or the names in a pattern. These are a set
-referred to as @dvLhs@, the defined variables of the left hand side.
-
-\item
-the free variables of the body. These are referred to as @fvBody@.
-
-\item
-the definition's actual code. This is referred to as just @code@.
-\end{enumerate}
-
-The function @nonRecDvFv@ returns two sets of variables. The first is
-the set of variables defined in the set of monomorphic bindings, while the
-second is the set of free variables in those bindings.
-
-The set of variables defined in a non-recursive binding is just the
-union of all of them, as @union@ removes duplicates. However, the
-free variables in each successive set of cumulative bindings is the
-union of those in the previous set plus those of the newest binding after
-the defined variables of the previous set have been removed.
-
-@rnMethodBinds@ deals only with the declarations in class and
-instance declarations. It expects only to see @FunMonoBind@s, and
-it expects the global environment to contain bindings for the binders
-(which are all class operations).
-
-\begin{code}
-rnTopBinds :: ProtoNameHsBinds -> Rn4M RenamedHsBinds
-rnMethodBinds :: Name{-class-} -> ProtoNameMonoBinds -> Rn4M RenamedMonoBinds
-rnBinds :: ProtoNameHsBinds -> Rn4M (RenamedHsBinds, FreeVars, [Name])
-
-rnTopBinds EmptyBinds = returnRn4 EmptyBinds
-rnTopBinds (SingleBind (RecBind bind)) = rnTopMonoBinds bind []
-rnTopBinds (BindWith (RecBind bind) sigs) = rnTopMonoBinds bind sigs
- -- the parser doesn't produce other forms
-
--- ********************************************************************
-
-rnMethodBinds class_name EmptyMonoBinds = returnRn4 EmptyMonoBinds
-
-rnMethodBinds class_name (AndMonoBinds mb1 mb2)
- = andRn4 AndMonoBinds (rnMethodBinds class_name mb1)
- (rnMethodBinds class_name mb2)
-
-rnMethodBinds class_name (FunMonoBind pname matches locn)
- = pushSrcLocRn4 locn (
- lookupClassOp class_name pname `thenRn4` \ op_name ->
- mapAndUnzipRn4 rnMatch matches `thenRn4` \ (new_matches, _) ->
- returnRn4 (FunMonoBind op_name new_matches locn)
- )
-
-rnMethodBinds class_name (PatMonoBind (VarPatIn pname) grhss_and_binds locn)
- = pushSrcLocRn4 locn (
- lookupClassOp class_name pname `thenRn4` \ op_name ->
- rnGRHSsAndBinds grhss_and_binds `thenRn4` \ (grhss_and_binds', _) ->
- returnRn4 (PatMonoBind (VarPatIn op_name) grhss_and_binds' locn)
- )
-
--- Can't handle method pattern-bindings which bind multiple methods.
-rnMethodBinds _ mbind@(PatMonoBind other_pat _ locn)
- = failButContinueRn4 EmptyMonoBinds (methodBindErr mbind locn)
-
--- ********************************************************************
-
-rnBinds EmptyBinds = returnRn4 (EmptyBinds,emptyUniqSet,[])
-rnBinds (SingleBind (RecBind bind)) = rnNestedMonoBinds bind []
-rnBinds (BindWith (RecBind bind) sigs) = rnNestedMonoBinds bind sigs
- -- the parser doesn't produce other forms
-\end{code}
-
-@rnNestedMonoBinds@
- - collects up the binders for this declaration group,
- - checkes that they form a set
- - extends the environment to bind them to new local names
- - calls @rnMonoBinds@ to do the real work
-
-In contrast, @rnTopMonoBinds@ doesn't extend the environment, because that's
-already done in pass3. All it does is call @rnMonoBinds@ and discards
-the free var info.
-
-\begin{code}
-rnTopMonoBinds :: ProtoNameMonoBinds -> [ProtoNameSig] -> Rn4M RenamedHsBinds
-
-rnTopMonoBinds EmptyMonoBinds sigs = returnRn4 EmptyBinds
-
-rnTopMonoBinds mbs sigs
- = rnBindSigs True{-top-level-} (collectMonoBinders mbs) sigs `thenRn4` \ siglist ->
- rnMonoBinds mbs siglist `thenRn4` \ (new_binds, fv_set) ->
- returnRn4 new_binds
-
-
-rnNestedMonoBinds :: ProtoNameMonoBinds -> [ProtoNameSig]
- -> Rn4M (RenamedHsBinds, FreeVars, [Name])
-
-rnNestedMonoBinds EmptyMonoBinds sigs
- = returnRn4 (EmptyBinds, emptyUniqSet, [])
-
-rnNestedMonoBinds mbinds sigs -- Non-empty monobinds
- =
- -- Extract all the binders in this group,
- -- and extend current scope, inventing new names for the new binders
- -- This also checks that the names form a set
- let
- mbinders_w_srclocs = collectMonoBindersAndLocs mbinds
- mbinders = map fst mbinders_w_srclocs
- in
- namesFromProtoNames
- "variable" -- in binding group
- mbinders_w_srclocs `thenRn4` \ new_mbinders ->
-
- extendSS2 new_mbinders (
- rnBindSigs False{-not top- level-} mbinders sigs `thenRn4` \ siglist ->
- rnMonoBinds mbinds siglist
- ) `thenRn4` \ (new_binds, fv_set) ->
- returnRn4 (new_binds, fv_set, new_mbinders)
-\end{code}
-
-@rnMonoBinds@ is used by *both* top-level and nested bindings. It
-assumes that all variables bound in this group are already in scope.
-This is done *either* by pass 3 (for the top-level bindings),
-*or* by @rnNestedMonoBinds@ (for the nested ones).
-
-\begin{code}
-rnMonoBinds :: ProtoNameMonoBinds
- -> [RenamedSig] -- Signatures attached to this group
- -> Rn4M (RenamedHsBinds, FreeVars)
-
-rnMonoBinds mbinds siglist
- =
- -- Rename the bindings, returning a MonoBindsInfo
- -- which is a list of indivisible vertices so far as
- -- the strongly-connected-components (SCC) analysis is concerned
- flattenMonoBinds 0 siglist mbinds `thenRn4` \ (_, mbinds_info) ->
-
- -- Do the SCC analysis
- let vertices = mkVertices mbinds_info
- edges = mkEdges vertices mbinds_info
-
- scc_result = stronglyConnComp (==) edges vertices
-
- -- Deal with bound and free-var calculation
- rhs_free_vars = foldr f emptyUniqSet mbinds_info
-
- final_binds = reconstructRec scc_result edges mbinds_info
-
- happy_answer = returnRn4 (final_binds, rhs_free_vars)
- in
- case (inline_sigs_in_recursive_binds final_binds) of
- Nothing -> happy_answer
- Just names_n_locns ->
--- SLPJ: sometimes want recursive INLINE for worker wrapper style stuff
--- addErrRn4 (inlineInRecursiveBindsErr names_n_locns) `thenRn4_`
- {-not so-}happy_answer
- where
- f :: (a,b, FreeVars, c,d) -> FreeVars -> FreeVars
-
- f (_, _, fvs_body, _, _) fvs_sofar = fvs_sofar `unionUniqSets` fvs_body
-
- inline_sigs_in_recursive_binds (BindWith (RecBind _) sigs)
- = case [(n, locn) | (InlineSig n locn) <- sigs ] of
- [] -> Nothing
- sigh ->
-#if OMIT_DEFORESTER
- Just sigh
-#else
- -- Allow INLINEd recursive functions if they are
- -- designated DEFORESTable too.
- case [(n, locn) | (DeforestSig n locn) <- sigs ] of
- [] -> Just sigh
- sigh -> Nothing
-#endif
-
- inline_sigs_in_recursive_binds (ThenBinds b1 b2)
- = case (inline_sigs_in_recursive_binds b1) of
- Nothing -> inline_sigs_in_recursive_binds b2
- Just x -> Just x -- NB: won't report error(s) in b2
-
- inline_sigs_in_recursive_binds anything_else = Nothing
-\end{code}
-
-@flattenMonoBinds@ is ever-so-slightly magical in that it sticks
-unique ``vertex tags'' on its output; minor plumbing required.
-
-\begin{code}
-flattenMonoBinds :: Int -- Next free vertex tag
- -> [RenamedSig] -- Signatures
- -> ProtoNameMonoBinds
- -> Rn4M (Int, FlatMonoBindsInfo)
-
-flattenMonoBinds uniq sigs EmptyMonoBinds = returnRn4 (uniq, [])
-
-flattenMonoBinds uniq sigs (AndMonoBinds mB1 mB2)
- = flattenMonoBinds uniq sigs mB1 `thenRn4` \ (uniq1, flat1) ->
- flattenMonoBinds uniq1 sigs mB2 `thenRn4` \ (uniq2, flat2) ->
- returnRn4 (uniq2, flat1 ++ flat2)
-
-flattenMonoBinds uniq sigs (PatMonoBind pat grhss_and_binds locn)
- = pushSrcLocRn4 locn (
- rnPat pat `thenRn4` \ pat' ->
- rnGRHSsAndBinds grhss_and_binds `thenRn4` \ (grhss_and_binds', fvs) ->
-
- -- Find which things are bound in this group
- let
- names_bound_here = collectPatBinders pat'
-
- sigs_etc_for_here = foldl (sig_for_here (\ n -> n `is_elem` names_bound_here))
- [] sigs
-
- sigs_fvs = foldr sig_fv emptyUniqSet sigs_etc_for_here
-
- is_elem = isIn "flattenMonoBinds"
- in
- returnRn4 (
- uniq + 1,
- [(uniq,
- mkUniqSet names_bound_here,
- fvs `unionUniqSets` sigs_fvs,
- PatMonoBind pat' grhss_and_binds' locn,
- sigs_etc_for_here
- )]
- ))
-
-flattenMonoBinds uniq sigs (FunMonoBind name matches locn)
- = pushSrcLocRn4 locn (
- lookupValue name `thenRn4` \ name' ->
- mapAndUnzipRn4 rnMatch matches `thenRn4` \ (new_matches, fv_lists) ->
- let
- fvs = unionManyUniqSets fv_lists
-
- sigs_for_me = foldl (sig_for_here (\ n -> n == name')) [] sigs
-
- sigs_fvs = foldr sig_fv emptyUniqSet sigs_for_me
- in
- returnRn4 (
- uniq + 1,
- [(uniq,
- unitUniqSet name',
- fvs `unionUniqSets` sigs_fvs,
- FunMonoBind name' new_matches locn,
- sigs_for_me
- )]
- ))
-\end{code}
-
-Grab type-signatures/user-pragmas of interest:
-\begin{code}
-sig_for_here want_me acc s@(Sig n _ _ _) | want_me n = s:acc
-sig_for_here want_me acc s@(InlineSig n _) | want_me n = s:acc
-sig_for_here want_me acc s@(DeforestSig n _) | want_me n = s:acc
-sig_for_here want_me acc s@(SpecSig n _ _ _) | want_me n = s:acc
-sig_for_here want_me acc s@(MagicUnfoldingSig n _ _)
- | want_me n = s:acc
-sig_for_here want_me acc other_wise = acc
-
--- If a SPECIALIZE pragma is of the "... = blah" form,
--- then we'd better make sure "blah" is taken into
--- acct in the dependency analysis (or we get an
--- unexpected out-of-scope error)! WDP 95/07
-
-sig_fv (SpecSig _ _ (Just blah) _) acc = addOneToUniqSet acc blah
-sig_fv _ acc = acc
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[reconstruct-deps]{Reconstructing dependencies}
-%* *
-%************************************************************************
-
-This @MonoBinds@- and @ClassDecls@-specific code is segregated here,
-as the two cases are similar.
-
-\begin{code}
-reconstructRec :: [Cycle] -- Result of SCC analysis; at least one
- -> [Edge] -- Original edges
- -> FlatMonoBindsInfo
- -> RenamedHsBinds
-
-reconstructRec cycles edges mbi
- = foldr1 ThenBinds (map (reconstructCycle mbi) cycles)
- where
- reconstructCycle :: FlatMonoBindsInfo -> Cycle -> RenamedHsBinds
-
- reconstructCycle mbi2 cycle
- = BIND [(binds,sigs) | (vertex, _, _, binds, sigs) <- mbi2, vertex `is_elem` cycle]
- _TO_ relevant_binds_and_sigs ->
-
- BIND (unzip relevant_binds_and_sigs) _TO_ (binds, sig_lists) ->
-
- BIND (foldr AndMonoBinds EmptyMonoBinds binds) _TO_ this_gp_binds ->
- let
- this_gp_sigs = foldr1 (++) sig_lists
- have_sigs = not (null sig_lists)
- -- ToDo: this might not be the right
- -- thing to call this predicate;
- -- e.g. "have_sigs [[], [], []]" ???????????
- in
- mk_binds this_gp_binds this_gp_sigs (isCyclic edges cycle) have_sigs
- BEND BEND BEND
- where
- is_elem = isIn "reconstructRec"
-
- mk_binds :: RenamedMonoBinds -> [RenamedSig]
- -> Bool -> Bool -> RenamedHsBinds
-
- mk_binds bs ss True False = SingleBind (RecBind bs)
- mk_binds bs ss True True{-have sigs-} = BindWith (RecBind bs) ss
- mk_binds bs ss False False = SingleBind (NonRecBind bs)
- mk_binds bs ss False True{-have sigs-} = BindWith (NonRecBind bs) ss
-
- -- moved from Digraph, as this is the only use here
- -- (avoid overloading cost). We have to use elem
- -- (not FiniteMaps or whatever), because there may be
- -- many edges out of one vertex. We give it its own
- -- "elem" just for speed.
-
- isCyclic es [] = panic "isCyclic: empty component"
- isCyclic es [v] = (v,v) `elem` es
- isCyclic es vs = True
-
- elem _ [] = False
- elem x (y:ys) = x==y || elem x ys
-\end{code}
-
-%************************************************************************
-%* *
-%* Manipulating FlatMonoBindInfo *
-%* *
-%************************************************************************
-
-During analysis a @MonoBinds@ is flattened to a @FlatMonoBindsInfo@.
-The @RenamedMonoBinds@ is always an empty bind, a pattern binding or
-a function binding, and has itself been dependency-analysed and
-renamed.
-
-\begin{code}
-type FlatMonoBindsInfo
- = [(VertexTag, -- Identifies the vertex
- UniqSet Name, -- Set of names defined in this vertex
- UniqSet Name, -- Set of names used in this vertex
- RenamedMonoBinds, -- Binding for this vertex (always just one binding, either fun or pat)
- [RenamedSig]) -- Signatures, if any, for this vertex
- ]
-
-mkVertices :: FlatMonoBindsInfo -> [VertexTag]
-mkVertices info = [ vertex | (vertex,_,_,_,_) <- info]
-
-mkEdges :: [VertexTag] -> FlatMonoBindsInfo -> [Edge]
-
-mkEdges vertices flat_info
- -- An edge (v,v') indicates that v depends on v'
- = [ (source_vertex, target_vertex)
- | (source_vertex, _, used_names, _, _) <- flat_info,
- target_name <- uniqSetToList used_names,
- target_vertex <- vertices_defining target_name flat_info
- ]
- where
- -- If each name only has one binding in this group, then
- -- vertices_defining will always return the empty list, or a
- -- singleton. The case when there is more than one binding (an
- -- error) needs more thought.
-
- vertices_defining name flat_info2
- = [ vertex | (vertex, names_defined, _, _, _) <- flat_info2,
- name `elementOfUniqSet` names_defined
- ]
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}
-%* *
-%************************************************************************
-
-@rnBindSigs@ checks for: (a)~more than one sig for one thing;
-(b)~signatures given for things not bound here; (c)~with suitably
-flaggery, that all top-level things have type signatures.
-
-\begin{code}
-rnBindSigs :: Bool -- True <=> top-level binders
- -> [ProtoName] -- Binders for this decl group
- -> [ProtoNameSig]
- -> Rn4M [RenamedSig] -- List of Sig constructors
-
-rnBindSigs is_toplev binder_pnames sigs
- =
- -- Rename the signatures
- -- Will complain about sigs for variables not in this group
- mapRn4 rename_sig sigs `thenRn4` \ sigs_maybe ->
- let
- sigs' = catMaybes sigs_maybe
-
- -- Discard unbound ones we've already complained about, so we
- -- complain about duplicate ones.
-
- (goodies, dups) = removeDups compare (filter not_unbound sigs')
- in
- mapRn4 (addErrRn4 . dupSigDeclErr) dups `thenRn4_`
-
- getSrcLocRn4 `thenRn4` \ locn ->
-
- (if (is_toplev && opt_SigsRequired) then
- let
- sig_frees = catMaybes (map (sig_free sigs) binder_pnames)
- in
- mapRn4 (addErrRn4 . missingSigErr locn) sig_frees
- else
- returnRn4 []
- ) `thenRn4_`
-
- returnRn4 sigs' -- bad ones and all:
- -- we need bindings of *some* sort for every name
- where
- rename_sig (Sig v ty pragma src_loc)
- = pushSrcLocRn4 src_loc (
-
- if not (v `elemByLocalNames` binder_pnames) then
- addErrRn4 (unknownSigDeclErr "type signature" v src_loc) `thenRn4_`
- returnRn4 Nothing
- else
- lookupValue v `thenRn4` \ new_v ->
- rnPolyType False nullTyVarNamesEnv ty `thenRn4` \ new_ty ->
- recoverQuietlyRn4 noGenPragmas (
- rnGenPragmas pragma
- ) `thenRn4` \ new_pragma ->
- returnRn4 (Just (Sig new_v new_ty new_pragma src_loc))
- )
-
- -- and now, the various flavours of value-modifying user-pragmas:
-
- rename_sig (SpecSig v ty using src_loc)
- = pushSrcLocRn4 src_loc (
-
- if not (v `elemByLocalNames` binder_pnames) then
- addErrRn4 (unknownSigDeclErr "SPECIALIZE pragma" v src_loc) `thenRn4_`
- returnRn4 Nothing
- else
- lookupValue v `thenRn4` \ new_v ->
- rnPolyType False nullTyVarNamesEnv ty `thenRn4` \ new_ty ->
- rn_using using `thenRn4` \ new_using ->
- returnRn4 (Just (SpecSig new_v new_ty new_using src_loc))
- )
- where
- rn_using Nothing = returnRn4 Nothing
- rn_using (Just x) = lookupValue x `thenRn4` \ new_x ->
- returnRn4 (Just new_x)
-
- rename_sig (InlineSig v src_loc)
- = pushSrcLocRn4 src_loc (
-
- if not (v `elemByLocalNames` binder_pnames) then
- addErrRn4 (unknownSigDeclErr "INLINE pragma" v src_loc) `thenRn4_`
- returnRn4 Nothing
- else
- lookupValue v `thenRn4` \ new_v ->
- returnRn4 (Just (InlineSig new_v src_loc))
- )
-
- rename_sig (DeforestSig v src_loc)
- = pushSrcLocRn4 src_loc (
-
- if not (v `elemByLocalNames` binder_pnames) then
- addErrRn4 (unknownSigDeclErr "DEFOREST pragma" v src_loc) `thenRn4_`
- returnRn4 Nothing
- else
- lookupValue v `thenRn4` \ new_v ->
- returnRn4 (Just (DeforestSig new_v src_loc))
- )
-
- rename_sig (MagicUnfoldingSig v str src_loc)
- = pushSrcLocRn4 src_loc (
-
- if not (v `elemByLocalNames` binder_pnames) then
- addErrRn4 (unknownSigDeclErr "MAGIC_UNFOLDING pragma" v src_loc) `thenRn4_`
- returnRn4 Nothing
- else
- lookupValue v `thenRn4` \ new_v ->
- returnRn4 (Just (MagicUnfoldingSig new_v str src_loc))
- )
-
- not_unbound :: RenamedSig -> Bool
-
- not_unbound (Sig n _ _ _) = not (isUnboundName n)
- not_unbound (SpecSig n _ _ _) = not (isUnboundName n)
- not_unbound (InlineSig n _) = not (isUnboundName n)
- not_unbound (DeforestSig n _) = not (isUnboundName n)
- not_unbound (MagicUnfoldingSig n _ _) = not (isUnboundName n)
-
- -------------------------------------
- sig_free :: [ProtoNameSig] -> ProtoName -> Maybe ProtoName
- -- Return "Just x" if "x" has no type signature in
- -- sigs. Nothing, otherwise.
-
- sig_free [] ny = Just ny
- sig_free (Sig nx _ _ _ : rest) ny
- = if (nx `eqByLocalName` ny) then Nothing else sig_free rest ny
- sig_free (_ : rest) ny = sig_free rest ny
-
- -------------------------------------
- compare :: RenamedSig -> RenamedSig -> TAG_
- compare x y = c x y
-
- c (Sig n1 _ _ _) (Sig n2 _ _ _) = n1 `cmp` n2
- c (InlineSig n1 _) (InlineSig n2 _) = n1 `cmp` n2
- c (MagicUnfoldingSig n1 _ _) (MagicUnfoldingSig n2 _ _) = n1 `cmp` n2
- c (SpecSig n1 ty1 _ _) (SpecSig n2 ty2 _ _)
- = -- may have many specialisations for one value;
- -- but not ones that are exactly the same...
- case (n1 `cmp` n2) of
- EQ_ -> cmpPolyType cmp ty1 ty2
- other -> other
-
- c other_1 other_2 -- tags *must* be different
- = let tag1 = tag other_1
- tag2 = tag other_2
- in
- if tag1 _LT_ tag2 then LT_ else GT_
-
- tag (Sig n1 _ _ _) = (ILIT(1) :: FAST_INT)
- tag (SpecSig n1 _ _ _) = ILIT(2)
- tag (InlineSig n1 _) = ILIT(3)
- tag (MagicUnfoldingSig n1 _ _) = ILIT(4)
- tag (DeforestSig n1 _) = ILIT(5)
- tag _ = panic# "tag(RnBinds4)"
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Error messages}
-%* *
-%************************************************************************
-
-\begin{code}
-dupSigDeclErr sigs
- = let
- undup_sigs = fst (removeDups cmp_sig sigs)
- in
- addErrLoc locn1
- ("more than one "++what_it_is++"\n\thas been given for these variables") ( \ sty ->
- ppAboves (map (ppr sty) undup_sigs) )
- where
- (what_it_is, locn1)
- = case (head sigs) of
- Sig _ _ _ loc -> ("type signature",loc)
- ClassOpSig _ _ _ loc -> ("class-method type signature", loc)
- SpecSig _ _ _ loc -> ("SPECIALIZE pragma",loc)
- InlineSig _ loc -> ("INLINE pragma",loc)
- MagicUnfoldingSig _ _ loc -> ("MAGIC_UNFOLDING pragma",loc)
-
- cmp_sig a b = get_name a `cmp` get_name b
-
- get_name (Sig n _ _ _) = n
- get_name (ClassOpSig n _ _ _) = n
- get_name (SpecSig n _ _ _) = n
- get_name (InlineSig n _) = n
- get_name (MagicUnfoldingSig n _ _) = n
-
-------------------------
-methodBindErr mbind locn
- = addErrLoc locn "Can't handle multiple methods defined by one pattern binding"
- (\ sty -> ppr sty mbind)
-
---------------------------
-missingSigErr locn var
- = addShortErrLocLine locn ( \ sty ->
- ppBesides [ppStr "a definition but no type signature for `",
- ppr sty var,
- ppStr "'."])
-
---------------------------------
-unknownSigDeclErr flavor var locn
- = addShortErrLocLine locn ( \ sty ->
- ppBesides [ppStr flavor, ppStr " but no definition for `",
- ppr sty var,
- ppStr "'."])
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-%
-\section[RnExpr4]{Renaming of expressions (pass 4)}
-
-Basically dependency analysis.
-
-Handles @Match@, @GRHSsAndBinds@, @HsExpr@, and @Qual@ datatypes. In
-general, all of these functions return a renamed thing, and a set of
-free variables.
-
-\begin{code}
-#include "HsVersions.h"
-
-module RnExpr4 (
- rnMatch, rnGRHSsAndBinds, rnPat
-
- -- and to make the interface self-sufficient...
- ) where
-
-import Ubiq{-uitous-}
-import RnLoop -- break the RnPass4/RnExpr4/RnBinds4 loops
-
-import HsSyn
-import RdrHsSyn
-import RnHsSyn
-import RnMonad4
-
--- others:
-import Name ( Name(..) )
-import NameTypes ( FullName{-instances-} )
-import Outputable ( isConop )
-import UniqSet ( emptyUniqSet, unitUniqSet,
- unionUniqSets, unionManyUniqSets,
- UniqSet(..)
- )
-import Util ( panic )
-\end{code}
-
-
-*********************************************************
-* *
-\subsection{Patterns}
-* *
-*********************************************************
-
-\begin{code}
-rnPat :: ProtoNamePat -> Rn4M RenamedPat
-
-rnPat WildPatIn = returnRn4 WildPatIn
-
-rnPat (VarPatIn name)
- = lookupValue name `thenRn4` \ vname ->
- returnRn4 (VarPatIn vname)
-
-rnPat (LitPatIn n) = returnRn4 (LitPatIn n)
-
-rnPat (LazyPatIn pat)
- = rnPat pat `thenRn4` \ pat' ->
- returnRn4 (LazyPatIn pat')
-
-rnPat (AsPatIn name pat)
- = rnPat pat `thenRn4` \ pat' ->
- lookupValue name `thenRn4` \ vname ->
- returnRn4 (AsPatIn vname pat')
-
-rnPat (ConPatIn name pats)
- = lookupValue name `thenRn4` \ name' ->
- mapRn4 rnPat pats `thenRn4` \ patslist ->
- returnRn4 (ConPatIn name' patslist)
-
-rnPat (ConOpPatIn pat1 name pat2)
- = lookupValue name `thenRn4` \ name' ->
- rnPat pat1 `thenRn4` \ pat1' ->
- rnPat pat2 `thenRn4` \ pat2' ->
- returnRn4 (ConOpPatIn pat1' name' pat2')
-
-rnPat (ListPatIn pats)
- = mapRn4 rnPat pats `thenRn4` \ patslist ->
- returnRn4 (ListPatIn patslist)
-
-rnPat (TuplePatIn pats)
- = mapRn4 rnPat pats `thenRn4` \ patslist ->
- returnRn4 (TuplePatIn patslist)
-
-rnPat (RecPatIn con rpats)
- = panic "rnPat:RecPatIn"
-
-\end{code}
-
-************************************************************************
-* *
-\subsection{Match}
-* *
-************************************************************************
-
-\begin{code}
-rnMatch :: ProtoNameMatch -> Rn4M (RenamedMatch, FreeVars)
-
-rnMatch match
- = getSrcLocRn4 `thenRn4` \ src_loc ->
- namesFromProtoNames "variable in pattern"
- (binders `zip` repeat src_loc) `thenRn4` \ new_binders ->
- extendSS2 new_binders (rnMatch_aux match)
- where
- binders = collect_binders match
-
- collect_binders :: ProtoNameMatch -> [ProtoName]
-
- collect_binders (GRHSMatch _) = []
- collect_binders (PatMatch pat match)
- = collectPatBinders pat ++ collect_binders match
-
-rnMatch_aux (PatMatch pat match)
- = rnPat pat `thenRn4` \ pat' ->
- rnMatch_aux match `thenRn4` \ (match', fvMatch) ->
- returnRn4 (PatMatch pat' match', fvMatch)
-
-rnMatch_aux (GRHSMatch grhss_and_binds)
- = rnGRHSsAndBinds grhss_and_binds `thenRn4` \ (grhss_and_binds', fvs) ->
- returnRn4 (GRHSMatch grhss_and_binds', fvs)
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{Guarded right-hand sides (GRHSsAndBinds)}
-%* *
-%************************************************************************
-
-\begin{code}
-rnGRHSsAndBinds :: ProtoNameGRHSsAndBinds -> Rn4M (RenamedGRHSsAndBinds, FreeVars)
-
-rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds)
- = rnBinds binds `thenRn4` \ (binds', fvBinds, scope) ->
- extendSS2 scope (rnGRHSs grhss) `thenRn4` \ (grhss', fvGRHS) ->
- returnRn4 (GRHSsAndBindsIn grhss' binds', fvBinds `unionUniqSets` fvGRHS)
- where
- rnGRHSs [] = returnRn4 ([], emptyUniqSet)
-
- rnGRHSs (grhs:grhss)
- = rnGRHS grhs `thenRn4` \ (grhs', fvs) ->
- rnGRHSs grhss `thenRn4` \ (grhss', fvss) ->
- returnRn4 (grhs' : grhss', fvs `unionUniqSets` fvss)
-
- rnGRHS (GRHS guard expr locn)
- = pushSrcLocRn4 locn (
- rnExpr guard `thenRn4` \ (guard', fvsg) ->
- rnExpr expr `thenRn4` \ (expr', fvse) ->
- returnRn4 (GRHS guard' expr' locn, fvsg `unionUniqSets` fvse)
- )
-
- rnGRHS (OtherwiseGRHS expr locn)
- = pushSrcLocRn4 locn (
- rnExpr expr `thenRn4` \ (expr', fvs) ->
- returnRn4 (OtherwiseGRHS expr' locn, fvs)
- )
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{Expressions}
-%* *
-%************************************************************************
-
-\begin{code}
-rnExprs :: [ProtoNameHsExpr] -> Rn4M ([RenamedHsExpr], FreeVars)
-
-rnExprs [] = returnRn4 ([], emptyUniqSet)
-
-rnExprs (expr:exprs)
- = rnExpr expr `thenRn4` \ (expr', fvExpr) ->
- rnExprs exprs `thenRn4` \ (exprs', fvExprs) ->
- returnRn4 (expr':exprs', fvExpr `unionUniqSets` fvExprs)
-\end{code}
-
-Variables. We look up the variable and return the resulting name. The
-interesting question is what the free-variable set should be. We
-don't want to return imported or prelude things as free vars. So we
-look at the Name returned from the lookup, and make it part of the
-free-var set iff:
-\begin{itemize}
-\item
-if it's a @Short@,
-\item
-or it's an @ValName@ and it's defined in this module
-(this includes locally-defined constructrs, but that's too bad)
-\end{itemize}
-
-\begin{code}
-rnExpr :: ProtoNameHsExpr -> Rn4M (RenamedHsExpr, FreeVars)
-
-rnExpr (HsVar v)
- = lookupValue v `thenRn4` \ vname ->
- returnRn4 (HsVar vname, fv_set vname)
- where
- fv_set n@(Short uniq sname) = unitUniqSet n
- fv_set n@(ValName uniq fname)
- | isLocallyDefined fname
- && not (isConop (getOccurrenceName fname))
- = unitUniqSet n
- fv_set other = emptyUniqSet
-
-rnExpr (HsLit lit) = returnRn4 (HsLit lit, emptyUniqSet)
-
-rnExpr (HsLam match)
- = rnMatch match `thenRn4` \ (match', fvMatch) ->
- returnRn4 (HsLam match', fvMatch)
-
-rnExpr (HsApp fun arg)
- = rnExpr fun `thenRn4` \ (fun',fvFun) ->
- rnExpr arg `thenRn4` \ (arg',fvArg) ->
- returnRn4 (HsApp fun' arg', fvFun `unionUniqSets` fvArg)
-
-rnExpr (OpApp e1 op e2)
- = rnExpr e1 `thenRn4` \ (e1', fvs_e1) ->
- rnExpr op `thenRn4` \ (op', fvs_op) ->
- rnExpr e2 `thenRn4` \ (e2', fvs_e2) ->
- returnRn4 (OpApp e1' op' e2', (fvs_op `unionUniqSets` fvs_e1) `unionUniqSets` fvs_e2)
-
-rnExpr (SectionL expr op)
- = rnExpr expr `thenRn4` \ (expr', fvs_expr) ->
- rnExpr op `thenRn4` \ (op', fvs_op) ->
- returnRn4 (SectionL expr' op', fvs_op `unionUniqSets` fvs_expr)
-
-rnExpr (SectionR op expr)
- = rnExpr op `thenRn4` \ (op', fvs_op) ->
- rnExpr expr `thenRn4` \ (expr', fvs_expr) ->
- returnRn4 (SectionR op' expr', fvs_op `unionUniqSets` fvs_expr)
-
-rnExpr (CCall fun args may_gc is_casm fake_result_ty)
- = rnExprs args `thenRn4` \ (args', fvs_args) ->
- returnRn4 (CCall fun args' may_gc is_casm fake_result_ty, fvs_args)
-
-rnExpr (HsSCC label expr)
- = rnExpr expr `thenRn4` \ (expr', fvs_expr) ->
- returnRn4 (HsSCC label expr', fvs_expr)
-
-rnExpr (HsCase expr ms src_loc)
- = pushSrcLocRn4 src_loc $
- rnExpr expr `thenRn4` \ (new_expr, e_fvs) ->
- mapAndUnzipRn4 rnMatch ms `thenRn4` \ (new_ms, ms_fvs) ->
- returnRn4 (HsCase new_expr new_ms src_loc, unionManyUniqSets (e_fvs : ms_fvs))
-
-rnExpr (HsLet binds expr)
- = rnBinds binds `thenRn4` \ (binds', fvBinds, new_binders) ->
- extendSS2 new_binders (rnExpr expr) `thenRn4` \ (expr',fvExpr) ->
- returnRn4 (HsLet binds' expr', fvBinds `unionUniqSets` fvExpr)
-
-rnExpr (HsDo stmts src_loc)
- = pushSrcLocRn4 src_loc $
- rnStmts stmts `thenRn4` \ (stmts', fvStmts) ->
- returnRn4 (HsDo stmts' src_loc, fvStmts)
-
-rnExpr (ListComp expr quals)
- = rnQuals quals `thenRn4` \ ((quals', qual_binders), fvQuals) ->
- extendSS2 qual_binders (rnExpr expr) `thenRn4` \ (expr', fvExpr) ->
- returnRn4 (ListComp expr' quals', fvExpr `unionUniqSets` fvQuals)
-
-rnExpr (ExplicitList exps)
- = rnExprs exps `thenRn4` \ (exps', fvs) ->
- returnRn4 (ExplicitList exps', fvs)
-
-rnExpr (ExplicitTuple exps)
- = rnExprs exps `thenRn4` \ (exps', fvExps) ->
- returnRn4 (ExplicitTuple exps', fvExps)
-
-rnExpr (RecordCon con rbinds)
- = panic "rnExpr:RecordCon"
-rnExpr (RecordUpd exp rbinds)
- = panic "rnExpr:RecordUpd"
-
-rnExpr (ExprWithTySig expr pty)
- = rnExpr expr `thenRn4` \ (expr', fvExpr) ->
- rnPolyType False nullTyVarNamesEnv pty `thenRn4` \ pty' ->
- returnRn4 (ExprWithTySig expr' pty', fvExpr)
-
-rnExpr (HsIf p b1 b2 src_loc)
- = pushSrcLocRn4 src_loc $
- rnExpr p `thenRn4` \ (p', fvP) ->
- rnExpr b1 `thenRn4` \ (b1', fvB1) ->
- rnExpr b2 `thenRn4` \ (b2', fvB2) ->
- returnRn4 (HsIf p' b1' b2' src_loc, unionManyUniqSets [fvP, fvB1, fvB2])
-
-rnExpr (ArithSeqIn seq)
- = rn_seq seq `thenRn4` \ (new_seq, fvs) ->
- returnRn4 (ArithSeqIn new_seq, fvs)
- where
- rn_seq (From expr)
- = rnExpr expr `thenRn4` \ (expr', fvExpr) ->
- returnRn4 (From expr', fvExpr)
-
- rn_seq (FromThen expr1 expr2)
- = rnExpr expr1 `thenRn4` \ (expr1', fvExpr1) ->
- rnExpr expr2 `thenRn4` \ (expr2', fvExpr2) ->
- returnRn4 (FromThen expr1' expr2', fvExpr1 `unionUniqSets` fvExpr2)
-
- rn_seq (FromTo expr1 expr2)
- = rnExpr expr1 `thenRn4` \ (expr1', fvExpr1) ->
- rnExpr expr2 `thenRn4` \ (expr2', fvExpr2) ->
- returnRn4 (FromTo expr1' expr2', fvExpr1 `unionUniqSets` fvExpr2)
-
- rn_seq (FromThenTo expr1 expr2 expr3)
- = rnExpr expr1 `thenRn4` \ (expr1', fvExpr1) ->
- rnExpr expr2 `thenRn4` \ (expr2', fvExpr2) ->
- rnExpr expr3 `thenRn4` \ (expr3', fvExpr3) ->
- returnRn4 (FromThenTo expr1' expr2' expr3',
- unionManyUniqSets [fvExpr1, fvExpr2, fvExpr3])
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{@Qual@s: in list comprehensions}
-%* *
-%************************************************************************
-
-Note that although some bound vars may appear in the free var set for
-the first qual, these will eventually be removed by the caller. For
-example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
-@[q <- r, p <- q]@, the free var set for @q <- r@ will
-be @{r}@, and the free var set for the entire Quals will be @{r}@. This
-@r@ will be removed only when we finally return from examining all the
-Quals.
-
-\begin{code}
-rnQuals :: [ProtoNameQual]
- -> Rn4M (([RenamedQual], -- renamed qualifiers
- [Name]), -- qualifiers' binders
- FreeVars) -- free variables
-
-rnQuals [qual] -- must be at least one qual
- = rnQual qual `thenRn4` \ ((new_qual, bs), fvs) ->
- returnRn4 (([new_qual], bs), fvs)
-
-rnQuals (qual: quals)
- = rnQual qual `thenRn4` \ ((qual', bs1), fvQuals1) ->
- extendSS2 bs1 (rnQuals quals) `thenRn4` \ ((quals', bs2), fvQuals2) ->
- returnRn4
- ((qual' : quals', bs2 ++ bs1), -- The ones on the right (bs2) shadow the
- -- ones on the left (bs1)
- fvQuals1 `unionUniqSets` fvQuals2)
-
-rnQual (GeneratorQual pat expr)
- = rnExpr expr `thenRn4` \ (expr', fvExpr) ->
- let
- binders = collectPatBinders pat
- in
- getSrcLocRn4 `thenRn4` \ src_loc ->
- namesFromProtoNames "variable in list-comprehension-generator pattern"
- (binders `zip` repeat src_loc) `thenRn4` \ new_binders ->
- extendSS new_binders (rnPat pat) `thenRn4` \ pat' ->
-
- returnRn4 ((GeneratorQual pat' expr', new_binders), fvExpr)
-
-rnQual (FilterQual expr)
- = rnExpr expr `thenRn4` \ (expr', fvs) ->
- returnRn4 ((FilterQual expr', []), fvs)
-
-rnQual (LetQual binds)
- = rnBinds binds `thenRn4` \ (binds', binds_fvs, new_binders) ->
- returnRn4 ((LetQual binds', new_binders), binds_fvs)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsubsection{@Stmt@s: in @do@ expressions}
-%* *
-%************************************************************************
-
-\begin{code}
-rnStmts :: [ProtoNameStmt]
- -> Rn4M ([RenamedStmt], -- renamed qualifiers
- FreeVars) -- free variables
-
-rnStmts [stmt@(ExprStmt _ _)] -- last stmt must be ExprStmt
- = rnStmt stmt `thenRn4` \ ((stmt',[]), fvStmt) ->
- returnRn4 ([stmt'], fvStmt)
-
-rnStmts (stmt:stmts)
- = rnStmt stmt `thenRn4` \ ((stmt',bs), fvStmt) ->
- extendSS2 bs (rnStmts stmts) `thenRn4` \ (stmts', fvStmts) ->
- returnRn4 (stmt':stmts', fvStmt `unionUniqSets` fvStmts)
-
-
-rnStmt (BindStmt pat expr src_loc)
- = pushSrcLocRn4 src_loc $
- rnExpr expr `thenRn4` \ (expr', fvExpr) ->
- let
- binders = collectPatBinders pat
- in
- namesFromProtoNames "variable in do binding"
- (binders `zip` repeat src_loc) `thenRn4` \ new_binders ->
- extendSS new_binders (rnPat pat) `thenRn4` \ pat' ->
-
- returnRn4 ((BindStmt pat' expr' src_loc, new_binders), fvExpr)
-
-rnStmt (ExprStmt expr src_loc)
- =
- rnExpr expr `thenRn4` \ (expr', fvs) ->
- returnRn4 ((ExprStmt expr' src_loc, []), fvs)
-
-rnStmt (LetStmt binds)
- = rnBinds binds `thenRn4` \ (binds', binds_fvs, new_binders) ->
- returnRn4 ((LetStmt binds', new_binders), binds_fvs)
-
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-%
-\section[RnPass1]{@RnPass1@: gather up imported information}
-
-See the @Rename@ module for a basic description of the renamer.
-
-\begin{code}
-#include "HsVersions.h"
-
-module RnPass1 (
- rnModule1
-
- -- for completeness
- ) where
-
-import Ubiq{-uitous-}
-
-import HsSyn
-import HsPragmas ( DataPragmas(..) )
-import RdrHsSyn -- ProtoName* instantiations...
-
-import Bag ( emptyBag, unitBag, snocBag, unionBags, Bag )
-import ErrUtils
-import FiniteMap ( lookupFM, listToFM, elementOf )
-import Maybes ( catMaybes, maybeToBool )
-import Name ( Name{-instances-} )
-import Outputable ( isAvarid, getLocalName, interpp'SP )
-import PprStyle ( PprStyle(..) )
-import Pretty
-import ProtoName ( mkPreludeProtoName, ProtoName(..) )
-import RnMonad12
-import RnUtils
-import Util ( lengthExceeds, panic )
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Types and things used herein}
-%* *
-%************************************************************************
-
-@AllIntDecls@ is the type returned from processing import statement(s)
-in the main module.
-
-\begin{code}
-type AllIntDecls = ([ProtoNameFixityDecl], [ProtoNameTyDecl],
- [ProtoNameClassDecl], [ProtoNameInstDecl],
- [ProtoNameSig], Bag FAST_STRING)
-\end{code}
-
-The selective-import function @SelectiveImporter@ maps a @ProtoName@
-to something which indicates how much of the thing, if anything, is
-wanted by the importing module.
-\begin{code}
-type SelectiveImporter = ProtoName -> Wantedness
-
-data Wantedness
- = Wanted
- | NotWanted
- | WantedWith (IE ProtoName)
-\end{code}
-
-The @ProtoNames@ supplied to these ``name functions'' are always
-@Unks@, unless they are fully-qualified names, which occur only in
-interface pragmas (and, therefore, never on the {\em definitions} of
-things). That doesn't happen in @RnPass1@!
-\begin{code}
-type IntNameFun = ProtoName -> ProtoName
-type IntTCNameFun = ProtoName -> (ProtoName, IntNameFun)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{First pass over the entire module}
-%* *
-%************************************************************************
-
-This pass flattens out the declarations embedded within the interfaces
-which this module imports. The result is a new module with no
-imports, but with more declarations. The declarations which arose
-from the imported interfaces will have @ProtoNames@ with @Imp@
-constructors; the declarations in the body of this module are
-unaffected, so they will still be @Unk@'s.
-
-We import only the declarations from interfaces which are actually {\em
-used}. This saves time later, because we don't need process the
-unused ones.
-
-\begin{code}
-rnModule1 :: PreludeNameMappers
- -> Bool -- see use below
- -> ProtoNameHsModule
- -> Rn12M (ProtoNameHsModule, Bag FAST_STRING)
-
-rnModule1 pnf@(v_pnf, tc_pnf)
- use_mentioned_vars_heuristic
- (HsModule mod_name exports imports fixes
- ty_decls absty_sigs class_decls inst_decls specinst_sigs
- defaults binds _ src_loc)
-
- = -- slurp through the *body* of the module, collecting names of
- -- mentioned *variables*, 3+ letters long & not prelude names.
- -- Note: we *do* have to pick up top-level binders,
- -- so we can check for conflicts with imported guys!
- let
- is_mentioned_fn = \ x -> True -- wimp way out
-{- OLD:
- (uses_Mdotdot_in_exports, mentioned_vars)
- = getMentionedVars v_pnf exports fixes class_decls inst_decls binds
-
- -- Using the collected "mentioned" variables, create an
- -- "is-mentioned" function (:: FAST_STRING -> Bool), which gives
- -- True if something is mentioned is in the list collected.
- -- For more details, see under @selectAll@, notably the
- -- handling of short (< 3 chars) names.
-
- -- Note: this "is_mentioned" game doesn't work if the export
- -- list includes any M.. constructs (because that mentions
- -- variables *implicitly*, basically). getMentionedVars tells
- -- us this, and we act accordingly.
-
- is_mentioned_maybe
- = lookupFM (listToFM
- [ (x, panic "is_mentioned_fn")
- | x <- mentioned_vars ++ needed_for_deriving ]
- )
- where
- needed_for_deriving -- is this a HACK or what?
- = [ SLIT("&&"),
- SLIT("."),
- SLIT("lex"),
- SLIT("map"),
- SLIT("not"),
- SLIT("readParen"),
- SLIT("showParen"),
- SLIT("showSpace__"),
- SLIT("showString")
- ]
-
- is_mentioned_fn
- = if use_mentioned_vars_heuristic
- && not (uses_Mdotdot_in_exports)
- then \ x -> maybeToBool (is_mentioned_maybe x)
- else \ x -> True
--}
- in
- -- OK, now do the business:
- doImportedIfaces pnf is_mentioned_fn imports
- `thenRn12` \ (int_fixes, int_ty_decls,
- int_class_decls, int_inst_decls,
- int_sigs, import_names) ->
- let
- inst_decls' = doRevoltingInstDecls tc_nf inst_decls
- in
- returnRn12
- ((HsModule mod_name
- exports imports -- passed along mostly for later checking
- (int_fixes ++ fixes)
- (int_ty_decls ++ ty_decls)
- absty_sigs
- (int_class_decls ++ class_decls)
- (int_inst_decls ++ inst_decls')
- specinst_sigs
- defaults
- binds
- int_sigs
- src_loc),
- import_names)
- where
- -- This function just spots prelude names
- tc_nf pname@(Unk s) = case (tc_pnf s) of
- Nothing -> pname
- Just name -> Prel name
-
- tc_nf other_pname = panic "In tc_nf passed to doRevoltingInstDecls"
- -- The only place where Imps occur is on Ids in unfoldings;
- -- this function is only used on type-things.
-\end{code}
-
-Instance declarations in the module itself are treated in a horribly
-special way. Because their class name and type constructor will be
-compared against imported ones in the second pass (to eliminate
-duplicate instance decls) we need to make Prelude classes and tycons
-appear as such. (For class and type decls, the module can't be
-declaring a prelude class or tycon, so Prel and Unk things can just
-compare non-equal.) This is a HACK.
-
-\begin{code}
-doRevoltingInstDecls :: IntNameFun -> [ProtoNameInstDecl] -> [ProtoNameInstDecl]
-
-doRevoltingInstDecls tc_nf decls
- = map revolt_me decls
- where
- revolt_me (InstDecl cname ty binds True modname uprags pragma src_loc)
- = InstDecl
- (tc_nf cname) -- Look up the class
- (doIfacePolyType1 tc_nf ty) -- Ditto the type
- binds -- Binds unchanged
- True{-yes,defined in this module-}
- modname
- uprags
- pragma
- src_loc
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Process a module's imported interfaces}
-%* *
-%************************************************************************
-
-@doImportedIfaces@ processes the entire set of interfaces imported by the
-module being renamed.
-
-\begin{code}
-doImportedIfaces :: PreludeNameMappers
- -> (FAST_STRING -> Bool)
- -> [ProtoNameImportedInterface]
- -> Rn12M AllIntDecls
-
-doImportedIfaces pnfs is_mentioned_fn []
- = returnRn12 ( [{-fixities-}], [{-tydecls-}], [{-clasdecls-}],
- [{-instdecls-}], [{-sigs-}], emptyBag )
-
-doImportedIfaces pnfs is_mentioned_fn (iface:ifaces)
- = doOneIface pnfs is_mentioned_fn iface
- `thenRn12` \ (ifixes1, itd1, icd1, iid1, isd1, names1) ->
-
- doImportedIfaces pnfs is_mentioned_fn ifaces
- `thenRn12` \ (ifixes2, itd2, icd2, iid2, isd2, names2) ->
-
- returnRn12 (ifixes1 ++ ifixes2,
- itd1 ++ itd2,
- icd1 ++ icd2,
- iid1 ++ iid2,
- isd1 ++ isd2,
- names1 `unionBags` names2)
-\end{code}
-
-\begin{code}
-doOneIface :: PreludeNameMappers
- -> (FAST_STRING -> Bool)
- -> ProtoNameImportedInterface
- -> Rn12M AllIntDecls
-
-doOneIface _ _ (ImportMod _ True{-qualified-} _ _)
- = panic "RnPass1.doOneIface:can't grok `qualified'"
-
-doOneIface _ _ (ImportMod _ _ (Just _) _)
- = panic "RnPass1.doOneIface:can't grok `as' module (blech)"
-
-doOneIface pnfs is_mentioned_fn (ImportMod iface qual asmod Nothing{-all-})
- = doIface1 pnfs (selectAll is_mentioned_fn) iface
-
-doOneIface pnfs _ (ImportMod iface qual asmod (Just (False{-unhidden-}, ies)))
- = doIface1 pnfs si_fun iface
- where
- -- the `selective import' function should not be applied
- -- to the Imps that occur on Ids in unfoldings.
-
- si_fun (Unk n) = check_ie n ies
- si_fun (Qunk _ n) = check_ie n ies
-
- check_ie name [] = NotWanted
- check_ie name (ie:ies)
- = case ie of
- IEVar (Unk n) | name == n -> Wanted
- IEThingAbs (Unk n) | name == n -> WantedWith ie
- IEThingAll (Unk n) | name == n -> WantedWith ie
- IEModuleContents _ -> panic "Module.. in import list?"
- other -> check_ie name ies
-
-doOneIface pnfs _ (ImportMod iface qual asmod (Just (True{-hidden-}, ies)))
- = doIface1 pnfs si_fun iface
- where
- -- see comment above:
-
- si_fun x | n `elementOf` entity_info = NotWanted
- | otherwise = Wanted
- where
- n = case x of { Unk s -> s; Qunk _ s -> s }
-
- entity_info = getImportees ies
-\end{code}
-
-@selectAll@ ``normally'' creates an @SelectiveImporter@ that declares
-everything from an interface to be @Wanted@. We may, however, pass
-in a more discriminating @is_mentioned_fn@ (returns @True@ if the
-named entity is mentioned in the body of the module in question), which
-can be used to trim off junk from an interface.
-
-For @selectAll@ to say something is @NotWanted@, it must be a
-variable, it must not be in the collected-up list of mentioned
-variables (checked with @is_mentioned_fn@), and it must be three chars
-or longer.
-
-And, of course, we mustn't forget to take account of renaming!
-
-ADR Question: What's so magical about names longer than 3 characters?
-Why would we want to keep long names which aren't mentioned when we're
-quite happy to throw away short names that aren't mentioned?
-
-\begin{code}
-selectAll :: (FAST_STRING -> Bool) -> SelectiveImporter
-
-selectAll is_mentioned_fn n
- = let
- rn_str = case n of { Unk s -> s ; Qunk _ s -> s }
- in
- if (isAvarid rn_str)
- && (not (is_mentioned_fn rn_str))
- && (_UNPK_ rn_str `lengthExceeds` 2)
- then NotWanted
- else Wanted
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{First pass over a particular interface}
-%* *
-%************************************************************************
-
-
-@doIface1@ handles a specific interface. First it looks at the
-interface imports, creating a bag that maps local names back to their
-original names, from which it makes a function that does the same. It
-then uses this function to create a triple of bags for the interface
-type, class and value declarations, in which local names have been
-mapped back into original names.
-
-Notice that @mkLocalNameFun@ makes two different functions. The first
-is the name function for the interface. This takes a local name and
-provides an original name for any name in the interface by using
-either of:
-\begin{itemize}
-\item
-the original name produced by the renaming function;
-\item
-the local name in the interface and the interface name.
-\end{itemize}
-
-The function @doIfaceImports1@ receives two association lists which will
-be described at its definition.
-
-\begin{code}
-doIface1 :: PreludeNameMappers
- -> SelectiveImporter
- -> ProtoNameInterface
- -> Rn12M AllIntDecls
-
-doIface1 (v_pnf, tc_pnf) sifun
- (Interface i_name import_decls fix_decls ty_decls class_decls
- inst_decls sig_decls anns)
-
- = doIfaceImports1 (panic "i_name"{-i_name-}) import_decls `thenRn12` \ (v_bag, tc_bag) ->
- do_body (v_bag, tc_bag)
- where
- do_body (v_bag, tc_bag)
- = report_all_errors `thenRn12` \ _ ->
-
- doIfaceTyDecls1 sifun full_tc_nf ty_decls `thenRn12` \ ty_decls' ->
-
- doIfaceClassDecls1 sifun full_tc_nf class_decls `thenRn12` \ class_decls' ->
-
- let sig_decls' = doIfaceSigs1 sifun v_nf tc_nf sig_decls
- fix_decls' = doIfaceFixes1 sifun v_nf fix_decls
- inst_decls' = doIfaceInstDecls1 sifun tc_nf inst_decls
- in
- returnRn12 (fix_decls', ty_decls', class_decls', inst_decls', sig_decls', unitBag i_name)
- where
- v_dups :: [[(FAST_STRING, ProtoName)]]
- tc_dups :: [[(FAST_STRING, (ProtoName, IntNameFun))]]
-
- (imp_v_nf, v_dups) = mkNameFun v_bag
- (imp_tc_nf, tc_dups) = mkNameFun tc_bag
-
- v_nf :: IntNameFun
- v_nf (Unk s) = case v_pnf s of
- Just n -> mkPreludeProtoName n
- Nothing -> case imp_v_nf s of
- Just n -> n
- Nothing -> Imp i_name s [i_name] s
-
- -- used for (..)'d parts of prelude datatype/class decls
- prel_con_or_op_nf :: FAST_STRING{-module name-}-> IntNameFun
- prel_con_or_op_nf m (Unk s)
- = case v_pnf s of
- Just n -> mkPreludeProtoName n
- Nothing -> Imp m s [m] s
- -- Strictly speaking, should be *no renaming* here, folks
-
- -- used for non-prelude constructors/ops/fields
- local_con_or_op_nf :: IntNameFun
- local_con_or_op_nf (Unk s) = Imp i_name s [i_name] s
-
- full_tc_nf :: IntTCNameFun
- full_tc_nf (Unk s)
- = case tc_pnf s of
- Just n -> (mkPreludeProtoName n,
- let
- mod = fst (getOrigName n)
- in
- prel_con_or_op_nf mod)
-
- Nothing -> case imp_tc_nf s of
- Just pair -> pair
- Nothing -> (Imp i_name s [i_name] s,
- local_con_or_op_nf)
-
- tc_nf = fst . full_tc_nf
-
- -- ADR: commented out next new lines because I don't believe
- -- ADR: the check is useful or required by the Standard. (It
- -- ADR: also messes up the interpreter.)
-
- tc_errs = [] -- map (map (fst . snd)) tc_dups
- -- Ugh! Just keep the dup'd protonames
- v_errs = [] -- map (map snd) v_dups
- -- Ditto
-
- report_all_errors
- = mapRn12 (addErrRn12 . duplicateImportsInInterfaceErr (_UNPK_ i_name))
- (tc_errs ++ v_errs)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{doIfaceImports1}
-%* *
-%************************************************************************
-
-@ImportNameBags@ is a pair of bags (one for values, one for types and
-classes) which specify the new names brought into scope by some
-import declarations in an interface.
-
-\begin{code}
-type ImportNameBags = (Bag (FAST_STRING, ProtoName),
- Bag (FAST_STRING, (ProtoName, IntNameFun))
- )
-\end{code}
-
-\begin{code}
-doIfaceImports1
- :: FAST_STRING -- name of module whose interface we're doing
- -> [IfaceImportDecl ProtoName]
- -> Rn12M ImportNameBags
-
-doIfaceImports1 _ [] = returnRn12 (emptyBag, emptyBag)
-
-doIfaceImports1 int_mod_name (imp_decl1 : rest)
- = do_decl imp_decl1 `thenRn12` \ (vb1, tcb1) ->
- doIfaceImports1 int_mod_name rest `thenRn12` \ (vb2, tcb2) ->
- returnRn12 (vb1 `unionBags` vb2, tcb1 `unionBags` tcb2)
- where
- do_decl (IfaceImportDecl orig_mod_name imports src_loc)
- = -- Look at the renamings to get a suitable renaming function
- doRenamings{-not really-} int_mod_name orig_mod_name
- `thenRn12` \ (orig_to_pn, local_to_pn) ->
-
- -- Now deal with one import at a time, combining results.
- returnRn12 (
- foldl (doIfaceImport1 orig_to_pn local_to_pn)
- (emptyBag, emptyBag)
- imports
- )
-\end{code}
-
-@doIfaceImport1@ takes a list of imports and the pair of renaming functions,
-returning a bag which maps local names to original names.
-
-\begin{code}
-doIfaceImport1 :: ( ProtoName -- Original local name
- -> (FAST_STRING, -- Local name in this interface
- ProtoName) -- Its full protoname
- )
-
- -> IntNameFun -- Local name to ProtoName; use for
- -- constructors and class ops
-
- -> ImportNameBags -- Accumulator
- -> (IE ProtoName) -- An item in the import list
- -> ImportNameBags
-
-doIfaceImport1 orig_to_pn local_to_pn (v_bag, tc_bag) (IEVar orig_name)
- = (v_bag `snocBag` (orig_to_pn orig_name), tc_bag)
-
-doIfaceImport1 orig_to_pn local_to_pn acc (IEThingAbs orig_name)
- = int_import1_help orig_to_pn local_to_pn acc orig_name
-
-doIfaceImport1 orig_to_pn local_to_pn acc (IEThingAll orig_name)
- = int_import1_help orig_to_pn local_to_pn acc orig_name
-
--- the next ones will go away with 1.3:
-{- OLD:
-doIfaceImport1 orig_to_pn local_to_pn acc (IEConWithCons orig_name _)
- = int_import1_help orig_to_pn local_to_pn acc orig_name
-
-doIfaceImport1 orig_to_pn local_to_pn acc (IEClsWithOps orig_name _)
- = int_import1_help orig_to_pn local_to_pn acc orig_name
--}
-
-doIfaceImport1 orig_to_pn local_to_pn (v_bag, tc_bag) other
- = panic "RnPass1: strange import decl"
-
--- Little help guy...
-
-int_import1_help orig_to_pn local_to_pn (v_bag, tc_bag) orig_name
- = case (orig_to_pn orig_name) of { (str, o_name) ->
- (v_bag, tc_bag `snocBag` (str, (o_name, local_to_pn)))
- }
-\end{code}
-
-
-The renaming-processing code. It returns two name-functions. The
-first maps the {\em original} name for an entity onto a @ProtoName@
---- it is used when running over the list of things to be imported.
-The second maps the {\em local} name for a constructor or class op
-back to its original name --- it is used when scanning the RHS of
-a @data@ or @class@ decl.
-
-It can produce errors, if there is a domain clash on the renamings.
-
-\begin{code}
-doRenamings :: FAST_STRING -- Name of the module whose interface we're working on
- -> FAST_STRING -- Original-name module for these renamings
- -> Rn12M
- ((ProtoName -- Original local name to...
- -> (FAST_STRING, -- ... Local name in this interface
- ProtoName) -- ... Its full protoname
- ),
- IntNameFun) -- Use for constructors, class ops
-
-doRenamings int_mod orig_mod
- = returnRn12 (
- \ (Unk s) ->
- let
- result = (s, Imp orig_mod s [int_mod] s)
- in
- result
- ,
-
- \ (Unk s) ->
- let
- result = Imp orig_mod s [int_mod] s
- in
- result
- )
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Type declarations}
-%* *
-%************************************************************************
-
-@doIfaceTyDecls1@ uses the `name function' to map local tycon names into
-original names, calling @doConDecls1@ to do the same for the
-constructors. @doTyDecls1@ is used to do both module and interface
-type declarations.
-
-\begin{code}
-doIfaceTyDecls1 :: SelectiveImporter
- -> IntTCNameFun
- -> [ProtoNameTyDecl]
- -> Rn12M [ProtoNameTyDecl]
-
-doIfaceTyDecls1 sifun full_tc_nf ty_decls
- = mapRn12 do_decl ty_decls `thenRn12` \ decls_maybe ->
- returnRn12 (catMaybes decls_maybe)
- where
- do_decl (TySynonym tycon tyvars monoty src_loc)
- = let
- full_thing = returnRn12 (Just ty_decl')
- in
- case (sifun tycon) of
- NotWanted -> returnRn12 Nothing
- Wanted -> full_thing
- WantedWith (IEThingAll _) -> full_thing
-
- WantedWith weird_ie -> full_thing
- where
- (tycon_name,_) = full_tc_nf tycon
- tc_nf = fst . full_tc_nf
- monoty' = doIfaceMonoType1 tc_nf monoty
- ty_decl' = TySynonym tycon_name tyvars monoty' src_loc
-
- do_decl (TyData context tycon tyvars condecls derivs pragmas src_loc)
- = do_data context tycon condecls derivs pragmas src_loc `thenRn12` \ done_data ->
- case done_data of
- Nothing -> returnRn12 Nothing
- Just (context', tycon', condecls', derivs', pragmas') ->
- returnRn12 (Just (TyData context' tycon' tyvars condecls' derivs' pragmas' src_loc))
-
- do_decl (TyNew context tycon tyvars condecl derivs pragmas src_loc)
- = do_data context tycon condecl derivs pragmas src_loc `thenRn12` \ done_data ->
- case done_data of
- Nothing -> returnRn12 Nothing
- Just (context', tycon', condecl', derivs', pragmas') ->
- returnRn12 (Just (TyNew context' tycon' tyvars condecl' derivs' pragmas' src_loc))
-
- --------------------------------------------
- do_data context tycon condecls derivs (DataPragmas hidden_cons specs) src_loc
- = let
- full_thing = Just (context', tycon_name, condecls', deriv', (pragmas' False))
- abs_thing = Just (context', tycon_name, [], deriv', (pragmas' True))
- in
- case (sifun tycon) of
- NotWanted -> returnRn12 Nothing
- Wanted -> returnRn12 full_thing
- WantedWith (IEThingAll _) -> returnRn12 full_thing
- WantedWith (IEThingAbs _) -> returnRn12 abs_thing
-
- WantedWith really_weird_ie -> -- probably a typo in the pgm
- addErrRn12 (weirdImportExportConstraintErr
- tycon really_weird_ie src_loc) `thenRn12` \ _ ->
- returnRn12 full_thing
- where
- (tycon_name, constrfield_nf) = full_tc_nf tycon
- tc_nf = fst . full_tc_nf
-
- condecls' = map (do_condecl constrfield_nf tc_nf) condecls
- hidden_cons' = map (do_condecl constrfield_nf tc_nf) hidden_cons
-
- pragmas' invent_hidden
- = DataPragmas (if null hidden_cons && invent_hidden
- then condecls' -- if importing abstractly but condecls were
- -- exported we add them to the data pragma
- else hidden_cons')
- specs {- ToDo: do_specs -}
-
- context' = doIfaceContext1 tc_nf context
- deriv' = case derivs of
- Nothing -> Nothing
- Just ds -> panic "doIfaceTyDecls1:derivs" -- Just (map tc_nf ds)
- -- rename derived classes
-
- --------------------------------------------
- -- one name fun for the data constructor, another for the type:
-
- do_condecl cf_nf tc_nf (ConDecl name tys src_loc)
- = ConDecl (cf_nf name) (map (do_bang tc_nf) tys) src_loc
-
- do_condecl cf_nf tc_nf (ConOpDecl ty1 op ty2 src_loc)
- = ConOpDecl (do_bang tc_nf ty1) (cf_nf op) (do_bang tc_nf ty2) src_loc
-
- do_condecl cf_nf tc_nf (NewConDecl name ty src_loc)
- = NewConDecl (cf_nf name) (doIfaceMonoType1 tc_nf ty) src_loc
-
- do_condecl cf_nf tc_nf (RecConDecl con fields src_loc)
- = RecConDecl (cf_nf con) (map do_field fields) src_loc
- where
- do_field (vars, ty) = (map cf_nf vars, do_bang tc_nf ty)
-
- --------------------------------------------
- do_bang tc_nf (Banged ty) = Banged (doIfaceMonoType1 tc_nf ty)
- do_bang tc_nf (Unbanged ty) = Unbanged (doIfaceMonoType1 tc_nf ty)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Class declarations}
-%* *
-%************************************************************************
-
-@doIfaceClassDecls1@ uses the `name function' to map local class names into
-original names, calling @doIfaceClassOp1@ to do the same for the
-class operations. @doClassDecls1@ is used to process both module and
-interface class declarations.
-
-\begin{code}
-doIfaceClassDecls1 :: SelectiveImporter
- -> IntTCNameFun
- -> [ProtoNameClassDecl]
- -> Rn12M [ProtoNameClassDecl]
-
-doIfaceClassDecls1 sifun full_tc_nf clas_decls
- = mapRn12 do_decl clas_decls `thenRn12` \ decls_maybe ->
- returnRn12 (catMaybes decls_maybe)
- where
- do_decl (ClassDecl ctxt cname tyvar sigs bs@EmptyMonoBinds prags locn)
- -- No defaults in interface
- = let
- full_thing = returnRn12 (Just class_decl')
- in
- case (sifun cname) of
- NotWanted -> returnRn12 Nothing
- Wanted -> full_thing
- WantedWith (IEThingAll _) -> full_thing
- -- ToDo: add checking of IEClassWithOps
- WantedWith really_weird_ie -> -- probably a typo in the pgm
- addErrRn12 (weirdImportExportConstraintErr
- cname really_weird_ie locn) `thenRn12` \ _ ->
- full_thing
- where
- (clas, op_nf) = full_tc_nf cname
- tc_nf = fst . full_tc_nf
-
- sigs' = map (doIfaceClassOp1 op_nf tc_nf) sigs
- ctxt' = doIfaceContext1 tc_nf ctxt
-
- class_decl' = ClassDecl ctxt' clas tyvar sigs' bs prags locn
- abs_class_decl' = ClassDecl ctxt' clas tyvar [] bs prags locn
-\end{code}
-
-\begin{code}
-doIfaceClassOp1 :: IntNameFun -- Use this for the class ops
- -> IntNameFun -- Use this for the types
- -> ProtoNameClassOpSig
- -> ProtoNameClassOpSig
-
-doIfaceClassOp1 op_nf tc_nf (ClassOpSig v ty pragma src_loc)
- = ClassOpSig (op_nf v) (doIfacePolyType1 tc_nf ty) pragma src_loc
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Instance declarations}
-%* *
-%************************************************************************
-
-We select the instance decl if either the class or the type constructor
-are selected.
-
-\begin{code}
-doIfaceInstDecls1 :: SelectiveImporter
- -> IntNameFun
- -> [ProtoNameInstDecl]
- -> [ProtoNameInstDecl]
-
-doIfaceInstDecls1 si tc_nf inst_decls
- = catMaybes (map do_decl inst_decls)
- where
- do_decl (InstDecl cname ty EmptyMonoBinds False modname uprags pragmas src_loc)
- = case (si cname, tycon_reqd) of
- (NotWanted, NotWanted) -> Nothing
- _ -> Just inst_decl'
- where
- ty' = doIfacePolyType1 tc_nf ty
-
- inst_decl' = InstDecl (tc_nf cname) ty' EmptyMonoBinds False modname uprags pragmas src_loc
-
- tycon_reqd = _trace "RnPass1.tycon_reqd" NotWanted
-{- LATER:
- = case getNonPrelOuterTyCon ty of
- Nothing -> NotWanted -- Type doesn't have a user-defined tycon
- -- at its outermost level
- Just tycon -> si tycon -- It does, so look up in the si-fun
--}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Signature declarations}
-%* *
-%************************************************************************
-
-@doIfaceSigs1@ uses the name function to create a bag that
-maps local names into original names.
-
-NB: Can't have user-pragmas & other weird things in interfaces.
-
-\begin{code}
-doIfaceSigs1 :: SelectiveImporter -> IntNameFun -> IntNameFun
- -> [ProtoNameSig]
- -> [ProtoNameSig]
-
-doIfaceSigs1 si v_nf tc_nf sigs
- = catMaybes (map do_sig sigs)
- where
- do_sig (Sig v ty pragma src_loc)
- = case (si v) of
- NotWanted -> Nothing
- Wanted -> Just (Sig (v_nf v) (doIfacePolyType1 tc_nf ty) pragma src_loc)
- -- WantedWith doesn't make sense
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Fixity declarations}
-%* *
-%************************************************************************
-
-\begin{code}
-doIfaceFixes1 :: SelectiveImporter -> IntNameFun
- -> [ProtoNameFixityDecl]
- -> [ProtoNameFixityDecl]
-
-doIfaceFixes1 si vnf fixities
- = catMaybes (map do_fixity fixities)
- where
- do_fixity (InfixL name i) = do_one InfixL name i
- do_fixity (InfixR name i) = do_one InfixR name i
- do_fixity (InfixN name i) = do_one InfixN name i
-
- do_one con name i
- = case si name of
- Wanted -> Just (con (vnf name) i)
- NotWanted -> Nothing
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{doContext, MonoTypes, MonoType, Polytype}
-%* *
-%************************************************************************
-
-\begin{code}
-doIfacePolyType1 :: IntNameFun -> ProtoNamePolyType -> ProtoNamePolyType
-
-doIfacePolyType1 tc_nf (HsPreForAllTy ctxt ty)
- = HsPreForAllTy (doIfaceContext1 tc_nf ctxt) (doIfaceMonoType1 tc_nf ty)
-
-doIfacePolyType1 tc_nf (HsForAllTy tvs ctxt ty)
- = HsForAllTy tvs (doIfaceContext1 tc_nf ctxt) (doIfaceMonoType1 tc_nf ty)
-\end{code}
-
-\begin{code}
-doIfaceContext1 :: IntNameFun -> ProtoNameContext -> ProtoNameContext
-doIfaceContext1 tc_nf context = [(tc_nf clas, tyvar) | (clas,tyvar) <- context]
-\end{code}
-
-
-\begin{code}
-doIfaceMonoType1 :: IntNameFun -> ProtoNameMonoType -> ProtoNameMonoType
-
-doIfaceMonoType1 tc_nf tv@(MonoTyVar _) = tv
-
-doIfaceMonoType1 tc_nf (MonoListTy ty)
- = MonoListTy (doIfaceMonoType1 tc_nf ty)
-
-doIfaceMonoType1 tc_nf (MonoFunTy ty1 ty2)
- = MonoFunTy (doIfaceMonoType1 tc_nf ty1) (doIfaceMonoType1 tc_nf ty2)
-
-doIfaceMonoType1 tc_nf (MonoTupleTy tys)
- = MonoTupleTy (map (doIfaceMonoType1 tc_nf) tys)
-
-doIfaceMonoType1 tc_nf (MonoTyApp name tys)
- = MonoTyApp (tc_nf name) (map (doIfaceMonoType1 tc_nf) tys)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Error messages}
-%* *
-%************************************************************************
-
-\begin{code}
-duplicateImportsInInterfaceErr iface dups
- = panic "duplicateImportsInInterfaceErr: NOT DONE YET?"
-
-weirdImportExportConstraintErr thing constraint locn
- = addShortErrLocLine locn ( \ sty ->
- ppBesides [ppStr "Illegal import/export constraint on `",
- ppr sty thing,
- ppStr "': ", ppr PprForUser constraint])
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-%
-\section[RnPass4]{Fourth of the renaming passes}
-
-\begin{code}
-#include "HsVersions.h"
-
-module RnPass4 ( rnModule, rnPolyType, rnGenPragmas ) where
-
-import Ubiq{-uitous-}
-import RnLoop -- *check* the RnPass4/RnExpr4/RnBinds4 loop-breaking
-
-import HsSyn
-import RdrHsSyn
-import RnHsSyn
-import HsPragmas -- all of it
-import HsCore -- all of it
-import RnMonad4
-
-import Class ( derivableClassKeys )
-import Maybes ( maybeToBool, catMaybes )
-import Name ( Name(..) )
-import Outputable ( Outputable(..), isAvarid )
-import Pretty ( ppHang, ppStr, ppCat, ppAboves )
-import ProtoName ( eqProtoName, elemProtoNames, ProtoName{-instance-} )
-import RnBinds4 ( rnTopBinds, rnMethodBinds )
-import SrcLoc ( SrcLoc{-instance-} )
-import Unique ( Unique{-instances-} )
-import UniqSet ( UniqSet(..) )
-import Util ( isIn, panic, assertPanic )
-\end{code}
-
-This pass `renames' the module+imported info, simultaneously
-performing dependency analysis. It also does the following error
-checks:
-\begin{enumerate}
-\item
-Checks that tyvars are used properly. This includes checking
-for undefined tyvars, and tyvars in contexts that are ambiguous.
-\item
-Checks that local variables are defined.
-\end{enumerate}
-
-\begin{code}
-rnModule :: ProtoNameHsModule -> Rn4M RenamedHsModule
-
-rnModule (HsModule mod_name exports _ fixes ty_decls specdata_sigs
- class_decls inst_decls specinst_sigs defaults
- binds int_sigs src_loc)
-
- = pushSrcLocRn4 src_loc (
-
- mapRn4 rnTyDecl ty_decls `thenRn4` \ new_ty_decls ->
- mapRn4 rnSpecDataSig specdata_sigs `thenRn4` \ new_specdata_sigs ->
- mapRn4 rnClassDecl class_decls `thenRn4` \ new_class_decls ->
- mapRn4 rnInstDecl inst_decls `thenRn4` \ new_inst_decls ->
- mapRn4 rnSpecInstSig specinst_sigs `thenRn4` \ new_specinst_sigs ->
- rnDefaultDecl defaults `thenRn4` \ new_defaults ->
- rnTopBinds binds `thenRn4` \ new_binds ->
- mapRn4 rnIntSig int_sigs `thenRn4` \ new_int_sigs ->
- rnFixes fixes `thenRn4` \ new_fixes ->
- rnExports exports `thenRn4` \ new_exports ->
-
- returnRn4 (HsModule mod_name
- new_exports [{-imports finally clobbered-}] new_fixes
- new_ty_decls new_specdata_sigs new_class_decls
- new_inst_decls new_specinst_sigs new_defaults
- new_binds new_int_sigs src_loc)
- )
-
-rnExports Nothing = returnRn4 Nothing
-rnExports (Just exp_list)
- = returnRn4 (Just (_trace "rnExports:trashing exports" []))
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Type declarations}
-%* *
-%*********************************************************
-
-@rnTyDecl@ uses the `global name function' to create a new type
-declaration in which local names have been replaced by their original
-names, reporting any unknown names.
-
-Renaming type variables is a pain. Because they now contain uniques,
-it is necessary to pass in an association list which maps a parsed
-tyvar to its Name representation. In some cases (type signatures of
-values), it is even necessary to go over the type first in order to
-get the set of tyvars used by it, make an assoc list, and then go over
-it again to rename the tyvars! However, we can also do some scoping
-checks at the same time.
-
-\begin{code}
-rnTyDecl :: ProtoNameTyDecl -> Rn4M RenamedTyDecl
-
-rnTyDecl (TyData context tycon tyvars condecls derivings pragmas src_loc)
- = pushSrcLocRn4 src_loc (
- lookupTyCon tycon `thenRn4` \ tycon' ->
- mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env, tyvars') ->
- rnContext tv_env context `thenRn4` \ context' ->
- rnConDecls tv_env False condecls `thenRn4` \ condecls' ->
- rn_derivs tycon' src_loc derivings `thenRn4` \ derivings' ->
- recoverQuietlyRn4 (DataPragmas [] []) (
- rnDataPragmas tv_env pragmas
- ) `thenRn4` \ pragmas' ->
- returnRn4 (TyData context' tycon' tyvars' condecls' derivings' pragmas' src_loc)
- )
-
-rnTyDecl (TyNew context tycon tyvars condecl derivings pragmas src_loc)
- = pushSrcLocRn4 src_loc (
- lookupTyCon tycon `thenRn4` \ tycon' ->
- mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env, tyvars') ->
- rnContext tv_env context `thenRn4` \ context' ->
- rnConDecls tv_env False condecl `thenRn4` \ condecl' ->
- rn_derivs tycon' src_loc derivings `thenRn4` \ derivings' ->
- recoverQuietlyRn4 (DataPragmas [] []) (
- rnDataPragmas tv_env pragmas
- ) `thenRn4` \ pragmas' ->
- returnRn4 (TyNew context' tycon' tyvars' condecl' derivings' pragmas' src_loc)
- )
-
-rnTyDecl (TySynonym name tyvars ty src_loc)
- = pushSrcLocRn4 src_loc (
- lookupTyCon name `thenRn4` \ name' ->
- mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env, tyvars') ->
- rnMonoType False{-no invisible types-} tv_env ty
- `thenRn4` \ ty' ->
- returnRn4 (TySynonym name' tyvars' ty' src_loc)
- )
-
-rn_derivs tycon2 locn Nothing -- derivs not specified
- = returnRn4 Nothing
-
-rn_derivs tycon2 locn (Just ds)
- = mapRn4 (rn_deriv tycon2 locn) ds `thenRn4` \ derivs ->
- returnRn4 (Just derivs)
- where
- rn_deriv tycon2 locn clas
- = lookupClass clas `thenRn4` \ clas_name ->
- case clas_name of
- ClassName key _ _ | key `is_elem` derivableClassKeys
- -> returnRn4 clas_name
- _ -> addErrRn4 (derivingNonStdClassErr clas locn) `thenRn4_`
- returnRn4 clas_name
- where
- is_elem = isIn "rn_deriv"
-\end{code}
-
-@rnConDecls@ uses the `global name function' to create a new
-constructor in which local names have been replaced by their original
-names, reporting any unknown names.
-
-\begin{code}
-rnConDecls :: TyVarNamesEnv
- -> Bool -- True <=> allowed to see invisible data-cons
- -> [ProtoNameConDecl]
- -> Rn4M [RenamedConDecl]
-
-rnConDecls tv_env invisibles_allowed con_decls
- = mapRn4 rn_decl con_decls
- where
- lookup_fn
- = if invisibles_allowed
- then lookupValueEvenIfInvisible
- else lookupValue
-
- rn_decl (ConDecl name tys src_loc)
- = pushSrcLocRn4 src_loc (
- lookup_fn name `thenRn4` \ new_name ->
- mapRn4 rn_bang_ty tys `thenRn4` \ new_tys ->
- returnRn4 (ConDecl new_name new_tys src_loc)
- )
-
- rn_decl (ConOpDecl ty1 op ty2 src_loc)
- = pushSrcLocRn4 src_loc (
- lookup_fn op `thenRn4` \ new_op ->
- rn_bang_ty ty1 `thenRn4` \ new_ty1 ->
- rn_bang_ty ty2 `thenRn4` \ new_ty2 ->
- returnRn4 (ConOpDecl new_ty1 new_op new_ty2 src_loc)
- )
-
- rn_decl (NewConDecl name ty src_loc)
- = pushSrcLocRn4 src_loc (
- lookup_fn name `thenRn4` \ new_name ->
- rn_mono_ty ty `thenRn4` \ new_ty ->
- returnRn4 (NewConDecl new_name new_ty src_loc)
- )
-
- rn_decl (RecConDecl con fields src_loc)
- = panic "rnConDecls:RecConDecl"
-
- ----------
- rn_mono_ty = rnMonoType invisibles_allowed tv_env
-
- rn_bang_ty (Banged ty)
- = rn_mono_ty ty `thenRn4` \ new_ty ->
- returnRn4 (Banged new_ty)
- rn_bang_ty (Unbanged ty)
- = rn_mono_ty ty `thenRn4` \ new_ty ->
- returnRn4 (Unbanged new_ty)
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{SPECIALIZE data pragmas}
-%* *
-%*********************************************************
-
-\begin{code}
-rnSpecDataSig :: ProtoNameSpecDataSig
- -> Rn4M RenamedSpecDataSig
-
-rnSpecDataSig (SpecDataSig tycon ty src_loc)
- = pushSrcLocRn4 src_loc (
- let
- tyvars = extractMonoTyNames eqProtoName ty
- in
- mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env,_) ->
- lookupTyCon tycon `thenRn4` \ tycon' ->
- rnMonoType False tv_env ty `thenRn4` \ ty' ->
- returnRn4 (SpecDataSig tycon' ty' src_loc)
- )
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Class declarations}
-%* *
-%*********************************************************
-
-@rnClassDecl@ uses the `global name function' to create a new
-class declaration in which local names have been replaced by their
-original names, reporting any unknown names.
-
-\begin{code}
-rnClassDecl :: ProtoNameClassDecl -> Rn4M RenamedClassDecl
-
-rnClassDecl (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)
- = pushSrcLocRn4 src_loc (
- mkTyVarNamesEnv src_loc [tyvar] `thenRn4` \ (tv_env, [tyvar']) ->
- rnContext tv_env context `thenRn4` \ context' ->
- lookupClass cname `thenRn4` \ cname' ->
- mapRn4 (rn_op cname' tv_env) sigs `thenRn4` \ sigs' ->
- rnMethodBinds cname' mbinds `thenRn4` \ mbinds' ->
- recoverQuietlyRn4 NoClassPragmas (
- rnClassPragmas pragmas
- ) `thenRn4` \ pragmas' ->
- returnRn4 (ClassDecl context' cname' tyvar' sigs' mbinds' pragmas' src_loc)
- )
- where
- rn_op clas tv_env (ClassOpSig op ty pragma locn)
- = pushSrcLocRn4 locn (
- lookupClassOp clas op `thenRn4` \ op_name ->
- rnPolyType False tv_env ty `thenRn4` \ new_ty ->
-
-{-
-*** Please check here that tyvar' appears in new_ty ***
-*** (used to be in tcClassSig, but it's better here)
-*** not_elem = isn'tIn "tcClassSigs"
-*** -- Check that the class type variable is mentioned
-*** checkTc (clas_tyvar `not_elem` extractTyVarTemplatesFromTy local_ty)
-*** (methodTypeLacksTyVarErr clas_tyvar (_UNPK_ op_name) src_loc) `thenTc_`
--}
- recoverQuietlyRn4 NoClassOpPragmas (
- rnClassOpPragmas pragma
- ) `thenRn4` \ new_pragma ->
- returnRn4 (ClassOpSig op_name new_ty new_pragma locn)
- )
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Instance declarations}
-%* *
-%*********************************************************
-
-
-@rnInstDecl@ uses the `global name function' to create a new of
-instance declaration in which local names have been replaced by their
-original names, reporting any unknown names.
-
-\begin{code}
-rnInstDecl :: ProtoNameInstDecl -> Rn4M RenamedInstDecl
-
-rnInstDecl (InstDecl cname ty mbinds from_here modname uprags pragmas src_loc)
- = pushSrcLocRn4 src_loc (
- let
- tyvars = extract_poly_ty_names ty
- in
- mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env,_) ->
- lookupClass cname `thenRn4` \ cname' ->
-
- rnPolyType False{-no invisibles-} [] ty
- -- The "[]" was tv_env, but that means the InstDecl's tyvars aren't
- -- pinned on the HsForAllType, which they should be.
- -- Urgh! Improve in the new renamer!
-
- `thenRn4` \ ty' ->
- rnMethodBinds cname' mbinds `thenRn4` \ mbinds' ->
- mapRn4 (rn_uprag cname') uprags `thenRn4` \ new_uprags ->
- recoverQuietlyRn4 NoInstancePragmas (
- rnInstancePragmas cname' tv_env pragmas
- ) `thenRn4` \ new_pragmas ->
- returnRn4 (InstDecl cname' ty' mbinds'
- from_here modname new_uprags new_pragmas src_loc)
- )
- where
- rn_uprag class_name (SpecSig op ty using locn)
- = ASSERT(not (maybeToBool using)) -- ToDo: SPEC method with explicit spec_id
- pushSrcLocRn4 src_loc (
- lookupClassOp class_name op `thenRn4` \ op_name ->
- rnPolyType False nullTyVarNamesEnv ty `thenRn4` \ new_ty ->
- returnRn4 (SpecSig op_name new_ty Nothing locn)
- )
- rn_uprag class_name (InlineSig op locn)
- = pushSrcLocRn4 locn (
- lookupClassOp class_name op `thenRn4` \ op_name ->
- returnRn4 (InlineSig op_name locn)
- )
- rn_uprag class_name (DeforestSig op locn)
- = pushSrcLocRn4 locn (
- lookupClassOp class_name op `thenRn4` \ op_name ->
- returnRn4 (DeforestSig op_name locn)
- )
- rn_uprag class_name (MagicUnfoldingSig op str locn)
- = pushSrcLocRn4 locn (
- lookupClassOp class_name op `thenRn4` \ op_name ->
- returnRn4 (MagicUnfoldingSig op_name str locn)
- )
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{@SPECIALIZE instance@ user-pragmas}
-%* *
-%*********************************************************
-
-\begin{code}
-rnSpecInstSig :: ProtoNameSpecInstSig
- -> Rn4M RenamedSpecInstSig
-
-rnSpecInstSig (SpecInstSig clas ty src_loc)
- = pushSrcLocRn4 src_loc (
- let tyvars = extractMonoTyNames eqProtoName ty in
- mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env,_) ->
- lookupClass clas `thenRn4` \ new_clas ->
- rnMonoType False tv_env ty `thenRn4` \ new_ty ->
- returnRn4 (SpecInstSig new_clas new_ty src_loc)
- )
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Default declarations}
-%* *
-%*********************************************************
-
-@rnDefaultDecl@ uses the `global name function' to create a new set
-of default declarations in which local names have been replaced by
-their original names, reporting any unknown names.
-
-\begin{code}
-rnDefaultDecl :: [ProtoNameDefaultDecl] -> Rn4M [RenamedDefaultDecl]
-
-rnDefaultDecl [] = returnRn4 []
-rnDefaultDecl [DefaultDecl tys src_loc]
- = pushSrcLocRn4 src_loc $
- mapRn4 (rnMonoType False nullTyVarNamesEnv) tys `thenRn4` \ tys' ->
- returnRn4 [DefaultDecl tys' src_loc]
-rnDefaultDecl defs@(d:ds)
- = addErrRn4 (dupDefaultDeclErr defs) `thenRn4_`
- rnDefaultDecl [d]
-\end{code}
-
-%*************************************************************************
-%* *
-\subsection{Type signatures from interfaces}
-%* *
-%*************************************************************************
-
-Non-interface type signatures (which may include user-pragmas) are
-handled with @HsBinds@.
-
-@ClassOpSigs@ are dealt with in class declarations.
-
-\begin{code}
-rnIntSig :: ProtoNameSig -> Rn4M RenamedSig
-
-rnIntSig (Sig name ty pragma src_loc)
- = pushSrcLocRn4 src_loc (
- lookupValue name `thenRn4` \ new_name ->
- rnPolyType False nullTyVarNamesEnv ty `thenRn4` \ new_ty ->
- recoverQuietlyRn4 NoGenPragmas (
- rnGenPragmas pragma
- ) `thenRn4` \ new_pragma ->
- returnRn4 (Sig new_name new_ty new_pragma src_loc)
- )
-\end{code}
-
-%*************************************************************************
-%* *
-\subsection{Fixity declarations}
-%* *
-%*************************************************************************
-
-\begin{code}
-rnFixes :: [ProtoNameFixityDecl] -> Rn4M [RenamedFixityDecl]
-
-rnFixes fixities
- = mapRn4 rn_fixity fixities `thenRn4` \ fixes_maybe ->
- returnRn4 (catMaybes fixes_maybe)
- where
- rn_fixity (InfixL name i)
- = lookupFixityOp name `thenRn4` \ res ->
- returnRn4 (
- case res of
- Just name2 -> Just (InfixL name2 i)
- Nothing -> Nothing
- )
-
- rn_fixity (InfixR name i)
- = lookupFixityOp name `thenRn4` \ res ->
- returnRn4 (
- case res of
- Just name2 -> Just (InfixR name2 i)
- Nothing -> Nothing
- )
-
- rn_fixity (InfixN name i)
- = lookupFixityOp name `thenRn4` \ res ->
- returnRn4 (
- case res of
- Just name2 -> Just (InfixN name2 i)
- Nothing -> Nothing
- )
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Support code to rename types}
-%* *
-%*********************************************************
-
-\begin{code}
-rnPolyType :: Bool -- True <=> "invisible" tycons (in pragmas) allowed
- -> TyVarNamesEnv
- -> ProtoNamePolyType
- -> Rn4M RenamedPolyType
-
-rnPolyType invisibles_allowed tv_env (HsForAllTy tvs ctxt ty)
- = rn_poly_help invisibles_allowed tv_env tvs ctxt ty
-
-rnPolyType invisibles_allowed tv_env poly_ty@(HsPreForAllTy ctxt ty)
- = rn_poly_help invisibles_allowed tv_env forall_tyvars ctxt ty
- where
- mentioned_tyvars = extract_poly_ty_names poly_ty
-
- forall_tyvars = mentioned_tyvars `minus_list` domTyVarNamesEnv tv_env
-
- -- URGH! Why is this here? SLPJ
- -- Because we are doing very delicate comparisons
- -- (eqProtoName and all that); if we got rid of
- -- that, then we could use ListSetOps stuff. WDP
- minus_list xs ys = [ x | x <- xs, not (x `elemProtoNames` ys)]
-
-------------
-extract_poly_ty_names (HsPreForAllTy ctxt ty)
- = extractCtxtTyNames eqProtoName ctxt
- `union_list`
- extractMonoTyNames eqProtoName ty
- where
- -- see comment above
- union_list [] [] = []
- union_list [] b = b
- union_list a [] = a
- union_list (a:as) b
- | a `elemProtoNames` b = union_list as b
- | otherwise = a : union_list as b
-
-------------
-rn_poly_help :: Bool
- -> TyVarNamesEnv
- -> [ProtoName]
- -> ProtoNameContext
- -> ProtoNameMonoType
- -> Rn4M RenamedPolyType
-
-rn_poly_help invisibles_allowed tv_env tyvars ctxt ty
- = getSrcLocRn4 `thenRn4` \ src_loc ->
- mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env1, new_tyvars) ->
- let
- tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
- in
- rnContext tv_env2 ctxt `thenRn4` \ new_ctxt ->
- rnMonoType invisibles_allowed tv_env2 ty `thenRn4` \ new_ty ->
- returnRn4 (HsForAllTy new_tyvars new_ctxt new_ty)
-\end{code}
-
-\begin{code}
-rnMonoType :: Bool -- allowed to look at invisible tycons
- -> TyVarNamesEnv
- -> ProtoNameMonoType
- -> Rn4M RenamedMonoType
-
-rnMonoType invisibles_allowed tv_env (MonoTyVar tyvar)
- = lookupTyVarName tv_env tyvar `thenRn4` \ tyvar' ->
- returnRn4 (MonoTyVar tyvar')
-
-rnMonoType invisibles_allowed tv_env (MonoListTy ty)
- = rnMonoType invisibles_allowed tv_env ty `thenRn4` \ ty' ->
- returnRn4 (MonoListTy ty')
-
-rnMonoType invisibles_allowed tv_env (MonoFunTy ty1 ty2)
- = andRn4 MonoFunTy (rnMonoType invisibles_allowed tv_env ty1)
- (rnMonoType invisibles_allowed tv_env ty2)
-
-rnMonoType invisibles_allowed tv_env (MonoTupleTy tys)
- = mapRn4 (rnMonoType invisibles_allowed tv_env) tys `thenRn4` \ tys' ->
- returnRn4 (MonoTupleTy tys')
-
-rnMonoType invisibles_allowed tv_env (MonoTyApp name tys)
- = let
- lookup_fn = if isAvarid (getOccurrenceName name)
- then lookupTyVarName tv_env
- else if invisibles_allowed
- then lookupTyConEvenIfInvisible
- else lookupTyCon
- in
- lookup_fn name `thenRn4` \ name' ->
- mapRn4 (rnMonoType invisibles_allowed tv_env) tys `thenRn4` \ tys' ->
- returnRn4 (MonoTyApp name' tys')
-
--- for unfoldings only:
-
-rnMonoType invisibles_allowed tv_env (MonoForAllTy tyvars_w_kinds ty)
- = getSrcLocRn4 `thenRn4` \ src_loc ->
- mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env1, new_tyvars) ->
- let
- tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
- in
- rnMonoType invisibles_allowed tv_env2 ty `thenRn4` \ ty' ->
- returnRn4 (MonoForAllTy (new_tyvars `zip` kinds) ty')
- where
- (tyvars, kinds) = unzip tyvars_w_kinds
-
-rnMonoType invisibles_allowed tv_env (MonoDictTy clas ty)
- = lookupClass clas `thenRn4` \ new_clas ->
- rnMonoType invisibles_allowed tv_env ty `thenRn4` \ new_ty ->
- returnRn4 (MonoDictTy new_clas new_ty)
-\end{code}
-
-\begin{code}
-rnContext :: TyVarNamesEnv -> ProtoNameContext -> Rn4M RenamedContext
-
-rnContext tv_env ctxt
- = mapRn4 rn_ctxt ctxt
- where
- rn_ctxt (clas, tyvar)
- = lookupClass clas `thenRn4` \ clas_name ->
- lookupTyVarName tv_env tyvar `thenRn4` \ tyvar_name ->
- returnRn4 (clas_name, tyvar_name)
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Support code to rename various pragmas}
-%* *
-%*********************************************************
-
-\begin{code}
-rnDataPragmas tv_env (DataPragmas cons specs)
- = rnConDecls tv_env True{-invisibles allowed-} cons `thenRn4` \ new_cons ->
- mapRn4 types_n_spec specs `thenRn4` \ new_specs ->
- returnRn4 (DataPragmas new_cons new_specs)
- where
- types_n_spec ty_maybes
- = mapRn4 (rn_ty_maybe nullTyVarNamesEnv) ty_maybes
-\end{code}
-
-\begin{code}
-rnClassOpPragmas NoClassOpPragmas = returnRn4 NoClassOpPragmas
-
-rnClassOpPragmas (ClassOpPragmas dsel defm)
- = recoverQuietlyRn4 NoGenPragmas (rnGenPragmas dsel) `thenRn4` \ new_dsel ->
- recoverQuietlyRn4 NoGenPragmas (rnGenPragmas defm) `thenRn4` \ new_defm ->
- returnRn4 (ClassOpPragmas new_dsel new_defm)
-\end{code}
-
-\begin{code}
-rnClassPragmas NoClassPragmas = returnRn4 NoClassPragmas
-
-rnClassPragmas (SuperDictPragmas sds)
- = mapRn4 rnGenPragmas sds `thenRn4` \ new_sds ->
- returnRn4 (SuperDictPragmas new_sds)
-\end{code}
-
-NB: In various cases around here, we don't @recoverQuietlyRn4@ around
-calls to @rnGenPragmas@; not really worth it.
-
-\begin{code}
-rnInstancePragmas _ _ NoInstancePragmas = returnRn4 NoInstancePragmas
-
-rnInstancePragmas _ _ (SimpleInstancePragma dfun)
- = rnGenPragmas dfun `thenRn4` \ new_dfun ->
- returnRn4 (SimpleInstancePragma new_dfun)
-
-rnInstancePragmas clas tv_env (ConstantInstancePragma dfun constms)
- = recoverQuietlyRn4 NoGenPragmas (
- rnGenPragmas dfun
- ) `thenRn4` \ new_dfun ->
- mapRn4 name_n_gen constms `thenRn4` \ new_constms ->
- returnRn4 (ConstantInstancePragma new_dfun new_constms)
- where
- name_n_gen (op, gen)
- = lookupClassOp clas op `thenRn4` \ new_op ->
- rnGenPragmas gen `thenRn4` \ new_gen ->
- returnRn4 (new_op, new_gen)
-
-rnInstancePragmas clas tv_env (SpecialisedInstancePragma dfun specs)
- = recoverQuietlyRn4 NoGenPragmas (
- rnGenPragmas dfun
- ) `thenRn4` \ new_dfun ->
- mapRn4 types_n_spec specs `thenRn4` \ new_specs ->
- returnRn4 (SpecialisedInstancePragma new_dfun new_specs)
- where
- types_n_spec (ty_maybes, dicts_to_ignore, inst)
- = mapRn4 (rn_ty_maybe tv_env) ty_maybes `thenRn4` \ new_tys ->
- rnInstancePragmas clas tv_env inst `thenRn4` \ new_inst ->
- returnRn4 (new_tys, dicts_to_ignore, new_inst)
-\end{code}
-
-And some general pragma stuff: (Not sure what, if any, of this would
-benefit from a TyVarNamesEnv passed in.... [ToDo])
-\begin{code}
-rnGenPragmas :: ProtoNameGenPragmas -> Rn4M RenamedGenPragmas
-
-rnGenPragmas NoGenPragmas = returnRn4 NoGenPragmas
-
-rnGenPragmas (GenPragmas arity upd def strict unfold specs)
- = recoverQuietlyRn4 NoImpUnfolding (
- rn_unfolding unfold
- ) `thenRn4` \ new_unfold ->
- rn_strictness strict `thenRn4` \ new_strict ->
- recoverQuietlyRn4 [] (
- mapRn4 types_n_gen specs
- ) `thenRn4` \ new_specs ->
- returnRn4 (GenPragmas arity upd def new_strict new_unfold new_specs)
- where
- rn_unfolding NoImpUnfolding = returnRn4 NoImpUnfolding
-
- rn_unfolding (ImpMagicUnfolding str) = returnRn4 (ImpMagicUnfolding str)
-
- rn_unfolding (ImpUnfolding guidance core)
- = rn_core nullTyVarNamesEnv core `thenRn4` \ new_core ->
- returnRn4 (ImpUnfolding guidance new_core)
-
- ------------
- rn_strictness NoImpStrictness = returnRn4 NoImpStrictness
-
- rn_strictness (ImpStrictness is_bot ww_info wrkr_info)
- = recoverQuietlyRn4 NoGenPragmas (
- rnGenPragmas wrkr_info
- ) `thenRn4` \ new_wrkr_info ->
- returnRn4 (ImpStrictness is_bot ww_info new_wrkr_info)
-
- -------------
- types_n_gen (ty_maybes, dicts_to_ignore, gen)
- = mapRn4 (rn_ty_maybe no_env) ty_maybes `thenRn4` \ new_tys ->
- recoverQuietlyRn4 NoGenPragmas (
- rnGenPragmas gen
- ) `thenRn4` \ new_gen ->
- returnRn4 (new_tys, dicts_to_ignore, new_gen)
- where
- no_env = nullTyVarNamesEnv
-
-------------
-rn_ty_maybe tv_env Nothing = returnRn4 Nothing
-
-rn_ty_maybe tv_env (Just ty)
- = rnMonoType True{-invisibles OK-} tv_env ty `thenRn4` \ new_ty ->
- returnRn4 (Just new_ty)
-
-------------
-rn_core tvenv (UfVar v)
- = rn_uf_id tvenv v `thenRn4` \ vname ->
- returnRn4 (UfVar vname)
-
-rn_core tvenv (UfLit lit)
- = returnRn4 (UfLit lit)
-
-rn_core tvenv (UfCon con tys as)
- = lookupValueEvenIfInvisible con `thenRn4` \ new_con ->
- mapRn4 (rn_core_type tvenv) tys `thenRn4` \ new_tys ->
- mapRn4 (rn_atom tvenv) as `thenRn4` \ new_as ->
- returnRn4 (UfCon new_con new_tys new_as)
-
-rn_core tvenv (UfPrim op tys as)
- = rn_core_primop tvenv op `thenRn4` \ new_op ->
- mapRn4 (rn_core_type tvenv) tys `thenRn4` \ new_tys ->
- mapRn4 (rn_atom tvenv) as `thenRn4` \ new_as ->
- returnRn4 (UfPrim new_op new_tys new_as)
-
-rn_core tvenv (UfLam binder body)
- = rn_binder tvenv binder `thenRn4` \ (b,ty) ->
- extendSS [b] (rn_core tvenv body) `thenRn4` \ new_body ->
- returnRn4 (UfLam (b,ty) new_body)
-
-rn_core tvenv (UfApp fun arg)
- = rn_core tvenv fun `thenRn4` \ new_fun ->
- rn_atom tvenv arg `thenRn4` \ new_arg ->
- returnRn4 (UfApp new_fun new_arg)
-
-rn_core tvenv (UfCase expr alts)
- = rn_core tvenv expr `thenRn4` \ new_expr ->
- rn_alts alts `thenRn4` \ new_alts ->
- returnRn4 (UfCase new_expr new_alts)
- where
- rn_alts (UfCoAlgAlts alg_alts deflt)
- = mapRn4 rn_alg_alt alg_alts `thenRn4` \ new_alts ->
- rn_deflt deflt `thenRn4` \ new_deflt ->
- returnRn4 (UfCoAlgAlts new_alts new_deflt)
- where
- rn_alg_alt (con, params, rhs)
- = lookupValueEvenIfInvisible con `thenRn4` \ new_con ->
- mapRn4 (rn_binder tvenv) params `thenRn4` \ new_params ->
- let
- bs = [ b | (b, ty) <- new_params ]
- in
- extendSS bs (rn_core tvenv rhs) `thenRn4` \ new_rhs ->
- returnRn4 (new_con, new_params, new_rhs)
-
- rn_alts (UfCoPrimAlts prim_alts deflt)
- = mapRn4 rn_prim_alt prim_alts `thenRn4` \ new_alts ->
- rn_deflt deflt `thenRn4` \ new_deflt ->
- returnRn4 (UfCoPrimAlts new_alts new_deflt)
- where
- rn_prim_alt (lit, rhs)
- = rn_core tvenv rhs `thenRn4` \ new_rhs ->
- returnRn4 (lit, new_rhs)
-
- rn_deflt UfCoNoDefault = returnRn4 UfCoNoDefault
- rn_deflt (UfCoBindDefault b rhs)
- = rn_binder tvenv b `thenRn4` \ new_b@(binder, ty) ->
- extendSS [binder] (rn_core tvenv rhs) `thenRn4` \ new_rhs ->
- returnRn4 (UfCoBindDefault new_b new_rhs)
-
-rn_core tvenv (UfLet bind body)
- = rn_bind bind `thenRn4` \ (new_bind, new_binders) ->
- extendSS new_binders (rn_core tvenv body) `thenRn4` \ new_body ->
- returnRn4 (UfLet new_bind new_body)
- where
- rn_bind (UfCoNonRec b rhs)
- = rn_binder tvenv b `thenRn4` \ new_b@(binder, ty) ->
- rn_core tvenv rhs `thenRn4` \ new_rhs ->
- returnRn4 (UfCoNonRec new_b new_rhs, [binder])
-
- rn_bind (UfCoRec pairs)
- = -- conjure up Names; we do this differently than
- -- elsewhere for Core, because of the recursion here;
- -- no deep issue.
- -- [BEFORE IT WAS "FIXED"... 94/05...]
- -- [Andy -- It *was* a 'deep' issue to me...]
- -- [Will -- Poor wee soul.]
-
- getSrcLocRn4 `thenRn4` \ locn ->
- namesFromProtoNames "core variable"
- [ (b, locn) | ((b,_),_) <- pairs] `thenRn4` \ binders ->
-
- extendSS binders (mapRn4 rn_pair (pairs `zip` binders)) `thenRn4` \ new_pairs ->
- returnRn4 (UfCoRec new_pairs, binders)
- where
- rn_pair (((b, ty), rhs), new_b)
- = rn_core_type tvenv ty `thenRn4` \ new_ty ->
- rn_core tvenv rhs `thenRn4` \ new_rhs ->
- returnRn4 ((new_b, new_ty), new_rhs)
-
-rn_core tvenv (UfSCC uf_cc body)
- = rn_cc uf_cc `thenRn4` \ new_cc ->
- rn_core tvenv body `thenRn4` \ new_body ->
- returnRn4 (UfSCC new_cc new_body)
- where
- rn_cc (UfAutoCC id m g is_dupd is_caf)
- = rn_uf_id tvenv id `thenRn4` \ new_id ->
- returnRn4 (UfAutoCC new_id m g is_dupd is_caf)
-
- rn_cc (UfDictCC id m g is_caf is_dupd)
- = rn_uf_id tvenv id `thenRn4` \ new_id ->
- returnRn4 (UfDictCC new_id m g is_dupd is_caf)
-
- -- the rest are boring:
- rn_cc (UfPreludeDictsCC d) = returnRn4 (UfPreludeDictsCC d)
- rn_cc (UfAllDictsCC m g d) = returnRn4 (UfAllDictsCC m g d)
- rn_cc (UfUserCC n m g d c) = returnRn4 (UfUserCC n m g d c)
-
-------------
-rn_core_primop tvenv (UfCCallOp str is_casm may_gc arg_tys res_ty)
- = mapRn4 (rn_core_type tvenv) arg_tys `thenRn4` \ new_arg_tys ->
- rn_core_type tvenv res_ty `thenRn4` \ new_res_ty ->
- returnRn4 (UfCCallOp str is_casm may_gc new_arg_tys new_res_ty)
-rn_core_primop tvenv (UfOtherOp op)
- = returnRn4 (UfOtherOp op)
-
-------------
-rn_uf_id tvenv (BoringUfId v)
- = lookupValueEvenIfInvisible v `thenRn4` \ vname ->
- returnRn4 (BoringUfId vname)
-
-rn_uf_id tvenv (SuperDictSelUfId c sc)
- = lookupClass{-EvenIfInvisible-} c `thenRn4` \ new_c ->
- lookupClass{-EvenIfInvisible-} sc `thenRn4` \ new_sc ->
- returnRn4 (SuperDictSelUfId new_c new_sc)
-
-rn_uf_id tvenv (ClassOpUfId c op)
- = lookupClass{-EvenIfInvisible-} c `thenRn4` \ new_c ->
- lookupClassOp{-EvenIfInvisible-} new_c op `thenRn4` \ new_op ->
- returnRn4 (ClassOpUfId new_c new_op)
-
-rn_uf_id tvenv (DictFunUfId c ty)
- = lookupClass{-EvenIfInvisible-} c `thenRn4` \ new_c ->
- rn_core_type tvenv ty `thenRn4` \ new_ty ->
- returnRn4 (DictFunUfId new_c new_ty)
-
-rn_uf_id tvenv (ConstMethodUfId c op ty)
- = lookupClass{-EvenIfInvisible-} c `thenRn4` \ new_c ->
- lookupClassOp{-EvenIfInvisible-} new_c op `thenRn4` \ new_op ->
- rn_core_type tvenv ty `thenRn4` \ new_ty ->
- returnRn4 (ConstMethodUfId new_c new_op new_ty)
-
-rn_uf_id tvenv (DefaultMethodUfId c op)
- = lookupClass{-EvenIfInvisible-} c `thenRn4` \ new_c ->
- lookupClassOp{-EvenIfInvisible-} new_c op `thenRn4` \ new_op ->
- returnRn4 (DefaultMethodUfId new_c new_op)
-
-rn_uf_id tvenv (SpecUfId unspec ty_maybes)
- = rn_uf_id tvenv unspec `thenRn4` \ new_unspec ->
- mapRn4 (rn_ty_maybe tvenv) ty_maybes `thenRn4` \ new_ty_maybes ->
- returnRn4 (SpecUfId new_unspec new_ty_maybes)
-
-rn_uf_id tvenv (WorkerUfId unwrkr)
- = rn_uf_id tvenv unwrkr `thenRn4` \ new_unwrkr ->
- returnRn4 (WorkerUfId new_unwrkr)
-
-------------
-rn_binder tvenv (b, ty)
- = getSrcLocRn4 `thenRn4` \ src_loc ->
- namesFromProtoNames "binder in core unfolding" [(b, src_loc)]
- `thenRn4` \ [new_b] ->
- rn_core_type tvenv ty `thenRn4` \ new_ty ->
- returnRn4 (new_b, new_ty)
-
-------------
-rn_atom tvenv (UfCoLitAtom l) = returnRn4 (UfCoLitAtom l)
-rn_atom tvenv (UfCoVarAtom v)
- = rn_uf_id tvenv v `thenRn4` \ vname ->
- returnRn4 (UfCoVarAtom vname)
-
-------------
-rn_core_type_maybe tvenv Nothing = returnRn4 Nothing
-rn_core_type_maybe tvenv (Just ty)
- = rn_core_type tvenv ty `thenRn4` \ new_ty ->
- returnRn4 (Just new_ty)
-
-------------
-rn_core_type tvenv ty
- = rnPolyType True{-invisible tycons OK-} tvenv ty
-\end{code}
-
-
-\begin{code}
-derivingNonStdClassErr clas locn sty
- = ppHang (ppStr "Non-standard class in deriving")
- 4 (ppCat [ppr sty clas, ppr sty locn])
-
-dupDefaultDeclErr defs sty
- = ppHang (ppStr "Duplicate default declarations")
- 4 (ppAboves (map pp_def_loc defs))
- where
- pp_def_loc (DefaultDecl _ src_loc) = ppr sty src_loc
-\end{code}
projects / ghc-hetmet.git / commitdiff