Commit 4edf8929 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

Fix Trac #2045: use big-tuple machiney for implication constraints

parent 9aa2708b
......@@ -797,17 +797,18 @@ mkLHsVarTup ids = mkLHsTup (map nlHsVar ids)
mkLHsTup :: [LHsExpr Id] -> LHsExpr Id
mkLHsTup [] = nlHsVar unitDataConId
mkLHsTup [lexp] = lexp
mkLHsTup lexps = noLoc $ ExplicitTuple lexps Boxed
mkLHsTup lexps = L (getLoc (head lexps)) $
ExplicitTuple lexps Boxed
-- Smart constructors for source tuple patterns
mkLHsVarPatTup :: [Id] -> LPat Id
mkLHsVarPatTup bs = mkLHsPatTup (map nlVarPat bs)
mkLHsPatTup :: [LPat Id] -> LPat Id
mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed
mkLHsPatTup [lpat] = lpat
mkLHsPatTup lpats = noLoc $ mkVanillaTuplePat lpats Boxed -- Handles the case where lpats = [] gracefully
mkLHsPatTup lpats = L (getLoc (head lpats)) $
mkVanillaTuplePat lpats Boxed
-- The Big equivalents for the source tuple expressions
mkBigLHsVarTup :: [Id] -> LHsExpr Id
......@@ -823,7 +824,6 @@ mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)
mkBigLHsPatTup :: [LPat Id] -> LPat Id
mkBigLHsPatTup = mkBigTuple mkLHsPatTup
\end{code}
......
......@@ -33,6 +33,7 @@ import {-# SOURCE #-} TcUnify( unifyType )
import HsSyn
import TcRnMonad
import TcHsSyn ( hsLPatType )
import Inst
import TcEnv
import InstEnv
......@@ -40,6 +41,7 @@ import TcType
import TcMType
import TcIface
import TcTyFuns
import DsUtils -- Big-tuple functions
import TypeRep
import Var
import Name
......@@ -1006,16 +1008,15 @@ makeImplicationBind loc all_tvs
(eq_irreds, dict_irreds) = partition isEqInst irreds
n_dict_irreds = length dict_irreds
dict_irred_ids = map instToId dict_irreds
tup_ty = mkTupleTy Boxed n_dict_irreds (map idType dict_irred_ids)
pat = TuplePat (map nlVarPat dict_irred_ids) Boxed tup_ty
lpat = mkBigLHsPatTup (map (L span . VarPat) dict_irred_ids)
rhs = L span (mkHsWrap co (HsVar (instToId implic_inst)))
co = mkWpApps (map instToId dict_givens)
<.> mkWpTyApps eq_tyvar_cos
<.> mkWpTyApps (mkTyVarTys all_tvs)
bind | [dict_irred_id] <- dict_irred_ids = VarBind dict_irred_id rhs
| otherwise = PatBind { pat_lhs = L span pat,
| otherwise = PatBind { pat_lhs = lpat,
pat_rhs = unguardedGRHSs rhs,
pat_rhs_ty = tup_ty,
pat_rhs_ty = hsLPatType lpat,
bind_fvs = placeHolderNames }
; traceTc $ text "makeImplicationBind" <+> ppr implic_inst
; return ([implic_inst], unitBag (L span bind))
......@@ -2187,16 +2188,15 @@ reduceImplication env
<.> WpLet (binds `unionBags` bind)
wrap_inline | null dict_ids = idHsWrapper
| otherwise = WpInline
rhs = mkHsWrap co payload
rhs = mkLHsWrap co payload
loc = instLocSpan inst_loc
payload | [dict_wanted] <- dict_wanteds = HsVar (instToId dict_wanted)
| otherwise = ExplicitTuple (map (L loc . HsVar . instToId) dict_wanteds) Boxed
payload = mkBigLHsTup (map (L loc . HsVar . instToId) dict_wanteds)
; traceTc (vcat [text "reduceImplication" <+> ppr name,
ppr simpler_implic_insts,
text "->" <+> ppr rhs])
; return (unitBag (L loc (VarBind (instToId orig_implic) (L loc rhs))),
; return (unitBag (L loc (VarBind (instToId orig_implic) rhs)),
simpler_implic_insts)
}
}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment