Commit 15cb792d authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

Complete the evidence generation for GADTs

Mon Sep 18 14:43:22 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Complete the evidence generation for GADTs
  Sat Aug  5 21:39:51 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * Complete the evidence generation for GADTs
    Thu Jul 13 17:18:07 EDT 2006  simonpj@microsoft.com
      
      This patch completes FC evidence generation for GADTs.
      
      It doesn't work properly yet, because part of the compiler thinks
      	(t1 :=: t2) => t3
      is represented with FunTy/PredTy, while the rest thinks it's represented
      using ForAllTy.  Once that's done things should start to work.
parent 5d541fe7
......@@ -11,13 +11,11 @@ module CoreTidy (
import CoreSyn
import CoreUtils ( exprArity )
import DataCon ( DataCon )
import Id ( Id, mkUserLocal, idInfo, setIdInfo, idUnique,
idType, setIdType )
import Id ( Id, mkUserLocal, idInfo, setIdInfo, idUnique, idType )
import IdInfo ( setArityInfo, vanillaIdInfo,
newStrictnessInfo, setAllStrictnessInfo,
newDemandInfo, setNewDemandInfo )
import Type ( Type, tidyType, tidyTyVarBndr, substTy, mkOpenTvSubst )
import Type ( tidyType, tidyTyVarBndr, substTy )
import Var ( Var, TyVar, varName )
import VarEnv
import UniqFM ( lookupUFM )
......
......@@ -513,8 +513,8 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_
let
left_id = HsVar (dataConWrapId left_con)
right_id = HsVar (dataConWrapId right_con)
left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsCoerce (CoTyApps [ty1, ty2]) left_id ) e
right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsCoerce (CoTyApps [ty1, ty2]) right_id) e
left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsCoerce (mkCoTyApps [ty1, ty2]) left_id ) e
right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsCoerce (mkCoTyApps [ty1, ty2]) right_id) e
-- Prefix each tuple with a distinct series of Left's and Right's,
-- in a balanced way, keeping track of the types.
......
......@@ -424,14 +424,14 @@ dsCoercion CoHole thing_inside = thing_inside
dsCoercion (CoCompose c1 c2) thing_inside = dsCoercion c1 (dsCoercion c2 thing_inside)
dsCoercion (ExprCoFn co) thing_inside = do { expr <- thing_inside
; return (Cast expr co) }
dsCoercion (CoLams ids) thing_inside = do { expr <- thing_inside
; return (mkLams ids expr) }
dsCoercion (CoTyLams tvs) thing_inside = do { expr <- thing_inside
; return (mkLams tvs expr) }
dsCoercion (CoApps ids) thing_inside = do { expr <- thing_inside
; return (mkVarApps expr ids) }
dsCoercion (CoTyApps tys) thing_inside = do { expr <- thing_inside
; return (mkTyApps expr tys) }
dsCoercion (CoLam id) thing_inside = do { expr <- thing_inside
; return (Lam id expr) }
dsCoercion (CoTyLam tv) thing_inside = do { expr <- thing_inside
; return (Lam tv expr) }
dsCoercion (CoApp id) thing_inside = do { expr <- thing_inside
; return (App expr (Var id)) }
dsCoercion (CoTyApp ty) thing_inside = do { expr <- thing_inside
; return (App expr (Type ty)) }
dsCoercion (CoLet bs) thing_inside = do { prs <- dsLHsBinds bs
; expr <- thing_inside
; return (Let (Rec prs) expr) }
......
......@@ -310,33 +310,48 @@ data ExprCoFn
| ExprCoFn Coercion -- A cast: [] `cast` co
-- Guaranteedn not the identity coercion
-- Non-empty list in all of these, so that the identity coercion
-- is always exactly CoHole, not, say, (CoTyLams [])
| CoApps [Var] -- [] x1 .. xn; the xi are dicts or coercions
| CoTyApps [Type] -- [] t1 .. tn
| CoLams [Id] -- \x1..xn. []; the xi are dicts or coercions
| CoTyLams [TyVar] -- \a1..an. []
| CoApp Var -- [] x; the xi are dicts or coercions
| CoTyApp Type -- [] t
| CoLam Id -- \x. []; the xi are dicts or coercions
| CoTyLam TyVar -- \a. []
-- Non-empty bindings, so that the identity coercion
-- is always exactly CoHole
| CoLet (LHsBinds Id) -- let binds in []
-- (ould be nicer to be core bindings)
instance Outputable ExprCoFn where
ppr CoHole = ptext SLIT("<>")
ppr (ExprCoFn co) = ppr co
ppr (CoApps ids) = ppr CoHole <+> interppSP ids
ppr (CoTyApps tys) = ppr CoHole <+> hsep (map pprParendType tys)
ppr (CoTyLams tvs) = sep [ptext SLIT("/\\") <> hsep (map (pprBndr LambdaBind) tvs),
ptext SLIT("->") <+> ppr CoHole]
ppr (CoLams ids) = sep [ptext SLIT("\\") <> hsep (map (pprBndr LambdaBind) ids),
ptext SLIT("->") <+> ppr CoHole]
ppr (CoLet binds) = sep [ptext SLIT("let") <+> braces (ppr binds),
ppr CoHole]
ppr (CoCompose co1 co2) = sep [ppr co1, ptext SLIT("<.>"), ppr co2]
instance Outputable ExprCoFn where
ppr co_fn = pprCoFn (ptext SLIT("<>")) co_fn
pprCoFn it CoHole = it
pprCoFn it (CoCompose f1 f2) = pprCoFn (pprCoFn it f2) f1
pprCoFn it (ExprCoFn co) = it <+> ptext SLIT("`cast`") <+> pprParendType co
pprCoFn it (CoApp id) = it <+> ppr id
pprCoFn it (CoTyApp ty) = it <+> ptext SLIT("@") <+> pprParendType ty
pprCoFn it (CoLam id) = ptext SLIT("\\") <> pprBndr LambdaBind id <> dot <+> it
pprCoFn it (CoTyLam tv) = ptext SLIT("/\\") <> pprBndr LambdaBind tv <> dot <+> it
pprCoFn it (CoLet binds) = sep [ptext SLIT("let") <+> braces (ppr binds), it]
(<.>) :: ExprCoFn -> ExprCoFn -> ExprCoFn
CoHole <.> c = c
c <.> CoHole = c
c1 <.> c2 = c1 `CoCompose` c2
mkCoTyApps :: [Type] -> ExprCoFn
mkCoTyApps tys = mk_co_fn CoTyApp (reverse tys)
mkCoApps :: [Id] -> ExprCoFn
mkCoApps ids = mk_co_fn CoApp (reverse ids)
mkCoTyLams :: [TyVar] -> ExprCoFn
mkCoTyLams ids = mk_co_fn CoTyLam ids
mkCoLams :: [Id] -> ExprCoFn
mkCoLams ids = mk_co_fn CoLam ids
mk_co_fn :: (a -> ExprCoFn) -> [a] -> ExprCoFn
mk_co_fn f as = foldr (CoCompose . f) CoHole as
idCoercion :: ExprCoFn
idCoercion = CoHole
......
......@@ -14,7 +14,8 @@ import HsPat ( LPat )
import HsLit ( HsLit(..), HsOverLit )
import HsTypes ( LHsType, PostTcType )
import HsImpExp ( isOperator, pprHsVar )
import HsBinds ( HsLocalBinds, DictBinds, ExprCoFn, isEmptyLocalBinds )
import HsBinds ( HsLocalBinds, DictBinds, isEmptyLocalBinds,
ExprCoFn, pprCoFn )
-- others:
import Type ( Type, pprParendType )
......@@ -379,10 +380,8 @@ ppr_expr (EAsPat v e) = ppr v <> char '@' <> pprParendExpr e
ppr_expr (HsSCC lbl expr)
= sep [ ptext SLIT("_scc_") <+> doubleQuotes (ftext lbl), pprParendExpr expr ]
ppr_expr (HsCoerce co_fn e)
= ppr_expr e <+> ptext SLIT("`cast`") <+> ppr co_fn
ppr_expr (HsType id) = ppr id
ppr_expr (HsCoerce co_fn e) = pprCoFn (ppr_expr e) co_fn
ppr_expr (HsType id) = ppr id
ppr_expr (HsSpliceE s) = pprSplice s
ppr_expr (HsBracket b) = pprHsBracket b
......
......@@ -72,7 +72,7 @@ mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
nlHsTyApp :: name -> [Type] -> LHsExpr name
nlHsTyApp fun_id tys = noLoc (HsCoerce (CoTyApps tys) (HsVar fun_id))
nlHsTyApp fun_id tys = noLoc (HsCoerce (mkCoTyApps tys) (HsVar fun_id))
mkLHsCoerce :: ExprCoFn -> LHsExpr id -> LHsExpr id
mkLHsCoerce co_fn (L loc e) = L loc (mkHsCoerce co_fn e)
......
......@@ -42,9 +42,9 @@ module SimplEnv (
import SimplMonad
import Id ( Id, idType, idOccInfo, idUnfolding, setIdUnfolding )
import IdInfo ( IdInfo, vanillaIdInfo, occInfo, setOccInfo, specInfo, setSpecInfo,
arityInfo, setArityInfo, workerInfo, setWorkerInfo,
arityInfo, workerInfo, setWorkerInfo,
unfoldingInfo, setUnfoldingInfo, isEmptySpecInfo,
unknownArity, workerExists
workerExists
)
import CoreSyn
import Rules ( RuleBase )
......@@ -58,7 +58,7 @@ import OrdList
import qualified CoreSubst ( Subst, mkSubst, substExpr, substSpec, substWorker )
import qualified Type ( substTy, substTyVarBndr )
import Type ( Type, TvSubst(..), TvSubstEnv, composeTvSubst,
import Type ( Type, TvSubst(..), TvSubstEnv,
isUnLiftedType, seqType, tyVarsOfType )
import Coercion ( Coercion )
import BasicTypes ( OccInfo(..), isFragileOcc )
......@@ -556,8 +556,7 @@ substIdInfo subst info
not (workerExists old_wrkr) &&
not (hasUnfolding (unfoldingInfo info))
keep_occ = not (isFragileOcc old_occ)
old_arity = arityInfo info
keep_occ = not (isFragileOcc old_occ)
old_occ = occInfo info
old_rules = specInfo info
old_wrkr = workerInfo info
......
......@@ -12,17 +12,18 @@ module Inst (
tidyInsts, tidyMoreInsts,
newDicts, newDictsAtLoc, cloneDict,
newDictBndr, newDictBndrs, newDictBndrsO,
instCall, instStupidTheta,
cloneDict,
shortCutFracLit, shortCutIntLit, newIPDict,
newMethod, newMethodFromName, newMethodWithGivenTy,
tcInstClassOp, tcInstStupidTheta,
tcInstClassOp,
tcSyntaxName, isHsVar,
tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
instLoc, getDictClassTys, dictPred,
mkInstCoFn,
lookupInst, LookupInstResult(..), lookupPred,
tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
......@@ -39,9 +40,11 @@ module Inst (
#include "HsVersions.h"
import {-# SOURCE #-} TcExpr( tcPolyExpr )
import {-# SOURCE #-} TcUnify( unifyType )
import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, mkHsApp,
ExprCoFn(..), (<.>), nlHsLit, nlHsVar )
ExprCoFn(..), (<.>), mkCoTyApps, idCoercion,
nlHsLit, nlHsVar )
import TcHsSyn ( zonkId )
import TcRnMonad
import TcEnv ( tcLookupId, checkWellStaged, topIdLvl, tcMetaTy )
......@@ -66,7 +69,7 @@ import TcType ( Type, TcType, TcThetaType, TcTyVarSet, TcPredType,
tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy,
pprPred, pprParendType, pprTheta
)
import Type ( TvSubst, substTy, substTyVar, substTyWith, substTheta, zipTopTvSubst,
import Type ( TvSubst, substTy, substTyVar, substTyWith,
notElemTvSubst, extendTvSubstList )
import Unify ( tcMatchTys )
import Module ( modulePackageId )
......@@ -74,20 +77,18 @@ import {- Kind parts of -} Type ( isSubKind )
import Coercion ( isEqPred )
import HscTypes ( ExternalPackageState(..), HscEnv(..) )
import CoreFVs ( idFreeTyVars )
import DataCon ( DataCon, dataConStupidTheta, dataConName,
dataConWrapId, dataConUnivTyVars )
import DataCon ( dataConWrapId )
import Id ( Id, idName, idType, mkUserLocal, mkLocalId, isId )
import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, nameModule,
isInternalName, setNameUnique )
import NameSet ( addOneToNameSet )
import Literal ( inIntRange )
import Var ( Var, TyVar, tyVarKind, setIdType, mkTyVar )
import Var ( Var, TyVar, tyVarKind, setIdType, isId, mkTyVar )
import VarEnv ( TidyEnv, emptyTidyEnv )
import VarSet ( elemVarSet, emptyVarSet, unionVarSet, mkVarSet )
import TysWiredIn ( floatDataCon, doubleDataCon )
import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName )
import BasicTypes( IPName(..), mapIPName, ipNameName )
import UniqSupply( uniqsFromSupply )
import SrcLoc ( mkSrcSpan, noLoc, unLoc, Located(..) )
import DynFlags ( DynFlag(..), DynFlags(..), dopt )
import Maybes ( isJust )
......@@ -98,9 +99,6 @@ import Outputable
Selection
~~~~~~~~~
\begin{code}
mkInstCoFn :: [TcType] -> [Inst] -> ExprCoFn
mkInstCoFn tys dicts = CoApps (map instToId dicts) <.> CoTyApps tys
instName :: Inst -> Name
instName inst = idName (instToId inst)
......@@ -212,32 +210,75 @@ linearInstType (Dict _ (IParam _ ty) _) = ty
%* *
%************************************************************************
\begin{code}
newDicts :: InstOrigin
-> TcThetaType
-> TcM [Inst]
newDicts orig theta
= getInstLoc orig `thenM` \ loc ->
newDictsAtLoc loc theta
-- newDictBndrs makes a dictionary at a binding site
-- instCall makes a dictionary at an occurrence site
-- and throws it into the LIE
cloneDict :: Inst -> TcM Inst -- Only used for linear implicit params
cloneDict (Dict nm ty loc) = newUnique `thenM` \ uniq ->
returnM (Dict (setNameUnique nm uniq) ty loc)
\begin{code}
----------------
newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst]
newDictBndrsO orig theta = do { loc <- getInstLoc orig
; newDictBndrs loc theta }
newDictsAtLoc :: InstLoc -> TcThetaType -> TcM [Inst]
newDictsAtLoc inst_loc theta = mapM (newDictAtLoc inst_loc) theta
newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
{-
newDictOcc :: InstLoc -> TcPredType -> TcM Inst
newDictOcc inst_loc (EqPred ty1 ty2)
= do { unifyType ty1 ty2 -- We insist that they unify right away
; return ty1 } -- And return the relexive coercion
-}
newDictAtLoc inst_loc pred
newDictBndr :: InstLoc -> TcPredType -> TcM Inst
newDictBndr inst_loc pred
= do { uniq <- newUnique
; let name = mkPredName uniq (instLocSrcLoc inst_loc) pred
; return (Dict name pred inst_loc) }
----------------
instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM ExprCoFn
-- Instantiate the constraints of a call
-- (instCall o tys theta)
-- (a) Makes fresh dictionaries as necessary for the constraints (theta)
-- (b) Throws these dictionaries into the LIE
-- (c) Eeturns an ExprCoFn ([.] tys dicts)
instCall orig tys theta
= do { loc <- getInstLoc orig
; (dicts, dict_app) <- instCallDicts loc theta
; extendLIEs dicts
; return (dict_app <.> mkCoTyApps tys) }
----------------
instStupidTheta :: InstOrigin -> TcThetaType -> TcM ()
-- Similar to instCall, but only emit the constraints in the LIE
-- Used exclusively for the 'stupid theta' of a data constructor
instStupidTheta orig theta
= do { loc <- getInstLoc orig
; (dicts, _) <- instCallDicts loc theta
; extendLIEs dicts }
----------------
instCallDicts :: InstLoc -> TcThetaType -> TcM ([Inst], ExprCoFn)
-- This is the key place where equality predicates
-- are unleashed into the world
instCallDicts loc [] = return ([], idCoercion)
instCallDicts loc (EqPred ty1 ty2 : preds)
= do { unifyType ty1 ty2 -- For now, we insist that they unify right away
-- Later on, when we do associated types,
-- unifyType might return a coercion
; (dicts, co_fn) <- instCallDicts loc preds
; return (dicts, co_fn <.> CoTyApp ty1) }
-- We use type application to apply the function to the
-- coercion; here ty1 *is* the appropriate identity coercion
instCallDicts loc (pred : preds)
= do { uniq <- newUnique
; let name = mkPredName uniq (instLocSrcLoc loc) pred
dict = Dict name pred loc
; (dicts, co_fn) <- instCallDicts loc preds
; return (dict:dicts, co_fn <.> CoApp (instToId dict)) }
-------------
cloneDict :: Inst -> TcM Inst -- Only used for linear implicit params
cloneDict (Dict nm ty loc) = newUnique `thenM` \ uniq ->
returnM (Dict (setNameUnique nm uniq) ty loc)
-- For vanilla implicit parameters, there is only one in scope
-- at any time, so we used to use the name of the implicit parameter itself
-- But with splittable implicit parameters there may be many in
......@@ -265,20 +306,6 @@ newIPDict orig ip_name ty
\begin{code}
tcInstStupidTheta :: DataCon -> [TcType] -> TcM ()
-- Instantiate the "stupid theta" of the data con, and throw
-- the constraints into the constraint set
tcInstStupidTheta data_con inst_tys
| null stupid_theta
= return ()
| otherwise
= do { stupid_dicts <- newDicts (OccurrenceOf (dataConName data_con))
(substTheta tenv stupid_theta)
; extendLIEs stupid_dicts }
where
stupid_theta = dataConStupidTheta data_con
tenv = zipTopTvSubst (dataConUnivTyVars data_con) inst_tys
newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
newMethodFromName origin ty name
= tcLookupId name `thenM` \ id ->
......@@ -592,8 +619,8 @@ lookupInst :: Inst -> TcM LookupInstResult
-- Methods
lookupInst inst@(Method _ id tys theta loc)
= do { dicts <- newDictsAtLoc loc theta
; let co_fn = mkInstCoFn tys dicts
= do { (dicts, dict_app) <- instCallDicts loc theta
; let co_fn = dict_app <.> mkCoTyApps tys
; return (GenInst dicts (L span $ HsCoerce co_fn (HsVar id))) }
where
span = instLocSrcSpan loc
......@@ -671,10 +698,10 @@ lookupInst (Dict _ pred loc)
dfun = HsVar dfun_id
tys = map (substTyVar tenv') tyvars
; if null theta then
returnM (SimpleInst (L src_loc $ HsCoerce (CoTyApps tys) dfun))
returnM (SimpleInst (L src_loc $ HsCoerce (mkCoTyApps tys) dfun))
else do
{ dicts <- newDictsAtLoc loc theta
; let co_fn = mkInstCoFn tys dicts
{ (dicts, dict_app) <- instCallDicts loc theta
; let co_fn = dict_app <.> mkCoTyApps tys
; returnM (GenInst dicts (L src_loc $ HsCoerce co_fn dfun))
}}}}
......
......@@ -264,7 +264,7 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty)
-- the s1..sm and check each cmd
; cmds' <- mapM (tc_cmd w_tv) cmds_w_tys
; returnM (HsArrForm (noLoc $ HsCoerce (CoTyLams [w_tv])
; returnM (HsArrForm (noLoc $ HsCoerce (CoTyLam w_tv)
(unLoc $ mkHsDictLet inst_binds expr'))
fixity cmds')
}
......
......@@ -28,7 +28,7 @@ import HsSyn ( HsExpr(..), HsBind(..), LHsBinds, LHsBind, Sig(..),
import TcHsSyn ( zonkId )
import TcRnMonad
import Inst ( newDictsAtLoc, newIPDict, instToId )
import Inst ( newDictBndrs, newIPDict, instToId )
import TcEnv ( tcExtendIdEnv, tcExtendIdEnv2, tcExtendTyVarEnv2,
pprBinders, tcLookupId,
tcGetGlobalTyVars )
......@@ -773,7 +773,7 @@ might not otherwise be related. This is a rather subtle issue.
unifyCtxts :: [TcSigInfo] -> TcM [Inst]
unifyCtxts (sig1 : sigs) -- Argument is always non-empty
= do { mapM unify_ctxt sigs
; newDictsAtLoc (sig_loc sig1) (sig_theta sig1) }
; newDictBndrs (sig_loc sig1) (sig_theta sig1) }
where
theta1 = sig_theta sig1
unify_ctxt :: TcSigInfo -> TcM ()
......
......@@ -16,7 +16,7 @@ import HsSyn
import RnHsSyn ( maybeGenericMatch, extractHsTyVars )
import RnExpr ( rnLExpr )
import RnEnv ( lookupTopBndrRn, lookupImportedName )
import Inst ( instToId, newDicts, newDictsAtLoc, newMethod, getOverlapFlag )
import Inst ( instToId, newDictBndr, newDictBndrs, newMethod, getOverlapFlag )
import InstEnv ( mkLocalInstance )
import TcEnv ( tcLookupLocatedClass,
tcExtendTyVarEnv, tcExtendIdEnv,
......@@ -246,9 +246,13 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
-- default methods. Better to make separate AbsBinds for each
let
(tyvars, _, _, op_items) = classBigSig clas
rigid_info = ClsSkol clas
origin = SigOrigin rigid_info
prag_fn = mkPragFun sigs
sig_fn = mkTcSigFun sigs
tc_dm = tcDefMeth clas tyvars default_binds sig_fn prag_fn
clas_tyvars = tcSkolSigTyVars rigid_info tyvars
tc_dm = tcDefMeth origin clas clas_tyvars
default_binds sig_fn prag_fn
dm_sel_ids = [sel_id | (sel_id, DefMeth) <- op_items]
-- Generate code for polymorphic default methods only
......@@ -261,19 +265,17 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
mapAndUnzipM tc_dm dm_sel_ids `thenM` \ (defm_binds, dm_ids_s) ->
returnM (listToBag defm_binds, concat dm_ids_s)
tcDefMeth clas tyvars binds_in sig_fn prag_fn sel_id
tcDefMeth origin clas tyvars binds_in sig_fn prag_fn sel_id
= do { dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_id)
; let rigid_info = ClsSkol clas
clas_tyvars = tcSkolSigTyVars rigid_info tyvars
inst_tys = mkTyVarTys clas_tyvars
; let inst_tys = mkTyVarTys tyvars
dm_ty = idType sel_id -- Same as dict selector!
theta = [mkClassPred clas inst_tys]
cls_pred = mkClassPred clas inst_tys
local_dm_id = mkDefaultMethodId dm_name dm_ty
origin = SigOrigin rigid_info
; (_, meth_info) <- mkMethodBind origin clas inst_tys binds_in (sel_id, DefMeth)
; [this_dict] <- newDicts origin theta
; (defm_bind, insts_needed) <- getLIE (tcMethodBind clas_tyvars theta [this_dict]
; loc <- getInstLoc origin
; this_dict <- newDictBndr loc cls_pred
; (defm_bind, insts_needed) <- getLIE (tcMethodBind tyvars [cls_pred] [this_dict]
sig_fn prag_fn meth_info)
; addErrCtxt (defltMethCtxt clas) $ do
......@@ -281,12 +283,12 @@ tcDefMeth clas tyvars binds_in sig_fn prag_fn sel_id
-- Check the context
{ dict_binds <- tcSimplifyCheck
(ptext SLIT("class") <+> ppr clas)
clas_tyvars
tyvars
[this_dict]
insts_needed
-- Simplification can do unification
; checkSigTyVars clas_tyvars
; checkSigTyVars tyvars
-- Inline pragmas
-- We'll have an inline pragma on the local binding, made by tcMethodBind
......@@ -297,9 +299,9 @@ tcDefMeth clas tyvars binds_in sig_fn prag_fn sel_id
inline_prags = filter isInlineLSig (prag_fn sel_name)
; prags <- tcPrags dm_inst_id inline_prags
; let full_bind = AbsBinds clas_tyvars
; let full_bind = AbsBinds tyvars
[instToId this_dict]
[(clas_tyvars, local_dm_id, dm_inst_id, prags)]
[(tyvars, local_dm_id, dm_inst_id, prags)]
(dict_binds `unionBags` defm_bind)
; returnM (noLoc full_bind, [local_dm_id]) }}
......@@ -374,7 +376,7 @@ tcMethodBind inst_tyvars inst_theta avail_insts sig_fn prag_fn
in
addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id)) $
newDictsAtLoc (sig_loc sig) (sig_theta sig) `thenM` \ meth_dicts ->
newDictBndrs (sig_loc sig) (sig_theta sig) `thenM` \ meth_dicts ->
let
meth_tvs = sig_tvs sig
all_tyvars = meth_tvs ++ inst_tyvars
......
......@@ -45,19 +45,19 @@ module TcEnv(
import HsSyn ( LRuleDecl, LHsBinds, LSig,
LHsTyVarBndr, HsTyVarBndr(..), pprLHsBinds,
ExprCoFn(..), idCoercion, (<.>) )
idCoercion, (<.>) )
import TcIface ( tcImportDecl )
import IfaceEnv ( newGlobalBinder )
import TcRnMonad
import TcMType ( zonkTcType, zonkTcTyVarsAndFV )
import TcType ( Type, TcKind, TcTyVar, TcTyVarSet, TcType, TvSubst,
substTy, substTyVar, tyVarsOfType, tcTyVarsOfTypes, mkTyConApp,
import TcType ( Type, TcKind, TcTyVar, TcTyVarSet, TcType,
substTy, tyVarsOfType, tcTyVarsOfTypes, mkTyConApp,
getDFunTyKey, tcTyConAppTyCon, tcGetTyVar, mkTyVarTy,
tidyOpenType, isRefineableTy
)
import TcGadt ( Refinement, refineType )
import qualified Type ( getTyVar_maybe )
import Id ( idName, isLocalId, setIdType )
import Id ( idName, isLocalId )
import Var ( TyVar, Id, idType, tyVarName )
import VarSet
import VarEnv
......
......@@ -29,15 +29,15 @@ import TcUnify ( tcInfer, tcSubExp, tcFunResTy, tcGen, boxyUnify, subFunTys, za
boxySplitListTy, boxySplitTyConApp, wrapFunResCoercion, preSubType,
unBox )
import BasicTypes ( Arity, isMarkedStrict )
import Inst ( newMethodFromName, newIPDict, mkInstCoFn,
newDicts, newMethodWithGivenTy, tcInstStupidTheta )
import Inst ( newMethodFromName, newIPDict, instCall,
newMethodWithGivenTy, instStupidTheta )
import TcBinds ( tcLocalBinds )
import TcEnv ( tcLookup, tcLookupDataCon, tcLookupField )
import TcArrows ( tcProc )
import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcBody,
TcMatchCtxt(..) )
import TcHsType ( tcHsSigType, UserTypeCtxt(..) )
import TcPat ( tcOverloadedLit, badFieldCon )
import TcPat ( tcOverloadedLit, addDataConStupidTheta, badFieldCon )
import TcMType ( tcInstTyVars, newFlexiTyVarTy, newBoxyTyVars,
readFilledBox, zonkTcTypes )
import TcType ( TcType, TcSigmaType, TcRhoType, TvSubst,
......@@ -489,14 +489,11 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty
-- dictionaries for the data type context, since we are going to
-- do pattern matching over the data cons.
--
-- What dictionaries do we need?
-- We just take the context of the first data constructor
-- This isn't right, but I just can't bear to union up all the relevant ones
-- What dictionaries do we need? The tyConStupidTheta tells us.
let
theta' = substTheta inst_env (tyConStupidTheta tycon)
in
newDicts RecordUpdOrigin theta' `thenM` \ dicts ->
extendLIEs dicts `thenM_`
instStupidTheta RecordUpdOrigin theta' `thenM_`
-- Phew!
returnM (mkHsCoerce co_fn (RecordUpd record_expr' rbinds' record_ty result_record_ty))
......@@ -791,7 +788,8 @@ instFun orig fun subst tv_theta_prs
= (map (substTyVar subst) tvs, substTheta subst theta)
inst_stupid (HsVar fun_id) ((tys,_):_)
| Just con <- isDataConId_maybe fun_id = tcInstStupidTheta con tys
| Just con <- isDataConId_maybe fun_id
= addDataConStupidTheta orig con tys
inst_stupid _ _ = return ()
go _ fun [] = return fun
......@@ -804,9 +802,7 @@ instFun orig fun subst tv_theta_prs
-- of newMethod: see Note [Multiple instantiation]
go _ fun ((tys, theta) : prs)
= do { dicts <- newDicts orig theta
; extendLIEs dicts
; let co_fn = mkInstCoFn tys dicts
= do { co_fn <- instCall orig tys theta
; go False (HsCoerce co_fn fun) prs }
-- Hack Alert (want_method_inst)!
......
......@@ -537,14 +537,14 @@ zonkCoFn env (ExprCoFn co) = do { co' <- zonkTcTypeToType env co
zonkCoFn env (CoCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
; (env2, c2') <- zonkCoFn env1 c2
; return (env2, CoCompose c1' c2') }
zonkCoFn env (CoLams ids) = do { ids' <- zonkIdBndrs env ids
; let env1 = extendZonkEnv env ids'
; return (env1, CoLams ids') }
zonkCoFn env (CoTyLams tvs) = ASSERT( all isImmutableTyVar tvs )
do { return (env, CoTyLams tvs) }
zonkCoFn env (CoApps ids) = do { return (env, CoApps (zonkIdOccs env ids)) }
zonkCoFn env (CoTyApps tys) = do { tys' <- zonkTcTypeToTypes env tys
; return (env, CoTyApps tys') }
zonkCoFn env (CoLam id) = do { id' <- zonkIdBndr env id
; let env1 = extendZonkEnv1 env id'
; return (env1, CoLam id') }
zonkCoFn env (CoTyLam tv) = ASSERT( isImmutableTyVar tv )
do { return (env, CoTyLam tv) }
zonkCoFn env (CoApp id) = do { return (env, CoApp (zonkIdOcc env id)) }
zonkCoFn env (CoTyApp ty) = do { ty' <- zonkTcTypeToType env ty
; return (env, CoTyApp ty') }
zonkCoFn env (CoLet bs) = do { (env1, bs') <- zonkRecMonoBinds env bs
; return (env1, CoLet bs') }
......
......@@ -14,9 +14,9 @@ import TcClassDcl ( tcMethodBind, mkMethodBind, badMethodErr,
tcClassDecl2, getGenericInstances )
import TcRnMonad
import TcMType ( tcSkolSigType, checkValidInstance, checkValidInstHead )
import TcType ( mkClassPred, tcSplitSigmaTy, tcSplitDFunHead, mkTyVarTys,
import TcType ( mkClassPred, tcSplitSigmaTy, tcSplitDFunHead,
SkolemInfo(InstSkol), tcSplitDFunTy, mkFunTy )
import Inst ( tcInstClassOp, newDicts, instToId, showLIE,
import Inst ( newDictBndr, newDictBndrs, instToId, showLIE,
getOverlapFlag, tcExtendLocalInstEnv )
import InstEnv ( mkLocalInstance, instanceDFunId )
import TcDeriv ( tcDeriving )
......@@ -25,19 +25,19 @@ import TcEnv ( InstInfo(..), InstBindings(..),
)
import TcHsType ( kcHsSigType, tcHsKindedType )
import TcUnify ( checkSigTyVars )
import TcSimplify ( tcSimplifyCheck, tcSimplifySuperClasses )
import Type ( zipOpenTvSubst, substTheta, substTys, mkTyConApp, mkTyVarTy )
import TcSimplify ( tcSimplifySuperClasses )
import Type ( zipOpenTvSubst, substTheta, mkTyConApp, mkTyVarTy )
import Coercion ( mkAppCoercion, mkAppsCoercion )
import TyCon ( TyCon, newTyConCo )
import DataCon ( classDataCon, dataConTyCon, dataConInstArgTys )
import Class ( classBigSig, classMethods )
import Class ( classBigSig )
import Var ( TyVar, Id, idName, idType )
import Id ( mkSysLocal )
import UniqSupply ( uniqsFromSupply, splitUniqSupply )
import MkId ( mkDictFunId )