From: partain Date: Sun, 7 Apr 1996 15:36:51 +0000 (+0000) Subject: [project @ 1996-04-07 15:36:47 by partain] X-Git-Tag: Approximately_1000_patches_recorded~931 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=e5401e80e37622869b31d646a25da413c6801bae [project @ 1996-04-07 15:36:47 by partain] Remove some Rn* files to make way for new renamer --- diff --git a/ghc/compiler/rename/RnBinds4.lhs b/ghc/compiler/rename/RnBinds4.lhs deleted file mode 100644 index 57303d8..0000000 --- a/ghc/compiler/rename/RnBinds4.lhs +++ /dev/null @@ -1,709 +0,0 @@ -% -% (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} diff --git a/ghc/compiler/rename/RnExpr4.lhs b/ghc/compiler/rename/RnExpr4.lhs deleted file mode 100644 index 99f0b75..0000000 --- a/ghc/compiler/rename/RnExpr4.lhs +++ /dev/null @@ -1,407 +0,0 @@ -% -% (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} diff --git a/ghc/compiler/rename/RnPass1.lhs b/ghc/compiler/rename/RnPass1.lhs deleted file mode 100644 index bd76c69..0000000 --- a/ghc/compiler/rename/RnPass1.lhs +++ /dev/null @@ -1,861 +0,0 @@ -% -% (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} diff --git a/ghc/compiler/rename/RnPass4.lhs b/ghc/compiler/rename/RnPass4.lhs deleted file mode 100644 index 5006d17..0000000 --- a/ghc/compiler/rename/RnPass4.lhs +++ /dev/null @@ -1,882 +0,0 @@ -% -% (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}