Complete the evidence generation for GADTs
authorManuel M T Chakravarty <chak@cse.unsw.edu.au>
Wed, 20 Sep 2006 17:05:28 +0000 (17:05 +0000)
committerManuel M T Chakravarty <chak@cse.unsw.edu.au>
Wed, 20 Sep 2006 17:05:28 +0000 (17:05 +0000)
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.

21 files changed:
compiler/coreSyn/CoreTidy.lhs
compiler/deSugar/DsArrows.lhs
compiler/deSugar/DsBinds.lhs
compiler/hsSyn/HsBinds.lhs
compiler/hsSyn/HsExpr.lhs
compiler/hsSyn/HsUtils.lhs
compiler/simplCore/SimplEnv.lhs
compiler/typecheck/Inst.lhs
compiler/typecheck/TcArrows.lhs
compiler/typecheck/TcBinds.lhs
compiler/typecheck/TcClassDcl.lhs
compiler/typecheck/TcEnv.lhs
compiler/typecheck/TcExpr.lhs
compiler/typecheck/TcHsSyn.lhs
compiler/typecheck/TcInstDcls.lhs
compiler/typecheck/TcPat.lhs
compiler/typecheck/TcSimplify.lhs
compiler/typecheck/TcType.lhs
compiler/typecheck/TcUnify.lhs
compiler/types/Type.lhs
compiler/types/Unify.lhs

index 7b80eac..35948fc 100644 (file)
@@ -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 )
index 3484a5d..d477eff 100644 (file)
@@ -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.
index de8e981..58e42fd 100644 (file)
@@ -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) }
index f3a0d0b..900b800 100644 (file)
@@ -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
 
index 25ecbb1..18306a9 100644 (file)
@@ -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
index cbc59c4..1839aef 100644 (file)
@@ -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)
index 3556b7e..960475c 100644 (file)
@@ -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
index cc91be8..63b5f26 100644 (file)
@@ -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))
     }}}}
 
index b4afcaf..2316162 100644 (file)
@@ -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')
        }
index 9cc66e3..4223af4 100644 (file)
@@ -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 ()
index 31e3d5a..25795ce 100644 (file)
@@ -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
index b3e0d7f..1d093e2 100644 (file)
@@ -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
index 43360c7..bda4e2f 100644 (file)
@@ -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)!
index 8ab91ce..4e650c5 100644 (file)
@@ -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') }
 
index 1bb1bb7..ba57563 100644 (file)
@@ -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 )
 import Name            ( Name, getSrcLoc )
 import Maybe           ( catMaybes )
-import SrcLoc          ( noSrcSpan, srcLocSpan, unLoc, noLoc, Located(..), srcSpanStart )
+import SrcLoc          ( srcLocSpan, unLoc, noLoc, Located(..), srcSpanStart )
 import ListSetOps      ( minusList )
 import Outputable
 import Bag
@@ -309,7 +309,7 @@ First comes the easy case of a non-local instance decl.
 tcInstDecl2 :: InstInfo -> TcM (LHsBinds Id)
 -- Returns a binding for the dfun
 
---
+------------------------
 -- Derived newtype instances
 --
 -- We need to make a copy of the dictionary we are deriving from
@@ -334,22 +334,20 @@ tcInstDecl2 (InstInfo { iSpec = ispec,
              rigid_info   = InstSkol dfun_id
              origin       = SigOrigin rigid_info
              inst_ty      = idType dfun_id
-              maybe_co_con = newTyConCo tycon
+       ; inst_loc <- getInstLoc origin
        ; (tvs, theta, inst_head) <- tcSkolSigType rigid_info inst_ty
-       ; dicts <- newDicts origin theta
+       ; dicts <- newDictBndrs inst_loc theta
         ; uniqs <- newUniqueSupply
         ; let (cls, cls_inst_tys) = tcSplitDFunHead inst_head
-        ; [this_dict] <- newDicts origin [mkClassPred cls rep_tys]
-        ; let (rep_dict_id:sc_dict_ids) =
-                 if null dicts then
-                     [instToId this_dict]
-                 else
-                     map instToId dicts
+        ; this_dict <- newDictBndr inst_loc (mkClassPred cls rep_tys)
+        ; let (rep_dict_id:sc_dict_ids)
+                 | null dicts = [instToId this_dict]
+                | otherwise  = map instToId dicts
 
                -- (Here, we are relying on the order of dictionary 
                -- arguments built by NewTypeDerived in TcDeriv.)
 
-              wrap_fn = CoTyLams tvs <.> CoLams (rep_dict_id:sc_dict_ids)
+              wrap_fn = mkCoTyLams tvs <.> mkCoLams (rep_dict_id:sc_dict_ids)
         
               coerced_rep_dict = mkHsCoerce (co_fn tvs cls_tycon) (HsVar rep_dict_id)
 
@@ -358,7 +356,8 @@ tcInstDecl2 (InstInfo { iSpec = ispec,
                                 MatchGroup [the_match] (mkFunTy in_dict_ty inst_head)
              in_dict_ty = mkTyConApp cls_tycon cls_inst_tys
 
-              the_match = mkSimpleMatch [the_pat] the_rhs
+              the_match = mkSimpleMatch [noLoc the_pat] the_rhs
+             the_rhs = mkHsConApp cls_data_con cls_inst_tys (map HsVar (sc_dict_ids ++ op_ids))
 
              (uniqs1, uniqs2) = splitUniqSupply uniqs
 
@@ -368,23 +367,21 @@ tcInstDecl2 (InstInfo { iSpec = ispec,
               dict_ids = zipWith (mkSysLocal FSLIT("dict"))
                           (uniqsFromSupply uniqs2) (map idType sc_dict_ids)
 
-             the_pat = noLoc $
-                        ConPatOut { pat_con = noLoc cls_data_con, pat_tvs = [],
+             the_pat = ConPatOut { pat_con = noLoc cls_data_con, pat_tvs = [],
                                    pat_dicts = dict_ids,
                                    pat_binds = emptyLHsBinds,
                                    pat_args = PrefixCon (map nlVarPat op_ids),
                                    pat_ty = in_dict_ty} 
 
               cls_data_con = classDataCon cls
-              cls_tycon = dataConTyCon cls_data_con
-              cls_arg_tys = dataConInstArgTys cls_data_con cls_inst_tys 
+              cls_tycon    = dataConTyCon cls_data_con
+              cls_arg_tys  = dataConInstArgTys cls_data_con cls_inst_tys 
               
               n_dict_args = if length dicts == 0 then 0 else length dicts - 1
               op_tys = drop n_dict_args cls_arg_tys
               
-             the_rhs = mkHsConApp cls_data_con cls_inst_tys (map HsVar (sc_dict_ids ++ op_ids))
-              dict = (mkHsCoerce wrap_fn body)
-        ; return (unitBag (noLoc $ VarBind (dfun_id) (noLoc dict))) }
+              dict    = mkHsCoerce wrap_fn body
+        ; return (unitBag (noLoc $ VarBind dfun_id (noLoc dict))) }
   where
     co_fn :: [TyVar] -> TyCon -> ExprCoFn
     co_fn tvs cls_tycon | Just co_con <- newTyConCo tycon
@@ -395,6 +392,9 @@ tcInstDecl2 (InstInfo { iSpec = ispec,
          | otherwise
          = idCoercion
 
+------------------------
+-- Ordinary instances
+
 tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
   = let 
        dfun_id    = instanceDFunId ispec
@@ -420,9 +420,11 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
        origin    = SigOrigin rigid_info
     in
         -- Create dictionary Ids from the specified instance contexts.
-    newDicts InstScOrigin sc_theta'                    `thenM` \ sc_dicts ->
-    newDicts origin dfun_theta'                                `thenM` \ dfun_arg_dicts ->
-    newDicts origin [mkClassPred clas inst_tys']       `thenM` \ [this_dict] ->
+    getInstLoc InstScOrigin                            `thenM` \ sc_loc -> 
+    newDictBndrs sc_loc sc_theta'                      `thenM` \ sc_dicts ->
+    getInstLoc origin                                  `thenM` \ inst_loc -> 
+    newDictBndrs inst_loc dfun_theta'                  `thenM` \ dfun_arg_dicts ->
+    newDictBndr inst_loc (mkClassPred clas inst_tys')  `thenM` \ this_dict ->
                -- Default-method Ids may be mentioned in synthesised RHSs,
                -- but they'll already be in the environment.
 
index 33b7630..2316c93 100644 (file)
@@ -5,7 +5,7 @@
 
 \begin{code}
 module TcPat ( tcLetPat, tcLamPat, tcLamPats, tcOverloadedLit,
-              badFieldCon, polyPatSig ) where
+              addDataConStupidTheta, badFieldCon, polyPatSig ) where
 
 #include "HsVersions.h"
 
@@ -17,7 +17,7 @@ import HsSyn          ( Pat(..), LPat, HsConDetails(..), HsLit(..), HsOverLit(..), HsExp
 import TcHsSyn         ( TcId, hsLitType )
 import TcRnMonad
 import Inst            ( InstOrigin(..), shortCutFracLit, shortCutIntLit, 
-                         newDicts, instToId, tcInstStupidTheta, isHsVar
+                         newDictBndrs, instToId, instStupidTheta, isHsVar
                        )
 import Id              ( Id, idType, mkLocalId )
 import CoreFVs         ( idFreeTyVars )
@@ -47,7 +47,8 @@ import Type           ( substTys, substTheta )
 import StaticFlags     ( opt_IrrefutableTuples )
 import TyCon           ( TyCon, FieldLabel )
 import DataCon         ( DataCon, dataConTyCon, dataConFullSig, dataConName,
-                         dataConFieldLabels, dataConSourceArity )
+                         dataConFieldLabels, dataConSourceArity, 
+                         dataConStupidTheta, dataConUnivTyVars )
 import PrelNames       ( integralClassName, fromIntegerName, integerTyConName, 
                          fromRationalName, rationalTyConName )
 import BasicTypes      ( isBoxed )
@@ -460,8 +461,7 @@ tc_pat pstate pat@(NPlusKPat (L nm_loc name) lit ge minus) pat_ty thing_inside
        -- The Report says that n+k patterns must be in Integral
        -- We may not want this when using re-mappable syntax, though (ToDo?)
        ; icls <- tcLookupClass integralClassName
-       ; dicts <- newDicts orig [mkClassPred icls [pat_ty']]   
-       ; extendLIEs dicts
+       ; instStupidTheta orig [mkClassPred icls [pat_ty']]     
     
        ; res <- tcExtendIdEnv1 name bndr_id (thing_inside pstate)
        ; returnM (NPlusKPat (L nm_loc bndr_id) lit' ge' minus', [], res) }
@@ -490,6 +490,7 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
   = do { span <- getSrcSpanM   -- Span for the whole pattern
        ; let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys) = dataConFullSig data_con
              skol_info = PatSkol data_con span
+             origin    = SigOrigin skol_info
 
          -- Instantiate the constructor type variables [a->ty]
        ; ctxt_res_tys <- boxySplitTyConApp tycon pat_ty
@@ -506,10 +507,11 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
        ; ((arg_pats', inner_tvs, res), lie_req) <- getLIE $
                tcConArgs data_con arg_tys' arg_pats pstate' thing_inside
 
-       ; dicts <- newDicts (SigOrigin skol_info) theta'
+       ; loc <- getInstLoc origin
+       ; dicts <- newDictBndrs loc theta'
        ; dict_binds <- tcSimplifyCheck doc ex_tvs' dicts lie_req
 
-       ; tcInstStupidTheta data_con ctxt_res_tys
+       ; addDataConStupidTheta origin data_con ctxt_res_tys
 
        ; return (ConPatOut { pat_con = L con_span data_con, 
                              pat_tvs = ex_tvs' ++ co_vars,
@@ -589,6 +591,19 @@ tcConArg (arg_pat, arg_ty) pstate thing_inside
        --     refinements from peer argument patterns to the left
 \end{code}
 
+\begin{code}
+addDataConStupidTheta :: InstOrigin -> DataCon -> [TcType] -> TcM ()
+-- Instantiate the "stupid theta" of the data con, and throw 
+-- the constraints into the constraint set
+addDataConStupidTheta origin data_con inst_tys
+  | null stupid_theta = return ()
+  | otherwise        = instStupidTheta origin inst_theta
+  where
+    stupid_theta = dataConStupidTheta data_con
+    tenv = zipTopTvSubst (dataConUnivTyVars data_con) inst_tys
+    inst_theta = substTheta tenv stupid_theta
+\end{code}
+
 
 %************************************************************************
 %*                                                                     *
index c0bb23b..98fdaf9 100644 (file)
@@ -21,19 +21,19 @@ module TcSimplify (
 #include "HsVersions.h"
 
 import {-# SOURCE #-} TcUnify( unifyType )
-import HsSyn           ( HsBind(..), HsExpr(..), LHsExpr, 
+import HsSyn           ( HsBind(..), HsExpr(..), LHsExpr, mkCoTyApps,
                          ExprCoFn(..), (<.>), nlHsTyApp, emptyLHsBinds )
 import TcHsSyn         ( mkHsApp )
 
 import TcRnMonad
 import Inst            ( lookupInst, LookupInstResult(..),
-                         tyVarsOfInst, fdPredsOfInsts, newDicts, 
+                         tyVarsOfInst, fdPredsOfInsts,
                          isDict, isClassDict, isLinearInst, linearInstType,
                          isMethodFor, isMethod,
                          instToId, tyVarsOfInsts,  cloneDict,
                          ipNamesOfInsts, ipNamesOfInst, dictPred,
-                         fdPredsOfInst, mkInstCoFn,
-                         newDictsAtLoc, tcInstClassOp,
+                         fdPredsOfInst, 
+                         newDictBndrs, newDictBndrsO, tcInstClassOp,
                          getDictClassTys, isTyVarDict, instLoc,
                          zonkInst, tidyInsts, tidyMoreInsts,
                          pprInsts, pprDictsInFull, pprInstInFull, tcGetInstEnvs,
@@ -1912,7 +1912,7 @@ addSCs :: (TcPredType -> Bool) -> Avails -> Inst -> TcM Avails
        -- Invariant: the Inst is already in Avails.
 
 addSCs is_loop avails dict
-  = do { sc_dicts <- newDictsAtLoc (instLoc dict) sc_theta'
+  = do { sc_dicts <- newDictBndrs (instLoc dict) sc_theta'
        ; foldlM add_sc avails (zipEqual "add_scs" sc_dicts sc_sels) }
   where
     (clas, tys) = getDictClassTys dict
@@ -1925,7 +1925,7 @@ addSCs is_loop avails dict
       | otherwise                 = addSCs is_loop avails' sc_dict
       where
        sc_sel_rhs = L (instSpan dict) (HsCoerce co_fn (HsVar sc_sel))
-       co_fn      = mkInstCoFn tys [dict]
+       co_fn      = CoApp (instToId dict) <.> mkCoTyApps tys
        avails'    = addToFM avails sc_dict (Rhs sc_sel_rhs [dict])
 
     is_given :: Inst -> Bool
@@ -2279,7 +2279,7 @@ tcSimplifyDeriv tc tyvars theta
        -- The main loop may do unification, and that may crash if 
        -- it doesn't see a TcTyVar, so we have to instantiate. Sigh
        -- ToDo: what if two of them do get unified?
-    newDicts DerivOrigin (substTheta tenv theta)       `thenM` \ wanteds ->
+    newDictBndrsO DerivOrigin (substTheta tenv theta)  `thenM` \ wanteds ->
     simpleReduceLoop doc reduceMe wanteds              `thenM` \ (frees, _, irreds) ->
     ASSERT( null frees )                       -- reduceMe never returns Free
 
@@ -2325,7 +2325,7 @@ tcSimplifyDefault :: ThetaType    -- Wanted; has no type variables in it
                  -> TcM ()
 
 tcSimplifyDefault theta
-  = newDicts DefaultOrigin theta               `thenM` \ wanteds ->
+  = newDictBndrsO DefaultOrigin theta          `thenM` \ wanteds ->
     simpleReduceLoop doc reduceMe wanteds      `thenM` \ (frees, _, irreds) ->
     ASSERT( null frees )       -- try_me never returns Free
     addNoInstanceErrs Nothing []  irreds       `thenM_`
index 84d944a..55e20fc 100644 (file)
@@ -187,7 +187,7 @@ import PrelNames    -- Lots (e.g. in isFFIArgumentTy)
 import TysWiredIn      ( unitTyCon, charTyCon, listTyCon )
 import BasicTypes      ( IPName(..), Arity, ipNameName )
 import SrcLoc          ( SrcLoc, SrcSpan )
-import Util            ( snocView, equalLength )
+import Util            ( equalLength )
 import Maybes          ( maybeToBool, expectJust, mapCatMaybes )
 import ListSetOps      ( hasNoDups )
 import List            ( nubBy )
@@ -988,8 +988,9 @@ tcTyVarsOfTypes :: [Type] -> TyVarSet
 tcTyVarsOfTypes tys = foldr (unionVarSet.tcTyVarsOfType) emptyVarSet tys
 
 tcTyVarsOfPred :: PredType -> TyVarSet
-tcTyVarsOfPred (IParam _ ty)  = tcTyVarsOfType ty
-tcTyVarsOfPred (ClassP _ tys) = tcTyVarsOfTypes tys
+tcTyVarsOfPred (IParam _ ty)   = tcTyVarsOfType ty
+tcTyVarsOfPred (ClassP _ tys)  = tcTyVarsOfTypes tys
+tcTyVarsOfPred (EqPred ty1 ty2) = tcTyVarsOfType ty1 `unionVarSet` tcTyVarsOfType ty2
 \end{code}
 
 Note [Silly type synonym]
@@ -1026,8 +1027,9 @@ exactTyVarsOfType ty
     go (AppTy fun arg)           = go fun `unionVarSet` go arg
     go (ForAllTy tyvar ty)       = delVarSet (go ty) tyvar
 
-    go_pred (IParam _ ty)  = go ty
-    go_pred (ClassP _ tys) = exactTyVarsOfTypes tys
+    go_pred (IParam _ ty)    = go ty
+    go_pred (ClassP _ tys)   = exactTyVarsOfTypes tys
+    go_pred (EqPred ty1 ty2) = go ty1 `unionVarSet` go ty2
 
 exactTyVarsOfTypes :: [TcType] -> TyVarSet
 exactTyVarsOfTypes tys = foldr (unionVarSet . exactTyVarsOfType) emptyVarSet tys
@@ -1043,6 +1045,7 @@ tyClsNamesOfType (TyConApp tycon tys)         = unitNameSet (getName tycon) `unionNa
 tyClsNamesOfType (NoteTy _ ty2)            = tyClsNamesOfType ty2
 tyClsNamesOfType (PredTy (IParam n ty))     = tyClsNamesOfType ty
 tyClsNamesOfType (PredTy (ClassP cl tys))   = unitNameSet (getName cl) `unionNameSets` tyClsNamesOfTypes tys
+tyClsNamesOfType (PredTy (EqPred ty1 ty2))  = tyClsNamesOfType ty1 `unionNameSets` tyClsNamesOfType ty2
 tyClsNamesOfType (FunTy arg res)           = tyClsNamesOfType arg `unionNameSets` tyClsNamesOfType res
 tyClsNamesOfType (AppTy fun arg)           = tyClsNamesOfType fun `unionNameSets` tyClsNamesOfType arg
 tyClsNamesOfType (ForAllTy tyvar ty)       = tyClsNamesOfType ty
index 1295ab3..000024e 100644 (file)
@@ -25,7 +25,8 @@ module TcUnify (
 
 #include "HsVersions.h"
 
-import HsSyn           ( ExprCoFn(..), idCoercion, isIdCoercion, (<.>) )
+import HsSyn           ( ExprCoFn(..), idCoercion, isIdCoercion, (<.>),
+                         mkCoLams, mkCoTyLams, mkCoApps )
 import TypeRep         ( Type(..), PredType(..) )
 
 import TcMType         ( lookupTcTyVar, LookupTyVarResult(..),
@@ -61,7 +62,7 @@ import Type           ( Kind, SimpleKind, KindVar,
                          isSubKind, pprKind, splitKindFunTys, isSubKindCon,
                           isOpenTypeKind, isArgTypeKind )
 import TysPrim         ( alphaTy, betaTy )
-import Inst            ( newDicts, instToId, mkInstCoFn )
+import Inst            ( newDictBndrsO, instCall, instToId )
 import TyCon           ( TyCon, tyConArity, tyConTyVars, isSynTyCon )
 import TysWiredIn      ( listTyCon )
 import Id              ( Id, mkSysLocal )
@@ -698,13 +699,12 @@ tc_sub1 mb_fun act_sty actual_ty exp_ib exp_sty expected_ty
        ; traceTc (text "tc_sub_spec" <+> vcat [ppr actual_ty, 
                                                ppr tyvars <+> ppr theta <+> ppr tau,
                                                ppr tau'])
-       ; co_fn <- tc_sub mb_fun tau' tau' exp_ib exp_sty expected_ty
+       ; co_fn2 <- tc_sub mb_fun tau tau exp_ib exp_sty expected_ty
 
                -- Deal with the dictionaries
-       ; dicts <- newDicts InstSigOrigin (substTheta subst' theta)
-       ; extendLIEs dicts
-       ; let inst_fn = mkInstCoFn inst_tys dicts
-       ; return (co_fn <.> inst_fn) }
+       ; co_fn1 <- instCall InstSigOrigin (mkTyVarTys tyvars) theta
+       ; co_fn2 <- tc_sub False tau tau exp_sty expected_ty
+       ; return (co_fn2 <.> co_fn1) }
 
 -----------------------------------
 -- Function case (rule F1)
@@ -748,7 +748,7 @@ wrapFunResCoercion arg_tys co_fn_res
   | otherwise         
   = do { us <- newUniqueSupply
        ; let arg_ids = zipWith (mkSysLocal FSLIT("sub")) (uniqsFromSupply us) arg_tys
-       ; return (CoLams arg_ids <.> co_fn_res <.> CoApps arg_ids) }
+       ; return (mkCoLams arg_ids <.> co_fn_res <.> mkCoApps arg_ids) }
 \end{code}
 
 
@@ -802,7 +802,7 @@ tcGen expected_ty extra_tvs thing_inside    -- We expect expected_ty to be a forall
        -- Conclusion: include the free vars of the expected_ty in the
        -- list of "free vars" for the signature check.
 
-       ; dicts <- newDicts (SigOrigin skol_info) theta
+       ; dicts <- newDictBndrsO (SigOrigin skol_info) theta
        ; inst_binds <- tcSimplifyCheck sig_msg forall_tvs dicts lie
 
        ; checkSigTyVarsWrt free_tvs forall_tvs
@@ -811,7 +811,7 @@ tcGen expected_ty extra_tvs thing_inside    -- We expect expected_ty to be a forall
        ; let
            -- The CoLet binds any Insts which came out of the simplification.
                dict_ids = map instToId dicts
-               co_fn = CoTyLams forall_tvs <.> CoLams dict_ids <.> CoLet inst_binds
+               co_fn = mkCoTyLams forall_tvs <.> mkCoLams dict_ids <.> CoLet inst_binds
        ; returnM (co_fn, result) }
   where
     free_tvs = tyVarsOfType expected_ty `unionVarSet` extra_tvs
@@ -1331,6 +1331,7 @@ checkTauTvUpdate orig_tv orig_ty
 
     go_pred (ClassP c tys) = do { tys' <- mapM go tys; return (ClassP c tys') }
     go_pred (IParam n ty)  = do { ty' <- go ty;        return (IParam n ty') }
+    go_pred (EqPred t1 t2) = do { t1' <- go t1; t2' <- go t2; return (EqPred t1' t2') }
 
     go_tyvar tv (SkolemTv _) = return (TyVarTy tv)
     go_tyvar tv (MetaTv box ref)
index 4614395..fd8e8c5 100644 (file)
@@ -106,18 +106,15 @@ import TypeRep
 
 -- friends:
 import Var     ( Var, TyVar, tyVarKind, tyVarName, 
-                 setTyVarName, setTyVarKind, mkTyVar, isTyVar )
-import Name    ( Name(..) )
-import Unique  ( Unique )
+                 setTyVarName, setTyVarKind )
 import VarEnv
 import VarSet
 
 import OccName ( tidyOccName )
-import Name    ( NamedThing(..), mkInternalName, tidyNameOcc )
+import Name    ( NamedThing(..), tidyNameOcc )
 import Class   ( Class, classTyCon )
 import PrelNames( openTypeKindTyConKey, unliftedTypeKindTyConKey, 
-                  ubxTupleKindTyConKey, argTypeKindTyConKey, 
-                  eqCoercionKindTyConKey )
+                  ubxTupleKindTyConKey, argTypeKindTyConKey )
 import TyCon   ( TyCon, isRecursiveTyCon, isPrimTyCon,
                  isUnboxedTupleTyCon, isUnLiftedTyCon,
                  isFunTyCon, isNewTyCon, newTyConRep, newTyConRhs,
@@ -129,7 +126,6 @@ import TyCon        ( TyCon, isRecursiveTyCon, isPrimTyCon,
 
 -- others
 import StaticFlags     ( opt_DictsStrict )
-import SrcLoc          ( noSrcLoc )
 import Util            ( mapAccumL, seqList, lengthIs, snocView, thenCmp, isEqual, all2 )
 import Outputable
 import UniqSet         ( sizeUniqSet )         -- Should come via VarSet
@@ -681,8 +677,9 @@ tyVarsOfTypes :: [Type] -> TyVarSet
 tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
 
 tyVarsOfPred :: PredType -> TyVarSet
-tyVarsOfPred (IParam _ ty)  = tyVarsOfType ty
-tyVarsOfPred (ClassP _ tys) = tyVarsOfTypes tys
+tyVarsOfPred (IParam _ ty)    = tyVarsOfType ty
+tyVarsOfPred (ClassP _ tys)   = tyVarsOfTypes tys
+tyVarsOfPred (EqPred ty1 ty2) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
 
 tyVarsOfTheta :: ThetaType -> TyVarSet
 tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet
@@ -756,6 +753,7 @@ tidyTypes env tys = map (tidyType env) tys
 tidyPred :: TidyEnv -> PredType -> PredType
 tidyPred env (IParam n ty)     = IParam n (tidyType env ty)
 tidyPred env (ClassP clas tys) = ClassP clas (tidyTypes env tys)
+tidyPred env (EqPred ty1 ty2)  = EqPred (tidyType env ty1) (tidyType env ty2)
 \end{code}
 
 
@@ -874,8 +872,9 @@ seqNote :: TyNote -> ()
 seqNote (FTVNote set) = sizeUniqSet set `seq` ()
 
 seqPred :: PredType -> ()
-seqPred (ClassP c tys) = c  `seq` seqTypes tys
-seqPred (IParam n ty)  = n  `seq` seqType ty
+seqPred (ClassP c tys)   = c `seq` seqTypes tys
+seqPred (IParam n ty)    = n `seq` seqType ty
+seqPred (EqPred ty1 ty2) = seqType ty1 `seq` seqType ty2
 \end{code}
 
 
index 9f5b405..0f810da 100644 (file)
@@ -11,13 +11,10 @@ module Unify (
 import Var             ( Var, TyVar, tyVarKind )
 import VarEnv
 import VarSet
-import Type            ( typeKind, tyVarsOfType, tyVarsOfTypes, tyVarsOfTheta, mkTyVarTys,
-                         TvSubstEnv, emptyTvSubstEnv, TvSubst(..), substTy, tcEqTypeX,
-                         mkOpenTvSubst, tcView, isSubKind, eqKind, repSplitAppTy_maybe )
-import TypeRep          ( Type(..), PredType(..), funTyCon )
-import DataCon                 ( DataCon, dataConResTys )
-import Util            ( snocView )
-import ErrUtils                ( Message )
+import Type            ( typeKind, tyVarsOfType, tyVarsOfTypes, tyVarsOfTheta, 
+                         TvSubstEnv, emptyTvSubstEnv, TvSubst(..), tcEqTypeX,
+                         tcView, isSubKind, repSplitAppTy_maybe )
+import TypeRep          ( Type(..), PredType(..) )
 import Outputable
 import Maybes
 \end{code}