import HsSyn ( MonoBinds(..), HsExpr(..), InPat, OutPat, HsLit,
Match, HsBinds, HsType, ArithSeqInfo, Fixity,
GRHSsAndBinds, Stmt, DoOrListComp, Fake )
import HsSyn ( MonoBinds(..), HsExpr(..), InPat, OutPat, HsLit,
Match, HsBinds, HsType, ArithSeqInfo, Fixity,
GRHSsAndBinds, Stmt, DoOrListComp, Fake )
-import TcHsSyn ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcExpr), SYN_IE(TcMonoBinds) )
+import HsBinds ( andMonoBinds )
+import TcHsSyn ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcExpr),
+ SYN_IE(TcMonoBinds), SYN_IE(TcDictBinds) )
import Maybes ( expectJust, firstJust, catMaybes, seqMaybe, maybeToBool )
import Outputable ( Outputable(..){-instance * []-} )
import Maybes ( expectJust, firstJust, catMaybes, seqMaybe, maybeToBool )
import Outputable ( Outputable(..){-instance * []-} )
import PprType ( GenType, GenTyVar )
import Pretty
import SrcLoc ( noSrcLoc )
import PprType ( GenType, GenTyVar )
import Pretty
import SrcLoc ( noSrcLoc )
- -> TcM s (LIE s, -- Free
- [(TcIdOcc s,TcExpr s)]) -- Bindings
+ -> TcM s (LIE s, -- Free
+ TcDictBinds s) -- Bindings
\end{code}
@tcSimplifyTop@ deals with constant @Insts@, using the standard simplification
mechansim with the extra flag to say ``beat out constant insts''.
\begin{code}
\end{code}
@tcSimplifyTop@ deals with constant @Insts@, using the standard simplification
mechansim with the extra flag to say ``beat out constant insts''.
\begin{code}
returnTc (free,binds,irreds)
where
-- eTC :: LIE s -> [Inst s]
returnTc (free,binds,irreds)
where
-- eTC :: LIE s -> [Inst s]
--- -> TcM s (LIE s, LIE s, Bag (TcIdOcc s, TcExpr s), LIE s)
+-- -> TcM s (LIE s, LIE s, TcDictBinds s, LIE s)
- eTC givens [] = returnTc (givens, emptyBag, emptyBag, emptyBag)
+ eTC givens [] = returnTc (givens, emptyBag, EmptyMonoBinds, emptyBag)
| otherwise = binds
in
returnTc (givens1, frees, new_binds, irreds)
| otherwise = binds
in
returnTc (givens1, frees, new_binds, irreds)
- = recoverTc (returnTc (wanted `consBag` givens, emptyLIE, emptyBag, emptyLIE))
+ = recoverTc (returnTc (wanted `consBag` givens, emptyLIE, EmptyMonoBinds, emptyLIE))
(simplify_one simplify_always givens wanted)
`thenTc` \ (givens1, frees1, binds1, irreds1) ->
eTC givens1 wanteds `thenTc` \ (givens2, frees2, binds2, irreds2) ->
returnTc (givens2, frees1 `plusLIE` frees2,
(simplify_one simplify_always givens wanted)
`thenTc` \ (givens1, frees1, binds1, irreds1) ->
eTC givens1 wanteds `thenTc` \ (givens2, frees2, binds2, irreds2) ->
returnTc (givens2, frees1 `plusLIE` frees2,
if (not_var rhs && not simplify_always) then
-- Ho ho! It isn't trivial to simplify "wanted",
-- because the rhs isn't a simple variable. Unless the flag
-- simplify_always is set, just give up now and
-- just fling it out the top.
if (not_var rhs && not simplify_always) then
-- Ho ho! It isn't trivial to simplify "wanted",
-- because the rhs isn't a simple variable. Unless the flag
-- simplify_always is set, just give up now and
-- just fling it out the top.
- returnTc (wanted `consLIE` givens, unitLIE wanted, emptyBag, emptyLIE)
+ returnTc (wanted `consLIE` givens, unitLIE wanted, EmptyMonoBinds, emptyLIE)
else
-- Aha! Either it's easy, or simplify_always is True
-- so we must do it right here.
eTC givens simpler_wanteds `thenTc` \ (givens1, frees1, binds1, irreds1) ->
returnTc (wanted `consLIE` givens1, frees1,
else
-- Aha! Either it's easy, or simplify_always is True
-- so we must do it right here.
eTC givens simpler_wanteds `thenTc` \ (givens1, frees1, binds1, irreds1) ->
returnTc (wanted `consLIE` givens1, frees1,
elimSCs :: LIE s -- Given; no dups
-> LIE s -- Wanted; no dups; all dictionaries, all
-- constraining just a type variable
elimSCs :: LIE s -- Given; no dups
-> LIE s -- Wanted; no dups; all dictionaries, all
-- constraining just a type variable
elimSCs_help givens (wanted:wanteds)
= trySC givens wanted `thenNF_Tc` \ (givens1, binds1, irreds1) ->
elimSCs_help givens1 wanteds `thenNF_Tc` \ (binds2, irreds2) ->
elimSCs_help givens (wanted:wanteds)
= trySC givens wanted `thenNF_Tc` \ (givens1, binds1, irreds1) ->
elimSCs_help givens1 wanteds `thenNF_Tc` \ (binds2, irreds2) ->
LIE s) -- Irreducible wanted set
trySC givens wanted@(Dict _ wanted_class wanted_ty wanted_orig loc)
| not (maybeToBool maybe_best_subclass_chain)
= -- No superclass relationship
LIE s) -- Irreducible wanted set
trySC givens wanted@(Dict _ wanted_class wanted_ty wanted_orig loc)
| not (maybeToBool maybe_best_subclass_chain)
= -- No superclass relationship
let
mk_bind (dict,clas) dict_sub@(Dict _ dict_sub_class ty _ _)
= ((dict_sub, dict_sub_class),
let
mk_bind (dict,clas) dict_sub@(Dict _ dict_sub_class ty _ _)
= ((dict_sub, dict_sub_class),
(_, new_binds) = mapAccumR mk_bind (wanted,wanted_class) (given : intermediates)
in
returnNF_Tc (wanted `consLIE` givens `plusLIE` listToBag intermediates,
(_, new_binds) = mapAccumR mk_bind (wanted,wanted_class) (given : intermediates)
in
returnNF_Tc (wanted `consLIE` givens `plusLIE` listToBag intermediates,
bind_inst some_other_inst (insts, binds)
-- Either not a method, or a method instance for an id not in local_ids
bind_inst some_other_inst (insts, binds)
-- Either not a method, or a method instance for an id not in local_ids
- = ppHang (ppPStr SLIT("Cannot generalise these overloadings (in a _ccall_):"))
- 4 (ppAboves (map (ppr sty) (bagToList insts)))
+ = hang (ptext SLIT("Cannot generalise these overloadings (in a _ccall_):"))
+ 4 (vcat (map (ppr sty) (bagToList insts)))