%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
-\section[RenameBinds4]{Renaming and dependency analysis of bindings}
+\section[RnBinds4]{Renaming and dependency analysis of bindings}
This module does renaming and dependency analysis on value bindings in
-@AbsSyntax@ programs. It does {\em not} do cycle-checks on class or
+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 RenameBinds4 (
- rnTopBinds4, rnMethodBinds4,
- rnBinds4,
- FreeVars(..), DefinedVars(..),
+module RnBinds4 (
+ rnTopBinds, rnMethodBinds,
+ rnBinds,
+ FreeVars(..), DefinedVars(..)
-- and to make the interface self-sufficient...
- Bag, Binds, MonoBinds, InPat, Name, ProtoName,
- GlobalNameFun(..), Maybe, UniqSet(..), UniqFM, SrcLoc, Unique,
- SplitUniqSupply, Error(..), Pretty(..), PprStyle,
- PrettyRep
) where
-import AbsSyn
-import CmdLineOpts ( GlobalSwitch(..) )
-import Digraph ( stronglyConnComp {- MOVED HERE: , isCyclic -} )
-import Errors -- ( unknownSigDeclErr, dupSigDeclErr, methodBindErr )
-import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ******
-import Maybes ( catMaybes, Maybe(..) )
-import Name ( eqName, cmpName, isUnboundName )
-import ProtoName ( elemByLocalNames, eqByLocalName )
-import Rename4 ( rnPolyType4, rnGenPragmas4 )
-import RenameAuxFuns ( GlobalNameFuns(..) )
-import RenameMonad4
-import RenameExpr4 ( rnMatch4, rnGRHSsAndBinds4, rnPat4 )
-import UniqSet
-import Util
+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, singletonUniqSet, mkUniqSet,
+ unionUniqSets, unionManyUniqSets,
+ elementOfUniqSet,
+ 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 @rnBinds4@ contains definitions
+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}
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 @rnBinds4@ does.
+This is precisely what the function @rnBinds@ does.
ToDo: deal with case where a single monobinds binds the same variable
twice.
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 (Binds) and qualifier lists in
+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.
%************************************************************************
%* *
-%* analysing polymorphic bindings (Binds, Bind, MonoBinds) *
+%* analysing polymorphic bindings (HsBinds, Bind, MonoBinds) *
%* *
%************************************************************************
-\subsubsection[dep-Binds]{Polymorphic bindings}
+\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.
union of those in the previous set plus those of the newest binding after
the defined variables of the previous set have been removed.
-@rnMethodBinds4@ deals only with the declarations in class and
+@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}
-rnTopBinds4 :: ProtoNameBinds -> Rn4M RenamedBinds
-rnMethodBinds4 :: Name{-class-} -> ProtoNameMonoBinds -> Rn4M RenamedMonoBinds
-rnBinds4 :: ProtoNameBinds -> Rn4M (RenamedBinds, FreeVars, [Name])
+rnTopBinds :: ProtoNameHsBinds -> Rn4M RenamedHsBinds
+rnMethodBinds :: Name{-class-} -> ProtoNameMonoBinds -> Rn4M RenamedMonoBinds
+rnBinds :: ProtoNameHsBinds -> Rn4M (RenamedHsBinds, FreeVars, [Name])
-rnTopBinds4 EmptyBinds = returnRn4 EmptyBinds
-rnTopBinds4 (SingleBind (RecBind bind)) = rnTopMonoBinds4 bind []
-rnTopBinds4 (BindWith (RecBind bind) sigs) = rnTopMonoBinds4 bind sigs
+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
-- ********************************************************************
-rnMethodBinds4 class_name EmptyMonoBinds = returnRn4 EmptyMonoBinds
+rnMethodBinds class_name EmptyMonoBinds = returnRn4 EmptyMonoBinds
-rnMethodBinds4 class_name (AndMonoBinds mb1 mb2)
- = andRn4 AndMonoBinds (rnMethodBinds4 class_name mb1)
- (rnMethodBinds4 class_name mb2)
+rnMethodBinds class_name (AndMonoBinds mb1 mb2)
+ = andRn4 AndMonoBinds (rnMethodBinds class_name mb1)
+ (rnMethodBinds class_name mb2)
-rnMethodBinds4 class_name (FunMonoBind pname matches locn)
+rnMethodBinds class_name (FunMonoBind pname matches locn)
= pushSrcLocRn4 locn (
lookupClassOp class_name pname `thenRn4` \ op_name ->
- mapAndUnzipRn4 rnMatch4 matches `thenRn4` \ (new_matches, _) ->
+ mapAndUnzipRn4 rnMatch matches `thenRn4` \ (new_matches, _) ->
returnRn4 (FunMonoBind op_name new_matches locn)
)
-rnMethodBinds4 class_name (PatMonoBind (VarPatIn pname) grhss_and_binds locn)
+rnMethodBinds class_name (PatMonoBind (VarPatIn pname) grhss_and_binds locn)
= pushSrcLocRn4 locn (
lookupClassOp class_name pname `thenRn4` \ op_name ->
- rnGRHSsAndBinds4 grhss_and_binds `thenRn4` \ (grhss_and_binds', _) ->
+ 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.
-rnMethodBinds4 _ mbind@(PatMonoBind other_pat _ locn)
+rnMethodBinds _ mbind@(PatMonoBind other_pat _ locn)
= failButContinueRn4 EmptyMonoBinds (methodBindErr mbind locn)
-- ********************************************************************
-rnBinds4 EmptyBinds = returnRn4 (EmptyBinds,emptyUniqSet,[])
-rnBinds4 (SingleBind (RecBind bind)) = rnNestedMonoBinds4 bind []
-rnBinds4 (BindWith (RecBind bind) sigs) = rnNestedMonoBinds4 bind sigs
+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}
-@rnNestedMonoBinds4@
+@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 @rnMonoBinds4@ to do the real work
+ - calls @rnMonoBinds@ to do the real work
-In contrast, @rnTopMonoBinds4@ doesn't extend the environment, because that's
-already done in pass3. All it does is call @rnMonoBinds4@ and discards
+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}
-rnTopMonoBinds4 :: ProtoNameMonoBinds -> [ProtoNameSig] -> Rn4M RenamedBinds
+rnTopMonoBinds :: ProtoNameMonoBinds -> [ProtoNameSig] -> Rn4M RenamedHsBinds
-rnTopMonoBinds4 EmptyMonoBinds sigs = returnRn4 EmptyBinds
+rnTopMonoBinds EmptyMonoBinds sigs = returnRn4 EmptyBinds
-rnTopMonoBinds4 mbs sigs
- = rnBindSigs4 True{-top-level-} (collectMonoBinders mbs) sigs `thenRn4` \ siglist ->
- rnMonoBinds4 mbs siglist `thenRn4` \ (new_binds, fv_set) ->
+rnTopMonoBinds mbs sigs
+ = rnBindSigs True{-top-level-} (collectMonoBinders mbs) sigs `thenRn4` \ siglist ->
+ rnMonoBinds mbs siglist `thenRn4` \ (new_binds, fv_set) ->
returnRn4 new_binds
-rnNestedMonoBinds4 :: ProtoNameMonoBinds -> [ProtoNameSig]
- -> Rn4M (RenamedBinds, FreeVars, [Name])
+rnNestedMonoBinds :: ProtoNameMonoBinds -> [ProtoNameSig]
+ -> Rn4M (RenamedHsBinds, FreeVars, [Name])
-rnNestedMonoBinds4 EmptyMonoBinds sigs
+rnNestedMonoBinds EmptyMonoBinds sigs
= returnRn4 (EmptyBinds, emptyUniqSet, [])
-rnNestedMonoBinds4 mbinds sigs -- Non-empty monobinds
+rnNestedMonoBinds mbinds sigs -- Non-empty monobinds
=
-- Extract all the binders in this group,
-- and extend current scope, inventing new names for the new binders
mbinders_w_srclocs `thenRn4` \ new_mbinders ->
extendSS2 new_mbinders (
- rnBindSigs4 False{-not top- level-} mbinders sigs `thenRn4` \ siglist ->
- rnMonoBinds4 mbinds siglist
+ 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}
-@rnMonoBinds4@ is used by *both* top-level and nested bindings. It
+@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 @rnNestedMonoBinds4@ (for the nested ones).
+*or* by @rnNestedMonoBinds@ (for the nested ones).
\begin{code}
-rnMonoBinds4 :: ProtoNameMonoBinds
+rnMonoBinds :: ProtoNameMonoBinds
-> [RenamedSig] -- Signatures attached to this group
- -> Rn4M (RenamedBinds, FreeVars)
+ -> Rn4M (RenamedHsBinds, FreeVars)
-rnMonoBinds4 mbinds siglist
+rnMonoBinds mbinds siglist
=
-- Rename the bindings, returning a MonoBindsInfo
-- which is a list of indivisible vertices so far as
- -- the SCC analysis is concerned
+ -- the strongly-connected-components (SCC) analysis is concerned
flattenMonoBinds 0 siglist mbinds `thenRn4` \ (_, mbinds_info) ->
-- Do the SCC analysis
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
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
+ = case [(n, locn) | (InlineSig n locn) <- sigs ] of
[] -> Nothing
- sigh ->
+ sigh ->
#if OMIT_DEFORESTER
Just sigh
#else
flattenMonoBinds uniq sigs (PatMonoBind pat grhss_and_binds locn)
= pushSrcLocRn4 locn (
- rnPat4 pat `thenRn4` \ pat' ->
- rnGRHSsAndBinds4 grhss_and_binds `thenRn4` \ (grhss_and_binds', fvs) ->
+ rnPat pat `thenRn4` \ pat' ->
+ rnGRHSsAndBinds grhss_and_binds `thenRn4` \ (grhss_and_binds', fvs) ->
-- Find which things are bound in this group
let
flattenMonoBinds uniq sigs (FunMonoBind name matches locn)
= pushSrcLocRn4 locn (
lookupValue name `thenRn4` \ name' ->
- mapAndUnzipRn4 rnMatch4 matches `thenRn4` \ (new_matches, fv_lists) ->
+ mapAndUnzipRn4 rnMatch matches `thenRn4` \ (new_matches, fv_lists) ->
let
fvs = unionManyUniqSets fv_lists
- sigs_for_me = foldl (sig_for_here (\ n -> n `eqName` name')) [] sigs
+ 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,
- singletonUniqSet name',
+ singletonUniqSet name',
fvs `unionUniqSets` sigs_fvs,
FunMonoBind name' new_matches locn,
sigs_for_me
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@(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
+ | want_me n = s:acc
sig_for_here want_me acc other_wise = acc
-- If a SPECIALIZE pragma is of the "... = blah" form,
as the two cases are similar.
\begin{code}
-reconstructRec :: [Cycle] -- Result of SCC analysis; at least one
- -> [Edge] -- Original edges
+reconstructRec :: [Cycle] -- Result of SCC analysis; at least one
+ -> [Edge] -- Original edges
-> FlatMonoBindsInfo
- -> RenamedBinds
+ -> RenamedHsBinds
reconstructRec cycles edges mbi
= foldr1 ThenBinds (map (reconstructCycle mbi) cycles)
where
- reconstructCycle :: FlatMonoBindsInfo -> Cycle -> RenamedBinds
+ reconstructCycle :: FlatMonoBindsInfo -> Cycle -> RenamedHsBinds
reconstructCycle mbi2 cycle
= BIND [(binds,sigs) | (vertex, _, _, binds, sigs) <- mbi2, vertex `is_elem` cycle]
is_elem = isIn "reconstructRec"
mk_binds :: RenamedMonoBinds -> [RenamedSig]
- -> Bool -> Bool -> RenamedBinds
+ -> Bool -> Bool -> RenamedHsBinds
mk_binds bs ss True False = SingleBind (RecBind bs)
mk_binds bs ss True True{-have sigs-} = BindWith (RecBind bs) ss
%* *
%************************************************************************
-@rnBindSigs4@ checks for: (a)~more than one sig for one thing;
+@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}
-rnBindSigs4 :: Bool -- True <=> top-level binders
+rnBindSigs :: Bool -- True <=> top-level binders
-> [ProtoName] -- Binders for this decl group
- -> [ProtoNameSig]
+ -> [ProtoNameSig]
-> Rn4M [RenamedSig] -- List of Sig constructors
-rnBindSigs4 is_toplev binder_pnames sigs
+rnBindSigs is_toplev binder_pnames sigs
=
-- Rename the signatures
-- Will complain about sigs for variables not in this group
-- Discard unbound ones we've already complained about, so we
-- complain about duplicate ones.
- (goodies, dups) = removeDups cmp (filter not_unbound sigs')
+ (goodies, dups) = removeDups compare (filter not_unbound sigs')
in
mapRn4 (addErrRn4 . dupSigDeclErr) dups `thenRn4_`
- getSwitchCheckerRn4 `thenRn4` \ sw_chkr ->
getSrcLocRn4 `thenRn4` \ locn ->
- (if (is_toplev && sw_chkr SigsRequired) then
+ (if (is_toplev && opt_SigsRequired) then
let
sig_frees = catMaybes (map (sig_free sigs) binder_pnames)
in
returnRn4 Nothing
else
lookupValue v `thenRn4` \ new_v ->
- rnPolyType4 False True nullTyVarNamesEnv ty `thenRn4` \ new_ty ->
- recoverQuietlyRn4 NoGenPragmas (
- rnGenPragmas4 pragma
+ 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))
)
returnRn4 Nothing
else
lookupValue v `thenRn4` \ new_v ->
- rnPolyType4 False True nullTyVarNamesEnv ty `thenRn4` \ new_ty ->
+ rnPolyType False nullTyVarNamesEnv ty `thenRn4` \ new_ty ->
rn_using using `thenRn4` \ new_using ->
returnRn4 (Just (SpecSig new_v new_ty new_using src_loc))
)
rn_using (Just x) = lookupValue x `thenRn4` \ new_x ->
returnRn4 (Just new_x)
- rename_sig (InlineSig v howto src_loc)
+ rename_sig (InlineSig v src_loc)
= pushSrcLocRn4 src_loc (
if not (v `elemByLocalNames` binder_pnames) then
returnRn4 Nothing
else
lookupValue v `thenRn4` \ new_v ->
- returnRn4 (Just (InlineSig new_v howto src_loc))
+ returnRn4 (Just (InlineSig new_v src_loc))
)
rename_sig (DeforestSig v src_loc)
not_unbound (Sig n _ _ _) = not (isUnboundName n)
not_unbound (SpecSig n _ _ _) = not (isUnboundName n)
- not_unbound (InlineSig 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 (_ : rest) ny = sig_free rest ny
-------------------------------------
- cmp :: RenamedSig -> RenamedSig -> TAG_
+ compare :: RenamedSig -> RenamedSig -> TAG_
+ compare x y = c x y
- cmp (Sig n1 _ _ _) (Sig n2 _ _ _) = n1 `cmpName` n2
- cmp (InlineSig n1 _ _) (InlineSig n2 _ _) = n1 `cmpName` n2
- cmp (MagicUnfoldingSig n1 _ _) (MagicUnfoldingSig n2 _ _) = n1 `cmpName` n2
- cmp (SpecSig n1 ty1 _ _) (SpecSig n2 ty2 _ _)
+ 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 `cmpName` n2) of
- EQ_ -> cmpPolyType cmpName ty1 ty2
+ case (n1 `cmp` n2) of
+ EQ_ -> cmpPolyType cmp ty1 ty2
other -> other
- cmp other_1 other_2 -- tags *must* be different
+ c other_1 other_2 -- tags *must* be different
= let tag1 = tag other_1
tag2 = tag other_2
in
tag (Sig n1 _ _ _) = (ILIT(1) :: FAST_INT)
tag (SpecSig n1 _ _ _) = ILIT(2)
- tag (InlineSig n1 _ _) = ILIT(3)
+ tag (InlineSig n1 _) = ILIT(3)
tag (MagicUnfoldingSig n1 _ _) = ILIT(4)
tag (DeforestSig n1 _) = ILIT(5)
- tag _ = case (panic "tag(RenameBinds4)") of { s -> tag s } -- BUG avoidance
+ 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}
projects / ghc-hetmet.git / blobdiff