Implement -XConstraintKind
authorMax Bolingbroke <batterseapower@hotmail.com>
Tue, 6 Sep 2011 16:22:47 +0000 (17:22 +0100)
committerMax Bolingbroke <batterseapower@hotmail.com>
Tue, 6 Sep 2011 19:48:41 +0000 (20:48 +0100)
Basically as documented in http://hackage.haskell.org/trac/ghc/wiki/KindFact,
this patch adds a new kind Constraint such that:

  Show :: * -> Constraint
  (?x::Int) :: Constraint
  (Int ~ a) :: Constraint

And you can write *any* type with kind Constraint to the left of (=>):
even if that type is a type synonym, type variable, indexed type or so on.

The following (somewhat related) changes are also made:
 1. We now box equality evidence. This is required because we want
    to give (Int ~ a) the *lifted* kind Constraint
 2. For similar reasons, implicit parameters can now only be of
    a lifted kind. (?x::Int#) => ty is now ruled out
 3. Implicit parameter constraints are now allowed in superclasses
    and instance contexts (this just falls out as OK with the new
    constraint solver)

Internally the following major changes were made:
 1. There is now no PredTy in the Type data type. Instead
    GHC checks the kind of a type to figure out if it is a predicate
 2. There is now no AClass TyThing: we represent classes as TyThings
    just as a ATyCon (classes had TyCons anyway)
 3. What used to be (~) is now pretty-printed as (~#). The box
    constructor EqBox :: (a ~# b) -> (a ~ b)
 4. The type LCoercion is used internally in the constraint solver
    and type checker to represent coercions with free variables
    of type (a ~ b) rather than (a ~# b)

125 files changed:
compiler/basicTypes/BasicTypes.lhs
compiler/basicTypes/DataCon.lhs
compiler/basicTypes/MkId.lhs
compiler/basicTypes/Name.lhs
compiler/basicTypes/OccName.lhs
compiler/basicTypes/SrcLoc.lhs
compiler/basicTypes/Unique.lhs
compiler/basicTypes/Var.lhs
compiler/codeGen/ClosureInfo.lhs
compiler/codeGen/StgCmmClosure.hs
compiler/coreSyn/CoreLint.lhs
compiler/coreSyn/CoreSubst.lhs
compiler/coreSyn/MkCore.lhs
compiler/coreSyn/MkExternalCore.lhs
compiler/coreSyn/PprCore.lhs
compiler/coreSyn/TrieMap.lhs
compiler/deSugar/Check.lhs
compiler/deSugar/Desugar.lhs
compiler/deSugar/DsArrows.lhs
compiler/deSugar/DsBinds.lhs
compiler/deSugar/DsCCall.lhs
compiler/deSugar/DsExpr.lhs
compiler/deSugar/DsMeta.hs
compiler/deSugar/DsMonad.lhs
compiler/deSugar/DsUtils.lhs
compiler/deSugar/Match.lhs
compiler/deSugar/MatchCon.lhs
compiler/ghc.cabal.in
compiler/ghci/RtClosureInspect.hs
compiler/hsSyn/Convert.lhs
compiler/hsSyn/HsBinds.lhs
compiler/hsSyn/HsExpr.lhs
compiler/hsSyn/HsPat.lhs
compiler/hsSyn/HsTypes.lhs
compiler/hsSyn/HsUtils.lhs
compiler/iface/BinIface.hs
compiler/iface/BuildTyCl.lhs
compiler/iface/IfaceEnv.lhs
compiler/iface/IfaceSyn.lhs
compiler/iface/IfaceType.lhs
compiler/iface/MkIface.lhs
compiler/iface/TcIface.lhs
compiler/main/DynFlags.hs
compiler/main/GHC.hs
compiler/main/HscTypes.lhs
compiler/main/InteractiveEval.hs
compiler/main/PprTyThing.hs
compiler/main/TidyPgm.lhs
compiler/parser/Lexer.x
compiler/parser/Parser.y.pp
compiler/parser/ParserCore.y
compiler/parser/RdrHsSyn.lhs
compiler/prelude/PrelNames.lhs
compiler/prelude/PrelRules.lhs
compiler/prelude/PrimOp.lhs
compiler/prelude/TysPrim.lhs
compiler/prelude/TysWiredIn.lhs
compiler/prelude/TysWiredIn.lhs-boot [new file with mode: 0644]
compiler/rename/RnBinds.lhs
compiler/rename/RnEnv.lhs
compiler/rename/RnExpr.lhs
compiler/rename/RnHsSyn.lhs
compiler/rename/RnNames.lhs
compiler/rename/RnPat.lhs
compiler/rename/RnSource.lhs
compiler/rename/RnTypes.lhs
compiler/specialise/SpecConstr.lhs
compiler/specialise/Specialise.lhs
compiler/stranal/WwLib.lhs
compiler/typecheck/Inst.lhs
compiler/typecheck/TcArrows.lhs
compiler/typecheck/TcBinds.lhs
compiler/typecheck/TcCanonical.lhs
compiler/typecheck/TcClassDcl.lhs
compiler/typecheck/TcDeriv.lhs
compiler/typecheck/TcEnv.lhs
compiler/typecheck/TcErrors.lhs
compiler/typecheck/TcExpr.lhs
compiler/typecheck/TcGenDeriv.lhs
compiler/typecheck/TcHsSyn.lhs
compiler/typecheck/TcHsType.lhs
compiler/typecheck/TcInstDcls.lhs
compiler/typecheck/TcInteract.lhs
compiler/typecheck/TcMType.lhs
compiler/typecheck/TcMatches.lhs
compiler/typecheck/TcPat.lhs
compiler/typecheck/TcRnDriver.lhs
compiler/typecheck/TcRnMonad.lhs
compiler/typecheck/TcRnTypes.lhs
compiler/typecheck/TcSMonad.lhs
compiler/typecheck/TcSimplify.lhs
compiler/typecheck/TcSplice.lhs
compiler/typecheck/TcTyClsDecls.lhs
compiler/typecheck/TcTyDecls.lhs
compiler/typecheck/TcType.lhs
compiler/typecheck/TcUnify.lhs
compiler/typecheck/TcUnify.lhs-boot
compiler/types/Class.lhs
compiler/types/Coercion.lhs
compiler/types/FamInstEnv.lhs
compiler/types/FunDeps.lhs
compiler/types/IParam.lhs [new file with mode: 0644]
compiler/types/IParam.lhs-boot [new file with mode: 0644]
compiler/types/Kind.lhs
compiler/types/TyCon.lhs
compiler/types/TyCon.lhs-boot
compiler/types/Type.lhs
compiler/types/Type.lhs-boot [new file with mode: 0644]
compiler/types/TypeRep.lhs
compiler/types/TypeRep.lhs-boot
compiler/types/Unify.lhs
compiler/utils/Util.lhs
compiler/vectorise/Vectorise/Builtins/Base.hs
compiler/vectorise/Vectorise/Builtins/Initialise.hs
compiler/vectorise/Vectorise/Type/Classify.hs
compiler/vectorise/Vectorise/Type/PADict.hs
compiler/vectorise/Vectorise/Type/PRepr.hs
compiler/vectorise/Vectorise/Type/TyConDecl.hs
compiler/vectorise/Vectorise/Type/Type.hs
compiler/vectorise/Vectorise/Utils/Closure.hs
compiler/vectorise/Vectorise/Utils/PADict.hs
docs/users_guide/flags.xml
docs/users_guide/glasgow_exts.xml
ghc/GhciTags.hs
utils/genprimopcode/Main.hs

index 14ef2c5..e892316 100644 (file)
@@ -44,7 +44,8 @@ module BasicTypes(
 
        Boxity(..), isBoxed, 
 
-       TupCon(..), tupleParens,
+        TupleSort(..), tupleSortBoxity, boxityNormalTupleSort,
+        tupleParens,
 
        OccInfo(..), seqOccInfo, zapFragileOcc, isOneOcc, 
        isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isNoOcc,
@@ -168,9 +169,10 @@ early in the hierarchy), but also in HsSyn.
 
 \begin{code}
 newtype IPName name = IPName name      -- ?x
-  deriving( Eq, Ord, Data, Typeable )
-  -- Ord is used in the IP name cache finite map
-  -- (used in HscTypes.OrigIParamCache)
+  deriving( Eq, Data, Typeable )
+
+instance Functor IPName where
+    fmap = mapIPName
 
 ipNameName :: IPName name -> name
 ipNameName (IPName n) = n
@@ -284,7 +286,7 @@ instance Outputable TopLevelFlag where
 
 %************************************************************************
 %*                                                                     *
-               Top-level/not-top level flag
+               Boxity flag
 %*                                                                     *
 %************************************************************************
 
@@ -382,14 +384,25 @@ pprSafeOverlap False = empty
 %************************************************************************
 
 \begin{code}
-data TupCon = TupCon Boxity Arity
-
-instance Eq TupCon where
-  (TupCon b1 a1) == (TupCon b2 a2) = b1==b2 && a1==a2
-   
-tupleParens :: Boxity -> SDoc -> SDoc
-tupleParens Boxed   p = parens p
-tupleParens Unboxed p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)")
+data TupleSort
+  = BoxedTuple
+  | UnboxedTuple
+  | FactTuple
+  deriving( Eq, Data, Typeable )
+
+tupleSortBoxity :: TupleSort -> Boxity
+tupleSortBoxity BoxedTuple   = Boxed
+tupleSortBoxity UnboxedTuple = Unboxed
+tupleSortBoxity FactTuple    = Boxed
+
+boxityNormalTupleSort :: Boxity -> TupleSort
+boxityNormalTupleSort Boxed   = BoxedTuple
+boxityNormalTupleSort Unboxed = UnboxedTuple
+
+tupleParens :: TupleSort -> SDoc -> SDoc
+tupleParens BoxedTuple   p = parens p
+tupleParens FactTuple    p = parens p -- The user can't write fact tuples directly, we overload the (,,) syntax
+tupleParens UnboxedTuple p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)")
 \end{code}
 
 %************************************************************************
index 6e02ed9..c773d58 100644 (file)
@@ -47,11 +47,11 @@ import TyCon
 import Class
 import Name
 import Var
-import BasicTypes
 import Outputable
 import Unique
 import ListSetOps
 import Util
+import BasicTypes
 import FastString
 import Module
 
@@ -535,7 +535,7 @@ mkDataCon name declared_infix
        -- source-language arguments.  We add extra ones for the
        -- dictionary arguments right here.
     full_theta   = eqSpecPreds eq_spec ++ theta
-    real_arg_tys = mkPredTys full_theta               ++ orig_arg_tys
+    real_arg_tys = full_theta                         ++ orig_arg_tys
     real_stricts = map mk_dict_strict_mark full_theta ++ arg_stricts
 
        -- Representation arguments and demands
@@ -551,8 +551,9 @@ eqSpecPreds :: [(TyVar,Type)] -> ThetaType
 eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv, ty) | (tv,ty) <- spec ]
 
 mk_dict_strict_mark :: PredType -> HsBang
-mk_dict_strict_mark pred | isStrictPred pred = HsStrict
-                        | otherwise         = HsNoBang
+mk_dict_strict_mark pred | isEqPred pred = HsUnpack
+                        | otherwise     = HsNoBang
+
 \end{code}
 
 \begin{code}
@@ -658,7 +659,7 @@ dataConStrictMarks = dcStrictMarks
 -- | Strictness of evidence arguments to the wrapper function
 dataConExStricts :: DataCon -> [HsBang]
 -- Usually empty, so we don't bother to cache this
-dataConExStricts dc = map mk_dict_strict_mark (dataConTheta dc)
+dataConExStricts dc = map mk_dict_strict_mark (dataConTheta dc)
 
 -- | Source-level arity of the data constructor
 dataConSourceArity :: DataCon -> Arity
@@ -746,7 +747,7 @@ dataConUserType  (MkData { dcUnivTyVars = univ_tvs,
                           dcOtherTheta = theta, dcOrigArgTys = arg_tys,
                           dcOrigResTy = res_ty })
   = mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $
-    mkFunTys (mkPredTys theta) $
+    mkFunTys theta $
     mkFunTys arg_tys $
     res_ty
 
@@ -841,11 +842,16 @@ dataConCannotMatch tys con
   | all isTyVarTy tys = False  -- Also common
   | otherwise
   = typesCantMatch [(Type.substTy subst ty1, Type.substTy subst ty2)
-                   | EqPred ty1 ty2 <- theta ]
+                   | (ty1, ty2) <- concatMap (predEqs . predTypePredTree) theta ]
   where
     dc_tvs  = dataConUnivTyVars con
     theta   = dataConTheta con
     subst   = zipTopTvSubst dc_tvs tys
+
+    -- TODO: could gather equalities from superclasses too
+    predEqs (EqPred ty1 ty2) = [(ty1, ty2)]
+    predEqs (TuplePred ts)   = concatMap predEqs ts
+    predEqs _                = []
 \end{code}
 
 %************************************************************************
@@ -935,4 +941,4 @@ computeRep stricts tys
                       where
                         (_tycon, _tycon_args, arg_dc, arg_tys) 
                            = deepSplitProductType "unbox_strict_arg_ty" ty
-\end{code}
+\end{code}
\ No newline at end of file
index 7993b05..5ad9b0e 100644 (file)
@@ -293,20 +293,23 @@ mkDataConIds wrap_name wkr_name data_con
         -- extra constraints where necessary.
     wrap_tvs    = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
     res_ty_args = substTyVars (mkTopTvSubst eq_spec) univ_tvs
-    ev_tys      = mkPredTys other_theta
+    ev_tys      = other_theta
     wrap_ty     = mkForAllTys wrap_tvs $ 
                   mkFunTys ev_tys $
                   mkFunTys orig_arg_tys $ res_ty
 
         ----------- Wrappers for algebraic data types -------------- 
     alg_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty alg_wrap_info
-    alg_wrap_info = noCafIdInfo         -- The NoCaf-ness is set by noCafIdInfo
+    alg_wrap_info = noCafIdInfo
                     `setArityInfo`         wrap_arity
                         -- It's important to specify the arity, so that partial
                         -- applications are treated as values
                    `setInlinePragInfo`    alwaysInlinePragma
                     `setUnfoldingInfo`     wrap_unf
                     `setStrictnessInfo` Just wrap_sig
+                        -- We need to get the CAF info right here because TidyPgm
+                        -- does not tidy the IdInfo of implicit bindings (like the wrapper)
+                        -- so it not make sure that the CAF info is sane
 
     all_strict_marks = dataConExStricts data_con ++ dataConStrictMarks data_con
     wrap_sig = mkStrictSig (mkTopDmdType wrap_arg_dmds cpr_info)
@@ -339,6 +342,8 @@ mkDataConIds wrap_name wkr_name data_con
                                      `mkVarApps` ex_tvs                 
                                      `mkCoApps`  map (mkReflCo . snd) eq_spec
                                      `mkVarApps` reverse rep_ids
+                            -- Dont box the eq_spec coercions since they are
+                            -- marked as HsUnpack by mk_dict_strict_mark
 
     (ev_args,i2) = mkLocals 1  ev_tys
     (id_args,i3) = mkLocals i2 orig_arg_tys
@@ -481,7 +486,7 @@ mkDictSelId no_unf name clas
 
     the_arg_id     = arg_ids !! val_index
     pred                  = mkClassPred clas (mkTyVarTys tyvars)
-    dict_id               = mkTemplateLocal 1 $ mkPredTy pred
+    dict_id               = mkTemplateLocal 1 pred
     arg_ids               = mkTemplateLocalsNum 2 arg_tys
 
     rhs = mkLams tyvars  (Lam dict_id   rhs_body)
@@ -838,7 +843,7 @@ mkDictFunId dfun_name tvs theta clas tys
 
 mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> Type
 mkDictFunTy tvs theta clas tys
-  = mkSigmaTy tvs theta (mkDictTy clas tys)
+  = mkSigmaTy tvs theta (mkClassPred clas tys)
 \end{code}
 
 
@@ -1038,7 +1043,7 @@ voidArgId       -- :: State# RealWorld
 coercionTokenId :: Id        -- :: () ~ ()
 coercionTokenId -- Used to replace Coercion terms when we go to STG
   = pcMiscPrelId coercionTokenName 
-                 (mkTyConApp eqPredPrimTyCon [unitTy, unitTy])
+                 (mkTyConApp eqPrimTyCon [unitTy, unitTy])
                  noCafIdInfo
 \end{code}
 
index 94ad72d..db24f75 100644 (file)
@@ -40,7 +40,7 @@ module Name (
        mkSystemName, mkSystemNameAt,
         mkInternalName, mkDerivedInternalName, 
        mkSystemVarName, mkSysTvName, 
-       mkFCallName, mkIPName,
+       mkFCallName,
         mkTickBoxOpName,
        mkExternalName, mkWiredInName,
 
@@ -302,14 +302,6 @@ mkTickBoxOpName :: Unique -> String -> Name
 mkTickBoxOpName uniq str 
    = Name { n_uniq = getKeyFastInt uniq, n_sort = Internal, 
            n_occ = mkVarOcc str, n_loc = noSrcSpan }
-
--- | Make the name of an implicit parameter
-mkIPName :: Unique -> OccName -> Name
-mkIPName uniq occ
-  = Name { n_uniq = getKeyFastInt uniq,
-          n_sort = Internal,
-          n_occ  = occ,
-          n_loc = noSrcSpan }
 \end{code}
 
 \begin{code}
index 3ae9b54..3b1b41f 100644 (file)
@@ -51,7 +51,7 @@ module OccName (
        mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc,
        mkDerivedTyConOcc, mkNewTyCoOcc, mkClassOpAuxOcc,
         mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
-       mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, 
+       mkClassDataConOcc, mkDictOcc, mkIPOcc, 
        mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
        mkGenD, mkGenR, mkGenRCo, mkGenC, mkGenS,
        mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc,
@@ -541,12 +541,12 @@ isDerivedOccName occ =
 
 \begin{code}
 mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc,
-  mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkDictOcc,
-  mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
-  mkGenD, mkGenR, mkGenRCo,
-  mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc,
-  mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,
-  mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc
+       mkDerivedTyConOcc, mkClassDataConOcc, mkDictOcc,
+       mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
+       mkGenD, mkGenR, mkGenRCo,
+       mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc,
+       mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,
+        mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc
    :: OccName -> OccName
 
 -- These derived variables have a prefix that no Haskell value could have
@@ -555,8 +555,7 @@ mkWorkerOcc         = mk_simple_deriv varName  "$w"
 mkDefaultMethodOcc  = mk_simple_deriv varName  "$dm"
 mkGenDefMethodOcc   = mk_simple_deriv varName  "$gdm"
 mkClassOpAuxOcc     = mk_simple_deriv varName  "$c"
-mkDerivedTyConOcc   = mk_simple_deriv tcName   ":"     -- The : prefix makes sure it classifies
-mkClassTyConOcc     = mk_simple_deriv tcName   "T:"    -- as a tycon/datacon
+mkDerivedTyConOcc   = mk_simple_deriv tcName   ":"     -- The : prefix makes sure it classifies as a tycon/datacon
 mkClassDataConOcc   = mk_simple_deriv dataName "D:"    -- We go straight to the "real" data con
                                                        -- for datacons from classes
 mkDictOcc          = mk_simple_deriv varName  "$d"
@@ -624,8 +623,8 @@ mkDataConWorkerOcc datacon_occ = setOccNameSpace varName datacon_occ
 mkSuperDictSelOcc :: Int       -- ^ Index of superclass, e.g. 3
                  -> OccName    -- ^ Class, e.g. @Ord@
                  -> OccName    -- ^ Derived 'Occname', e.g. @$p3Ord@
-mkSuperDictSelOcc index cls_occ
-  = mk_deriv varName "$p" (show index ++ occNameString cls_occ)
+mkSuperDictSelOcc index cls_tc_occ
+  = mk_deriv varName "$p" (show index ++ occNameString cls_tc_occ)
 
 mkLocalOcc :: Unique           -- ^ Unique to combine with the 'OccName'
           -> OccName           -- ^ Local name, e.g. @sat@
@@ -751,24 +750,43 @@ tidyOccName in_scope occ@(OccName occ_sp fs)
 %************************************************************************
 
 \begin{code}
-mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName
-mkTupleOcc ns bx ar = OccName ns (mkFastString str)
+mkTupleOcc :: NameSpace -> TupleSort -> Arity -> OccName
+mkTupleOcc ns sort ar = OccName ns (mkFastString str)
   where
        -- no need to cache these, the caching is done in the caller
        -- (TysWiredIn.mk_tuple)
-    str = case bx of
-               Boxed   -> '(' : commas ++ ")"
-               Unboxed -> '(' : '#' : commas ++ "#)"
+    str = case sort of
+               UnboxedTuple -> '(' : '#' : commas ++ "#)"
+               BoxedTuple   -> '(' : commas ++ ")"
+                FactTuple    -> '(' : commas ++ ")"
+                  -- Cute hack: reuse the standard tuple OccNames (and hence code)
+                  -- for fact tuples, but give them different Uniques so they are not equal.
+                  --
+                  -- You might think that this will go wrong because isTupleOcc_maybe won't
+                  -- be able to tell the difference between boxed tuples and fact tuples. BUT:
+                  --  1. Fact tuples never occur directly in user code, so it doesn't matter
+                  --     that we can't detect them in Orig OccNames originating from the user
+                  --     programs (or those built by setRdrNameSpace used on an Exact tuple Name)
+                  --  2. Interface files have a special representation for tuple *occurrences*
+                  --     in IfaceTyCons, their workers (in IfaceSyn) and their DataCons (in case
+                  --     alternatives). Thus we don't rely on the OccName to figure out what kind
+                  --     of tuple an occurrence was trying to use in these situations.
+                  --  3. We *don't* represent tuple data type declarations specially, so those
+                  --     are still turned into wired-in names via isTupleOcc_maybe. But that's OK
+                  --     because we don't actually need to declare fact tuples thanks to this hack.
+                  --
+                  -- So basically any OccName like (,,) flowing to isTupleOcc_maybe will always
+                  -- refer to the standard boxed tuple. Cool :-)
 
     commas = take (ar-1) (repeat ',')
 
-isTupleOcc_maybe :: OccName -> Maybe (NameSpace, Boxity, Arity)
+isTupleOcc_maybe :: OccName -> Maybe (NameSpace, TupleSort, Arity)
 -- Tuples are special, because there are so many of them!
 isTupleOcc_maybe (OccName ns fs)
   = case unpackFS fs of
-       '(':'#':',':rest -> Just (ns, Unboxed, 2 + count_commas rest)
-       '(':',':rest     -> Just (ns, Boxed,   2 + count_commas rest)
-       _other           -> Nothing
+       '(':'#':',':rest     -> Just (ns, UnboxedTuple, 2 + count_commas rest)
+       '(':',':rest         -> Just (ns, BoxedTuple,   2 + count_commas rest)
+       _other               -> Nothing
   where
     count_commas (',':rest) = 1 + count_commas rest
     count_commas _          = 0
index b89d55e..c39f714 100644 (file)
@@ -99,6 +99,10 @@ data RealSrcLoc
                {-# UNPACK #-} !Int             -- line number, begins at 1
                {-# UNPACK #-} !Int             -- column number, begins at 1
 
+#ifdef DEBUG
+  deriving Show -- debugging
+#endif
+
 data SrcLoc
   = RealSrcLoc {-# UNPACK #-}!RealSrcLoc
   | UnhelpfulLoc FastString    -- Just a general indication
index 3ebf950..87c22aa 100644 (file)
@@ -34,9 +34,7 @@ module Unique (
        newTagUnique,                   -- Used in CgCase
        initTyVarUnique,
 
-       isTupleKey, 
-
-        -- ** Making built-in uniques
+       -- ** Making built-in uniques
 
        -- now all the built-in Uniques (and functions to make them)
        -- [the Oh-So-Wonderful Haskell module system wins again...]
@@ -47,7 +45,7 @@ module Unique (
        mkPreludeTyConUnique, mkPreludeClassUnique,
        mkPArrDataConUnique,
 
-        mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique,
+    mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique,
         mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique,
 
        mkBuiltinUnique,
@@ -105,8 +103,6 @@ getKeyFastInt       :: Unique -> FastInt            -- for Var
 incrUnique     :: Unique -> Unique
 deriveUnique   :: Unique -> Int -> Unique
 newTagUnique   :: Unique -> Char -> Unique
-
-isTupleKey     :: Unique -> Bool
 \end{code}
 
 
@@ -311,9 +307,9 @@ Allocation of unique supply characters:
 mkAlphaTyVarUnique     :: Int -> Unique
 mkPreludeClassUnique   :: Int -> Unique
 mkPreludeTyConUnique   :: Int -> Unique
-mkTupleTyConUnique     :: Boxity -> Int -> Unique
+mkTupleTyConUnique     :: TupleSort -> Int -> Unique
 mkPreludeDataConUnique :: Int -> Unique
-mkTupleDataConUnique   :: Boxity -> Int -> Unique
+mkTupleDataConUnique   :: TupleSort -> Int -> Unique
 mkPrimOpIdUnique       :: Int -> Unique
 mkPreludeMiscIdUnique  :: Int -> Unique
 mkPArrDataConUnique    :: Int -> Unique
@@ -327,8 +323,9 @@ mkPreludeClassUnique i          = mkUnique '2' i
 -- are for the generic to/from Ids.  See TysWiredIn.mk_tc_gen_info.
 
 mkPreludeTyConUnique i         = mkUnique '3' (3*i)
-mkTupleTyConUnique Boxed   a   = mkUnique '4' (3*a)
-mkTupleTyConUnique Unboxed a   = mkUnique '5' (3*a)
+mkTupleTyConUnique BoxedTuple   a      = mkUnique '4' (3*a)
+mkTupleTyConUnique UnboxedTuple a      = mkUnique '5' (3*a)
+mkTupleTyConUnique FactTuple    a      = mkUnique 'k' (3*a)
 
 -- Data constructor keys occupy *two* slots.  The first is used for the
 -- data constructor itself and its wrapper function (the function that
@@ -337,13 +334,9 @@ mkTupleTyConUnique Unboxed a       = mkUnique '5' (3*a)
 -- representation).
 
 mkPreludeDataConUnique i       = mkUnique '6' (2*i)    -- Must be alphabetic
-mkTupleDataConUnique Boxed a   = mkUnique '7' (2*a)    -- ditto (*may* be used in C labels)
-mkTupleDataConUnique Unboxed a = mkUnique '8' (2*a)
-
--- This one is used for a tiresome reason
--- to improve a consistency-checking error check in the renamer
-isTupleKey u = case unpkUnique u of
-               (tag,_) -> tag == '4' || tag == '5' || tag == '7' || tag == '8'
+mkTupleDataConUnique BoxedTuple   a = mkUnique '7' (2*a)       -- ditto (*may* be used in C labels)
+mkTupleDataConUnique UnboxedTuple a = mkUnique '8' (2*a)
+mkTupleDataConUnique FactTuple    a = mkUnique 'h' (2*a)
 
 mkPrimOpIdUnique op         = mkUnique '9' op
 mkPreludeMiscIdUnique  i    = mkUnique '0' i
index 5cbf89b..3319fdf 100644 (file)
@@ -32,7 +32,7 @@
 
 module Var (
         -- * The main data type and synonyms
-        Var, TyVar, CoVar, Id, DictId, DFunId, EvVar, EvId, IpId,
+        Var, TyVar, CoVar, Id, DictId, DFunId, EvVar, EqVar, EvId, IpId,
 
        -- ** Taking 'Var's apart
        varName, varUnique, varType, 
@@ -98,11 +98,12 @@ type DFunId = Id    -- A dictionary function
 type EvId   = Id        -- Term-level evidence: DictId or IpId
 type DictId = EvId     -- A dictionary variable
 type IpId   = EvId      -- A term-level implicit parameter
+type EqVar  = EvId      -- Boxed equality evidence
 
 type TyVar = Var
 type CoVar = Id                -- A coercion variable is simply an Id
-                       -- variable of kind @ty1 ~ ty2@. Hence its
-                       -- 'varType' is always @PredTy (EqPred t1 t2)@
+                       -- variable of kind @#@. Its
+                       -- 'varType' is always @ty1 ~# ty2@
 \end{code}
 
 %************************************************************************
index 04f7acb..66eeb34 100644 (file)
@@ -1091,15 +1091,9 @@ getTyDescription ty
       AppTy fun _                   -> getTyDescription fun
       FunTy _ res                   -> '-' : '>' : fun_result res
       TyConApp tycon _              -> getOccString tycon
-      PredTy sty            -> getPredTyDescription sty
       ForAllTy _ ty          -> getTyDescription ty
     }
   where
     fun_result (FunTy _ res) = '>' : fun_result res
     fun_result other        = getTyDescription other
-
-getPredTyDescription :: PredType -> String
-getPredTyDescription (ClassP cl _) = getOccString cl
-getPredTyDescription (IParam ip _) = getOccString (ipNameName ip)
-getPredTyDescription (EqPred _ _)  = "Type equality"
 \end{code}
index 12624ba..712263a 100644 (file)
@@ -855,18 +855,12 @@ getTyDescription ty
       AppTy fun _                   -> getTyDescription fun
       FunTy _ res                   -> '-' : '>' : fun_result res
       TyConApp tycon _              -> getOccString tycon
-      PredTy sty            -> getPredTyDescription sty
       ForAllTy _ ty          -> getTyDescription ty
     }
   where
     fun_result (FunTy _ res) = '>' : fun_result res
     fun_result other        = getTyDescription other
 
-getPredTyDescription :: PredType -> String
-getPredTyDescription (ClassP cl _) = getOccString cl
-getPredTyDescription (IParam ip _) = getOccString (ipNameName ip)
-getPredTyDescription (EqPred {})   = "Type equality"
-
 --------------------------------------
 --   CmmInfoTable-related things
 --------------------------------------
index 7bc82cf..db3a108 100644 (file)
@@ -20,6 +20,7 @@ import Bag
 import Literal
 import DataCon
 import TysWiredIn
+import TysPrim
 import Var
 import VarEnv
 import VarSet
@@ -27,13 +28,12 @@ import Name
 import Id
 import PprCore
 import ErrUtils
+import Coercion
 import SrcLoc
 import Kind
 import Type
 import TypeRep
-import Coercion
 import TyCon
-import Class
 import BasicTypes
 import StaticFlags
 import ListSetOps
@@ -281,10 +281,24 @@ lintCoreExpr (Let (Rec pairs) body)
     bndrs = map fst pairs
     (_, dups) = removeDups compare bndrs
 
-lintCoreExpr e@(App fun arg)
-  = do { fun_ty <- lintCoreExpr fun
-       ; addLoc (AnExpr e) $
-          lintCoreArg fun_ty arg }
+lintCoreExpr e@(App _ _)
+    | Var x <- fun -- Greivous hack for Eq# construction: Eq# may have type arguments
+                   -- of kind (* -> *) but its type insists on *. When we have polymorphic kinds,
+                   -- we should do this properly
+    , Just dc <- isDataConWorkId_maybe x
+    , dc == eqBoxDataCon
+    , [Type arg_ty1, Type arg_ty2, co_e] <- args
+    = do arg_kind1 <- lintType arg_ty1
+         arg_kind2 <- lintType arg_ty2
+         unless (arg_kind1 `eqKind` arg_kind2)
+                (addErrL (mkEqBoxKindErrMsg arg_ty1 arg_ty2))
+         
+         lintCoreArg (mkCoercionType arg_ty1 arg_ty2 `mkFunTy` mkEqPred (arg_ty1, arg_ty2)) co_e
+    | otherwise
+    = do { fun_ty <- lintCoreExpr fun
+         ; addLoc (AnExpr e) $ foldM lintCoreArg fun_ty args }
+  where
+    (fun, args) = collectArgs e
 
 lintCoreExpr (Lam var expr)
   = addLoc (LambdaBodyOf var) $
@@ -339,7 +353,7 @@ lintCoreExpr (Type ty)
 lintCoreExpr (Coercion co)
   = do { co' <- lintInCo co
        ; let Pair ty1 ty2 = coercionKind co'
-       ; return (mkPredTy $ EqPred ty1 ty2) }
+       ; return (mkCoercionType ty1 ty2) }
 \end{code}
 
 %************************************************************************
@@ -646,6 +660,10 @@ lintCoercion (ForAllCo v co)
        ; return (ForAllTy v s, ForAllTy v t) }
 
 lintCoercion (CoVarCo cv)
+  | not (isCoVar cv)
+  = failWithL (hang (ptext (sLit "Bad CoVarCo:") <+> ppr cv)
+                  2 (ptext (sLit "With offending type:") <+> ppr (varType cv)))
+  | otherwise
   = do { checkTyCoVarInScope cv
        ; return (coVarKind cv) }
 
@@ -716,7 +734,9 @@ lintType ty@(FunTy t1 t2)
   = lint_ty_app ty (tyConKind funTyCon) [t1,t2]
 
 lintType ty@(TyConApp tc tys)
-  | tc `hasKey` eqPredPrimTyConKey     -- See Note [The (~) TyCon] in TysPrim
+  | tc `hasKey` eqPrimTyConKey -- See Note [The ~# TyCon] in TysPrim
+  = lint_prim_eq_pred ty tys
+  | tc `hasKey` eqTyConKey
   = lint_eq_pred ty tys
   | tyConHasKind tc
   = lint_ty_app ty (tyConKind tc) tys
@@ -727,20 +747,6 @@ lintType (ForAllTy tv ty)
   = do { lintTyBndrKind tv
        ; addInScopeVar tv (lintType ty) }
 
-lintType ty@(PredTy (ClassP cls tys))
-  = lint_ty_app ty (tyConKind (classTyCon cls)) tys
-
-lintType (PredTy (IParam _ p_ty))
-  = lintType p_ty
-
-lintType ty@(PredTy (EqPred t1 t2))
-  = do { k1 <- lintType t1
-       ; k2 <- lintType t2
-       ; unless (k1 `eqKind` k2) 
-                (addErrL (sep [ ptext (sLit "Kind mis-match in equality predicate:")
-                              , nest 2 (ppr ty) ]))
-       ; return unliftedTypeKind }
-
 ----------------
 lint_ty_app :: Type -> Kind -> [OutType] -> LintM Kind
 lint_ty_app ty k tys 
@@ -748,7 +754,21 @@ lint_ty_app ty k tys
        ; lint_kind_app (ptext (sLit "type") <+> quotes (ppr ty)) k ks }
 
 lint_eq_pred :: Type -> [OutType] -> LintM Kind
-lint_eq_pred ty arg_tys
+lint_eq_pred ty arg_tys = case arg_tys of
+  [ty1, ty2] ->  do { k1 <- lintType ty1
+                    ; k2 <- lintType ty2
+                    ; unless (k1 `eqKind` k2) 
+                             (addErrL (sep [ ptext (sLit "Kind mis-match in equality predicate:")
+                                           , nest 2 (ppr ty) ]))
+                    ; return constraintKind }
+  [ty1] -> do { k1 <- lintType ty1;
+                return (k1 `mkFunTy` constraintKind) }
+  []    -> do { return (typeKind ty) }
+  _     -> failWithL (ptext (sLit "Oversaturated (~) type") <+> ppr ty)
+
+
+lint_prim_eq_pred :: Type -> [OutType] -> LintM Kind
+lint_prim_eq_pred ty arg_tys
   | [ty1,ty2] <- arg_tys
   = do { k1 <- lintType ty1
        ; k2 <- lintType ty2
@@ -756,7 +776,7 @@ lint_eq_pred ty arg_tys
                 (ptext (sLit "Mismatched arg kinds:") <+> ppr ty)
        ; return unliftedTypeKind }
   | otherwise
-  = failWithL (ptext (sLit "Unsaturated (~) type") <+> ppr ty)
+  = failWithL (ptext (sLit "Unsaturated ~# type") <+> ppr ty)
 
 ----------------
 check_co_app :: Coercion -> Kind -> [OutType] -> LintM ()
@@ -926,7 +946,7 @@ lookupIdInScope id
 
 
 oneTupleDataConId :: Id        -- Should not happen
-oneTupleDataConId = dataConWorkId (tupleCon Boxed 1)
+oneTupleDataConId = dataConWorkId (tupleCon BoxedTuple 1)
 
 checkBndrIdInScope :: Var -> Var -> LintM ()
 checkBndrIdInScope binder id 
@@ -1127,6 +1147,14 @@ mkStrictMsg binder
             ]
 
 
+mkEqBoxKindErrMsg :: Type -> Type -> Message
+mkEqBoxKindErrMsg ty1 ty2
+  = vcat [ptext (sLit "Kinds don't match in type arguments of Eq#:"),
+          hang (ptext (sLit "Arg type 1:"))   
+                 4 (ppr ty1 <+> dcolon <+> ppr (typeKind ty1)),
+          hang (ptext (sLit "Arg type 2:"))   
+                 4 (ppr ty2 <+> dcolon <+> ppr (typeKind ty2))]
+
 mkKindErrMsg :: TyVar -> Type -> Message
 mkKindErrMsg tyvar arg_ty
   = vcat [ptext (sLit "Kinds don't match in type application:"),
index 8de2c4f..be1d7ae 100644 (file)
@@ -51,6 +51,7 @@ import Coercion hiding ( substTy, substCo, extendTvSubst, substTyVarBndr, substC
 
 import OptCoercion ( optCoercion )
 import PprCore     ( pprCoreBindings, pprRules )
+import PrelNames   ( eqBoxDataConKey )
 import Module     ( Module )
 import VarSet
 import VarEnv
@@ -768,6 +769,28 @@ InlVanilla.  The WARN is just so I can see if it happens a lot.
 %*                                                                     *
 %************************************************************************
 
+Note [Optimise coercion boxes agressively]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The simple expression optimiser has special cases for Eq# boxes as follows:
+ 1. If the result of optimising the RHS of a non-recursive binding is an
+    Eq# box, that box is substituted rather than turned into a let, just as
+    if it were trivial.
+
+ 2. If the result of optimising a case scrutinee is a Eq# box and the case
+    deconstructs it in a trivial way, we evaluate the case then and there.
+
+We do this for two reasons:
+
+ 1. Bindings/case scrutinisation of this form is often created by the
+    evidence-binding mechanism and we need them to be inlined to be able
+    desugar RULE LHSes that involve equalities (see e.g. T2291)
+
+ 2. The test T4356 fails Lint because it creates a coercion between types
+    of kind (* -> * -> *) and (?? -> ? -> *), which differ. If we do this
+    inlining agressively we can collapse away the intermediate coercion between
+    these two types and hence pass Lint again. (This is a sort of a hack.)
+
 \begin{code}
 simpleOptExpr :: CoreExpr -> CoreExpr
 -- Do simple optimisation on an expression
@@ -775,6 +798,9 @@ simpleOptExpr :: CoreExpr -> CoreExpr
 -- inline non-recursive bindings that are used only once, 
 -- or where the RHS is trivial
 --
+-- We also inline bindings that bind a Eq# box: see
+-- See Note [Optimise coercion boxes agressively].
+--
 -- The result is NOT guaranteed occurence-analysed, becuase
 -- in  (let x = y in ....) we substitute for x; so y's occ-info
 -- may change radically
@@ -849,10 +875,19 @@ simple_opt_expr' subst expr
                            (subst', Just bind) -> Let bind (simple_opt_expr subst' body)
 
     go lam@(Lam {})     = go_lam [] subst lam
-    go (Case e b ty as) = Case (go e) b' (substTy subst ty)
-                                      (map (go_alt subst') as)
-                               where
-                                 (subst', b') = subst_opt_bndr subst b
+    go (Case e b ty as)
+      | [(DataAlt dc, [cov], e_alt)] <- as -- See Note [Optimise coercion boxes agressively]
+      , dc `hasKey` eqBoxDataConKey
+      , (Var fun, [Type _, Type _, Coercion co]) <- collectArgs e'
+      , isDataConWorkId fun
+      , isDeadBinder b
+      = simple_opt_expr (extendCvSubst subst cov co) e_alt
+      | otherwise
+      = Case (go e) b' (substTy subst ty)
+                              (map (go_alt subst') as)
+        where
+          e' = go e
+          (subst', b') = subst_opt_bndr subst b
 
     ----------------------
     go_alt subst (con, bndrs, rhs) 
@@ -944,8 +979,14 @@ maybe_substitute subst b r
     safe_to_inline :: OccInfo -> Bool
     safe_to_inline (IAmALoopBreaker {})     = False
     safe_to_inline IAmDead                  = True
-    safe_to_inline (OneOcc in_lam one_br _) = (not in_lam && one_br) || exprIsTrivial r
-    safe_to_inline NoOccInfo                = exprIsTrivial r
+    safe_to_inline (OneOcc in_lam one_br _) = (not in_lam && one_br) || trivial
+    safe_to_inline NoOccInfo                = trivial
+
+    trivial | exprIsTrivial r = True
+            | (Var fun, _args) <- collectArgs r
+            , Just dc <- isDataConWorkId_maybe fun
+            , dc `hasKey` eqBoxDataConKey = True -- See Note [Optimise coercion boxes agressively]
+            | otherwise = False
 
 ----------------------
 subst_opt_bndr :: Subst -> InVar -> (Subst, OutVar)
index b6bc7d4..2146158 100644 (file)
@@ -13,6 +13,12 @@ module MkCore (
         mkIntegerExpr,
         mkFloatExpr, mkDoubleExpr,
         mkCharExpr, mkStringExpr, mkStringExprFS,
+
+        -- * Constructing/deconstructing implicit parameter boxes
+        mkIPUnbox, mkIPBox,
+
+        -- * Constructing/deconstructing equality evidence boxes
+        mkEqBox,
         
         -- * Constructing general big tuples
         -- $big_tuples
@@ -45,7 +51,7 @@ module MkCore (
 #include "HsVersions.h"
 
 import Id
-import Var      ( EvVar, setTyVarUnique )
+import Var      ( IpId, EvVar, setTyVarUnique )
 
 import CoreSyn
 import CoreUtils        ( exprType, needsCaseBinding, bindNonRec )
@@ -55,19 +61,21 @@ import HscTypes
 import TysWiredIn
 import PrelNames
 
-import TcType          ( mkSigmaTy )
+import IParam           ( ipCoAxiom )
+import TcType          ( mkSigmaTy, evVarPred )
 import Type
 import Coercion
 import TysPrim
 import DataCon          ( DataCon, dataConWorkId )
 import IdInfo          ( vanillaIdInfo, setStrictnessInfo, setArityInfo )
 import Demand
-import Name
+import Name      hiding ( varName )
 import Outputable
 import FastString
 import UniqSupply
 import BasicTypes
 import Util             ( notNull, zipEqual )
+import Pair
 import Constants
 
 import Data.Char        ( ord )
@@ -151,7 +159,7 @@ mk_val_app fun arg arg_ty res_ty
        -- fragmet of it as the fun part of a 'mk_val_app'.
 
 mkWildEvBinder :: PredType -> EvVar
-mkWildEvBinder pred = mkWildValBinder (mkPredTy pred)
+mkWildEvBinder pred = mkWildValBinder pred
 
 -- | Make a /wildcard binder/. This is typically used when you need a binder 
 -- that you expect to use only at a *binding* site.  Do not use it at
@@ -286,6 +294,29 @@ mkStringExprFS str
     safeChar c = ord c >= 1 && ord c <= 0x7F
 \end{code}
 
+\begin{code}
+
+mkIPBox :: IPName IpId -> CoreExpr -> CoreExpr
+mkIPBox ipx e = e `Cast` mkSymCo (mkAxInstCo (ipCoAxiom ip) [ty])
+  where x = ipNameName ipx
+        Just (ip, ty) = getIPPredTy_maybe (evVarPred x)
+        -- NB: don't use the DataCon work id because we don't generate code for it
+
+mkIPUnbox :: IPName IpId -> CoreExpr
+mkIPUnbox ipx = Var x `Cast` mkAxInstCo (ipCoAxiom ip) [ty]
+  where x = ipNameName ipx
+        Just (ip, ty) = getIPPredTy_maybe (evVarPred x)
+
+\end{code}
+
+\begin{code}
+
+mkEqBox :: Coercion -> CoreExpr
+mkEqBox co = Var (dataConWorkId eqBoxDataCon) `mkTyApps` [ty1, ty2] `App` Coercion co
+  where Pair ty1 ty2 = coercionKind co
+
+\end{code}
+
 %************************************************************************
 %*                                                                      *
 \subsection{Tuple constructors}
@@ -360,7 +391,7 @@ mkCoreVarTupTy ids = mkBoxedTupleTy (map idType ids)
 mkCoreTup :: [CoreExpr] -> CoreExpr
 mkCoreTup []  = Var unitDataConId
 mkCoreTup [c] = c
-mkCoreTup cs  = mkConApp (tupleCon Boxed (length cs))
+mkCoreTup cs  = mkConApp (tupleCon BoxedTuple (length cs))
                          (map (Type . exprType) cs ++ cs)
 
 -- | Build a big tuple holding the specified variables
@@ -444,7 +475,7 @@ mkSmallTupleSelector [var] should_be_the_same_var _ scrut
 mkSmallTupleSelector vars the_var scrut_var scrut
   = ASSERT( notNull vars )
     Case scrut scrut_var (idType the_var)
-         [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)]
+         [(DataAlt (tupleCon BoxedTuple (length vars)), vars, Var the_var)]
 \end{code}
 
 \begin{code}
@@ -501,7 +532,7 @@ mkSmallTupleCase [var] body _scrut_var scrut
   = bindNonRec var scrut body
 mkSmallTupleCase vars body scrut_var scrut
 -- One branch no refinement?
-  = Case scrut scrut_var (exprType body) [(DataAlt (tupleCon Boxed (length vars)), vars, body)]
+  = Case scrut scrut_var (exprType body) [(DataAlt (tupleCon BoxedTuple (length vars)), vars, body)]
 \end{code}
 
 %************************************************************************
index 71c07c3..940e058 100644 (file)
@@ -14,7 +14,6 @@ import CoreSyn
 import HscTypes        
 import TyCon
 -- import Class
--- import TysPrim( eqPredPrimTyCon )
 import TypeRep
 import Type
 import PprExternalCore () -- Instances
@@ -228,8 +227,6 @@ make_ty' (TyConApp tc ts)    = make_tyConApp tc ts
 -- expose the representation in interface files, which definitely isn't right.
 -- Maybe CoreTidy should know whether to expand newtypes or not?
 
-make_ty' (PredTy p)    = make_ty (predTypeRep p)
-
 make_tyConApp :: TyCon -> [Type] -> C.Ty
 make_tyConApp tc ts =
   foldl C.Tapp (C.Tcon (qtc tc)) 
index cf92924..94f3e04 100644 (file)
@@ -143,7 +143,7 @@ ppr_expr add_par expr@(App {})
                        -- Notice that we print the *worker*
                        -- for tuples in paren'd format.
                   Just dc | saturated && isTupleTyCon tc
-                          -> tupleParens (tupleTyConBoxity tc) pp_tup_args
+                          -> tupleParens (tupleTyConSort tc) pp_tup_args
                           where
                             tc        = dataConTyCon dc
                             saturated = val_args `lengthIs` idArity f
@@ -241,7 +241,7 @@ pprCoreAlt (con, args, rhs)
 ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc
 ppr_case_pat (DataAlt dc) args
   | isTupleTyCon tc
-  = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args)))
+  = tupleParens (tupleTyConSort tc) (hsep (punctuate comma (map ppr_bndr args)))
   where
     ppr_bndr = pprBndr CaseBind
     tc = dataConTyCon dc
index 735f7dd..120b676 100644 (file)
@@ -510,7 +510,6 @@ lkT env ty m
     go (FunTy t1 t2)     = tm_fun    >.> lkT env t1 >=> lkT env t2
     go (TyConApp tc tys) = tm_tc_app >.> lkNamed tc >=> lkList (lkT env) tys
     go (ForAllTy tv ty)  = tm_forall >.> lkT (extendCME env tv) ty >=> lkBndr env tv
-    go (PredTy {})       = panic "lkT"  -- Dealt with by coreView
 
 -----------------
 xtT :: CmEnv -> Type -> XT a -> TypeMap a -> TypeMap a
@@ -525,7 +524,6 @@ xtT env (ForAllTy tv ty)  f  m = m { tm_forall = tm_forall m |> xtT (extendCME e
                                                  |>> xtBndr env tv f }
 xtT env (TyConApp tc tys) f  m = m { tm_tc_app = tm_tc_app m |> xtNamed tc 
                                                  |>> xtList (xtT env) tys f }
-xtT _   (PredTy {})       _  _ = panic "xtT"  -- Dealt with by coreView
 
 fdT :: (a -> b -> b) -> TypeMap a -> b -> b
 fdT _ EmptyTM = \z -> z
index 59c102f..49d9f3d 100644 (file)
@@ -690,7 +690,7 @@ tidy_pat (PArrPat ps ty)
                           (mkPArrTy ty)
 
 tidy_pat (TuplePat ps boxity ty)
-  = unLoc $ mkPrefixConPat (tupleCon boxity arity)
+  = unLoc $ mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity)
                           (map tidy_lpat ps) ty
   where
     arity = length ps
index 2c5a3c8..6cbda9e 100644 (file)
@@ -185,18 +185,16 @@ dsImpSpecs imp_specs
       ; let (spec_binds, spec_rules) = unzip spec_prs
       ; return (concatOL spec_binds, spec_rules) }
 
-combineEvBinds :: [DsEvBind] -> [(Id,CoreExpr)] -> [CoreBind]
+combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind]
 -- Top-level bindings can include coercion bindings, but not via superclasses
 -- See Note [Top-level evidence]
 combineEvBinds [] val_prs 
   = [Rec val_prs]
-combineEvBinds (LetEvBind (NonRec b r) : bs) val_prs
+combineEvBinds (NonRec b r : bs) val_prs
   | isId b    = combineEvBinds bs ((b,r):val_prs)
   | otherwise = NonRec b r : combineEvBinds bs val_prs
-combineEvBinds (LetEvBind (Rec prs) : bs) val_prs 
+combineEvBinds (Rec prs : bs) val_prs 
   = combineEvBinds bs (prs ++ val_prs)
-combineEvBinds (CaseEvBind x _ _ : _) _
-  = pprPanic "topEvBindPairs" (ppr x)
 \end{code}
 
 Note [Top-level evidence]
index 7f798f8..d7d5e70 100644 (file)
@@ -135,7 +135,7 @@ coreCaseTuple uniqs scrut_var vars body
 coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr
 coreCasePair scrut_var var1 var2 body
   = Case (Var scrut_var) scrut_var (exprType body)
-         [(DataAlt (tupleCon Boxed 2), [var1, var2], body)]
+         [(DataAlt (tupleCon BoxedTuple 2), [var1, var2], body)]
 \end{code}
 
 \begin{code}
index 7eceeb2..c73940e 100644 (file)
@@ -11,8 +11,8 @@ lower levels it is preserved with @let@/@letrec@s).
 
 \begin{code}
 module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
-                dsHsWrapper, dsTcEvBinds, dsEvBinds, wrapDsEvBinds, 
-                DsEvBind(..), AutoScc(..)
+                dsHsWrapper, dsTcEvBinds, dsEvBinds, 
+                AutoScc(..)
   ) where
 
 #include "HsVersions.h"
@@ -34,15 +34,16 @@ import CoreUnfold
 import CoreFVs
 import Digraph
 
+import TyCon      ( isTupleTyCon, tyConDataCons_maybe )
 import TcType
 import Type
-import Coercion
+import Coercion hiding (substCo)
+import TysWiredIn ( eqBoxDataCon, tupleCon )
 import CostCentre
 import Module
 import Id
-import TyCon   ( tyConDataCons )
 import Class
-import DataCon ( dataConRepType )
+import DataCon ( dataConWorkId )
 import Name    ( localiseName )
 import MkId    ( seqId )
 import Var
@@ -133,7 +134,7 @@ dsHsBind auto_scc (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
                rhs       = addAutoScc auto_scc global $
                            wrap_fn $  -- Usually the identity
                            mkLams tyvars $ mkLams dicts $ 
-                           wrapDsEvBinds ds_ev_binds $
+                           mkCoreLets ds_ev_binds $
                             Let core_bind $
                             Var local
     
@@ -161,7 +162,7 @@ dsHsBind auto_scc (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
              tup_expr     = mkBigCoreVarTup locals
              tup_ty       = exprType tup_expr
              poly_tup_rhs = mkLams tyvars $ mkLams dicts $
-                            wrapDsEvBinds ds_ev_binds $
+                            mkCoreLets ds_ev_binds $
                             Let core_bind $
                             tup_expr
              locals       = map abe_mono exports
@@ -187,28 +188,11 @@ dsHsBind auto_scc (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
                    concatOL export_binds_s) }
 
 --------------------------------------
-data DsEvBind 
-  = LetEvBind          -- Dictionary or coercion
-      CoreBind         -- recursive or non-recursive
-
-  | CaseEvBind         -- Coercion binding by superclass selection
-                       -- Desugars to case d of d { K _ g _ _ _ -> ... }                       
-      DictId              -- b   The dictionary
-      AltCon              -- K   Its constructor
-      [CoreBndr]          -- _ g _ _ _   The binders in the alternative
-
-wrapDsEvBinds :: [DsEvBind] -> CoreExpr -> CoreExpr
-wrapDsEvBinds ds_ev_binds body = foldr wrap_one body ds_ev_binds
-  where
-    body_ty = exprType body
-    wrap_one (LetEvBind b)       body = Let b body
-    wrap_one (CaseEvBind x k xs) body = Case (Var x) x body_ty [(k,xs,body)]
-
-dsTcEvBinds :: TcEvBinds -> DsM [DsEvBind]
+dsTcEvBinds :: TcEvBinds -> DsM [CoreBind]
 dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this
 dsTcEvBinds (EvBinds bs)   = dsEvBinds bs
 
-dsEvBinds :: Bag EvBind -> DsM [DsEvBind]
+dsEvBinds :: Bag EvBind -> DsM [CoreBind]
 dsEvBinds bs = return (map dsEvGroup sccs)
   where
     sccs :: [SCC EvBind]
@@ -223,45 +207,60 @@ dsEvBinds bs = return (map dsEvGroup sccs)
     free_vars_of :: EvTerm -> [EvVar]
     free_vars_of (EvId v)           = [v]
     free_vars_of (EvCast v co)      = v : varSetElems (tyCoVarsOfCo co)
-    free_vars_of (EvCoercion co)    = varSetElems (tyCoVarsOfCo co)
+    free_vars_of (EvCoercionBox co) = varSetElems (tyCoVarsOfCo co)
     free_vars_of (EvDFunApp _ _ vs) = vs
+    free_vars_of (EvTupleSel v _)   = [v]
+    free_vars_of (EvTupleMk vs)     = vs
     free_vars_of (EvSuperClass d _) = [d]
 
-dsEvGroup :: SCC EvBind -> DsEvBind
-dsEvGroup (AcyclicSCC (EvBind co_var (EvSuperClass dict n)))
-  | isCoVar co_var      -- An equality superclass
-  = ASSERT( null other_data_cons )
-    CaseEvBind dict (DataAlt data_con) bndrs
-  where
-    (cls, tys) = getClassPredTys (evVarPred dict)
-    (data_con:other_data_cons) = tyConDataCons (classTyCon cls)
-    (ex_tvs, theta, rho) = tcSplitSigmaTy (applyTys (dataConRepType data_con) tys)
-    (arg_tys, _) = splitFunTys rho
-    bndrs = ex_tvs ++ map mk_wild_pred (theta `zip` [0..])
-                   ++ map mkWildValBinder arg_tys
-    mk_wild_pred (p, i) | i==n      = ASSERT( p `eqPred` (coVarPred co_var)) 
-                                      co_var
-                        | otherwise = mkWildEvBinder p
-    
+dsEvGroup :: SCC EvBind -> CoreBind
+
 dsEvGroup (AcyclicSCC (EvBind v r))
-  = LetEvBind (NonRec v (dsEvTerm r))
+  = NonRec v (dsEvTerm r)
 
 dsEvGroup (CyclicSCC bs)
-  = LetEvBind (Rec (map ds_pair bs))
+  = Rec (map ds_pair bs)
   where
     ds_pair (EvBind v r) = (v, dsEvTerm r)
 
+dsLCoercion :: LCoercion -> (Coercion -> CoreExpr) -> CoreExpr
+dsLCoercion co k = foldr go (k (substCo subst co)) eqvs_covs
+  where
+    -- We use the same uniques for the EqVars and the CoVars, and just change
+    -- the type. So the CoVars shadow the EqVars
+    --
+    -- NB: DON'T try to cheat and not substitute into the LCoercion to change the
+    -- types of the free variables: -ddump-ds will panic if you do this since it
+    -- runs before we substitute CoVar occurrences out for their binding sites.
+    eqvs_covs = [(eqv, eqv `setIdType` mkCoercionType ty1 ty2)
+                | eqv <- varSetElems (coVarsOfCo co)
+                , let (ty1, ty2) = getEqPredTys (evVarPred eqv)]
+
+    subst = extendCvSubstList (mkEmptySubst (mkInScopeSet (tyCoVarsOfCo co)))
+                              [(eqv, mkCoVarCo cov) | (eqv, cov) <- eqvs_covs]
+
+    go (eqv, cov) e = Case (Var eqv) (mkWildValBinder (varType eqv)) (exprType e)
+                           [(DataAlt eqBoxDataCon, [cov], e)]
+
 dsEvTerm :: EvTerm -> CoreExpr
 dsEvTerm (EvId v)                = Var v
-dsEvTerm (EvCast v co)           = Cast (Var v) co
+dsEvTerm (EvCast v co)           = dsLCoercion co $ Cast (Var v)
 dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars
-dsEvTerm (EvCoercion co)         = Coercion co
+dsEvTerm (EvCoercionBox co)      = dsLCoercion co mkEqBox
+dsEvTerm (EvTupleSel v n)
+   = ASSERT( isTupleTyCon tc )
+     Case (Var v) (mkWildValBinder (varType v)) (tys !! n) [(DataAlt dc, xs, Var v')]
+  where
+    (tc, tys) = splitTyConApp (evVarPred v)
+    Just [dc] = tyConDataCons_maybe tc
+    v' = v `setVarType` ty_want
+    xs = map mkWildValBinder tys_before ++ v' : map mkWildValBinder tys_after
+    (tys_before, ty_want:tys_after) = splitAt n tys
+dsEvTerm (EvTupleMk vs) = Var (dataConWorkId dc) `mkTyApps` tys `mkVarApps` vs
+  where dc = tupleCon FactTuple (length vs)
+        tys = map varType vs
 dsEvTerm (EvSuperClass d n)
-  = ASSERT( isClassPred (classSCTheta cls !! n) )
-           -- We can only select *dictionary* superclasses
-           -- in terms.  Equality superclasses are dealt with
-           -- in dsEvGroup, where they can generate a case expression
-    Var sc_sel_id `mkTyApps` tys `App` Var d
+  = Var sc_sel_id `mkTyApps` tys `App` Var d
   where
     sc_sel_id  = classSCSelId cls n    -- Zero-indexed
     (cls, tys) = getClassPredTys (evVarPred d)    
@@ -736,12 +735,14 @@ dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
 dsHsWrapper WpHole           = return (\e -> e)
 dsHsWrapper (WpTyApp ty)      = return (\e -> App e (Type ty))
 dsHsWrapper (WpLet ev_binds)  = do { ds_ev_binds <- dsTcEvBinds ev_binds
-                                   ; return (wrapDsEvBinds ds_ev_binds) }
+                                   ; return (mkCoreLets ds_ev_binds) }
 dsHsWrapper (WpCompose c1 c2) = do { k1 <- dsHsWrapper c1 
                                    ; k2 <- dsHsWrapper c2
                                    ; return (k1 . k2) }
-dsHsWrapper (WpCast co)       = return (\e -> Cast e co) 
+dsHsWrapper (WpCast co)
+  = return (\e -> dsLCoercion co (Cast e)) 
 dsHsWrapper (WpEvLam ev)      = return (\e -> Lam ev e) 
 dsHsWrapper (WpTyLam tv)      = return (\e -> Lam tv e) 
-dsHsWrapper (WpEvApp evtrm)   = return (\e -> App e (dsEvTerm evtrm))
+dsHsWrapper (WpEvApp evtrm)
+  = return (\e -> App e (dsEvTerm evtrm))
 \end{code}
index 9adbac1..bdacc9f 100644 (file)
@@ -263,7 +263,7 @@ boxResult result_ty
                     _ -> []
 
              return_result state anss
-               = mkConApp (tupleCon Unboxed (2 + length extra_result_tys))
+               = mkConApp (tupleCon UnboxedTuple (2 + length extra_result_tys))
                           (map Type (realWorldStatePrimTy : io_res_ty : extra_result_tys)
                              ++ (state : anss)) 
 
@@ -327,9 +327,9 @@ mk_alt return_result (Just prim_res_ty, wrap_result)
     let
         the_rhs = return_result (Var state_id) 
                                 (wrap_result (Var result_id) : map Var as)
-        ccall_res_ty = mkTyConApp (tupleTyCon Unboxed arity)
+        ccall_res_ty = mkTyConApp (tupleTyCon UnboxedTuple arity)
                                   (realWorldStatePrimTy : ls)
-        the_alt      = ( DataAlt (tupleCon Unboxed arity)
+        the_alt      = ( DataAlt (tupleCon UnboxedTuple arity)
                        , (state_id : args_ids)
                        , the_rhs
                        )
index 743874d..6b476a6 100644 (file)
@@ -86,14 +86,14 @@ dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
 dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr
 dsIPBinds (IPBinds ip_binds ev_binds) body
   = do { ds_ev_binds <- dsTcEvBinds ev_binds
-       ; let inner = wrapDsEvBinds ds_ev_binds body
+       ; let inner = mkCoreLets ds_ev_binds body
                -- The dict bindings may not be in 
                -- dependency order; hence Rec
        ; foldrM ds_ip_bind inner ip_binds }
   where
     ds_ip_bind (L _ (IPBind n e)) body
       = do e' <- dsLExpr e
-           return (Let (NonRec (ipNameName n) e') body)
+           return (Let (NonRec (ipNameName n) (mkIPBox n e')) body)
 
 -------------------------
 ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
@@ -139,7 +139,7 @@ dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
              bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b
        ; body2 <- foldlBagM (\body bind -> dsStrictBind (unLoc bind) body) 
                             body1 binds 
-       ; return (wrapDsEvBinds ds_ev_binds body2) }
+       ; return (mkCoreLets ds_ev_binds body2) }
 
 dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn 
                      , fun_tick = tick, fun_infix = inf }) body
@@ -218,7 +218,7 @@ dsExpr :: HsExpr Id -> DsM CoreExpr
 dsExpr (HsPar e)             = dsLExpr e
 dsExpr (ExprWithTySigOut e _) = dsLExpr e
 dsExpr (HsVar var)                   = return (varToCoreExpr var)   -- See Note [Desugaring vars]
-dsExpr (HsIPVar ip)                  = return (Var (ipNameName ip))
+dsExpr (HsIPVar ip)                  = return (mkIPUnbox ip)
 dsExpr (HsLit lit)                   = dsLit lit
 dsExpr (HsOverLit lit)               = dsOverLit lit
 
@@ -312,7 +312,7 @@ dsExpr (ExplicitTuple tup_args boxity)
                -- The reverse is because foldM goes left-to-right
 
        ; return $ mkCoreLams lam_vars $ 
-                  mkConApp (tupleCon boxity (length tup_args))
+                  mkConApp (tupleCon (boxityNormalTupleSort boxity) (length tup_args))
                            (map (Type . exprType) args ++ args) }
 
 dsExpr (HsSCC cc expr) = do
@@ -550,21 +550,21 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
 
                        -- Tediously wrap the application in a cast
                        -- Note [Update for GADTs]
-                wrapped_rhs | null eq_spec = rhs
-                            | otherwise    = mkLHsWrap (WpCast wrap_co) rhs
-                wrap_co = mkTyConAppCo tycon [ lookup tv ty
-                                             | (tv,ty) <- univ_tvs `zip` out_inst_tys]
+                wrap_co = mkTyConAppCo tycon
+                                [ lookup tv ty | (tv,ty) <- univ_tvs `zip` out_inst_tys ]
                 lookup univ_tv ty = case lookupVarEnv wrap_subst univ_tv of
                                        Just co' -> co'
                                        Nothing  -> mkReflCo ty
-                wrap_subst = mkVarEnv [ (tv, mkSymCo (mkCoVarCo co_var))
-                                      | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ]
+                wrap_subst = mkVarEnv [ (tv, mkSymCo (mkEqVarLCo eq_var))
+                                      | ((tv,_),eq_var) <- eq_spec `zip` eqs_vars ]
 
                 pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs
                                         , pat_dicts = eqs_vars ++ theta_vars
                                         , pat_binds = emptyTcEvBinds
                                         , pat_args = PrefixCon $ map nlVarPat arg_ids
                                         , pat_ty = in_ty }
+           ; let wrapped_rhs | null eq_spec = rhs
+                             | otherwise    = mkLHsWrap (WpCast wrap_co) rhs
           ; return (mkSimpleMatch [pat] wrapped_rhs) }
 
 \end{code}
index 1d94cf6..4f78a45 100644 (file)
@@ -312,14 +312,16 @@ repInstD' (L loc (InstDecl ty binds _ ats))       -- Ignore user pragmas for now
            -- the selector Ids, not to fresh names (Trac #5410)
            --
             do { cxt1 <- repContext cxt
-               ; inst_ty1 <- repPredTy (HsClassP cls tys)
+               ; cls_tcon <- repTy (HsTyVar cls)
+               ; cls_tys <- repLTys tys
+               ; inst_ty1 <- repTapps cls_tcon cls_tys
                ; binds1 <- rep_binds binds
                ; ats1 <- repLAssocFamInst ats
                ; decls <- coreList decQTyConName (ats1 ++ binds1)
                ; repInst cxt1 inst_ty1 decls }
        ; return (loc, dec) }
  where
-   (tvs, cxt, L _ cls, tys) = splitHsInstDeclTy ty
+   Just (tvs, cxt, cls, tys) = splitHsInstDeclTy_maybe (unLoc ty)
 
 repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
 repForD (L loc (ForeignImport name typ (CImport cc s ch cis)))
@@ -420,7 +422,7 @@ mkGadtCtxt data_tvs (ResTyGADT res_ty)
        = go (eq_pred : cxt) subst rest
        where
          loc = getLoc ty
-         eq_pred = L loc (HsEqualP (L loc (HsTyVar data_tv)) ty)
+         eq_pred = L loc (HsEqTy (L loc (HsTyVar data_tv)) ty)
 
     is_hs_tyvar (L _ (HsTyVar n))  = Just n   -- Type variables *and* tycons
     is_hs_tyvar (L _ (HsParTy ty)) = is_hs_tyvar ty
@@ -450,8 +452,11 @@ repDerivs (Just ctxt)
   where
     rep_deriv :: LHsType Name -> DsM (Core TH.Name)
        -- Deriving clauses must have the simple H98 form
-    rep_deriv (L _ (HsPredTy (HsClassP cls []))) = lookupOcc cls
-    rep_deriv other = notHandled "Non-H98 deriving clause" (ppr other)
+    rep_deriv ty
+      | Just (cls, []) <- splitHsClassTy_maybe (unLoc ty)
+      = lookupOcc cls
+      | otherwise
+      = notHandled "Non-H98 deriving clause" (ppr ty)
 
 
 -------------------------------------------------------
@@ -602,30 +607,24 @@ repContext ctxt = do
 
 -- represent a type predicate
 --
-repLPred :: LHsPred Name -> DsM (Core TH.PredQ)
+repLPred :: LHsType Name -> DsM (Core TH.PredQ)
 repLPred (L _ p) = repPred p
 
-repPred :: HsPred Name -> DsM (Core TH.PredQ)
-repPred (HsClassP cls tys) 
+repPred :: HsType Name -> DsM (Core TH.PredQ)
+repPred ty
+  | Just (cls, tys) <- splitHsClassTy_maybe ty
   = do
       cls1 <- lookupOcc cls
       tys1 <- repLTys tys
       tys2 <- coreList typeQTyConName tys1
       repClassP cls1 tys2
-repPred (HsEqualP tyleft tyright) 
+repPred (HsEqTy tyleft tyright) 
   = do
       tyleft1  <- repLTy tyleft
       tyright1 <- repLTy tyright
       repEqualP tyleft1 tyright1
-repPred p@(HsIParam _ _) = notHandled "Implicit parameter constraint" (ppr p)
-
-repPredTy :: HsPred Name -> DsM (Core TH.TypeQ)
-repPredTy (HsClassP cls tys) 
-  = do
-      tcon <- repTy (HsTyVar cls)
-      tys1 <- repLTys tys
-      repTapps tcon tys1
-repPredTy _ = panic "DsMeta.repPredTy: unexpected equality: internal error"
+repPred ty
+  = notHandled "Exotic predicate type" (ppr ty)
 
 -- yield the representation of a list of types
 --
@@ -669,18 +668,18 @@ repTy (HsPArrTy t)          = do
                                t1   <- repLTy t
                                tcon <- repTy (HsTyVar (tyConName parrTyCon))
                                repTapp tcon t1
-repTy (HsTupleTy Boxed tys)        = do
+repTy (HsTupleTy (HsBoxyTuple kind) tys)
+  | kind `eqKind` liftedTypeKind = do
                                tys1 <- repLTys tys 
                                tcon <- repTupleTyCon (length tys)
                                repTapps tcon tys1
-repTy (HsTupleTy Unboxed tys)      = do
+repTy (HsTupleTy HsUnboxedTuple tys) = do
                                tys1 <- repLTys tys
                                tcon <- repUnboxedTupleTyCon (length tys)
                                repTapps tcon tys1
 repTy (HsOpTy ty1 n ty2)    = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) 
                                   `nlHsAppTy` ty2)
 repTy (HsParTy t)          = repLTy t
-repTy (HsPredTy pred)       = repPredTy pred
 repTy (HsKindSig t k)       = do
                                 t1 <- repLTy t
                                 k1 <- repKind k
index 06d677f..798b8ba 100644 (file)
@@ -22,7 +22,6 @@ module DsMonad (
         UniqSupply, newUniqueSupply,
         getDOptsDs, getGhcModeDs, doptDs, woptDs,
         dsLookupGlobal, dsLookupGlobalId, dsLookupDPHId, dsLookupTyCon, dsLookupDataCon,
-        dsLookupClass,
 
        DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
 
@@ -47,10 +46,8 @@ import HscTypes
 import Bag
 import DataCon
 import TyCon
-import Class
 import Id
 import Module
-import Var
 import Outputable
 import SrcLoc
 import Type
@@ -231,13 +228,7 @@ duplicateLocalDs old_local
 
 newPredVarDs :: PredType -> DsM Var
 newPredVarDs pred
- | isEqPred pred
- = do { uniq <- newUnique; 
-      ; let name = mkSystemName uniq (mkOccNameFS tcName (fsLit "co_pv"))
-           kind = mkPredTy pred
-      ; return (mkCoVar name kind) }
- | otherwise
- = newSysLocalDs (mkPredTy pred)
+ = newSysLocalDs pred
  
 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
 newSysLocalDs  = mkSysLocalM (fsLit "ds")
@@ -326,10 +317,6 @@ dsLookupTyCon name
 dsLookupDataCon :: Name -> DsM DataCon
 dsLookupDataCon name
   = tyThingDataCon <$> dsLookupGlobal name
-
-dsLookupClass :: Name -> DsM Class
-dsLookupClass name
-  = tyThingClass <$> dsLookupGlobal name
 \end{code}
 
 \begin{code}
index 292ebae..462137a 100644 (file)
@@ -662,7 +662,7 @@ mkLHsVarPatTup bs  = mkLHsPatTup (map nlVarPat bs)
 mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id
 -- A vanilla tuple pattern simply gets its type from its sub-patterns
 mkVanillaTuplePat pats box 
-  = TuplePat pats box (mkTupleTy box (map hsLPatType pats))
+  = TuplePat pats box (mkTupleTy (boxityNormalTupleSort box) (map hsLPatType pats))
 
 -- The Big equivalents for the source tuple expressions
 mkBigLHsVarTup :: [Id] -> LHsExpr Id
index 25dab93..d2a56d1 100644 (file)
@@ -37,6 +37,7 @@ import Maybes
 import Util
 import Name
 import Outputable
+import BasicTypes ( boxityNormalTupleSort )
 import FastString
 
 import Control.Monad( when )
@@ -515,7 +516,7 @@ tidy1 _ (TuplePat pats boxity ty)
   = return (idDsWrapper, unLoc tuple_ConPat)
   where
     arity = length pats
-    tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats ty
+    tuple_ConPat = mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity) pats ty
 
 -- LitPats: we *might* be able to replace these w/ a simpler form
 tidy1 _ (LitPat lit)
@@ -911,17 +912,17 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
     --        equating different ways of writing a coercion)
     wrap WpHole WpHole = True
     wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'
-    wrap (WpCast c)  (WpCast c')     = coreEqCoercion c c'
-    wrap (WpEvApp et1) (WpEvApp et2) = ev_term et1 et2
-    wrap (WpTyApp t) (WpTyApp t')    = eqType t t'
+    wrap (WpCast co)       (WpCast co')        = co `coreEqCoercion` co'
+    wrap (WpEvApp et1)     (WpEvApp et2)       = et1 `ev_term` et2
+    wrap (WpTyApp t)       (WpTyApp t')        = eqType t t'
     -- Enhancement: could implement equality for more wrappers
     --   if it seems useful (lams and lets)
     wrap _ _ = False
 
     ---------
     ev_term :: EvTerm -> EvTerm -> Bool
-    ev_term (EvId a)       (EvId b)       = a==b
-    ev_term (EvCoercion a) (EvCoercion b) = coreEqCoercion a b
+    ev_term (EvId a)          (EvId b)          = a==b
+    ev_term (EvCoercionBox a) (EvCoercionBox b) = coreEqCoercion a b
     ev_term _ _ = False        
 
     ---------
index d84b901..adaa48e 100644 (file)
@@ -25,6 +25,7 @@ import DataCon
 import TcType
 import DsMonad
 import DsUtils
+import MkCore   ( mkCoreLets )
 import Util    ( all2, takeList, zipEqual )
 import ListSetOps ( runs )
 import Id
@@ -140,7 +141,7 @@ matchOneCon vars ty (eqn1 : eqns)   -- All eqns for a single constructor
       = do { ds_ev_binds <- dsTcEvBinds bind
           ; return (wrapBinds (tvs `zip` tvs1) 
                    . wrapBinds (ds  `zip` dicts1)
-                   . wrapDsEvBinds ds_ev_binds,
+                   . mkCoreLets ds_ev_binds,
                    eqn { eqn_pats = conArgPats arg_tys args ++ pats }) }
 
     -- Choose the right arg_vars in the right order for this group
index d553e5d..eea42bf 100644 (file)
@@ -413,6 +413,7 @@ Library
         TcCanonical
         TcSMonad
         Class
+        IParam
         Coercion
         FamInstEnv
         FunDeps
index 4891509..340899f 100644 (file)
@@ -34,7 +34,6 @@ import Linker
 import DataCon
 import Type
 import qualified Unify as U
-import TypeRep         -- I know I know, this is cheating
 import Var
 import TcRnMonad
 import TcType
@@ -1138,14 +1137,6 @@ zonkRttiType = zonkType (mkZonkTcTyVar zonk_unbound_meta)
 --------------------------------------------------------------------------------
 -- Restore Class predicates out of a representation type
 dictsView :: Type -> Type
--- dictsView ty = ty
-dictsView (FunTy (TyConApp tc_dict args) ty)
-  | Just c <- tyConClass_maybe tc_dict
-  = FunTy (PredTy (ClassP c args)) (dictsView ty)
-dictsView ty
-  | Just (tc_fun, [TyConApp tc_dict args, ty2]) <- tcSplitTyConApp_maybe ty
-  , Just c <- tyConClass_maybe tc_dict
-  = mkTyConApp tc_fun [PredTy (ClassP c args), dictsView ty2]
 dictsView ty = ty
 
 
index f847765..afb6933 100644 (file)
@@ -7,7 +7,7 @@ This module converts Template Haskell syntax into HsSyn
 
 \begin{code}
 module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
-                convertToHsType, convertToHsPred,
+                convertToHsType,
                 thRdrNameGuesses ) where
 
 import HsSyn as Hs
@@ -59,10 +59,6 @@ convertToHsType :: SrcSpan -> TH.Type -> Either Message (LHsType RdrName)
 convertToHsType loc t
   = initCvt loc $ wrapMsg "type" t $ cvtType t
 
-convertToHsPred :: SrcSpan -> TH.Pred -> Either Message (LHsPred RdrName)
-convertToHsPred loc t
-  = initCvt loc $ wrapMsg "type" t $ cvtPred t
-
 -------------------------------------------------------------------
 newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either Message a }
        -- Push down the source location;
@@ -190,8 +186,8 @@ cvtDec (ClassD ctxt cl tvs fds decs)
 cvtDec (InstanceD ctxt ty decs)
   = do         { (binds', sigs', ats') <- cvt_ci_decs (ptext (sLit "an instance declaration")) decs
        ; ctxt' <- cvtContext ctxt
-       ; L loc pred' <- cvtPredTy ty
-       ; let inst_ty' = L loc $ mkImplicitHsForAllTy ctxt' $ L loc $ HsPredTy pred'
+       ; L loc ty' <- cvtType ty
+       ; let inst_ty' = L loc $ mkImplicitHsForAllTy ctxt' $ L loc ty'
        ; returnL $ InstD (InstDecl inst_ty' binds' sigs' ats') }
 
 cvtDec (ForeignD ford) 
@@ -356,7 +352,7 @@ cvtDerivs cs = do { cs' <- mapM cvt_one cs
                  ; return (Just cs') }
        where
          cvt_one c = do { c' <- tconName c
-                        ; returnL $ HsPredTy $ HsClassP c' [] }
+                        ; returnL $ HsTyVar c' }
 
 cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep RdrName))
 cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs; ys' <- mapM tName ys; returnL (xs', ys') }
@@ -783,27 +779,18 @@ cvt_tv (TH.KindedTV nm ki)
 cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
 
-cvtPred :: TH.Pred -> CvtM (LHsPred RdrName)
+cvtPred :: TH.Pred -> CvtM (LHsType RdrName)
 cvtPred (TH.ClassP cla tys)
   = do { cla' <- if isVarName cla then tName cla else tconName cla
        ; tys' <- mapM cvtType tys
-       ; returnL $ HsClassP cla' tys'
+       ; mk_apps (HsTyVar cla') tys'
        }
 cvtPred (TH.EqualP ty1 ty2)
   = do { ty1' <- cvtType ty1
        ; ty2' <- cvtType ty2
-       ; returnL $ HsEqualP ty1' ty2'
+       ; returnL $ HsEqTy ty1' ty2'
        }
 
-cvtPredTy :: TH.Type -> CvtM (LHsPred RdrName)
-cvtPredTy ty 
-  = do { (head, tys') <- split_ty_app ty
-       ; case head of
-           ConT tc -> do { tc' <- tconName tc; returnL $ HsClassP tc' tys' }
-           VarT tv -> do { tv' <- tName tv;    returnL $ HsClassP tv' tys' }
-           _       -> failWith (ptext (sLit "Malformed predicate") <+> 
-                       text (TH.pprint ty)) }
-
 cvtType :: TH.Type -> CvtM (LHsType RdrName)
 cvtType ty 
   = do { (head_ty, tys') <- split_ty_app ty
@@ -812,18 +799,18 @@ cvtType ty
              | length tys' == n        -- Saturated
              -> if n==1 then return (head tys')        -- Singleton tuples treated 
                                                 -- like nothing (ie just parens)
-                        else returnL (HsTupleTy Boxed tys')
+                        else returnL (HsTupleTy (HsBoxyTuple liftedTypeKind) tys')
              | n == 1    
              -> failWith (ptext (sLit "Illegal 1-tuple type constructor"))
              | otherwise 
-             -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys'
+             -> mk_apps (HsTyVar (getRdrName (tupleTyCon BoxedTuple n))) tys'
            UnboxedTupleT n
              | length tys' == n        -- Saturated
              -> if n==1 then return (head tys')        -- Singleton tuples treated
                                                 -- like nothing (ie just parens)
-                        else returnL (HsTupleTy Unboxed tys')
+                        else returnL (HsTupleTy HsUnboxedTuple tys')
              | otherwise
-             -> mk_apps (HsTyVar (getRdrName (tupleTyCon Unboxed n))) tys'
+             -> mk_apps (HsTyVar (getRdrName (tupleTyCon UnboxedTuple n))) tys'
            ArrowT 
              | [x',y'] <- tys' -> returnL (HsFunTy x' y')
              | otherwise       -> mk_apps (HsTyVar (getRdrName funTyCon)) tys'
@@ -848,10 +835,11 @@ cvtType ty
 
            _ -> failWith (ptext (sLit "Malformed type") <+> text (show ty))
     }
-  where
-    mk_apps head_ty []       = returnL head_ty
-    mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty
-                                 ; mk_apps (HsAppTy head_ty' ty) tys }
+
+mk_apps :: HsType RdrName -> [LHsType RdrName] -> CvtM (LHsType RdrName)
+mk_apps head_ty []       = returnL head_ty
+mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty
+                              ; mk_apps (HsAppTy head_ty' ty) tys }
 
 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])
 split_ty_app ty = go ty []
@@ -992,8 +980,8 @@ isBuiltInOcc ctxt_ns occ
     go_tuple _ _            = Nothing
 
     tup_name n 
-       | OccName.isTcClsNameSpace ctxt_ns = Name.getName (tupleTyCon Boxed n)
-       | otherwise                        = Name.getName (tupleCon Boxed n)
+       | OccName.isTcClsNameSpace ctxt_ns = Name.getName (tupleTyCon BoxedTuple n)
+       | otherwise                        = Name.getName (tupleCon BoxedTuple n)
 
 -- The packing and unpacking is rather turgid :-(
 mk_occ :: OccName.NameSpace -> String -> OccName.OccName
index 4a57727..7bc74e2 100644 (file)
@@ -432,9 +432,6 @@ instance (OutputableBndr id) => Outputable (IPBind id) where
 %************************************************************************
 
 \begin{code}
--- A HsWrapper is an expression with a hole in it
--- We need coercions to have concrete form so that we can zonk them
-
 data HsWrapper
   = WpHole                     -- The identity coercion
 
@@ -444,8 +441,8 @@ data HsWrapper
        -- Hence  (\a. []) `WpCompose` (\b. []) = (\a b. [])
        -- But    ([] a)   `WpCompose` ([] b)   = ([] b a)
 
-  | WpCast Coercion            -- A cast:  [] `cast` co
-                               -- Guaranteed not the identity coercion
+  | WpCast LCoercion          -- A cast:  [] `cast` co
+                              -- Guaranteed not the identity coercion
 
        -- Evidence abstraction and application
         -- (both dictionaries and coercions)
@@ -502,24 +499,24 @@ data EvBind = EvBind EvVar EvTerm
 
 data EvTerm
   = EvId EvId                  -- Term-level variable-to-variable bindings 
-                               -- (no coercion variables! they come via EvCoercion)
+                               -- (no coercion variables! they come via EvCoercionBox)
 
-  | EvCoercion Coercion        -- Coercion bindings
+  | EvCoercionBox LCoercion    -- (Boxed) coercion bindings
 
-  | EvCast EvVar Coercion      -- d |> co
+  | EvCast EvVar LCoercion     -- d |> co
 
   | EvDFunApp DFunId           -- Dictionary instance application
-       [Type] [EvVar] 
+       [Type] [EvVar]
+
+  | EvTupleSel EvId  Int       -- n'th component of the tuple
+
+  | EvTupleMk [EvId]           -- tuple built from this stuff
 
   | EvSuperClass DictId Int    -- n'th superclass. Used for both equalities and
                                -- dictionaries, even though the former have no
                               -- selector Id.  We count up from _0_ 
                               
   deriving( Data, Typeable)
-
-evVarTerm :: EvVar -> EvTerm
-evVarTerm v | isCoVar v = EvCoercion (mkCoVarCo v)
-            | otherwise = EvId v
 \end{code}
 
 Note [EvBinds/EvTerm]
@@ -560,7 +557,7 @@ mkWpEvApps :: [EvTerm] -> HsWrapper
 mkWpEvApps args = mk_co_app_fn WpEvApp args
 
 mkWpEvVarApps :: [EvVar] -> HsWrapper
-mkWpEvVarApps vs = mkWpEvApps (map evVarTerm vs)
+mkWpEvVarApps vs = mkWpEvApps (map EvId vs)
 
 mkWpTyLams :: [TyVar] -> HsWrapper
 mkWpTyLams ids = mk_co_lam_fn WpTyLam ids
@@ -630,11 +627,14 @@ instance Outputable EvBindsVar where
 
 instance Outputable EvBind where
   ppr (EvBind v e)   = ppr v <+> equals <+> ppr e
+   -- We cheat a bit and pretend EqVars are CoVars for the purposes of pretty printing
 
 instance Outputable EvTerm where
   ppr (EvId v)          = ppr v
   ppr (EvCast v co)      = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendCo co
-  ppr (EvCoercion co)    = ptext (sLit "CO") <+> ppr co
+  ppr (EvCoercionBox co) = ptext (sLit "CO") <+> ppr co
+  ppr (EvTupleSel v n)   = ptext (sLit "tupsel") <> parens (ppr (v,n))
+  ppr (EvTupleMk vs)     = ptext (sLit "tupmk") <+> ppr vs
   ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n))
   ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ]
 \end{code}
index 9d441b7..995c660 100644 (file)
@@ -425,7 +425,7 @@ ppr_expr (SectionR op expr)
     pp_infixly v = sep [pprHsInfix v, pp_expr]
 
 ppr_expr (ExplicitTuple exprs boxity)
-  = tupleParens boxity (fcat (ppr_tup_args exprs))
+  = tupleParens (boxityNormalTupleSort boxity) (fcat (ppr_tup_args exprs))
   where
     ppr_tup_args []               = []
     ppr_tup_args (Present e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es
index 71dfe1d..5c404a6 100644 (file)
@@ -252,7 +252,7 @@ pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", ppr pat]
 pprPat (ParPat pat)        = parens (ppr pat)
 pprPat (ListPat pats _)     = brackets (interpp'SP pats)
 pprPat (PArrPat pats _)     = pabrackets (interpp'SP pats)
-pprPat (TuplePat pats bx _) = tupleParens bx (interpp'SP pats)
+pprPat (TuplePat pats bx _) = tupleParens (boxityNormalTupleSort bx) (interpp'SP pats)
 
 pprPat (ConPatIn con details) = pprUserCon con details
 pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts, 
index f8b7be4..89a002b 100644 (file)
@@ -11,9 +11,8 @@ HsTypes: Abstract syntax: user-defined types
 module HsTypes (
        HsType(..), LHsType, 
        HsTyVarBndr(..), LHsTyVarBndr,
-       HsExplicitFlag(..),
+       HsTupleSort(..), HsExplicitFlag(..),
        HsContext, LHsContext,
-       HsPred(..), LHsPred,
        HsQuasiQuote(..),
 
        LBangType, BangType, HsBang(..), 
@@ -25,7 +24,10 @@ module HsTypes (
        hsTyVarName, hsTyVarNames, replaceTyVarName, replaceLTyVarName,
        hsTyVarKind, hsTyVarNameKind,
        hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
-       splitHsInstDeclTy, splitHsFunType,
+       splitHsInstDeclTy_maybe, splitLHsInstDeclTy_maybe,
+        splitHsForAllTy, splitLHsForAllTy,
+        splitHsClassTy_maybe, splitLHsClassTy_maybe,
+        splitHsFunType,
        splitHsAppTys, mkHsAppTys,
        
        -- Type place holder
@@ -37,7 +39,7 @@ module HsTypes (
 
 import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice )
 
-import NameSet( FreeVars )
+import NameSet ( FreeVars )
 import Type
 import HsDoc
 import BasicTypes
@@ -124,14 +126,7 @@ This is the syntax for types as seen in type signatures.
 \begin{code}
 type LHsContext name = Located (HsContext name)
 
-type HsContext name = [LHsPred name]
-
-type LHsPred name = Located (HsPred name)
-
-data HsPred name = HsClassP name [LHsType name]                 -- class constraint
-                | HsEqualP (LHsType name) (LHsType name)-- equality constraint
-                | HsIParam (IPName name) (LHsType name)
-                deriving (Data, Typeable)
+type HsContext name = [LHsType name]
 
 type LHsType name = Located (HsType name)
 
@@ -156,7 +151,7 @@ data HsType name
 
   | HsPArrTy           (LHsType name)  -- Elem. type of parallel array: [:t:]
 
-  | HsTupleTy          Boxity
+  | HsTupleTy          HsTupleSort
                        [LHsType name]  -- Element types (length gives arity)
 
   | HsOpTy             (LHsType name) (Located name) (LHsType name)
@@ -165,12 +160,11 @@ data HsType name
        -- Parenthesis preserved for the precedence re-arrangement in RnTypes
        -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c!
 
-  | HsPredTy           (HsPred name)   -- Only used in the type of an instance
-                                       -- declaration, eg.  Eq [a] -> Eq a
-                                       --                             ^^^^
-                                       --                            HsPredTy
-                                       -- Note no need for location info on the
-                                       -- Enclosed HsPred; the one on the type will do
+  | HsIParamTy         (IPName name)    -- (?x :: ty)
+                        (LHsType name)   -- Implicit parameters as they occur in contexts
+
+  | HsEqTy              (LHsType name)   -- ty1 ~ ty2
+                        (LHsType name)   -- Always allowed even without TypeOperators, and has special kinding rule
 
   | HsKindSig          (LHsType name)  -- (ty :: kind)
                        Kind            -- A type with a kind signature
@@ -191,6 +185,10 @@ data HsType name
                                         
   deriving (Data, Typeable)
 
+data HsTupleSort = HsUnboxedTuple
+                 | HsBoxyTuple Kind -- Either a Constraint or normal tuple: resolved during type checking
+                 deriving (Data, Typeable)
+
 data HsExplicitFlag = Explicit | Implicit deriving (Data, Typeable)
 
 data ConDeclField name -- Record fields have Haddoc docs on them
@@ -223,7 +221,7 @@ mkHsForAllTy exp tvs ctxt ty = HsForAllTy exp tvs ctxt ty
 mk_forall_ty :: HsExplicitFlag -> [LHsTyVarBndr name] -> LHsType name -> HsType name
 mk_forall_ty exp  tvs  (L _ (HsParTy ty))                  = mk_forall_ty exp tvs ty
 mk_forall_ty exp1 tvs1 (L _ (HsForAllTy exp2 tvs2 ctxt ty)) = mkHsForAllTy (exp1 `plus` exp2) (tvs1 ++ tvs2) ctxt ty
-mk_forall_ty exp  tvs  ty                                  = HsForAllTy exp tvs (L noSrcSpan []) ty
+mk_forall_ty exp  tvs  ty                                  = HsForAllTy exp tvs (noLoc []) ty
        -- Even if tvs is empty, we still make a HsForAll!
        -- In the Implicit case, this signals the place to do implicit quantification
        -- In the Explicit case, it prevents implicit quantification    
@@ -305,22 +303,53 @@ mkHsAppTys fun_ty (arg_ty:arg_tys)
        -- Add noLocs for inner nodes of the application; 
        -- they are never used 
 
-splitHsInstDeclTy 
-    :: OutputableBndr name
-    => LHsType name 
-    -> ([LHsTyVarBndr name], HsContext name, Located name, [LHsType name])
-       -- Split up an instance decl type, returning the pieces
+splitHsInstDeclTy_maybe :: HsType name 
+                        -> Maybe ([LHsTyVarBndr name], HsContext name, name, [LHsType name])
+splitHsInstDeclTy_maybe ty
+  = fmap (\(tvs, cxt, L _ n, tys) -> (tvs, cxt, n, tys)) $ splitLHsInstDeclTy_maybe (noLoc ty)
 
-splitHsInstDeclTy linst_ty@(L _ inst_ty)
-  = case inst_ty of
-       HsParTy ty              -> splitHsInstDeclTy ty
-       HsForAllTy _ tvs cxt ty -> split_tau tvs (unLoc cxt) ty
-       _                       -> split_tau []  []          linst_ty
-    -- The type vars should have been computed by now, even if they were implicit
+splitLHsInstDeclTy_maybe
+    :: LHsType name 
+    -> Maybe ([LHsTyVarBndr name], HsContext name, Located name, [LHsType name])
+       -- Split up an instance decl type, returning the pieces
+splitLHsInstDeclTy_maybe inst_ty = do
+    let (tvs, cxt, ty) = splitLHsForAllTy inst_ty
+    (cls, tys) <- splitLHsClassTy_maybe ty
+    return (tvs, cxt, cls, tys)
+
+splitHsForAllTy :: HsType name -> ([LHsTyVarBndr name], HsContext name, HsType name)
+splitHsForAllTy ty = case splitLHsForAllTy (noLoc ty) of (tvs, cxt, L _ ty) -> (tvs, cxt, ty)
+
+splitLHsForAllTy
+    :: LHsType name 
+    -> ([LHsTyVarBndr name], HsContext name, LHsType name)
+splitLHsForAllTy poly_ty
+  = case unLoc poly_ty of
+        HsParTy ty              -> splitLHsForAllTy ty
+        HsForAllTy _ tvs cxt ty -> (tvs, unLoc cxt, ty)
+        _                       -> ([], [], poly_ty)
+        -- The type vars should have been computed by now, even if they were implicit
+
+splitHsClassTy_maybe :: HsType name -> Maybe (name, [LHsType name])
+splitHsClassTy_maybe ty = fmap (\(L _ n, tys) -> (n, tys)) $ splitLHsClassTy_maybe (noLoc ty)
+
+splitLHsClassTy_maybe :: LHsType name -> Maybe (Located name, [LHsType name])
+--- Watch out.. in ...deriving( Show )... we use this on 
+--- the list of partially applied predicates in the deriving,
+--- so there can be zero args.
+
+-- In TcDeriv we also use this to figure out what data type is being
+-- mentioned in a deriving (Generic (Foo bar baz)) declaration (i.e. "Foo").
+splitLHsClassTy_maybe ty
+  = checkl ty []
   where
-    split_tau tvs cxt (L loc (HsPredTy (HsClassP cls tys))) = (tvs, cxt, L loc cls, tys)
-    split_tau tvs cxt (L _ (HsParTy ty))                   = split_tau tvs cxt ty
-    split_tau _ _ _ = pprPanic "splitHsInstDeclTy" (ppr inst_ty)
+    checkl (L l ty) args = case ty of
+        HsTyVar t      -> Just (L l t, args)
+        HsAppTy l r    -> checkl l (r:args)
+        HsOpTy l tc r  -> checkl (fmap HsTyVar tc) (l:r:args)
+        HsParTy t      -> checkl t args
+        HsKindSig ty _ -> checkl ty args
+        _              -> Nothing
 
 -- Splits HsType into the (init, last) parts
 -- Breaks up any parens in the result type: 
@@ -348,15 +377,6 @@ instance (Outputable name) => Outputable (HsTyVarBndr name) where
     ppr (UserTyVar name _)      = ppr name
     ppr (KindedTyVar name kind) = hsep [ppr name, dcolon, pprParendKind kind]
 
-instance OutputableBndr name => Outputable (HsPred name) where
-    ppr (HsClassP clas tys) = ppr clas <+> hsep (map pprLHsType tys)
-    ppr (HsEqualP t1 t2)    = hsep [pprLHsType t1, ptext (sLit "~"), 
-                                   pprLHsType t2]
-    ppr (HsIParam n ty)     = hsep [ppr n, dcolon, ppr ty]
-
-pprLHsType :: OutputableBndr name => LHsType name -> SDoc
-pprLHsType = pprParendHsType . unLoc
-
 pprHsForAll :: OutputableBndr name => HsExplicitFlag -> [LHsTyVarBndr name] ->  LHsContext name -> SDoc
 pprHsForAll exp tvs cxt 
   | show_forall = forall_part <+> pprHsContext (unLoc cxt)
@@ -369,16 +389,9 @@ pprHsForAll exp tvs cxt
 
 pprHsContext :: (OutputableBndr name) => HsContext name -> SDoc
 pprHsContext []                = empty
-pprHsContext [L _ pred] 
-   | noParenHsPred pred = ppr pred <+> darrow
+pprHsContext [L _ pred] = ppr pred <+> darrow
 pprHsContext cxt        = ppr_hs_context cxt <+> darrow
 
-noParenHsPred :: HsPred name -> Bool
--- c.f. TypeRep.noParenPred
-noParenHsPred (HsClassP {}) = True
-noParenHsPred (HsEqualP {}) = True
-noParenHsPred (HsIParam {}) = False
-
 ppr_hs_context :: (OutputableBndr name) => HsContext name -> SDoc
 ppr_hs_context []  = empty
 ppr_hs_context cxt = parens (interpp'SP cxt)
@@ -446,14 +459,21 @@ ppr_mono_ty _    (HsQuasiQuoteTy qq) = ppr qq
 ppr_mono_ty _    (HsRecTy flds)      = pprConDeclFields flds
 ppr_mono_ty _    (HsTyVar name)      = ppr name
 ppr_mono_ty prec (HsFunTy ty1 ty2)   = ppr_fun_ty prec ty1 ty2
-ppr_mono_ty _    (HsTupleTy con tys) = tupleParens con (interpp'SP tys)
+ppr_mono_ty _    (HsTupleTy con tys) = tupleParens std_con (interpp'SP tys)
+  where std_con = case con of
+                    HsUnboxedTuple -> UnboxedTuple
+                    HsBoxyTuple _  -> BoxedTuple
 ppr_mono_ty _    (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> pprKind kind)
 ppr_mono_ty _    (HsListTy ty)      = brackets (ppr_mono_lty pREC_TOP ty)
 ppr_mono_ty _    (HsPArrTy ty)      = pabrackets (ppr_mono_lty pREC_TOP ty)
-ppr_mono_ty _    (HsPredTy pred)     = ppr pred
+ppr_mono_ty prec (HsIParamTy n ty)   = maybeParen prec pREC_FUN (ppr n <+> dcolon <+> ppr_mono_lty pREC_TOP ty)
 ppr_mono_ty _    (HsSpliceTy s _ _)  = pprSplice s
 ppr_mono_ty _    (HsCoreTy ty)       = ppr ty
 
+ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2)
+  = maybeParen ctxt_prec pREC_OP $
+    ppr_mono_lty pREC_OP ty1 <+> char '~' <+> ppr_mono_lty pREC_OP ty2
+
 ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty)
   = maybeParen ctxt_prec pREC_CON $
     hsep [ppr_mono_lty pREC_FUN fun_ty, ppr_mono_lty pREC_CON arg_ty]
index cd95571..3451e4c 100644 (file)
@@ -173,15 +173,15 @@ mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
 mkHsWrap co_fn e | isIdHsWrapper co_fn = e
                 | otherwise           = HsWrap co_fn e
 
-mkHsWrapCo :: Coercion -> HsExpr id -> HsExpr id
+mkHsWrapCo :: LCoercion -> HsExpr id -> HsExpr id
 mkHsWrapCo (Refl _) e = e
 mkHsWrapCo co       e = mkHsWrap (WpCast co) e
 
-mkLHsWrapCo :: Coercion -> LHsExpr id -> LHsExpr id
+mkLHsWrapCo :: LCoercion -> LHsExpr id -> LHsExpr id
 mkLHsWrapCo (Refl _) e         = e
 mkLHsWrapCo co       (L loc e) = L loc (mkHsWrap (WpCast co) e)
 
-coToHsWrapper :: Coercion -> HsWrapper
+coToHsWrapper :: LCoercion -> HsWrapper
 coToHsWrapper (Refl _) = idHsWrapper
 coToHsWrapper co       = WpCast co
 
@@ -189,7 +189,7 @@ mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
 mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
                       | otherwise           = CoPat co_fn p ty
 
-mkHsWrapPatCo :: Coercion -> Pat id -> Type -> Pat id
+mkHsWrapPatCo :: LCoercion -> Pat id -> Type -> Pat id
 mkHsWrapPatCo (Refl _) pat _  = pat
 mkHsWrapPatCo co       pat ty = CoPat (WpCast co) pat ty
 
index 26b3d9c..3df9f1a 100644 (file)
@@ -651,23 +651,16 @@ instance Binary HsBang where
              2 -> do return HsUnpack
              _ -> do return HsUnpackFailed
 
-instance Binary Boxity where
-    put_ bh Boxed   = putByte bh 0
-    put_ bh Unboxed = putByte bh 1
+instance Binary TupleSort where
+    put_ bh BoxedTuple   = putByte bh 0
+    put_ bh UnboxedTuple = putByte bh 1
+    put_ bh FactTuple    = putByte bh 2
     get bh = do
-           h <- getByte bh
-           case h of
-             0 -> do return Boxed
-             _ -> do return Unboxed
-
-instance Binary TupCon where
-    put_ bh (TupCon ab ac) = do
-           put_ bh ab
-           put_ bh ac
-    get bh = do
-         ab <- get bh
-         ac <- get bh
-         return (TupCon ab ac)
+      h <- getByte bh
+      case h of
+        0 -> do return BoxedTuple
+        1 -> do return UnboxedTuple
+        _ -> do return FactTuple
 
 instance Binary RecFlag where
     put_ bh Recursive = do
@@ -896,24 +889,22 @@ instance Binary IfaceType where
            putByte bh 3
            put_ bh ag
            put_ bh ah
-    put_ bh (IfacePredTy aq) = do
-           putByte bh 5
-           put_ bh aq
-
+    
        -- Simple compression for common cases of TyConApp
     put_ bh (IfaceTyConApp IfaceIntTc  [])   = putByte bh 6
     put_ bh (IfaceTyConApp IfaceCharTc [])   = putByte bh 7
     put_ bh (IfaceTyConApp IfaceBoolTc [])   = putByte bh 8
     put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
        -- Unit tuple and pairs
-    put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) [])     = putByte bh 10
-    put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
+    put_ bh (IfaceTyConApp (IfaceTupTc BoxedTuple 0) [])        = putByte bh 10
+    put_ bh (IfaceTyConApp (IfaceTupTc BoxedTuple 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
         -- Kind cases
     put_ bh (IfaceTyConApp IfaceLiftedTypeKindTc [])   = putByte bh 12
     put_ bh (IfaceTyConApp IfaceOpenTypeKindTc [])     = putByte bh 13
     put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14
     put_ bh (IfaceTyConApp IfaceUbxTupleKindTc [])     = putByte bh 15
     put_ bh (IfaceTyConApp IfaceArgTypeKindTc [])      = putByte bh 16
+    put_ bh (IfaceTyConApp IfaceConstraintKindTc [])   = putByte bh 21
     put_ bh (IfaceTyConApp (IfaceAnyTc k) [])         = do { putByte bh 17; put_ bh k }
 
        -- Generic cases
@@ -936,21 +927,20 @@ instance Binary IfaceType where
              3 -> do ag <- get bh
                      ah <- get bh
                      return (IfaceFunTy ag ah)
-             5 -> do ap <- get bh
-                     return (IfacePredTy ap)
-
+             
                -- Now the special cases for TyConApp
              6 -> return (IfaceTyConApp IfaceIntTc [])
              7 -> return (IfaceTyConApp IfaceCharTc [])
              8 -> return (IfaceTyConApp IfaceBoolTc [])
              9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
-             10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
-             11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
+             10 -> return (IfaceTyConApp (IfaceTupTc BoxedTuple 0) [])
+             11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc BoxedTuple 2) [t1,t2]) }
               12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc [])
               13 -> return (IfaceTyConApp IfaceOpenTypeKindTc [])
               14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc [])
               15 -> return (IfaceTyConApp IfaceUbxTupleKindTc [])
               16 -> return (IfaceTyConApp IfaceArgTypeKindTc [])
+              21 -> return (IfaceTyConApp IfaceConstraintKindTc [])
               17 -> do { k <- get bh; return (IfaceTyConApp (IfaceAnyTc k) []) }
 
              18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
@@ -969,9 +959,11 @@ instance Binary IfaceTyCon where
    put_ bh IfaceUnliftedTypeKindTc = putByte bh 8
    put_ bh IfaceUbxTupleKindTc     = putByte bh 9
    put_ bh IfaceArgTypeKindTc      = putByte bh 10
+   put_ bh IfaceConstraintKindTc   = putByte bh 15
    put_ bh (IfaceTupTc bx ar)  = do { putByte bh 11; put_ bh bx; put_ bh ar }
    put_ bh (IfaceTc ext)       = do { putByte bh 12; put_ bh ext }
-   put_ bh (IfaceAnyTc k)      = do { putByte bh 13; put_ bh k }
+   put_ bh (IfaceIPTc n)       = do { putByte bh 13; put_ bh n }
+   put_ bh (IfaceAnyTc k)      = do { putByte bh 14; put_ bh k }
 
    get bh = do
        h <- getByte bh
@@ -986,9 +978,11 @@ instance Binary IfaceTyCon where
           8 -> return IfaceUnliftedTypeKindTc
           9 -> return IfaceUbxTupleKindTc
           10 -> return IfaceArgTypeKindTc
+          15 -> return IfaceConstraintKindTc
          11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
          12 -> do { ext <- get bh; return (IfaceTc ext) }
-         _ -> do { k <- get bh; return (IfaceAnyTc k) }
+         13 -> do { n <- get bh; return (IfaceIPTc n) }
+          _  -> do { k <- get bh; return (IfaceAnyTc k) }
 
 instance Binary IfaceCoCon where
    put_ bh (IfaceCoAx n)       = do { putByte bh 0; put_ bh n }
@@ -998,6 +992,7 @@ instance Binary IfaceCoCon where
    put_ bh IfaceTransCo        = putByte bh 4
    put_ bh IfaceInstCo         = putByte bh 5
    put_ bh (IfaceNthCo d)      = do { putByte bh 6; put_ bh d }
+   put_ bh (IfaceIPCoAx ip)    = do { putByte bh 7; put_ bh ip }
   
    get bh = do
        h <- getByte bh
@@ -1008,34 +1003,8 @@ instance Binary IfaceCoCon where
          3 -> return IfaceSymCo
          4 -> return IfaceTransCo
          5 -> return IfaceInstCo
-          _ -> do { d <- get bh; return (IfaceNthCo d) }
-
-instance Binary IfacePredType where
-    put_ bh (IfaceClassP aa ab) = do
-           putByte bh 0
-           put_ bh aa
-           put_ bh ab
-    put_ bh (IfaceIParam ac ad) = do
-           putByte bh 1
-           put_ bh ac
-           put_ bh ad
-    put_ bh (IfaceEqPred ac ad) = do
-           putByte bh 2
-           put_ bh ac
-           put_ bh ad
-    get bh = do
-           h <- getByte bh
-           case h of
-             0 -> do aa <- get bh
-                     ab <- get bh
-                     return (IfaceClassP aa ab)
-             1 -> do ac <- get bh
-                     ad <- get bh
-                     return (IfaceIParam ac ad)
-             2 -> do ac <- get bh
-                     ad <- get bh
-                     return (IfaceEqPred ac ad)
-             _ -> panic ("get IfacePredType " ++ show h)
+          6 -> do { d <- get bh; return (IfaceNthCo d) }
+          _ -> do { ip <- get bh; return (IfaceIPCoAx ip) }
 
 -------------------------------------------------------------------------
 --             IfaceExpr and friends
@@ -1094,6 +1063,10 @@ instance Binary IfaceExpr where
             putByte bh 13
             put_ bh m
             put_ bh ix
+    put_ bh (IfaceTupId aa ab) = do
+      putByte bh 14
+      put_ bh aa
+      put_ bh ab
     get bh = do
            h <- getByte bh
            case h of
@@ -1135,6 +1108,9 @@ instance Binary IfaceExpr where
               13 -> do m <- get bh
                        ix <- get bh
                        return (IfaceTick m ix)
+              14 -> do aa <- get bh
+                       ab <- get bh
+                       return (IfaceTupId aa ab)
               _ -> panic ("get IfaceExpr " ++ show h)
 
 instance Binary IfaceConAlt where
index 7f2ade2..4f61197 100644 (file)
@@ -8,8 +8,8 @@ module BuildTyCl (
        buildSynTyCon, 
         buildAlgTyCon, 
         buildDataCon,
-       TcMethInfo, buildClass,
-       distinctAbstractTyConRhs, totallyAbstractTyConRhs, 
+        TcMethInfo, buildClass,
+       distinctAbstractTyConRhs, totallyAbstractTyConRhs,
        mkNewTyConRhs, mkDataTyConRhs, 
         newImplicitBinder
     ) where
@@ -216,7 +216,7 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
 
     arg_tyvars      = tyVarsOfTypes arg_tys
     in_arg_tys pred = not $ isEmptyVarSet $ 
-                     tyVarsOfPred pred `intersectVarSet` arg_tyvars
+                     tyVarsOfType pred `intersectVarSet` arg_tyvars
 \end{code}
 
 
@@ -236,10 +236,9 @@ buildClass :: Bool         -- True <=> do not include unfoldings
           -> RecFlag                      -- Info for type constructor
           -> TcRnIf m n Class
 
-buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
+buildClass no_unf tycon_name tvs sc_theta fds ats sig_stuff tc_isrec
   = do { traceIf (text "buildClass")
-       ; tycon_name <- newImplicitBinder class_name mkClassTyConOcc
-       ; datacon_name <- newImplicitBinder class_name mkClassDataConOcc
+       ; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc
                -- The class name is the 'parent' for this datacon, not its tycon,
                -- because one should import the class to get the binding for 
                -- the datacon
@@ -250,7 +249,7 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
                        -- Build the selector id and default method id
 
              -- Make selectors for the superclasses 
-       ; sc_sel_names <- mapM  (newImplicitBinder class_name . mkSuperDictSelOcc) 
+       ; sc_sel_names <- mapM  (newImplicitBinder tycon_name . mkSuperDictSelOcc) 
                                [1..length sc_theta]
         ; let sc_sel_ids = [ mkDictSelId no_unf sc_name rec_clas 
                            | sc_name <- sc_sel_names]
@@ -262,13 +261,12 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
              -- (We used to call them D_C, but now we can have two different
              --  superclasses both called C!)
        
-       ; let use_newtype = isSingleton arg_tys && not (any isEqPred sc_theta)
+       ; let use_newtype = isSingleton arg_tys
                -- Use a newtype if the data constructor 
                --   (a) has exactly one value field
                --       i.e. exactly one operation or superclass taken together
-                --   (b) it's of lifted type 
-               -- (NB: for (b) don't look at the classes in sc_theta, because
-               --      they are part of the knot!  Hence isEqPred.)
+                --   (b) that value is of lifted type (which they always are, because
+                --       we box equality superclasses)
                -- See note [Class newtypes and equality predicates]
 
                -- We treat the dictionary superclasses as ordinary arguments.  
@@ -278,7 +276,7 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
              args      = sc_sel_names ++ op_names
              op_tys    = [ty | (_,_,ty) <- sig_stuff]
              op_names  = [op | (op,_,_) <- sig_stuff]
-             arg_tys   = map mkPredTy sc_theta ++ op_tys
+             arg_tys   = sc_theta ++ op_tys
               rec_tycon = classTyCon rec_clas
                
        ; dict_con <- buildDataCon datacon_name
@@ -296,7 +294,7 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
                 then mkNewTyConRhs tycon_name rec_tycon dict_con
                 else return (mkDataTyConRhs [dict_con])
 
-       ; let { clas_kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
+       ; let { clas_kind = mkArrowKinds (map tyVarKind tvs) constraintKind
 
              ; tycon = mkClassTyCon tycon_name clas_kind tvs
                                     rhs rec_clas tc_isrec
@@ -310,7 +308,7 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
                -- type]
              ; atTyCons = [tycon | ATyCon tycon <- ats]
 
-             ; result = mkClass class_name tvs fds 
+             ; result = mkClass tvs fds 
                                 sc_theta sc_sel_ids atTyCons
                                 op_items tycon
              }
@@ -344,4 +342,3 @@ Moreover,
 Here we can't use a newtype either, even though there is only
 one field, because equality predicates are unboxed, and classes
 are boxed.
-
index cf8a57c..0b28525 100644 (file)
@@ -2,10 +2,10 @@
 
 \begin{code}
 module IfaceEnv (
-       newGlobalBinder, newIPName, newImplicitBinder, 
+       newGlobalBinder, newImplicitBinder, 
        lookupIfaceTop,
        lookupOrig, lookupOrigNameCache, extendNameCache,
-       newIfaceName, newIfaceNames,
+       newIPName, newIfaceName, newIfaceNames,
        extendIfaceIdEnv, extendIfaceTyVarEnv, 
        tcIfaceLclId, tcIfaceTyVar, lookupIfaceTyVar,
        tcIfaceTick,
@@ -23,6 +23,7 @@ import TcRnMonad
 import TysWiredIn
 import HscTypes
 import TyCon
+import Type
 import DataCon
 import Var
 import Name
@@ -31,9 +32,9 @@ import Module
 import UniqFM
 import FastString
 import UniqSupply
-import BasicTypes
 import SrcLoc
 import MkId
+import BasicTypes
 
 import Outputable
 import Exception     ( evaluate )
@@ -148,21 +149,19 @@ lookupOrig mod occ
                   in (name_cache{ nsUniqs = us, nsNames = new_cache }, name)
     }}}
 
-newIPName :: IPName OccName -> TcRnIf m n (IPName Name)
-newIPName occ_name_ip =
+newIPName :: FastString -> TcRnIf m n (IPName Name)
+newIPName ip =
   updNameCache $ \name_cache ->
-    let
-       ipcache = nsIPs name_cache
-        key = occ_name_ip  -- Ensures that ?x and %x get distinct Names
-    in
-    case Map.lookup key ipcache of
-      Just name_ip -> (name_cache, name_ip)
-      Nothing      -> (new_ns, name_ip)
-         where
-           (uniq, us') = takeUniqFromSupply (nsUniqs name_cache)
-           name_ip     = mapIPName (mkIPName uniq) occ_name_ip
-           new_ipcache = Map.insert key name_ip ipcache
-           new_ns      = name_cache {nsUniqs = us', nsIPs = new_ipcache}
+    let ipcache = nsIPs name_cache
+    in case Map.lookup ip ipcache of
+         Just name_ip -> (name_cache, name_ip)
+         Nothing      -> (new_ns, name_ip)
+            where
+              (us_here, us') = splitUniqSupply (nsUniqs name_cache)
+              tycon_u:datacon_u:dc_wrk_u:co_ax_u:_ = uniqsFromSupply us_here
+              name_ip     = mkIPName ip tycon_u datacon_u dc_wrk_u co_ax_u
+              new_ipcache = Map.insert ip name_ip ipcache
+              new_ns      = name_cache {nsUniqs = us', nsIPs = new_ipcache}
 \end{code}
 
 %************************************************************************
@@ -174,16 +173,18 @@ newIPName occ_name_ip =
 \begin{code}
 lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name
 lookupOrigNameCache _ mod occ
+  -- Don't need to mention gHC_UNIT here because it is explicitly
+  -- included in TysWiredIn.wiredInTyCons
   | mod == gHC_TUPLE || mod == gHC_PRIM,               -- Boxed tuples from one, 
     Just tup_info <- isTupleOcc_maybe occ      -- unboxed from the other
   =    -- Special case for tuples; there are too many
        -- of them to pre-populate the original-name cache
     Just (mk_tup_name tup_info)
   where
-    mk_tup_name (ns, boxity, arity)
-       | ns == tcName   = tyConName (tupleTyCon boxity arity)
-       | ns == dataName = dataConName (tupleCon boxity arity)
-       | otherwise      = Var.varName (dataConWorkId (tupleCon boxity arity))
+    mk_tup_name (ns, sort, arity)
+       | ns == tcName   = tyConName (tupleTyCon sort arity)
+       | ns == dataName = dataConName (tupleCon sort arity)
+       | otherwise      = Var.varName (dataConWorkId (tupleCon sort arity))
 
 lookupOrigNameCache nc mod occ -- The normal case
   = case lookupModuleEnv nc mod of
@@ -231,7 +232,7 @@ initNameCache :: UniqSupply -> [Name] -> NameCache
 initNameCache us names
   = NameCache { nsUniqs = us,
                nsNames = initOrigNames names,
-               nsIPs   = Map.empty }
+                nsIPs   = Map.empty }
 
 initOrigNames :: [Name] -> OrigNameCache
 initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
index eb09c2f..c406d04 100644 (file)
@@ -40,6 +40,7 @@ import BasicTypes
 import Outputable
 import FastString
 import Module
+import TysWiredIn ( eqTyConName )
 
 infixl 3 &&&
 \end{code}
@@ -84,7 +85,7 @@ data IfaceDecl
     }
 
   | IfaceClass { ifCtxt    :: IfaceContext,     -- Context...
-                 ifName    :: OccName,          -- Name of the class
+                 ifName    :: OccName,          -- Name of the class TyCon
                  ifTyVars  :: [IfaceTvBndr],    -- Type variables
                  ifFDs     :: [FunDep FastString], -- Functional dependencies
                  ifATs     :: [IfaceDecl],      -- Associated type families
@@ -224,9 +225,10 @@ data IfaceUnfolding
 data IfaceExpr
   = IfaceLcl    IfLclName
   | IfaceExt    IfExtName
+  | IfaceTupId  TupleSort Arity
   | IfaceType   IfaceType
   | IfaceCo     IfaceType              -- We re-use IfaceType for coercions
-  | IfaceTuple         Boxity [IfaceExpr]      -- Saturated; type arguments omitted
+  | IfaceTuple         TupleSort [IfaceExpr]   -- Saturated; type arguments omitted
   | IfaceLam   IfaceBndr IfaceExpr
   | IfaceApp   IfaceExpr IfaceExpr
   | IfaceCase  IfaceExpr IfLclName [IfaceAlt]
@@ -247,7 +249,7 @@ type IfaceAlt = (IfaceConAlt, [IfLclName], IfaceExpr)
 
 data IfaceConAlt = IfaceDefault
                  | IfaceDataAlt IfExtName
-                 | IfaceTupleAlt Boxity
+                 | IfaceTupleAlt TupleSort
                  | IfaceLitAlt Literal
 
 data IfaceBinding
@@ -371,12 +373,9 @@ ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
           has_wrapper = ifConWrapper con_decl     -- This is the reason for
                                                   -- having the ifConWrapper field!
 
-ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ,
+ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ,
                                ifSigs = sigs, ifATs = ats })
-  = -- dictionary datatype:
-    --   type constructor
-    tc_occ :
-    --   (possibly) newtype coercion
+  = --   (possibly) newtype coercion
     co_occs ++
     --    data constructor (DataCon namespace)
     --    data worker (Id namespace)
@@ -385,17 +384,16 @@ ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ,
     -- associated types
     [ifName at | at <- ats ] ++
     -- superclass selectors
-    [mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]] ++
+    [mkSuperDictSelOcc n cls_tc_occ | n <- [1..n_ctxt]] ++
     -- operation selectors
     [op | IfaceClassOp op  _ _ <- sigs]
   where
     n_ctxt = length sc_ctxt
     n_sigs = length sigs
-    tc_occ  = mkClassTyConOcc cls_occ
-    dc_occ  = mkClassDataConOcc cls_occ
-    co_occs | is_newtype = [mkNewTyCoOcc tc_occ]
+    co_occs | is_newtype = [mkNewTyCoOcc cls_tc_occ]
             | otherwise  = []
     dcww_occ = mkDataConWorkerOcc dc_occ
+    dc_occ = mkClassDataConOcc cls_tc_occ
     is_newtype = n_sigs + n_ctxt == 1 -- Sigh
 
 ifaceDeclSubBndrs (IfaceSyn {ifName = tc_occ,
@@ -478,6 +476,9 @@ pp_condecls tc (IfNewTyCon c)   = equals <+> pprIfaceConDecl tc c
 pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext (sLit " |"))
                                                             (map (pprIfaceConDecl tc) cs))
 
+mkIfaceEqPred :: IfaceType -> IfaceType -> IfacePredType
+mkIfaceEqPred ty1 ty2 = IfaceTyConApp (IfaceTc eqTyConName) [ty1, ty2]
+
 pprIfaceConDecl :: OccName -> IfaceConDecl -> SDoc
 pprIfaceConDecl tc
         (IfCon { ifConOcc = name, ifConInfix = is_infix, ifConWrapper = has_wrap,
@@ -498,7 +499,7 @@ pprIfaceConDecl tc
     main_payload = ppr name <+> dcolon <+>
                    pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau
 
-    eq_ctxt = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty)
+    eq_ctxt = [(mkIfaceEqPred (IfaceTyVar (occNameFS tv)) ty)
               | (tv,ty) <- eq_spec]
 
         -- A bit gruesome this, but we can't form the full con_tau, and ppr it,
@@ -555,6 +556,7 @@ pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc
 
 pprIfaceExpr _       (IfaceLcl v)       = ppr v
 pprIfaceExpr _       (IfaceExt v)       = ppr v
+pprIfaceExpr _       (IfaceTupId c n)   = tupleParens c (hcat (replicate (n - 1) (char ',')))
 pprIfaceExpr _       (IfaceLit l)       = ppr l
 pprIfaceExpr _       (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
 pprIfaceExpr _       (IfaceTick m ix)   = braces (text "tick" <+> ppr m <+> ppr ix)
@@ -720,7 +722,7 @@ freeNamesIfTcFam Nothing =
   emptyNameSet
 
 freeNamesIfContext :: IfaceContext -> NameSet
-freeNamesIfContext = fnList freeNamesIfPredType
+freeNamesIfContext = fnList freeNamesIfType
 
 freeNamesIfDecls :: [IfaceDecl] -> NameSet
 freeNamesIfDecls = fnList freeNamesIfDecl
@@ -741,18 +743,9 @@ freeNamesIfConDecl c =
   fnList freeNamesIfType (ifConArgTys c) &&&
   fnList freeNamesIfType (map snd (ifConEqSpec c)) -- equality constraints
 
-freeNamesIfPredType :: IfacePredType -> NameSet
-freeNamesIfPredType (IfaceClassP cl tys) =
-   unitNameSet cl &&& fnList freeNamesIfType tys
-freeNamesIfPredType (IfaceIParam _n ty) =
-   freeNamesIfType ty
-freeNamesIfPredType (IfaceEqPred ty1 ty2) =
-   freeNamesIfType ty1 &&& freeNamesIfType ty2
-
 freeNamesIfType :: IfaceType -> NameSet
 freeNamesIfType (IfaceTyVar _)        = emptyNameSet
 freeNamesIfType (IfaceAppTy s t)      = freeNamesIfType s &&& freeNamesIfType t
-freeNamesIfType (IfacePredTy st)      = freeNamesIfPredType st
 freeNamesIfType (IfaceTyConApp tc ts) =
    freeNamesIfTc tc &&& fnList freeNamesIfType ts
 freeNamesIfType (IfaceForAllTy tv t)  =
@@ -800,6 +793,7 @@ freeNamesIfUnfold (IfDFunUnfold vs)      = fnList freeNamesIfExpr vs
 
 freeNamesIfExpr :: IfaceExpr -> NameSet
 freeNamesIfExpr (IfaceExt v)      = unitNameSet v
+freeNamesIfExpr (IfaceTupId _ _)  = emptyNameSet
 freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty
 freeNamesIfExpr (IfaceType ty)    = freeNamesIfType ty
 freeNamesIfExpr (IfaceCo co)      = freeNamesIfType co
@@ -839,6 +833,7 @@ freeNamesIfTc _ = emptyNameSet
 
 freeNamesIfCo :: IfaceCoCon -> NameSet
 freeNamesIfCo (IfaceCoAx tc) = unitNameSet tc
+-- ToDo: include IfaceIPCoAx? Probably not necessary.
 freeNamesIfCo _ = emptyNameSet
 
 freeNamesIfRule :: IfaceRule -> NameSet
index 89cc755..b9fcb8f 100644 (file)
@@ -7,9 +7,9 @@ This module defines interface types and binders
 
 \begin{code}
 module IfaceType (
-       IfExtName, IfLclName,
+       IfExtName, IfLclName, IfIPName,
 
-        IfaceType(..), IfaceKind, IfacePredType(..), IfaceTyCon(..), IfaceCoCon(..),
+        IfaceType(..), IfacePredType, IfaceKind, IfaceTyCon(..), IfaceCoCon(..),
        IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, IfaceCoercion,
        ifaceTyConName,
 
@@ -22,7 +22,7 @@ module IfaceType (
         coToIfaceType,
 
        -- Printing
-       pprIfaceType, pprParendIfaceType, pprIfaceContext, 
+       pprIfaceType, pprParendIfaceType, pprIfaceContext,
        pprIfaceIdBndr, pprIfaceTvBndr, pprIfaceTvBndrs, pprIfaceBndrs,
        tOP_PREC, tYCON_PREC, noParens, maybeParen, pprIfaceForAllPart
 
@@ -30,6 +30,8 @@ module IfaceType (
 
 import Coercion
 import TypeRep hiding( maybeParen )
+import Type (tyConAppTyCon_maybe)
+import IParam (ipFastString)
 import TyCon
 import Id
 import Var
@@ -53,6 +55,8 @@ type IfLclName = FastString   -- A local name in iface syntax
 type IfExtName = Name  -- An External or WiredIn Name can appear in IfaceSyn
                        -- (However Internal or System Names never should)
 
+type IfIPName = FastString -- Represent implicit parameters simply as a string
+
 data IfaceBndr                 -- Local (non-top-level) binders
   = IfaceIdBndr {-# UNPACK #-} !IfaceIdBndr
   | IfaceTvBndr {-# UNPACK #-} !IfaceTvBndr
@@ -69,16 +73,11 @@ data IfaceType         -- A kind of universal type, used for types, kinds, and coerci
   | IfaceAppTy    IfaceType IfaceType
   | IfaceFunTy    IfaceType IfaceType
   | IfaceForAllTy IfaceTvBndr IfaceType
-  | IfacePredTy   IfacePredType
   | IfaceTyConApp IfaceTyCon [IfaceType]  -- Not necessarily saturated
                                          -- Includes newtypes, synonyms, tuples
   | IfaceCoConApp IfaceCoCon [IfaceType]  -- Always saturated
 
-data IfacePredType     -- NewTypes are handled as ordinary TyConApps
-  = IfaceClassP IfExtName [IfaceType]
-  | IfaceIParam (IPName OccName) IfaceType
-  | IfaceEqPred IfaceType IfaceType
-
+type IfacePredType = IfaceType
 type IfaceContext = [IfacePredType]
 
 data IfaceTyCon        -- Encodes type consructors, kind constructors
@@ -86,17 +85,19 @@ data IfaceTyCon     -- Encodes type consructors, kind constructors
   = IfaceTc IfExtName  -- The common case
   | IfaceIntTc | IfaceBoolTc | IfaceCharTc
   | IfaceListTc | IfacePArrTc
-  | IfaceTupTc Boxity Arity 
+  | IfaceTupTc TupleSort Arity 
+  | IfaceIPTc IfIPName       -- Used for implicit parameter TyCons
   | IfaceAnyTc IfaceKind     -- Used for AnyTyCon (see Note [Any Types] in TysPrim)
                             -- other than 'Any :: *' itself
+  
   -- Kind constructors
   | IfaceLiftedTypeKindTc | IfaceOpenTypeKindTc | IfaceUnliftedTypeKindTc
-  | IfaceUbxTupleKindTc | IfaceArgTypeKindTc 
+  | IfaceUbxTupleKindTc | IfaceArgTypeKindTc | IfaceConstraintKindTc
 
   -- Coercion constructors
 data IfaceCoCon
   = IfaceCoAx IfExtName
+  | IfaceIPCoAx FastString
   | IfaceReflCo    | IfaceUnsafeCo  | IfaceSymCo
   | IfaceTransCo   | IfaceInstCo
   | IfaceNthCo Int
@@ -113,9 +114,12 @@ ifaceTyConName IfaceOpenTypeKindTc     = openTypeKindTyConName
 ifaceTyConName IfaceUnliftedTypeKindTc = unliftedTypeKindTyConName
 ifaceTyConName IfaceUbxTupleKindTc     = ubxTupleKindTyConName
 ifaceTyConName IfaceArgTypeKindTc      = argTypeKindTyConName
+ifaceTyConName IfaceConstraintKindTc   = constraintKindTyConName
 ifaceTyConName (IfaceTc ext)           = ext
-ifaceTyConName (IfaceAnyTc k)          = pprPanic "ifaceTyConName" (ppr k)
+ifaceTyConName (IfaceIPTc n)           = pprPanic "ifaceTyConName:IPTc" (ppr n)
+ifaceTyConName (IfaceAnyTc k)          = pprPanic "ifaceTyConName:AnyTc" (ppr k)
                                         -- Note [The Name of an IfaceAnyTc]
+                                         -- The same caveat applies to IfaceIPTc
 \end{code}
 
 Note [The Name of an IfaceAnyTc]
@@ -137,20 +141,20 @@ than solve this potential problem now, I'm going to defer it until it happens!
 
 
 \begin{code}
-splitIfaceSigmaTy :: IfaceType -> ([IfaceTvBndr], IfaceContext, IfaceType)
+splitIfaceSigmaTy :: IfaceType -> ([IfaceTvBndr], [IfacePredType], IfaceType)
 -- Mainly for printing purposes
 splitIfaceSigmaTy ty
-  = (tvs,theta,tau)
+  = (tvs, theta, tau)
   where
-    (tvs, rho)   = split_foralls ty
-    (theta, tau) = split_rho rho
+    (tvs,   rho)   = split_foralls ty
+    (theta, tau)   = split_rho rho
 
     split_foralls (IfaceForAllTy tv ty) 
        = case split_foralls ty of { (tvs, rho) -> (tv:tvs, rho) }
     split_foralls rho = ([], rho)
 
-    split_rho (IfaceFunTy (IfacePredTy st) ty) 
-       = case split_rho ty of { (sts, tau) -> (st:sts, tau) }
+    split_rho (IfaceFunTy ty1 ty2)
+      | isIfacePredTy ty1 = case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) }
     split_rho tau = ([], tau)
 \end{code}
 
@@ -218,11 +222,14 @@ pprIfaceType, pprParendIfaceType ::IfaceType -> SDoc
 pprIfaceType       = ppr_ty tOP_PREC
 pprParendIfaceType = ppr_ty tYCON_PREC
 
+isIfacePredTy :: IfaceType -> Bool
+isIfacePredTy _  = False
+-- FIXME: fix this to print iface pred tys correctly
+-- isIfacePredTy ty = ifaceTypeKind ty `eqKind` constraintKind
 
 ppr_ty :: Int -> IfaceType -> SDoc
 ppr_ty _         (IfaceTyVar tyvar)     = ppr tyvar
 ppr_ty ctxt_prec (IfaceTyConApp tc tys) = ppr_tc_app ctxt_prec tc tys
-ppr_ty _         (IfacePredTy st)       = ppr st
 
 ppr_ty ctxt_prec (IfaceCoConApp tc tys) 
   = maybeParen ctxt_prec tYCON_PREC 
@@ -234,10 +241,13 @@ ppr_ty ctxt_prec (IfaceFunTy ty1 ty2)
     maybeParen ctxt_prec fUN_PREC $
     sep (ppr_ty fUN_PREC ty1 : ppr_fun_tail ty2)
   where
+    arr | isIfacePredTy ty1 = darrow
+        | otherwise         = arrow
+
     ppr_fun_tail (IfaceFunTy ty1 ty2) 
-      = (arrow <+> ppr_ty fUN_PREC ty1) : ppr_fun_tail ty2
+      = (arr <+> ppr_ty fUN_PREC ty1) : ppr_fun_tail ty2
     ppr_fun_tail other_ty
-      = [arrow <+> pprIfaceType other_ty]
+      = [arr <+> pprIfaceType other_ty]
 
 ppr_ty ctxt_prec (IfaceAppTy ty1 ty2)
   = maybeParen ctxt_prec tYCON_PREC $
@@ -247,14 +257,14 @@ ppr_ty ctxt_prec ty@(IfaceForAllTy _ _)
   = maybeParen ctxt_prec fUN_PREC (pprIfaceForAllPart tvs theta (pprIfaceType tau))
  where         
     (tvs, theta, tau) = splitIfaceSigmaTy ty
-    
--------------------
+     
+ -------------------
 pprIfaceForAllPart :: [IfaceTvBndr] -> IfaceContext -> SDoc -> SDoc
 pprIfaceForAllPart tvs ctxt doc 
   = sep [ppr_tvs, pprIfaceContext ctxt, doc]
   where
     ppr_tvs | null tvs  = empty
-           | otherwise = ptext (sLit "forall") <+> pprIfaceTvBndrs tvs <> dot
+            | otherwise = ptext (sLit "forall") <+> pprIfaceTvBndrs tvs <> dot
 
 -------------------
 ppr_tc_app :: Int -> IfaceTyCon -> [IfaceType] -> SDoc
@@ -264,6 +274,7 @@ ppr_tc_app _         IfacePArrTc [ty] = pabrackets (pprIfaceType ty)
 ppr_tc_app _         (IfaceTupTc bx arity) tys
   | arity == length tys 
   = tupleParens bx (sep (punctuate comma (map pprIfaceType tys)))
+ppr_tc_app _         (IfaceIPTc n) [ty] = parens (ppr (IPName n) <> dcolon <> pprIfaceType ty)
 ppr_tc_app ctxt_prec tc tys 
   = maybeParen ctxt_prec tYCON_PREC 
               (sep [ppr_tc tc, nest 4 (sep (map pprParendIfaceType tys))])
@@ -274,39 +285,34 @@ ppr_tc tc@(IfaceTc ext_nm) = parenSymOcc (getOccName ext_nm) (ppr tc)
 ppr_tc tc                 = ppr tc
 
 -------------------
-instance Outputable IfacePredType where
-       -- Print without parens
-  ppr (IfaceEqPred ty1 ty2)= hsep [ppr ty1, ptext (sLit "~"), ppr ty2]
-  ppr (IfaceIParam ip ty)  = hsep [ppr ip, dcolon, ppr ty]
-  ppr (IfaceClassP cls ts) = parenSymOcc (getOccName cls) (ppr cls)
-                            <+> sep (map pprParendIfaceType ts)
-
 instance Outputable IfaceTyCon where
+  ppr (IfaceIPTc n)  = ppr (IPName n)
   ppr (IfaceAnyTc k) = ptext (sLit "Any") <> pprParendIfaceType k
-                            -- We can't easily get the Name of an IfaceAnyTc
+                            -- We can't easily get the Name of an IfaceAnyTc/IfaceIPTc
                             -- (see Note [The Name of an IfaceAnyTc])
                             -- so we fake it.  It's only for debug printing!
   ppr other_tc       = ppr (ifaceTyConName other_tc)
 
 instance Outputable IfaceCoCon where
-  ppr (IfaceCoAx n)  = ppr n
-  ppr IfaceReflCo    = ptext (sLit "Refl")
-  ppr IfaceUnsafeCo  = ptext (sLit "Unsafe")
-  ppr IfaceSymCo     = ptext (sLit "Sym")
-  ppr IfaceTransCo   = ptext (sLit "Trans")
-  ppr IfaceInstCo    = ptext (sLit "Inst")
-  ppr (IfaceNthCo d) = ptext (sLit "Nth:") <> int d
+  ppr (IfaceCoAx n)    = ppr n
+  ppr (IfaceIPCoAx ip) = ppr (IPName ip)
+  ppr IfaceReflCo      = ptext (sLit "Refl")
+  ppr IfaceUnsafeCo    = ptext (sLit "Unsafe")
+  ppr IfaceSymCo       = ptext (sLit "Sym")
+  ppr IfaceTransCo     = ptext (sLit "Trans")
+  ppr IfaceInstCo      = ptext (sLit "Inst")
+  ppr (IfaceNthCo d)   = ptext (sLit "Nth:") <> int d
 
 -------------------
 pprIfaceContext :: IfaceContext -> SDoc
 -- Prints "(C a, D b) =>", including the arrow
-pprIfaceContext []     = empty
+pprIfaceContext []    = empty
 pprIfaceContext theta = ppr_preds theta <+> darrow
 
 ppr_preds :: [IfacePredType] -> SDoc
-ppr_preds [pred] = ppr pred    -- No parens
+ppr_preds [pred] = ppr pred    -- No parens
 ppr_preds preds  = parens (sep (punctuate comma (map ppr preds))) 
-                        
+
 -------------------
 pabrackets :: SDoc -> SDoc
 pabrackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]")
@@ -343,7 +349,6 @@ toIfaceType (AppTy t1 t2)     = IfaceAppTy (toIfaceType t1) (toIfaceType t2)
 toIfaceType (FunTy t1 t2)     = IfaceFunTy (toIfaceType t1) (toIfaceType t2)
 toIfaceType (TyConApp tc tys) = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTypes tys)
 toIfaceType (ForAllTy tv t)   = IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType t)
-toIfaceType (PredTy st)       = IfacePredTy (toIfacePred toIfaceType st)
 
 toIfaceTyVar :: TyVar -> FastString
 toIfaceTyVar = occNameFS . getOccName
@@ -361,9 +366,10 @@ toIfaceCoVar = occNameFS . getOccName
 
 toIfaceTyCon :: TyCon -> IfaceTyCon
 toIfaceTyCon tc 
-  | isTupleTyCon tc = IfaceTupTc (tupleTyConBoxity tc) (tyConArity tc)
-  | isAnyTyCon tc   = IfaceAnyTc (toIfaceKind (tyConKind tc))
-  | otherwise      = toIfaceTyCon_name (tyConName tc)
+  | isTupleTyCon tc            = IfaceTupTc (tupleTyConSort tc) (tyConArity tc)
+  | isAnyTyCon tc              = IfaceAnyTc (toIfaceKind (tyConKind tc))
+  | Just n <- tyConIP_maybe tc = IfaceIPTc (ipFastString n)
+  | otherwise                 = toIfaceTyCon_name (tyConName tc)
 
 toIfaceTyCon_name :: Name -> IfaceTyCon
 toIfaceTyCon_name nm
@@ -374,8 +380,9 @@ toIfaceTyCon_name nm
 
 toIfaceWiredInTyCon :: TyCon -> Name -> IfaceTyCon
 toIfaceWiredInTyCon tc nm
-  | isTupleTyCon tc                 = IfaceTupTc  (tupleTyConBoxity tc) (tyConArity tc)
+  | isTupleTyCon tc                 = IfaceTupTc  (tupleTyConSort tc) (tyConArity tc)
   | isAnyTyCon tc                   = IfaceAnyTc (toIfaceKind (tyConKind tc))
+  | Just n <- tyConIP_maybe tc      = IfaceIPTc (ipFastString n)
   | nm == intTyConName              = IfaceIntTc
   | nm == boolTyConName             = IfaceBoolTc 
   | nm == charTyConName             = IfaceCharTc 
@@ -385,6 +392,7 @@ toIfaceWiredInTyCon tc nm
   | nm == unliftedTypeKindTyConName = IfaceUnliftedTypeKindTc
   | nm == openTypeKindTyConName     = IfaceOpenTypeKindTc
   | nm == argTypeKindTyConName      = IfaceArgTypeKindTc
+  | nm == constraintKindTyConName   = IfaceConstraintKindTc
   | nm == ubxTupleKindTyConName     = IfaceUbxTupleKindTc
   | otherwise                      = IfaceTc nm
 
@@ -393,14 +401,8 @@ toIfaceTypes :: [Type] -> [IfaceType]
 toIfaceTypes ts = map toIfaceType ts
 
 ----------------
-toIfacePred :: (a -> IfaceType) -> Pred a -> IfacePredType
-toIfacePred to (ClassP cls ts)  = IfaceClassP (getName cls) (map to ts)
-toIfacePred to (IParam ip t)    = IfaceIParam (mapIPName getOccName ip) (to t)
-toIfacePred to (EqPred ty1 ty2) =  IfaceEqPred (to ty1) (to ty2)
-
-----------------
 toIfaceContext :: ThetaType -> IfaceContext
-toIfaceContext cs = map (toIfacePred toIfaceType) cs
+toIfaceContext = toIfaceTypes
 
 ----------------
 coToIfaceType :: Coercion -> IfaceType
@@ -412,7 +414,7 @@ coToIfaceType (AppCo co1 co2)       = IfaceAppTy    (coToIfaceType co1)
 coToIfaceType (ForAllCo v co)       = IfaceForAllTy (toIfaceTvBndr v) 
                                                     (coToIfaceType co)
 coToIfaceType (CoVarCo cv)          = IfaceTyVar  (toIfaceCoVar cv)
-coToIfaceType (AxiomInstCo con cos) = IfaceCoConApp (IfaceCoAx (coAxiomName con))
+coToIfaceType (AxiomInstCo con cos) = IfaceCoConApp (coAxiomToIfaceType con)
                                                     (map coToIfaceType cos)
 coToIfaceType (UnsafeCo ty1 ty2)    = IfaceCoConApp IfaceUnsafeCo 
                                                     [ toIfaceType ty1
@@ -427,5 +429,13 @@ coToIfaceType (NthCo d co)          = IfaceCoConApp (IfaceNthCo d)
 coToIfaceType (InstCo co ty)        = IfaceCoConApp IfaceInstCo 
                                                     [ coToIfaceType co
                                                     , toIfaceType ty ]
+
+coAxiomToIfaceType :: CoAxiom -> IfaceCoCon
+coAxiomToIfaceType con
+  | Just tc <- tyConAppTyCon_maybe (co_ax_lhs con)
+  , Just ip <- tyConIP_maybe tc
+  = IfaceIPCoAx (ipFastString ip)
+  | otherwise
+  = IfaceCoAx (coAxiomName con)
 \end{code}
 
index b73e00a..7ab38d2 100644 (file)
@@ -1325,38 +1325,10 @@ tyThingToIfaceDecl (AnId id)
              ifIdDetails = toIfaceIdDetails (idDetails id),
              ifIdInfo    = toIfaceIdInfo (idInfo id) }
 
-tyThingToIfaceDecl (AClass clas)
-  = IfaceClass { ifCtxt          = toIfaceContext sc_theta,
-                ifName   = getOccName clas,
-                ifTyVars = toIfaceTvBndrs clas_tyvars,
-                ifFDs    = map toIfaceFD clas_fds,
-                ifATs    = map (tyThingToIfaceDecl . ATyCon) clas_ats,
-                ifSigs   = map toIfaceClassOp op_stuff,
-                ifRec    = boolToRecFlag (isRecursiveTyCon tycon) }
-  where
-    (clas_tyvars, clas_fds, sc_theta, _, clas_ats, op_stuff) 
-      = classExtraBigSig clas
-    tycon = classTyCon clas
-
-    toIfaceClassOp (sel_id, def_meth)
-       = ASSERT(sel_tyvars == clas_tyvars)
-         IfaceClassOp (getOccName sel_id) (toDmSpec def_meth) (toIfaceType op_ty)
-       where
-               -- Be careful when splitting the type, because of things
-               -- like         class Foo a where
-               --                op :: (?x :: String) => a -> a
-               -- and          class Baz a where
-               --                op :: (Ord a) => a -> a
-         (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
-         op_ty                = funResultTy rho_ty
-
-    toDmSpec NoDefMeth      = NoDM
-    toDmSpec (GenDefMeth _) = GenericDM
-    toDmSpec (DefMeth _)    = VanillaDM
-
-    toIfaceFD (tvs1, tvs2) = (map getFS tvs1, map getFS tvs2)
-
 tyThingToIfaceDecl (ATyCon tycon)
+  | Just clas <- tyConClass_maybe tycon
+  = classToIfaceDecl clas
+
   | isSynTyCon tycon
   = IfaceSyn { ifName    = getOccName tycon,
                ifTyVars  = toIfaceTvBndrs tyvars,
@@ -1424,6 +1396,39 @@ tyThingToIfaceDecl (ADataCon dc)
  = pprPanic "toIfaceDecl" (ppr dc)     -- Should be trimmed out earlier
 
 
+classToIfaceDecl :: Class -> IfaceDecl
+classToIfaceDecl clas
+  = IfaceClass { ifCtxt   = toIfaceContext sc_theta,
+                 ifName   = getOccName (classTyCon clas),
+                 ifTyVars = toIfaceTvBndrs clas_tyvars,
+                 ifFDs    = map toIfaceFD clas_fds,
+                 ifATs    = map (tyThingToIfaceDecl . ATyCon) clas_ats,
+                 ifSigs   = map toIfaceClassOp op_stuff,
+                 ifRec    = boolToRecFlag (isRecursiveTyCon tycon) }
+  where
+    (clas_tyvars, clas_fds, sc_theta, _, clas_ats, op_stuff) 
+      = classExtraBigSig clas
+    tycon = classTyCon clas
+
+    toIfaceClassOp (sel_id, def_meth)
+        = ASSERT(sel_tyvars == clas_tyvars)
+          IfaceClassOp (getOccName sel_id) (toDmSpec def_meth) (toIfaceType op_ty)
+        where
+                -- Be careful when splitting the type, because of things
+                -- like         class Foo a where
+                --                op :: (?x :: String) => a -> a
+                -- and          class Baz a where
+                --                op :: (Ord a) => a -> a
+          (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
+          op_ty                = funResultTy rho_ty
+
+    toDmSpec NoDefMeth      = NoDM
+    toDmSpec (GenDefMeth _) = GenericDM
+    toDmSpec (DefMeth _)    = VanillaDM
+
+    toIfaceFD (tvs1, tvs2) = (map getFS tvs1, map getFS tvs2)
+
+
 getFS :: NamedThing a => a -> FastString
 getFS x = occNameFS (getOccName x)
 
@@ -1633,8 +1638,10 @@ toIfaceAlt (c,bs,r) = (toIfaceCon c, map getFS bs, toIfaceExpr r)
 
 ---------------------
 toIfaceCon :: AltCon -> IfaceConAlt
-toIfaceCon (DataAlt dc) | isTupleTyCon tc = IfaceTupleAlt (tupleTyConBoxity tc)
-                       | otherwise       = IfaceDataAlt (getName dc)
+toIfaceCon (DataAlt dc) | isTupleTyCon tc
+                        = IfaceTupleAlt (tupleTyConSort tc)
+                        | otherwise
+                        = IfaceDataAlt (getName dc)
                        where
                          tc = dataConTyCon dc
           
@@ -1648,7 +1655,7 @@ toIfaceApp (Var v) as
   = case isDataConWorkId_maybe v of
        -- We convert the *worker* for tuples into IfaceTuples
        Just dc |  isTupleTyCon tc && saturated 
-               -> IfaceTuple (tupleTyConBoxity tc) tup_args
+               -> IfaceTuple (tupleTyConSort tc) tup_args
          where
            val_args  = dropWhile isTypeArg as
            saturated = val_args `lengthIs` idArity v
@@ -1664,13 +1671,15 @@ mkIfaceApps f as = foldl (\f a -> IfaceApp f (toIfaceExpr a)) f as
 
 ---------------------
 toIfaceVar :: Id -> IfaceExpr
-toIfaceVar v 
-  | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v))
+toIfaceVar v = case isDataConWorkId_maybe v of
+    Just dc | isTupleTyCon tc -> IfaceTupId (tupleTyConSort tc) (tupleTyConArity tc)
+      where tc = dataConTyCon dc
+          -- Tuple workers also have special syntax, so we get their
+          -- Uniques right (they are wired-in but infinite)
+    _ | Just fcall <- isFCallId_maybe v            -> IfaceFCall fcall (toIfaceType (idType v))
          -- Foreign calls have special syntax
-  | isExternalName name                    = IfaceExt name
-  | Just (TickBox m ix) <- isTickBoxOp_maybe v
-                                   = IfaceTick m ix
-  | otherwise                      = IfaceLcl (getFS name)
-  where
-    name = idName v
+      | isExternalName name                       -> IfaceExt name
+      | Just (TickBox m ix) <- isTickBoxOp_maybe v -> IfaceTick m ix
+      | otherwise                                 -> IfaceLcl (getFS name)
+  where name = idName v
 \end{code}
index 87fac02..642bcf4 100644 (file)
@@ -36,6 +36,7 @@ import Id
 import MkId
 import IdInfo
 import Class
+import IParam
 import TyCon
 import DataCon
 import TysWiredIn
@@ -467,21 +468,21 @@ tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
                               ; return (SynonymTyCon rhs_ty) }
 
 tc_iface_decl _parent ignore_prags
-           (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, 
-                        ifTyVars = tv_bndrs, ifFDs = rdr_fds, 
+           (IfaceClass {ifCtxt = rdr_ctxt, ifName = tc_occ,
+                ifTyVars = tv_bndrs, ifFDs = rdr_fds, 
                         ifATs = rdr_ats, ifSigs = rdr_sigs, 
                         ifRec = tc_isrec })
 -- ToDo: in hs-boot files we should really treat abstract classes specially,
 --      as we do abstract tycons
   = bindIfaceTyVars tv_bndrs $ \ tyvars -> do
-    { cls_name <- lookupIfaceTop occ_name
+    { tc_name <- lookupIfaceTop tc_occ
     ; ctxt <- tcIfaceCtxt rdr_ctxt
     ; sigs <- mapM tc_sig rdr_sigs
     ; fds  <- mapM tc_fd rdr_fds
     ; cls  <- fixM $ \ cls -> do
               { ats  <- mapM (tc_iface_decl (AssocFamilyTyCon cls) ignore_prags) rdr_ats
-              ; buildClass ignore_prags cls_name tyvars ctxt fds ats sigs tc_isrec }
-    ; return (AClass cls) }
+              ; buildClass ignore_prags tc_name tyvars ctxt fds ats sigs tc_isrec }
+    ; return (ATyCon (classTyCon cls)) }
   where
    tc_sig (IfaceClassOp occ dm rdr_ty)
      = do { op_name <- lookupIfaceTop occ
@@ -811,24 +812,14 @@ tcIfaceType (IfaceAppTy t1 t2)    = do { t1' <- tcIfaceType t1; t2' <- tcIfaceTy
 tcIfaceType (IfaceFunTy t1 t2)    = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') }
 tcIfaceType (IfaceTyConApp tc ts) = do { tc' <- tcIfaceTyCon tc; ts' <- tcIfaceTypes ts; return (mkTyConApp tc' ts') }
 tcIfaceType (IfaceForAllTy tv t)  = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') }
-tcIfaceType (IfacePredTy st)      = do { st' <- tcIfacePred tcIfaceType st; return (PredTy st') }
 tcIfaceType t@(IfaceCoConApp {})  = pprPanic "tcIfaceType" (ppr t)
 
 tcIfaceTypes :: [IfaceType] -> IfL [Type]
 tcIfaceTypes tys = mapM tcIfaceType tys
 
 -----------------------------------------
-tcIfacePred :: (IfaceType -> IfL a) -> IfacePredType -> IfL (Pred a)
-tcIfacePred tc (IfaceClassP cls ts)
-  = do { cls' <- tcIfaceClass cls; ts' <- mapM tc ts; return (ClassP cls' ts') }
-tcIfacePred tc (IfaceIParam ip t)
-  = do { ip' <- newIPName ip; t' <- tc t; return (IParam ip' t') }
-tcIfacePred tc (IfaceEqPred t1 t2)
-  = do { t1' <- tc t1; t2' <- tc t2; return (EqPred t1' t2') }
-
------------------------------------------
 tcIfaceCtxt :: IfaceContext -> IfL ThetaType
-tcIfaceCtxt sts = mapM (tcIfacePred tcIfaceType) sts
+tcIfaceCtxt sts = mapM tcIfaceType sts
 \end{code}
 
 %************************************************************************
@@ -846,17 +837,16 @@ tcIfaceCo (IfaceTyConApp tc ts) = mkTyConAppCo <$> tcIfaceTyCon tc <*> mapM tcIf
 tcIfaceCo (IfaceCoConApp tc ts) = tcIfaceCoApp tc ts
 tcIfaceCo (IfaceForAllTy tv t)  = bindIfaceTyVar tv $ \ tv' ->
                                   mkForAllCo tv' <$> tcIfaceCo t
--- tcIfaceCo (IfacePredTy co)      = mkPredCo <$> tcIfacePred tcIfaceCo co
-tcIfaceCo (IfacePredTy _)      = panic "tcIfaceCo"
 
 tcIfaceCoApp :: IfaceCoCon -> [IfaceType] -> IfL Coercion
-tcIfaceCoApp IfaceReflCo    [t]     = Refl         <$> tcIfaceType t
-tcIfaceCoApp (IfaceCoAx n)  ts      = AxiomInstCo  <$> tcIfaceCoAxiom n <*> mapM tcIfaceCo ts
-tcIfaceCoApp IfaceUnsafeCo  [t1,t2] = UnsafeCo     <$> tcIfaceType t1 <*> tcIfaceType t2
-tcIfaceCoApp IfaceSymCo     [t]     = SymCo        <$> tcIfaceCo t
-tcIfaceCoApp IfaceTransCo   [t1,t2] = TransCo      <$> tcIfaceCo t1 <*> tcIfaceCo t2
-tcIfaceCoApp IfaceInstCo    [t1,t2] = InstCo       <$> tcIfaceCo t1 <*> tcIfaceType t2
-tcIfaceCoApp (IfaceNthCo d) [t]     = NthCo d      <$> tcIfaceCo t
+tcIfaceCoApp IfaceReflCo      [t]     = Refl         <$> tcIfaceType t
+tcIfaceCoApp (IfaceCoAx n)    ts      = AxiomInstCo  <$> tcIfaceCoAxiom n <*> mapM tcIfaceCo ts
+tcIfaceCoApp (IfaceIPCoAx ip) ts      = AxiomInstCo  <$> liftM ipCoAxiom (newIPName ip) <*> mapM tcIfaceCo ts
+tcIfaceCoApp IfaceUnsafeCo    [t1,t2] = UnsafeCo     <$> tcIfaceType t1 <*> tcIfaceType t2
+tcIfaceCoApp IfaceSymCo       [t]     = SymCo        <$> tcIfaceCo t
+tcIfaceCoApp IfaceTransCo     [t1,t2] = TransCo      <$> tcIfaceCo t1 <*> tcIfaceCo t2
+tcIfaceCoApp IfaceInstCo      [t1,t2] = InstCo       <$> tcIfaceCo t1 <*> tcIfaceType t2
+tcIfaceCoApp (IfaceNthCo d)   [t]     = NthCo d      <$> tcIfaceCo t
 tcIfaceCoApp cc ts = pprPanic "toIfaceCoApp" (ppr cc <+> ppr ts)
 
 tcIfaceCoVar :: FastString -> IfL CoVar
@@ -890,6 +880,9 @@ tcIfaceExpr (IfaceTick modName tickNo)
 tcIfaceExpr (IfaceExt gbl)
   = Var <$> tcIfaceExtId gbl
 
+tcIfaceExpr (IfaceTupId boxity arity)
+  = return $ Var (dataConWorkId (tupleCon boxity arity))
+
 tcIfaceExpr (IfaceLit lit)
   = return (Lit lit)
 
@@ -987,9 +980,9 @@ tcIfaceAlt scrut (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs)
        ; when (debugIsOn && not (con `elem` tyConDataCons tycon))
               (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon)))
        ; tcIfaceDataAlt con inst_tys arg_strs rhs }
-                 
+
 tcIfaceAlt _ (tycon, inst_tys) (IfaceTupleAlt _boxity, arg_occs, rhs)
-  = ASSERT2( isTupleTyCon tycon, ppr tycon )
+  = ASSERT2( isTupleTyCon tycon && tupleTyConSort tycon == _boxity, ppr tycon )
     do { let [data_con] = tyConDataCons tycon
        ; tcIfaceDataAlt data_con inst_tys arg_occs rhs }
 
@@ -1241,6 +1234,8 @@ tcIfaceTyCon IfaceCharTc          = tcWiredInTyCon charTyCon
 tcIfaceTyCon IfaceListTc       = tcWiredInTyCon listTyCon
 tcIfaceTyCon IfacePArrTc       = tcWiredInTyCon parrTyCon
 tcIfaceTyCon (IfaceTupTc bx ar) = tcWiredInTyCon (tupleTyCon bx ar)
+tcIfaceTyCon (IfaceIPTc n)      = do { n' <- newIPName n
+                                     ; tcWiredInTyCon (ipTyCon n') }
 tcIfaceTyCon (IfaceAnyTc kind)  = do { tc_kind <- tcIfaceType kind
                                      ; tcWiredInTyCon (anyTyConOfKind tc_kind) }
 tcIfaceTyCon (IfaceTc name)     = do { thing <- tcIfaceGlobal name 
@@ -1257,6 +1252,7 @@ tcIfaceTyCon IfaceOpenTypeKindTc     = return openTypeKindTyCon
 tcIfaceTyCon IfaceUnliftedTypeKindTc = return unliftedTypeKindTyCon
 tcIfaceTyCon IfaceArgTypeKindTc      = return argTypeKindTyCon
 tcIfaceTyCon IfaceUbxTupleKindTc     = return ubxTupleKindTyCon
+tcIfaceTyCon IfaceConstraintKindTc   = return constraintKindTyCon
 
 -- Even though we are in an interface file, we want to make
 -- sure the instances and RULES of this tycon are loaded 
@@ -1265,10 +1261,6 @@ tcWiredInTyCon :: TyCon -> IfL TyCon
 tcWiredInTyCon tc = do { ifCheckWiredInThing (ATyCon tc)
                       ; return tc }
 
-tcIfaceClass :: Name -> IfL Class
-tcIfaceClass name = do { thing <- tcIfaceGlobal name
-                      ; return (tyThingClass thing) }
-
 tcIfaceCoAxiom :: Name -> IfL CoAxiom
 tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name
                         ; return (tyThingCoAxiom thing) }
index 3f34eb6..6d15352 100644 (file)
@@ -383,7 +383,8 @@ data ExtensionFlag
    | Opt_NPlusKPatterns
    | Opt_DoAndIfThenElse
    | Opt_RebindableSyntax
-
+   | Opt_ConstraintKind
+   
    | Opt_StandaloneDeriving
    | Opt_DeriveDataTypeable
    | Opt_DeriveFunctor
@@ -1861,6 +1862,7 @@ xFlags = [
   ( "NPlusKPatterns",                   AlwaysAllowed, Opt_NPlusKPatterns, nop ),
   ( "DoAndIfThenElse",                  AlwaysAllowed, Opt_DoAndIfThenElse, nop ),
   ( "RebindableSyntax",                 AlwaysAllowed, Opt_RebindableSyntax, nop ),
+  ( "ConstraintKind",                   AlwaysAllowed, Opt_ConstraintKind, nop ),
   ( "MonoPatBinds",                     AlwaysAllowed, Opt_MonoPatBinds, 
     \ turn_on -> when turn_on $ deprecate "Experimental feature now removed; has no effect" ),
   ( "ExplicitForAll",                   AlwaysAllowed, Opt_ExplicitForAll, nop ),
index bd7baa1..7489ea3 100644 (file)
@@ -145,7 +145,7 @@ module GHC (
        TyCon, 
        tyConTyVars, tyConDataCons, tyConArity,
        isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
-       isFamilyTyCon,
+       isFamilyTyCon, tyConClass_maybe,
        synTyConDefn, synTyConType, synTyConResKind,
 
        -- ** Type variables
@@ -173,7 +173,7 @@ module GHC (
        pprParendType, pprTypeApp, 
        Kind,
        PredType,
-       ThetaType, pprForAll, pprThetaArrow, pprThetaArrowTy,
+       ThetaType, pprForAll, pprThetaArrowTy,
 
        -- ** Entities
        TyThing(..), 
@@ -254,7 +254,7 @@ import NameSet
 import RdrName
 import qualified HsSyn -- hack as we want to reexport the whole module
 import HsSyn hiding ((<.>))
-import Type
+import Type     hiding( typeKind )
 import Coercion                ( synTyConResKind )
 import TcType          hiding( typeKind )
 import Id
index 5b170c6..7fab8d0 100644 (file)
@@ -56,13 +56,13 @@ module HscTypes (
 
         -- * TyThings and type environments
        TyThing(..),
-       tyThingClass, tyThingTyCon, tyThingDataCon, 
+       tyThingTyCon, tyThingDataCon,
         tyThingId, tyThingCoAxiom, tyThingParent_maybe,
        implicitTyThings, implicitTyConThings, implicitClassThings, isImplicitTyThing,
        
        TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv,
        extendTypeEnv, extendTypeEnvList, extendTypeEnvWithIds, lookupTypeEnv,
-       typeEnvElts, typeEnvClasses, typeEnvTyCons, typeEnvIds,
+       typeEnvElts, typeEnvTyCons, typeEnvIds,
        typeEnvDataCons, typeEnvCoAxioms,
 
         -- * MonadThings
@@ -158,8 +158,8 @@ import System.FilePath
 import System.Time     ( ClockTime )
 import Data.IORef
 import Data.Array       ( Array, array )
+import Data.Map         ( Map )
 import Data.List
-import Data.Map (Map)
 import Data.Word
 import Control.Monad    ( mplus, guard, liftM, when )
 import Exception
@@ -1066,7 +1066,6 @@ implicitTyThings :: TyThing -> [TyThing]
 implicitTyThings (AnId _)       = []
 implicitTyThings (ACoAxiom _cc) = []
 implicitTyThings (ATyCon tc)    = implicitTyConThings tc
-implicitTyThings (AClass cl)    = implicitClassThings cl
 implicitTyThings (ADataCon dc)  = map AnId (dataConImplicitIds dc)
     -- For data cons add the worker and (possibly) wrapper
     
@@ -1074,15 +1073,6 @@ implicitClassThings :: Class -> [TyThing]
 implicitClassThings cl 
   = -- Does not include default methods, because those Ids may have
     --    their own pragmas, unfoldings etc, not derived from the Class object
-    -- Dictionary datatype:
-    --    [extras_plus:]
-    --      type constructor 
-    --    [recursive call:]
-    --      (possibly) newtype coercion; definitely no family coercion here
-    --      data constructor
-    --      worker
-    --      (no wrapper by invariant)
-    extras_plus (ATyCon (classTyCon cl)) ++
     -- associated types 
     --    No extras_plus (recursive call) for the classATs, because they
     --    are only the family decls; they have no implicit things
@@ -1092,14 +1082,18 @@ implicitClassThings cl
 
 implicitTyConThings :: TyCon -> [TyThing]
 implicitTyConThings tc 
-  =   -- fields (names of selectors)
+  = class_stuff ++
+      -- fields (names of selectors)
       -- (possibly) implicit coercion and family coercion
       --   depending on whether it's a newtype or a family instance or both
     implicitCoTyCon tc ++
       -- for each data constructor in order,
       --   the contructor, worker, and (possibly) wrapper
     concatMap (extras_plus . ADataCon) (tyConDataCons tc)
-
+  where
+    class_stuff = case tyConClass_maybe tc of
+        Nothing -> []
+        Just cl -> implicitClassThings cl
 
 -- add a thing and recursive call
 extras_plus :: TyThing -> [TyThing]
@@ -1124,7 +1118,6 @@ implicitCoTyCon tc
 isImplicitTyThing :: TyThing -> Bool
 isImplicitTyThing (ADataCon {}) = True
 isImplicitTyThing (AnId id)     = isImplicitId id
-isImplicitTyThing (AClass {})   = False
 isImplicitTyThing (ATyCon tc)   = isImplicitTyCon tc
 isImplicitTyThing (ACoAxiom {}) = True
 
@@ -1141,11 +1134,11 @@ tyThingParent_maybe :: TyThing -> Maybe TyThing
 -- might have a parent.
 tyThingParent_maybe (ADataCon dc) = Just (ATyCon (dataConTyCon dc))
 tyThingParent_maybe (ATyCon tc)   = case tyConAssoc_maybe tc of
-                                      Just cls -> Just (AClass cls)
+                                      Just cls -> Just (ATyCon (classTyCon cls))
                                       Nothing  -> Nothing
 tyThingParent_maybe (AnId id)     = case idDetails id of
                                         RecSelId { sel_tycon = tc } -> Just (ATyCon tc)
-                                        ClassOpId cls               -> Just (AClass cls)
+                                        ClassOpId cls               -> Just (ATyCon (classTyCon cls))
                                         _other                      -> Nothing
 tyThingParent_maybe _other = Nothing
 \end{code}
@@ -1163,7 +1156,6 @@ type TypeEnv = NameEnv TyThing
 
 emptyTypeEnv    :: TypeEnv
 typeEnvElts     :: TypeEnv -> [TyThing]
-typeEnvClasses  :: TypeEnv -> [Class]
 typeEnvTyCons   :: TypeEnv -> [TyCon]
 typeEnvCoAxioms :: TypeEnv -> [CoAxiom]
 typeEnvIds      :: TypeEnv -> [Id]
@@ -1172,7 +1164,6 @@ lookupTypeEnv   :: TypeEnv -> Name -> Maybe TyThing
 
 emptyTypeEnv       = emptyNameEnv
 typeEnvElts     env = nameEnvElts env
-typeEnvClasses  env = [cl | AClass cl   <- typeEnvElts env]
 typeEnvTyCons   env = [tc | ATyCon tc   <- typeEnvElts env] 
 typeEnvCoAxioms env = [ax | ACoAxiom ax <- typeEnvElts env] 
 typeEnvIds      env = [id | AnId id     <- typeEnvElts env] 
@@ -1235,11 +1226,6 @@ tyThingCoAxiom :: TyThing -> CoAxiom
 tyThingCoAxiom (ACoAxiom ax) = ax
 tyThingCoAxiom other        = pprPanic "tyThingCoAxiom" (pprTyThing other)
 
--- | Get the 'Class' from a 'TyThing' if it is a class thing. Panics otherwise
-tyThingClass :: TyThing -> Class
-tyThingClass (AClass cls) = cls
-tyThingClass other       = pprPanic "tyThingClass" (pprTyThing other)
-
 -- | Get the 'DataCon' from a 'TyThing' if it is a data constructor thing. Panics otherwise
 tyThingDataCon :: TyThing -> DataCon
 tyThingDataCon (ADataCon dc) = dc
@@ -1274,9 +1260,6 @@ class Monad m => MonadThings m where
 
         lookupTyCon :: Name -> m TyCon
         lookupTyCon = liftM tyThingTyCon . lookupThing
-
-        lookupClass :: Name -> m Class
-        lookupClass = liftM tyThingClass . lookupThing
 \end{code}
 
 \begin{code}
@@ -1640,15 +1623,15 @@ data NameCache
                -- ^ Supply of uniques
                nsNames :: OrigNameCache,
                -- ^ Ensures that one original name gets one unique
-               nsIPs   :: OrigIParamCache
-               -- ^ Ensures that one implicit parameter name gets one unique
+                nsIPs   :: OrigIParamCache
+                -- ^ Ensures that one implicit parameter name gets one unique
    }
 
 -- | Per-module cache of original 'OccName's given 'Name's
 type OrigNameCache   = ModuleEnv (OccEnv Name)
 
 -- | Module-local cache of implicit parameter 'OccName's given 'Name's
-type OrigIParamCache = Map (IPName OccName) (IPName Name)
+type OrigIParamCache = Map FastString (IPName Name)
 \end{code}
 
 
index 24f340b..d94e514 100644 (file)
@@ -44,7 +44,7 @@ import HsSyn
 import HscTypes
 import RnNames          (gresFromAvails)
 import InstEnv
-import Type
+import Type     hiding( typeKind )
 import TcType          hiding( typeKind )
 import Var
 import Id
index 7e2a98b..635bdce 100644 (file)
@@ -89,7 +89,6 @@ pprTyThingHdr pefas (AnId id)          = pprId         pefas id
 pprTyThingHdr pefas (ADataCon dataCon) = pprDataConSig pefas dataCon
 pprTyThingHdr pefas (ATyCon tyCon)     = pprTyConHdr   pefas tyCon
 pprTyThingHdr _     (ACoAxiom ax)      = pprCoAxiom ax
-pprTyThingHdr pefas (AClass cls)       = pprClassHdr   pefas cls
 
 ------------------------
 ppr_ty_thing :: PrintExplicitForalls -> ShowSub -> TyThing -> SDoc
@@ -97,12 +96,12 @@ ppr_ty_thing pefas _  (AnId id)          = pprId         pefas id
 ppr_ty_thing pefas _  (ADataCon dataCon) = pprDataConSig pefas dataCon
 ppr_ty_thing pefas ss (ATyCon tyCon)            = pprTyCon      pefas ss tyCon
 ppr_ty_thing _     _  (ACoAxiom ax)             = pprCoAxiom    ax
-ppr_ty_thing pefas ss (AClass cls)              = pprClass      pefas ss cls
-
 pprTyConHdr :: PrintExplicitForalls -> TyCon -> SDoc
-pprTyConHdr _ tyCon
+pprTyConHdr pefas tyCon
   | Just (fam_tc, tys) <- tyConFamInst_maybe tyCon
   = ptext keyword <+> ptext (sLit "instance") <+> pprTypeApp fam_tc tys
+  | Just cls <- tyConClass_maybe tyCon
+  = pprClassHdr pefas cls
   | otherwise
   = ptext keyword <+> opt_family <+> opt_stupid <+> ppr_bndr tyCon <+> hsep (map ppr vars)
   where
@@ -166,6 +165,8 @@ pprTyCon pefas ss tyCon
     else
       let rhs_type = GHC.synTyConType tyCon
       in hang (pprTyConHdr pefas tyCon <+> equals) 2 (pprTypeForUser pefas rhs_type)
+  | Just cls <- GHC.tyConClass_maybe tyCon
+  = pprClass pefas ss cls
   | otherwise
   = pprAlgTyCon pefas ss tyCon
 
index 01c9f7b..e1e4d87 100644 (file)
@@ -580,8 +580,8 @@ getImplicitBinds :: TypeEnv -> [CoreBind]
 getImplicitBinds type_env
   = map get_defn (concatMap implicit_ids (typeEnvElts type_env))
   where
-    implicit_ids (ATyCon tc)  = mapCatMaybes dataConWrapId_maybe (tyConDataCons tc)
-    implicit_ids (AClass cls) = classAllSelIds cls
+    implicit_ids (ATyCon tc)  = class_ids ++ mapCatMaybes dataConWrapId_maybe (tyConDataCons tc)
+      where class_ids = maybe [] classAllSelIds (tyConClass_maybe tc)
     implicit_ids _            = []
     
     get_defn :: Id -> CoreBind
index 1570af3..90e1e66 100644 (file)
@@ -495,6 +495,7 @@ data Token
   | ITrarrow
   | ITat
   | ITtilde
+  | ITtildehsh
   | ITdarrow
   | ITminus
   | ITbang
@@ -661,6 +662,7 @@ reservedSymsFM = listToUFM $
        ,("->",  ITrarrow,   always)
        ,("@",   ITat,       always)
        ,("~",   ITtilde,    always)
+       ,("~#",  ITtildehsh, always)
        ,("=>",  ITdarrow,   always)
        ,("-",   ITminus,    always)
        ,("!",   ITbang,     always)
index 1bf3810..3864c6b 100644 (file)
@@ -32,9 +32,10 @@ import RdrHsSyn
 import HscTypes                ( IsBootInterface, WarningTxt(..) )
 import Lexer
 import RdrName
+import TysPrim         ( eqPrimTyCon )
 import TysWiredIn      ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon,
                          unboxedSingletonTyCon, unboxedSingletonDataCon,
-                         listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR )
+                         listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR, eqTyCon_RDR )
 import Type            ( funTyCon )
 import ForeignCall     ( Safety(..), CExportSpec(..), CLabelString,
                          CCallConv(..), CCallTarget(..), defaultCCallConv
@@ -278,6 +279,7 @@ incorrect.
  '->'          { L _ ITrarrow }
  '@'           { L _ ITat }
  '~'           { L _ ITtilde }
+ '~#'          { L _ ITtildehsh }
  '=>'          { L _ ITdarrow }
  '-'           { L _ ITminus }
  '!'           { L _ ITbang }
@@ -961,7 +963,7 @@ ctype       :: { LHsType RdrName }
        : 'forall' tv_bndrs '.' ctype   { LL $ mkExplicitHsForAllTy $2 (noLoc []) $4 }
        | context '=>' ctype            { LL $ mkImplicitHsForAllTy   $1 $3 }
        -- A type of form (context => type) is an *implicit* HsForAllTy
-       | ipvar '::' type               { LL (HsPredTy (HsIParam (unLoc $1) $3)) }
+       | ipvar '::' type               { LL (HsIParamTy (unLoc $1) $3) }
        | type                          { $1 }
 
 ----------------------
@@ -979,7 +981,7 @@ ctypedoc :: { LHsType RdrName }
        : 'forall' tv_bndrs '.' ctypedoc        { LL $ mkExplicitHsForAllTy $2 (noLoc []) $4 }
        | context '=>' ctypedoc         { LL $ mkImplicitHsForAllTy   $1 $3 }
        -- A type of form (context => type) is an *implicit* HsForAllTy
-       | ipvar '::' type               { LL (HsPredTy (HsIParam (unLoc $1) $3)) }
+       | ipvar '::' type               { LL (HsIParamTy (unLoc $1) $3) }
        | typedoc                       { $1 }
 
 ----------------------
@@ -995,7 +997,7 @@ ctypedoc :: { LHsType RdrName }
 -- but not                         f :: ?x::Int => blah
 context :: { LHsContext RdrName }
         : btype '~'      btype         {% checkContext
-                                            (LL $ HsPredTy (HsEqualP $1 $3)) }
+                                            (LL $ HsEqTy $1 $3) }
        | btype                         {% checkContext $1 }
 
 type :: { LHsType RdrName }
@@ -1003,7 +1005,7 @@ type :: { LHsType RdrName }
         | btype qtyconop type           { LL $ HsOpTy $1 $2 $3 }
         | btype tyvarop  type          { LL $ HsOpTy $1 $2 $3 }
        | btype '->'     ctype          { LL $ HsFunTy $1 $3 }
-        | btype '~'      btype         { LL $ HsPredTy (HsEqualP $1 $3) }
+        | btype '~'      btype         { LL $ HsEqTy $1 $3 }
 
 typedoc :: { LHsType RdrName }
         : btype                          { $1 }
@@ -1014,7 +1016,7 @@ typedoc :: { LHsType RdrName }
         | btype tyvarop  type docprev    { LL $ HsDocTy (L (comb3 $1 $2 $3) (HsOpTy $1 $2 $3)) $4 }
         | btype '->'     ctypedoc        { LL $ HsFunTy $1 $3 }
         | btype docprev '->' ctypedoc    { LL $ HsFunTy (L (comb2 $1 $2) (HsDocTy $1 $2)) $4 }
-        | btype '~'      btype           { LL $ HsPredTy (HsEqualP $1 $3) }
+        | btype '~'      btype           { LL $ HsEqTy $1 $3 }
 
 btype :: { LHsType RdrName }
        : btype atype                   { LL $ HsAppTy $1 $2 }
@@ -1025,8 +1027,8 @@ atype :: { LHsType RdrName }
        | tyvar                         { L1 (HsTyVar (unLoc $1)) }
        | strict_mark atype             { LL (HsBangTy (unLoc $1) $2) }  -- Constructor sigs only
        | '{' fielddecls '}'            { LL $ HsRecTy $2 }              -- Constructor sigs only
-       | '(' ctype ',' comma_types1 ')'  { LL $ HsTupleTy Boxed  ($2:$4) }
-       | '(#' comma_types1 '#)'        { LL $ HsTupleTy Unboxed $2     }
+       | '(' ctype ',' comma_types1 ')'  { LL $ HsTupleTy (HsBoxyTuple placeHolderKind)  ($2:$4) }
+       | '(#' comma_types1 '#)'        { LL $ HsTupleTy HsUnboxedTuple $2     }
        | '[' ctype ']'                 { LL $ HsListTy  $2 }
        | '[:' ctype ':]'               { LL $ HsPArrTy  $2 }
        | '(' ctype ')'                 { LL $ HsParTy   $2 }
@@ -1090,6 +1092,7 @@ kind      :: { Located Kind }
 akind  :: { Located Kind }
        : '*'                   { L1 liftedTypeKind }
        | '!'                   { L1 unliftedTypeKind }
+       | CONID                 {% checkKindName (L1 (getCONID $1)) }
        | '(' kind ')'          { LL (unLoc $2) }
 
 
@@ -1710,9 +1713,9 @@ con_list : con                  { L1 [$1] }
 
 sysdcon        :: { Located DataCon }  -- Wired in data constructors
        : '(' ')'               { LL unitDataCon }
-       | '(' commas ')'        { LL $ tupleCon Boxed ($2 + 1) }
+       | '(' commas ')'        { LL $ tupleCon BoxedTuple ($2 + 1) }
        | '(#' '#)'             { LL $ unboxedSingletonDataCon }
-       | '(#' commas '#)'      { LL $ tupleCon Unboxed ($2 + 1) }
+       | '(#' commas '#)'      { LL $ tupleCon UnboxedTuple ($2 + 1) }
        | '[' ']'               { LL nilDataCon }
 
 conop :: { Located RdrName }
@@ -1729,16 +1732,18 @@ qconop :: { Located RdrName }
 gtycon         :: { Located RdrName }  -- A "general" qualified tycon
        : oqtycon                       { $1 }
        | '(' ')'                       { LL $ getRdrName unitTyCon }
-       | '(' commas ')'                { LL $ getRdrName (tupleTyCon Boxed ($2 + 1)) }
+       | '(' commas ')'                { LL $ getRdrName (tupleTyCon BoxedTuple ($2 + 1)) }
        | '(#' '#)'                     { LL $ getRdrName unboxedSingletonTyCon }
-       | '(#' commas '#)'              { LL $ getRdrName (tupleTyCon Unboxed ($2 + 1)) }
+       | '(#' commas '#)'              { LL $ getRdrName (tupleTyCon UnboxedTuple ($2 + 1)) }
        | '(' '->' ')'                  { LL $ getRdrName funTyCon }
        | '[' ']'                       { LL $ listTyCon_RDR }
        | '[:' ':]'                     { LL $ parrTyCon_RDR }
+       | '(' '~#' ')'                  { LL $ getRdrName eqPrimTyCon }
 
 oqtycon :: { Located RdrName } -- An "ordinary" qualified tycon
        : qtycon                        { $1 }
        | '(' qtyconsym ')'             { LL (unLoc $2) }
+       | '(' '~' ')'                   { LL $ eqTyCon_RDR } -- In here rather than gtycon because I want to write it in the GHC.Types export list
 
 qtyconop :: { Located RdrName }        -- Qualified or unqualified
        : qtyconsym                     { $1 }
index c99fcb6..cd76284 100644 (file)
@@ -246,7 +246,6 @@ akind       :: { IfaceKind }
 kind   :: { IfaceKind }
        : akind            { $1 }
        | akind '->' kind  { ifaceArrow $1 $3 }
-        | ty ':=:' ty      { ifaceEq $1 $3 }
 
 -----------------------------------------
 --             Expressions
@@ -378,8 +377,6 @@ ifaceUnliftedTypeKind = ifaceTcType IfaceUnliftedTypeKindTc
 
 ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2
 
-ifaceEq ifT1 ifT2 = IfacePredTy (IfaceEqPred ifT1 ifT2)
-
 toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName
 toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) (toKind k)
 
index 6886732..e6824e7 100644 (file)
@@ -33,17 +33,17 @@ module RdrHsSyn (
        -- checking and constructing values
        checkPrecP,           -- Int -> P Int
        checkContext,         -- HsType -> P HsContext
-       checkPred,            -- HsType -> P HsPred
        checkTyVars,          -- [LHsType RdrName] -> P ()
        checkKindSigs,        -- [LTyClDecl RdrName] -> P ()
        checkInstType,        -- HsType -> P HsType
        checkPattern,         -- HsExp -> P HsPat
-       bang_RDR,
+        bang_RDR,
        checkPatterns,        -- SrcLoc -> [HsExp] -> P [HsPat]
        checkMonadComp,       -- P (HsStmtContext RdrName)
        checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
        checkValSig,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
        checkDoAndIfThenElse,
+        checkKindName,
        parseError,         
        parseErrorSDoc,     
     ) where
@@ -53,13 +53,15 @@ import Class            ( FunDep )
 import TypeRep          ( Kind )
 import RdrName         ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, 
                          isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace )
-import Name             ( Name )
+import OccName          ( occNameFS )
+import Name             ( Name, nameOccName )
 import BasicTypes      ( maxPrecedence, Activation(..), RuleMatchInfo,
                           InlinePragma(..), InlineSpec(..) )
 import Lexer
-import TysWiredIn      ( unitTyCon ) 
+import TysWiredIn      ( unitTyCon )
+import TysPrim          ( constraintKindTyConName, constraintKind )
 import ForeignCall
-import OccName         ( srcDataName, varName, isDataOcc, isTcOcc, 
+import OccName         ( srcDataName, varName, isDataOcc, isTcOcc,
                          occNameString )
 import PrelNames       ( forall_tv_RDR )
 import DynFlags
@@ -102,13 +104,8 @@ extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrNa
 extractHsRhoRdrTyVars ctxt ty 
  = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
 
-extract_lctxt :: Located [LHsPred RdrName] -> [Located RdrName] -> [Located RdrName]
-extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
-
-extract_pred :: HsPred RdrName -> [Located RdrName] -> [Located RdrName]
-extract_pred (HsClassP _   tys) acc = extract_ltys tys acc
-extract_pred (HsEqualP ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
-extract_pred (HsIParam _   ty ) acc = extract_lty ty acc
+extract_lctxt :: LHsContext RdrName -> [Located RdrName] -> [Located RdrName]
+extract_lctxt ctxt acc = foldr extract_lty acc (unLoc ctxt)
 
 extract_ltys :: [LHsType RdrName] -> [Located RdrName] -> [Located RdrName]
 extract_ltys tys acc = foldr extract_lty acc tys
@@ -124,7 +121,8 @@ extract_lty (L loc ty) acc
       HsPArrTy ty                      -> extract_lty ty acc
       HsTupleTy _ tys                  -> extract_ltys tys acc
       HsFunTy ty1 ty2                  -> extract_lty ty1 (extract_lty ty2 acc)
-      HsPredTy p               -> extract_pred p acc
+      HsIParamTy _ ty          -> extract_lty ty acc
+      HsEqTy ty1 ty2            -> extract_lty ty1 (extract_lty ty2 acc)
       HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
       HsParTy ty                       -> extract_lty ty acc
       HsCoreTy {}               -> acc  -- The type is closed
@@ -473,15 +471,9 @@ checkInstType (L l t)
                   return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
 
 checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
-checkDictTy (L spn ty) = check ty []
-  where
-  check (HsTyVar tc)            args | isRdrTc tc = done tc args
-  check (HsOpTy t1 (L _ tc) t2) args | isRdrTc tc = done tc (t1:t2:args)
-  check (HsAppTy l r) args = check (unLoc l) (r:args)
-  check (HsParTy t)   args = check (unLoc t) args
-  check _ _ = parseErrorSDoc spn (text "Malformed instance header:" <+> ppr ty)
-
-  done tc args = return (L spn (HsPredTy (HsClassP tc args)))
+checkDictTy lty@(L l ty) = case splitLHsClassTy_maybe lty of
+    Nothing -> parseErrorSDoc l (text "Malformed instance header:" <+> ppr ty)
+    Just _  -> return lty
 
 checkTParams :: Bool     -- Type/data family
             -> LHsType RdrName
@@ -570,12 +562,11 @@ checkKindSigs = mapM_ check
        parseErrorSDoc l (text "Type declaration in a class must be a kind signature:" $$ ppr tydecl)
 
 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
-checkContext (L l t)
-  = check t
+checkContext (L l orig_t)
+  = check orig_t
  where
   check (HsTupleTy _ ts)       -- (Eq a, Ord b) shows up as a tuple type
-    = do ctx <- mapM checkPred ts
-        return (L l ctx)
+    = return (L l ts)
 
   check (HsParTy ty)   -- to be sure HsParTy doesn't get into the way
     = check (unLoc ty)
@@ -583,32 +574,8 @@ checkContext (L l t)
   check (HsTyVar t)    -- Empty context shows up as a unit type ()
     | t == getRdrName unitTyCon = return (L l [])
 
-  check t 
-    = do p <- checkPred (L l t)
-         return (L l [p])
-
-
-checkPred :: LHsType RdrName -> P (LHsPred RdrName)
--- Watch out.. in ...deriving( Show )... we use checkPred on 
--- the list of partially applied predicates in the deriving,
--- so there can be zero args.
-checkPred (L spn (HsPredTy (HsIParam n ty)))
-  = return (L spn (HsIParam n ty))
-checkPred (L spn ty)
-  = check spn ty []
-  where
-    checkl (L l ty) args = check l ty args
-
-    check _loc (HsPredTy pred@(HsEqualP _ _)) 
-                                       args | null args
-                                           = return $ L spn pred
-    check _loc (HsTyVar t)             args | not (isRdrTyVar t) 
-                                           = return (L spn (HsClassP t args))
-    check _loc (HsAppTy l r)           args = checkl l (r:args)
-    check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
-    check _loc (HsParTy t)            args = checkl t args
-    check loc _                        _    = parseErrorSDoc loc
-                                (text "malformed class assertion:" <+> ppr ty)
+  check _
+    = return (L l [L l orig_t])
 
 -- -------------------------------------------------------------------------
 -- Checking Patterns.
@@ -816,6 +783,17 @@ checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
           expr = text "if"   <+> ppr guardExpr <> pprOptSemi semiThen <+>
                  text "then" <+> ppr thenExpr  <> pprOptSemi semiElse <+>
                  text "else" <+> ppr elseExpr
+
+checkKindName :: Located FastString -> P (Located Kind)
+checkKindName (L l fs) = do
+    pState <- getPState
+    let ext_enabled = xopt Opt_ConstraintKind (dflags pState)
+        is_kosher = fs == occNameFS (nameOccName constraintKindTyConName)
+    if not ext_enabled || not is_kosher
+     then parseErrorSDoc l (text "Unexpected named kind:"
+                         $$ nest 4 (ppr fs)
+                         $$ if (not ext_enabled && is_kosher) then text "Perhaps you meant to use -XConstraintKind?" else empty)
+     else return (L l constraintKind)
 \end{code}
 
 
index f5ba7de..bd59a01 100644 (file)
@@ -57,7 +57,7 @@ import Unique     ( Unique, Uniquable(..), hasKey,
                     mkPreludeTyConUnique, mkPreludeClassUnique,
                     mkTupleTyConUnique
                   )
-import BasicTypes ( Boxity(..), Arity )
+import BasicTypes ( TupleSort(..), Arity )
 import Name       ( Name, mkInternalName, mkExternalName, mkSystemVarName )
 import SrcLoc
 import FastString
@@ -403,9 +403,10 @@ mkMainModule_ m = mkModule mainPackageId m
 %************************************************************************
 
 \begin{code}
-mkTupleModule :: Boxity -> Arity -> Module
-mkTupleModule Boxed   _ = gHC_TUPLE
-mkTupleModule Unboxed _ = gHC_PRIM
+mkTupleModule :: TupleSort -> Arity -> Module
+mkTupleModule BoxedTuple   _ = gHC_TUPLE
+mkTupleModule FactTuple    _ = gHC_TUPLE
+mkTupleModule UnboxedTuple _ = gHC_PRIM
 \end{code}
 
 
@@ -1137,7 +1138,7 @@ addrPrimTyConKey, arrayPrimTyConKey, boolTyConKey, byteArrayPrimTyConKey,
     mutableArrayPrimTyConKey, mutableByteArrayPrimTyConKey,
     orderingTyConKey, mVarPrimTyConKey, ratioTyConKey, rationalTyConKey,
     realWorldTyConKey, stablePtrPrimTyConKey, stablePtrTyConKey,
-    anyTyConKey :: Unique
+    anyTyConKey, eqTyConKey :: Unique
 addrPrimTyConKey                        = mkPreludeTyConUnique  1
 arrayPrimTyConKey                       = mkPreludeTyConUnique  3
 boolTyConKey                            = mkPreludeTyConUnique  4
@@ -1171,6 +1172,7 @@ realWorldTyConKey                       = mkPreludeTyConUnique 34
 stablePtrPrimTyConKey                   = mkPreludeTyConUnique 35
 stablePtrTyConKey                       = mkPreludeTyConUnique 36
 anyTyConKey                             = mkPreludeTyConUnique 37
+eqTyConKey                              = mkPreludeTyConUnique 38
 
 statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey,
     mutVarPrimTyConKey, ioTyConKey,
@@ -1178,11 +1180,11 @@ statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey,
     word32PrimTyConKey, word32TyConKey, word64PrimTyConKey, word64TyConKey,
     liftedConKey, unliftedConKey, anyBoxConKey, kindConKey, boxityConKey,
     typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey,
-    funPtrTyConKey, tVarPrimTyConKey, eqPredPrimTyConKey :: Unique
+    funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey :: Unique
 statePrimTyConKey                       = mkPreludeTyConUnique 50
 stableNamePrimTyConKey                  = mkPreludeTyConUnique 51
 stableNameTyConKey                      = mkPreludeTyConUnique 52
-eqPredPrimTyConKey                      = mkPreludeTyConUnique 53
+eqPrimTyConKey                          = mkPreludeTyConUnique 53
 mutVarPrimTyConKey                      = mkPreludeTyConUnique 55
 ioTyConKey                              = mkPreludeTyConUnique 56
 wordPrimTyConKey                        = mkPreludeTyConUnique 58
@@ -1222,12 +1224,13 @@ tySuperKindTyConKey                    = mkPreludeTyConUnique 85
 
 -- Kind constructors
 liftedTypeKindTyConKey, openTypeKindTyConKey, unliftedTypeKindTyConKey,
-    ubxTupleKindTyConKey, argTypeKindTyConKey :: Unique
+    ubxTupleKindTyConKey, argTypeKindTyConKey, constraintKindTyConKey :: Unique
 liftedTypeKindTyConKey                  = mkPreludeTyConUnique 87
 openTypeKindTyConKey                    = mkPreludeTyConUnique 88
 unliftedTypeKindTyConKey                = mkPreludeTyConUnique 89
 ubxTupleKindTyConKey                    = mkPreludeTyConUnique 90
 argTypeKindTyConKey                     = mkPreludeTyConUnique 91
+constraintKindTyConKey                  = mkPreludeTyConUnique 92
 
 -- Coercion constructors
 symCoercionTyConKey, transCoercionTyConKey, leftCoercionTyConKey,
@@ -1298,7 +1301,7 @@ rep1TyConKey = mkPreludeTyConUnique 156
 -----------------------------------------------------
 
 unitTyConKey :: Unique
-unitTyConKey = mkTupleTyConUnique Boxed 0
+unitTyConKey = mkTupleTyConUnique BoxedTuple 0
 \end{code}
 
 %************************************************************************
@@ -1311,7 +1314,7 @@ unitTyConKey = mkTupleTyConUnique Boxed 0
 charDataConKey, consDataConKey, doubleDataConKey, falseDataConKey,
     floatDataConKey, intDataConKey, nilDataConKey, ratioDataConKey,
     stableNameDataConKey, trueDataConKey, wordDataConKey,
-    ioDataConKey, integerDataConKey :: Unique
+    ioDataConKey, integerDataConKey, eqBoxDataConKey :: Unique
 charDataConKey                          = mkPreludeDataConUnique  1
 consDataConKey                          = mkPreludeDataConUnique  2
 doubleDataConKey                        = mkPreludeDataConUnique  3
@@ -1325,6 +1328,7 @@ trueDataConKey                          = mkPreludeDataConUnique 15
 wordDataConKey                          = mkPreludeDataConUnique 16
 ioDataConKey                            = mkPreludeDataConUnique 17
 integerDataConKey                       = mkPreludeDataConUnique 18
+eqBoxDataConKey                         = mkPreludeDataConUnique 19
 
 -- Generic data constructors
 crossDataConKey, inlDataConKey, inrDataConKey, genUnitDataConKey :: Unique
index f86e6a4..9dbc32f 100644 (file)
@@ -557,7 +557,7 @@ dataToTagRule _ _ = Nothing
 -- seq# :: forall a s . a -> State# s -> (# State# s, a #)
 seqRule :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
 seqRule _ [ty_a, Type ty_s, a, s] | exprIsHNF a
-   = Just (mkConApp (tupleCon Unboxed 2)
+   = Just (mkConApp (tupleCon UnboxedTuple 2)
                     [Type (mkStatePrimTy ty_s), ty_a, s, a])
 seqRule _ _ = Nothing
 
index 29c5644..ccf6ea0 100644 (file)
@@ -37,7 +37,7 @@ import OccName                ( OccName, pprOccName, mkVarOccFS )
 import TyCon           ( TyCon, isPrimTyCon, tyConPrimRep, PrimRep(..) )
 import Type            ( Type, mkForAllTys, mkFunTy, mkFunTys, tyConAppTyCon,
                          typePrimRep )
-import BasicTypes      ( Arity, Boxity(..) )
+import BasicTypes      ( Arity, TupleSort(..) )
 import ForeignCall     ( CLabelString )
 import Unique          ( Unique, mkPrimOpIdUnique )
 import Outputable
index b130c21..43fd143 100644 (file)
@@ -9,7 +9,9 @@
 -- | This module defines TyCons that can't be expressed in Haskell. 
 --   They are all, therefore, wired-in TyCons.  C.f module TysWiredIn
 module TysPrim(
-       alphaTyVars, betaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar,
+       mkPrimTyConName, -- For implicit parameters in TysWiredIn only
+
+        tyVarList, alphaTyVars, betaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar,
        alphaTy, betaTy, gammaTy, deltaTy,
        openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, openAlphaTyVars,
         argAlphaTy, argAlphaTyVar, argBetaTy, argBetaTyVar,
@@ -17,15 +19,16 @@ module TysPrim(
         -- Kind constructors...
         tySuperKindTyCon, tySuperKind,
         liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
-        argTypeKindTyCon, ubxTupleKindTyCon,
+        argTypeKindTyCon, ubxTupleKindTyCon, constraintKindTyCon,
 
         tySuperKindTyConName, liftedTypeKindTyConName,
         openTypeKindTyConName, unliftedTypeKindTyConName,
         ubxTupleKindTyConName, argTypeKindTyConName,
+        constraintKindTyConName,
 
         -- Kinds
        liftedTypeKind, unliftedTypeKind, openTypeKind,
-        argTypeKind, ubxTupleKind,
+        argTypeKind, ubxTupleKind, constraintKind,
         mkArrowKind, mkArrowKinds,
 
         funTyCon, funTyConName,
@@ -61,7 +64,7 @@ module TysPrim(
        int64PrimTyCon,         int64PrimTy,
         word64PrimTyCon,        word64PrimTy,
 
-        eqPredPrimTyCon,            -- ty1 ~ ty2
+        eqPrimTyCon,            -- ty1 ~# ty2
 
        -- * Any
        anyTyCon, anyTyConOfKind, anyTypeOfKind
@@ -117,7 +120,7 @@ primTyCons
     , word32PrimTyCon
     , word64PrimTyCon
     , anyTyCon
-    , eqPredPrimTyCon
+    , eqPrimTyCon
     ]
 
 mkPrimTc :: FastString -> Unique -> TyCon -> Name
@@ -127,7 +130,7 @@ mkPrimTc fs unique tycon
                  (ATyCon tycon)        -- Relevant TyCon
                  UserSyntax            -- None are built-in syntax
 
-charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPredPrimTyConName :: Name
+charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName :: Name
 charPrimTyConName            = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon
 intPrimTyConName             = mkPrimTc (fsLit "Int#") intPrimTyConKey  intPrimTyCon
 int32PrimTyConName           = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon
@@ -139,7 +142,7 @@ addrPrimTyConName                 = mkPrimTc (fsLit "Addr#") addrPrimTyConKey addrPrim
 floatPrimTyConName           = mkPrimTc (fsLit "Float#") floatPrimTyConKey floatPrimTyCon
 doublePrimTyConName          = mkPrimTc (fsLit "Double#") doublePrimTyConKey doublePrimTyCon
 statePrimTyConName            = mkPrimTc (fsLit "State#") statePrimTyConKey statePrimTyCon
-eqPredPrimTyConName           = mkPrimTc (fsLit "~") eqPredPrimTyConKey eqPredPrimTyCon
+eqPrimTyConName               = mkPrimTc (fsLit "~#") eqPrimTyConKey eqPrimTyCon
 realWorldTyConName            = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon
 arrayPrimTyConName           = mkPrimTc (fsLit "Array#") arrayPrimTyConKey arrayPrimTyCon
 byteArrayPrimTyConName       = mkPrimTc (fsLit "ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon
@@ -241,11 +244,13 @@ funTyCon = mkFunTyCon funTyConName (mkArrowKinds [argTypeKind, openTypeKind] lif
 -- | See "Type#kind_subtyping" for details of the distinction between the 'Kind' 'TyCon's
 tySuperKindTyCon, liftedTypeKindTyCon,
       openTypeKindTyCon, unliftedTypeKindTyCon,
-      ubxTupleKindTyCon, argTypeKindTyCon
+      ubxTupleKindTyCon, argTypeKindTyCon,
+      constraintKindTyCon
    :: TyCon
 tySuperKindTyConName, liftedTypeKindTyConName,
       openTypeKindTyConName, unliftedTypeKindTyConName,
-      ubxTupleKindTyConName, argTypeKindTyConName
+      ubxTupleKindTyConName, argTypeKindTyConName,
+      constraintKindTyConName
    :: Name
 
 tySuperKindTyCon      = mkSuperKindTyCon tySuperKindTyConName
@@ -254,6 +259,7 @@ openTypeKindTyCon     = mkKindTyCon openTypeKindTyConName     tySuperKind
 unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName tySuperKind
 ubxTupleKindTyCon     = mkKindTyCon ubxTupleKindTyConName     tySuperKind
 argTypeKindTyCon      = mkKindTyCon argTypeKindTyConName      tySuperKind
+constraintKindTyCon   = mkKindTyCon constraintKindTyConName   tySuperKind
 
 --------------------------
 -- ... and now their names
@@ -264,6 +270,7 @@ openTypeKindTyConName     = mkPrimTyConName (fsLit "?") openTypeKindTyConKey ope
 unliftedTypeKindTyConName = mkPrimTyConName (fsLit "#") unliftedTypeKindTyConKey unliftedTypeKindTyCon
 ubxTupleKindTyConName     = mkPrimTyConName (fsLit "(#)") ubxTupleKindTyConKey ubxTupleKindTyCon
 argTypeKindTyConName      = mkPrimTyConName (fsLit "??") argTypeKindTyConKey argTypeKindTyCon
+constraintKindTyConName   = mkPrimTyConName (fsLit "Constraint") constraintKindTyConKey constraintKindTyCon
 
 mkPrimTyConName :: FastString -> Unique -> TyCon -> Name
 mkPrimTyConName occ key tycon = mkWiredInName gHC_PRIM (mkTcOccFS occ) 
@@ -280,13 +287,14 @@ kindTyConType :: TyCon -> Type
 kindTyConType kind = TyConApp kind []
 
 -- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's
-liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind :: Kind
+liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind, constraintKind :: Kind
 
 liftedTypeKind   = kindTyConType liftedTypeKindTyCon
 unliftedTypeKind = kindTyConType unliftedTypeKindTyCon
 openTypeKind     = kindTyConType openTypeKindTyCon
 argTypeKind      = kindTyConType argTypeKindTyCon
 ubxTupleKind    = kindTyConType ubxTupleKindTyCon
+constraintKind   = kindTyConType constraintKindTyCon
 
 -- | Given two kinds @k1@ and @k2@, creates the 'Kind' @k1 -> k2@
 mkArrowKind :: Kind -> Kind -> Kind
@@ -379,18 +387,18 @@ doublePrimTyCon   = pcPrimTyCon0 doublePrimTyConName DoubleRep
 %*                                                                     *
 %************************************************************************
 
-Note [The (~) TyCon)
+Note [The ~# TyCon)
 ~~~~~~~~~~~~~~~~~~~~
-There is a perfectly ordinary type constructor (~) that represents the type
+There is a perfectly ordinary type constructor ~# that represents the type
 of coercions (which, remember, are values).  For example
-   Refl Int :: Int ~ Int
+   Refl Int :: ~# Int Int
 
 Atcually it is not quite "perfectly ordinary" because it is kind-polymorphic:
-   Refl Maybe :: Maybe ~ Maybe
+   Refl Maybe :: ~# Maybe Maybe
 
-So the true kind of (~) :: forall k. k -> k -> #.  But we don't have
+So the true kind of ~# :: forall k. k -> k -> #.  But we don't have
 polymorphic kinds (yet). However, (~) really only appears saturated in
-which case there is no problem in finding the kind of (ty1 ~ ty2). So
+which case there is no problem in finding the kind of (ty1 ~# ty2). So
 we check that in CoreLint (and, in an assertion, in Kind.typeKind).
 
 Note [The State# TyCon]
@@ -411,9 +419,9 @@ mkStatePrimTy ty = mkTyConApp statePrimTyCon [ty]
 statePrimTyCon :: TyCon   -- See Note [The State# TyCon]
 statePrimTyCon  = pcPrimTyCon statePrimTyConName 1 VoidRep
 
-eqPredPrimTyCon :: TyCon  -- The representation type for equality predicates
-                         -- See Note [The (~) TyCon]
-eqPredPrimTyCon  = pcPrimTyCon eqPredPrimTyConName 2 VoidRep
+eqPrimTyCon :: TyCon  -- The representation type for equality predicates
+                     -- See Note [The ~# TyCon]
+eqPrimTyCon  = pcPrimTyCon eqPrimTyConName 2 VoidRep
 \end{code}
 
 RealWorld is deeply magical.  It is *primitive*, but it is not
@@ -575,8 +583,6 @@ threadIdPrimTyCon :: TyCon
 threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName PtrRep
 \end{code}
 
-
-
 %************************************************************************
 %*                                                                     *
                Any
index 65a0c33..7b12fec 100644 (file)
@@ -8,7 +8,7 @@
 --   must be wired into the compiler nonetheless.  C.f module TysPrim
 module TysWiredIn (
         -- * All wired in things
-       wiredInTyCons, 
+       wiredInTyCons,
 
         -- * Bool
        boolTy, boolTyCon, boolTyCon_RDR, boolTyConName,
@@ -55,7 +55,13 @@ module TysWiredIn (
         -- * Parallel arrays
        mkPArrTy,
        parrTyCon, parrFakeCon, isPArrTyCon, isPArrFakeCon,
-       parrTyCon_RDR, parrTyConName
+       parrTyCon_RDR, parrTyConName,
+
+        -- * Equality predicates
+        eqTyCon_RDR, eqTyCon, eqTyConName, eqBoxDataCon,
+
+        -- * Implicit parameter predicates
+        mkIPName
     ) where
 
 #include "HsVersions.h"
@@ -67,6 +73,7 @@ import PrelNames
 import TysPrim
 
 -- others:
+import Coercion
 import Constants       ( mAX_TUPLE_SIZE )
 import Module          ( Module )
 import DataCon          ( DataCon, mkDataCon, dataConWorkId, dataConSourceArity )
@@ -75,7 +82,7 @@ import TyCon
 import TypeRep
 import RdrName
 import Name
-import BasicTypes       ( Arity, RecFlag(..), Boxity(..), isBoxed, HsBang(..) )
+import BasicTypes       ( TupleSort(..), tupleSortBoxity, IPName(..), Arity, RecFlag(..), Boxity(..), HsBang(..) )
 import Unique           ( incrUnique, mkTupleTyConUnique,
                          mkTupleDataConUnique, mkPArrDataConUnique )
 import Data.Array
@@ -100,9 +107,16 @@ If you change which things are wired in, make sure you change their
 names in PrelNames, so they use wTcQual, wDataQual, etc
 
 \begin{code}
-wiredInTyCons :: [TyCon]       -- Excludes tuples
--- This list is used only to define PrelInfo.wiredInThings
-
+-- This list is used only to define PrelInfo.wiredInThings. That in turn
+-- is used to initialise the name environment carried around by the renamer.
+-- This means that if we look up the name of a TyCon (or its implicit binders)
+-- that occurs in this list that name will be assigned the wired-in key we
+-- define here.
+--
+-- Because of their infinite nature, this list excludes tuples, Any and implicit
+-- parameter TyCons. Instead, we have a hack in lookupOrigNameCache to deal with
+-- these names.
+wiredInTyCons :: [TyCon]
 -- It does not need to include kind constructors, because
 -- all that wiredInThings does is to initialise the Name table,
 -- and kind constructors don't appear in source code.
@@ -120,6 +134,7 @@ wiredInTyCons = [ unitTyCon -- Not treated like other tuples, because
              , intTyCon
              , listTyCon
              , parrTyCon
+              , eqTyCon
              ]
 \end{code}
 
@@ -136,6 +151,10 @@ mkWiredInDataConName built_in modu fs unique datacon
                  (ADataCon datacon)    -- Relevant DataCon
                  built_in
 
+eqTyConName, eqBoxDataConName :: Name
+eqTyConName      = mkWiredInTyConName   BuiltInSyntax gHC_TYPES (fsLit "~")   eqTyConKey      eqTyCon
+eqBoxDataConName = mkWiredInDataConName UserSyntax       gHC_TYPES (fsLit "Eq#") eqBoxDataConKey eqBoxDataCon
+
 charTyConName, charDataConName, intTyConName, intDataConName :: Name
 charTyConName    = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Char") charTyConKey charTyCon
 charDataConName   = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "C#") charDataConKey charDataCon
@@ -165,7 +184,7 @@ parrDataConName = mkWiredInDataConName UserSyntax
                     gHC_PARR' (fsLit "PArr") parrDataConKey parrDataCon
 
 boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR,
-    intDataCon_RDR, listTyCon_RDR, consDataCon_RDR, parrTyCon_RDR:: RdrName
+    intDataCon_RDR, listTyCon_RDR, consDataCon_RDR, parrTyCon_RDR, eqTyCon_RDR :: RdrName
 boolTyCon_RDR   = nameRdrName boolTyConName
 false_RDR      = nameRdrName falseDataConName
 true_RDR       = nameRdrName trueDataConName
@@ -175,6 +194,7 @@ intDataCon_RDR      = nameRdrName intDataConName
 listTyCon_RDR  = nameRdrName listTyConName
 consDataCon_RDR = nameRdrName consDataConName
 parrTyCon_RDR  = nameRdrName parrTyConName
+eqTyCon_RDR     = nameRdrName eqTyConName
 \end{code}
 
 
@@ -206,15 +226,23 @@ pcTyCon is_enum is_rec name tyvars cons
 pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon
 pcDataCon = pcDataConWithFixity False
 
+pcDataCon' :: Name -> Unique -> [TyVar] -> [Type] -> TyCon -> DataCon
+pcDataCon' = pcDataConWithFixity' False
+
 pcDataConWithFixity :: Bool -> Name -> [TyVar] -> [Type] -> TyCon -> DataCon
--- The Name should be in the DataName name space; it's the name
--- of the DataCon itself.
---
--- The unique is the first of two free uniques;
+pcDataConWithFixity infx n = pcDataConWithFixity' infx n (incrUnique (nameUnique n))
+-- The Name's unique is the first of two free uniques;
 -- the first is used for the datacon itself,
 -- the second is used for the "worker name"
+--
+-- To support this the mkPreludeDataConUnique function "allocates"
+-- one DataCon unique per pair of Ints.
+
+pcDataConWithFixity' :: Bool -> Name -> Unique -> [TyVar] -> [Type] -> TyCon -> DataCon
+-- The Name should be in the DataName name space; it's the name
+-- of the DataCon itself.
 
-pcDataConWithFixity declared_infix dc_name tyvars arg_tys tycon
+pcDataConWithFixity' declared_infix dc_name wrk_key tyvars arg_tys tycon
   = data_con
   where
     data_con = mkDataCon dc_name declared_infix
@@ -233,7 +261,6 @@ pcDataConWithFixity declared_infix dc_name tyvars arg_tys tycon
     modu     = ASSERT( isExternalName dc_name ) 
               nameModule dc_name
     wrk_occ  = mkDataConWorkerOcc (nameOccName dc_name)
-    wrk_key  = incrUnique (nameUnique dc_name)
     wrk_name = mkWiredInName modu wrk_occ wrk_key
                             (AnId (dataConWorkId data_con)) UserSyntax
     bogus_wrap_name = pprPanic "Wired-in data wrapper id" (ppr dc_name)
@@ -248,62 +275,101 @@ pcDataConWithFixity declared_infix dc_name tyvars arg_tys tycon
 %************************************************************************
 
 \begin{code}
-tupleTyCon :: Boxity -> Arity -> TyCon
-tupleTyCon boxity i | i > mAX_TUPLE_SIZE = fst (mk_tuple boxity i)     -- Build one specially
-tupleTyCon Boxed   i = fst (boxedTupleArr   ! i)
-tupleTyCon Unboxed i = fst (unboxedTupleArr ! i)
-
-tupleCon :: Boxity -> Arity -> DataCon
-tupleCon boxity i | i > mAX_TUPLE_SIZE = snd (mk_tuple boxity i)       -- Build one specially
-tupleCon Boxed   i = snd (boxedTupleArr   ! i)
-tupleCon Unboxed i = snd (unboxedTupleArr ! i)
-
-boxedTupleArr, unboxedTupleArr :: Array Int (TyCon,DataCon)
-boxedTupleArr   = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Boxed i | i <- [0..mAX_TUPLE_SIZE]]
-unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mAX_TUPLE_SIZE]]
-
-mk_tuple :: Boxity -> Int -> (TyCon,DataCon)
-mk_tuple boxity arity = (tycon, tuple_con)
+tupleTyCon :: TupleSort -> Arity -> TyCon
+tupleTyCon sort i | i > mAX_TUPLE_SIZE = fst (mk_tuple sort i) -- Build one specially
+tupleTyCon BoxedTuple   i = fst (boxedTupleArr   ! i)
+tupleTyCon UnboxedTuple i = fst (unboxedTupleArr ! i)
+tupleTyCon FactTuple    i = fst (factTupleArr    ! i)
+
+tupleCon :: TupleSort -> Arity -> DataCon
+tupleCon sort i | i > mAX_TUPLE_SIZE = snd (mk_tuple sort i)   -- Build one specially
+tupleCon BoxedTuple   i = snd (boxedTupleArr   ! i)
+tupleCon UnboxedTuple i = snd (unboxedTupleArr ! i)
+tupleCon FactTuple    i = snd (factTupleArr    ! i)
+
+boxedTupleArr, unboxedTupleArr, factTupleArr :: Array Int (TyCon,DataCon)
+boxedTupleArr   = listArray (0,mAX_TUPLE_SIZE) [mk_tuple BoxedTuple i | i <- [0..mAX_TUPLE_SIZE]]
+unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple UnboxedTuple i | i <- [0..mAX_TUPLE_SIZE]]
+factTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple FactTuple i | i <- [0..mAX_TUPLE_SIZE]]
+
+mk_tuple :: TupleSort -> Int -> (TyCon,DataCon)
+mk_tuple sort arity = (tycon, tuple_con)
   where
-       tycon   = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con boxity 
-       modu    = mkTupleModule boxity arity
-       tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq
+       tycon   = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con sort 
+       modu    = mkTupleModule sort arity
+       tc_name = mkWiredInName modu (mkTupleOcc tcName sort arity) tc_uniq
                                (ATyCon tycon) BuiltInSyntax
        tc_kind = mkArrowKinds (map tyVarKind tyvars) res_kind
-       res_kind | isBoxed boxity = liftedTypeKind
-                | otherwise      = ubxTupleKind
+       res_kind = case sort of
+         BoxedTuple   -> liftedTypeKind
+         UnboxedTuple -> ubxTupleKind
+         FactTuple    -> constraintKind
 
-       tyvars   | isBoxed boxity = take arity alphaTyVars
-                | otherwise      = take arity openAlphaTyVars
+       tyvars = take arity $ case sort of
+         BoxedTuple   -> alphaTyVars
+         UnboxedTuple -> openAlphaTyVars
+         FactTuple    -> tyVarList constraintKind
 
        tuple_con = pcDataCon dc_name tyvars tyvar_tys tycon
        tyvar_tys = mkTyVarTys tyvars
-       dc_name   = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq
+       dc_name   = mkWiredInName modu (mkTupleOcc dataName sort arity) dc_uniq
                                  (ADataCon tuple_con) BuiltInSyntax
-       tc_uniq   = mkTupleTyConUnique   boxity arity
-       dc_uniq   = mkTupleDataConUnique boxity arity
+       tc_uniq   = mkTupleTyConUnique   sort arity
+       dc_uniq   = mkTupleDataConUnique sort arity
 
 unitTyCon :: TyCon
-unitTyCon     = tupleTyCon Boxed 0
+unitTyCon     = tupleTyCon BoxedTuple 0
 unitDataCon :: DataCon
 unitDataCon   = head (tyConDataCons unitTyCon)
 unitDataConId :: Id
 unitDataConId = dataConWorkId unitDataCon
 
 pairTyCon :: TyCon
-pairTyCon = tupleTyCon Boxed 2
+pairTyCon = tupleTyCon BoxedTuple 2
 
 unboxedSingletonTyCon :: TyCon
-unboxedSingletonTyCon   = tupleTyCon Unboxed 1
+unboxedSingletonTyCon   = tupleTyCon UnboxedTuple 1
 unboxedSingletonDataCon :: DataCon
-unboxedSingletonDataCon = tupleCon   Unboxed 1
+unboxedSingletonDataCon = tupleCon   UnboxedTuple 1
 
 unboxedPairTyCon :: TyCon
-unboxedPairTyCon   = tupleTyCon Unboxed 2
+unboxedPairTyCon   = tupleTyCon UnboxedTuple 2
 unboxedPairDataCon :: DataCon
-unboxedPairDataCon = tupleCon   Unboxed 2
+unboxedPairDataCon = tupleCon   UnboxedTuple 2
 \end{code}
 
+%************************************************************************
+%*                                                                      *
+\subsection[TysWiredIn-ImplicitParams]{Special type constructors for implicit parameters}
+%*                                                                      *
+%************************************************************************
+
+\begin{code}
+mkIPName :: FastString
+         -> Unique -> Unique -> Unique -> Unique
+         -> IPName Name
+mkIPName ip tycon_u datacon_u dc_wrk_u co_ax_u = name_ip
+  where
+    name_ip = IPName tycon_name
+
+    tycon_name = mkPrimTyConName ip tycon_u tycon
+    tycon      = mkAlgTyCon tycon_name
+                   (liftedTypeKind `mkArrowKind` constraintKind)
+                   [alphaTyVar]
+                   []      -- No stupid theta
+                   (NewTyCon { data_con    = datacon, 
+                               nt_rhs      = mkTyVarTy alphaTyVar,
+                               nt_etad_rhs = ([alphaTyVar], mkTyVarTy alphaTyVar),
+                               nt_co       = mkNewTypeCo co_ax_name tycon [alphaTyVar] (mkTyVarTy alphaTyVar) })
+                   (IPTyCon name_ip)
+                   NonRecursive
+                   False
+
+    datacon_name = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "IPBox") datacon_u datacon
+    datacon      = pcDataCon' datacon_name dc_wrk_u [alphaTyVar] [mkTyVarTy alphaTyVar] tycon
+
+    co_ax_name = mkPrimTyConName ip co_ax_u tycon
+\end{code}
 
 %************************************************************************
 %*                                                                     *
@@ -312,6 +378,21 @@ unboxedPairDataCon = tupleCon   Unboxed 2
 %************************************************************************
 
 \begin{code}
+eqTyCon :: TyCon
+eqTyCon = mkAlgTyCon eqTyConName
+            (mkArrowKinds [openTypeKind, openTypeKind] constraintKind)
+            [alphaTyVar, betaTyVar]
+            []      -- No stupid theta
+            (DataTyCon [eqBoxDataCon] False)
+            NoParentTyCon
+            NonRecursive
+            False
+    
+eqBoxDataCon :: DataCon
+eqBoxDataCon = pcDataCon eqBoxDataConName [alphaTyVar, betaTyVar] [TyConApp eqPrimTyCon [mkTyVarTy alphaTyVar, mkTyVarTy betaTyVar]] eqTyCon
+\end{code}
+
+\begin{code}
 charTy :: Type
 charTy = mkTyConTy charTyCon
 
@@ -526,17 +607,17 @@ done by enumeration\srcloc{lib/prelude/InTup?.hs}.
 \end{itemize}
 
 \begin{code}
-mkTupleTy :: Boxity -> [Type] -> Type
+mkTupleTy :: TupleSort -> [Type] -> Type
 -- Special case for *boxed* 1-tuples, which are represented by the type itself
-mkTupleTy boxity [ty] | Boxed <- boxity = ty
-mkTupleTy boxity tys = mkTyConApp (tupleTyCon boxity (length tys)) tys
+mkTupleTy sort [ty] | Boxed <- tupleSortBoxity sort = ty
+mkTupleTy sort tys = mkTyConApp (tupleTyCon sort (length tys)) tys
 
 -- | Build the type of a small tuple that holds the specified type of thing
 mkBoxedTupleTy :: [Type] -> Type
-mkBoxedTupleTy tys = mkTupleTy Boxed tys
+mkBoxedTupleTy tys = mkTupleTy BoxedTuple tys
 
 unitTy :: Type
-unitTy = mkTupleTy Boxed []
+unitTy = mkTupleTy BoxedTuple []
 \end{code}
 
 %************************************************************************
diff --git a/compiler/prelude/TysWiredIn.lhs-boot b/compiler/prelude/TysWiredIn.lhs-boot
new file mode 100644 (file)
index 0000000..9740c0a
--- /dev/null
@@ -0,0 +1,10 @@
+\begin{code}
+module TysWiredIn where
+
+import {-# SOURCE #-} TyCon      (TyCon)
+import {-# SOURCE #-} TypeRep    (Type)
+
+
+eqTyCon :: TyCon
+mkBoxedTupleTy :: [Type] -> Type
+\end{code}
index 2737752..5fd0f1c 100644 (file)
@@ -28,7 +28,7 @@ import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )
 import HsSyn
 import RnHsSyn
 import TcRnMonad
-import RnTypes        ( rnHsSigType, rnLHsType, checkPrecMatch)
+import RnTypes        ( rnIPName, rnHsSigType, rnLHsType, checkPrecMatch )
 import RnPat          (rnPats, rnBindPat,
                        NameMaker, localRecNameMaker, topRecNameMaker, applyNameMaker
                       )
@@ -231,9 +231,9 @@ rnIPBinds (IPBinds ip_binds _no_dict_binds) = do
 
 rnIPBind :: IPBind RdrName -> RnM (IPBind Name, FreeVars)
 rnIPBind (IPBind n expr) = do
-    name <- newIPNameRn  n
+    n' <- rnIPName n
     (expr',fvExpr) <- rnLExpr expr
-    return (IPBind name expr', fvExpr)
+    return (IPBind n' expr', fvExpr)
 \end{code}
 
 
index 8faf6e3..cfdeab2 100644 (file)
@@ -17,7 +17,7 @@ module RnEnv (
        lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe,
        getLookupOccRn, addUsedRdrNames,
 
-       newLocalBndrRn, newLocalBndrsRn, newIPNameRn,
+       newLocalBndrRn, newLocalBndrsRn,
        bindLocalName, bindLocalNames, bindLocalNamesFV, 
        MiniFixityEnv, emptyFsEnv, extendFsEnv, lookupFsEnv,
        addLocalFixities,
@@ -36,7 +36,7 @@ module RnEnv (
 #include "HsVersions.h"
 
 import LoadIface       ( loadInterfaceForName, loadSrcInterface )
-import IfaceEnv                ( lookupOrig, newGlobalBinder, newIPName, updNameCache, extendNameCache )
+import IfaceEnv                ( lookupOrig, newGlobalBinder, updNameCache, extendNameCache )
 import HsSyn
 import RdrHsSyn                ( extractHsTyRdrTyVars )
 import RdrName
@@ -351,9 +351,6 @@ lookupSubBndrGREs env parent rdr_name
 
     parent_is p (GRE { gre_par = ParentIs p' }) = p == p'
     parent_is _ _                               = False
-
-newIPNameRn :: IPName RdrName -> TcRnIf m n (IPName Name)
-newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr)
 \end{code}
 
 Note [Looking up Exact RdrNames]
index 88e0462..8478db0 100644 (file)
@@ -27,7 +27,7 @@ import HsSyn
 import TcRnMonad
 import TcEnv           ( thRnBrack )
 import RnEnv
-import RnTypes         ( rnHsTypeFVs, rnSplice, checkTH,
+import RnTypes         ( rnHsTypeFVs, rnSplice, rnIPName, checkTH,
                          mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec)
 import RnPat
 import DynFlags
@@ -105,8 +105,8 @@ rnExpr (HsVar v)
        finishHsVar name
 
 rnExpr (HsIPVar v)
-  = newIPNameRn v              `thenM` \ name ->
-    return (HsIPVar name, emptyFVs)
+  = do v' <- rnIPName v
+       return (HsIPVar v', emptyFVs)
 
 rnExpr (HsLit lit@(HsString s))
   = do {
index bfbcdc5..79aaf6a 100644 (file)
@@ -8,7 +8,7 @@ module RnHsSyn(
         -- Names
         charTyCon_name, listTyCon_name, parrTyCon_name, tupleTyCon_name,
         extractHsTyVars, extractHsTyNames, extractHsTyNames_s,
-        extractFunDepNames, extractHsCtxtTyNames, extractHsPredTyNames,
+        extractFunDepNames, extractHsCtxtTyNames,
 
         -- Free variables
         hsSigsFVs, hsSigFVs, conDeclFVs, bangTyFVs
@@ -21,7 +21,7 @@ import Class            ( FunDep )
 import TysWiredIn       ( tupleTyCon, listTyCon, parrTyCon, charTyCon )
 import Name             ( Name, getName, isTyVarName )
 import NameSet
-import BasicTypes       ( Boxity )
+import BasicTypes       ( TupleSort )
 import SrcLoc
 \end{code}
 
@@ -39,8 +39,8 @@ charTyCon_name    = getName charTyCon
 listTyCon_name    = getName listTyCon
 parrTyCon_name    = getName parrTyCon
 
-tupleTyCon_name :: Boxity -> Int -> Name
-tupleTyCon_name boxity n = getName (tupleTyCon boxity n)
+tupleTyCon_name :: TupleSort -> Int -> Name
+tupleTyCon_name sort n = getName (tupleTyCon sort n)
 
 extractHsTyVars :: LHsType Name -> NameSet
 extractHsTyVars x = filterNameSet isTyVarName (extractHsTyNames x)
@@ -59,7 +59,8 @@ extractHsTyNames ty
     get (HsPArrTy ty)          = unitNameSet parrTyCon_name `unionNameSets` getl ty
     get (HsTupleTy _ tys)      = extractHsTyNames_s tys
     get (HsFunTy ty1 ty2)      = getl ty1 `unionNameSets` getl ty2
-    get (HsPredTy p)           = extractHsPredTyNames p
+    get (HsIParamTy _ ty)      = getl ty
+    get (HsEqTy ty1 ty2)       = getl ty1 `unionNameSets` getl ty2
     get (HsOpTy ty1 op ty2)    = getl ty1 `unionNameSets` getl ty2 `unionNameSets` unitNameSet (unLoc op)
     get (HsParTy ty)           = getl ty
     get (HsBangTy _ ty)        = getl ty
@@ -82,17 +83,7 @@ extractHsTyNames_s tys = foldr (unionNameSets . extractHsTyNames) emptyNameSet t
 
 extractHsCtxtTyNames :: LHsContext Name -> NameSet
 extractHsCtxtTyNames (L _ ctxt)
-  = foldr (unionNameSets . extractHsPredTyNames . unLoc) emptyNameSet ctxt
-
--- You don't import or export implicit parameters,
--- so don't mention the IP names
-extractHsPredTyNames :: HsPred Name -> NameSet
-extractHsPredTyNames (HsClassP cls tys)
-  = unitNameSet cls `unionNameSets` extractHsTyNames_s tys
-extractHsPredTyNames (HsEqualP ty1 ty2)
-  = extractHsTyNames ty1 `unionNameSets` extractHsTyNames ty2
-extractHsPredTyNames (HsIParam _ ty)
-  = extractHsTyNames ty
+  = foldr (unionNameSets . extractHsTyNames) emptyNameSet ctxt
 \end{code}
 
 
index 88113e4..ef842f2 100644 (file)
@@ -544,7 +544,7 @@ getLocalNonValBinders fixity_env
       = do { cls_nm <- setSrcSpan loc $ lookupGlobalOccRn cls_rdr
            ; mapM (new_ti (Just cls_nm)) ats }
       where
-        (_, _, L loc cls_rdr, _) = splitHsInstDeclTy inst_ty
+        Just (_, _, L loc cls_rdr, _) = splitLHsInstDeclTy_maybe inst_ty
 
 lookupTcdName :: Maybe Name -> TyClDecl RdrName -> RnM (Located Name)
 -- Used for TyData and TySynonym only
index 975969d..a6f619a 100644 (file)
@@ -155,15 +155,15 @@ matchNameMaker ctxt = LamMk report_unused
                       StmtCtxt GhciStmt -> False
                       _                 -> True
 
-newName :: NameMaker -> Located RdrName -> CpsRn Name
-newName (LamMk report_unused) rdr_name
+newPatName :: NameMaker -> Located RdrName -> CpsRn Name
+newPatName (LamMk report_unused) rdr_name
   = CpsRn (\ thing_inside -> 
        do { name <- newLocalBndrRn rdr_name
           ; (res, fvs) <- bindLocalName name (thing_inside name)
           ; when report_unused $ warnUnusedMatches [name] fvs
           ; return (res, name `delFV` fvs) })
 
-newName (LetMk is_top fix_env) rdr_name
+newPatName (LetMk is_top fix_env) rdr_name
   = CpsRn (\ thing_inside -> 
         do { name <- case is_top of
                        NotTopLevel -> newLocalBndrRn rdr_name
@@ -253,7 +253,7 @@ rnPat ctxt pat thing_inside
   = rnPats ctxt [pat] (\pats' -> let [pat'] = pats' in thing_inside pat')
 
 applyNameMaker :: NameMaker -> Located RdrName -> RnM Name
-applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newName mk rdr); return n }
+applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newPatName mk rdr); return n }
 
 -- ----------- Entry point 2: rnBindPat -------------------
 -- Binds local names; in a recursive scope that involves other bound vars
@@ -298,7 +298,7 @@ rnPatAndThen mk (ParPat pat)  = do { pat' <- rnLPatAndThen mk pat; return (ParPa
 rnPatAndThen mk (LazyPat pat) = do { pat' <- rnLPatAndThen mk pat; return (LazyPat pat') }
 rnPatAndThen mk (BangPat pat) = do { pat' <- rnLPatAndThen mk pat; return (BangPat pat') }
 rnPatAndThen mk (VarPat rdr)  = do { loc <- liftCps getSrcSpanM
-                                   ; name <- newName mk (L loc rdr)
+                                   ; name <- newPatName mk (L loc rdr)
                                    ; return (VarPat name) }
      -- we need to bind pattern variables for view pattern expressions
      -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple)
@@ -334,7 +334,7 @@ rnPatAndThen _ (NPat lit mb_neg _eq)
        ; return (NPat lit' mb_neg' eq') }
 
 rnPatAndThen mk (NPlusKPat rdr lit _ _)
-  = do { new_name <- newName mk rdr
+  = do { new_name <- newPatName mk rdr
        ; lit'  <- liftCpsFV $ rnOverLit lit
        ; minus <- liftCpsFV $ lookupSyntaxName minusName
        ; ge    <- liftCpsFV $ lookupSyntaxName geName
@@ -342,7 +342,7 @@ rnPatAndThen mk (NPlusKPat rdr lit _ _)
                -- The Report says that n+k patterns must be in Integral
 
 rnPatAndThen mk (AsPat rdr pat)
-  = do { new_name <- newName mk rdr
+  = do { new_name <- newPatName mk rdr
        ; pat' <- rnLPatAndThen mk pat
        ; return (AsPat (L (nameSrcSpan new_name) new_name) pat') }
 
index 2f01d7d..76b8146 100644 (file)
@@ -27,6 +27,7 @@ import RnNames        ( getLocalNonValBinders, extendGlobalRdrEnvRn, lookupTcdNa
 import HscTypes        ( AvailInfo(..) )
 import RnHsDoc          ( rnHsDoc, rnMbLHsDoc )
 import TcRnMonad
+import Kind             ( liftedTypeKind )
 
 import ForeignCall     ( CCallTarget(..) )
 import Module
@@ -42,7 +43,6 @@ import Util           ( filterOut )
 import SrcLoc
 import DynFlags
 import HscTypes                ( HscEnv, hsc_dflags )
-import BasicTypes       ( Boxity(..) )
 import ListSetOps       ( findDupsEq )
 import Digraph         ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices )
 
@@ -424,7 +424,7 @@ rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars)
 rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
        -- Used for both source and interface file decls
   = do { inst_ty' <- rnHsSigType (text "an instance decl") inst_ty
-       ; let (inst_tyvars, _, L _ cls, _) = splitHsInstDeclTy inst_ty'
+       ; let Just (inst_tyvars, _, L _ cls,_) = splitLHsInstDeclTy_maybe inst_ty'
 
        -- Rename the bindings
        -- The typechecker (not the renamer) checks that all 
@@ -991,7 +991,7 @@ rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
                        , con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' }) }}
  where
     doc = text "In the definition of data constructor" <+> quotes (ppr name)
-    get_rdr_tvs tys  = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))
+    get_rdr_tvs tys  = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy (HsBoxyTuple liftedTypeKind) tys))
 
 rnConResult :: SDoc
             -> HsConDetails (LHsType Name) [ConDeclField Name]
index 392e411..770ef28 100644 (file)
@@ -7,7 +7,8 @@
 module RnTypes ( 
        -- Type related stuff
        rnHsType, rnLHsType, rnLHsTypes, rnContext,
-       rnHsSigType, rnHsTypeFVs, rnConDeclFields, rnLPred,
+       rnHsSigType, rnHsTypeFVs, rnConDeclFields,
+        rnIPName,
 
        -- Precence related stuff
        mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
@@ -29,6 +30,7 @@ import RnHsSyn                ( extractHsTyNames )
 import RnHsDoc          ( rnLHsDoc, rnMbLHsDoc )
 import RnEnv
 import TcRnMonad
+import IfaceEnv         ( newIPName )
 import RdrName
 import PrelNames
 import TysPrim          ( funTyConName )
@@ -37,7 +39,7 @@ import SrcLoc
 import NameSet
 
 import Util            ( filterOut )
-import BasicTypes      ( compareFixity, funTyFixity, negateFixity, 
+import BasicTypes      ( IPName(..), ipNameName, compareFixity, funTyFixity, negateFixity, 
                          Fixity(..), FixityDirection(..) )
 import Outputable
 import FastString
@@ -172,9 +174,15 @@ rnHsType doc (HsAppTy ty1 ty2) = do
     ty2' <- rnLHsType doc ty2
     return (HsAppTy ty1' ty2')
 
-rnHsType doc (HsPredTy pred) = do
-    pred' <- rnPred doc pred
-    return (HsPredTy pred')
+rnHsType doc (HsIParamTy n ty) = do
+    ty' <- rnLHsType doc ty
+    n' <- rnIPName n
+    return (HsIParamTy n' ty')
+
+rnHsType doc (HsEqTy ty1 ty2) = do
+    ty1' <- rnLHsType doc ty1
+    ty2' <- rnLHsType doc ty2
+    return (HsEqTy ty1' ty2')
 
 rnHsType _ (HsSpliceTy sp _ k)
   = do { (sp', fvs) <- rnSplice sp     -- ToDo: deal with fvs
@@ -243,28 +251,10 @@ rnContext :: SDoc -> LHsContext RdrName -> RnM (LHsContext Name)
 rnContext doc = wrapLocM (rnContext' doc)
 
 rnContext' :: SDoc -> HsContext RdrName -> RnM (HsContext Name)
-rnContext' doc ctxt = mapM (rnLPred doc) ctxt
-
-rnLPred :: SDoc -> LHsPred RdrName -> RnM (LHsPred Name)
-rnLPred doc  = wrapLocM (rnPred doc)
-
-rnPred :: SDoc -> HsPred RdrName
-       -> IOEnv (Env TcGblEnv TcLclEnv) (HsPred Name)
-rnPred doc (HsClassP clas tys)
-  = do { clas_name <- lookupOccRn clas
-       ; tys' <- rnLHsTypes doc tys
-       ; return (HsClassP clas_name tys')
-       }
-rnPred doc (HsEqualP ty1 ty2)
-  = do { ty1' <- rnLHsType doc ty1
-       ; ty2' <- rnLHsType doc ty2
-       ; return (HsEqualP ty1' ty2')
-       }
-rnPred doc (HsIParam n ty)
-  = do { name <- newIPNameRn n
-       ; ty' <- rnLHsType doc ty
-       ; return (HsIParam name ty')
-       }
+rnContext' doc ctxt = mapM (rnLHsType doc) ctxt
+
+rnIPName :: IPName RdrName -> RnM (IPName Name)
+rnIPName n = newIPName (occNameFS (rdrNameOcc (ipNameName n)))
 \end{code}
 
 
index 3debe8e..cca940f 100644 (file)
@@ -1618,7 +1618,7 @@ argToPat env in_scope val_env (Cast arg co) arg_occ
        { -- Make a wild-card pattern for the coercion
          uniq <- getUniqueUs
        ; let co_name = mkSysTvName uniq (fsLit "sg")
-             co_var = mkCoVar co_name (mkCoType ty1 ty2)
+             co_var = mkCoVar co_name (mkCoercionType ty1 ty2)
        ; return (interesting, Cast arg' (mkCoVarCo co_var)) } }
   where
     Pair ty1 ty2 = coercionKind co
index ff536f5..68d023b 100644 (file)
@@ -1578,7 +1578,7 @@ mkCallUDs f args
     _trace_doc = vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts
                       , ppr (map interestingDict dicts)]
     (tyvars, theta, _) = tcSplitSigmaTy (idType f)
-    constrained_tyvars = tyVarsOfTheta theta 
+    constrained_tyvars = tyVarsOfTypes theta 
     n_tyvars          = length tyvars
     n_dicts           = length theta
 
index 7627ac9..223cb81 100644 (file)
@@ -24,7 +24,7 @@ import TysPrim                ( realWorldStatePrimTy )
 import TysWiredIn      ( tupleCon )
 import Type
 import Coercion         ( mkSymCo, splitNewTypeRepCo_maybe )
-import BasicTypes      ( Boxity(..) )
+import BasicTypes      ( TupleSort(..) )
 import Literal         ( absentLiteralOf )
 import UniqSupply
 import Unique
@@ -450,7 +450,7 @@ mkWWcpr body_ty RetCPR
       let
         (wrap_wild : work_wild : args) = zipWith mk_ww_local uniqs (ubx_tup_ty : body_ty : con_arg_tys)
        arg_vars                       = varsToCoreExprs args
-       ubx_tup_con                    = tupleCon Unboxed n_con_args
+       ubx_tup_con                    = tupleCon UnboxedTuple n_con_args
        ubx_tup_ty                     = exprType ubx_tup_app
        ubx_tup_app                    = mkConApp ubx_tup_con (map Type con_arg_tys   ++ arg_vars)
         con_app                               = mkProductBox args body_ty
index 028f339..1690079 100644 (file)
@@ -43,13 +43,14 @@ import TcEnv
 import InstEnv
 import FunDeps
 import TcMType
+import Type
 import TcType
 import Class
 import Unify
 import HscTypes
 import Id
 import Name
-import Var      ( Var, TyVar, EvVar, varType, setVarType )
+import Var      ( Var, EvVar, varType, setVarType )
 import VarEnv
 import VarSet
 import PrelNames
@@ -209,13 +210,14 @@ instCallConstraints :: CtOrigin -> TcThetaType -> TcM HsWrapper
 
 instCallConstraints _ [] = return idHsWrapper
 
-instCallConstraints origin (EqPred ty1 ty2 : preds)    -- Try short-cut
-  = do  { traceTc "instCallConstraints" $ ppr (EqPred ty1 ty2)
-        ; co    <- unifyType ty1 ty2
+instCallConstraints origin (pred : preds)
+  | Just (ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut
+  = do  { traceTc "instCallConstraints" $ ppr (mkEqPred (ty1, ty2))
+        ; co <- unifyType ty1 ty2
        ; co_fn <- instCallConstraints origin preds
-        ; return (co_fn <.> WpEvApp (EvCoercion co)) }
+        ; return (co_fn <.> WpEvApp (EvCoercionBox co)) }
 
-instCallConstraints origin (pred : preds)
+  | otherwise
   = do { ev_var <- emitWanted origin pred
        ; co_fn <- instCallConstraints origin preds
        ; return (co_fn <.> WpEvApp (EvId ev_var)) }
@@ -485,9 +487,13 @@ hasEqualities :: [EvVar] -> Bool
 -- Has a bunch of canonical constraints (all givens) got any equalities in it?
 hasEqualities givens = any (has_eq . evVarPred) givens
   where
-    has_eq (EqPred {})              = True
-    has_eq (IParam {})              = False
-    has_eq (ClassP cls _tys) = any has_eq (classSCTheta cls)
+    has_eq = has_eq' . predTypePredTree
+
+    has_eq' (EqPred {})          = True
+    has_eq' (IPPred {})          = False
+    has_eq' (ClassPred cls _tys) = any has_eq (classSCTheta cls)
+    has_eq' (TuplePred ts)       = any has_eq' ts
+    has_eq' (IrredPred _)        = True -- Might have equalities in it after reduction?
 
 ---------------- Getting free tyvars -------------------------
 tyVarsOfWC :: WantedConstraints -> TyVarSet
@@ -507,7 +513,7 @@ tyVarsOfEvVarXs :: Bag (EvVarX a) -> TyVarSet
 tyVarsOfEvVarXs = tyVarsOfBag tyVarsOfEvVarX
 
 tyVarsOfEvVar :: EvVar -> TyVarSet
-tyVarsOfEvVar ev = tyVarsOfPred $ evVarPred ev
+tyVarsOfEvVar ev = tyVarsOfType $ evVarPred ev
 
 tyVarsOfEvVars :: [EvVar] -> TyVarSet
 tyVarsOfEvVars = foldr (unionVarSet . tyVarsOfEvVar) emptyVarSet
index 7ce5fc1..774cea5 100644 (file)
@@ -43,17 +43,17 @@ import Control.Monad
 \begin{code}
 tcProc :: InPat Name -> LHsCmdTop Name         -- proc pat -> expr
        -> TcRhoType                            -- Expected type of whole proc expression
-       -> TcM (OutPat TcId, LHsCmdTop TcId, Coercion)
+       -> TcM (OutPat TcId, LHsCmdTop TcId, LCoercion)
 
 tcProc pat cmd exp_ty
   = newArrowScope $
-    do { (coi, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty 
-       ; (coi1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1
+    do { (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty 
+       ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1
        ; let cmd_env = CmdEnv { cmd_arr = arr_ty }
         ; (pat', cmd') <- tcPat ProcExpr pat arg_ty $
                          tcCmdTop cmd_env cmd [] res_ty
-        ; let res_coi = mkTransCo coi (mkAppCo coi1 (mkReflCo res_ty))
-        ; return (pat', cmd', res_coi) }
+        ; let res_co = mkTransCo co (mkAppCo co1 (mkReflCo res_ty))
+        ; return (pat', cmd', res_co) }
 \end{code}
 
 
index 3597ebf..fa292a6 100644 (file)
@@ -459,7 +459,7 @@ mkExport prag_fn qtvs theta (poly_name, mb_sig, mono_id)
   = do  { mono_ty <- zonkTcTypeCarefully (idType mono_id)
         ; let inferred_poly_ty = mkSigmaTy my_tvs theta mono_ty
               my_tvs   = filter (`elemVarSet` used_tvs) qtvs
-              used_tvs = tyVarsOfTheta theta `unionVarSet` tyVarsOfType mono_ty
+              used_tvs = tyVarsOfTypes theta `unionVarSet` tyVarsOfType mono_ty
 
               poly_id  = case mb_sig of
                            Nothing  -> mkLocalId poly_name inferred_poly_ty
@@ -919,7 +919,7 @@ unifyCtxts (sig1 : sigs)
     unify_ctxt sig@(TcSigInfo { sig_theta = theta })
         = setSrcSpan (sig_loc sig)                      $
           addErrCtxt (sigContextsCtxt sig1 sig)         $
-          do { cois <- unifyTheta theta1 theta
+          do { mk_cos <- unifyTheta theta1 theta
              ; -- Check whether all coercions are identity coercions
                -- That can happen if we have, say
                --         f :: C [a]   => ...
@@ -927,7 +927,7 @@ unifyCtxts (sig1 : sigs)
                -- where F is a type function and (F a ~ [a])
                -- Then unification might succeed with a coercion.  But it's much
                -- much simpler to require that such signatures have identical contexts
-               checkTc (all isReflCo cois)
+               checkTc (isReflMkCos mk_cos)
                        (ptext (sLit "Mutually dependent functions have syntactically distinct contexts"))
              }
 
index a18ddb3..0bf1169 100644 (file)
@@ -22,7 +22,7 @@ import Name
 import Var
 import VarEnv          ( TidyEnv )
 import Outputable
-import Control.Monad    ( unless, when, zipWithM, zipWithM_, foldM )
+import Control.Monad    ( unless, when, zipWithM, zipWithM_, foldM, liftM, forM )
 import MonadUtils
 import Control.Applicative ( (<|>) )
 
@@ -96,7 +96,7 @@ multiple times.
 \begin{code}
 
 -- Flatten a bunch of types all at once.
-flattenMany :: CtFlavor -> [Type] -> TcS ([Xi], [Coercion], CanonicalCts)
+flattenMany :: CtFlavor -> [Type] -> TcS ([Xi], [LCoercion], CanonicalCts)
 -- Coercions :: Xi ~ Type 
 flattenMany ctxt tys 
   = do { (xis, cos, cts_s) <- mapAndUnzip3M (flatten ctxt) tys
@@ -105,15 +105,16 @@ flattenMany ctxt tys
 -- Flatten a type to get rid of type function applications, returning
 -- the new type-function-free type, and a collection of new equality
 -- constraints.  See Note [Flattening] for more detail.
-flatten :: CtFlavor -> TcType -> TcS (Xi, Coercion, CanonicalCts)
--- Postcondition: Coercion :: Xi ~ TcType 
+flatten :: CtFlavor -> TcType -> TcS (Xi, LCoercion, CanonicalCts)
+-- Postcondition: Coercion :: Xi ~ TcType
+-- Postcondition: CanonicalCts are all CFunEqCan
 flatten ctxt ty 
   | Just ty' <- tcView ty
   = do { (xi, co, ccs) <- flatten ctxt ty'
        -- Preserve type synonyms if possible
        -- We can tell if ty' is function-free by
        -- whether there are any floated constraints
-        ; if isReflCo co then
+       ; if isReflCo co then
              return (ty, mkReflCo ty, emptyCCan)
          else
              return (xi, co, ccs) }
@@ -145,50 +146,44 @@ flatten fl (TyConApp tc tys)
   = ASSERT( tyConArity tc <= length tys )      -- Type functions are saturated
       do { (xis, cos, ccs) <- flattenMany fl tys
          ; let (xi_args, xi_rest)  = splitAt (tyConArity tc) xis
-               (cos_args, cos_rest) = splitAt (tyConArity tc) cos 
                 -- The type function might be *over* saturated
                 -- in which case the remaining arguments should
                 -- be dealt with by AppTys
                fam_ty = mkTyConApp tc xi_args
-         ; (ret_co, rhs_var, ct) <-
+         ; (ret_eqv, rhs_var, ct) <-
              do { is_cached <- lookupFlatCacheMap tc xi_args fl 
                 ; case is_cached of 
-                    Just (rhs_var,ret_co,_fl) -> return (ret_co, rhs_var, emptyCCan)
+                    Just (rhs_var,ret_eqv,_fl) -> return (ret_eqv, rhs_var, emptyCCan)
                     Nothing
                         | isGivenOrSolved fl ->
                             do { rhs_var <- newFlattenSkolemTy fam_ty
-                               ; cv <- newGivenCoVar fam_ty rhs_var (mkReflCo fam_ty)
-                               ; let ct = CFunEqCan { cc_id     = cv
+                               ; eqv <- newGivenEqVar fam_ty rhs_var (mkReflCo fam_ty)
+                               ; let ct = CFunEqCan { cc_id     = eqv
                                                     , cc_flavor = fl -- Given
                                                     , cc_fun    = tc 
                                                     , cc_tyargs = xi_args 
                                                     , cc_rhs    = rhs_var }
-                               ; let ret_co = mkCoVarCo cv 
-                               ; updateFlatCacheMap tc xi_args rhs_var fl ret_co 
-                               ; return $ (ret_co, rhs_var, singleCCan ct) }
+                               ; updateFlatCacheMap tc xi_args rhs_var fl eqv 
+                               ; return (eqv, rhs_var, singleCCan ct) }
                         | otherwise ->
                     -- Derived or Wanted: make a new *unification* flatten variable
                             do { rhs_var <- newFlexiTcSTy (typeKind fam_ty)
-                               ; cv <- newCoVar fam_ty rhs_var
-                               ; let ct = CFunEqCan { cc_id = cv
+                               ; eqv <- newEqVar fam_ty rhs_var
+                               ; let ct = CFunEqCan { cc_id = eqv
                                                     , cc_flavor = mkWantedFlavor fl
                                                     -- Always Wanted, not Derived
                                                     , cc_fun = tc
                                                     , cc_tyargs = xi_args
                                                     , cc_rhs    = rhs_var }
-                               ; let ret_co = mkCoVarCo cv
-                               ; updateFlatCacheMap tc xi_args rhs_var fl ret_co
-                               ; return $ (ret_co, rhs_var, singleCCan ct) } }
+                               ; updateFlatCacheMap tc xi_args rhs_var fl eqv
+                               ; return (eqv, rhs_var, singleCCan ct) } }
+         ; let ret_co = mkEqVarLCo ret_eqv
+               (cos_args, cos_rest) = splitAt (tyConArity tc) cos
          ; return ( foldl AppTy rhs_var xi_rest
-                  , foldl AppCo (mkSymCo ret_co 
-                                   `mkTransCo` mkTyConAppCo tc cos_args) 
+                  , foldl AppCo (mkSymCo ret_co `mkTransCo` mkTyConAppCo tc cos_args)
                                 cos_rest
                   , ccs `andCCan` ct) }
 
-flatten ctxt (PredTy pred) 
-  = do { (pred', co, ccs) <- flattenPred ctxt pred
-       ; return (PredTy pred', co, ccs) }
-
 flatten ctxt ty@(ForAllTy {})
 -- We allow for-alls when, but only when, no type function
 -- applications inside the forall involve the bound type variables
@@ -202,19 +197,6 @@ flatten ctxt ty@(ForAllTy {})
        ; unless (isEmptyBag bad_eqs)
                 (flattenForAllErrorTcS ctxt ty bad_eqs)
        ; return (mkForAllTys tvs rho', foldr mkForAllCo co tvs, ccs)  }
-
----------------
-flattenPred :: CtFlavor -> TcPredType -> TcS (TcPredType, Coercion, CanonicalCts)
-flattenPred ctxt (ClassP cls tys)
-  = do { (tys', cos, ccs) <- flattenMany ctxt tys
-       ; return (ClassP cls tys', mkPredCo $ ClassP cls cos, ccs) }
-flattenPred ctxt (IParam nm ty)
-  = do { (ty', co, ccs) <- flatten ctxt ty
-       ; return (IParam nm ty', mkPredCo $ IParam nm co, ccs) }
-flattenPred ctxt (EqPred ty1 ty2)
-  = do { (ty1', co1, ccs1) <- flatten ctxt ty1
-       ; (ty2', co2, ccs2) <- flatten ctxt ty2
-       ; return (EqPred ty1' ty2', mkPredCo $ EqPred co1 co2, ccs1 `andCCan` ccs2) }
 \end{code}
 
 %************************************************************************
@@ -244,13 +226,29 @@ mkCanonicalFEVs = foldrBagM canon_one emptyWorkList
     canon_one fev wl = do { wl' <- mkCanonicalFEV fev
                           ; return (unionWorkList wl' wl) }
 
-
 mkCanonical :: CtFlavor -> EvVar -> TcS WorkList
-mkCanonical fl ev = case evVarPred ev of 
-                        ClassP clas tys -> canClassToWorkList fl ev clas tys 
-                        IParam ip ty    -> canIPToWorkList    fl ev ip ty 
-                        EqPred ty1 ty2  -> canEqToWorkList    fl ev ty1 ty2 
-                         
+mkCanonical fl ev = go ev (predTypePredTree (evVarPred ev))
+  where
+    go ev (ClassPred clas tys) = canClassToWorkList fl ev clas tys
+    go ev (EqPred ty1 ty2)     = canEqToWorkList    fl ev ty1 ty2
+    go ev (IPPred ip ty)       = canIPToWorkList    fl ev ip ty
+    go ev (TuplePred tys)      = do
+      (mb_evs', wlists) <- liftM unzip $ forM (tys `zip` [0..]) $ \(ty, n) -> do
+        ev' <- newEvVar (predTreePredType ty)
+        mb_ev <- case fl of 
+           Wanted {}  -> return (Just ev')
+           Given {}   -> setEvBind ev' (EvTupleSel ev n) >> return Nothing
+           Derived {} -> return Nothing -- Derived ips: we don't set any evidence
+
+        liftM ((,) mb_ev) $ go ev' ty
+
+      -- If we Wanted this TuplePred we have to bind it from the newly Wanted components
+      case sequence mb_evs' of
+        Just evs' -> setEvBind ev (EvTupleMk evs')
+        Nothing   -> return ()
+      
+      return (unionWorkLists wlists)
+    go ev (IrredPred ev_ty)    = canIrredEvidence fl ev ev_ty
 
 canClassToWorkList :: CtFlavor -> EvVar -> Class -> [TcType] -> TcS WorkList
 canClassToWorkList fl v cn tys 
@@ -262,8 +260,8 @@ canClassToWorkList fl v cn tys
                          -- The cos are all identities if fl=Given,
                          -- hence nothing to do
                   else do { v' <- newDictVar cn xis  -- D xis
-                          ; when (isWanted fl) $ setDictBind v  (EvCast v' dict_co)
-                          ; when (isGivenOrSolved fl) $ setDictBind v' (EvCast v (mkSymCo dict_co))
+                          ; when (isWanted fl) $ setEvBind v (EvCast v' dict_co)
+                          ; when (isGivenOrSolved fl) $ setEvBind v' (EvCast v (mkSymCo dict_co))
                                  -- NB: No more setting evidence for derived now 
                           ; return v' }
 
@@ -348,15 +346,14 @@ happen.
 
 newSCWorkFromFlavored :: EvVar -> CtFlavor -> Class -> [Xi] -> TcS WorkList
 -- Returns superclasses, see Note [Adding superclasses]
-newSCWorkFromFlavored ev orig_flavor cls xis 
-  | isDerived orig_flavor 
+newSCWorkFromFlavored ev flavor cls xis 
+  | isDerived flavor 
   = return emptyWorkList  -- Deriveds don't yield more superclasses because we will
                           -- add them transitively in the case of wanteds. 
 
-  | Just gk <- isGiven_maybe orig_flavor 
+  | Just gk <- isGiven_maybe flavor 
   = case gk of 
       GivenOrig -> do { let sc_theta = immSuperClasses cls xis 
-                            flavor   = orig_flavor
                       ; sc_vars <- mapM newEvVar sc_theta
                       ; _ <- zipWithM_ setEvBind sc_vars [EvSuperClass ev n | n <- [0..]]
                       ; mkCanonicals flavor sc_vars }
@@ -371,17 +368,21 @@ newSCWorkFromFlavored ev orig_flavor cls xis
   | otherwise -- Wanted case, just add those SC that can lead to improvement. 
   = do { let sc_rec_theta = transSuperClasses cls xis 
              impr_theta   = filter is_improvement_pty sc_rec_theta 
-             Wanted wloc  = orig_flavor
+             Wanted wloc  = flavor
        ; der_ids <- mapM newDerivedId impr_theta
        ; mkCanonicals (Derived wloc) der_ids }
 
 
 is_improvement_pty :: PredType -> Bool 
 -- Either it's an equality, or has some functional dependency
-is_improvement_pty (EqPred {})      = True 
-is_improvement_pty (ClassP cls _ty) = not $ null fundeps
- where (_,fundeps,_,_,_,_) = classExtraBigSig cls
-is_improvement_pty _ = False
+is_improvement_pty ty = go (predTypePredTree ty)
+  where
+    go (EqPred {})         = True 
+    go (ClassPred cls _ty) = not $ null fundeps
+      where (_,fundeps,_,_,_,_) = classExtraBigSig cls
+    go (IPPred {})         = False
+    go (TuplePred ts)      = any go ts
+    go (IrredPred {})      = True -- Might have equalities after reduction?
 
 
 
@@ -395,103 +396,121 @@ canIPToWorkList fl v nm ty
                                       , cc_ip_nm = nm
                                       , cc_ip_ty = ty })
 
+canIrredEvidence :: CtFlavor -> EvVar -> TcType -> TcS WorkList
+canIrredEvidence fl v ty = do
+    (xi, co, ccs) <- flatten fl ty -- co :: xi ~ ty
+    v' <- newEvVar xi
+    case fl of 
+        Wanted {}         -> setEvBind v  (EvCast v' co)
+        Given {}          -> setEvBind v' (EvCast v (mkSymCo co))
+        Derived {}        -> return () -- Derived ips: we don't set any evidence
+    
+    return (workListFromEqs ccs `unionWorkList`
+            workListFromNonEq (CIrredEvCan { cc_id = v'
+                                           , cc_flavor = fl
+                                           , cc_ty = xi }))
+
 -----------------
 canEqToWorkList :: CtFlavor -> EvVar -> Type -> Type -> TcS WorkList
-canEqToWorkList fl cv ty1 ty2 = do { cts <- canEq fl cv ty1 ty2 
-                         ; return $ workListFromEqs cts }
+canEqToWorkList fl eqv ty1 ty2 = do { cts <- canEq fl eqv ty1 ty2 
+                                   ; return $ workListFromEqs cts }
 
-canEq :: CtFlavor -> EvVar -> Type -> Type -> TcS CanonicalCts 
-canEq fl cv ty1 ty2 
+canEq :: CtFlavor -> EqVar -> Type -> Type -> TcS CanonicalCts 
+canEq fl eqv ty1 ty2
   | eqType ty1 ty2     -- Dealing with equality here avoids
                        -- later spurious occurs checks for a~a
-  = do { when (isWanted fl) (setCoBind cv (mkReflCo ty1))
+  = do { when (isWanted fl) (setEqBind eqv (mkReflCo ty1))
        ; return emptyCCan }
 
 -- If one side is a variable, orient and flatten, 
 -- WITHOUT expanding type synonyms, so that we tend to 
 -- substitute a ~ Age rather than a ~ Int when @type Age = Int@
-canEq fl cv ty1@(TyVarTy {}) ty2 
+canEq fl eqv ty1@(TyVarTy {}) ty2 
   = do { untch <- getUntouchables 
-       ; canEqLeaf untch fl cv (classify ty1) (classify ty2) }
-canEq fl cv ty1 ty2@(TyVarTy {}) 
+       ; canEqLeaf untch fl eqv (classify ty1) (classify ty2) }
+canEq fl eqv ty1 ty2@(TyVarTy {}) 
   = do { untch <- getUntouchables 
-       ; canEqLeaf untch fl cv (classify ty1) (classify ty2) }
+       ; canEqLeaf untch fl eqv (classify ty1) (classify ty2) }
       -- NB: don't use VarCls directly because tv1 or tv2 may be scolems!
 
 -- Split up an equality between function types into two equalities.
-canEq fl cv (FunTy s1 t1) (FunTy s2 t2)
-  = do { (argv, resv) <- 
+canEq fl eqv (FunTy s1 t1) (FunTy s2 t2)
+  = do { (argeqv, reseqv) <- 
              if isWanted fl then 
-                 do { argv <- newCoVar s1 s2 
-                    ; resv <- newCoVar t1 t2 
-                    ; setCoBind cv $ 
-                      mkFunCo (mkCoVarCo argv) (mkCoVarCo resv) 
-                    ; return (argv,resv) } 
+                 do { argeqv <- newEqVar s1 s2 
+                    ; reseqv <- newEqVar t1 t2 
+                    ; setEqBind eqv
+                      (mkFunCo (mkEqVarLCo argeqv) (mkEqVarLCo reseqv))
+                    ; return (argeqv,reseqv) } 
              else if isGivenOrSolved fl then 
-                      let [arg,res] = decomposeCo 2 (mkCoVarCo cv) 
-                      in do { argv <- newGivenCoVar s1 s2 arg 
-                            ; resv <- newGivenCoVar t1 t2 res
-                            ; return (argv,resv) } 
+                      do { argeqv <- newEqVar s1 s2
+                         ; setEqBind argeqv (mkNthCo 0 (mkEqVarLCo eqv))
+                         ; reseqv <- newEqVar t1 t2
+                         ; setEqBind reseqv (mkNthCo 1 (mkEqVarLCo eqv))
+                         ; return (argeqv,reseqv) } 
 
              else -- Derived 
-                 do { argv <- newDerivedId (EqPred s1 s2)
-                    ; resv <- newDerivedId (EqPred t1 t2)
-                    ; return (argv,resv) }
+                 do { argeqv <- newDerivedId (mkEqPred (s1, s2))
+                    ; reseqv <- newDerivedId (mkEqPred (t1, t2))
+                    ; return (argeqv, reseqv) }
 
-       ; cc1 <- canEq fl argv s1 s2 -- inherit original kinds and locations
-       ; cc2 <- canEq fl resv t1 t2
+       ; cc1 <- canEq fl argeqv s1 s2 -- inherit original kinds and locations
+       ; cc2 <- canEq fl reseqv t1 t2
        ; return (cc1 `andCCan` cc2) }
 
-canEq fl cv (TyConApp fn tys) ty2 
+canEq fl eqv (TyConApp fn tys) ty2 
   | isSynFamilyTyCon fn, length tys == tyConArity fn
   = do { untch <- getUntouchables 
-       ; canEqLeaf untch fl cv (FunCls fn tys) (classify ty2) }
-canEq fl cv ty1 (TyConApp fn tys)
+       ; canEqLeaf untch fl eqv (FunCls fn tys) (classify ty2) }
+canEq fl eqv ty1 (TyConApp fn tys)
   | isSynFamilyTyCon fn, length tys == tyConArity fn
   = do { untch <- getUntouchables 
-       ; canEqLeaf untch fl cv (classify ty1) (FunCls fn tys) }
+       ; canEqLeaf untch fl eqv (classify ty1) (FunCls fn tys) }
 
-canEq fl cv (TyConApp tc1 tys1) (TyConApp tc2 tys2)
+canEq fl eqv (TyConApp tc1 tys1) (TyConApp tc2 tys2)
   | isDecomposableTyCon tc1 && isDecomposableTyCon tc2
   , tc1 == tc2
   , length tys1 == length tys2
   = -- Generate equalities for each of the corresponding arguments
-    do { argsv 
+    do { argeqvs 
              <- if isWanted fl then
-                    do { argsv <- zipWithM newCoVar tys1 tys2
-                       ; setCoBind cv $ 
-                         mkTyConAppCo tc1 (map mkCoVarCo argsv)
-                       ; return argsv }
+                    do { argeqvs <- zipWithM newEqVar tys1 tys2
+                       ; setEqBind eqv
+                         (mkTyConAppCo tc1 (map mkEqVarLCo argeqvs))
+                       ; return argeqvs }
                 else if isGivenOrSolved fl then
-                    let cos = decomposeCo (length tys1) (mkCoVarCo cv)
-                    in zipWith3M newGivenCoVar tys1 tys2 cos
+                    let go_one ty1 ty2 n = do
+                          argeqv <- newEqVar ty1 ty2
+                          setEqBind argeqv (mkNthCo n (mkEqVarLCo eqv))
+                          return argeqv
+                    in zipWith3M go_one tys1 tys2 [0..]
 
                 else -- Derived 
-                    zipWithM (\t1 t2 -> newDerivedId (EqPred t1 t2)) tys1 tys2
+                    zipWithM (\t1 t2 -> newDerivedId (mkEqPred (t1, t2))) tys1 tys2
 
-       ; andCCans <$> zipWith3M (canEq fl) argsv tys1 tys2 }
+       ; andCCans <$> zipWith3M (canEq fl) argeqvs tys1 tys2 }
 
 -- See Note [Equality between type applications]
 --     Note [Care with type applications] in TcUnify
-canEq fl cv ty1 ty2
+canEq fl eqv ty1 ty2
   | Nothing <- tcView ty1  -- Naked applications ONLY
   , Nothing <- tcView ty2  -- See Note [Naked given applications]
   , Just (s1,t1) <- tcSplitAppTy_maybe ty1
   , Just (s2,t2) <- tcSplitAppTy_maybe ty2
     = if isWanted fl 
-      then do { cv1 <- newCoVar s1 s2 
-              ; cv2 <- newCoVar t1 t2 
-              ; setCoBind cv $ 
-                mkAppCo (mkCoVarCo cv1) (mkCoVarCo cv2) 
-              ; cc1 <- canEq fl cv1 s1 s2 
-              ; cc2 <- canEq fl cv2 t1 t2 
+      then do { eqv1 <- newEqVar s1 s2 
+              ; eqv2 <- newEqVar t1 t2 
+              ; setEqBind eqv
+                (mkAppCo (mkEqVarLCo eqv1) (mkEqVarLCo eqv2))
+              ; cc1 <- canEq fl eqv1 s1 s2 
+              ; cc2 <- canEq fl eqv2 t1 t2 
               ; return (cc1 `andCCan` cc2) } 
 
       else if isDerived fl 
-      then do { cv1 <- newDerivedId (EqPred s1 s2)
-              ; cv2 <- newDerivedId (EqPred t1 t2)
-              ; cc1 <- canEq fl cv1 s1 s2 
-              ; cc2 <- canEq fl cv2 t1 t2 
+      then do { eqv1 <- newDerivedId (mkEqPred (s1, s2))
+              ; eqv2 <- newDerivedId (mkEqPred (t1, t2))
+              ; cc1 <- canEq fl eqv1 s1 s2 
+              ; cc2 <- canEq fl eqv2 t1 t2 
               ; return (cc1 `andCCan` cc2) } 
       
       else do { traceTcS "canEq/(app case)" $
@@ -501,21 +520,21 @@ canEq fl cv ty1 ty2
                                    -- because we no longer have 'left' and 'right'
               }
 
-canEq fl cv s1@(ForAllTy {}) s2@(ForAllTy {})
+canEq fl eqv s1@(ForAllTy {}) s2@(ForAllTy {})
  | tcIsForAllTy s1, tcIsForAllTy s2, 
    Wanted {} <- fl 
- = canEqFailure fl cv
+ = canEqFailure fl eqv
  | otherwise
  = do { traceTcS "Ommitting decomposition of given polytype equality" (pprEq s1 s2)
       ; return emptyCCan }
 
 -- Finally expand any type synonym applications.
-canEq fl cv ty1 ty2 | Just ty1' <- tcView ty1 = canEq fl cv ty1' ty2
-canEq fl cv ty1 ty2 | Just ty2' <- tcView ty2 = canEq fl cv ty1 ty2'
-canEq fl cv _ _                               = canEqFailure fl cv
+canEq fl eqv ty1 ty2 | Just ty1' <- tcView ty1 = canEq fl eqv ty1' ty2
+canEq fl eqv ty1 ty2 | Just ty2' <- tcView ty2 = canEq fl eqv ty1 ty2'
+canEq fl eqv _ _                               = canEqFailure fl eqv
 
 canEqFailure :: CtFlavor -> EvVar -> TcS CanonicalCts
-canEqFailure fl cv = return (singleCCan (mkFrozenError fl cv))
+canEqFailure fl eqv = return (singleCCan (mkFrozenError fl eqv))
 \end{code}
 
 Note [Naked given applications]
@@ -709,7 +728,7 @@ reOrient _fl (FskCls {}) (OtherCls {})   = False
 
 ------------------
 canEqLeaf :: TcsUntouchables 
-          -> CtFlavor -> CoVar 
+          -> CtFlavor -> EqVar 
           -> TypeClassifier -> TypeClassifier -> TcS CanonicalCts 
 -- Canonicalizing "leaf" equality constraints which cannot be
 -- decomposed further (ie one of the types is a variable or
@@ -718,35 +737,38 @@ canEqLeaf :: TcsUntouchables
   -- Preconditions: 
   --    * one of the two arguments is not OtherCls
   --    * the two types are not equal (looking through synonyms)
-canEqLeaf _untch fl cv cls1 cls2 
+canEqLeaf _untch fl eqv cls1 cls2 
   | cls1 `re_orient` cls2
-  = do { cv' <- if isWanted fl 
-                then do { cv' <- newCoVar s2 s1 
-                        ; setCoBind cv $ mkSymCo (mkCoVarCo cv') 
-                        ; return cv' } 
-                else if isGivenOrSolved fl then
-                         newGivenCoVar s2 s1 (mkSymCo (mkCoVarCo cv))
-                else -- Derived
-                    newDerivedId (EqPred s2 s1)
-       ; canEqLeafOriented fl cv' cls2 s1 }
+  = do { eqv' <- if isWanted fl 
+                 then do { eqv' <- newEqVar s2 s1
+                         ; setEqBind eqv (mkSymCo (mkEqVarLCo eqv'))
+                         ; return eqv' } 
+                 else if isGivenOrSolved fl then
+                      do { eqv' <- newEqVar s2 s1
+                         ; setEqBind eqv' (mkSymCo (mkEqVarLCo eqv))
+                         ; return eqv' }
+                          
+                 else -- Derived
+                     newDerivedId (mkEqPred (s2, s1))
+       ; canEqLeafOriented fl eqv' cls2 s1 }
 
   | otherwise
   = do { traceTcS "canEqLeaf" (ppr (unClassify cls1) $$ ppr (unClassify cls2))
-       ; canEqLeafOriented fl cv cls1 s2 }
+       ; canEqLeafOriented fl eqv cls1 s2 }
   where
     re_orient = reOrient fl 
     s1 = unClassify cls1  
     s2 = unClassify cls2  
 
 ------------------
-canEqLeafOriented :: CtFlavor -> CoVar 
+canEqLeafOriented :: CtFlavor -> EqVar 
                   -> TypeClassifier -> TcType -> TcS CanonicalCts 
 -- First argument is not OtherCls
-canEqLeafOriented fl cv cls1@(FunCls fn tys1) s2         -- cv : F tys1
+canEqLeafOriented fl eqv cls1@(FunCls fn tys1) s2         -- cv : F tys1
   | let k1 = kindAppResult (tyConKind fn) tys1,
     let k2 = typeKind s2, 
     not (k1 `compatKind` k2) -- Establish the kind invariant for CFunEqCan
-  = canEqFailure fl cv
+  = canEqFailure fl eqv
     -- Eagerly fails, see Note [Kind errors] in TcInteract
 
   | otherwise 
@@ -757,23 +779,25 @@ canEqLeafOriented fl cv cls1@(FunCls fn tys1) s2         -- cv : F tys1
                                                  -- co2  :: xi2 ~ s2
        ; let ccs = ccs1 `andCCan` ccs2
              no_flattening_happened = all isReflCo (co2:cos1)
-       ; cv_new <- if no_flattening_happened  then return cv
-                   else if isGivenOrSolved fl then return cv
-                   else if isWanted fl then 
-                         do { cv' <- newCoVar (unClassify (FunCls fn xis1)) xi2
-                                 -- cv' : F xis ~ xi2
-                            ; let -- fun_co :: F xis1 ~ F tys1
-                                 fun_co = mkTyConAppCo fn cos1
-                                 -- want_co :: F tys1 ~ s2
-                                 want_co = mkSymCo fun_co
-                                           `mkTransCo` mkCoVarCo cv'
-                                           `mkTransCo` co2
-                            ; setCoBind cv  want_co
-                            ; return cv' }
-                   else -- Derived 
-                       newDerivedId (EqPred (unClassify (FunCls fn xis1)) xi2)
-
-       ; let final_cc = CFunEqCan { cc_id     = cv_new
+       ; eqv_new <- if no_flattening_happened  then return eqv
+                    else if isGivenOrSolved fl then return eqv
+                    else if isWanted fl then 
+                          do { eqv' <- newEqVar (unClassify (FunCls fn xis1)) xi2
+
+                             ; let -- cv' : F xis ~ xi2
+                                   cv' = mkEqVarLCo eqv'
+                                   -- fun_co :: F xis1 ~ F tys1
+                                   fun_co = mkTyConAppCo fn cos1
+                                   -- want_co :: F tys1 ~ s2
+                                   want_co = mkSymCo fun_co
+                                                `mkTransCo` cv'
+                                                `mkTransCo` co2
+                             ; setEqBind eqv want_co
+                             ; return eqv' }
+                    else -- Derived 
+                        newDerivedId (mkEqPred (unClassify (FunCls fn xis1), xi2))
+
+       ; let final_cc = CFunEqCan { cc_id     = eqv_new
                                   , cc_flavor = fl
                                   , cc_fun    = fn
                                   , cc_tyargs = xis1 
@@ -781,18 +805,18 @@ canEqLeafOriented fl cv cls1@(FunCls fn tys1) s2         -- cv : F tys1
        ; return $ ccs `extendCCans` final_cc }
 
 -- Otherwise, we have a variable on the left, so call canEqLeafTyVarLeft
-canEqLeafOriented fl cv (FskCls tv) s2 
-  = canEqLeafTyVarLeft fl cv tv s2 
-canEqLeafOriented fl cv (VarCls tv) s2 
-  = canEqLeafTyVarLeft fl cv tv s2 
-canEqLeafOriented _ cv (OtherCls ty1) ty2 
-  = pprPanic "canEqLeaf" (ppr cv $$ ppr ty1 $$ ppr ty2)
-
-canEqLeafTyVarLeft :: CtFlavor -> CoVar -> TcTyVar -> TcType -> TcS CanonicalCts
+canEqLeafOriented fl eqv (FskCls tv) s2 
+  = canEqLeafTyVarLeft fl eqv tv s2 
+canEqLeafOriented fl eqv (VarCls tv) s2 
+  = canEqLeafTyVarLeft fl eqv tv s2 
+canEqLeafOriented _ eqv (OtherCls ty1) ty2 
+  = pprPanic "canEqLeaf" (ppr eqv $$ ppr ty1 $$ ppr ty2)
+
+canEqLeafTyVarLeft :: CtFlavor -> EqVar -> TcTyVar -> TcType -> TcS CanonicalCts
 -- Establish invariants of CTyEqCans 
-canEqLeafTyVarLeft fl cv tv s2       -- cv : tv ~ s2
+canEqLeafTyVarLeft fl eqv tv s2       -- cv : tv ~ s2
   | not (k1 `compatKind` k2) -- Establish the kind invariant for CTyEqCan
-  = canEqFailure fl cv
+  = canEqFailure fl eqv
        -- Eagerly fails, see Note [Kind errors] in TcInteract
   | otherwise
   = do { (xi2, co, ccs2) <- flatten fl s2  -- Flatten RHS   co : xi2 ~ s2
@@ -800,19 +824,19 @@ canEqLeafTyVarLeft fl cv tv s2       -- cv : tv ~ s2
                                            -- unfolded version of the RHS, if we had to 
                                            -- unfold any type synonyms to get rid of tv.
        ; case mxi2' of {
-           Nothing   -> canEqFailure fl cv ;
+           Nothing   -> canEqFailure fl eqv ;
            Just xi2' ->
     do { let no_flattening_happened = isReflCo co
-       ; cv_new <- if no_flattening_happened  then return cv
-                   else if isGivenOrSolved fl then return cv
-                   else if isWanted fl then 
-                         do { cv' <- newCoVar (mkTyVarTy tv) xi2'  -- cv' : tv ~ xi2
-                            ; setCoBind cv  (mkCoVarCo cv' `mkTransCo` co)
-                            ; return cv' }
-                   else -- Derived
-                       newDerivedId (EqPred (mkTyVarTy tv) xi2')
-
-       ; return $ ccs2 `extendCCans` CTyEqCan { cc_id     = cv_new
+       ; eqv_new <- if no_flattening_happened  then return eqv
+                    else if isGivenOrSolved fl then return eqv
+                    else if isWanted fl then 
+                          do { eqv' <- newEqVar (mkTyVarTy tv) xi2'  -- cv' : tv ~ xi2
+                             ; setEqBind eqv $ mkTransCo (mkEqVarLCo eqv') co
+                             ; return eqv' }
+                    else -- Derived
+                        newDerivedId (mkEqPred (mkTyVarTy tv, xi2'))
+
+       ; return $ ccs2 `extendCCans` CTyEqCan { cc_id     = eqv_new
                                               , cc_flavor = fl
                                               , cc_tyvar  = tv
                                               , cc_rhs    = xi2' } } } }
@@ -877,9 +901,6 @@ expandAway tv ty@(ForAllTy {})
            Nothing 
        else do { rho' <- expandAway tv rho
                ; return (mkForAllTys tvs rho') }
-expandAway tv (PredTy pred) 
-  = do { pred' <- expandAwayPred tv pred  
-       ; return (PredTy pred') }
 -- For a type constructor application, first try expanding away the
 -- offending variable from the arguments.  If that doesn't work, next
 -- see if the type constructor is a type synonym, and if so, expand
@@ -887,19 +908,6 @@ expandAway tv (PredTy pred)
 expandAway tv ty@(TyConApp tc tys)
   = (mkTyConApp tc <$> mapM (expandAway tv) tys) <|> (tcView ty >>= expandAway tv)
 
-expandAwayPred :: TcTyVar -> TcPredType -> Maybe TcPredType 
-expandAwayPred tv (ClassP cls tys) 
-  = do { tys' <- mapM (expandAway tv) tys; return (ClassP cls tys') } 
-expandAwayPred tv (EqPred ty1 ty2)
-  = do { ty1' <- expandAway tv ty1
-       ; ty2' <- expandAway tv ty2 
-       ; return (EqPred ty1' ty2') }
-expandAwayPred tv (IParam nm ty) 
-  = do { ty' <- expandAway tv ty
-       ; return (IParam nm ty') }
-
-                
-
 \end{code}
 
 Note [Type synonyms and canonicalization]
@@ -1007,7 +1015,7 @@ now!).
 rewriteWithFunDeps :: [Equation]
                    -> [Xi] 
                    -> WantedLoc 
-                   -> TcS (Maybe ([Xi], [Coercion], [(EvVar,WantedLoc)])) 
+                   -> TcS (Maybe ([Xi], [LCoercion], [(EvVar,WantedLoc)])) 
                                            -- Not quite a WantedEvVar unfortunately
                                            -- Because our intention could be to make 
                                            -- it derived at the end of the day
@@ -1015,7 +1023,7 @@ rewriteWithFunDeps :: [Equation]
 -- Post: returns no trivial equalities (identities)
 rewriteWithFunDeps eqn_pred_locs xis wloc
  = do { fd_ev_poss <- mapM (instFunDepEqn wloc) eqn_pred_locs
-      ; let fd_ev_pos :: [(Int,(EvVar,WantedLoc))]
+      ; let fd_ev_pos :: [(Int,(EqVar,WantedLoc))]
             fd_ev_pos = concat fd_ev_poss
             (rewritten_xis, cos) = unzip (rewriteDictParams fd_ev_pos xis)
       ; if null fd_ev_pos then return Nothing
@@ -1034,9 +1042,9 @@ instFunDepEqn wl (FDEqn { fd_qtvs = qtvs, fd_eqs = eqs
        = let sty1 = Type.substTy subst ty1 
              sty2 = Type.substTy subst ty2 
          in if eqType sty1 sty2 then return ievs -- Return no trivial equalities
-            else do { ev <- newCoVar sty1 sty2
+            else do { eqv <- newEqVar sty1 sty2
                     ; let wl' = push_ctx wl 
-                    ; return $ (i,(ev,wl')):ievs }
+                    ; return $ (i,(eqv,wl')):ievs }
 
     push_ctx :: WantedLoc -> WantedLoc 
     push_ctx loc = pushErrCtxt FunDepOrigin (False, mkEqnMsg d1 d2) loc
@@ -1046,27 +1054,27 @@ mkEqnMsg :: (TcPredType, SDoc)
 mkEqnMsg (pred1,from1) (pred2,from2) tidy_env
   = do  { zpred1 <- TcM.zonkTcPredType pred1
         ; zpred2 <- TcM.zonkTcPredType pred2
-       ; let { tpred1 = tidyPred tidy_env zpred1
-              ; tpred2 = tidyPred tidy_env zpred2 }
+       ; let { tpred1 = tidyType tidy_env zpred1
+              ; tpred2 = tidyType tidy_env zpred2 }
        ; let msg = vcat [ptext (sLit "When using functional dependencies to combine"),
                          nest 2 (sep [ppr tpred1 <> comma, nest 2 from1]), 
                          nest 2 (sep [ppr tpred2 <> comma, nest 2 from2])]
        ; return (tidy_env, msg) }
 
-rewriteDictParams :: [(Int,(EvVar,WantedLoc))] -- A set of coercions : (pos, ty' ~ ty)
+rewriteDictParams :: [(Int,(EqVar,WantedLoc))] -- A set of coercions : (pos, ty' ~ ty)
                   -> [Type]                    -- A sequence of types: tys
-                  -> [(Type,Coercion)]         -- Returns: [(ty', co : ty' ~ ty)]
+                  -> [(Type,LCoercion)]      -- Returns: [(ty', co : ty' ~ ty)]
 rewriteDictParams param_eqs tys
   = zipWith do_one tys [0..]
   where
-    do_one :: Type -> Int -> (Type,Coercion)
+    do_one :: Type -> Int -> (Type,LCoercion)
     do_one ty n = case lookup n param_eqs of
-                    Just wev -> (get_fst_ty wev, mkCoVarCo (fst wev))
+                    Just wev -> (get_fst_ty wev, mkEqVarLCo (fst wev))
                     Nothing  -> (ty,             mkReflCo ty)  -- Identity
 
     get_fst_ty (wev,_wloc) 
-      | EqPred ty1 _ <- evVarPred wev 
-      = ty1 
+      | Just (ty1, _) <- getEqPredTys_maybe (evVarPred wev )
+      = ty1
       | otherwise 
       = panic "rewriteDictParams: non equality fundep!?"
 
index 1d12c33..9fdaf6f 100644 (file)
@@ -21,6 +21,7 @@ import TcBinds
 import TcUnify
 import TcHsType
 import TcMType
+import Type     ( getClassPredTys_maybe )
 import TcType
 import TcRnMonad
 import BuildTyCl( TcMethInfo )
index 4a6c524..c5166c3 100644 (file)
@@ -482,10 +482,9 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
           let allTyNames = [ tcdName d | L _ d <- tycl_decls, isDataDecl d ]
         -- Select only those types that derive Generic
         ; let sel_tydata = [ tcdName t | (L _ c, L _ t) <- all_tydata
-                                       , getClassName c == Just genClassName ]
+                                       , isGenClassName c ]
         ; let sel_deriv_decls = catMaybes [ getTypeName t
-                                  | L _ (DerivDecl (L _ t)) <- deriv_decls
-                                  , getClassName t == Just genClassName ] 
+                                  | L _ (DerivDecl (L _ t)) <- deriv_decls ] 
         ; derTyDecls <- mapM tcLookupTyCon $ 
                          filter (needsExtras xDerRep
                                   (sel_tydata ++ sel_deriv_decls)) allTyNames
@@ -504,25 +503,21 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
       -- deriving Generic
     needsExtras xDerRep tydata tc_name = xDerRep && tc_name `elem` tydata
 
-    -- Extracts the name of the class in the deriving
-    getClassName :: HsType Name -> Maybe Name
-    getClassName (HsForAllTy _ _ _ (L _ n)) = getClassName n
-    getClassName (HsPredTy (HsClassP n _))  = Just n
-    getClassName _                          = Nothing
+    -- Extracts the name of the class in the deriving and makes sure it is ours
+    isGenClassName :: HsType Name -> Bool
+    isGenClassName ty = case splitHsInstDeclTy_maybe ty of
+        Just (_, _, cls_name, _) -> cls_name == genClassName
+        _                        -> False
 
     -- Extracts the name of the type in the deriving
     -- This function (and also getClassName above) is not really nice, and I
     -- might not have covered all possible cases. I wonder if there is no easier
     -- way to extract class and type name from a LDerivDecl...
     getTypeName :: HsType Name -> Maybe Name
-    getTypeName (HsForAllTy _ _ _ (L _ n))      = getTypeName n
-    getTypeName (HsTyVar n)                     = Just n
-    getTypeName (HsOpTy _ (L _ n) _)            = Just n
-    getTypeName (HsPredTy (HsClassP _ [L _ n])) = getTypeName n
-    getTypeName (HsAppTy (L _ n) _)             = getTypeName n
-    getTypeName (HsParTy (L _ n))               = getTypeName n
-    getTypeName (HsKindSig (L _ n) _)           = getTypeName n
-    getTypeName _                               = Nothing
+    getTypeName ty = do
+        (_, _, cls_name, [ty]) <- splitHsInstDeclTy_maybe ty
+        guard (cls_name == genClassName)
+        fmap fst $ splitHsClassTy_maybe (unLoc ty)
 
     extractTyDataPreds decls
       = [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds]
@@ -1042,7 +1037,7 @@ cond_functorOK allowFunctions (_, rep_tc)
     tc_tvs            = tyConTyVars rep_tc
     Just (_, last_tv) = snocView tc_tvs
     bad_stupid_theta  = filter is_bad (tyConStupidTheta rep_tc)
-    is_bad pred       = last_tv `elemVarSet` tyVarsOfPred pred
+    is_bad pred       = last_tv `elemVarSet` tyVarsOfType pred
 
     data_cons = tyConDataCons rep_tc
     check_con con = msum (check_vanilla con : foldDataConArgs (ft_check con) con)
@@ -1360,7 +1355,10 @@ inferInstanceContexts oflag infer_specs
                          extendLocalInstEnv inst_specs $
                          mapM gen_soln infer_specs
 
-          ; if (current_solns == new_solns) then
+           ; let eqList :: (a -> b -> Bool) -> [a] -> [b] -> Bool
+                 eqList f xs ys = length xs == length ys && and (zipWith f xs ys)
+
+          ; if (eqList (eqList eqType) current_solns new_solns) then
                return [ spec { ds_theta = soln } 
                        | (spec, soln) <- zip infer_specs current_solns ]
             else
@@ -1381,7 +1379,7 @@ inferInstanceContexts oflag infer_specs
                -- Claim: the result instance declaration is guaranteed valid
                -- Hence no need to call:
                --   checkValidInstance tyvars theta clas inst_tys
-          ; return (sortLe (<=) theta) }       -- Canonicalise before returning the solution
+          ; return (sortLe (\p1 p2 -> cmpType p1 p2 /= GT) theta) }    -- Canonicalise before returning the solution
       where
         the_pred = mkClassPred clas inst_tys
 
index 9550232..aab1a5f 100644 (file)
@@ -155,8 +155,8 @@ tcLookupClass :: Name -> TcM Class
 tcLookupClass name = do
     thing <- tcLookupGlobal name
     case thing of
-       AClass cls -> return cls
-       _          -> wrongThingErr "class" (AGlobal thing) name
+       ATyCon tc | Just cls <- tyConClass_maybe tc -> return cls
+       _                                           -> wrongThingErr "class" (AGlobal thing) name
 
 tcLookupTyCon :: Name -> TcM TyCon
 tcLookupTyCon name = do
index 254f132..0892783 100644 (file)
@@ -15,7 +15,8 @@ import TcMType
 import TcSMonad
 import TcType
 import TypeRep
-import Type( isTyVarTy )
+import Type
+import Class
 import Unify ( tcMatchTys )
 import Inst
 import InstEnv
@@ -28,6 +29,7 @@ import VarSet
 import VarEnv
 import SrcLoc
 import Bag
+import BasicTypes ( IPName )
 import ListSetOps( equivClasses )
 import Maybes( mapCatMaybes )
 import Util
@@ -35,7 +37,7 @@ import FastString
 import Outputable
 import DynFlags
 import Data.List( partition )
-import Control.Monad( when, unless )
+import Control.Monad( when, unless, filterM )
 \end{code}
 
 %************************************************************************
@@ -114,8 +116,8 @@ reportTidyWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = impli
 
   | otherwise          -- No insoluble ones
   = ASSERT( isEmptyBag insols )
-    do { let (ambigs, non_ambigs) = partition is_ambiguous (bagToList flats)
-                    (tv_eqs, others)     = partition is_tv_eq non_ambigs
+    do { let (ambigs, non_ambigs) = partition     is_ambiguous (bagToList flats)
+                    (tv_eqs, others)     = partitionWith is_tv_eq     non_ambigs
 
        ; groupErrs (reportEqErrs ctxt) tv_eqs
        ; when (null tv_eqs) $ groupErrs (reportFlat ctxt) others
@@ -128,9 +130,11 @@ reportTidyWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = impli
        -- Report equalities of form (a~ty) first.  They are usually
        -- skolem-equalities, and they cause confusing knock-on 
        -- effects in other errors; see test T4093b.
-    is_tv_eq c | EqPred ty1 ty2 <- evVarOfPred c
-               = tcIsTyVarTy ty1 || tcIsTyVarTy ty2
-               | otherwise = False
+    is_tv_eq c | Just (ty1, ty2) <- getEqPredTys_maybe (evVarOfPred c)
+               , tcIsTyVarTy ty1 || tcIsTyVarTy ty2
+               = Left (c, (ty1, ty2))
+               | otherwise
+               = Right (c, evVarOfPred c)
 
        -- Treat it as "ambiguous" if 
        --   (a) it is a class constraint
@@ -138,13 +142,13 @@ reportTidyWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = impli
        --       (else we'd prefer to report it as "no instance for...")
         --   (c) it mentions a (presumably un-filled-in) meta type variable
     is_ambiguous d = isTyVarClassPred pred
-                  && any isAmbiguousTyVar (varSetElems (tyVarsOfPred pred))
+                  && any isAmbiguousTyVar (varSetElems (tyVarsOfType pred))
                  where   
                      pred = evVarOfPred d
 
 reportInsoluble :: ReportErrCtxt -> FlavoredEvVar -> TcM ()
 reportInsoluble ctxt (EvVarX ev flav)
-  | EqPred ty1 ty2 <- evVarPred ev
+  | Just (ty1, ty2) <- getEqPredTys_maybe (evVarPred ev)
   = setCtFlavorLoc flav $
     do { let ctxt2 = ctxt { cec_extra = cec_extra ctxt $$ inaccessible_msg }
        ; reportEqErr ctxt2 ty1 ty2 }
@@ -160,36 +164,47 @@ reportInsoluble ctxt (EvVarX ev flav)
 reportFlat :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
 -- The [PredType] are already tidied
 reportFlat ctxt flats origin
-  = do { unless (null dicts) $ reportDictErrs ctxt dicts origin
-       ; unless (null eqs)   $ reportEqErrs   ctxt eqs   origin
-       ; unless (null ips)   $ reportIPErrs   ctxt ips   origin
-       ; ASSERT( null others ) return () }
+  = do { unless (null dicts)  $ reportDictErrs   ctxt dicts  origin
+       ; unless (null eqs)    $ reportEqErrs     ctxt eqs    origin
+       ; unless (null ips)    $ reportIPErrs     ctxt ips    origin
+       ; unless (null irreds) $ reportIrredsErrs ctxt irreds origin }
   where
-    (dicts, non_dicts) = partition isClassPred flats
-    (eqs, non_eqs)     = partition isEqPred    non_dicts
-    (ips, others)      = partition isIPPred    non_eqs
+    (dicts, eqs, ips, irreds) = go_many (map predTypePredTree flats)
+
+    go_many []     = ([], [], [], [])
+    go_many (t:ts) = (as ++ as', bs ++ bs', cs ++ cs', ds ++ ds')
+      where (as, bs, cs, ds) = go t
+            (as', bs', cs', ds') = go_many ts
+
+    go (ClassPred cls tys) = ([(cls, tys)], [], [], [])
+    go (EqPred ty1 ty2)    = ([], [(ty1, ty2)], [], [])
+    go (IPPred ip ty)      = ([], [], [(ip, ty)], [])
+    go (IrredPred ty)      = ([], [], [], [ty])
+    go (TuplePred {})      = panic "reportFlat"
+    -- TuplePreds should have been expanded away by the constraint
+    -- simplifier, so they shouldn't show up at this point
 
 --------------------------------------------
 --      Support code 
 --------------------------------------------
 
-groupErrs :: ([PredType] -> CtOrigin -> TcM ()) -- Deal with one group
-         -> [WantedEvVar]                      -- Unsolved wanteds
+groupErrs :: ([a] -> CtOrigin -> TcM ()) -- Deal with one group
+         -> [(WantedEvVar, a)]                 -- Unsolved wanteds
           -> TcM ()
 -- Group together insts with the same origin
 -- We want to report them together in error messages
 
 groupErrs _ [] 
   = return ()
-groupErrs report_err (wanted : wanteds)
+groupErrs report_err ((wanted, x) : wanteds)
   = do  { setCtLoc the_loc $
-          report_err the_vars (ctLocOrigin the_loc)
+          report_err the_xs (ctLocOrigin the_loc)
        ; groupErrs report_err others }
   where
    the_loc           = evVarX wanted
    the_key          = mk_key the_loc
-   the_vars          = map evVarOfPred (wanted:friends)
-   (friends, others) = partition is_friend wanteds
+   the_xs            = x:map snd friends
+   (friends, others) = partition (is_friend . fst) wanteds
    is_friend friend  = mk_key (evVarX friend) `same_key` the_key
 
    mk_key :: WantedLoc -> (SrcSpan, CtOrigin)
@@ -221,7 +236,7 @@ pprWithArising ev_vars
   where
     first_loc = evVarX (head ev_vars)
     ppr_one (EvVarX v loc)
-       = hang (parens (pprPredTy (evVarPred v))) 2 (pprArisingAt loc)
+       = hang (parens (pprType (evVarPred v))) 2 (pprArisingAt loc)
 
 addErrorReport :: ReportErrCtxt -> SDoc -> TcM ()
 addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt)
@@ -234,6 +249,21 @@ getUserGivens (CEC {cec_encl = ctxt})
                     , not (null givens) ]
 \end{code}
 
+%************************************************************************
+%*       &