DefinedVars(..)
) where
-import Ubiq
-import RnLoop -- break the RnPass4/RnExpr4/RnBinds4 loops
+IMP_Ubiq()
+IMPORT_DELOOPER(RnLoop) -- break the RnPass/RnExpr/RnBinds loops
import HsSyn
import HsPragmas ( isNoGenPragmas, noGenPragmas )
import RdrHsSyn
import RnHsSyn
import RnMonad
-import RnExpr ( rnMatch, rnGRHSsAndBinds, rnPat )
+import RnExpr ( rnMatch, rnGRHSsAndBinds, rnPat, checkPrecMatch )
import CmdLineOpts ( opt_SigsRequired )
import Digraph ( stronglyConnComp )
import ErrUtils ( addErrLoc, addShortErrLocLine )
import Name ( RdrName )
import Maybes ( catMaybes )
+import PprStyle--ToDo:rm
import Pretty
import UniqSet ( emptyUniqSet, unitUniqSet, mkUniqSet,
unionUniqSets, unionManyUniqSets,
elementOfUniqSet, uniqSetToList, UniqSet(..) )
-import Util ( thenCmp, isIn, removeDups, panic, panic#, assertPanic )
+import Util ( thenCmp, isIn, removeDups, panic, panic#, assertPanic, pprTrace{-ToDo:rm-} )
\end{code}
-- ToDo: Put the annotations into the monad, so that they arrive in the proper
rnMethodBinds class_name (AndMonoBinds mb1 mb2)
= andRn AndMonoBinds (rnMethodBinds class_name mb1)
- (rnMethodBinds class_name mb2)
+ (rnMethodBinds class_name mb2)
-rnMethodBinds class_name (FunMonoBind occname matches locn)
- = pushSrcLocRn locn $
- lookupClassOp class_name occname `thenRn` \ op_name ->
- mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, _) ->
- returnRn (FunMonoBind op_name new_matches locn)
+rnMethodBinds class_name (FunMonoBind occname inf matches locn)
+ = pushSrcLocRn locn $
+ lookupClassOp class_name occname `thenRn` \ op_name ->
+ mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, _) ->
+ mapRn (checkPrecMatch inf op_name) new_matches `thenRn_`
+ returnRn (FunMonoBind op_name inf new_matches locn)
rnMethodBinds class_name (PatMonoBind (VarPatIn occname) grhss_and_binds locn)
= pushSrcLocRn locn $
-- Do the SCC analysis
let vertices = mkVertices mbinds_info
- edges = mkEdges vertices mbinds_info
+ edges = mkEdges mbinds_info
scc_result = stronglyConnComp (==) edges vertices
flattenMonoBinds uniq sigs EmptyMonoBinds = returnRn (uniq, [])
-flattenMonoBinds uniq sigs (AndMonoBinds mB1 mB2)
- = flattenMonoBinds uniq sigs mB1 `thenRn` \ (uniq1, flat1) ->
- flattenMonoBinds uniq1 sigs mB2 `thenRn` \ (uniq2, flat2) ->
+flattenMonoBinds uniq sigs (AndMonoBinds bs1 bs2)
+ = flattenMonoBinds uniq sigs bs1 `thenRn` \ (uniq1, flat1) ->
+ flattenMonoBinds uniq1 sigs bs2 `thenRn` \ (uniq2, flat2) ->
returnRn (uniq2, flat1 ++ flat2)
flattenMonoBinds uniq sigs (PatMonoBind pat grhss_and_binds locn)
)]
)
-flattenMonoBinds uniq sigs (FunMonoBind name matches locn)
- = pushSrcLocRn locn $
- lookupValue name `thenRn` \ name' ->
- mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, fv_lists) ->
+flattenMonoBinds uniq sigs (FunMonoBind name inf matches locn)
+ = pushSrcLocRn locn $
+ lookupValue name `thenRn` \ name' ->
+ mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, fv_lists) ->
+ mapRn (checkPrecMatch inf name') new_matches `thenRn_`
let
fvs = unionManyUniqSets fv_lists
[(uniq,
unitUniqSet name',
fvs `unionUniqSets` sigs_fvs,
- FunMonoBind name' new_matches locn,
+ FunMonoBind name' inf new_matches locn,
sigs_for_me
)]
)
reconstructCycle :: FlatMonoBindsInfo -> Cycle -> RenamedHsBinds
reconstructCycle mbi2 cycle
- = BIND [(binds,sigs) | (vertex, _, _, binds, sigs) <- mbi2, vertex `is_elem` cycle]
- _TO_ relevant_binds_and_sigs ->
+ = case [(binds,sigs) | (vertex, _, _, binds, sigs) <- mbi2, vertex `is_elem` cycle]
+ of { relevant_binds_and_sigs ->
- BIND (unzip relevant_binds_and_sigs) _TO_ (binds, sig_lists) ->
+ case (unzip relevant_binds_and_sigs) of { (binds, sig_lists) ->
- BIND (foldr AndMonoBinds EmptyMonoBinds binds) _TO_ this_gp_binds ->
+ case (foldr AndMonoBinds EmptyMonoBinds binds) of { this_gp_binds ->
let
this_gp_sigs = foldr1 (++) sig_lists
have_sigs = not (null sig_lists)
-- 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"
]
mkVertices :: FlatMonoBindsInfo -> [VertexTag]
-mkVertices info = [ vertex | (vertex,_,_,_,_) <- info]
+mkEdges :: FlatMonoBindsInfo -> [Edge]
-mkEdges :: [VertexTag] -> FlatMonoBindsInfo -> [Edge]
+mkVertices info = [ vertex | (vertex,_,_,_,_) <- info]
-mkEdges vertices flat_info
+mkEdges 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
- ]
+ = -- pprTrace "mkEdges:" (ppAboves [ppAboves[ppInt v, ppCat [ppr PprDebug d|d <- uniqSetToList defd], ppCat [ppr PprDebug u|u <- uniqSetToList used]] | (v,defd,used,_,_) <- flat_info]) $
+ [ (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}
projects / ghc-hetmet.git / blobdiff