Merge branch 'master' of darcs.haskell.org:/srv/darcs//ghc
authorIan Lynagh <ian@well-typed.com>
Tue, 1 Jan 2013 13:24:58 +0000 (13:24 +0000)
committerIan Lynagh <ian@well-typed.com>
Tue, 1 Jan 2013 13:24:58 +0000 (13:24 +0000)
106 files changed:
compiler/basicTypes/BasicTypes.lhs
compiler/basicTypes/DataCon.lhs
compiler/basicTypes/DataCon.lhs-boot
compiler/basicTypes/MkId.lhs
compiler/basicTypes/MkId.lhs-boot
compiler/cmm/CmmPipeline.hs
compiler/cmm/CmmProcPoint.hs
compiler/coreSyn/CoreLint.lhs
compiler/coreSyn/ExternalCore.lhs
compiler/coreSyn/MkExternalCore.lhs
compiler/coreSyn/TrieMap.lhs
compiler/deSugar/DsArrows.lhs
compiler/deSugar/DsBinds.lhs
compiler/deSugar/DsMeta.hs
compiler/deSugar/DsUtils.lhs
compiler/ghc.cabal.in
compiler/hsSyn/Convert.lhs
compiler/hsSyn/HsDecls.lhs
compiler/hsSyn/HsTypes.lhs
compiler/hsSyn/HsUtils.lhs
compiler/iface/BinIface.hs
compiler/iface/BuildTyCl.lhs
compiler/iface/IfaceSyn.lhs
compiler/iface/IfaceType.lhs
compiler/iface/MkIface.lhs
compiler/iface/TcIface.lhs
compiler/iface/TcIface.lhs-boot
compiler/main/DynFlags.hs
compiler/main/GHC.hs
compiler/main/HscMain.hs
compiler/main/HscStats.hs
compiler/main/HscStats.lhs
compiler/main/HscTypes.lhs
compiler/main/InteractiveEval.hs
compiler/main/PprTyThing.hs
compiler/main/TidyPgm.lhs
compiler/parser/Parser.y.pp
compiler/parser/ParserCore.y
compiler/parser/RdrHsSyn.lhs
compiler/prelude/PrelNames.lhs
compiler/prelude/TysPrim.lhs
compiler/prelude/TysWiredIn.lhs
compiler/prelude/TysWiredIn.lhs-boot
compiler/rename/RnNames.lhs
compiler/rename/RnSource.lhs
compiler/rename/RnTypes.lhs
compiler/simplCore/CoreMonad.lhs
compiler/simplCore/Simplify.lhs
compiler/stranal/DmdAnal.lhs
compiler/stranal/WwLib.lhs
compiler/typecheck/FamInst.lhs
compiler/typecheck/TcBinds.lhs
compiler/typecheck/TcCanonical.lhs
compiler/typecheck/TcClassDcl.lhs
compiler/typecheck/TcDeriv.lhs
compiler/typecheck/TcEnv.lhs
compiler/typecheck/TcEvidence.lhs
compiler/typecheck/TcExpr.lhs
compiler/typecheck/TcForeign.lhs
compiler/typecheck/TcGenDeriv.lhs
compiler/typecheck/TcGenGenerics.lhs
compiler/typecheck/TcHsSyn.lhs
compiler/typecheck/TcHsType.lhs
compiler/typecheck/TcInstDcls.lhs
compiler/typecheck/TcInteract.lhs
compiler/typecheck/TcPat.lhs
compiler/typecheck/TcRnDriver.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/types/Class.lhs
compiler/types/CoAxiom.lhs [new file with mode: 0644]
compiler/types/Coercion.lhs
compiler/types/FamInstEnv.lhs
compiler/types/Kind.lhs
compiler/types/OptCoercion.lhs
compiler/types/TyCon.lhs
compiler/types/Type.lhs
compiler/types/TypeRep.lhs
compiler/types/Unify.lhs
compiler/vectorise/Vectorise.hs
compiler/vectorise/Vectorise/Env.hs
compiler/vectorise/Vectorise/Generic/PADict.hs
compiler/vectorise/Vectorise/Generic/PAMethods.hs
compiler/vectorise/Vectorise/Generic/PData.hs
compiler/vectorise/Vectorise/Monad/InstEnv.hs
compiler/vectorise/Vectorise/Type/Env.hs
compiler/vectorise/Vectorise/Type/TyConDecl.hs
compiler/vectorise/Vectorise/Utils/Base.hs
compiler/vectorise/Vectorise/Utils/PADict.hs
docs/core-spec/CoreLint.ott
docs/core-spec/CoreSyn.ott
docs/core-spec/core-spec.mng
docs/core-spec/core-spec.pdf
docs/users_guide/flags.xml
docs/users_guide/ghci.xml
docs/users_guide/glasgow_exts.xml
docs/users_guide/using.xml
ghc/InteractiveUI.hs
includes/rts/storage/ClosureMacros.h
sync-all

index 616316c..be6a78f 100644 (file)
@@ -62,9 +62,6 @@ module BasicTypes(
 
         EP(..),
 
-       HsBang(..), isBanged, isMarkedUnboxed, 
-        StrictnessMark(..), isMarkedStrict,
-
        DefMethSpec(..),
         SwapFlag(..), flipSwap, unSwap,
 
@@ -574,61 +571,6 @@ instance Outputable OccInfo where
 
 %************************************************************************
 %*                                                                     *
-               Strictness indication
-%*                                                                     *
-%************************************************************************
-
-The strictness annotations on types in data type declarations
-e.g.   data T = MkT !Int !(Bool,Bool)
-
-\begin{code}
--------------------------
--- HsBang describes what the *programmer* wrote
--- This info is retained in the DataCon.dcStrictMarks field
-data HsBang = HsNoBang 
-
-           | HsStrict  
-
-           | HsUnpack         -- {-# UNPACK #-} ! (GHC extension, meaning "unbox")
-
-           | HsUnpackFailed   -- An UNPACK pragma that we could not make 
-                              -- use of, because the type isn't unboxable; 
-                               -- equivalant to HsStrict except for checkValidDataCon
-            | HsNoUnpack       -- {-# NOUNPACK #-} ! (GHC extension, meaning "strict but not unboxed")
-  deriving (Eq, Data, Typeable)
-
-instance Outputable HsBang where
-    ppr HsNoBang       = empty
-    ppr HsStrict       = char '!'
-    ppr HsUnpack       = ptext (sLit "{-# UNPACK #-} !")
-    ppr HsUnpackFailed = ptext (sLit "{-# UNPACK (failed) #-} !")
-    ppr HsNoUnpack     = ptext (sLit "{-# NOUNPACK #-} !")
-
-isBanged :: HsBang -> Bool
-isBanged HsNoBang = False
-isBanged _        = True
-
-isMarkedUnboxed :: HsBang -> Bool
-isMarkedUnboxed HsUnpack = True
-isMarkedUnboxed _        = False
-
--------------------------
--- StrictnessMark is internal only, used to indicate strictness 
--- of the DataCon *worker* fields
-data StrictnessMark = MarkedStrict | NotMarkedStrict   
-
-instance Outputable StrictnessMark where
-  ppr MarkedStrict     = ptext (sLit "!")
-  ppr NotMarkedStrict  = empty
-
-isMarkedStrict :: StrictnessMark -> Bool
-isMarkedStrict NotMarkedStrict = False
-isMarkedStrict _               = True   -- All others are strict
-\end{code}
-
-
-%************************************************************************
-%*                                                                     *
                Default method specfication
 %*                                                                     *
 %************************************************************************
index 9516e4e..e55a6e4 100644 (file)
@@ -14,7 +14,7 @@
 
 module DataCon (
         -- * Main data types
-       DataCon, DataConIds(..),
+       DataCon, DataConRep(..), HsBang(..), StrictnessMark(..),
        ConTag,
        
        -- ** Type construction
@@ -30,19 +30,19 @@ module DataCon (
        dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,
        dataConInstOrigArgTys, dataConRepArgTys, 
        dataConFieldLabels, dataConFieldType,
-       dataConStrictMarks, dataConExStricts,
+       dataConStrictMarks, 
        dataConSourceArity, dataConRepArity, dataConRepRepArity,
        dataConIsInfix,
        dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds,
-       dataConRepStrictness,
+       dataConRepStrictness, dataConRepBangs, dataConBoxer,
        
        -- ** Predicates on DataCons
        isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon,
        isVanillaDataCon, classDataCon, dataConCannotMatch,
+        isBanged, isMarkedStrict, eqHsBang,
 
         -- * Splitting product types
-       splitProductType_maybe, splitProductType, deepSplitProductType,
-        deepSplitProductType_maybe,
+       splitProductType_maybe, splitProductType, 
 
         -- ** Promotion related functions
         isPromotableTyCon, promoteTyCon, 
@@ -51,12 +51,13 @@ module DataCon (
 
 #include "HsVersions.h"
 
+import {-# SOURCE #-} MkId( DataConBoxer )
 import Type
 import TypeRep( Type(..) )  -- Used in promoteType
 import PrelNames( liftedTypeKindTyConKey )
+import Coercion
 import Kind
 import Unify
-import Coercion
 import TyCon
 import Class
 import Name
@@ -342,24 +343,28 @@ data DataCon
                -- The OrigResTy is T [a], but the dcRepTyCon might be :T123
 
        -- Now the strictness annotations and field labels of the constructor
-       dcStrictMarks :: [HsBang],
+        -- See Note [Bangs on data constructor arguments]
+       dcArgBangs :: [HsBang],
                -- Strictness annotations as decided by the compiler.  
-               -- Does *not* include the existential dictionaries
-               -- length = dataConSourceArity dataCon
+               -- Matches 1-1 with dcOrigArgTys
+               -- Hence length = dataConSourceArity dataCon
 
        dcFields  :: [FieldLabel],
                -- Field labels for this constructor, in the
                -- same order as the dcOrigArgTys; 
                -- length = 0 (if not a record) or dataConSourceArity.
 
+       -- The curried worker function that corresponds to the constructor:
+       -- It doesn't have an unfolding; the code generator saturates these Ids
+       -- and allocates a real constructor when it finds one.
+       dcWorkId :: Id,
+
        -- Constructor representation
-       dcRepArgTys :: [Type],  -- Final, representation argument types, 
-                               -- after unboxing and flattening,
-                               -- and *including* all existential evidence args
+        dcRep      :: DataConRep,
 
-       dcRepStrictness :: [StrictnessMark],
-                -- One for each *representation* *value* argument
-               -- See also Note [Data-con worker strictness] in MkId.lhs
+        -- Cached
+        dcRepArity    :: Arity,  -- == length dataConRepArgTys
+        dcSourceArity :: Arity,  -- == length dcOrigArgTys
 
        -- Result type of constructor is T t1..tn
        dcRepTyCon  :: TyCon,           -- Result tycon, T
@@ -379,13 +384,6 @@ data DataCon
        -- used in CoreLint.
 
 
-       -- The curried worker function that corresponds to the constructor:
-       -- It doesn't have an unfolding; the code generator saturates these Ids
-       -- and allocates a real constructor when it finds one.
-       --
-       -- An entirely separate wrapper function is built in TcTyDecls
-       dcIds :: DataConIds,
-
        dcInfix :: Bool,        -- True <=> declared infix
                                -- Used for Template Haskell and 'deriving' only
                                -- The actual fixity is stored elsewhere
@@ -395,29 +393,70 @@ data DataCon
   }
   deriving Data.Typeable.Typeable
 
--- | Contains the Ids of the data constructor functions
-data DataConIds
-  = DCIds (Maybe Id) Id        -- Algebraic data types always have a worker, and
-                               -- may or may not have a wrapper, depending on whether
-                               -- the wrapper does anything.  Newtypes just have a worker
-
-       -- _Neither_ the worker _nor_ the wrapper take the dcStupidTheta dicts as arguments
-
-       -- The wrapper takes dcOrigArgTys as its arguments
-       -- The worker takes dcRepArgTys as its arguments
-       -- If the worker is absent, dcRepArgTys is the same as dcOrigArgTys
-
-       -- The 'Nothing' case of DCIds is important
-       -- Not only is this efficient,
-       -- but it also ensures that the wrapper is replaced
-       -- by the worker (because it *is* the worker)
-       -- even when there are no args. E.g. in
-       --              f (:) x
-       -- the (:) *is* the worker.
-       -- This is really important in rule matching,
-       -- (We could match on the wrappers,
-       -- but that makes it less likely that rules will match
-       -- when we bring bits of unfoldings together.)
+data DataConRep 
+  = NoDataConRep              -- No wrapper
+
+  | DCR { dcr_wrap_id :: Id   -- Takes src args, unboxes/flattens, 
+                              -- and constructs the representation
+
+        , dcr_boxer   :: DataConBoxer
+
+        , dcr_arg_tys :: [Type]  -- Final, representation argument types, 
+                                 -- after unboxing and flattening,
+                                 -- and *including* all evidence args
+
+        , dcr_stricts :: [StrictnessMark]  -- 1-1 with dcr_arg_tys
+               -- See also Note [Data-con worker strictness] in MkId.lhs
+
+        , dcr_bangs :: [HsBang]  -- The actual decisions made (including failures)
+                                 -- 1-1 with orig_arg_tys
+                                 -- See Note [Bangs on data constructor arguments]
+
+    }
+-- Algebraic data types always have a worker, and
+-- may or may not have a wrapper, depending on whether
+-- the wrapper does anything.  
+--
+-- Data types have a worker with no unfolding
+-- Newtypes just have a worker, which has a compulsory unfolding (just a cast)
+
+-- _Neither_ the worker _nor_ the wrapper take the dcStupidTheta dicts as arguments
+
+-- The wrapper (if it exists) takes dcOrigArgTys as its arguments
+-- The worker takes dataConRepArgTys as its arguments
+-- If the worker is absent, dataConRepArgTys is the same as dcOrigArgTys
+
+-- The 'NoDataConRep' case is important
+-- Not only is this efficient,
+-- but it also ensures that the wrapper is replaced
+-- by the worker (because it *is* the worker)
+-- even when there are no args. E.g. in
+--             f (:) x
+-- the (:) *is* the worker.
+-- This is really important in rule matching,
+-- (We could match on the wrappers,
+-- but that makes it less likely that rules will match
+-- when we bring bits of unfoldings together.)
+
+-------------------------
+-- HsBang describes what the *programmer* wrote
+-- This info is retained in the DataCon.dcStrictMarks field
+data HsBang 
+  = HsNoBang          -- Lazy field
+
+  | HsBang Bool      -- Source-language '!' bang
+                     --  True <=> also an {-# UNPACK #-} pragma
+
+  | HsUnpack              -- Definite commitment: this field is strict and unboxed
+       (Maybe Coercion)   --    co :: arg-ty ~ product-ty
+
+  | HsStrict            -- Definite commitment: this field is strict but not unboxed
+  deriving (Data.Data, Data.Typeable)
+
+-------------------------
+-- StrictnessMark is internal only, used to indicate strictness 
+-- of the DataCon *worker* fields
+data StrictnessMark = MarkedStrict | NotMarkedStrict   
 
 -- | Type of the tags associated with each constructor possibility
 type ConTag = Int
@@ -445,6 +484,25 @@ but the rep type is
        Trep :: Int# -> a -> T a
 Actually, the unboxed part isn't implemented yet!
 
+Note [Bangs on data constructor arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  data T = MkT !Int {-# UNPACK #-} !Int Bool
+Its dcArgBangs field records the *users* specifications, in this case
+    [HsBang False, HsBang True, HsNoBang]
+See the declaration of HsBang in BasicTypes
+
+The dcr_bangs field of the dcRep field records the *actual, decided*
+representation of the data constructor.  Without -O this might be
+    [HsStrict, HsStrict, HsNoBang]
+With -O it might be
+    [HsStrict, HsUnpack, HsNoBang]
+With -funbox-small-strict-fields it might be
+    [HsUnpack, HsUnpack, HsNoBang]
+
+For imported data types, the dcArgBangs field is just the same as the
+dcr_bangs field; we don't know what the user originally said.
+
 
 %************************************************************************
 %*                                                                     *
@@ -478,6 +536,35 @@ instance Data.Data DataCon where
     toConstr _   = abstractConstr "DataCon"
     gunfold _ _  = error "gunfold"
     dataTypeOf _ = mkNoRepType "DataCon"
+
+instance Outputable HsBang where
+    ppr HsNoBang             = empty
+    ppr (HsBang True)        = ptext (sLit "{-# UNPACK #-} !")
+    ppr (HsBang False)       = char '!'
+    ppr (HsUnpack Nothing)   = ptext (sLit "Unpk")
+    ppr (HsUnpack (Just co)) = ptext (sLit "Unpk") <> parens (ppr co)
+    ppr HsStrict             = ptext (sLit "SrictNotUnpacked")
+
+instance Outputable StrictnessMark where
+  ppr MarkedStrict     = ptext (sLit "!")
+  ppr NotMarkedStrict  = empty
+
+
+eqHsBang :: HsBang -> HsBang -> Bool
+eqHsBang HsNoBang             HsNoBang             = True
+eqHsBang HsStrict             HsStrict             = True
+eqHsBang (HsBang b1)          (HsBang b2)          = b1 == b2
+eqHsBang (HsUnpack Nothing)   (HsUnpack Nothing)   = True
+eqHsBang (HsUnpack (Just c1)) (HsUnpack (Just c2)) = eqType (coercionType c1) (coercionType c2)
+eqHsBang _ _ = False
+
+isBanged :: HsBang -> Bool
+isBanged HsNoBang = False
+isBanged _        = True
+
+isMarkedStrict :: StrictnessMark -> Bool
+isMarkedStrict NotMarkedStrict = False
+isMarkedStrict _               = True   -- All others are strict
 \end{code}
 
 
@@ -503,7 +590,8 @@ mkDataCon :: Name
          -> TyCon              -- ^ Representation type constructor
          -> ThetaType          -- ^ The "stupid theta", context of the data declaration 
                                --   e.g. @data Eq a => T a ...@
-         -> DataConIds         -- ^ The Ids of the actual builder functions
+          -> Id                 -- ^ Worker Id
+         -> DataConRep         -- ^ Representation
          -> DataCon
   -- Can get the tag from the TyCon
 
@@ -513,7 +601,7 @@ mkDataCon name declared_infix
          univ_tvs ex_tvs 
          eq_spec theta
          orig_arg_tys orig_res_ty rep_tycon
-         stupid_theta ids
+         stupid_theta work_id rep
 -- Warning: mkDataCon is not a good place to check invariants. 
 -- If the programmer writes the wrong result type in the decl, thus:
 --     data T a where { MkT :: S }
@@ -533,37 +621,30 @@ mkDataCon name declared_infix
                  dcStupidTheta = stupid_theta, 
                  dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty,
                  dcRepTyCon = rep_tycon, 
-                 dcRepArgTys = rep_arg_tys,
-                 dcStrictMarks = arg_stricts, 
-                 dcRepStrictness = rep_arg_stricts,
-                 dcFields = fields, dcTag = tag, dcRepType = ty,
-                 dcIds = ids,
+                 dcArgBangs = arg_stricts, 
+                 dcFields = fields, dcTag = tag, dcRepType = rep_ty,
+                 dcWorkId = work_id,
+                  dcRep = rep, 
+                  dcSourceArity = length orig_arg_tys,
+                  dcRepArity = length rep_arg_tys,
                   dcPromoted = mb_promoted }
 
-       -- Strictness marks for source-args
-       --      *after unboxing choices*, 
-       -- but  *including existential dictionaries*
        -- 
        -- The 'arg_stricts' passed to mkDataCon are simply those for the
        -- source-language arguments.  We add extra ones for the
        -- dictionary arguments right here.
-    full_theta   = eqSpecPreds eq_spec ++ theta
-    real_arg_tys = full_theta                         ++ orig_arg_tys
-    real_stricts = map mk_pred_strict_mark full_theta ++ arg_stricts
-
-       -- Representation arguments and demands
-       -- To do: eliminate duplication with MkId
-    (rep_arg_stricts, rep_arg_tys) = computeRep real_stricts real_arg_tys
 
     tag = assoc "mkDataCon" (tyConDataCons rep_tycon `zip` [fIRST_TAG..]) con
-    ty  = mkForAllTys univ_tvs $ mkForAllTys ex_tvs $ 
-         mkFunTys rep_arg_tys $
-         mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
+    rep_arg_tys = dataConRepArgTys con
+    rep_ty = mkForAllTys univ_tvs $ mkForAllTys ex_tvs $ 
+            mkFunTys rep_arg_tys $
+            mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
 
     mb_promoted   -- See Note [Promoted data constructors] in TyCon
       | all (isLiftedTypeKind . tyVarKind) (univ_tvs ++ ex_tvs)
                           -- No kind polymorphism, and all of kind *
-      , null full_theta   -- No constraints
+      , null eq_spec   -- No constraints
+      , null theta
       , all isPromotableType orig_arg_tys
       = Just (mkPromotedDataCon con name (getUnique name) prom_kind arity)
       | otherwise 
@@ -573,11 +654,6 @@ mkDataCon name declared_infix
 
 eqSpecPreds :: [(TyVar,Type)] -> ThetaType
 eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv) ty | (tv,ty) <- spec ]
-
-mk_pred_strict_mark :: PredType -> HsBang
-mk_pred_strict_mark pred 
-  | isEqPred pred = HsUnpack   -- Note [Unpack equality predicates]
-  | otherwise     = HsNoBang
 \end{code}
 
 Note [Unpack equality predicates]
@@ -647,31 +723,32 @@ dataConTheta (MkData { dcEqSpec = eq_spec, dcOtherTheta = theta })
 -- be different from the obvious one written in the source program. Panics
 -- if there is no such 'Id' for this 'DataCon'
 dataConWorkId :: DataCon -> Id
-dataConWorkId dc = case dcIds dc of
-                       DCIds _ wrk_id -> wrk_id
+dataConWorkId dc = dcWorkId dc
 
 -- | Get the Id of the 'DataCon' wrapper: a function that wraps the "actual"
 -- constructor so it has the type visible in the source program: c.f. 'dataConWorkId'.
 -- Returns Nothing if there is no wrapper, which occurs for an algebraic data constructor 
 -- and also for a newtype (whose constructor is inlined compulsorily)
 dataConWrapId_maybe :: DataCon -> Maybe Id
-dataConWrapId_maybe dc = case dcIds dc of
-                               DCIds mb_wrap _ -> mb_wrap
+dataConWrapId_maybe dc = case dcRep dc of
+                           NoDataConRep -> Nothing
+                           DCR { dcr_wrap_id = wrap_id } -> Just wrap_id
 
 -- | Returns an Id which looks like the Haskell-source constructor by using
 -- the wrapper if it exists (see 'dataConWrapId_maybe') and failing over to
 -- the worker (see 'dataConWorkId')
 dataConWrapId :: DataCon -> Id
-dataConWrapId dc = case dcIds dc of
-                       DCIds (Just wrap) _   -> wrap
-                       DCIds Nothing     wrk -> wrk        -- worker=wrapper
+dataConWrapId dc = case dcRep dc of
+                     NoDataConRep-> dcWorkId dc    -- worker=wrapper
+                     DCR { dcr_wrap_id = wrap_id } -> wrap_id
 
 -- | Find all the 'Id's implicitly brought into scope by the data constructor. Currently,
 -- the union of the 'dataConWorkId' and the 'dataConWrapId'
 dataConImplicitIds :: DataCon -> [Id]
-dataConImplicitIds dc = case dcIds dc of
-                         DCIds (Just wrap) work -> [wrap,work]
-                         DCIds Nothing     work -> [work]
+dataConImplicitIds (MkData { dcWorkId = work, dcRep = rep})
+  = case rep of
+       NoDataConRep               -> [work]
+       DCR { dcr_wrap_id = wrap } -> [wrap,work]
 
 -- | The labels for the fields of this particular 'DataCon'
 dataConFieldLabels :: DataCon -> [FieldLabel]
@@ -687,22 +764,18 @@ dataConFieldType con label
 -- | The strictness markings decided on by the compiler.  Does not include those for
 -- existential dictionaries.  The list is in one-to-one correspondence with the arity of the 'DataCon'
 dataConStrictMarks :: DataCon -> [HsBang]
-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_pred_strict_mark (dataConTheta dc)
+dataConStrictMarks = dcArgBangs
 
 -- | Source-level arity of the data constructor
 dataConSourceArity :: DataCon -> Arity
-dataConSourceArity dc = length (dcOrigArgTys dc)
+dataConSourceArity (MkData { dcSourceArity = arity }) = arity
 
 -- | Gives the number of actual fields in the /representation/ of the 
 -- data constructor. This may be more than appear in the source code;
 -- the extra ones are the existentially quantified dictionaries
 dataConRepArity :: DataCon -> Arity
-dataConRepArity (MkData {dcRepArgTys = arg_tys}) = length arg_tys
+dataConRepArity (MkData { dcRepArity = arity }) = arity
+
 
 -- | The number of fields in the /representation/ of the constructor
 -- AFTER taking into account the unpacking of any unboxed tuple fields
@@ -715,12 +788,23 @@ isNullarySrcDataCon dc = null (dcOrigArgTys dc)
 
 -- | Return whether there are any argument types for this 'DataCon's runtime representation type
 isNullaryRepDataCon :: DataCon -> Bool
-isNullaryRepDataCon dc = null (dcRepArgTys dc)
+isNullaryRepDataCon dc = dataConRepArity dc == 0
 
 dataConRepStrictness :: DataCon -> [StrictnessMark]
 -- ^ Give the demands on the arguments of a
 -- Core constructor application (Con dc args)
-dataConRepStrictness dc = dcRepStrictness dc
+dataConRepStrictness dc = case dcRep dc of
+                            NoDataConRep -> [NotMarkedStrict | _ <- dataConRepArgTys dc]
+                            DCR { dcr_stricts = strs } -> strs
+
+dataConRepBangs :: DataCon -> [HsBang]
+dataConRepBangs dc = case dcRep dc of
+                       NoDataConRep -> dcArgBangs dc
+                       DCR { dcr_bangs = bangs } -> bangs
+
+dataConBoxer :: DataCon -> Maybe DataConBoxer
+dataConBoxer (MkData { dcRep = DCR { dcr_boxer = boxer } }) = Just boxer
+dataConBoxer _ = Nothing 
 
 -- | The \"signature\" of the 'DataCon' returns, in order:
 --
@@ -798,13 +882,12 @@ dataConInstArgTys :: DataCon      -- ^ A datacon with no existentials or equality con
                                -- class dictionary, with superclasses)
                  -> [Type]     -- ^ Instantiated at these types
                  -> [Type]
-dataConInstArgTys dc@(MkData {dcRepArgTys = rep_arg_tys, 
-                             dcUnivTyVars = univ_tvs, dcEqSpec = eq_spec,
+dataConInstArgTys dc@(MkData {dcUnivTyVars = univ_tvs, dcEqSpec = eq_spec,
                              dcExTyVars = ex_tvs}) inst_tys
  = ASSERT2 ( length univ_tvs == length inst_tys 
            , ptext (sLit "dataConInstArgTys") <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys)
    ASSERT2 ( null ex_tvs && null eq_spec, ppr dc )        
-   map (substTyWith univ_tvs inst_tys) rep_arg_tys
+   map (substTyWith univ_tvs inst_tys) (dataConRepArgTys dc)
 
 -- | Returns just the instantiated /value/ argument types of a 'DataCon',
 -- (excluding dictionary args)
@@ -831,10 +914,16 @@ dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys,
 dataConOrigArgTys :: DataCon -> [Type]
 dataConOrigArgTys dc = dcOrigArgTys dc
 
--- | Returns the arg types of the worker, including all dictionaries, after any 
+-- | Returns the arg types of the worker, including *all* evidence, after any 
 -- flattening has been done and without substituting for any type variables
 dataConRepArgTys :: DataCon -> [Type]
-dataConRepArgTys dc = dcRepArgTys dc
+dataConRepArgTys (MkData { dcRep = rep 
+                         , dcEqSpec = eq_spec
+                         , dcOtherTheta = theta
+                        , dcOrigArgTys = orig_arg_tys })
+  = case rep of
+      NoDataConRep -> ASSERT( null eq_spec ) theta ++ orig_arg_tys
+      DCR { dcr_arg_tys = arg_tys } -> arg_tys
 \end{code}
 
 \begin{code}
@@ -872,7 +961,7 @@ classDataCon clas = case tyConDataCons (classTyCon clas) of
 dataConCannotMatch :: [Type] -> DataCon -> Bool
 -- Returns True iff the data con *definitely cannot* match a 
 --                 scrutinee of type (T tys)
---                 where T is the type constructor for the data con
+--                 where T is the dcRepTyCon for the data con
 -- NB: look at *all* equality constraints, not only those
 --     in dataConEqSpec; see Trac #5168
 dataConCannotMatch tys con
@@ -884,7 +973,8 @@ dataConCannotMatch tys con
   where
     dc_tvs  = dataConUnivTyVars con
     theta   = dataConTheta con
-    subst   = zipTopTvSubst dc_tvs tys
+    subst   = ASSERT2( length dc_tvs == length tys, ppr con $$ ppr dc_tvs $$ ppr tys ) 
+              zipTopTvSubst dc_tvs tys
 
     -- TODO: could gather equalities from superclasses too
     predEqs pred = case classifyPredType pred of
@@ -940,47 +1030,6 @@ splitProductType str ty
   = case splitProductType_maybe ty of
        Just stuff -> stuff
        Nothing    -> pprPanic (str ++ ": not a product") (pprType ty)
-
-
--- | As 'splitProductType_maybe', but in turn instantiates the 'TyCon' returned
--- and hence recursively tries to unpack it as far as it able to
-deepSplitProductType_maybe :: Type -> Maybe (TyCon, [Type], DataCon, [Type])
-deepSplitProductType_maybe ty
-  = do { (res@(tycon, tycon_args, _, _)) <- splitProductType_maybe ty
-       ; let {result 
-             | Just (ty', _co) <- instNewTyCon_maybe tycon tycon_args
-            , not (isRecursiveTyCon tycon)
-             = deepSplitProductType_maybe ty'  -- Ignore the coercion?
-             | isNewTyCon tycon = Nothing  -- cannot unbox through recursive
-                                          -- newtypes nor through families
-             | otherwise = Just res}
-       ; result
-       }
-
--- | As 'deepSplitProductType_maybe', but panics if the 'Type' is not a product type
-deepSplitProductType :: String -> Type -> (TyCon, [Type], DataCon, [Type])
-deepSplitProductType str ty 
-  = case deepSplitProductType_maybe ty of
-      Just stuff -> stuff
-      Nothing -> pprPanic (str ++ ": not a product") (pprType ty)
-
--- | Compute the representation type strictness and type suitable for a 'DataCon'
-computeRep :: [HsBang]                 -- ^ Original argument strictness
-          -> [Type]                    -- ^ Original argument types
-          -> ([StrictnessMark],        -- Representation arg strictness
-              [Type])                  -- And type
-
-computeRep stricts tys
-  = unzip $ concat $ zipWithEqual "computeRep" unbox stricts tys
-  where
-    unbox HsNoBang       ty = [(NotMarkedStrict, ty)]
-    unbox HsStrict       ty = [(MarkedStrict,    ty)]
-    unbox HsNoUnpack     ty = [(MarkedStrict,    ty)]
-    unbox HsUnpackFailed ty = [(MarkedStrict,    ty)]
-    unbox HsUnpack ty = zipEqual "computeRep" (dataConRepStrictness arg_dc) arg_tys
-                      where
-                        (_tycon, _tycon_args, arg_dc, arg_tys) 
-                           = deepSplitProductType "unbox_strict_arg_ty" ty
 \end{code}
 
 
@@ -1036,8 +1085,9 @@ isPromotableType _                 = False
 -- If tc's kind is [ *^n -> * ] returns [ Just n ], else returns [ Nothing ]
 isPromotableTyCon :: TyCon -> Maybe Int
 isPromotableTyCon tc
-  | isDataTyCon tc  -- Only *data* types can be promoted, not newtypes
-                   -- not synonyms, not type families
+  | isDataTyCon tc || isNewTyCon tc
+       -- Only *data* and *newtype* types can be promoted, 
+       -- not synonyms, not type/data families
   , all isLiftedTypeKind (res:args) = Just $ length args
   | otherwise                       = Nothing
   where
index 716dc7e..6f9a385 100644 (file)
@@ -2,11 +2,10 @@
 module DataCon where
 import Name( Name )
 import {-# SOURCE #-} TyCon( TyCon )
-import {-# SOURCE #-} TypeRep (Type)
 
 data DataCon
+data DataConRep
 dataConName      :: DataCon -> Name
-dataConRepArgTys :: DataCon -> [Type]
 dataConTyCon     :: DataCon -> TyCon
 isVanillaDataCon :: DataCon -> Bool
 instance Eq DataCon
index 345d8a6..ef0efc9 100644 (file)
@@ -22,12 +22,14 @@ have a standard form, namely:
 module MkId (
         mkDictFunId, mkDictFunTy, mkDictSelId,
 
-        mkDataConIds, mkPrimOpId, mkFCallId,
+        mkPrimOpId, mkFCallId,
 
-        mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody,
+        wrapNewTypeBody, unwrapNewTypeBody,
         wrapFamInstBody, unwrapFamInstScrut,
-        wrapTypeFamInstBody, unwrapTypeFamInstScrut,
-        mkUnpackCase, mkProductBox,
+        wrapTypeFamInstBody, wrapTypeUnbranchedFamInstBody, unwrapTypeFamInstScrut,
+        unwrapTypeUnbranchedFamInstScrut,
+
+        DataConBoxer(..), mkDataConRep, mkDataConWorkId,
 
         -- And some particular Ids; see below for why they are wired in
         wiredInIds, ghcPrimIds,
@@ -46,6 +48,7 @@ import TysPrim
 import TysWiredIn
 import PrelRules
 import Type
+import FamInstEnv
 import Coercion
 import TcType
 import MkCore
@@ -53,7 +56,9 @@ import CoreUtils      ( exprType, mkCast )
 import CoreUnfold
 import Literal
 import TyCon
+import CoAxiom
 import Class
+import NameSet
 import VarSet
 import Name
 import PrimOp
@@ -65,6 +70,7 @@ import IdInfo
 import Demand
 import CoreSyn
 import Unique
+import UniqSupply
 import PrelNames
 import BasicTypes       hiding ( SuccessFlag(..) )
 import Util
@@ -224,173 +230,6 @@ Hence we translate to
         -- Coercion from family type to representation type
   Co7T a :: T [a] ~ :R7T a
 
-\begin{code}
-mkDataConIds :: Name -> Name -> DataCon -> DataConIds
-mkDataConIds wrap_name wkr_name data_con
-  | isNewTyCon tycon                    -- Newtype, only has a worker
-  = DCIds Nothing nt_work_id                 
-
-  | any isBanged all_strict_marks      -- Algebraic, needs wrapper
-    || not (null eq_spec)              -- NB: LoadIface.ifaceDeclImplicitBndrs
-    || isFamInstTyCon tycon            --     depends on this test
-  = DCIds (Just alg_wrap_id) wrk_id
-
-  | otherwise                                -- Algebraic, no wrapper
-  = DCIds Nothing wrk_id
-  where
-    (univ_tvs, ex_tvs, eq_spec, 
-     other_theta, orig_arg_tys, res_ty) = dataConFullSig data_con
-    tycon = dataConTyCon data_con       -- The representation TyCon (not family)
-
-        ----------- Worker (algebraic data types only) --------------
-        -- The *worker* for the data constructor is the function that
-        -- takes the representation arguments and builds the constructor.
-    wrk_id = mkGlobalId (DataConWorkId data_con) wkr_name
-                        (dataConRepType data_con) wkr_info
-
-    wkr_arity = dataConRepArity data_con
-    wkr_info  = noCafIdInfo
-                `setArityInfo`       wkr_arity
-                `setStrictnessInfo`  Just wkr_sig
-                `setUnfoldingInfo`   evaldUnfolding  -- Record that it's evaluated,
-                                                        -- even if arity = 0
-
-    wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) cpr_info)
-        --      Note [Data-con worker strictness]
-        -- Notice that we do *not* say the worker is strict
-        -- even if the data constructor is declared strict
-        --      e.g.    data T = MkT !(Int,Int)
-        -- Why?  Because the *wrapper* is strict (and its unfolding has case
-        -- expresssions that do the evals) but the *worker* itself is not.
-        -- If we pretend it is strict then when we see
-        --      case x of y -> $wMkT y
-        -- the simplifier thinks that y is "sure to be evaluated" (because
-        --  $wMkT is strict) and drops the case.  No, $wMkT is not strict.
-        --
-        -- When the simplifer sees a pattern 
-        --      case e of MkT x -> ...
-        -- it uses the dataConRepStrictness of MkT to mark x as evaluated;
-        -- but that's fine... dataConRepStrictness comes from the data con
-        -- not from the worker Id.
-
-    cpr_info | isProductTyCon tycon && 
-               isDataTyCon tycon    &&
-               wkr_arity > 0        &&
-               wkr_arity <= mAX_CPR_SIZE        = retCPR
-             | otherwise                        = TopRes
-        -- RetCPR is only true for products that are real data types;
-        -- that is, not unboxed tuples or [non-recursive] newtypes
-
-        ----------- Workers for newtypes --------------
-    nt_work_id   = mkGlobalId (DataConWrapId data_con) wkr_name wrap_ty nt_work_info
-    nt_work_info = noCafIdInfo          -- The NoCaf-ness is set by noCafIdInfo
-                  `setArityInfo` 1      -- Arity 1
-                  `setInlinePragInfo`    alwaysInlinePragma
-                  `setUnfoldingInfo`     newtype_unf
-    id_arg1      = mkTemplateLocal 1 (head orig_arg_tys)
-    newtype_unf  = ASSERT2( isVanillaDataCon data_con &&
-                            isSingleton orig_arg_tys, ppr data_con  )
-                             -- Note [Newtype datacons]
-                   mkCompulsoryUnfolding $ 
-                   mkLams wrap_tvs $ Lam id_arg1 $ 
-                   wrapNewTypeBody tycon res_ty_args (Var id_arg1)
-
-
-        ----------- Wrapper --------------
-        -- We used to include the stupid theta in the wrapper's args
-        -- but now we don't.  Instead the type checker just injects these
-        -- 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      = 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
-                    `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)
-    wrap_stricts = dropList eq_spec all_strict_marks
-    wrap_arg_dmds = map mk_dmd wrap_stricts
-    mk_dmd str | isBanged str = evalDmd
-               | otherwise    = lazyDmd
-        -- The Cpr info can be important inside INLINE rhss, where the
-        -- wrapper constructor isn't inlined.
-        -- And the argument strictness can be important too; we
-        -- may not inline a contructor when it is partially applied.
-        -- For example:
-        --      data W = C !Int !Int !Int
-        --      ...(let w = C x in ...(w p q)...)...
-        -- we want to see that w is strict in its two arguments
-
-    wrap_unf = mkInlineUnfolding (Just (length ev_args + length id_args)) wrap_rhs
-    wrap_rhs = mkLams wrap_tvs $ 
-               mkLams ev_args $
-               mkLams id_args $
-               foldr mk_case con_app 
-                     (zip (ev_args ++ id_args) wrap_stricts)
-                     i3 []
-            -- The ev_args is the evidence arguments *other than* the eq_spec
-            -- Because we are going to apply the eq_spec args manually in the
-            -- wrapper
-
-    con_app _ rep_ids = wrapFamInstBody tycon res_ty_args $
-                          Var wrk_id `mkTyApps`  res_ty_args
-                                     `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
-    wrap_arity   = i3-1
-
-    mk_case 
-           :: (Id, HsBang)      -- Arg, strictness
-           -> (Int -> [Id] -> CoreExpr) -- Body
-           -> Int                       -- Next rep arg id
-           -> [Id]                      -- Rep args so far, reversed
-           -> CoreExpr
-    mk_case (arg,strict) body i rep_args
-          = case strict of
-                HsNoBang -> body i (arg:rep_args)
-                HsUnpack -> unboxProduct i (Var arg) (idType arg) the_body 
-                      where
-                        the_body i con_args = body i (reverse con_args ++ rep_args)
-                _other  -- HsUnpackFailed and HsStrict
-                   | isUnLiftedType (idType arg) -> body i (arg:rep_args)
-                   | otherwise -> Case (Var arg) arg res_ty 
-                                       [(DEFAULT,[], body i (arg:rep_args))]
-
-mAX_CPR_SIZE :: Arity
-mAX_CPR_SIZE = 10
--- We do not treat very big tuples as CPR-ish:
---      a) for a start we get into trouble because there aren't 
---         "enough" unboxed tuple types (a tiresome restriction, 
---         but hard to fix), 
---      b) more importantly, big unboxed tuples get returned mainly
---         on the stack, and are often then allocated in the heap
---         by the caller.  So doing CPR for them may in fact make
---         things worse.
-
-mkLocals :: Int -> [Type] -> ([Id], Int)
-mkLocals i tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n)
-               where
-                 n = length tys
-\end{code}
 
 Note [Newtype datacons]
 ~~~~~~~~~~~~~~~~~~~~~~~
@@ -528,136 +367,414 @@ dictSelRule val_index n_ty_args _ _ id_unf args
 %*                                                                      *
 %************************************************************************
 
+
 \begin{code}
--- unbox a product type...
--- we will recurse into newtypes, casting along the way, and unbox at the
--- first product data constructor we find. e.g.
---  
---   data PairInt = PairInt Int Int
---   newtype S = MkS PairInt
---   newtype T = MkT S
---
--- If we have e = MkT (MkS (PairInt 0 1)) and some body expecting a list of
--- ids, we get (modulo int passing)
---
---   case (e `cast` CoT) `cast` CoS of
---     PairInt a b -> body [a,b]
---
--- The Ints passed around are just for creating fresh locals
-unboxProduct :: Int -> CoreExpr -> Type -> (Int -> [Id] -> CoreExpr) -> CoreExpr
-unboxProduct i arg arg_ty body
-  = result
-  where 
-    result = mkUnpackCase the_id arg con_args boxing_con rhs
-    (_tycon, _tycon_args, boxing_con, tys) = deepSplitProductType "unboxProduct" arg_ty
-    ([the_id], i') = mkLocals i [arg_ty]
-    (con_args, i'') = mkLocals i' tys
-    rhs = body i'' con_args
-
-mkUnpackCase ::  Id -> CoreExpr -> [Id] -> DataCon -> CoreExpr -> CoreExpr
--- (mkUnpackCase x e args Con body)
---      returns
--- case (e `cast` ...) of bndr { Con args -> body }
--- 
--- the type of the bndr passed in is irrelevent
-mkUnpackCase bndr arg unpk_args boxing_con body
-  = Case cast_arg (setIdType bndr bndr_ty) (exprType body) [(DataAlt boxing_con, unpk_args, body)]
+mkDataConWorkId :: Name -> DataCon -> Id
+mkDataConWorkId wkr_name data_con
+  | isNewTyCon tycon
+  = mkGlobalId (DataConWrapId data_con) wkr_name nt_wrap_ty nt_work_info
+  | otherwise
+  = mkGlobalId (DataConWorkId data_con) wkr_name alg_wkr_ty wkr_info
+
   where
-  (cast_arg, bndr_ty) = go (idType bndr) arg
-  go ty arg 
-    | (tycon, tycon_args, _, _)  <- splitProductType "mkUnpackCase" ty
-    , isNewTyCon tycon && not (isRecursiveTyCon tycon)
-    = go (newTyConInstRhs tycon tycon_args) 
-         (unwrapNewTypeBody tycon tycon_args arg)
-    | otherwise = (arg, ty)
-
--- ...and the dual
-reboxProduct :: [Unique]     -- uniques to create new local binders
-             -> Type         -- type of product to box
-             -> ([Unique],   -- remaining uniques
-                 CoreExpr,   -- boxed product
-                 [Id])       -- Ids being boxed into product
-reboxProduct us ty
-  = let 
-        (_tycon, _tycon_args, _pack_con, con_arg_tys) = deepSplitProductType "reboxProduct" ty
-        us' = dropList con_arg_tys us
-
-        arg_ids  = zipWith (mkSysLocal (fsLit "rb")) us con_arg_tys
-
-        bind_rhs = mkProductBox arg_ids ty
-
-    in
-      (us', bind_rhs, arg_ids)
-
-mkProductBox :: [Id] -> Type -> CoreExpr
-mkProductBox arg_ids ty 
-  = result_expr
-  where 
-    (tycon, tycon_args, pack_con, _con_arg_tys) = splitProductType "mkProductBox" ty
-
-    result_expr
-      | isNewTyCon tycon && not (isRecursiveTyCon tycon) 
-      = wrap (mkProductBox arg_ids (newTyConInstRhs tycon tycon_args))
-      | otherwise = mkConApp pack_con (map Type tycon_args ++ varsToCoreExprs arg_ids)
-
-    wrap expr = wrapNewTypeBody tycon tycon_args expr
-
-
--- (mkReboxingAlt us con xs rhs) basically constructs the case
--- alternative (con, xs, rhs)
--- but it does the reboxing necessary to construct the *source* 
--- arguments, xs, from the representation arguments ys.
--- For example:
---      data T = MkT !(Int,Int) Bool
---
--- mkReboxingAlt MkT [x,b] r 
---      = (DataAlt MkT, [y::Int,z::Int,b], let x = (y,z) in r)
+    tycon = dataConTyCon data_con
+
+        ----------- Workers for data types --------------
+    alg_wkr_ty = dataConRepType data_con
+    wkr_arity = dataConRepArity data_con
+    wkr_info  = noCafIdInfo
+                `setArityInfo`       wkr_arity
+                `setStrictnessInfo`  Just wkr_sig
+                `setUnfoldingInfo`   evaldUnfolding  -- Record that it's evaluated,
+                                                     -- even if arity = 0
+
+    wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) (dataConCPR data_con))
+        --      Note [Data-con worker strictness]
+        -- Notice that we do *not* say the worker is strict
+        -- even if the data constructor is declared strict
+        --      e.g.    data T = MkT !(Int,Int)
+        -- Why?  Because the *wrapper* is strict (and its unfolding has case
+        -- expresssions that do the evals) but the *worker* itself is not.
+        -- If we pretend it is strict then when we see
+        --      case x of y -> $wMkT y
+        -- the simplifier thinks that y is "sure to be evaluated" (because
+        --  $wMkT is strict) and drops the case.  No, $wMkT is not strict.
+        --
+        -- When the simplifer sees a pattern 
+        --      case e of MkT x -> ...
+        -- it uses the dataConRepStrictness of MkT to mark x as evaluated;
+        -- but that's fine... dataConRepStrictness comes from the data con
+        -- not from the worker Id.
+
+        ----------- Workers for newtypes --------------
+    (nt_tvs, _, nt_arg_tys, _) = dataConSig data_con
+    res_ty_args  = mkTyVarTys nt_tvs
+    nt_wrap_ty   = dataConUserType data_con
+    nt_work_info = noCafIdInfo          -- The NoCaf-ness is set by noCafIdInfo
+                  `setArityInfo` 1      -- Arity 1
+                  `setInlinePragInfo`    alwaysInlinePragma
+                  `setUnfoldingInfo`     newtype_unf
+    id_arg1      = mkTemplateLocal 1 (head nt_arg_tys)
+    newtype_unf  = ASSERT2( isVanillaDataCon data_con &&
+                            isSingleton nt_arg_tys, ppr data_con  )
+                             -- Note [Newtype datacons]
+                   mkCompulsoryUnfolding $ 
+                   mkLams nt_tvs $ Lam id_arg1 $ 
+                   wrapNewTypeBody tycon res_ty_args (Var id_arg1)
+
+dataConCPR :: DataCon -> DmdResult
+dataConCPR con
+  | isProductTyCon tycon
+  , isDataTyCon tycon
+  , wkr_arity > 0
+  , wkr_arity <= mAX_CPR_SIZE
+  = retCPR
+  | otherwise
+  = TopRes
+        -- RetCPR is only true for products that are real data types;
+        -- that is, not unboxed tuples or [non-recursive] newtypes
+  where
+    tycon = dataConTyCon con
+    wkr_arity = dataConRepArity con
+
+    mAX_CPR_SIZE :: Arity
+    mAX_CPR_SIZE = 10
+    -- We do not treat very big tuples as CPR-ish:
+    --      a) for a start we get into trouble because there aren't 
+    --         "enough" unboxed tuple types (a tiresome restriction, 
+    --         but hard to fix), 
+    --      b) more importantly, big unboxed tuples get returned mainly
+    --         on the stack, and are often then allocated in the heap
+    --         by the caller.  So doing CPR for them may in fact make
+    --         things worse.
+\end{code}
+
+-------------------------------------------------
+--         Data constructor representation
+-- 
+-- This is where we decide how to wrap/unwrap the 
+-- constructor fields
 --
--- mkDataAlt should really be in DataCon, but it can't because
--- it manipulates CoreSyn.
+--------------------------------------------------
+
+
+\begin{code}
+type Unboxer = Var -> UniqSM ([Var], CoreExpr -> CoreExpr)
+  -- Unbox: bind rep vars by decomposing src var
+
+data Boxer = UnitBox | Boxer (TvSubst -> UniqSM ([Var], CoreExpr))
+  -- Box:   build src arg using these rep vars
 
-mkReboxingAlt
-  :: [Unique] -- Uniques for the new Ids
-  -> DataCon
-  -> [Var]    -- Source-level args, *including* all evidence vars 
-  -> CoreExpr -- RHS
-  -> CoreAlt
+newtype DataConBoxer = DCB ([Type] -> [Var] -> UniqSM ([Var], [CoreBind]))
+                       -- Bind these src-level vars, returning the
+                       -- rep-level vars to bind in the pattern
 
-mkReboxingAlt us con args rhs
-  | not (any isMarkedUnboxed stricts)
-  = (DataAlt con, args, rhs)
+mkDataConRep :: DynFlags -> FamInstEnvs -> Name -> DataCon -> UniqSM DataConRep
+mkDataConRep dflags fam_envs wrap_name data_con
+  | not wrapper_reqd
+  = return NoDataConRep
 
   | otherwise
-  = let
-        (binds, args') = go args stricts us
-    in
-    (DataAlt con, args', mkLets binds rhs)
+  = do { wrap_args <- mapM newLocal wrap_arg_tys
+       ; wrap_body <- mk_rep_app (wrap_args `zip` dropList eq_spec unboxers) 
+                                 initial_wrap_app
+
+       ; let wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty wrap_info
+             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
+
+            wrap_sig = mkStrictSig (mkTopDmdType wrap_arg_dmds (dataConCPR data_con))
+            wrap_arg_dmds = map mk_dmd (dropList eq_spec wrap_bangs)
+            mk_dmd str | isBanged str = evalDmd
+                       | otherwise    = lazyDmd
+                -- The Cpr info can be important inside INLINE rhss, where the
+                -- wrapper constructor isn't inlined.
+                -- And the argument strictness can be important too; we
+                -- may not inline a contructor when it is partially applied.
+                -- For example:
+                --      data W = C !Int !Int !Int
+                --      ...(let w = C x in ...(w p q)...)...
+                -- we want to see that w is strict in its two arguments
+
+            wrap_unf = mkInlineUnfolding (Just wrap_arity) wrap_rhs
+             wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
+            wrap_rhs = mkLams wrap_tvs $ 
+                       mkLams wrap_args $
+                       wrapFamInstBody tycon res_ty_args $
+                        wrap_body
+
+       ; return (DCR { dcr_wrap_id = wrap_id
+                     , dcr_boxer   = mk_boxer boxers
+                     , dcr_arg_tys = rep_tys
+                     , dcr_stricts = rep_strs
+                     , dcr_bangs   = dropList ev_tys wrap_bangs }) }
 
   where
-    stricts = dataConExStricts con ++ dataConStrictMarks con
-
-    go [] _stricts _us = ([], [])
-
-    -- Type variable case
-    go (arg:args) stricts us 
-      | isTyVar arg
-      = let (binds, args') = go args stricts us
-        in  (binds, arg:args')
-
-        -- Term variable case
-    go (arg:args) (str:stricts) us
-      | isMarkedUnboxed str
-      = let (binds, unpacked_args')        = go args stricts us'
-            (us', bind_rhs, unpacked_args) = reboxProduct us (idType arg)
-        in
-            (NonRec arg bind_rhs : binds, unpacked_args ++ unpacked_args')
-      | otherwise
-      = let (binds, args') = go args stricts us
-        in  (binds, arg:args')
-    go (_ : _) [] _ = panic "mkReboxingAlt"
+    (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _) = dataConFullSig data_con
+    res_ty_args  = substTyVars (mkTopTvSubst eq_spec) univ_tvs
+    tycon        = dataConTyCon data_con       -- The representation TyCon (not family)
+    wrap_ty      = dataConUserType data_con
+    ev_tys       = eqSpecPreds eq_spec ++ theta
+    all_arg_tys  = ev_tys                         ++ orig_arg_tys
+    orig_bangs   = map mk_pred_strict_mark ev_tys ++ dataConStrictMarks data_con
+
+    wrap_arg_tys = theta ++ orig_arg_tys
+    wrap_arity   = length wrap_arg_tys
+            -- The wrap_args are the arguments *other than* the eq_spec
+            -- Because we are going to apply the eq_spec args manually in the
+            -- wrapper
+
+    (wrap_bangs, rep_tys_w_strs, wrappers)
+       = unzip3 (zipWith (dataConArgRep dflags fam_envs) all_arg_tys orig_bangs)
+    (unboxers, boxers) = unzip wrappers
+    (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs)
+
+    wrapper_reqd = not (isNewTyCon tycon)  -- Newtypes have only a worker
+                && (any isBanged orig_bangs   -- Some forcing/unboxing
+                                              -- (includes eq_spec)
+                    || isFamInstTyCon tycon)  -- Cast result
+
+    initial_wrap_app = Var (dataConWorkId data_con)
+                      `mkTyApps`  res_ty_args
+                     `mkVarApps` ex_tvs                 
+                     `mkCoApps`  map (mkReflCo . snd) eq_spec
+                       -- Dont box the eq_spec coercions since they are
+                       -- marked as HsUnpack by mk_dict_strict_mark
+
+    mk_boxer :: [Boxer] -> DataConBoxer
+    mk_boxer boxers = DCB (\ ty_args src_vars -> 
+                      do { let ex_vars = takeList ex_tvs src_vars
+                               subst1 = mkTopTvSubst (univ_tvs `zip` ty_args)
+                               subst2 = extendTvSubstList subst1 ex_tvs 
+                                                          (mkTyVarTys ex_vars)
+                         ; (rep_ids, binds) <- go subst2 boxers (dropList ex_tvs src_vars)
+                         ; return (ex_vars ++ rep_ids, binds) } )
+
+    go _ [] src_vars = ASSERT2( null src_vars, ppr data_con ) return ([], [])
+    go subst (UnitBox : boxers) (src_var : src_vars)
+      = do { (rep_ids2, binds) <- go subst boxers src_vars
+           ; return (src_var : rep_ids2, binds) }
+    go subst (Boxer boxer : boxers) (src_var : src_vars)
+      = do { (rep_ids1, arg)  <- boxer subst
+           ; (rep_ids2, binds) <- go subst boxers src_vars
+           ; return (rep_ids1 ++ rep_ids2, NonRec src_var arg : binds) }
+    go _ (_:_) [] = pprPanic "mk_boxer" (ppr data_con)
+
+    mk_rep_app :: [(Id,Unboxer)] -> CoreExpr -> UniqSM CoreExpr
+    mk_rep_app [] con_app 
+      = return con_app
+    mk_rep_app ((wrap_arg, unboxer) : prs) con_app 
+      = do { (rep_ids, unbox_fn) <- unboxer wrap_arg
+           ; expr <- mk_rep_app prs (mkVarApps con_app rep_ids)
+           ; return (unbox_fn expr) }
+
+-------------------------
+newLocal :: Type -> UniqSM Var
+newLocal ty = do { uniq <- getUniqueUs 
+                 ; return (mkSysLocal (fsLit "dt") uniq ty) }
+
+-------------------------
+dataConArgRep
+   :: DynFlags 
+   -> FamInstEnvs
+   -> Type -> HsBang
+   -> ( HsBang   -- Like input but with HsUnpackFailed if necy
+      , [(Type, StrictnessMark)]   -- Rep types
+      , (Unboxer, Boxer) )
+
+dataConArgRep _ _ arg_ty HsNoBang
+  = (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
+
+dataConArgRep dflags fam_envs arg_ty (HsBang user_unpack_prag) 
+  | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas
+          -- Don't unpack if we aren't optimising; 
+          -- rather arbitrarily, we use -fomit-iface-pragmas
+          -- as the indication
+  , let mb_co   = topNormaliseType fam_envs arg_ty
+        arg_ty' = case mb_co of { Just (_,ty) -> ty; Nothing -> arg_ty }
+  , isUnpackableType fam_envs arg_ty'
+  , (rep_tys, wrappers) <- dataConArgUnpack arg_ty'
+  , user_unpack_prag
+    || gopt Opt_UnboxStrictFields dflags
+    || (gopt Opt_UnboxSmallStrictFields dflags 
+        && length rep_tys <= 1)  -- See Note [Unpack one-wide fields]
+  = case mb_co of
+      Nothing          -> (HsUnpack Nothing,   rep_tys, wrappers)
+      Just (co,rep_ty) -> (HsUnpack (Just co), rep_tys, wrapCo co rep_ty wrappers)
+
+  | otherwise  -- Record the strict-but-no-unpack decision
+  = strict_but_not_unpacked arg_ty
+
+dataConArgRep _ _ arg_ty HsStrict
+  = strict_but_not_unpacked arg_ty
+
+dataConArgRep _ _ arg_ty (HsUnpack Nothing)
+  | (rep_tys, wrappers) <- dataConArgUnpack arg_ty
+  = (HsUnpack Nothing, rep_tys, wrappers)
+
+dataConArgRep _ _ _ (HsUnpack (Just co))
+  | let co_rep_ty = pSnd (coercionKind co)
+  , (rep_tys, wrappers) <- dataConArgUnpack co_rep_ty
+  = (HsUnpack (Just co), rep_tys, wrapCo co co_rep_ty wrappers)
+
+strict_but_not_unpacked :: Type -> (HsBang, [(Type,StrictnessMark)], (Unboxer, Boxer))
+strict_but_not_unpacked arg_ty
+  = (HsStrict, [(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer))
+
+-------------------------
+wrapCo :: Coercion -> Type -> (Unboxer, Boxer) -> (Unboxer, Boxer)
+wrapCo co rep_ty (unbox_rep, box_rep)  -- co :: arg_ty ~ rep_ty
+  = (unboxer, boxer)
+  where
+    unboxer arg_id = do { rep_id <- newLocal rep_ty
+                        ; (rep_ids, rep_fn) <- unbox_rep rep_id
+                        ; let co_bind = NonRec rep_id (Var arg_id `Cast` co)
+                        ; return (rep_ids, Let co_bind . rep_fn) }
+    boxer = Boxer $ \ subst -> 
+            do { (rep_ids, rep_expr) 
+                    <- case box_rep of
+                         UnitBox -> do { rep_id <- newLocal (TcType.substTy subst rep_ty)
+                                       ; return ([rep_id], Var rep_id) }
+                         Boxer boxer -> boxer subst
+               ; let sco = substCo (tvCvSubst subst) co
+               ; return (rep_ids, rep_expr `Cast` mkSymCo sco) }
+
+------------------------
+seqUnboxer :: Unboxer
+seqUnboxer v = return ([v], \e -> Case (Var v) v (exprType e) [(DEFAULT, [], e)])
+
+unitUnboxer :: Unboxer
+unitUnboxer v = return ([v], \e -> e)
+
+unitBoxer :: Boxer
+unitBoxer = UnitBox
+
+-------------------------
+dataConArgUnpack
+   :: Type
+   ->  ( [(Type, StrictnessMark)]   -- Rep types
+       , (Unboxer, Boxer) )
+
+dataConArgUnpack arg_ty
+  | Just (tc, tc_args) <- splitTyConApp_maybe arg_ty
+  , Just con <- tyConSingleDataCon_maybe tc
+  , let rep_tys = dataConInstArgTys con tc_args
+  = ASSERT( isVanillaDataCon con )
+    ( rep_tys `zip` dataConRepStrictness con
+    ,( \ arg_id ->
+       do { rep_ids <- mapM newLocal rep_tys
+          ; let unbox_fn body
+                  = Case (Var arg_id) arg_id (exprType body)
+                         [(DataAlt con, rep_ids, body)]
+          ; return (rep_ids, unbox_fn) }
+     , Boxer $ \ subst ->
+       do { rep_ids <- mapM (newLocal . TcType.substTy subst) rep_tys
+          ; return (rep_ids, Var (dataConWorkId con)
+                             `mkTyApps` (substTys subst tc_args)
+                             `mkVarApps` rep_ids ) } ) )
+  | otherwise
+  = pprPanic "dataConArgUnpack" (ppr arg_ty)
+    -- An interface file specified Unpacked, but we couldn't unpack it
+
+isUnpackableType :: FamInstEnvs -> Type -> Bool
+-- True if we can unpack the UNPACK fields of the constructor
+-- without involving the NameSet tycons
+isUnpackableType fam_envs ty
+  | Just (tc, _) <- splitTyConApp_maybe ty
+  , Just con <- tyConSingleDataCon_maybe tc
+  , isVanillaDataCon con
+  = ok_con_args (unitNameSet (getName tc)) con
+  | otherwise
+  = False
+  where
+    ok_arg tcs (ty, bang) = no_unpack bang || ok_ty tcs norm_ty
+        where
+          norm_ty = case topNormaliseType fam_envs ty of
+                      Just (_, ty) -> ty
+                      Nothing      -> ty
+    ok_ty tcs ty
+      | Just (tc, _) <- splitTyConApp_maybe ty
+      , let tc_name = getName tc
+      =  not (tc_name `elemNameSet` tcs)
+      && case tyConSingleDataCon_maybe tc of
+            Just con | isVanillaDataCon con
+                    -> ok_con_args (tcs `addOneToNameSet` getName tc) con
+            _ -> True
+      | otherwise 
+      = True
+
+    ok_con_args tcs con
+       = all (ok_arg tcs) (dataConOrigArgTys con `zip` dataConStrictMarks con)
+
+    no_unpack (HsBang True)   = False
+    no_unpack (HsUnpack {})   = False
+    no_unpack _               = True
 \end{code}
 
+Note [Unpack one-wide fields]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The flag UnboxSmallStrictFields ensures that any field that can
+(safely) be unboxed to a word-sized unboxed field, should be so unboxed.
+For example:
+
+    data A = A Int#
+    newtype B = B A
+    data C = C !B
+    data D = D !C
+    data E = E !()
+    data F = F !D
+    data G = G !F !F
+
+All of these should have an Int# as their representation, except
+G which should have two Int#s.  
+
+However 
+
+    data T = T !(S Int)
+    data S = S !a
+
+Here we can represent T with an Int#.
+
+Note [Recursive unboxing]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Be careful not to try to unbox this!
+       data T = MkT {-# UNPACK #-} !T Int
+Reason: consider
+  data R = MkR {-# UNPACK #-} !S Int
+  data S = MkS {-# UNPACK #-} !Int
+The representation arguments of MkR are the *representation* arguments
+of S (plus Int); the rep args of MkS are Int#.  This is obviously no
+good for T, because then we'd get an infinite number of arguments.
+
+But it's the *argument* type that matters. This is fine:
+       data S = MkS S !Int
+because Int is non-recursive.
+
+
+Note [Unpack equality predicates]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have a GADT with a contructor C :: (a~[b]) => b -> T a
+we definitely want that equality predicate *unboxed* so that it
+takes no space at all.  This is easily done: just give it
+an UNPACK pragma. The rest of the unpack/repack code does the
+heavy lifting.  This one line makes every GADT take a word less
+space for each equality predicate, so it's pretty important!
+
+
+\begin{code}
+mk_pred_strict_mark :: PredType -> HsBang
+mk_pred_strict_mark pred 
+  | isEqPred pred = HsUnpack Nothing   -- Note [Unpack equality predicates]
+  | otherwise     = HsNoBang
+\end{code}
 
 %************************************************************************
 %*                                                                      *
@@ -690,7 +807,7 @@ wrapNewTypeBody tycon args result_expr
     wrapFamInstBody tycon args $
     mkCast result_expr (mkSymCo co)
   where
-    co = mkAxInstCo (newTyConCo tycon) args
+    co = mkUnbranchedAxInstCo (newTyConCo tycon) args
 
 -- When unwrapping, we do *not* apply any family coercion, because this will
 -- be done via a CoPat by the type checker.  We have to do it this way as
@@ -700,7 +817,7 @@ wrapNewTypeBody tycon args result_expr
 unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 unwrapNewTypeBody tycon args result_expr
   = ASSERT( isNewTyCon tycon )
-    mkCast result_expr (mkAxInstCo (newTyConCo tycon) args)
+    mkCast result_expr (mkUnbranchedAxInstCo (newTyConCo tycon) args)
 
 -- If the type constructor is a representation type of a data instance, wrap
 -- the expression into a cast adjusting the expression type, which is an
@@ -710,26 +827,34 @@ unwrapNewTypeBody tycon args result_expr
 wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 wrapFamInstBody tycon args body
   | Just co_con <- tyConFamilyCoercion_maybe tycon
-  = mkCast body (mkSymCo (mkAxInstCo co_con args))
+  = mkCast body (mkSymCo (mkUnbranchedAxInstCo co_con args))
   | otherwise
   = body
 
 -- Same as `wrapFamInstBody`, but for type family instances, which are
 -- represented by a `CoAxiom`, and not a `TyCon`
-wrapTypeFamInstBody :: CoAxiom -> [Type] -> CoreExpr -> CoreExpr
-wrapTypeFamInstBody axiom args body
-  = mkCast body (mkSymCo (mkAxInstCo axiom args))
+wrapTypeFamInstBody :: CoAxiom br -> Int -> [Type] -> CoreExpr -> CoreExpr
+wrapTypeFamInstBody axiom ind args body
+  = mkCast body (mkSymCo (mkAxInstCo axiom ind args))
+
+wrapTypeUnbranchedFamInstBody :: CoAxiom Unbranched -> [Type] -> CoreExpr -> CoreExpr
+wrapTypeUnbranchedFamInstBody axiom
+  = wrapTypeFamInstBody axiom 0
 
 unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 unwrapFamInstScrut tycon args scrut
   | Just co_con <- tyConFamilyCoercion_maybe tycon
-  = mkCast scrut (mkAxInstCo co_con args)
+  = mkCast scrut (mkUnbranchedAxInstCo co_con args) -- data instances only
   | otherwise
   = scrut
 
-unwrapTypeFamInstScrut :: CoAxiom -> [Type] -> CoreExpr -> CoreExpr
-unwrapTypeFamInstScrut axiom args scrut
-  = mkCast scrut (mkAxInstCo axiom args)
+unwrapTypeFamInstScrut :: CoAxiom br -> Int -> [Type] -> CoreExpr -> CoreExpr
+unwrapTypeFamInstScrut axiom ind args scrut
+  = mkCast scrut (mkAxInstCo axiom ind args)
+
+unwrapTypeUnbranchedFamInstScrut :: CoAxiom Unbranched -> [Type] -> CoreExpr -> CoreExpr
+unwrapTypeUnbranchedFamInstScrut axiom
+  = unwrapTypeFamInstScrut axiom 0
 \end{code}
 
 
index 7891e65..201f977 100644 (file)
@@ -1,12 +1,14 @@
 \begin{code}
 module MkId where
 import Name( Name )
-import DataCon( DataCon, DataConIds )
+import Var( Id )
+import {-# SOURCE #-} DataCon( DataCon )
 import {-# SOURCE #-} PrimOp( PrimOp )
-import Id( Id )
 
-mkDataConIds :: Name -> Name -> DataCon -> DataConIds
-mkPrimOpId :: PrimOp -> Id
+data DataConBoxer
+
+mkDataConWorkId :: Name -> DataCon -> Id
+mkPrimOpId      :: PrimOp -> Id
 \end{code}
 
 
index ff69d7e..6093419 100644 (file)
@@ -45,12 +45,11 @@ cmmPipeline hsc_env topSRT prog =
      tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog
 
      (topSRT, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags topSRT tops
-     dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms)
+     dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" cmms
 
      return (topSRT, cmms)
 
 
-
 cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl])
 cpsTop _ p@(CmmData {}) = return (mapEmpty, [p])
 cpsTop hsc_env proc =
@@ -63,7 +62,7 @@ cpsTop hsc_env proc =
        --
        CmmProc h l v g <- {-# SCC "cmmCfgOpts(1)" #-}
             return $ cmmCfgOptsProc splitting_proc_points proc
-       dump Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g
+       dump Opt_D_dump_cmm_cfg "Post control-flow optimsations" g
 
        let !TopInfo {stack_info=StackInfo { arg_space = entry_off
                                           , do_layout = do_layout }} = h
@@ -71,7 +70,7 @@ cpsTop hsc_env proc =
        ----------- Eliminate common blocks -------------------------------------
        g <- {-# SCC "elimCommonBlocks" #-}
             condPass Opt_CmmElimCommonBlocks elimCommonBlocks g
-                     Opt_D_dump_cmmz_cbe "Post common block elimination"
+                     Opt_D_dump_cmm_cbe "Post common block elimination"
 
        -- Any work storing block Labels must be performed _after_
        -- elimCommonBlocks
@@ -86,14 +85,14 @@ cpsTop hsc_env proc =
                   return call_pps
 
        let noncall_pps = proc_points `setDifference` call_pps
-       when (not (setNull noncall_pps) && dopt Opt_D_dump_cmmz dflags) $
+       when (not (setNull noncall_pps) && dopt Opt_D_dump_cmm dflags) $
          pprTrace "Non-call proc points: " (ppr noncall_pps) $ return ()
 
        ----------- Sink and inline assignments *before* stack layout -----------
        {-  Maybe enable this later
        g <- {-# SCC "sink1" #-}
-            condPass Opt_CmmSink cmmSink g
-                     Opt_D_dump_cmmz_rewrite "Sink assignments (1)"
+            condPass Opt_CmmSink (cmmSink dflags) g
+                     Opt_D_dump_cmm_rewrite "Sink assignments (1)"
        -}
 
        ----------- Layout the stack and manifest Sp ----------------------------
@@ -102,32 +101,32 @@ cpsTop hsc_env proc =
             if do_layout
                then runUniqSM $ cmmLayoutStack dflags proc_points entry_off g
                else return (g, mapEmpty)
-       dump Opt_D_dump_cmmz_sp "Layout Stack" g
+       dump Opt_D_dump_cmm_sp "Layout Stack" g
 
        ----------- Sink and inline assignments *after* stack layout ------------
        g <- {-# SCC "sink2" #-}
             condPass Opt_CmmSink (cmmSink dflags) g
-                     Opt_D_dump_cmmz_rewrite "Sink assignments (2)"
+                     Opt_D_dump_cmm_rewrite "Sink assignments (2)"
 
        ------------- CAF analysis ----------------------------------------------
        let cafEnv = {-# SCC "cafAnal" #-} cafAnal g
-       dumpIfSet_dyn dflags Opt_D_dump_cmmz "CAFEnv" (ppr cafEnv)
+       dumpIfSet_dyn dflags Opt_D_dump_cmm "CAFEnv" (ppr cafEnv)
 
        if splitting_proc_points
           then do
             ------------- Split into separate procedures -----------------------
             pp_map  <- {-# SCC "procPointAnalysis" #-} runUniqSM $
                              procPointAnalysis proc_points g
-            dumpWith dflags Opt_D_dump_cmmz_procmap "procpoint map" pp_map
+            dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map" pp_map
             gs <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
                   splitAtProcPoints dflags l call_pps proc_points pp_map
                                     (CmmProc h l v g)
-            dumps Opt_D_dump_cmmz_split "Post splitting" gs
+            dumps Opt_D_dump_cmm_split "Post splitting" gs
      
             ------------- Populate info tables with stack info -----------------
             gs <- {-# SCC "setInfoTableStackMap" #-}
                   return $ map (setInfoTableStackMap dflags stackmaps) gs
-            dumps Opt_D_dump_cmmz_info "after setInfoTableStackMap" gs
+            dumps Opt_D_dump_cmm_info "after setInfoTableStackMap" gs
      
             ----------- Control-flow optimisations -----------------------------
             gs <- {-# SCC "cmmCfgOpts(2)" #-}
@@ -136,7 +135,7 @@ cpsTop hsc_env proc =
                              else gs
             gs <- return (map removeUnreachableBlocksProc gs)
                 -- Note [unreachable blocks]
-            dumps Opt_D_dump_cmmz_cfg "Post control-flow optimsations" gs
+            dumps Opt_D_dump_cmm_cfg "Post control-flow optimsations" gs
 
             return (cafEnv, gs)
 
@@ -147,7 +146,7 @@ cpsTop hsc_env proc =
             ------------- Populate info tables with stack info -----------------
             g <- {-# SCC "setInfoTableStackMap" #-}
                   return $ setInfoTableStackMap dflags stackmaps g
-            dump' Opt_D_dump_cmmz_info "after setInfoTableStackMap" g
+            dump' Opt_D_dump_cmm_info "after setInfoTableStackMap" g
      
             ----------- Control-flow optimisations -----------------------------
             g <- {-# SCC "cmmCfgOpts(2)" #-}
@@ -156,7 +155,7 @@ cpsTop hsc_env proc =
                              else g
             g <- return (removeUnreachableBlocksProc g)
                 -- Note [unreachable blocks]
-            dump' Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g
+            dump' Opt_D_dump_cmm_cfg "Post control-flow optimsations" g
 
             return (cafEnv, [g])
 
@@ -254,10 +253,10 @@ dumpGraph dflags flag name g = do
 
 dumpWith :: Outputable a => DynFlags -> DumpFlag -> String -> a -> IO ()
 dumpWith dflags flag txt g = do
-         -- ToDo: No easy way of say "dump all the cmmz, *and* split
-         -- them into files."  Also, -ddump-cmmz doesn't play nicely
+         -- ToDo: No easy way of say "dump all the cmm, *and* split
+         -- them into files."  Also, -ddump-cmm doesn't play nicely
          -- with -ddump-to-file, since the headers get omitted.
    dumpIfSet_dyn dflags flag txt (ppr g)
    when (not (dopt flag dflags)) $
-      dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (ppr g)
+      dumpIfSet_dyn dflags Opt_D_dump_cmm txt (ppr g)
 
index fb94b95..abf2393 100644 (file)
@@ -315,7 +315,7 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
                  stack_info = StackInfo { arg_space = 0
                                         , updfr_space =  Nothing
                                         , do_layout = True }
-                               -- cannot use panic, this is printed by -ddump-cmmz
+                               -- cannot use panic, this is printed by -ddump-cmm
 
          -- References to procpoint IDs can now be replaced with the
          -- infotable's label
index c3f456b..a4a1958 100644 (file)
@@ -43,6 +43,7 @@ import Kind
 import Type
 import TypeRep
 import TyCon
+import CoAxiom
 import BasicTypes
 import StaticFlags
 import ListSetOps
@@ -50,6 +51,8 @@ import PrelNames
 import Outputable
 import FastString
 import Util
+import Unify
+import InstEnv ( instanceBindFun )
 import Control.Monad
 import MonadUtils
 import Data.Maybe
@@ -410,6 +413,30 @@ kind coercions and produce the following substitution which is to be
 applied in the type variables:
   k_ag   ~~>   * -> *
 
+Note [Conflict checking with AxiomInstCo]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the following type family and axiom:
+
+type family Equal (a :: k) (b :: k) :: Bool
+type instance where
+  Equal a a = True
+  Equal a b = False
+--
+Equal :: forall k::BOX. k -> k -> Bool
+axEqual :: { forall k::BOX. forall a::k. Equal k a a ~ True
+           ; forall k::BOX. forall a::k. forall b::k. Equal k a b ~ False }
+
+We wish to disallow (axEqual[1] <*> <Int> <Int). (Recall that the index is 0-based,
+so this is the second branch of the axiom.) The problem is that, on the surface, it
+seems that (axEqual[1] <*> <Int> <Int>) :: (Equal * Int Int ~ False) and that all is
+OK. But, all is not OK: we want to use the first branch of the axiom in this case,
+not the second. The problem is that the parameters of the first branch can unify with
+the supplied coercions, thus meaning that the first branch should be taken. See also
+Note [Instance checking within groups] in types/FamInstEnv.lhs.
+
+However, if the right-hand side of the previous branch coincides with the right-hand
+side of the selected branch, we wish to accept the AxiomInstCo. See also Note
+[Confluence checking within groups], also in types/FamInstEnv.lhs.
 
 %************************************************************************
 %*                                                                     *
@@ -909,24 +936,40 @@ lintCoercion (InstCo co arg_ty)
             -> failWithL (ptext (sLit "Kind mis-match in inst coercion"))
          _ -> failWithL (ptext (sLit "Bad argument of inst")) }
 
-lintCoercion co@(AxiomInstCo (CoAxiom { co_ax_tvs = ktvs
-                                      , co_ax_lhs = lhs
-                                      , co_ax_rhs = rhs })
-                             cos)
-  = do {  -- See Note [Kind instantiation in coercions]
-         unless (equalLength ktvs cos) (bad_ax (ptext (sLit "lengths")))
+lintCoercion co@(AxiomInstCo con ind cos)
+  = do { unless (0 <= ind && ind < brListLength (coAxiomBranches con))
+                (bad_ax (ptext (sLit "index out of range")))
+         -- See Note [Kind instantiation in coercions]
+       ; let CoAxBranch { cab_tvs = ktvs
+                        , cab_lhs = lhs
+                        , cab_rhs = rhs } = coAxiomNthBranch con ind
+       ; unless (equalLength ktvs cos) (bad_ax (ptext (sLit "lengths")))
        ; in_scope <- getInScope
        ; let empty_subst = mkTvSubst in_scope emptyTvSubstEnv
        ; (subst_l, subst_r) <- foldlM check_ki 
                                       (empty_subst, empty_subst) 
                                       (ktvs `zip` cos)
-       ; let lhs' = Type.substTy subst_l lhs
+       ; let lhs' = Type.substTys subst_l lhs
              rhs' = Type.substTy subst_r rhs
-       ; return (typeKind lhs', lhs', rhs') }
+       ; case check_no_conflict lhs' (ind - 1) of
+           Just bad_index -> bad_ax $ ptext (sLit "inconsistent with") <+> (ppr bad_index)
+           Nothing -> return ()
+       ; return (typeKind rhs', mkTyConApp (coAxiomTyCon con) lhs', rhs') }
   where
     bad_ax what = addErrL (hang (ptext (sLit "Bad axiom application") <+> parens what)
                         2 (ppr co))
 
+      -- See Note [Conflict checking with AxiomInstCo]
+    check_no_conflict :: [Type] -> Int -> Maybe Int
+    check_no_conflict _ (-1) = Nothing
+    check_no_conflict lhs' j
+      | SurelyApart <- tcApartTys instanceBindFun lhs' lhsj
+      = check_no_conflict lhs' (j-1)
+      | otherwise
+      = Just j
+      where
+        (CoAxBranch { cab_lhs = lhsj }) = coAxiomNthBranch con j
+
     check_ki (subst_l, subst_r) (ktv, co)
       = do { (k, t1, t2) <- lintCoercion co
            ; let ktv_kind = Type.substTy subst_l (tyVarKind ktv)
index 287f080..15de06c 100644 (file)
@@ -74,6 +74,7 @@ data Ty
   | UnsafeCoercion Ty Ty
   | InstCoercion Ty Ty
   | NthCoercion Int Ty
+  | AxiomCoercion (Qual Tcon) Int [Ty]
   | LRCoercion LeftOrRight Ty
 
 data LeftOrRight = CLeft | CRight
index 164146a..aa5e365 100644 (file)
@@ -20,6 +20,7 @@ import Module
 import CoreSyn
 import HscTypes        
 import TyCon
+import CoAxiom
 -- import Class
 import TypeRep
 import Type
@@ -112,7 +113,7 @@ collect_tdefs _ _ tdefs = tdefs
 qtc :: DynFlags -> TyCon -> C.Qual C.Tcon
 qtc dflags = make_con_qid dflags . tyConName
 
-qcc :: DynFlags -> CoAxiom -> C.Qual C.Tcon
+qcc :: DynFlags -> CoAxiom br -> C.Qual C.Tcon
 qcc dflags = make_con_qid dflags . co_ax_name
 
 make_cdef :: DynFlags -> DataCon -> C.Cdef
@@ -322,7 +323,7 @@ make_co dflags (TyConAppCo tc cos)   = make_conAppCo dflags (qtc dflags tc) cos
 make_co dflags (AppCo c1 c2)         = C.Tapp (make_co dflags c1) (make_co dflags c2)
 make_co dflags (ForAllCo tv co)      = C.Tforall (make_tbind tv) (make_co dflags co)
 make_co _      (CoVarCo cv)          = C.Tvar (make_var_id (coVarName cv))
-make_co dflags (AxiomInstCo cc cos)  = make_conAppCo dflags (qcc dflags cc) cos
+make_co dflags (AxiomInstCo cc ind cos) = C.AxiomCoercion (qcc dflags cc) ind (map (make_co dflags) cos)
 make_co dflags (UnsafeCo t1 t2)      = C.UnsafeCoercion (make_ty dflags t1) (make_ty dflags t2)
 make_co dflags (SymCo co)            = C.SymCoercion (make_co dflags co)
 make_co dflags (TransCo c1 c2)       = C.TransCoercion (make_co dflags c1) (make_co dflags c2)
index 6bc78a8..148464b 100644 (file)
@@ -465,7 +465,7 @@ data CoercionMap a
        , km_app    :: CoercionMap (CoercionMap a)
        , km_forall :: CoercionMap (TypeMap a)
        , km_var    :: VarMap a
-       , km_axiom  :: NameEnv (ListMap CoercionMap a)
+       , km_axiom  :: NameEnv (IntMap.IntMap (ListMap CoercionMap a))
        , km_unsafe :: TypeMap (TypeMap a)
        , km_sym    :: CoercionMap a
        , km_trans  :: CoercionMap (CoercionMap a)
@@ -503,7 +503,7 @@ mapC f (KM { km_refl = krefl, km_tc_app = ktc
        , km_app    = mapTM (mapTM f) kapp
        , km_forall = mapTM (mapTM f) kforall
        , km_var    = mapTM f kvar
-       , km_axiom  = mapNameEnv (mapTM f) kax
+       , km_axiom  = mapNameEnv (IntMap.map (mapTM f)) kax
        , km_unsafe = mapTM (mapTM f) kunsafe
        , km_sym    = mapTM f ksym
        , km_trans  = mapTM (mapTM f) ktrans
@@ -517,36 +517,36 @@ lkC env co m
   | EmptyKM <- m = Nothing
   | otherwise    = go co m
   where
-    go (Refl ty)           = km_refl   >.> lkT env ty
-    go (TyConAppCo tc cs)  = km_tc_app >.> lkNamed tc >=> lkList (lkC env) cs
-    go (AxiomInstCo ax cs) = km_axiom  >.> lkNamed ax >=> lkList (lkC env) cs
-    go (AppCo c1 c2)       = km_app    >.> lkC env c1 >=> lkC env c2
-    go (TransCo c1 c2)     = km_trans  >.> lkC env c1 >=> lkC env c2
-    go (UnsafeCo t1 t2)    = km_unsafe >.> lkT env t1 >=> lkT env t2
-    go (InstCo c t)        = km_inst   >.> lkC env c  >=> lkT env t
-    go (ForAllCo v c)      = km_forall >.> lkC (extendCME env v) c >=> lkBndr env v
-    go (CoVarCo v)         = km_var    >.> lkVar env v
-    go (SymCo c)           = km_sym    >.> lkC env c
-    go (NthCo n c)         = km_nth    >.> lookupTM n >=> lkC env c
-    go (LRCo CLeft  c)     = km_left   >.> lkC env c
-    go (LRCo CRight c)     = km_right  >.> lkC env c
+    go (Refl ty)               = km_refl   >.> lkT env ty
+    go (TyConAppCo tc cs)      = km_tc_app >.> lkNamed tc >=> lkList (lkC env) cs
+    go (AxiomInstCo ax ind cs) = km_axiom  >.> lkNamed ax >=> lookupTM ind >=> lkList (lkC env) cs
+    go (AppCo c1 c2)           = km_app    >.> lkC env c1 >=> lkC env c2
+    go (TransCo c1 c2)         = km_trans  >.> lkC env c1 >=> lkC env c2
+    go (UnsafeCo t1 t2)        = km_unsafe >.> lkT env t1 >=> lkT env t2
+    go (InstCo c t)            = km_inst   >.> lkC env c  >=> lkT env t
+    go (ForAllCo v c)          = km_forall >.> lkC (extendCME env v) c >=> lkBndr env v
+    go (CoVarCo v)             = km_var    >.> lkVar env v
+    go (SymCo c)               = km_sym    >.> lkC env c
+    go (NthCo n c)             = km_nth    >.> lookupTM n >=> lkC env c
+    go (LRCo CLeft  c)         = km_left   >.> lkC env c
+    go (LRCo CRight c)         = km_right  >.> lkC env c
 
 xtC :: CmEnv -> Coercion -> XT a -> CoercionMap a -> CoercionMap a
 xtC env co f EmptyKM = xtC env co f wrapEmptyKM
-xtC env (Refl ty)           f m = m { km_refl   = km_refl m   |> xtT env ty f }
-xtC env (TyConAppCo tc cs)  f m = m { km_tc_app = km_tc_app m |> xtNamed tc |>> xtList (xtC env) cs f }
-xtC env (AxiomInstCo ax cs) f m = m { km_axiom  = km_axiom m  |> xtNamed ax |>> xtList (xtC env) cs f }
-xtC env (AppCo c1 c2)       f m = m { km_app    = km_app m    |> xtC env c1 |>> xtC env c2 f }
-xtC env (TransCo c1 c2)     f m = m { km_trans  = km_trans m  |> xtC env c1 |>> xtC env c2 f }
-xtC env (UnsafeCo t1 t2)    f m = m { km_unsafe = km_unsafe m |> xtT env t1 |>> xtT env t2 f }
-xtC env (InstCo c t)        f m = m { km_inst   = km_inst m   |> xtC env c  |>> xtT env t  f }
-xtC env (ForAllCo v c)      f m = m { km_forall = km_forall m |> xtC (extendCME env v) c 
-                                                  |>> xtBndr env v f }
-xtC env (CoVarCo v)         f m = m { km_var   = km_var m   |> xtVar env v f }
-xtC env (SymCo c)           f m = m { km_sym   = km_sym m   |> xtC env   c f }
-xtC env (NthCo n c)         f m = m { km_nth   = km_nth m   |> xtInt n |>> xtC env c f } 
-xtC env (LRCo CLeft  c)     f m = m { km_left  = km_left  m |> xtC env c f } 
-xtC env (LRCo CRight c)     f m = m { km_right         = km_right m |> xtC env c f } 
+xtC env (Refl ty)               f m = m { km_refl   = km_refl m   |> xtT env ty f }
+xtC env (TyConAppCo tc cs)      f m = m { km_tc_app = km_tc_app m |> xtNamed tc |>> xtList (xtC env) cs f }
+xtC env (AxiomInstCo ax ind cs) f m = m { km_axiom  = km_axiom m  |> xtNamed ax |>> xtInt ind |>> xtList (xtC env) cs f }
+xtC env (AppCo c1 c2)           f m = m { km_app    = km_app m    |> xtC env c1 |>> xtC env c2 f }
+xtC env (TransCo c1 c2)         f m = m { km_trans  = km_trans m  |> xtC env c1 |>> xtC env c2 f }
+xtC env (UnsafeCo t1 t2)        f m = m { km_unsafe = km_unsafe m |> xtT env t1 |>> xtT env t2 f }
+xtC env (InstCo c t)            f m = m { km_inst   = km_inst m   |> xtC env c  |>> xtT env t  f }
+xtC env (ForAllCo v c)          f m = m { km_forall = km_forall m |> xtC (extendCME env v) c 
+                                                      |>> xtBndr env v f }
+xtC env (CoVarCo v)             f m = m { km_var    = km_var m |> xtVar env  v f }
+xtC env (SymCo c)               f m = m { km_sym    = km_sym m |> xtC env    c f }
+xtC env (NthCo n c)             f m = m { km_nth    = km_nth m |> xtInt n |>> xtC env c f } 
+xtC env (LRCo CLeft  c)         f m = m { km_left   = km_left  m |> xtC env c f } 
+xtC env (LRCo CRight c)         f m = m { km_right  = km_right m |> xtC env c f } 
 
 fdC :: (a -> b -> b) -> CoercionMap a -> b -> b
 fdC _ EmptyKM = \z -> z
@@ -555,7 +555,7 @@ fdC k m = foldTM k (km_refl m)
         . foldTM (foldTM k) (km_app m)
         . foldTM (foldTM k) (km_forall m)
         . foldTM k (km_var m)
-        . foldTM (foldTM k) (km_axiom m)
+        . foldTM (foldTM (foldTM k)) (km_axiom m)
         . foldTM (foldTM k) (km_unsafe m)
         . foldTM k (km_sym m)
         . foldTM (foldTM k) (km_trans m)
index 66e29f8..b74c885 100644 (file)
@@ -114,11 +114,12 @@ do_loop :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
 do_loop ids b_ty c_ty d_ty f
   = mkApps (loop_id ids) [Type b_ty, Type d_ty, Type c_ty, f]
 
--- map_arrow (f :: b -> c) (g :: a c d) = arr f >>> g :: a b d
-do_map_arrow :: DsCmdEnv -> Type -> Type -> Type ->
+-- premap :: forall b c d. (b -> c) -> a c d -> a b d
+-- premap f g = arr f >>> g
+do_premap :: DsCmdEnv -> Type -> Type -> Type ->
                CoreExpr -> CoreExpr -> CoreExpr
-do_map_arrow ids b_ty c_ty d_ty f c
-   = do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) c
+do_premap ids b_ty c_ty d_ty f g
+   = do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) g
 
 mkFailExpr :: HsMatchContext Id -> Type -> DsM CoreExpr
 mkFailExpr ctxt ty
@@ -242,7 +243,7 @@ Translation of arrow abstraction
 
 --     A | xs |- c :: [] t'        ---> c'
 --     --------------------------
---     A |- proc p -> c :: a t t'  ---> arr (\ p -> (xs)) >>> c'
+--     A |- proc p -> c :: a t t'  ---> premap (\ p -> (xs)) c'
 --
 --             where (xs) is the tuple of variables bound by p
 
@@ -259,7 +260,7 @@ dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids)) = do
     var <- selectSimpleMatchVarL pat
     match_code <- matchSimply (Var var) ProcExpr pat (mkBigCoreVarTup env_ids) fail_expr
     let pat_ty = hsLPatType pat
-        proc_code = do_map_arrow meth_ids pat_ty env_ty cmd_ty
+        proc_code = do_premap meth_ids pat_ty env_ty cmd_ty
                     (Lam var match_code)
                     core_cmd
     return (mkLets meth_binds proc_code)
@@ -292,7 +293,7 @@ dsCmd   :: DsCmdEnv         -- arrow combinators
 --     -----------------------------
 --     A | xs |- f -< arg :: [ts] t'
 --
---             ---> arr (\ ((xs)*ts) -> (arg*ts)) >>> f
+--             ---> premap (\ ((xs)*ts) -> (arg*ts)) f
 
 dsCmd ids local_vars stack res_ty
         (HsCmdArrApp arrow arg arrow_ty HsFirstOrderApp _)
@@ -305,7 +306,7 @@ dsCmd ids local_vars stack res_ty
     stack_ids  <- mapM newSysLocalDs stack
     core_make_arg <- matchEnvStack env_ids stack_ids
                       (foldl mkCorePairExpr core_arg (map Var stack_ids))
-    return (do_map_arrow ids
+    return (do_premap ids
               (envStackType env_ids stack)
               arg_ty
               res_ty
@@ -318,7 +319,7 @@ dsCmd ids local_vars stack res_ty
 --     ------------------------------
 --     A | xs |- f -<< arg :: [ts] t'
 --
---             ---> arr (\ ((xs)*ts) -> (f,(arg*ts))) >>> app
+--             ---> premap (\ ((xs)*ts) -> (f,(arg*ts))) app
 
 dsCmd ids local_vars stack res_ty
         (HsCmdArrApp arrow arg arrow_ty HsHigherOrderApp _)
@@ -334,7 +335,7 @@ dsCmd ids local_vars stack res_ty
           (mkCorePairExpr core_arrow
              (foldl mkCorePairExpr core_arg (map Var stack_ids)))
                              
-    return (do_map_arrow ids
+    return (do_premap ids
               (envStackType env_ids stack)
               (mkCorePairTy arrow_ty arg_ty)
               res_ty
@@ -348,7 +349,7 @@ dsCmd ids local_vars stack res_ty
 --     ------------------------
 --     A | xs |- c e :: [ts] t'
 --
---             ---> arr (\ ((xs)*ts) -> let z = e in (((ys),z)*ts)) >>> c
+--             ---> premap (\ ((xs)*ts) -> let z = e in (((ys),z)*ts)) c
 
 dsCmd ids local_vars stack res_ty (HsCmdApp cmd arg) env_ids = do
     core_arg <- dsLExpr arg
@@ -365,7 +366,7 @@ dsCmd ids local_vars stack res_ty (HsCmdApp cmd arg) env_ids = do
                         (buildEnvStack env_ids' (arg_id:stack_ids))
     -- match the environment and stack against the input
     core_map <- matchEnvStack env_ids stack_ids core_body
-    return (do_map_arrow ids
+    return (do_premap ids
                       (envStackType env_ids stack)
                       (envStackType env_ids' stack')
                       res_ty
@@ -378,7 +379,7 @@ dsCmd ids local_vars stack res_ty (HsCmdApp cmd arg) env_ids = do
 --     -----------------------------------------------
 --     A | xs |- \ p1 ... pk -> c :: [t1:...:tk:ts] t'
 --
---             ---> arr (\ ((((xs), p1), ... pk)*ts) -> ((ys)*ts)) >>> c
+--             ---> premap (\ ((((xs), p1), ... pk)*ts) -> ((ys)*ts)) c
 
 dsCmd ids local_vars stack res_ty
         (HsCmdLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] _))
@@ -405,7 +406,7 @@ dsCmd ids local_vars stack res_ty
     match_code <- matchSimplys (map Var actual_ids) LambdaExpr pats core_expr fail_expr
     -- match the old environment and stack against the input
     select_code <- matchEnvStack env_ids stack_ids match_code
-    return (do_map_arrow ids in_ty in_ty' res_ty select_code core_body,
+    return (do_premap ids in_ty in_ty' res_ty select_code core_body,
             free_vars `minusVarSet` pat_vars)
 
 dsCmd ids local_vars stack res_ty (HsCmdPar cmd) env_ids
@@ -417,9 +418,9 @@ dsCmd ids local_vars stack res_ty (HsCmdPar cmd) env_ids
 --     ----------------------------------------
 --     A | xs |- if e then c1 else c2 :: [ts] t
 --
---             ---> arr (\ ((xs)*ts) ->
---                     if e then Left ((xs1)*ts) else Right ((xs2)*ts)) >>>
---                  c1 ||| c2
+--             ---> premap (\ ((xs)*ts) ->
+--                      if e then Left ((xs1)*ts) else Right ((xs2)*ts))
+--                    (c1 ||| c2)
 
 dsCmd ids local_vars stack res_ty (HsCmdIf mb_fun cond then_cmd else_cmd)
         env_ids = do
@@ -450,7 +451,7 @@ dsCmd ids local_vars stack res_ty (HsCmdIf mb_fun cond then_cmd else_cmd)
        Nothing  -> matchEnvStack env_ids stack_ids $
                    mkIfThenElse core_cond core_left core_right
 
-    return (do_map_arrow ids in_ty sum_ty res_ty
+    return (do_premap ids in_ty sum_ty res_ty
                 core_if
                 (do_choice ids then_ty else_ty res_ty core_then core_else),
         fvs_cond `unionVarSet` fvs_then `unionVarSet` fvs_else)
@@ -463,11 +464,11 @@ Case commands are treated in much the same way as if commands
 
 is translated to
 
-       arr (\ ((xs)*ts) -> case e of
+       premap (\ ((xs)*ts) -> case e of
                p1 -> (Left (Left (xs1)*ts))
                p2 -> Left ((Right (xs2)*ts))
-               p3 -> Right ((xs3)*ts)) >>>
-       (c1 ||| c2) ||| c3
+               p3 -> Right ((xs3)*ts))
+       ((c1 ||| c2) ||| c3)
 
 The idea is to extract the commands from the case, build a balanced tree
 of choices, and replace the commands with expressions that build tagged
@@ -532,14 +533,14 @@ dsCmd ids local_vars stack res_ty (HsCmdCase exp (MatchGroup matches match_ty))
     
     core_body <- dsExpr (HsCase exp (MatchGroup matches' match_ty'))
     core_matches <- matchEnvStack env_ids stack_ids core_body
-    return (do_map_arrow ids in_ty sum_ty res_ty core_matches core_choices,
+    return (do_premap ids in_ty sum_ty res_ty core_matches core_choices,
             exprFreeIds core_body  `intersectVarSet` local_vars)
 
 --     A | ys |- c :: [ts] t
 --     ----------------------------------
 --     A | xs |- let binds in c :: [ts] t
 --
---             ---> arr (\ ((xs)*ts) -> let binds in ((ys)*ts)) >>> c
+--             ---> premap (\ ((xs)*ts) -> let binds in ((ys)*ts)) c
 
 dsCmd ids local_vars stack res_ty (HsCmdLet binds body) env_ids = do
     let
@@ -552,7 +553,7 @@ dsCmd ids local_vars stack res_ty (HsCmdLet binds body) env_ids = do
     core_binds <- dsLocalBinds binds (buildEnvStack env_ids' stack_ids)
     -- match the old environment and stack against the input
     core_map <- matchEnvStack env_ids stack_ids core_binds
-    return (do_map_arrow ids
+    return (do_premap ids
                         (envStackType env_ids stack)
                         (envStackType env_ids' stack)
                         res_ty
@@ -583,7 +584,7 @@ dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c)
 
 --     A | ys |- c :: [ts] t   (ys <= xs)
 --     ---------------------
---     A | xs |- c :: [ts] t   ---> arr_ts (\ (xs) -> (ys)) >>> c
+--     A | xs |- c :: [ts] t   ---> premap_ts (\ (xs) -> (ys)) c
 
 dsTrimCmdArg
        :: IdSet                -- set of local vars available to this command
@@ -600,7 +601,7 @@ dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack cmd_ty ids)) = do
         in_ty = envStackType env_ids stack
         in_ty' = envStackType env_ids' stack
         arg_code = if env_ids' == env_ids then core_cmd else
-                do_map_arrow meth_ids in_ty in_ty' cmd_ty trim_code core_cmd
+                do_premap meth_ids in_ty in_ty' cmd_ty trim_code core_cmd
     return (mkLets meth_binds arg_code, free_vars)
 
 -- Given A | xs |- c :: [ts] t, builds c with xs fed back.
@@ -700,8 +701,8 @@ dsCmdStmt
 --     ------------------------------
 --     A | xs |- do { c; ss } :: [] t'
 --
---             ---> arr (\ (xs) -> ((xs1),(xs'))) >>> first c >>>
---                     arr snd >>> ss
+--             ---> premap (\ (xs) -> ((xs1),(xs')))
+--                     (first c >>> arr snd) >>> ss
 
 dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do
     (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars [] c_ty cmd
@@ -714,7 +715,7 @@ dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do
        before_c_ty = mkCorePairTy in_ty1 out_ty
        after_c_ty = mkCorePairTy c_ty out_ty
     snd_fn <- mkSndExpr c_ty out_ty
-    return (do_map_arrow ids in_ty before_c_ty out_ty core_mux $
+    return (do_premap ids in_ty before_c_ty out_ty core_mux $
                do_compose ids before_c_ty after_c_ty out_ty
                        (do_first ids in_ty1 c_ty out_ty core_cmd) $
                do_arr ids after_c_ty out_ty snd_fn,
@@ -726,8 +727,8 @@ dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do
 --     -----------------------------------
 --     A | xs |- do { p <- c; ss } :: [] t'
 --
---             ---> arr (\ (xs) -> ((xs1),(xs2))) >>> first c >>>
---                     arr (\ (p, (xs2)) -> (xs')) >>> ss
+--             ---> premap (\ (xs) -> ((xs1),(xs2)))
+--                     (first c >>> arr (\ (p, (xs2)) -> (xs'))) >>> ss
 --
 -- It would be simpler and more consistent to do this using second,
 -- but that's likely to be defined in terms of first.
@@ -769,7 +770,7 @@ dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _) env_ids = do
        in_ty1 = mkBigCoreVarTupTy env_ids1
        in_ty2 = mkBigCoreVarTupTy env_ids2
        before_c_ty = mkCorePairTy in_ty1 in_ty2
-    return (do_map_arrow ids in_ty before_c_ty out_ty core_mux $
+    return (do_premap ids in_ty before_c_ty out_ty core_mux $
                do_compose ids before_c_ty after_c_ty out_ty
                        (do_first ids in_ty1 pat_ty in_ty2 core_cmd) $
                do_arr ids after_c_ty out_ty proj_expr,
@@ -847,7 +848,7 @@ dsCmdStmt ids local_vars out_ids
     let
         env_ty = mkBigCoreVarTupTy env_ids
         out_ty = mkBigCoreVarTupTy out_ids
-        core_body = do_map_arrow ids env_ty pre_pair_ty out_ty
+        core_body = do_premap ids env_ty pre_pair_ty out_ty
                 pre_loop_fn
                 (do_compose ids pre_pair_ty post_pair_ty out_ty
                         (do_first ids env1_ty later_ty env2_ty
@@ -859,9 +860,8 @@ dsCmdStmt ids local_vars out_ids
 
 dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s)
 
---     loop (arr (\ ((env1_ids), ~(rec_ids)) -> (env_ids)) >>>
---           ss >>>
---           arr (\ (out_ids) -> ((later_rets),(rec_rets))) >>>
+--     loop (premap (\ ((env1_ids), ~(rec_ids)) -> (env_ids))
+--           (ss >>> arr (\ (out_ids) -> ((later_rets),(rec_rets))))) >>>
 
 dsRecCmd
         :: DsCmdEnv            -- arrow combinators
@@ -922,12 +922,12 @@ dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do
 
     squash_pair_fn <- matchEnvStack env1_ids [rec_id] core_body
 
-    -- loop (arr squash_pair_fn >>> ss >>> arr mk_pair_fn)
+    -- loop (premap squash_pair_fn (ss >>> arr mk_pair_fn))
 
     let
         env_ty = mkBigCoreVarTupTy env_ids
         core_loop = do_loop ids env1_ty later_ty rec_ty
-                (do_map_arrow ids in_pair_ty env_ty out_pair_ty
+                (do_premap ids in_pair_ty env_ty out_pair_ty
                         squash_pair_fn
                         (do_compose ids env_ty out_ty out_pair_ty
                                 core_stmts
index 4b7f8c0..78d8569 100644 (file)
@@ -830,7 +830,8 @@ ds_tc_coercion subst tc_co
     go (TcForAllCo tv co)     = mkForAllCo tv' (ds_tc_coercion subst' co)
                               where
                                 (subst', tv') = Coercion.substTyVarBndr subst tv
-    go (TcAxiomInstCo ax tys) = mkAxInstCo ax (map (Coercion.substTy subst) tys)
+    go (TcAxiomInstCo ax ind tys)
+                              = mkAxInstCo ax ind (map (Coercion.substTy subst) tys)
     go (TcSymCo co)           = mkSymCo (go co)
     go (TcTransCo co1 co2)    = mkTransCo (go co1) (go co2)
     go (TcNthCo n co)         = mkNthCo n (go co)
index 405b768..fcaff4b 100644 (file)
@@ -65,7 +65,6 @@ import Bag
 import DynFlags
 import FastString
 import ForeignCall
-import MonadUtils
 import Util
 
 import Data.Maybe
@@ -203,31 +202,21 @@ in repTyClD and repC.
 
 -- represent associated family instances
 --
-repTyClDs :: [LTyClDecl Name] -> DsM [Core TH.DecQ]
-repTyClDs ds = liftM de_loc (mapMaybeM repTyClD ds)
-
-
 repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
 
-repTyClD (L loc (TyFamily { tcdFlavour = flavour,
-                           tcdLName   = tc, tcdTyVars = tvs, 
-                           tcdKindSig = opt_kind }))
-  = do { tc1 <- lookupLOcc tc          -- See note [Binders and occurrences] 
-       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
-           do { flav   <- repFamilyFlavour flavour
-             ; case opt_kind of 
-                  Nothing -> repFamilyNoKind flav tc1 bndrs
-                  Just ki -> do { ki1 <- repLKind ki 
-                                ; repFamilyKind flav tc1 bndrs ki1 }
-              }
-       ; return $ Just (loc, dec)
-       }
+repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $ repFamilyDecl (L loc fam)
+
+repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))
+  = do { tc1 <- lookupLOcc tc          -- See note [Binders and occurrences]  
+       ; dec <- addTyClTyVarBinds tvs $ \bndrs -> 
+               repSynDecl tc1 bndrs rhs
+       ; return (Just (loc, dec)) }
 
-repTyClD (L loc (TyDecl { tcdLName = tc, tcdTyVars = tvs, tcdTyDefn = defn }))
+repTyClD (L loc (DataDecl { tcdLName = tc, tcdTyVars = tvs, tcdDataDefn = defn }))
   = do { tc1 <- lookupLOcc tc          -- See note [Binders and occurrences]  
        ; tc_tvs <- mk_extra_tvs tc tvs defn
        ; dec <- addTyClTyVarBinds tc_tvs $ \bndrs -> 
-               repTyDefn tc1 bndrs Nothing (hsLTyVarNames tc_tvs) defn
+               repDataDefn tc1 bndrs Nothing (hsLTyVarNames tc_tvs) defn
        ; return (Just (loc, dec)) }
 
 repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, 
@@ -240,7 +229,7 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
              ; sigs1  <- rep_sigs sigs
              ; binds1 <- rep_binds meth_binds
              ; fds1   <- repLFunDeps fds
-              ; ats1   <- repTyClDs ats
+              ; ats1   <- repFamilyDecls ats
              ; decls1 <- coreList decQTyConName (ats1 ++ sigs1 ++ binds1)
              ; repClass cxt1 cls1 bndrs fds1 decls1 
               }
@@ -253,13 +242,13 @@ repTyClD (L loc d) = putSrcSpanDs loc $
                        ; return Nothing }
 
 -------------------------
-repTyDefn :: Core TH.Name -> Core [TH.TyVarBndr]
-          -> Maybe (Core [TH.TypeQ])
-          -> [Name] -> HsTyDefn Name
-          -> DsM (Core TH.DecQ)
-repTyDefn tc bndrs opt_tys tv_names
-          (TyData { td_ND = new_or_data, td_ctxt = cxt
-                 , td_cons = cons, td_derivs = mb_derivs })
+repDataDefn :: Core TH.Name -> Core [TH.TyVarBndr]
+            -> Maybe (Core [TH.TypeQ])
+            -> [Name] -> HsDataDefn Name
+            -> DsM (Core TH.DecQ)
+repDataDefn tc bndrs opt_tys tv_names
+          (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt
+                     , dd_cons = cons, dd_derivs = mb_derivs })
   = do { cxt1     <- repLContext cxt
        ; derivs1  <- repDerivs mb_derivs
        ; case new_or_data of
@@ -268,18 +257,40 @@ repTyDefn tc bndrs opt_tys tv_names
            DataType -> do { cons1 <- repList conQTyConName (repC tv_names) cons
                           ; repData cxt1 tc bndrs opt_tys cons1 derivs1 } }
 
-repTyDefn tc bndrs opt_tys _ (TySynonym { td_synRhs = ty })
+repSynDecl :: Core TH.Name -> Core [TH.TyVarBndr]
+          -> LHsType Name
+          -> DsM (Core TH.DecQ)
+repSynDecl tc bndrs ty
   = do { ty1 <- repLTy ty
-       ; repTySyn tc bndrs opt_tys ty1 }
+       ; repTySyn tc bndrs ty1 }
+
+repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ)
+repFamilyDecl (L loc (FamilyDecl { fdFlavour = flavour,
+                                   fdLName   = tc,
+                                   fdTyVars  = tvs, 
+                                  fdKindSig = opt_kind }))
+  = do { tc1 <- lookupLOcc tc          -- See note [Binders and occurrences] 
+       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
+           do { flav <- repFamilyFlavour flavour
+             ; case opt_kind of 
+                  Nothing -> repFamilyNoKind flav tc1 bndrs
+                  Just ki -> do { ki1 <- repLKind ki 
+                                ; repFamilyKind flav tc1 bndrs ki1 }
+              }
+       ; return (loc, dec)
+       }
+
+repFamilyDecls :: [LFamilyDecl Name] -> DsM [Core TH.DecQ]
+repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds)
 
 -------------------------
 mk_extra_tvs :: Located Name -> LHsTyVarBndrs Name 
-             -> HsTyDefn Name -> DsM (LHsTyVarBndrs Name)
+             -> HsDataDefn Name -> DsM (LHsTyVarBndrs Name)
 -- If there is a kind signature it must be of form
 --    k1 -> .. -> kn -> *
 -- Return type variables [tv1:k1, tv2:k2, .., tvn:kn]
 mk_extra_tvs tc tvs defn
-  | TyData { td_kindSig = Just hs_kind } <- defn
+  | HsDataDefn { dd_kindSig = Just hs_kind } <- defn
   = do { extra_tvs <- go hs_kind
        ; return (tvs { hsq_tvs = hsq_tvs tvs ++ extra_tvs }) }
   | otherwise
@@ -320,13 +331,21 @@ repFamilyFlavour DataFamily = rep2 dataFamName []
 -- Represent instance declarations
 --
 repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
-repInstD (L loc (FamInstD { lid_inst = fi_decl }))
-  = do { dec <- repFamInstD fi_decl
+repInstD (L loc (TyFamInstD { tfid_inst = fi_decl }))
+  = do { dec <- repTyFamInstD fi_decl
+       ; return (loc, dec) }
+repInstD (L loc (DataFamInstD { dfid_inst = fi_decl }))
+  = do { dec <- repDataFamInstD fi_decl
+       ; return (loc, dec) }
+repInstD (L loc (ClsInstD { cid_inst = cls_decl }))
+  = do { dec <- repClsInstD cls_decl
        ; return (loc, dec) }
 
-repInstD (L loc (ClsInstD { cid_poly_ty = ty, cid_binds = binds
-                          , cid_sigs = prags, cid_fam_insts = ats }))
-  = do { dec <- addTyVarBinds tvs $ \_ ->
+repClsInstD :: ClsInstDecl Name -> DsM (Core TH.DecQ)
+repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
+                         , cid_sigs = prags, cid_tyfam_insts = ats
+                         , cid_datafam_insts = adts })
+  = addTyVarBinds tvs $ \_ ->
            -- We must bring the type variables into scope, so their
            -- occurrences don't fail, even though the binders don't
             -- appear in the resulting data structure
@@ -342,25 +361,44 @@ repInstD (L loc (ClsInstD { cid_poly_ty = ty, cid_binds = binds
                ; inst_ty1 <- repTapps cls_tcon cls_tys
                ; binds1 <- rep_binds binds
                ; prags1 <- rep_sigs prags
-               ; ats1 <- mapM (repFamInstD . unLoc) ats
-               ; decls <- coreList decQTyConName (ats1 ++ binds1 ++ prags1)
+               ; ats1 <- mapM (repTyFamInstD . unLoc) ats
+               ; adts1 <- mapM (repDataFamInstD . unLoc) adts
+               ; decls <- coreList decQTyConName (ats1 ++ adts1 ++ binds1 ++ prags1)
                ; repInst cxt1 inst_ty1 decls }
-       ; return (loc, dec) }
  where
    Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty
 
-repFamInstD :: FamInstDecl Name -> DsM (Core TH.DecQ)
-repFamInstD (FamInstDecl { fid_tycon = tc_name
-                         , fid_pats = HsWB { hswb_cts = tys, hswb_kvs = kv_names, hswb_tvs = tv_names }
-                         , fid_defn = defn })
-  = WARN( not (null kv_names), ppr kv_names )   -- We have not yet dealt with kind 
-                                                -- polymorphism in Template Haskell (sigh)
-    do { tc <- lookupLOcc tc_name              -- See note [Binders and occurrences]  
+repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ)
+repTyFamInstD decl@(TyFamInstDecl { tfid_eqns = eqns })
+  = do { let tc_name = tyFamInstDeclLName decl
+       ; tc <- lookupLOcc tc_name              -- See note [Binders and occurrences]  
+       ; eqns1 <- mapM repTyFamEqn eqns
+       ; eqns2 <- coreList tySynEqnQTyConName eqns1
+       ; repTySynInst tc eqns2 }
+
+repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ)
+repTyFamEqn (L loc (TyFamInstEqn { tfie_pats = HsWB { hswb_cts = tys
+                                                    , hswb_kvs = kv_names
+                                                    , hswb_tvs = tv_names }
+                                 , tfie_rhs = rhs }))
+  = do { let hs_tvs = HsQTvs { hsq_kvs = kv_names
+                             , hsq_tvs = userHsTyVarBndrs loc tv_names }   -- Yuk
+       ; addTyClTyVarBinds hs_tvs $ \ _ ->
+         do { tys1 <- repLTys tys
+            ; tys2 <- coreList typeQTyConName tys1
+            ; rhs1 <- repLTy rhs
+            ; repTySynEqn tys2 rhs1 } }
+
+repDataFamInstD :: DataFamInstDecl Name -> DsM (Core TH.DecQ)
+repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name
+                                 , dfid_pats = HsWB { hswb_cts = tys, hswb_kvs = kv_names, hswb_tvs = tv_names }
+                                 , dfid_defn = defn })
+  = do { tc <- lookupLOcc tc_name              -- See note [Binders and occurrences]  
        ; let loc = getLoc tc_name
              hs_tvs = HsQTvs { hsq_kvs = kv_names, hsq_tvs = userHsTyVarBndrs loc tv_names }   -- Yuk
        ; addTyClTyVarBinds hs_tvs $ \ bndrs ->
          do { tys1 <- repList typeQTyConName repLTy tys
-            ; repTyDefn tc bndrs (Just tys1) tv_names defn } }
+            ; repDataDefn tc bndrs (Just tys1) tv_names defn } }
 
 repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
 repForD (L loc (ForeignImport name typ _ (CImport cc s mch cis)))
@@ -519,9 +557,9 @@ repBangTy ty= do
   rep2 strictTypeName [s, t]
   where
     (str, ty') = case ty of
-                  L _ (HsBangTy HsUnpack ty) -> (unpackedName,  ty)
-                  L _ (HsBangTy _ ty)        -> (isStrictName,  ty)
-                  _                          -> (notStrictName, ty)
+                  L _ (HsBangTy (HsBang True) ty) -> (unpackedName,  ty)
+                  L _ (HsBangTy _ ty)             -> (isStrictName,  ty)
+                  _                               -> (notStrictName, ty)
 
 -------------------------------------------------------
 --                     Deriving clause
@@ -1607,12 +1645,9 @@ repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC con) (MkC derivs)
   = rep2 newtypeInstDName [cxt, nm, tys, con, derivs]
 
 repTySyn :: Core TH.Name -> Core [TH.TyVarBndr]
-         -> Maybe (Core [TH.TypeQ])
          -> Core TH.TypeQ -> DsM (Core TH.DecQ)
-repTySyn (MkC nm) (MkC tvs) Nothing (MkC rhs)
+repTySyn (MkC nm) (MkC tvs) (MkC rhs)
   = rep2 tySynDName [nm, tvs, rhs]
-repTySyn (MkC nm) (MkC _) (Just (MkC tys)) (MkC rhs)
-  = rep2 tySynInstDName [nm, tys, rhs]
 
 repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
 repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
@@ -1657,6 +1692,14 @@ repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
 repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki)
     = rep2 familyKindDName [flav, nm, tvs, ki]
 
+repTySynInst :: Core TH.Name -> Core [TH.TySynEqnQ] -> DsM (Core TH.DecQ)
+repTySynInst (MkC nm) (MkC eqns)
+  = rep2 tySynInstDName [nm, eqns]
+
+repTySynEqn :: Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)
+repTySynEqn (MkC lhs) (MkC rhs)
+  = rep2 tySynEqnName [lhs, rhs]
+
 repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
 repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
 
@@ -1997,6 +2040,8 @@ templateHaskellNames = [
     funDepName,
     -- FamFlavour
     typeFamName, dataFamName,
+    -- TySynEqn
+    tySynEqnName,
 
     -- And the tycons
     qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
@@ -2005,7 +2050,7 @@ templateHaskellNames = [
     varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
     typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName,
     patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
-    predQTyConName, decsQTyConName, ruleBndrQTyConName,
+    predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName,
 
     -- Quasiquoting
     quoteDecName, quoteTypeName, quoteExpName, quotePatName]
@@ -2304,11 +2349,15 @@ typeFamName, dataFamName :: Name
 typeFamName = libFun (fsLit "typeFam") typeFamIdKey
 dataFamName = libFun (fsLit "dataFam") dataFamIdKey
 
+-- data TySynEqn = ...
+tySynEqnName :: Name
+tySynEqnName = libFun (fsLit "tySynEqn") tySynEqnIdKey
+
 matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,
     decQTyConName, conQTyConName, strictTypeQTyConName,
     varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName,
     patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName,
-    ruleBndrQTyConName :: Name
+    ruleBndrQTyConName, tySynEqnQTyConName :: Name
 matchQTyConName         = libTc (fsLit "MatchQ")         matchQTyConKey
 clauseQTyConName        = libTc (fsLit "ClauseQ")        clauseQTyConKey
 expQTyConName           = libTc (fsLit "ExpQ")           expQTyConKey
@@ -2324,6 +2373,7 @@ patQTyConName           = libTc (fsLit "PatQ")           patQTyConKey
 fieldPatQTyConName      = libTc (fsLit "FieldPatQ")      fieldPatQTyConKey
 predQTyConName          = libTc (fsLit "PredQ")          predQTyConKey
 ruleBndrQTyConName      = libTc (fsLit "RuleBndrQ")      ruleBndrQTyConKey
+tySynEqnQTyConName      = libTc (fsLit "TySynEqnQ")      tySynEqnQTyConKey
 
 -- quasiquoting
 quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name
@@ -2341,7 +2391,7 @@ expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
     decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey,
     fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
     fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
-    predQTyConKey, decsQTyConKey, ruleBndrQTyConKey :: Unique
+    predQTyConKey, decsQTyConKey, ruleBndrQTyConKey, tySynEqnQTyConKey :: Unique
 expTyConKey             = mkPreludeTyConUnique 200
 matchTyConKey           = mkPreludeTyConUnique 201
 clauseTyConKey          = mkPreludeTyConUnique 202
@@ -2370,6 +2420,7 @@ predQTyConKey           = mkPreludeTyConUnique 224
 tyVarBndrTyConKey       = mkPreludeTyConUnique 225
 decsQTyConKey           = mkPreludeTyConUnique 226
 ruleBndrQTyConKey       = mkPreludeTyConUnique 227
+tySynEqnQTyConKey       = mkPreludeTyConUnique 228
 
 -- IdUniques available: 200-499
 -- If you want to change this, make sure you check in PrelNames
@@ -2629,6 +2680,10 @@ typeFamIdKey, dataFamIdKey :: Unique
 typeFamIdKey = mkPreludeMiscIdUnique 415
 dataFamIdKey = mkPreludeMiscIdUnique 416
 
+-- data TySynEqn = ...
+tySynEqnIdKey :: Unique
+tySynEqnIdKey = mkPreludeMiscIdUnique 417
+
 -- quasiquoting
 quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique
 quoteExpKey  = mkPreludeMiscIdUnique 418
index 609041b..504a76d 100644 (file)
@@ -316,10 +316,14 @@ mkCoAlgCaseMatchResult dflags var ty match_alts
     mk_case fail = do alts <- mapM (mk_alt fail) sorted_alts
                       return (mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts))
 
-    mk_alt fail (con, args, MatchResult _ body_fn) = do
-          body <- body_fn fail
-          us <- newUniqueSupply
-          return (mkReboxingAlt (uniqsFromSupply us) con args body)
+    mk_alt fail (con, args, MatchResult _ body_fn)
+      = do { body <- body_fn fail
+           ; case dataConBoxer con of {
+                Nothing -> return (DataAlt con, args, body) ;
+                Just (DCB boxer) -> 
+        do { us <- newUniqueSupply
+           ; let (rep_ids, binds) = initUs_ us (boxer ty_args args)
+           ; return (DataAlt con, rep_ids, mkLets binds body) } } }
 
     mk_default fail | exhaustive_case = []
                    | otherwise       = [(DEFAULT, [], fail)]
index 3e7cd42..44d0952 100644 (file)
@@ -384,6 +384,7 @@ Library
         FunDeps
         InstEnv
         TyCon
+        CoAxiom
         Kind
         Type
         TypeRep
index d65410d..c5a92f8 100644 (file)
@@ -156,36 +156,39 @@ cvtDec (PragmaD prag)
 cvtDec (TySynD tc tvs rhs)
   = do  { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
         ; rhs' <- cvtType rhs
-        ; returnL $ TyClD (TyDecl { tcdLName = tc'
+        ; returnL $ TyClD (SynDecl { tcdLName = tc'
                                   , tcdTyVars = tvs', tcdFVs = placeHolderNames
-                                  , tcdTyDefn = TySynonym rhs' }) }
+                                  , tcdRhs = rhs' }) }
 
 cvtDec (DataD ctxt tc tvs constrs derivs)
   = do  { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
         ; cons' <- mapM cvtConstr constrs
         ; derivs' <- cvtDerivs derivs
-       ; let defn = TyData { td_ND = DataType, td_cType = Nothing
-                           , td_ctxt = ctxt'
-                           , td_kindSig = Nothing
-                           , td_cons = cons', td_derivs = derivs' }
-        ; returnL $ TyClD (TyDecl { tcdLName = tc', tcdTyVars = tvs'
-                                  , tcdTyDefn = defn, tcdFVs = placeHolderNames }) }
+        ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
+                                , dd_ctxt = ctxt'
+                                , dd_kindSig = Nothing
+                                , dd_cons = cons', dd_derivs = derivs' }
+        ; returnL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
+                                    , tcdDataDefn = defn, tcdFVs = placeHolderNames }) }
 
 cvtDec (NewtypeD ctxt tc tvs constr derivs)
   = do  { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
         ; con' <- cvtConstr constr
         ; derivs' <- cvtDerivs derivs
-        ; let defn = TyData { td_ND = NewType, td_cType = Nothing
-                            , td_ctxt = ctxt'
-                            , td_kindSig = Nothing
-                            , td_cons = [con'], td_derivs = derivs' }
-        ; returnL $ TyClD (TyDecl { tcdLName = tc', tcdTyVars = tvs'
-                                  , tcdTyDefn = defn, tcdFVs = placeHolderNames }) }
+        ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
+                                , dd_ctxt = ctxt'
+                                , dd_kindSig = Nothing
+                                , dd_cons = [con'], dd_derivs = derivs' }
+        ; returnL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
+                                    , tcdDataDefn = defn, tcdFVs = placeHolderNames }) }
 
 cvtDec (ClassD ctxt cl tvs fds decs)
   = do  { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
         ; fds'  <- mapM cvt_fundep fds
-        ; (binds', sigs', fams', ats') <- cvt_ci_decs (ptext (sLit "a class declaration")) decs
+        ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs (ptext (sLit "a class declaration")) decs
+        ; unless (null adts')
+            (failWith $ (ptext (sLit "Default data instance declarations are not allowed:"))
+                   $$ (Outputable.ppr adts'))
         ; returnL $ TyClD $
           ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
                     , tcdFDs = fds', tcdSigs = sigs', tcdMeths = binds'
@@ -196,12 +199,12 @@ cvtDec (ClassD ctxt cl tvs fds decs)
 
 cvtDec (InstanceD ctxt ty decs)
   = do  { let doc = ptext (sLit "an instance declaration")
-        ; (binds', sigs', fams', ats') <- cvt_ci_decs doc decs
+        ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs
         ; unless (null fams') (failWith (mkBadDecMsg doc fams'))
         ; ctxt' <- cvtContext ctxt
         ; L loc ty' <- cvtType ty
         ; let inst_ty' = L loc $ mkImplicitHsForAllTy ctxt' $ L loc ty'
-        ; returnL $ InstD (ClsInstD inst_ty' binds' sigs' ats') }
+        ; returnL $ InstD (ClsInstD (ClsInstDecl inst_ty' binds' sigs' ats' adts')) }
 
 cvtDec (ForeignD ford)
   = do { ford' <- cvtForD ford
@@ -210,7 +213,7 @@ cvtDec (ForeignD ford)
 cvtDec (FamilyD flav tc tvs kind)
   = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
        ; kind' <- cvtMaybeKind kind
-       ; returnL $ TyClD (TyFamily (cvtFamFlavour flav) tc' tvs' kind') }
+       ; returnL $ TyClD (FamDecl (FamilyDecl (cvtFamFlavour flav) tc' tvs' kind')) }
   where
     cvtFamFlavour TypeFam = TypeFamily
     cvtFamFlavour DataFam = DataFamily
@@ -219,50 +222,61 @@ cvtDec (DataInstD ctxt tc tys constrs derivs)
   = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
        ; cons' <- mapM cvtConstr constrs
        ; derivs' <- cvtDerivs derivs
-       ; let defn = TyData { td_ND = DataType, td_cType = Nothing
-                           , td_ctxt = ctxt'
-                           , td_kindSig = Nothing
-                           , td_cons = cons', td_derivs = derivs' }
+       ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
+                               , dd_ctxt = ctxt'
+                               , dd_kindSig = Nothing
+                               , dd_cons = cons', dd_derivs = derivs' }
 
-       ; returnL $ InstD $ FamInstD
-           { lid_inst = FamInstDecl { fid_tycon = tc', fid_pats = typats'
-                                    , fid_defn = defn, fid_fvs = placeHolderNames } }}
+       ; returnL $ InstD $ DataFamInstD
+           { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
+                                         , dfid_defn = defn, dfid_fvs = placeHolderNames } }}
 
 cvtDec (NewtypeInstD ctxt tc tys constr derivs)
   = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
        ; con' <- cvtConstr constr
        ; derivs' <- cvtDerivs derivs
-       ; let defn = TyData { td_ND = NewType, td_cType = Nothing
-                           , td_ctxt = ctxt'
-                           , td_kindSig = Nothing
-                           , td_cons = [con'], td_derivs = derivs' }
-       ; returnL $ InstD $ FamInstD
-           { lid_inst = FamInstDecl { fid_tycon = tc', fid_pats = typats'
-                                    , fid_defn = defn, fid_fvs = placeHolderNames } } }
-
-cvtDec (TySynInstD tc tys rhs)
-  = do  { (_, tc', tys') <- cvt_tyinst_hdr [] tc tys
+       ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
+                               , dd_ctxt = ctxt'
+                               , dd_kindSig = Nothing
+                               , dd_cons = [con'], dd_derivs = derivs' }
+       ; returnL $ InstD $ DataFamInstD
+           { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
+                                         , dfid_defn = defn, dfid_fvs = placeHolderNames } }}
+
+cvtDec (TySynInstD tc eqns)
+  = do  { tc' <- tconNameL tc
+        ; eqns' <- mapM (cvtTySynEqn tc') eqns
+        ; returnL $ InstD $ TyFamInstD
+            { tfid_inst = TyFamInstDecl { tfid_eqns = eqns'
+                                        , tfid_group = (length eqns' /= 1)
+                                        , tfid_fvs = placeHolderNames } } }
+----------------
+cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName)
+cvtTySynEqn tc (TySynEqn lhs rhs)
+  = do  { lhs' <- mapM cvtType lhs
         ; rhs' <- cvtType rhs
-        ; returnL $ InstD $ FamInstD
-            { lid_inst = FamInstDecl { fid_tycon = tc', fid_pats = tys'
-                                     , fid_defn = TySynonym rhs', fid_fvs = placeHolderNames } } }
+        ; returnL $ TyFamInstEqn { tfie_tycon = tc
+                                 , tfie_pats = mkHsWithBndrs lhs'
+                                 , tfie_rhs = rhs' } }
 
 ----------------
 cvt_ci_decs :: MsgDoc -> [TH.Dec]
             -> CvtM (LHsBinds RdrName,
                      [LSig RdrName],
-                     [LTyClDecl RdrName],    -- Family decls
-                     [LFamInstDecl RdrName])
+                     [LFamilyDecl RdrName],
+                     [LTyFamInstDecl RdrName],
+                     [LDataFamInstDecl RdrName])
 -- Convert the declarations inside a class or instance decl
 -- ie signatures, bindings, and associated types
 cvt_ci_decs doc decs
   = do  { decs' <- mapM cvtDec decs
-        ; let (ats', bind_sig_decs') = partitionWith is_fam_inst decs'
-        ; let (sigs', prob_binds')   = partitionWith is_sig bind_sig_decs'
+        ; let (ats', bind_sig_decs') = partitionWith is_tyfam_inst decs'
+        ; let (adts', no_ats')       = partitionWith is_datafam_inst bind_sig_decs'
+        ; let (sigs', prob_binds')   = partitionWith is_sig no_ats'
         ; let (binds', prob_fams')   = partitionWith is_bind prob_binds'
         ; let (fams', bads)          = partitionWith is_fam_decl prob_fams'
         ; unless (null bads) (failWith (mkBadDecMsg doc bads))
-        ; return (listToBag binds', sigs', fams', ats') }
+        ; return (listToBag binds', sigs', fams', ats', adts') }
 
 ----------------
 cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
@@ -290,13 +304,17 @@ cvt_tyinst_hdr cxt tc tys
 --              Partitioning declarations
 -------------------------------------------------------------------
 
-is_fam_decl :: LHsDecl RdrName -> Either (LTyClDecl RdrName) (LHsDecl RdrName)
-is_fam_decl (L loc (TyClD d@(TyFamily {}))) = Left (L loc d)
+is_fam_decl :: LHsDecl RdrName -> Either (LFamilyDecl RdrName) (LHsDecl RdrName)
+is_fam_decl (L loc (TyClD (FamDecl { tcdFam = d }))) = Left (L loc d)
 is_fam_decl decl = Right decl
 
-is_fam_inst :: LHsDecl RdrName -> Either (LFamInstDecl RdrName) (LHsDecl RdrName)
-is_fam_inst (L loc (Hs.InstD (FamInstD { lid_inst = d }))) = Left (L loc d)
-is_fam_inst decl                                           = Right decl
+is_tyfam_inst :: LHsDecl RdrName -> Either (LTyFamInstDecl RdrName) (LHsDecl RdrName)
+is_tyfam_inst (L loc (Hs.InstD (TyFamInstD { tfid_inst = d }))) = Left (L loc d)
+is_tyfam_inst decl                                              = Right decl
+
+is_datafam_inst :: LHsDecl RdrName -> Either (LDataFamInstDecl RdrName) (LHsDecl RdrName)
+is_datafam_inst (L loc (Hs.InstD (DataFamInstD { dfid_inst = d }))) = Left (L loc d)
+is_datafam_inst decl                                                = Right decl
 
 is_sig :: LHsDecl RdrName -> Either (LSig RdrName) (LHsDecl RdrName)
 is_sig (L loc (Hs.SigD sig)) = Left (L loc sig)
@@ -345,9 +363,9 @@ cvtConstr (ForallC tvs ctxt con)
                          , con_cxt = L loc (ctxt' ++ (unLoc $ con_cxt con')) } }
 
 cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName)
-cvt_arg (IsStrict, ty)  = do { ty' <- cvtType ty; returnL $ HsBangTy HsStrict ty' }
 cvt_arg (NotStrict, ty) = cvtType ty
-cvt_arg (Unpacked, ty)  = do { ty' <- cvtType ty; returnL $ HsBangTy HsUnpack ty' }
+cvt_arg (IsStrict,  ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsBang False) ty' }
+cvt_arg (Unpacked,  ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsBang True)  ty' }
 
 cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (ConDeclField RdrName)
 cvt_id_arg (i, str, ty)
index cd19e4c..8ee17a5 100644 (file)
@@ -8,20 +8,25 @@
 
 -- | Abstract syntax of global declarations.
 --
--- Definitions for: @TyDecl@ and @ConDecl@, @ClassDecl@,
+-- Definitions for: @SynDecl@ and @ConDecl@, @ClassDecl@,
 -- @InstDecl@, @DefaultDecl@ and @ForeignDecl@.
 module HsDecls (
   -- * Toplevel declarations
-  HsDecl(..), LHsDecl, HsTyDefn(..),
+  HsDecl(..), LHsDecl, HsDataDefn(..),
   -- ** Class or type declarations
   TyClDecl(..), LTyClDecl, TyClGroup,
-  isClassDecl, isDataDecl, isSynDecl, isFamilyDecl,
-  isHsDataDefn, isHsSynDefn, tcdName, famInstDeclName,
-  countTyClDecls, pprTyDefnFlavour, pprTyClDeclFlavour,
+  isClassDecl, isDataDecl, isSynDecl, isFamilyDecl, tcdName,
+  tyFamInstDeclName, tyFamInstDeclLName,
+  countTyClDecls, pprTyClDeclFlavour,
+  tyClDeclLName, tyClDeclTyVars,
+  FamilyDecl(..), LFamilyDecl,
 
   -- ** Instance declarations
   InstDecl(..), LInstDecl, NewOrData(..), FamilyFlavour(..),
-  FamInstDecl(..), LFamInstDecl, instDeclFamInsts,
+  TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts,
+  DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour,
+  TyFamInstEqn(..), LTyFamInstEqn,
+  LClsInstDecl, ClsInstDecl(..),
 
   -- ** Standalone deriving declarations
   DerivDecl(..), LDerivDecl,
@@ -275,7 +280,7 @@ instance OutputableBndr name => Outputable (SpliceDecl name) where
 
 %************************************************************************
 %*                                                                      *
-\subsection[TyDecl]{@data@, @newtype@ or @type@ (synonym) type declaration}
+\subsection[SynDecl]{@data@, @newtype@ or @type@ (synonym) type declaration}
 %*                                                                      *
 %************************************************************************
 
@@ -426,24 +431,26 @@ data TyClDecl name
     }
 
   | -- | @type/data family T :: *->*@
-    TyFamily {  tcdFlavour :: FamilyFlavour,             -- type or data
-                tcdLName   :: Located name,              -- type constructor
-                tcdTyVars  :: LHsTyVarBndrs name,        -- type variables
-                tcdKindSig :: Maybe (LHsKind name)       -- result kind
-    }
-
+    FamDecl { tcdFam :: FamilyDecl name }
 
-  | -- | @type/data declaration
-    TyDecl { tcdLName  :: Located name            -- ^ Type constructor
+  | -- | @type@ declaration
+    SynDecl { tcdLName  :: Located name            -- ^ Type constructor
            , tcdTyVars :: LHsTyVarBndrs name      -- ^ Type variables; for an associated type
                                                   --   these include outer binders
+           , tcdRhs    :: LHsType name            -- ^ RHS of type declaration
+           , tcdFVs    :: NameSet }
+
+  | -- | @data@ declaration
+    DataDecl { tcdLName    :: Located name        -- ^ Type constructor
+             , tcdTyVars   :: LHsTyVarBndrs name  -- ^ Type variables; for an assoicated type
+                                                  --   these include outer binders
                                                   -- Eg  class T a where
                                                   --       type F a :: *
                                                   --       type F a = a -> a
                                                   -- Here the type decl for 'f' includes 'a' 
                                                   -- in its tcdTyVars
-           , tcdTyDefn :: HsTyDefn name
-           , tcdFVs    :: NameSet }
+             , tcdDataDefn :: HsDataDefn name
+             , tcdFVs      :: NameSet }
 
   | ClassDecl { tcdCtxt    :: LHsContext name,          -- ^ Context...
                 tcdLName   :: Located name,             -- ^ Name of the class
@@ -451,102 +458,42 @@ data TyClDecl name
                 tcdFDs     :: [Located (FunDep name)],  -- ^ Functional deps
                 tcdSigs    :: [LSig name],              -- ^ Methods' signatures
                 tcdMeths   :: LHsBinds name,            -- ^ Default methods
-                tcdATs     :: [LTyClDecl name],         -- ^ Associated types; ie
-                                                        --   only 'TyFamily'
-                tcdATDefs  :: [LFamInstDecl name],      -- ^ Associated type defaults; ie
-                                                        --   only 'TySynonym'
+                tcdATs     :: [LFamilyDecl name],       -- ^ Associated types; ie
+                tcdATDefs  :: [LTyFamInstDecl name],    -- ^ Associated type defaults
                 tcdDocs    :: [LDocDecl],               -- ^ Haddock docs
                 tcdFVs     :: NameSet
     }
   deriving (Data, Typeable)
 
-
-data HsTyDefn name   -- The payload of a type synonym or data type defn
-                     -- Used *both* for vanialla type/data declarations,
-                     --       *and* for type/data family instances
-  = TySynonym { td_synRhs :: LHsType name }   -- ^ Synonym expansion
-
-  | -- | Declares a data type or newtype, giving its construcors
-    -- @
-    --  data/newtype T a = <constrs>
-    --  data/newtype instance T [a] = <constrs>
-    -- @
-    TyData { td_ND     :: NewOrData,
-             td_ctxt   :: LHsContext name,           -- ^ Context
-             td_cType  :: Maybe CType,
-             td_kindSig:: Maybe (LHsKind name),
-                     -- ^ Optional kind signature.
-                     --
-                     -- @(Just k)@ for a GADT-style @data@, 
-                     -- or @data instance@ decl, with explicit kind sig
-                     --
-                     -- Always @Nothing@ for H98-syntax decls
-
-             td_cons   :: [LConDecl name],
-                     -- ^ Data constructors
-                     --
-                     -- For @data T a = T1 | T2 a@
-                     --   the 'LConDecl's all have 'ResTyH98'.
-                     -- For @data T a where { T1 :: T a }@
-                     --   the 'LConDecls' all have 'ResTyGADT'.
-
-             td_derivs :: Maybe [LHsType name]
-                     -- ^ Derivings; @Nothing@ => not specified,
-                     --              @Just []@ => derive exactly what is asked
-                     --
-                     -- These "types" must be of form
-                     -- @
-                     --      forall ab. C ty1 ty2
-                     -- @
-                     -- Typically the foralls and ty args are empty, but they
-                     -- are non-empty for the newtype-deriving case
-    }
-    deriving( Data, Typeable )
-
-data NewOrData
-  = NewType                     -- ^ @newtype Blah ...@
-  | DataType                    -- ^ @data Blah ...@
-  deriving( Eq, Data, Typeable )                -- Needed because Demand derives Eq
+type LFamilyDecl name = Located (FamilyDecl name)
+data FamilyDecl name = FamilyDecl
+  { fdFlavour :: FamilyFlavour              -- type or data
+  , fdLName   :: Located name               -- type constructor
+  , fdTyVars  :: LHsTyVarBndrs name         -- type variables
+  , fdKindSig :: Maybe (LHsKind name) }     -- result kind
+  deriving( Data, Typeable )
 
 data FamilyFlavour
-  = TypeFamily                  -- ^ @type family ...@
-  | DataFamily                  -- ^ @data family ...@
-  deriving (Data, Typeable)
-\end{code}
-
-Note [tcdTypats and HsTyPats] 
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We use TyData and TySynonym both for vanilla data/type declarations
-     type T a = Int
-AND for data/type family instance declarations
-     type instance F [a] = (a,Int)
-
-tcdTyPats = HsTyDefn tvs
-   This is a vanilla data type or type synonym
-   tvs are the quantified type variables
+  = TypeFamily
+  | DataFamily
+  deriving( Data, Typeable )
 
+\end{code}
 
 ------------------------------
 Simple classifiers
 
 \begin{code}
-isHsDataDefn, isHsSynDefn :: HsTyDefn name -> Bool
-isHsDataDefn (TyData {}) = True
-isHsDataDefn _           = False
-
-isHsSynDefn (TySynonym {}) = True
-isHsSynDefn _              = False
-
 -- | @True@ <=> argument is a @data@\/@newtype@
 -- declaration.
 isDataDecl :: TyClDecl name -> Bool
-isDataDecl (TyDecl { tcdTyDefn = defn }) = isHsDataDefn defn
-isDataDecl _other                        = False
+isDataDecl (DataDecl {}) = True
+isDataDecl _other        = False
 
 -- | type or type instance declaration
 isSynDecl :: TyClDecl name -> Bool
-isSynDecl (TyDecl { tcdTyDefn = defn }) = isHsSynDefn defn
-isSynDecl _other                        = False
+isSynDecl (SynDecl {})   = True
+isSynDecl _other        = False
 
 -- | type class
 isClassDecl :: TyClDecl name -> Bool
@@ -555,18 +502,36 @@ isClassDecl _              = False
 
 -- | type family declaration
 isFamilyDecl :: TyClDecl name -> Bool
-isFamilyDecl (TyFamily {}) = True
+isFamilyDecl (FamDecl {})  = True
 isFamilyDecl _other        = False
 \end{code}
 
 Dealing with names
 
 \begin{code}
-famInstDeclName :: LFamInstDecl a -> a
-famInstDeclName (L _ (FamInstDecl { fid_tycon = L _ name })) = name
+tyFamInstDeclName :: OutputableBndr name
+                  => TyFamInstDecl name -> name
+tyFamInstDeclName = unLoc . tyFamInstDeclLName
+
+tyFamInstDeclLName :: OutputableBndr name
+                   => TyFamInstDecl name -> Located name
+tyFamInstDeclLName (TyFamInstDecl { tfid_eqns =
+                     (L _ (TyFamInstEqn { tfie_tycon = ln })) : _ })
+  -- there may be more than one equation, but grab the name from the first
+  = ln
+tyFamInstDeclLName decl = pprPanic "tyFamInstDeclLName" (ppr decl)
+
+tyClDeclLName :: TyClDecl name -> Located name
+tyClDeclLName (FamDecl { tcdFam = FamilyDecl { fdLName = ln } }) = ln
+tyClDeclLName decl = tcdLName decl
 
 tcdName :: TyClDecl name -> name
-tcdName decl = unLoc (tcdLName decl)
+tcdName = unLoc . tyClDeclLName
+
+tyClDeclTyVars :: OutputableBndr name => TyClDecl name -> LHsTyVarBndrs name
+tyClDeclTyVars decl@(ForeignType {}) = pprPanic "tyClDeclTyVars" (ppr decl)
+tyClDeclTyVars (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs
+tyClDeclTyVars d = tcdTyVars d
 \end{code}
 
 \begin{code}
@@ -579,11 +544,11 @@ countTyClDecls decls
     count isNewTy        decls,  -- ...instances
     count isFamilyDecl   decls)
  where
-   isDataTy TyDecl{ tcdTyDefn = TyData { td_ND = DataType } } = True
-   isDataTy _                                                 = False
+   isDataTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = DataType } } = True
+   isDataTy _                                                       = False
    
-   isNewTy TyDecl{ tcdTyDefn = TyData { td_ND = NewType } } = True
-   isNewTy _                                                = False
+   isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = NewType } } = True
+   isNewTy _                                                      = False
 \end{code}
 
 \begin{code}
@@ -593,20 +558,14 @@ instance OutputableBndr name
     ppr (ForeignType {tcdLName = ltycon})
         = hsep [ptext (sLit "foreign import type dotnet"), ppr ltycon]
 
-    ppr (TyFamily {tcdFlavour = flavour, tcdLName = ltycon, 
-                   tcdTyVars = tyvars, tcdKindSig = mb_kind})
-      = pp_flavour <+> pp_vanilla_decl_head ltycon tyvars [] <+> pp_kind
-        where
-          pp_flavour = case flavour of
-                         TypeFamily -> ptext (sLit "type family")
-                         DataFamily -> ptext (sLit "data family")
+    ppr (FamDecl { tcdFam = decl }) = ppr decl
+    ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdRhs = rhs })
+      = hang (ptext (sLit "type") <+>
+              pp_vanilla_decl_head ltycon tyvars [] <+> equals)
+          4 (ppr rhs) 
 
-          pp_kind = case mb_kind of
-                      Nothing   -> empty
-                      Just kind -> dcolon <+> ppr kind
-
-    ppr (TyDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdTyDefn = defn })
-      = pp_ty_defn (pp_vanilla_decl_head ltycon tyvars) defn
+    ppr (DataDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdDataDefn = defn })
+      = pp_data_defn (pp_vanilla_decl_head ltycon tyvars) defn
 
     ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, 
                     tcdFDs  = fds,
@@ -625,6 +584,19 @@ instance OutputableBndr name
                      <+> pp_vanilla_decl_head lclas tyvars (unLoc context)
                      <+> pprFundeps (map unLoc fds)
 
+instance (OutputableBndr name) => Outputable (FamilyDecl name) where
+  ppr (FamilyDecl { fdFlavour = flavour, fdLName = ltycon, 
+                    fdTyVars = tyvars, fdKindSig = mb_kind})
+      = ppr flavour <+> pp_vanilla_decl_head ltycon tyvars [] <+> pp_kind
+        where
+          pp_kind = case mb_kind of
+                      Nothing   -> empty
+                      Just kind -> dcolon <+> ppr kind
+
+instance Outputable FamilyFlavour where
+  ppr TypeFamily = ptext (sLit "type family")
+  ppr DataFamily = ptext (sLit "data family")
+
 pp_vanilla_decl_head :: OutputableBndr name
    => Located name
    -> LHsTyVarBndrs name
@@ -633,66 +605,24 @@ pp_vanilla_decl_head :: OutputableBndr name
 pp_vanilla_decl_head thing tyvars context
  = hsep [pprHsContext context, pprPrefixOcc (unLoc thing), ppr tyvars]
 
-pp_fam_inst_head :: OutputableBndr name
+pp_fam_inst_lhs :: OutputableBndr name
    => Located name
    -> HsWithBndrs [LHsType name]
    -> HsContext name
    -> SDoc
-pp_fam_inst_head thing (HsWB { hswb_cts = typats }) context -- explicit type patterns
-   = hsep [ ptext (sLit "instance"), pprHsContext context, pprPrefixOcc (unLoc thing)
+pp_fam_inst_lhs thing (HsWB { hswb_cts = typats }) context -- explicit type patterns
+   = hsep [ pprHsContext context, pprPrefixOcc (unLoc thing)
           , hsep (map (pprParendHsType.unLoc) typats)]
 
-pp_condecls :: OutputableBndr name => [LConDecl name] -> SDoc
-pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ } : _) -- In GADT syntax
-  = hang (ptext (sLit "where")) 2 (vcat (map ppr cs))
-pp_condecls cs                    -- In H98 syntax
-  = equals <+> sep (punctuate (ptext (sLit " |")) (map ppr cs))
-
-pp_ty_defn :: OutputableBndr name 
-           => (HsContext name -> SDoc)   -- Printing the header
-           -> HsTyDefn name
-           -> SDoc 
-
-pp_ty_defn pp_hdr (TySynonym { td_synRhs = rhs })
-  = hang (ptext (sLit "type") <+> pp_hdr [] <+> equals)
-       4 (ppr rhs)
-
-pp_ty_defn pp_hdr (TyData { td_ND = new_or_data, td_ctxt = L _ context
-                          , td_kindSig = mb_sig 
-                          , td_cons = condecls, td_derivs = derivings })
-  | null condecls
-  = ppr new_or_data <+> pp_hdr context <+> pp_sig
-
-  | otherwise
-  = hang (ppr new_or_data <+> pp_hdr context <+> pp_sig)
-       2 (pp_condecls condecls $$ pp_derivings)
-  where
-    pp_sig = case mb_sig of
-               Nothing   -> empty
-               Just kind -> dcolon <+> ppr kind
-    pp_derivings = case derivings of
-                     Nothing -> empty
-                     Just ds -> hsep [ptext (sLit "deriving"), parens (interpp'SP ds)]
-
-instance OutputableBndr name => Outputable (HsTyDefn name) where
-   ppr d = pp_ty_defn (\_ -> ptext (sLit "Naked HsTyDefn")) d
-
-instance Outputable NewOrData where
-  ppr NewType  = ptext (sLit "newtype")
-  ppr DataType = ptext (sLit "data")
-
-pprTyDefnFlavour :: HsTyDefn a -> SDoc
-pprTyDefnFlavour (TyData { td_ND = nd }) = ppr nd
-pprTyDefnFlavour (TySynonym {})          = ptext (sLit "type")
-
 pprTyClDeclFlavour :: TyClDecl a -> SDoc
-pprTyClDeclFlavour (ClassDecl {})                = ptext (sLit "class")
-pprTyClDeclFlavour (TyFamily {})                 = ptext (sLit "family")
-pprTyClDeclFlavour (TyDecl { tcdTyDefn = defn }) = pprTyDefnFlavour defn
-pprTyClDeclFlavour (ForeignType {})              = ptext (sLit "foreign type")
+pprTyClDeclFlavour (ClassDecl {})  = ptext (sLit "class")
+pprTyClDeclFlavour (FamDecl {})    = ptext (sLit "family")
+pprTyClDeclFlavour (SynDecl {})    = ptext (sLit "type")
+pprTyClDeclFlavour (DataDecl { tcdDataDefn = (HsDataDefn { dd_ND = nd }) })
+  = ppr nd
+pprTyClDeclFlavour (ForeignType {}) = ptext (sLit "foreign type")
 \end{code}
 
-
 %************************************************************************
 %*                                                                      *
 \subsection[ConDecl]{A data-constructor declaration}
@@ -700,6 +630,52 @@ pprTyClDeclFlavour (ForeignType {})              = ptext (sLit "foreign type")
 %************************************************************************
 
 \begin{code}
+
+data HsDataDefn name   -- The payload of a data type defn
+                       -- Used *both* for vanilla data declarations,
+                       --       *and* for data family instances
+  = -- | Declares a data type or newtype, giving its construcors
+    -- @
+    --  data/newtype T a = <constrs>
+    --  data/newtype instance T [a] = <constrs>
+    -- @
+    HsDataDefn { dd_ND     :: NewOrData,
+                 dd_ctxt   :: LHsContext name,           -- ^ Context
+                 dd_cType  :: Maybe CType,
+                 dd_kindSig:: Maybe (LHsKind name),
+                     -- ^ Optional kind signature.
+                     --
+                     -- @(Just k)@ for a GADT-style @data@, 
+                     -- or @data instance@ decl, with explicit kind sig
+                     --
+                     -- Always @Nothing@ for H98-syntax decls
+
+                 dd_cons   :: [LConDecl name],
+                     -- ^ Data constructors
+                     --
+                     -- For @data T a = T1 | T2 a@
+                     --   the 'LConDecl's all have 'ResTyH98'.
+                     -- For @data T a where { T1 :: T a }@
+                     --   the 'LConDecls' all have 'ResTyGADT'.
+
+                 dd_derivs :: Maybe [LHsType name]
+                     -- ^ Derivings; @Nothing@ => not specified,
+                     --              @Just []@ => derive exactly what is asked
+                     --
+                     -- These "types" must be of form
+                     -- @
+                     --      forall ab. C ty1 ty2
+                     -- @
+                     -- Typically the foralls and ty args are empty, but they
+                     -- are non-empty for the newtype-deriving case
+    }
+    deriving( Data, Typeable )
+
+data NewOrData
+  = NewType                     -- ^ @newtype Blah ...@
+  | DataType                    -- ^ @data Blah ...@
+  deriving( Eq, Data, Typeable )                -- Needed because Demand derives Eq
+
 type LConDecl name = Located (ConDecl name)
 
 -- data T b = forall a. Eq a => MkT a b
@@ -774,6 +750,40 @@ instance Outputable ty => Outputable (ResType ty) where
 
 
 \begin{code}
+pp_data_defn :: OutputableBndr name
+                  => (HsContext name -> SDoc)   -- Printing the header
+                  -> HsDataDefn name
+                  -> SDoc 
+pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context
+                              , dd_kindSig = mb_sig 
+                              , dd_cons = condecls, dd_derivs = derivings })
+  | null condecls
+  = ppr new_or_data <+> pp_hdr context <+> pp_sig
+
+  | otherwise
+  = hang (ppr new_or_data <+> pp_hdr context <+> pp_sig)
+       2 (pp_condecls condecls $$ pp_derivings)
+  where
+    pp_sig = case mb_sig of
+               Nothing   -> empty
+               Just kind -> dcolon <+> ppr kind
+    pp_derivings = case derivings of
+                     Nothing -> empty
+                     Just ds -> hsep [ptext (sLit "deriving"), parens (interpp'SP ds)]
+
+instance OutputableBndr name => Outputable (HsDataDefn name) where
+   ppr d = pp_data_defn (\_ -> ptext (sLit "Naked HsDataDefn")) d
+
+instance Outputable NewOrData where
+  ppr NewType  = ptext (sLit "newtype")
+  ppr DataType = ptext (sLit "data")
+
+pp_condecls :: OutputableBndr name => [LConDecl name] -> SDoc
+pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ } : _) -- In GADT syntax
+  = hang (ptext (sLit "where")) 2 (vcat (map ppr cs))
+pp_condecls cs                    -- In H98 syntax
+  = equals <+> sep (punctuate (ptext (sLit " |")) (map ppr cs))
+
 instance (OutputableBndr name) => Outputable (ConDecl name) where
     ppr = pprConDecl
 
@@ -813,36 +823,69 @@ pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT {
 %************************************************************************
 
 \begin{code}
-type LFamInstDecl name = Located (FamInstDecl name)
-data FamInstDecl name 
-  = FamInstDecl
-       { fid_tycon :: Located name
-       , fid_pats  :: HsWithBndrs [LHsType name]  -- ^ Type patterns (with kind and type bndrs)
-                                                  -- See Note [Family instance declaration binders]
-       , fid_defn  :: HsTyDefn name               -- Type or data family instance
-       , fid_fvs   :: NameSet  } 
+-- see note [Family instance equation groups]
+type LTyFamInstEqn name = Located (TyFamInstEqn name)
+
+-- | one equation in a family instance declaration
+data TyFamInstEqn name   
+  = TyFamInstEqn
+       { tfie_tycon :: Located name
+       , tfie_pats  :: HsWithBndrs [LHsType name]
+            -- ^ Type patterns (with kind and type bndrs)
+            -- See Note [Family instance declaration binders]
+       , tfie_rhs   :: LHsType name }         
+  deriving( Typeable, Data )
+
+type LTyFamInstDecl name = Located (TyFamInstDecl name)
+data TyFamInstDecl name 
+  = TyFamInstDecl
+       { tfid_eqns     :: [LTyFamInstEqn name] -- ^ list of (possibly-overlapping) eqns 
+       , tfid_group :: Bool                  -- was this declared with the "where" syntax?
+       , tfid_fvs      :: NameSet }          -- the group is type-checked as one,
+                                             -- so one NameSet will do
+               -- INVARIANT: tfid_group == False --> length tfid_eqns == 1
+  deriving( Typeable, Data )
+
+type LDataFamInstDecl name = Located (DataFamInstDecl name)
+data DataFamInstDecl name
+  = DataFamInstDecl
+       { dfid_tycon :: Located name
+       , dfid_pats  :: HsWithBndrs [LHsType name]   -- lhs
+            -- ^ Type patterns (with kind and type bndrs)
+            -- See Note [Family instance declaration binders]
+       , dfid_defn  :: HsDataDefn  name             -- rhs
+       , dfid_fvs   :: NameSet }                    -- free vars for dependency analysis
   deriving( Typeable, Data )
 
 type LInstDecl name = Located (InstDecl name)
 data InstDecl name  -- Both class and family instances
   = ClsInstD    
+      { cid_inst  :: ClsInstDecl name }
+  | DataFamInstD              -- data family instance
+      { dfid_inst :: DataFamInstDecl name }
+  | TyFamInstD              -- type family instance
+      { tfid_inst :: TyFamInstDecl name }
+  deriving (Data, Typeable)
+
+type LClsInstDecl name = Located (ClsInstDecl name)
+data ClsInstDecl name
+  = ClsInstDecl
       { cid_poly_ty :: LHsType name    -- Context => Class Instance-type
                                        -- Using a polytype means that the renamer conveniently
                                        -- figures out the quantified type variables for us.
       , cid_binds :: LHsBinds name
       , cid_sigs  :: [LSig name]                -- User-supplied pragmatic info
-      , cid_fam_insts :: [LFamInstDecl name]    -- Family instances for associated types
+      , cid_tyfam_insts :: [LTyFamInstDecl name]  -- type family instances
+      , cid_datafam_insts :: [LDataFamInstDecl name] -- data family instances
       }
-
-  | FamInstD              -- type/data family instance
-      { lid_inst :: FamInstDecl name }
   deriving (Data, Typeable)
+
 \end{code}
 
 Note [Family instance declaration binders]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A FamInstDecl is a data/type family instance declaration
-the fid_pats field is LHS patterns, and the tvs of the HsBSig
+A {Ty|Data}FamInstDecl is a data/type family instance declaration
+the pats field is LHS patterns, and the tvs of the HsBSig
 tvs are fv(pat_tys), *including* ones that are already in scope
 
    Eg   class C s t where
@@ -858,36 +901,69 @@ tvs are fv(pat_tys), *including* ones that are already in scope
    so that we can compare the type patter in the 'instance' decl and
    in the associated 'type' decl
 
-\begin{code}
-instance (OutputableBndr name) => Outputable (FamInstDecl name) where
-  ppr (FamInstDecl { fid_tycon = tycon
-                   , fid_pats = pats
-                   , fid_defn = defn })
-    = pp_ty_defn (pp_fam_inst_head tycon pats) defn
+Note [Family instance equation groups]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A TyFamInstDecl contains a list of FamInstEqn's, one for each
+equation defined in the instance group. For a standalone
+instance declaration, this list contains exactly one element.
+It is not possible for this list to have 0 elements --
+'type instance where' without anything else is not allowed.
 
-instance (OutputableBndr name) => Outputable (InstDecl name) where
-    ppr (ClsInstD { cid_poly_ty = inst_ty, cid_binds = binds
-                  , cid_sigs = sigs, cid_fam_insts = ats })
+\begin{code}
+instance (OutputableBndr name) => Outputable (TyFamInstDecl name) where
+  ppr (TyFamInstDecl { tfid_group = False, tfid_eqns = [lEqn] })
+    = let eqn = unLoc lEqn in
+        ptext (sLit "type instance") <+> (ppr eqn)
+  ppr (TyFamInstDecl { tfid_eqns = eqns })
+    = hang (ptext (sLit "type instance where"))
+        2 (vcat (map ppr eqns))
+
+instance (OutputableBndr name) => Outputable (TyFamInstEqn name) where
+  ppr (TyFamInstEqn { tfie_tycon = tycon
+                    , tfie_pats  = pats
+                    , tfie_rhs   = rhs })
+    = (pp_fam_inst_lhs tycon pats []) <+> equals <+> (ppr rhs)
+
+instance (OutputableBndr name) => Outputable (DataFamInstDecl name) where
+  ppr (DataFamInstDecl { dfid_tycon = tycon
+                       , dfid_pats  = pats
+                       , dfid_defn  = defn })
+    = pp_data_defn ((ptext (sLit "instance") <+>) . (pp_fam_inst_lhs tycon pats)) defn
+
+pprDataFamInstFlavour :: DataFamInstDecl name -> SDoc
+pprDataFamInstFlavour (DataFamInstDecl { dfid_defn = (HsDataDefn { dd_ND = nd }) })
+  = ppr nd
+
+instance (OutputableBndr name) => Outputable (ClsInstDecl name) where
+    ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds
+                     , cid_sigs = sigs, cid_tyfam_insts = ats
+                     , cid_datafam_insts = adts })
       | null sigs && null ats && isEmptyBag binds  -- No "where" part
       = top_matter
 
       | otherwise       -- Laid out
       = vcat [ top_matter <+> ptext (sLit "where")
              , nest 2 $ pprDeclList (map ppr ats ++
+                                     map ppr adts ++
                                      pprLHsBindsForUser binds sigs) ]
       where
         top_matter = ptext (sLit "instance") <+> ppr inst_ty
 
-    ppr (FamInstD { lid_inst = decl }) = ppr decl
+instance (OutputableBndr name) => Outputable (InstDecl name) where
+    ppr (ClsInstD     { cid_inst  = decl }) = ppr decl
+    ppr (TyFamInstD   { tfid_inst = decl }) = ppr decl
+    ppr (DataFamInstD { dfid_inst = decl }) = ppr decl
 
--- Extract the declarations of associated types from an instance
+-- Extract the declarations of associated data types from an instance
 
-instDeclFamInsts :: [LInstDecl name] -> [FamInstDecl name]
-instDeclFamInsts inst_decls 
+instDeclDataFamInsts :: [LInstDecl name] -> [DataFamInstDecl name]
+instDeclDataFamInsts inst_decls 
   = concatMap do_one inst_decls
   where
-    do_one (L _ (ClsInstD { cid_fam_insts = fam_insts })) = map unLoc fam_insts
-    do_one (L _ (FamInstD { lid_inst = fam_inst }))       = [fam_inst]
+    do_one (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fam_insts } }))
+      = map unLoc fam_insts
+    do_one (L _ (DataFamInstD { dfid_inst = fam_inst }))      = [fam_inst]
+    do_one (L _ (TyFamInstD {}))                              = []
 \end{code}
 
 %************************************************************************
index ffcc3ba..93d91b1 100644 (file)
@@ -45,6 +45,7 @@ import HsLit
 import NameSet( FreeVars )
 import Name( Name )
 import RdrName( RdrName )
+import DataCon( HsBang(..) )
 import Type
 import HsDoc
 import BasicTypes
index 087ecd2..e1005b6 100644 (file)
@@ -68,7 +68,7 @@ module HsUtils(
   collectLStmtBinders, collectStmtBinders,
 
   hsLTyClDeclBinders, hsTyClDeclBinders, hsTyClDeclsBinders, 
-  hsForeignDeclsBinders, hsGroupBinders, hsFamInstBinders,
+  hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,
   
   -- Collecting implicit binders
   lStmtsImplicits, hsValBindsImplicits, lPatImplicits
@@ -639,32 +639,35 @@ hsLTyClDeclBinders (L _ d) = hsTyClDeclBinders d
 
 -------------------
 hsTyClDeclBinders :: Eq name => TyClDecl name -> [Located name]
-hsTyClDeclBinders (TyFamily    {tcdLName = name}) = [name]
+hsTyClDeclBinders (FamDecl { tcdFam = FamilyDecl { fdLName = name} }) = [name]
 hsTyClDeclBinders (ForeignType {tcdLName = name}) = [name]
+hsTyClDeclBinders (SynDecl     {tcdLName = name}) = [name]
 
 hsTyClDeclBinders (ClassDecl { tcdLName = cls_name, tcdSigs = sigs
-                             , tcdATs = ats, tcdATDefs = fam_insts })
+                             , tcdATs = ats })
   = cls_name : 
-    concatMap hsLTyClDeclBinders ats ++ 
-    concatMap (hsFamInstBinders . unLoc) fam_insts ++
+    map (fdLName . unLoc) ats ++ 
     [n | L _ (TypeSig ns _) <- sigs, n <- ns]
 
-hsTyClDeclBinders (TyDecl { tcdLName = name, tcdTyDefn = defn }) 
-  = name : hsTyDefnBinders defn
+hsTyClDeclBinders (DataDecl { tcdLName = name, tcdDataDefn = defn }) 
+  = name : hsDataDefnBinders defn
 
 -------------------
 hsInstDeclBinders :: Eq name => InstDecl name -> [Located name]
-hsInstDeclBinders (ClsInstD { cid_fam_insts = fis }) = concatMap (hsFamInstBinders . unLoc) fis
-hsInstDeclBinders (FamInstD { lid_inst = fi }) = hsFamInstBinders fi
+hsInstDeclBinders (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } })
+  = concatMap (hsDataFamInstBinders . unLoc) dfis
+hsInstDeclBinders (DataFamInstD { dfid_inst = fi }) = hsDataFamInstBinders fi
+hsInstDeclBinders (TyFamInstD {}) = []
 
 -------------------
-hsFamInstBinders :: Eq name => FamInstDecl name -> [Located name]
-hsFamInstBinders (FamInstDecl { fid_defn = defn }) = hsTyDefnBinders defn
+hsDataFamInstBinders :: Eq name => DataFamInstDecl name -> [Located name]
+hsDataFamInstBinders (DataFamInstDecl { dfid_defn = defn })
+  = hsDataDefnBinders defn
+  -- There can't be repeated symbols because only data instances have binders
 
 -------------------
-hsTyDefnBinders :: Eq name => HsTyDefn name -> [Located name]
-hsTyDefnBinders (TySynonym {})              = []
-hsTyDefnBinders (TyData { td_cons = cons }) = hsConDeclsBinders cons
+hsDataDefnBinders :: Eq name => HsDataDefn name -> [Located name]
+hsDataDefnBinders (HsDataDefn { dd_cons = cons }) = hsConDeclsBinders cons
   -- See Note [Binders in family instances]
 
 -------------------
index 5d667ce..cf9402a 100644 (file)
@@ -748,20 +748,19 @@ instance Binary InlineSpec where
                   2 -> return Inlinable
                   _ -> return NoInline
 
-instance Binary HsBang where
-    put_ bh HsNoBang        = putByte bh 0
-    put_ bh HsStrict        = putByte bh 1
-    put_ bh HsUnpack        = putByte bh 2
-    put_ bh HsUnpackFailed  = putByte bh 3
-    put_ bh HsNoUnpack      = putByte bh 4
+instance Binary IfaceBang where
+    put_ bh IfNoBang        = putByte bh 0
+    put_ bh IfStrict        = putByte bh 1
+    put_ bh IfUnpack        = putByte bh 2
+    put_ bh (IfUnpackCo co) = putByte bh 3 >> put_ bh co
+
     get bh = do
             h <- getByte bh
             case h of
-              0 -> do return HsNoBang
-              1 -> do return HsStrict
-              2 -> do return HsUnpack
-              3 -> do return HsUnpackFailed
-              _ -> do return HsNoUnpack
+              0 -> do return IfNoBang
+              1 -> do return IfStrict
+              2 -> do return IfUnpack
+              _ -> do { a <- get bh; return (IfUnpackCo a) }
 
 instance Binary TupleSort where
     put_ bh BoxedTuple      = putByte bh 0
@@ -1048,7 +1047,7 @@ instance Binary LeftOrRight where
                    _ -> return CRight }
 
 instance Binary IfaceCoCon where
-   put_ bh (IfaceCoAx n)       = do { putByte bh 0; put_ bh n }
+   put_ bh (IfaceCoAx n ind)   = do { putByte bh 0; put_ bh n; put_ bh ind }
    put_ bh IfaceReflCo         = putByte bh 1
    put_ bh IfaceUnsafeCo       = putByte bh 2
    put_ bh IfaceSymCo          = putByte bh 3
@@ -1060,7 +1059,7 @@ instance Binary IfaceCoCon where
    get bh = do
         h <- getByte bh
         case h of
-          0 -> do { n <- get bh; return (IfaceCoAx n) }
+          0 -> do { n <- get bh; ind <- get bh; return (IfaceCoAx n ind) }
           1 -> return IfaceReflCo 
           2 -> return IfaceUnsafeCo
           3 -> return IfaceSymCo
@@ -1355,12 +1354,11 @@ instance Binary IfaceDecl where
         put_ bh a6
         put_ bh a7
         
-    put_ bh (IfaceAxiom a1 a2 a3 a4) = do
+    put_ bh (IfaceAxiom a1 a2 a3) = do
         putByte bh 5
         put_ bh (occNameFS a1)
         put_ bh a2
         put_ bh a3
-        put_ bh a4
 
     get bh = do
         h <- getByte bh
@@ -1400,9 +1398,19 @@ instance Binary IfaceDecl where
             _ -> do a1 <- get bh
                     a2 <- get bh
                     a3 <- get bh
-                    a4 <- get bh
                     occ <- return $! mkOccNameFS tcName a1
-                    return (IfaceAxiom occ a2 a3 a4)
+                    return (IfaceAxiom occ a2 a3)
+
+instance Binary IfaceAxBranch where
+    put_ bh (IfaceAxBranch a1 a2 a3) = do
+        put_ bh a1
+        put_ bh a2
+        put_ bh a3
+    get bh = do
+        a1 <- get bh
+        a2 <- get bh
+        a3 <- get bh
+        return (IfaceAxBranch a1 a2 a3)
 
 instance Binary ty => Binary (SynTyConRhs ty) where
     put_ bh (SynFamilyTyCon a b) = putByte bh 0 >> put_ bh a >> put_ bh b
@@ -1432,17 +1440,19 @@ instance Binary IfaceClsInst where
         return (IfaceClsInst cls tys dfun flag orph)
 
 instance Binary IfaceFamInst where
-    put_ bh (IfaceFamInst fam tys name orph) = do
+    put_ bh (IfaceFamInst fam group tys name orph) = do
         put_ bh fam
+        put_ bh group
         put_ bh tys
         put_ bh name
         put_ bh orph
     get bh = do
         fam      <- get bh
+        group    <- get bh
         tys      <- get bh
         name     <- get bh
         orph     <- get bh
-        return (IfaceFamInst fam tys name orph)
+        return (IfaceFamInst fam group tys name orph)
 
 instance Binary OverlapFlag where
     put_ bh (NoOverlap  b) = putByte bh 0 >> put_ bh b
index be757c6..495c6b9 100644 (file)
@@ -24,7 +24,7 @@ module BuildTyCl (
 #include "HsVersions.h"
 
 import IfaceEnv
-
+import FamInstEnv( FamInstEnvs )
 import DataCon
 import Var
 import VarSet
@@ -39,6 +39,7 @@ import Coercion
 
 import DynFlags
 import TcRnMonad
+import UniqSupply
 import Util
 import Outputable
 \end{code}
@@ -133,7 +134,8 @@ mkNewTyConRhs tycon_name tycon con
                                
 
 ------------------------------------------------------
-buildDataCon :: Name -> Bool
+buildDataCon :: FamInstEnvs 
+            -> Name -> Bool
            -> [HsBang] 
            -> [Name]                   -- Field labels
            -> [TyVar] -> [TyVar]       -- Univ and ext 
@@ -147,7 +149,7 @@ buildDataCon :: Name -> Bool
 --   a) makes the worker Id
 --   b) makes the wrapper Id if necessary, including
 --     allocating its unique (hence monadic)
-buildDataCon src_name declared_infix arg_stricts field_lbls
+buildDataCon fam_envs src_name declared_infix arg_stricts field_lbls
             univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon
   = do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
        ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
@@ -155,14 +157,17 @@ buildDataCon src_name declared_infix arg_stricts field_lbls
        -- code, which (for Haskell source anyway) will be in the DataName name
        -- space, and puts it into the VarName name space
 
+        ; us <- newUniqueSupply
+        ; dflags <- getDynFlags
        ; let
                stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
                data_con = mkDataCon src_name declared_infix
                                     arg_stricts field_lbls
                                     univ_tvs ex_tvs eq_spec ctxt
                                     arg_tys res_ty rep_tycon
-                                    stupid_ctxt dc_ids
-               dc_ids = mkDataConIds wrap_name work_name data_con
+                                    stupid_ctxt dc_wrk dc_rep
+                dc_wrk = mkDataConWorkId work_name data_con
+                dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name data_con)
 
        ; return data_con }
 
@@ -248,7 +253,8 @@ buildClass no_unf tycon_name tvs sc_theta fds at_items sig_stuff tc_isrec
              arg_tys   = sc_theta ++ op_tys
               rec_tycon = classTyCon rec_clas
                
-       ; dict_con <- buildDataCon datacon_name
+       ; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs")
+                                   datacon_name
                                   False        -- Not declared infix
                                   (map (const HsNoBang) args)
                                   [{- No fields -}]
index 2f827ca..e72f95c 100644 (file)
@@ -20,7 +20,8 @@ module IfaceSyn (
         IfaceBinding(..), IfaceConAlt(..),
         IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..),
         IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
-        IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..),
+        IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..), 
+        IfaceBang(..), IfaceAxBranch(..),
 
         -- Misc
         ifaceDeclImplicitBndrs, visibleIfConDecls,
@@ -102,10 +103,10 @@ data IfaceDecl
                                                 --   with the class recursive?
     }
 
-  | IfaceAxiom { ifName   :: OccName       -- Axiom name
-               , ifTyVars :: [IfaceTvBndr] -- Axiom tyvars
-               , ifLHS    :: IfaceType     -- Axiom LHS
-               , ifRHS    :: IfaceType }   -- and RHS
+  | IfaceAxiom { ifName       :: OccName,        -- Axiom name
+                 ifTyCon      :: IfaceTyCon,     -- LHS TyCon
+                 ifAxBranches :: [IfaceAxBranch] -- Branches
+    }
 
   | IfaceForeign { ifName :: OccName,           -- Needs expanding when we move
                                                 -- beyond .NET
@@ -126,6 +127,11 @@ data IfaceATDefault = IfaceATD [IfaceTvBndr] [IfaceType] IfaceType
         --   3. The instantiated family arguments
         --   2. The RHS of the synonym
 
+-- this is just like CoAxBranch
+data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr]
+                                   , ifaxbLHS    :: [IfaceType]
+                                   , ifaxbRHS    :: IfaceType }
+
 data IfaceConDecls
   = IfAbstractTyCon Bool        -- c.f TyCon.AbstractTyCon
   | IfDataFamTyCon              -- Data family
@@ -149,9 +155,12 @@ data IfaceConDecl
         ifConCtxt    :: IfaceContext,           -- Non-stupid context
         ifConArgTys  :: [IfaceType],            -- Arg types
         ifConFields  :: [OccName],              -- ...ditto... (field labels)
-        ifConStricts :: [HsBang]}               -- Empty (meaning all lazy),
+        ifConStricts :: [IfaceBang]}            -- Empty (meaning all lazy),
                                                 -- or 1-1 corresp with arg tys
 
+data IfaceBang
+  = IfNoBang | IfStrict | IfUnpack | IfUnpackCo IfaceCoercion
+
 data IfaceClsInst
   = IfaceClsInst { ifInstCls  :: IfExtName,                -- See comments with
                    ifInstTys  :: [Maybe IfaceTyCon],       -- the defn of ClsInst
@@ -165,11 +174,15 @@ data IfaceClsInst
         -- If this instance decl is *used*, we'll record a usage on the dfun;
         -- and if the head does not change it won't be used if it wasn't before
 
+-- The ifFamInstTys field of IfaceFamInst contains a list of the rough
+-- match types, one per branch... but each "rough match types" is itself
+-- a list of Maybe IfaceTyCon. So, we get [[Maybe IfaceTyCon]].
 data IfaceFamInst
-  = IfaceFamInst { ifFamInstFam   :: IfExtName           -- Family name
-                 , ifFamInstTys   :: [Maybe IfaceTyCon]  -- Rough match types
-                 , ifFamInstAxiom :: IfExtName           -- The axiom
-                 , ifFamInstOrph  :: Maybe OccName       -- Just like IfaceClsInst
+  = IfaceFamInst { ifFamInstFam   :: IfExtName            -- Family name
+                 , ifFamInstGroup :: Bool                 -- Is this a group?
+                 , ifFamInstTys   :: [[Maybe IfaceTyCon]] -- See above
+                 , ifFamInstAxiom :: IfExtName            -- The axiom
+                 , ifFamInstOrph  :: Maybe OccName        -- Just like IfaceClsInst
                  }
 
 data IfaceRule
@@ -517,10 +530,13 @@ pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
                 sep (map ppr ats),
                 sep (map ppr sigs)])
 
-pprIfaceDecl (IfaceAxiom {ifName = name, ifTyVars = tyvars,
-                          ifLHS = lhs, ifRHS = rhs})
-  = hang (ptext (sLit "axiom") <+> ppr name <+> ppr tyvars)
-       2 (dcolon <+> ppr lhs <+> text "~#" <+> ppr rhs)
+pprIfaceDecl (IfaceAxiom {ifName = name, ifTyCon = tycon, ifAxBranches = branches })
+  = hang (ptext (sLit "axiom") <+> ppr name <> colon)
+       2 (vcat $ map (pprIfaceAxBranch tycon) branches)
+
+pprIfaceAxBranch :: IfaceTyCon -> IfaceAxBranch -> SDoc
+pprIfaceAxBranch tc (IfaceAxBranch { ifaxbTyVars = tyvars, ifaxbLHS = lhs, ifaxbRHS = rhs })
+  = pprIfaceTvBndrs tyvars <> dot <+> ppr (IfaceTyConApp tc lhs) <+> text "~#" <+> ppr rhs
 
 pprCType :: Maybe CType -> SDoc
 pprCType Nothing = ptext (sLit "No C type associated")
@@ -572,8 +588,10 @@ pprIfaceConDecl tc
          ppUnless (null fields) $
             nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))]
   where
-    ppr_bang HsNoBang = char '_'        -- Want to see these
-    ppr_bang bang     = ppr bang
+    ppr_bang IfNoBang = char '_'        -- Want to see these
+    ppr_bang IfStrict = char '!'
+    ppr_bang IfUnpack = ptext (sLit "!!")
+    ppr_bang (IfUnpackCo co) = ptext (sLit "!!") <> pprParendIfaceType co
 
     main_payload = ppr name <+> dcolon <+>
                    pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau
@@ -606,10 +624,10 @@ instance Outputable IfaceClsInst where
          2 (equals <+> ppr dfun_id)
 
 instance Outputable IfaceFamInst where
-  ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcs,
+  ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcss,
                      ifFamInstAxiom = tycon_ax})
     = hang (ptext (sLit "family instance") <+>
-            ppr fam <+> brackets (pprWithCommas ppr_rough mb_tcs))
+            ppr fam <+> pprWithCommas (brackets . pprWithCommas ppr_rough) mb_tcss)
          2 (equals <+> ppr tycon_ax)
 
 ppr_rough :: Maybe IfaceTyCon -> SDoc
@@ -787,9 +805,16 @@ freeNamesIfDecl d@IfaceClass{} =
   fnList freeNamesIfAT     (ifATs d) &&&
   fnList freeNamesIfClsSig (ifSigs d)
 freeNamesIfDecl d@IfaceAxiom{} =
-  freeNamesIfTvBndrs (ifTyVars d) &&&
-  freeNamesIfType (ifLHS d) &&&
-  freeNamesIfType (ifRHS d)
+  freeNamesIfTc (ifTyCon d) &&&
+  fnList freeNamesIfAxBranch (ifAxBranches d)
+
+freeNamesIfAxBranch :: IfaceAxBranch -> NameSet
+freeNamesIfAxBranch (IfaceAxBranch { ifaxbTyVars = tyvars
+                                   , ifaxbLHS    = lhs
+                                   , ifaxbRHS    = rhs }) =
+  freeNamesIfTvBndrs tyvars &&&
+  fnList freeNamesIfType lhs &&&
+  freeNamesIfType rhs
 
 freeNamesIfIdDetails :: IfaceIdDetails -> NameSet
 freeNamesIfIdDetails (IfRecSelId tc _) = freeNamesIfTc tc
@@ -920,7 +945,7 @@ freeNamesIfTc (IfaceTc tc) = unitNameSet tc
 -- ToDo: shouldn't we include IfaceIntTc & co.?
 
 freeNamesIfCo :: IfaceCoCon -> NameSet
-freeNamesIfCo (IfaceCoAx tc) = unitNameSet tc
+freeNamesIfCo (IfaceCoAx tc _) = unitNameSet tc
 -- ToDo: include IfaceIPCoAx? Probably not necessary.
 freeNamesIfCo _ = emptyNameSet
 
index fd12af1..103d336 100644 (file)
@@ -32,6 +32,7 @@ import Coercion
 import TypeRep hiding( maybeParen )
 import Unique( hasKey )
 import TyCon
+import CoAxiom
 import Id
 import Var
 import TysWiredIn
@@ -89,7 +90,7 @@ newtype IfaceTyCon = IfaceTc { ifaceTyConName :: IfExtName }
 
   -- Coercion constructors
 data IfaceCoCon
-  = IfaceCoAx IfExtName
+  = IfaceCoAx IfExtName Int -- Int is 0-indexed branch number
   | IfaceReflCo    | IfaceUnsafeCo  | IfaceSymCo
   | IfaceTransCo   | IfaceInstCo
   | IfaceNthCo Int | IfaceLRCo LeftOrRight
@@ -264,7 +265,7 @@ instance Outputable IfaceTyCon where
   ppr = ppr . ifaceTyConName
 
 instance Outputable IfaceCoCon where
-  ppr (IfaceCoAx n)    = ppr n
+  ppr (IfaceCoAx n i)  = ppr n <> brackets (ppr i)
   ppr IfaceReflCo      = ptext (sLit "Refl")
   ppr IfaceUnsafeCo    = ptext (sLit "Unsafe")
   ppr IfaceSymCo       = ptext (sLit "Sym")
@@ -358,7 +359,8 @@ 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 (coAxiomToIfaceType con)
+coToIfaceType (AxiomInstCo con ind cos)
+                                    = IfaceCoConApp (coAxiomToIfaceType con ind)
                                                     (map coToIfaceType cos)
 coToIfaceType (UnsafeCo ty1 ty2)    = IfaceCoConApp IfaceUnsafeCo
                                                     [ toIfaceType ty1
@@ -376,7 +378,7 @@ coToIfaceType (InstCo co ty)        = IfaceCoConApp IfaceInstCo
                                                     [ coToIfaceType co
                                                     , toIfaceType ty ]
 
-coAxiomToIfaceType :: CoAxiom -> IfaceCoCon
-coAxiomToIfaceType con = IfaceCoAx (coAxiomName con)
+coAxiomToIfaceType :: CoAxiom br -> Int -> IfaceCoCon
+coAxiomToIfaceType con ind = IfaceCoAx (coAxiomName con) ind
 \end{code}
 
index 74a5acd..53e1a63 100644 (file)
@@ -69,7 +69,7 @@ import CoreFVs
 import Class
 import Kind
 import TyCon
-import Coercion         ( coAxiomSplitLHS )
+import CoAxiom
 import DataCon
 import Type
 import TcType
@@ -1438,17 +1438,24 @@ idToIfaceDecl id
 
 
 --------------------------
-coAxiomToIfaceDecl :: CoAxiom -> IfaceDecl
+coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl
 -- We *do* tidy Axioms, because they are not (and cannot 
 -- conveniently be) built in tidy form
-coAxiomToIfaceDecl ax
- = IfaceAxiom { ifName = name
-              , ifTyVars = toIfaceTvBndrs tv_bndrs
-              , ifLHS    = tidyToIfaceType env (coAxiomLHS ax)
-              , ifRHS    = tidyToIfaceType env (coAxiomRHS ax) }
+coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches })
+ = IfaceAxiom { ifName       = name
+              , ifTyCon      = toIfaceTyCon tycon
+              , ifAxBranches = brListMap coAxBranchToIfaceBranch branches }
  where
    name = getOccName ax
-   (env, tv_bndrs) = tidyTyVarBndrs emptyTidyEnv (coAxiomTyVars ax)
+
+
+coAxBranchToIfaceBranch :: CoAxBranch -> IfaceAxBranch
+coAxBranchToIfaceBranch (CoAxBranch { cab_tvs = tvs, cab_lhs = lhs, cab_rhs = rhs })
+  = IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tv_bndrs
+                  , ifaxbLHS    = map (tidyToIfaceType env) lhs
+                  , ifaxbRHS    = tidyToIfaceType env rhs }
+  where
+    (env, tv_bndrs) = tidyTyVarBndrs emptyTidyEnv tvs
 
 -----------------
 tyConToIfaceDecl :: TidyEnv -> TyCon -> IfaceDecl
@@ -1505,7 +1512,7 @@ tyConToIfaceDecl env tycon
                     ifConArgTys  = map (tidyToIfaceType env2) arg_tys,
                     ifConFields  = map getOccName 
                                        (dataConFieldLabels data_con),
-                    ifConStricts = dataConStrictMarks data_con }
+                    ifConStricts = map (toIfaceBang env2) (dataConRepBangs data_con) }
         where
           (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con
 
@@ -1516,6 +1523,12 @@ tyConToIfaceDecl env tycon
           to_eq_spec spec = [ (getOccName (tidyTyVar env2 tv), tidyToIfaceType env2 ty) 
                             | (tv,ty) <- spec]
 
+toIfaceBang :: TidyEnv -> HsBang -> IfaceBang
+toIfaceBang _    HsNoBang            = IfNoBang
+toIfaceBang _   (HsUnpack Nothing)   = IfUnpack
+toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (coToIfaceType (tidyCo env co))
+toIfaceBang _   HsStrict             = IfStrict
+toIfaceBang _   (HsBang {})          = panic "toIfaceBang"
 
 classToIfaceDecl :: TidyEnv -> Class -> IfaceDecl
 classToIfaceDecl env clas
@@ -1631,24 +1644,28 @@ instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag,
                         (n : _) -> Just (nameOccName n)
 
 --------------------------
-famInstToIfaceFamInst :: FamInst -> IfaceFamInst
-famInstToIfaceFamInst (FamInst { fi_axiom  = axiom,
-                                 fi_fam    = fam,
-                                 fi_tcs    = mb_tcs })
+famInstToIfaceFamInst :: FamInst br -> IfaceFamInst
+famInstToIfaceFamInst (FamInst { fi_axiom    = axiom,
+                                 fi_group    = group,
+                                 fi_fam      = fam,
+                                 fi_branches = branches })
   = IfaceFamInst { ifFamInstAxiom = coAxiomName axiom
                  , ifFamInstFam   = fam
-                 , ifFamInstTys   = map do_rough mb_tcs
+                 , ifFamInstGroup = group
+                 , ifFamInstTys   = map (map do_rough) roughs
                  , ifFamInstOrph  = orph }
   where
+    roughs = brListMap famInstBranchRoughMatch branches
+
     do_rough Nothing  = Nothing
     do_rough (Just n) = Just (toIfaceTyCon_name n)
 
-    fam_decl = tyConName . fst $ coAxiomSplitLHS axiom
+    fam_decl = tyConName $ coAxiomTyCon axiom
     mod = ASSERT( isExternalName (coAxiomName axiom) )
           nameModule (coAxiomName axiom)
     is_local name = nameIsLocalOrFrom mod name
 
-    lhs_names = filterNameSet is_local (orphNamesOfType (coAxiomLHS axiom))
+    lhs_names = filterNameSet is_local (orphNamesOfCoCon axiom)
 
     orph | is_local fam_decl
          = Just (nameOccName fam_decl)
index 652eb0a..3009781 100644 (file)
@@ -38,6 +38,7 @@ import MkId
 import IdInfo
 import Class
 import TyCon
+import CoAxiom
 import DataCon
 import PrelNames
 import TysWiredIn
@@ -454,13 +455,18 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name,
     tc_parent tyvars (Just ax_name)
       = ASSERT( isNoParent parent )
         do { ax <- tcIfaceCoAxiom ax_name
-           ; let (fam_tc, fam_tys) = coAxiomSplitLHS ax
-                 subst = zipTopTvSubst (coAxiomTyVars ax) (mkTyVarTys tyvars)
+           ; let fam_tc = coAxiomTyCon ax
+                 ax_unbr = toUnbranchedAxiom ax
+                 -- data families don't have branches:
+                 branch = coAxiomSingleBranch ax_unbr
+                 ax_tvs = coAxBranchTyVars branch
+                 ax_lhs = coAxBranchLHS branch
+                 subst = zipTopTvSubst ax_tvs (mkTyVarTys tyvars)
                             -- The subst matches the tyvar of the TyCon
                             -- with those from the CoAxiom.  They aren't
                             -- necessarily the same, since the two may be
                             -- gotten from separate interface-file declarations
-           ; return (FamInstTyCon ax fam_tc (substTys subst fam_tys)) }
+           ; return (FamInstTyCon ax_unbr fam_tc (substTys subst ax_lhs)) }
 
 tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, 
                                   ifSynRhs = mb_rhs_ty,
@@ -538,19 +544,25 @@ tc_iface_decl _ _ (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
         ; return (ATyCon (mkForeignTyCon name ext_name 
                                          liftedTypeKind 0)) }
 
-tc_iface_decl _ _ (IfaceAxiom {ifName = tc_occ, ifTyVars = tv_bndrs,
-                               ifLHS = lhs, ifRHS = rhs })
-  = bindIfaceTyVars tv_bndrs $ \ tvs -> do
-    { tc_name <- lookupIfaceTop tc_occ
-    ; tc_lhs  <- tcIfaceType lhs
-    ; tc_rhs  <- tcIfaceType rhs
-    ; let axiom = CoAxiom { co_ax_unique   = nameUnique tc_name
-                          , co_ax_name     = tc_name
-                          , co_ax_implicit = False
-                          , co_ax_tvs      = tvs
-                          , co_ax_lhs      = tc_lhs
-                          , co_ax_rhs      = tc_rhs }
-    ; return (ACoAxiom axiom) }
+tc_iface_decl _ _ (IfaceAxiom {ifName = ax_occ, ifTyCon = tc, ifAxBranches = branches})
+  = do { tc_name     <- lookupIfaceTop ax_occ
+       ; tc_tycon    <- tcIfaceTyCon tc
+       ; tc_branches <- mapM tc_branch branches
+       ; let axiom = CoAxiom { co_ax_unique   = nameUnique tc_name
+                             , co_ax_name     = tc_name
+                             , co_ax_tc       = tc_tycon
+                             , co_ax_branches = toBranchList tc_branches
+                             , co_ax_implicit = False }
+       ; return (ACoAxiom axiom) }
+  where tc_branch :: IfaceAxBranch -> IfL CoAxBranch
+        tc_branch (IfaceAxBranch { ifaxbTyVars = tv_bndrs, ifaxbLHS = lhs, ifaxbRHS = rhs })
+          = bindIfaceTyVars tv_bndrs $ \ tvs -> do
+            { tc_lhs <- mapM tcIfaceType lhs
+            ; tc_rhs <- tcIfaceType rhs
+            ; let branch = CoAxBranch { cab_tvs = tvs
+                                      , cab_lhs = tc_lhs
+                                      , cab_rhs = tc_rhs }
+            ; return branch }
 
 tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> IfL AlgTyConRhs
 tcIfaceDataCons tycon_name tycon _ if_cons
@@ -566,7 +578,7 @@ tcIfaceDataCons tycon_name tycon _ if_cons
                          ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
                          ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec,
                          ifConArgTys = args, ifConFields = field_lbls,
-                         ifConStricts = stricts})
+                         ifConStricts = if_stricts})
      = bindIfaceTyVars univ_tvs $ \ univ_tyvars -> do
        bindIfaceTyVars ex_tvs    $ \ ex_tyvars -> do
         { name  <- lookupIfaceTop occ
@@ -583,11 +595,14 @@ tcIfaceDataCons tycon_name tycon _ if_cons
                 ; return (eq_spec, theta, arg_tys) }
         ; lbl_names <- mapM lookupIfaceTop field_lbls
 
+        ; stricts <- mapM tc_strict if_stricts
+
         -- Remember, tycon is the representation tycon
         ; let orig_res_ty = mkFamilyTyConApp tycon 
                                 (substTyVars (mkTopTvSubst eq_spec) univ_tyvars)
 
-        ; buildDataCon name is_infix
+        ; buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr name))
+                       name is_infix
                        stricts lbl_names
                        univ_tyvars ex_tyvars 
                        eq_spec theta 
@@ -595,6 +610,12 @@ tcIfaceDataCons tycon_name tycon _ if_cons
         }
     mk_doc con_name = ptext (sLit "Constructor") <+> ppr con_name
 
+    tc_strict IfNoBang = return HsNoBang
+    tc_strict IfStrict = return HsStrict
+    tc_strict IfUnpack = return (HsUnpack Nothing)
+    tc_strict (IfUnpackCo if_co) = do { co <- tcIfaceCo if_co
+                                      ; return (HsUnpack (Just co)) }
+
 tcIfaceEqSpec :: [(OccName, IfaceType)] -> IfL [(TyVar, Type)]
 tcIfaceEqSpec spec
   = mapM do_item spec
@@ -637,13 +658,13 @@ tcIfaceInst (IfaceClsInst { ifDFun = dfun_occ, ifOFlag = oflag
        ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
        ; return (mkImportedInstance cls mb_tcs' dfun oflag) }
 
-tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
-tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs
-                             , ifFamInstAxiom = axiom_name } )
+tcIfaceFamInst :: IfaceFamInst -> IfL (FamInst Branched)
+tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcss
+                             , ifFamInstGroup = group, ifFamInstAxiom = axiom_name } )
     = do { axiom' <- forkM (ptext (sLit "Axiom") <+> ppr axiom_name) $
                      tcIfaceCoAxiom axiom_name
-         ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
-         ; return (mkImportedFamInst fam mb_tcs' axiom') }
+         ; let mb_tcss' = map (map (fmap ifaceTyConName)) mb_tcss
+         ; return (mkImportedFamInst fam group mb_tcss' axiom') }
 \end{code}
 
 
@@ -953,7 +974,9 @@ tcIfaceCo (IfaceForAllTy tv t)  = bindIfaceTyVar tv $ \ tv' ->
 
 tcIfaceCoApp :: IfaceCoCon -> [IfaceType] -> IfL Coercion
 tcIfaceCoApp IfaceReflCo      [t]     = Refl         <$> tcIfaceType t
-tcIfaceCoApp (IfaceCoAx n)    ts      = AxiomInstCo  <$> tcIfaceCoAxiom n <*> mapM tcIfaceCo ts
+tcIfaceCoApp (IfaceCoAx n i)  ts      = AxiomInstCo  <$> tcIfaceCoAxiom n
+                                                     <*> pure i
+                                                     <*> 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
@@ -1378,7 +1401,7 @@ tcIfaceKindCon (IfaceTc name)
 
            _ -> pprPanic "tcIfaceKindCon" (ppr name $$ ppr thing) }
 
-tcIfaceCoAxiom :: Name -> IfL CoAxiom
+tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched)
 tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name
                          ; return (tyThingCoAxiom thing) }
 
index 591419a..58df07c 100644 (file)
@@ -5,7 +5,7 @@ import IfaceSyn    ( IfaceDecl, IfaceClsInst, IfaceFamInst, IfaceRule, IfaceAnno
 import TypeRep     ( TyThing )
 import TcRnTypes   ( IfL )
 import InstEnv     ( ClsInst )
-import FamInstEnv  ( FamInst )
+import FamInstEnv  ( FamInst, Branched )
 import CoreSyn     ( CoreRule )
 import HscTypes    ( TypeEnv, VectInfo, IfaceVectInfo )
 import Module      ( Module )
@@ -15,7 +15,7 @@ tcIfaceDecl        :: Bool -> IfaceDecl -> IfL TyThing
 tcIfaceRules       :: Bool -> [IfaceRule] -> IfL [CoreRule]
 tcIfaceVectInfo    :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
 tcIfaceInst        :: IfaceClsInst -> IfL ClsInst
-tcIfaceFamInst     :: IfaceFamInst -> IfL FamInst
+tcIfaceFamInst     :: IfaceFamInst -> IfL (FamInst Branched)
 tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
 \end{code}
 
index ee03c93..f3d0106 100644 (file)
@@ -173,20 +173,19 @@ data DumpFlag
 
    -- debugging flags
    = Opt_D_dump_cmm
-   | Opt_D_dump_raw_cmm
-   | Opt_D_dump_cmmz
-   -- All of the cmmz subflags (there are a lot!)  Automatically
-   -- enabled if you run -ddump-cmmz
-   | Opt_D_dump_cmmz_cfg
-   | Opt_D_dump_cmmz_cbe
-   | Opt_D_dump_cmmz_proc
-   | Opt_D_dump_cmmz_rewrite
-   | Opt_D_dump_cmmz_sp
-   | Opt_D_dump_cmmz_procmap
-   | Opt_D_dump_cmmz_split
-   | Opt_D_dump_cmmz_info
-   -- end cmmz subflags
-   | Opt_D_dump_cps_cmm
+   | Opt_D_dump_cmm_raw
+   -- All of the cmm subflags (there are a lot!)  Automatically
+   -- enabled if you run -ddump-cmm
+   | Opt_D_dump_cmm_cfg
+   | Opt_D_dump_cmm_cbe
+   | Opt_D_dump_cmm_proc
+   | Opt_D_dump_cmm_rewrite
+   | Opt_D_dump_cmm_sp
+   | Opt_D_dump_cmm_procmap
+   | Opt_D_dump_cmm_split
+   | Opt_D_dump_cmm_info
+   | Opt_D_dump_cmm_cps
+   -- end cmm subflags
    | Opt_D_dump_asm
    | Opt_D_dump_asm_native
    | Opt_D_dump_asm_liveness
@@ -272,7 +271,7 @@ data GeneralFlag
    | Opt_DoEtaReduction
    | Opt_CaseMerge
    | Opt_UnboxStrictFields
-   | Opt_UnboxStrictPrimitiveFields
+   | Opt_UnboxSmallStrictFields
    | Opt_DictsCheap
    | Opt_EnableRewriteRules             -- Apply rewrite rules during simplification
    | Opt_Vectorise
@@ -2065,18 +2064,17 @@ dynamic_flags = [
   , Flag "dstg-stats"     (NoArg (setGeneralFlag Opt_StgStats))
 
   , Flag "ddump-cmm"               (setDumpFlag Opt_D_dump_cmm)
-  , Flag "ddump-raw-cmm"           (setDumpFlag Opt_D_dump_raw_cmm)
-  , Flag "ddump-cmmz"              (setDumpFlag Opt_D_dump_cmmz)
-  , Flag "ddump-cmmz-cfg"          (setDumpFlag Opt_D_dump_cmmz_cfg)
-  , Flag "ddump-cmmz-cbe"          (setDumpFlag Opt_D_dump_cmmz_cbe)
-  , Flag "ddump-cmmz-proc"         (setDumpFlag Opt_D_dump_cmmz_proc)
-  , Flag "ddump-cmmz-rewrite"      (setDumpFlag Opt_D_dump_cmmz_rewrite)
-  , Flag "ddump-cmmz-sp"           (setDumpFlag Opt_D_dump_cmmz_sp)
-  , Flag "ddump-cmmz-procmap"      (setDumpFlag Opt_D_dump_cmmz_procmap)
-  , Flag "ddump-cmmz-split"        (setDumpFlag Opt_D_dump_cmmz_split)
-  , Flag "ddump-cmmz-info"         (setDumpFlag Opt_D_dump_cmmz_info)
+  , Flag "ddump-cmm-raw"           (setDumpFlag Opt_D_dump_cmm_raw)
+  , Flag "ddump-cmm-cfg"           (setDumpFlag Opt_D_dump_cmm_cfg)
+  , Flag "ddump-cmm-cbe"           (setDumpFlag Opt_D_dump_cmm_cbe)
+  , Flag "ddump-cmm-proc"          (setDumpFlag Opt_D_dump_cmm_proc)
+  , Flag "ddump-cmm-rewrite"       (setDumpFlag Opt_D_dump_cmm_rewrite)
+  , Flag "ddump-cmm-sp"            (setDumpFlag Opt_D_dump_cmm_sp)
+  , Flag "ddump-cmm-procmap"       (setDumpFlag Opt_D_dump_cmm_procmap)
+  , Flag "ddump-cmm-split"         (setDumpFlag Opt_D_dump_cmm_split)
+  , Flag "ddump-cmm-info"          (setDumpFlag Opt_D_dump_cmm_info)
+  , Flag "ddump-cmm-cps"           (setDumpFlag Opt_D_dump_cmm_cps)
   , Flag "ddump-core-stats"        (setDumpFlag Opt_D_dump_core_stats)
-  , Flag "ddump-cps-cmm"           (setDumpFlag Opt_D_dump_cps_cmm)
   , Flag "ddump-asm"               (setDumpFlag Opt_D_dump_asm)
   , Flag "ddump-asm-native"        (setDumpFlag Opt_D_dump_asm_native)
   , Flag "ddump-asm-liveness"      (setDumpFlag Opt_D_dump_asm_liveness)
@@ -2400,7 +2398,7 @@ fFlags = [
   ( "do-eta-reduction",                 Opt_DoEtaReduction, nop ),
   ( "case-merge",                       Opt_CaseMerge, nop ),
   ( "unbox-strict-fields",              Opt_UnboxStrictFields, nop ),
-  ( "unbox-strict-primitive-fields",    Opt_UnboxStrictPrimitiveFields, nop ),
+  ( "unbox-small-strict-fields",        Opt_UnboxSmallStrictFields, nop ),
   ( "dicts-cheap",                      Opt_DictsCheap, nop ),
   ( "excess-precision",                 Opt_ExcessPrecision, nop ),
   ( "eager-blackholing",                Opt_EagerBlackHoling, nop ),
index 008a38d..40e913e 100644 (file)
@@ -181,7 +181,7 @@ module GHC (
         ClsInst, 
         instanceDFunId, 
         pprInstance, pprInstanceHdr,
-        pprFamInst, pprFamInstHdr,
+        pprFamInst,
 
         -- ** Types and Kinds
         Type, splitForAllTys, funResultTy, 
@@ -1004,7 +1004,7 @@ getBindings = withSession $ \hsc_env ->
     return $ icInScopeTTs $ hsc_IC hsc_env
 
 -- | Return the instances for the current interactive session.
-getInsts :: GhcMonad m => m ([ClsInst], [FamInst])
+getInsts :: GhcMonad m => m ([ClsInst], [FamInst Branched])
 getInsts = withSession $ \hsc_env ->
     return $ ic_instances (hsc_IC hsc_env)
 
index 5e5bd53..2a83816 100644 (file)
@@ -1297,7 +1297,7 @@ hscGenHardCode cgguts mod_summary = do
         rawcmms0 <- {-# SCC "cmmToRawCmm" #-}
                    cmmToRawCmm dflags cmms
 
-        let dump a = do dumpIfSet_dyn dflags Opt_D_dump_raw_cmm "Raw Cmm"
+        let dump a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm"
                            (ppr a)
                         return a
             rawcmms1 = Stream.mapM dump rawcmms0
@@ -1356,7 +1356,7 @@ hscCompileCmmFile hsc_env filename = runHsc hsc_env $ do
     liftIO $ do
         us <- mkSplitUniqSupply 'S'
         let initTopSRT = initUs_ us emptySRT
-        dumpIfSet_dyn dflags Opt_D_dump_cmmz "Parsed Cmm" (ppr cmm)
+        dumpIfSet_dyn dflags Opt_D_dump_cmm "Parsed Cmm" (ppr cmm)
         (_, cmmgroup) <- cmmPipeline hsc_env initTopSRT cmm
         rawCmms <- cmmToRawCmm dflags (Stream.yield cmmgroup)
         _ <- codeOutput dflags no_mod no_loc NoStubs [] rawCmms
@@ -1391,7 +1391,7 @@ tryNewCodeGen hsc_env this_mod data_tycons
         -- CmmGroup on input may produce many CmmGroups on output due
         -- to proc-point splitting).
 
-    let dump1 a = do dumpIfSet_dyn dflags Opt_D_dump_cmmz
+    let dump1 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm
                        "Cmm produced by new codegen" (ppr a)
                      return a
 
@@ -1429,7 +1429,7 @@ tryNewCodeGen hsc_env this_mod data_tycons
                 Stream.yield (srtToData topSRT)
 
     let
-        dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" $ ppr a
+        dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" $ ppr a
                      return a
 
         ppr_stream2 = Stream.mapM dump2 pipeline_stream
index 79eb8f5..2e60965 100644 (file)
@@ -122,7 +122,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
     spec_info (Just (False, _)) = (0,0,0,0,0,1,0)
     spec_info (Just (True, _))  = (0,0,0,0,0,0,1)
 
-    data_info (TyDecl { tcdTyDefn = TyData {td_cons = cs, td_derivs = derivs}})
+    data_info (DataDecl { tcdDataDefn = HsDataDefn {dd_cons = cs, dd_derivs = derivs}})
         = (length cs, case derivs of Nothing -> 0
                                      Just ds -> length ds)
     data_info _ = (0,0)
@@ -133,20 +133,17 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
                (classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl)))))
     class_info _ = (0,0)
 
-    inst_info (FamInstD { lid_inst = d }) 
-        = case countATDecl d of
-           (tyd, dtd) -> (0,0,0,tyd,dtd)
-    inst_info (ClsInstD { cid_binds = inst_meths, cid_sigs = inst_sigs, cid_fam_insts = ats })
+    inst_info (TyFamInstD {}) = (0,0,0,1,0)
+    inst_info (DataFamInstD {}) = (0,0,0,0,1)
+    inst_info (ClsInstD { cid_inst = ClsInstDecl {cid_binds = inst_meths
+                                                 , cid_sigs = inst_sigs
+                                                 , cid_tyfam_insts = ats
+                                                 , cid_datafam_insts = adts } })
         = case count_sigs (map unLoc inst_sigs) of
             (_,_,ss,is,_) ->
-              case foldr add2 (0, 0) (map (countATDecl . unLoc) ats) of
-                (tyDecl, dtDecl) ->
                   (addpr (foldr add2 (0,0) 
                            (map (count_bind.unLoc) (bagToList inst_meths))), 
-                   ss, is, tyDecl, dtDecl)
-        where
-    countATDecl (FamInstDecl { fid_defn = TyData    {} }) = (0, 1)
-    countATDecl (FamInstDecl { fid_defn = TySynonym {} }) = (1, 0)
+                   ss, is, length ats, length adts)
 
     addpr :: (Int,Int) -> Int
     add2  :: (Int,Int) -> (Int,Int) -> (Int, Int)
index b5fe0fd..299f688 100644 (file)
@@ -141,7 +141,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
     spec_info (Just (False, _)) = (0,0,0,0,0,1,0)
     spec_info (Just (True, _))  = (0,0,0,0,0,0,1)
 
-    data_info (TyDecl { tcdTyDefn = TyData {td_cons = cs, td_derivs = derivs}})
+    data_info (SynDecl { tcdTyDefn = TyData {td_cons = cs, td_derivs = derivs}})
        = (length cs, case derivs of Nothing -> 0
                                     Just ds -> length ds)
     data_info _ = (0,0)
@@ -158,10 +158,10 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
        = case count_sigs (map unLoc inst_sigs) of
            (_,_,ss,is,_) ->
              case foldr add2 (0, 0) (map (countATDecl . unLoc) ats) of
-               (tyDecl, dtDecl) ->
+               (SynDecl, dtDecl) ->
                  (addpr (foldr add2 (0,0) 
                           (map (count_bind.unLoc) (bagToList inst_meths))), 
-                   ss, is, tyDecl, dtDecl)
+                   ss, is, SynDecl, dtDecl)
         where
     countATDecl (FamInstDecl { fid_defn = TyData    {} }) = (0, 1)
     countATDecl (FamInstDecl { fid_defn = TySynonym {} }) = (1, 0)
index fce81da..2101fb5 100644 (file)
@@ -138,6 +138,7 @@ import Type
 import Annotations
 import Class
 import TyCon
+import CoAxiom
 import DataCon
 import PrelNames        ( gHC_PRIM, ioTyConName, printName )
 import Packages hiding  ( Version(..) )
@@ -455,7 +456,7 @@ lookupIfaceByModule dflags hpt pit mod
 -- modules imported by this one, directly or indirectly, and are in the Home
 -- Package Table.  This ensures that we don't see instances from modules @--make@
 -- compiled before this one, but which are not below this one.
-hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst])
+hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst Branched])
 hptInstances hsc_env want_this_module
   = let (insts, famInsts) = unzip $ flip hptAllThings hsc_env $ \mod_info -> do
                 guard (want_this_module (moduleName (mi_module (hm_iface mod_info))))
@@ -776,7 +777,7 @@ data ModDetails
         md_exports   :: [AvailInfo],
         md_types     :: !TypeEnv,       -- ^ Local type environment for this particular module
         md_insts     :: ![ClsInst],    -- ^ 'DFunId's for the instances in this module
-        md_fam_insts :: ![FamInst],
+        md_fam_insts :: ![FamInst Branched],
         md_rules     :: ![CoreRule],    -- ^ Domain may include 'Id's from other modules
         md_anns      :: ![Annotation],  -- ^ Annotations present in this module: currently
                                         -- they only annotate things also declared in this module
@@ -821,8 +822,9 @@ data ModGuts
                                          -- ToDo: I'm unconvinced this is actually used anywhere
         mg_tcs       :: ![TyCon],        -- ^ TyCons declared in this module
                                          -- (includes TyCons for classes)
-        mg_insts     :: ![ClsInst],     -- ^ Class instances declared in this module
-        mg_fam_insts :: ![FamInst],      -- ^ Family instances declared in this module
+        mg_insts     :: ![ClsInst],      -- ^ Class instances declared in this module
+        mg_fam_insts :: ![FamInst Branched], 
+                                         -- ^ Family instances declared in this module
         mg_rules     :: ![CoreRule],     -- ^ Before the core pipeline starts, contains
                                          -- See Note [Overall plumbing for rules] in Rules.lhs
         mg_binds     :: !CoreProgram,    -- ^ Bindings for this module
@@ -951,7 +953,7 @@ data InteractiveContext
              -- ^ Variables defined automatically by the system (e.g.
              -- record field selectors).  See Notes [ic_sys_vars]
 
-         ic_instances  :: ([ClsInst], [FamInst]),
+         ic_instances  :: ([ClsInst], [FamInst Branched]),
              -- ^ All instances and family instances created during
              -- this session.  These are grabbed en masse after each
              -- update to be sure that proper overlapping is retained.
@@ -1121,7 +1123,7 @@ exposed (say P2), so we use M.T for that, and P1:M.T for the other one.
 This is handled by the qual_mod component of PrintUnqualified, inside
 the (ppr mod) of case (3), in Name.pprModulePrefix
 
-    \begin{code}
+\begin{code}
 -- | Creates some functions that work out the best ways to format
 -- names for the user according to a set of heuristics
 mkPrintUnqualified :: DynFlags -> GlobalRdrEnv -> PrintUnqualified
@@ -1281,7 +1283,7 @@ extras_plus thing = thing : implicitTyThings thing
 -- For newtypes (only) add the implicit coercion tycon
 implicitCoTyCon :: TyCon -> [TyThing]
 implicitCoTyCon tc
-  | Just co <- newTyConCo_maybe tc = [ACoAxiom co]
+  | Just co <- newTyConCo_maybe tc = [ACoAxiom $ toBranchedAxiom co]
   | otherwise                      = []
 
 -- | Returns @True@ if there should be no interface-file declaration
@@ -1353,7 +1355,7 @@ type TypeEnv = NameEnv TyThing
 emptyTypeEnv    :: TypeEnv
 typeEnvElts     :: TypeEnv -> [TyThing]
 typeEnvTyCons   :: TypeEnv -> [TyCon]
-typeEnvCoAxioms :: TypeEnv -> [CoAxiom]
+typeEnvCoAxioms :: TypeEnv -> [CoAxiom Branched]
 typeEnvIds      :: TypeEnv -> [Id]
 typeEnvDataCons :: TypeEnv -> [DataCon]
 typeEnvClasses  :: TypeEnv -> [Class]
@@ -1377,7 +1379,7 @@ mkTypeEnvWithImplicits things =
     `plusNameEnv`
   mkTypeEnv (concatMap implicitTyThings things)
 
-typeEnvFromEntities :: [Id] -> [TyCon] -> [FamInst] -> TypeEnv
+typeEnvFromEntities :: [Id] -> [TyCon] -> [FamInst Branched] -> TypeEnv
 typeEnvFromEntities ids tcs famInsts =
   mkTypeEnv (   map AnId ids
              ++ map ATyCon all_tcs
@@ -1418,7 +1420,8 @@ lookupType dflags hpt pte name
   -- in one-shot, we don't use the HPT
   | not (isOneShot (ghcMode dflags)) && modulePackageId mod == this_pkg
   = do hm <- lookupUFM hpt (moduleName mod) -- Maybe monad
-       lookupNameEnv (md_types (hm_details hm)) name
+       x <- lookupNameEnv (md_types (hm_details hm)) name
+       return x
   | otherwise
   = lookupNameEnv pte name
   where 
@@ -1443,7 +1446,7 @@ tyThingTyCon (ATyCon tc) = tc
 tyThingTyCon other       = pprPanic "tyThingTyCon" (pprTyThing other)
 
 -- | Get the 'CoAxiom' from a 'TyThing' if it is a coercion axiom thing. Panics otherwise
-tyThingCoAxiom :: TyThing -> CoAxiom
+tyThingCoAxiom :: TyThing -> CoAxiom Branched
 tyThingCoAxiom (ACoAxiom ax) = ax
 tyThingCoAxiom other         = pprPanic "tyThingCoAxiom" (pprTyThing other)
 
index c5f35e5..7fa156a 100644 (file)
@@ -333,9 +333,10 @@ traceRunStatus expr bindings final_ids
              status <-
                  withBreakAction True (hsc_dflags hsc_env)
                                       breakMVar statusMVar $ do
-                   liftIO $ withInterruptsSentTo tid $ do
+                   liftIO $ mask_ $ do
                        putMVar breakMVar ()  -- awaken the stopped thread
-                       takeMVar statusMVar   -- and wait for the result
+                       redirectInterrupts tid $
+                         takeMVar statusMVar   -- and wait for the result
              traceRunStatus expr bindings final_ids
                             breakMVar statusMVar status history'
      _other ->
@@ -385,14 +386,39 @@ sandboxIO dflags statusMVar thing =
      in if gopt Opt_GhciSandbox dflags
         then do tid <- forkIO $ do res <- runIt
                                    putMVar statusMVar res -- empty: can't block
-                withInterruptsSentTo tid $ takeMVar statusMVar
+                redirectInterrupts tid $
+                  takeMVar statusMVar
+
         else -- GLUT on OS X needs to run on the main thread. If you
              -- try to use it from another thread then you just get a
              -- white rectangle rendered. For this, or anything else
              -- with such restrictions, you can turn the GHCi sandbox off
              -- and things will be run in the main thread.
+             --
+             -- BUT, note that the debugging features (breakpoints,
+             -- tracing, etc.) need the expression to be running in a
+             -- separate thread, so debugging is only enabled when
+             -- using the sandbox.
              runIt
 
+--
+-- While we're waiting for the sandbox thread to return a result, if
+-- the current thread receives an asynchronous exception we re-throw
+-- it at the sandbox thread and continue to wait.
+--
+-- This is for two reasons:
+--
+--  * So that ^C interrupts runStmt (e.g. in GHCi), allowing the
+--    computation to run its exception handlers before returning the
+--    exception result to the caller of runStmt.
+--
+--  * clients of the GHC API can terminate a runStmt in progress
+--    without knowing the ThreadId of the sandbox thread (#1381)
+--
+redirectInterrupts :: ThreadId -> IO a -> IO a
+redirectInterrupts target wait
+  = wait `catch` \e -> do throwTo target (e :: SomeException); wait
+
 -- We want to turn ^C into a break when -fbreak-on-exception is on,
 -- but it's an async exception and we only break for sync exceptions.
 -- Idea: if we catch and re-throw it, then the re-throw will trigger
@@ -417,12 +443,6 @@ rethrow dflags io = Exception.catch io $ \se -> do
 
                 Exception.throwIO se
 
-withInterruptsSentTo :: ThreadId -> IO r -> IO r
-withInterruptsSentTo thread get_result = do
-  bracket (pushInterruptTargetThread thread)
-          (\_ -> popInterruptTargetThread)
-          (\_ -> get_result)
-
 -- This function sets up the interpreter for catching breakpoints, and
 -- resets everything when the computation has stopped running.  This
 -- is a not-very-good way to ensure that only the interactive
@@ -495,10 +515,11 @@ resume canLogSpan step
                withVirtualCWD $ do
                 withBreakAction (isStep step) (hsc_dflags hsc_env)
                                         breakMVar statusMVar $ do
-                status <- liftIO $ withInterruptsSentTo tid $ do
+                status <- liftIO $ mask_ $ do
                              putMVar breakMVar ()
                                       -- this awakens the stopped thread...
-                             takeMVar statusMVar
+                             redirectInterrupts tid $
+                               takeMVar statusMVar
                                       -- and wait for the result
                 let prevHistoryLst = fromListBL 50 hist
                     hist' = case info of
index 0fa7bdf..4447ad5 100644 (file)
@@ -33,6 +33,7 @@ import Coercion( pprCoAxiom )
 import HscTypes( tyThingParent_maybe )
 import TcType
 import Name
+import StaticFlags( opt_PprStyle_Debug )
 import Outputable
 import FastString
 
@@ -203,7 +204,7 @@ pprDataConDecl pefas ss gadt_style dataCon
     (arg_tys, res_ty)        = tcSplitFunTys tau
     labels     = GHC.dataConFieldLabels dataCon
     stricts    = GHC.dataConStrictMarks dataCon
-    tys_w_strs = zip stricts arg_tys
+    tys_w_strs = zip (map user_ify stricts) arg_tys
     pp_foralls | pefas     = GHC.pprForAll forall_tvs
                | otherwise = empty
 
@@ -211,11 +212,17 @@ pprDataConDecl pefas ss gadt_style dataCon
     add str_ty pp_ty = pprParendBangTy str_ty <+> arrow <+> pp_ty
 
     pprParendBangTy (bang,ty) = ppr bang <> GHC.pprParendType ty
+    pprBangTy       (bang,ty) = ppr bang <> ppr ty
 
-    pprBangTy bang ty = ppr bang <> ppr ty
+    -- See Note [Printing bangs on data constructors]
+    user_ify :: HsBang -> HsBang
+    user_ify bang | opt_PprStyle_Debug = bang
+    user_ify HsStrict                  = HsBang False
+    user_ify (HsUnpack {})             = HsBang True
+    user_ify bang                      = bang
 
-    maybe_show_label (lbl,(strict,tp))
-       | showSub ss lbl = Just (ppr lbl <+> dcolon <+> pprBangTy strict tp)
+    maybe_show_label (lbl,bty)
+       | showSub ss lbl = Just (ppr lbl <+> dcolon <+> pprBangTy bty)
        | otherwise      = Nothing
 
     ppr_fields [ty1, ty2]
@@ -290,3 +297,11 @@ showWithLoc loc doc
   where
     comment = ptext (sLit "--")
 
+{- 
+Note [Printing bangs on data constructors] 
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For imported data constructors the dataConStrictMarks are the
+representation choices (see Note [Bangs on data constructor arguments]
+in DataCon.lhs). So we have to fiddle a little bit here to turn them
+back into user-printable form.
+-}
index 0ea01d5..39ccd62 100644 (file)
@@ -153,7 +153,7 @@ mkBootModDetailsTc hsc_env
         }
   where
 
-mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [FamInst] -> TypeEnv
+mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [FamInst Branched] -> TypeEnv
 mkBootTypeEnv exports ids tcs fam_insts
   = tidyTypeEnv True $
        typeEnvFromEntities final_ids tcs fam_insts
index 9db8f41..e3f4994 100644 (file)
@@ -642,7 +642,8 @@ ty_decl :: { LTyClDecl RdrName }
         | 'type' 'family' type opt_kind_sig 
                 -- Note the use of type for the head; this allows
                 -- infix type constructors to be declared
-                {% mkTyFamily (comb3 $1 $3 $4) TypeFamily $3 (unLoc $4) }
+                {% do { L loc decl <- mkFamDecl (comb3 $1 $3 $4) TypeFamily $3 (unLoc $4)
+                      ; return (L loc (FamDecl decl)) } }
 
           -- ordinary data type or newtype declaration
         | data_or_newtype capi_ctype tycl_hdr constrs deriving
@@ -662,26 +663,30 @@ ty_decl :: { LTyClDecl RdrName }
 
           -- data/newtype family
         | 'data' 'family' type opt_kind_sig
-                {% mkTyFamily (comb3 $1 $2 $4) DataFamily $3 (unLoc $4) }
+                {% do { L loc decl <- mkFamDecl (comb3 $1 $2 $4) DataFamily $3 (unLoc $4)
+                      ; return (L loc (FamDecl decl)) } }
 
 inst_decl :: { LInstDecl RdrName }
         : 'instance' inst_type where_inst
-                 { let (binds, sigs, _, ats, _) = cvBindsAndSigs (unLoc $3)
-                   in L (comb3 $1 $2 $3) (ClsInstD { cid_poly_ty = $2, cid_binds = binds
-                                                   , cid_sigs = sigs, cid_fam_insts = ats }) }
+                 { let (binds, sigs, _, ats, adts, _) = cvBindsAndSigs (unLoc $3) in
+                   let cid = ClsInstDecl { cid_poly_ty = $2, cid_binds = binds
+                                         , cid_sigs = sigs, cid_tyfam_insts = ats
+                                         , cid_datafam_insts = adts }
+                   in L (comb3 $1 $2 $3) (ClsInstD { cid_inst = cid }) }
 
            -- type instance declarations
-        | 'type' 'instance' type '=' ctype
-                -- Note the use of type for the head; this allows
-                -- infix type constructors and type patterns
-                {% do { L loc d <- mkFamInstSynonym (comb2 $1 $5) $3 $5
-                      ; return (L loc (FamInstD { lid_inst = d })) } }
+        | 'type' 'instance' ty_fam_inst_eqn
+                {% do { L loc tfi <- mkTyFamInst (comb2 $1 $3) $3
+                      ; return (L loc (TyFamInstD { tfid_inst = tfi })) } }
+
+        | 'type' 'instance' 'where' ty_fam_inst_eqn_list
+                { LL (TyFamInstD { tfid_inst = mkTyFamInstGroup (unLoc $4) }) }
 
           -- data/newtype instance declaration
         | data_or_newtype 'instance' tycl_hdr constrs deriving
                 {% do { L loc d <- mkFamInstData (comb4 $1 $3 $4 $5) (unLoc $1) Nothing $3
                                       Nothing (reverse (unLoc $4)) (unLoc $5)
-                      ; return (L loc (FamInstD { lid_inst = d })) } }
+                      ; return (L loc (DataFamInstD { dfid_inst = d })) } }
 
           -- GADT instance declaration
         | data_or_newtype 'instance' tycl_hdr opt_kind_sig 
@@ -689,8 +694,25 @@ inst_decl :: { LInstDecl RdrName }
                  deriving
                 {% do { L loc d <- mkFamInstData (comb4 $1 $3 $5 $6) (unLoc $1) Nothing $3
                                             (unLoc $4) (unLoc $5) (unLoc $6)
-                      ; return (L loc (FamInstD { lid_inst = d })) } }
+                      ; return (L loc (DataFamInstD { dfid_inst = d })) } }
         
+-- Type instance groups
+
+ty_fam_inst_eqn_list :: { Located [LTyFamInstEqn RdrName] }
+        :     '{' ty_fam_inst_eqns '}'     { LL (unLoc $2) }
+        | vocurly ty_fam_inst_eqns close   { $2 }
+
+ty_fam_inst_eqns :: { Located [LTyFamInstEqn RdrName] }
+        : ty_fam_inst_eqn ';' ty_fam_inst_eqns   { LL ($1 : unLoc $3) }
+        | ty_fam_inst_eqns ';'                   { LL (unLoc $1) }
+        | ty_fam_inst_eqn                        { LL [$1] }
+
+ty_fam_inst_eqn :: { LTyFamInstEqn RdrName }
+        : type '=' ctype
+                -- Note the use of type for the head; this allows
+                -- infix type constructors and type patterns
+              {% mkTyFamInstEqn (comb2 $1 $3) $1 $3 }
+
 -- Associated type family declarations
 --
 -- * They have a different syntax than on the toplevel (no family special
@@ -705,31 +727,32 @@ at_decl_cls :: { LHsDecl RdrName }
         : 'type' type opt_kind_sig
                 -- Note the use of type for the head; this allows
                 -- infix type constructors to be declared.
-                {% do { L loc decl <- mkTyFamily (comb3 $1 $2 $3) TypeFamily $2 (unLoc $3)
-                      ; return (L loc (TyClD decl)) } }
+                {% do { L loc decl <- mkFamDecl (comb3 $1 $2 $3) TypeFamily $2 (unLoc $3)
+                      ; return (L loc (TyClD (FamDecl decl))) } }
 
         | 'data' type opt_kind_sig
-                {% do { L loc decl <- mkTyFamily (comb3 $1 $2 $3) DataFamily $2 (unLoc $3)
-                      ; return (L loc (TyClD decl)) } }
+                {% do { L loc decl <- mkFamDecl (comb3 $1 $2 $3) DataFamily $2 (unLoc $3)
+                      ; return (L loc (TyClD (FamDecl decl))) } }
 
            -- default type instance
-        | 'type' type '=' ctype
+        | 'type' ty_fam_inst_eqn
                 -- Note the use of type for the head; this allows
                 -- infix type constructors and type patterns
-                {% do { L loc fid <- mkFamInstSynonym (comb2 $1 $4) $2 $4
-                      ; return (L loc (InstD (FamInstD { lid_inst = fid }))) } }
+                {% do { L loc tfi <- mkTyFamInst (comb2 $1 $2) $2
+                      ; return (L loc (InstD (TyFamInstD { tfid_inst = tfi }))) } }
 
 -- Associated type instances
 --
-at_decl_inst :: { LFamInstDecl RdrName }
+at_decl_inst :: { LTyFamInstDecl RdrName }
            -- type instance declarations
-        : 'type' type '=' ctype
+        : 'type' ty_fam_inst_eqn
                 -- Note the use of type for the head; this allows
                 -- infix type constructors and type patterns
-                {% mkFamInstSynonym (comb2 $1 $4) $2 $4 }
+                {% mkTyFamInst (comb2 $1 $2) $2 }
 
+adt_decl_inst :: { LDataFamInstDecl RdrName }
         -- data/newtype instance declaration
-        | data_or_newtype capi_ctype tycl_hdr constrs deriving
+        : data_or_newtype capi_ctype tycl_hdr constrs deriving
                 {% mkFamInstData (comb4 $1 $3 $4 $5) (unLoc $1) $2 $3 
                                  Nothing (reverse (unLoc $4)) (unLoc $5) }
 
@@ -808,7 +831,8 @@ where_cls :: { Located (OrdList (LHsDecl RdrName)) }    -- Reversed
 -- Declarations in instance bodies
 --
 decl_inst  :: { Located (OrdList (LHsDecl RdrName)) }
-decl_inst  : at_decl_inst               { LL (unitOL (L1 (InstD (FamInstD { lid_inst = unLoc $1 })))) }
+decl_inst  : at_decl_inst               { LL (unitOL (L1 (InstD (TyFamInstD { tfid_inst = unLoc $1 })))) }
+           | adt_decl_inst              { LL (unitOL (L1 (InstD (DataFamInstD { dfid_inst = unLoc $1 })))) }
            | decl                       { $1 }
 
 decls_inst :: { Located (OrdList (LHsDecl RdrName)) }   -- Reversed
@@ -870,16 +894,17 @@ rules   :: { OrdList (LHsDecl RdrName) }
         |  {- empty -}                          { nilOL }
 
 rule    :: { LHsDecl RdrName }
-        : STRING activation rule_forall infixexp '=' exp
+        : STRING rule_activation rule_forall infixexp '=' exp
              { LL $ RuleD (HsRule (getSTRING $1) 
                                   ($2 `orElse` AlwaysActive) 
                                   $3 $4 placeHolderNames $6 placeHolderNames) }
 
-activation :: { Maybe Activation } 
+-- Rules can be specified to be NeverActive, unlike inline/specialize pragmas
+rule_activation :: { Maybe Activation } 
         : {- empty -}                           { Nothing }
-        | explicit_activation                   { Just $1 }
+        | rule_explicit_activation              { Just $1 }
 
-explicit_activation :: { Activation }  -- In brackets
+rule_explicit_activation :: { Activation }  -- In brackets
         : '[' INTEGER ']'               { ActiveAfter  (fromInteger (getINTEGER $2)) }
         | '[' '~' INTEGER ']'           { ActiveBefore (fromInteger (getINTEGER $3)) }
         | '[' '~' ']'                   { NeverActive }
@@ -1005,9 +1030,9 @@ infixtype :: { LHsType RdrName }
         | btype tyvarop  type    { LL $ mkHsOpTy $1 $2 $3 }
 
 strict_mark :: { Located HsBang }
-        : '!'                           { L1 HsStrict }
-        | '{-# UNPACK' '#-}' '!'        { LL HsUnpack }
-        | '{-# NOUNPACK' '#-}' '!'      { LL HsNoUnpack }
+        : '!'                           { L1 (HsBang False) }
+        | '{-# UNPACK' '#-}' '!'        { LL (HsBang True) }
+        | '{-# NOUNPACK' '#-}' '!'      { LL HsStrict }
 
 -- A ctype is a for-all type
 ctype   :: { LHsType RdrName }
@@ -1374,6 +1399,14 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
         | '{-# SPECIALISE' 'instance' inst_type '#-}'
                 { LL $ unitOL (LL $ SigD (SpecInstSig $3)) }
 
+activation :: { Maybe Activation } 
+        : {- empty -}                           { Nothing }
+        | explicit_activation                   { Just $1 }
+
+explicit_activation :: { Activation }  -- In brackets
+        : '[' INTEGER ']'               { ActiveAfter  (fromInteger (getINTEGER $2)) }
+        | '[' '~' INTEGER ']'           { ActiveBefore (fromInteger (getINTEGER $3)) }
+
 -----------------------------------------------------------------------------
 -- Expressions
 
index fbcc983..0e78794 100644 (file)
@@ -127,18 +127,18 @@ tdefs     :: { [TyClDecl RdrName] }
 
 tdef   :: { TyClDecl RdrName }
        : '%data' q_tc_name tv_bndrs '=' '{' cons '}' ';'
-       { TyDecl { tcdLName = noLoc (ifaceExtRdrName $2)
-                 , tcdTyVars = mkHsQTvs (map toHsTvBndr $3)
-                 , tcdTyDefn = TyData { td_ND = DataType, td_ctxt = noLoc [] 
-                                     , td_kindSig = Nothing
-                                      , td_cons = $6, td_derivs = Nothing } } }
+       { DataDecl { tcdLName = noLoc (ifaceExtRdrName $2)
+                   , tcdTyVars = mkHsQTvs (map toHsTvBndr $3)
+                   , tcdDataDefn = HsDataDefn { dd_ND = DataType, dd_ctxt = noLoc [] 
+                                             , dd_kindSig = Nothing
+                                              , dd_cons = $6, dd_derivs = Nothing } } }
        | '%newtype' q_tc_name tv_bndrs trep ';'
        { let tc_rdr = ifaceExtRdrName $2 in
-          TyDecl { tcdLName = noLoc tc_rdr
-                , tcdTyVars = mkHsQTvs (map toHsTvBndr $3)
-                 , tcdTyDefn = TyData { td_ND = NewType, td_ctxt = noLoc []
-                                     , td_kindSig = Nothing
-                                      , td_cons = $4 (rdrNameOcc tc_rdr), td_derivs = Nothing } } }
+          DataDecl { tcdLName = noLoc tc_rdr
+                  , tcdTyVars = mkHsQTvs (map toHsTvBndr $3)
+                   , tcdDataDefn = HsDataDefn { dd_ND = NewType, dd_ctxt = noLoc []
+                                             , dd_kindSig = Nothing
+                                              , dd_cons = $4 (rdrNameOcc tc_rdr), dd_derivs = Nothing } } }
 
 -- For a newtype we have to invent a fake data constructor name
 -- It doesn't matter what it is, because it won't be used
index 5c0d3bb..f1fa5a4 100644 (file)
@@ -10,8 +10,9 @@ module RdrHsSyn (
         mkHsDo, mkHsSplice, mkTopSpliceDecl,
         mkClassDecl, 
         mkTyData, mkFamInstData, 
-        mkTySynonym, mkFamInstSynonym,
-        mkTyFamily, 
+        mkTySynonym, mkTyFamInstEqn, mkTyFamInstGroup,
+        mkTyFamInst, 
+        mkFamDecl, 
         splitCon, mkInlinePragma,
         mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
         mkTyLit,
@@ -112,7 +113,7 @@ mkClassDecl :: SrcSpan
             -> P (LTyClDecl RdrName)
 
 mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
-  = do { let (binds, sigs, ats, at_defs, docs) = cvBindsAndSigs (unLoc where_cls)
+  = do { let (binds, sigs, ats, at_defs, _, docs) = cvBindsAndSigs (unLoc where_cls)
              cxt = fromMaybe (noLoc []) mcxt
        ; (cls, tparams) <- checkTyClHdr tycl_hdr
        ; tyvars <- checkTyVars tycl_hdr tparams      -- Only type vars allowed
@@ -133,9 +134,9 @@ mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
   = do { (tc, tparams) <- checkTyClHdr tycl_hdr
        ; tyvars <- checkTyVars tycl_hdr tparams
        ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
-       ; return (L loc (TyDecl { tcdLName = tc, tcdTyVars = tyvars,
-                                 tcdTyDefn = defn,
-                                 tcdFVs = placeHolderNames })) }
+       ; return (L loc (DataDecl { tcdLName = tc, tcdTyVars = tyvars,
+                                   tcdDataDefn = defn,
+                                   tcdFVs = placeHolderNames })) }
 
 mkFamInstData :: SrcSpan
          -> NewOrData
@@ -144,12 +145,12 @@ mkFamInstData :: SrcSpan
          -> Maybe (LHsKind RdrName)
          -> [LConDecl RdrName]
          -> Maybe [LHsType RdrName]
-         -> P (LFamInstDecl RdrName)
+         -> P (LDataFamInstDecl RdrName)
 mkFamInstData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
   = do { (tc, tparams) <- checkTyClHdr tycl_hdr
        ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
-       ; return (L loc (FamInstDecl { fid_tycon = tc, fid_pats = mkHsWithBndrs tparams
-                                    , fid_defn = defn, fid_fvs = placeHolderNames })) }
+       ; return (L loc (DataFamInstDecl { dfid_tycon = tc, dfid_pats = mkHsWithBndrs tparams
+                                        , dfid_defn = defn, dfid_fvs = placeHolderNames })) }
 
 mkDataDefn :: NewOrData
            -> Maybe CType
@@ -157,15 +158,15 @@ mkDataDefn :: NewOrData
            -> Maybe (LHsKind RdrName)
            -> [LConDecl RdrName]
            -> Maybe [LHsType RdrName]
-           -> P (HsTyDefn RdrName)
+           -> P (HsDataDefn RdrName)
 mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
   = do { checkDatatypeContext mcxt
        ; let cxt = fromMaybe (noLoc []) mcxt
-       ; return (TyData { td_ND = new_or_data, td_cType = cType
-                        , td_ctxt = cxt 
-                        , td_cons = data_cons
-                        , td_kindSig = ksig
-                        , td_derivs = maybe_deriv }) }
+       ; return (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
+                            , dd_ctxt = cxt 
+                            , dd_cons = data_cons
+                            , dd_kindSig = ksig
+                            , dd_derivs = maybe_deriv }) }
 
 mkTySynonym :: SrcSpan
             -> LHsType RdrName  -- LHS
@@ -174,29 +175,42 @@ mkTySynonym :: SrcSpan
 mkTySynonym loc lhs rhs
   = do { (tc, tparams) <- checkTyClHdr lhs
        ; tyvars <- checkTyVars lhs tparams
-       ; return (L loc (TyDecl { tcdLName = tc, tcdTyVars = tyvars,
-                                 tcdTyDefn = TySynonym { td_synRhs = rhs },
-                                 tcdFVs = placeHolderNames })) }
-
-mkFamInstSynonym :: SrcSpan
-            -> LHsType RdrName  -- LHS
-            -> LHsType RdrName  -- RHS
-            -> P (LFamInstDecl RdrName)
-mkFamInstSynonym loc lhs rhs
+       ; return (L loc (SynDecl { tcdLName = tc, tcdTyVars = tyvars,
+                                 tcdRhs = rhs, tcdFVs = placeHolderNames })) }
+
+mkTyFamInstEqn :: SrcSpan
+               -> LHsType RdrName
+               -> LHsType RdrName
+               -> P (LTyFamInstEqn RdrName)
+mkTyFamInstEqn loc lhs rhs
   = do { (tc, tparams) <- checkTyClHdr lhs
-       ; return (L loc (FamInstDecl { fid_tycon = tc, fid_pats = mkHsWithBndrs tparams
-                                    , fid_defn = TySynonym { td_synRhs = rhs }
-                                    , fid_fvs = placeHolderNames })) }
-
-mkTyFamily :: SrcSpan
-           -> FamilyFlavour
-           -> LHsType RdrName   -- LHS
-           -> Maybe (LHsKind RdrName) -- Optional kind signature
-           -> P (LTyClDecl RdrName)
-mkTyFamily loc flavour lhs ksig
+       ; return (L loc (TyFamInstEqn { tfie_tycon = tc
+                                     , tfie_pats  = mkHsWithBndrs tparams
+                                     , tfie_rhs   = rhs })) }
+
+mkTyFamInst :: SrcSpan
+            -> LTyFamInstEqn RdrName
+            -> P (LTyFamInstDecl RdrName)
+mkTyFamInst loc eqn
+  = return (L loc (TyFamInstDecl { tfid_eqns  = [eqn]
+                                 , tfid_group = False
+                                 , tfid_fvs   = placeHolderNames }))
+
+mkTyFamInstGroup :: [LTyFamInstEqn RdrName]
+                 -> TyFamInstDecl RdrName
+mkTyFamInstGroup eqns = TyFamInstDecl { tfid_eqns  = eqns
+                                      , tfid_group = True
+                                      , tfid_fvs   = placeHolderNames }
+
+mkFamDecl :: SrcSpan
+          -> FamilyFlavour
+          -> LHsType RdrName   -- LHS
+          -> Maybe (LHsKind RdrName) -- Optional kind signature
+          -> P (LFamilyDecl RdrName)
+mkFamDecl loc flavour lhs ksig
   = do { (tc, tparams) <- checkTyClHdr lhs
        ; tyvars <- checkTyVars lhs tparams
-       ; return (L loc (TyFamily flavour tc tyvars ksig)) }
+       ; return (L loc (FamilyDecl flavour tc tyvars ksig)) }
 
 mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
 -- If the user wrote
@@ -249,30 +263,32 @@ cvTopDecls decls = go (fromOL decls)
 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
 cvBindGroup binding
   = case cvBindsAndSigs binding of
-      (mbs, sigs, fam_ds, fam_insts, _) 
-         -> ASSERT( null fam_ds && null fam_insts )
+      (mbs, sigs, fam_ds, tfam_insts, dfam_insts, _) 
+         -> ASSERT( null fam_ds && null tfam_insts && null dfam_insts)
             ValBindsIn mbs sigs
 
 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
-  -> (Bag ( LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName]
-          , [LFamInstDecl RdrName], [LDocDecl])
+  -> (Bag ( LHsBind RdrName), [LSig RdrName], [LFamilyDecl RdrName]
+          , [LTyFamInstDecl RdrName], [LDataFamInstDecl RdrName], [LDocDecl])
 -- Input decls contain just value bindings and signatures
 -- and in case of class or instance declarations also
 -- associated type declarations. They might also contain Haddock comments.
 cvBindsAndSigs  fb = go (fromOL fb)
   where
-    go []                  = (emptyBag, [], [], [], [])
-    go (L l (SigD s) : ds) = (bs, L l s : ss, ts, fis, docs)
-                           where (bs, ss, ts, fis, docs) = go ds
-    go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, fis, docs)
+    go []                  = (emptyBag, [], [], [], [], [])
+    go (L l (SigD s) : ds) = (bs, L l s : ss, ts, tfis, dfis, docs)
+                           where (bs, ss, ts, tfis, dfis, docs) = go ds
+    go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, tfis, dfis, docs)
                            where (b', ds')    = getMonoBind (L l b) ds
-                                 (bs, ss, ts, fis, docs) = go ds'
-    go (L l (TyClD t@(TyFamily {})) : ds) = (bs, ss, L l t : ts, fis, docs)
-                           where (bs, ss, ts, fis, docs) = go ds
-    go (L l (InstD (FamInstD { lid_inst = fi })) : ds) = (bs, ss, ts, L l fi : fis, docs)
-                           where (bs, ss, ts, fis, docs) = go ds
-    go (L l (DocD d) : ds) =  (bs, ss, ts, fis, (L l d) : docs)
-                           where (bs, ss, ts, fis, docs) = go ds
+                                 (bs, ss, ts, tfis, dfis, docs) = go ds'
+    go (L l (TyClD (FamDecl t)) : ds) = (bs, ss, L l t : ts, tfis, dfis, docs)
+                           where (bs, ss, ts, tfis, dfis, docs) = go ds
+    go (L l (InstD (TyFamInstD { tfid_inst = tfi })) : ds) = (bs, ss, ts, L l tfi : tfis, dfis, docs)
+                           where (bs, ss, ts, tfis, dfis, docs) = go ds
+    go (L l (InstD (DataFamInstD { dfid_inst = dfi })) : ds) = (bs, ss, ts, tfis, L l dfi : dfis, docs)
+                           where (bs, ss, ts, tfis, dfis, docs) = go ds
+    go (L l (DocD d) : ds) =  (bs, ss, ts, tfis, dfis, (L l d) : docs)
+                           where (bs, ss, ts, tfis, dfis, docs) = go ds
     go (L _ d : _) = pprPanic "cvBindsAndSigs" (ppr d)
 
 -----------------------------------------------------------------------------
index 4394309..5d8dc3c 100644 (file)
@@ -281,8 +281,6 @@ basicKnownKeyNames
         randomClassName, randomGenClassName, monadPlusClassName,
 
         -- Type-level naturals
-        typeNatKindConName,
-        typeStringKindConName,
         singIClassName,
         typeNatLeqClassName,
         typeNatAddTyFamName,
@@ -587,7 +585,7 @@ unsafeIndex_RDR         = varQual_RDR gHC_ARR (fsLit "unsafeIndex")
 unsafeRangeSize_RDR     = varQual_RDR gHC_ARR (fsLit "unsafeRangeSize")
 
 readList_RDR, readListDefault_RDR, readListPrec_RDR, readListPrecDefault_RDR,
-    readPrec_RDR, parens_RDR, choose_RDR, lexP_RDR :: RdrName
+    readPrec_RDR, parens_RDR, choose_RDR, lexP_RDR, expectP_RDR :: RdrName
 readList_RDR            = varQual_RDR gHC_READ (fsLit "readList")
 readListDefault_RDR     = varQual_RDR gHC_READ (fsLit "readListDefault")
 readListPrec_RDR        = varQual_RDR gHC_READ (fsLit "readListPrec")
@@ -596,6 +594,7 @@ readPrec_RDR            = varQual_RDR gHC_READ (fsLit "readPrec")
 parens_RDR              = varQual_RDR gHC_READ (fsLit "parens")
 choose_RDR              = varQual_RDR gHC_READ (fsLit "choose")
 lexP_RDR                = varQual_RDR gHC_READ (fsLit "lexP")
+expectP_RDR             = varQual_RDR gHC_READ (fsLit "expectP")
 
 punc_RDR, ident_RDR, symbol_RDR :: RdrName
 punc_RDR                = dataQual_RDR lEX (fsLit "Punc")
@@ -1089,12 +1088,8 @@ randomGenClassName  = clsQual rANDOM (fsLit "RandomGen") randomGenClassKey
 isStringClassName   = clsQual dATA_STRING (fsLit "IsString") isStringClassKey
 
 -- Type-level naturals
-typeNatKindConName, typeStringKindConName,
-  singIClassName, typeNatLeqClassName,
+singIClassName, typeNatLeqClassName,
   typeNatAddTyFamName, typeNatMulTyFamName, typeNatExpTyFamName :: Name
-typeNatKindConName    = tcQual gHC_TYPELITS (fsLit "Nat")  typeNatKindConNameKey
-typeStringKindConName = tcQual gHC_TYPELITS (fsLit "Symbol")
-                                                        typeStringKindConNameKey
 singIClassName      = clsQual gHC_TYPELITS (fsLit "SingI") singIClassNameKey
 typeNatLeqClassName = clsQual gHC_TYPELITS (fsLit "<=")  typeNatLeqClassNameKey
 typeNatAddTyFamName = tcQual  gHC_TYPELITS (fsLit "+")   typeNatAddTyFamNameKey
index 8c8b4b7..8b9cbf9 100644 (file)
@@ -34,7 +34,6 @@ module TysPrim(
         -- Kinds
        anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, constraintKind,
         mkArrowKind, mkArrowKinds,
-        typeNatKind, typeStringKind,
 
         funTyCon, funTyConName,
         primTyCons,
@@ -344,12 +343,6 @@ unliftedTypeKind = kindTyConType unliftedTypeKindTyCon
 openTypeKind     = kindTyConType openTypeKindTyCon
 constraintKind   = kindTyConType constraintKindTyCon
 
-typeNatKind :: Kind
-typeNatKind = kindTyConType (mkKindTyCon typeNatKindConName superKind)
-
-typeStringKind :: Kind
-typeStringKind = kindTyConType (mkKindTyCon typeStringKindConName superKind)
-
 -- | Given two kinds @k1@ and @k2@, creates the 'Kind' @k1 -> k2@
 mkArrowKind :: Kind -> Kind -> Kind
 mkArrowKind k1 k2 = FunTy k1 k2
index 5071b33..d94de11 100644 (file)
@@ -64,6 +64,9 @@ module TysWiredIn (
         -- * Unit
        unitTy,
 
+        -- * Kinds
+       typeNatKindCon, typeNatKind, typeStringKindCon, typeStringKind,
+
         -- * Parallel arrays
        mkPArrTy,
        parrTyCon, parrFakeCon, isPArrTyCon, isPArrFakeCon,
@@ -76,7 +79,7 @@ module TysWiredIn (
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} MkId( mkDataConIds )
+import {-# SOURCE #-} MkId( mkDataConWorkId )
 
 -- friends:
 import PrelNames
@@ -93,7 +96,7 @@ import TypeRep
 import RdrName
 import Name
 import BasicTypes       ( TupleSort(..), tupleSortBoxity,
-                          Arity, RecFlag(..), Boxity(..), HsBang(..) )
+                          Arity, RecFlag(..), Boxity(..) )
 import ForeignCall
 import Unique           ( incrUnique, mkTupleTyConUnique,
                          mkTupleDataConUnique, mkPArrDataConUnique )
@@ -148,6 +151,8 @@ wiredInTyCons = [ unitTyCon -- Not treated like other tuples, because
              , listTyCon
              , parrTyCon
               , eqTyCon
+              , typeNatKindCon
+              , typeStringKindCon
              ]
            ++ (case cIntegerLibraryType of
                IntegerGMP -> [integerTyCon]
@@ -193,6 +198,11 @@ floatDataConName   = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "F#") floa
 doubleTyConName    = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Double") doubleTyConKey doubleTyCon
 doubleDataConName  = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "D#") doubleDataConKey doubleDataCon
 
+-- Kinds
+typeNatKindConName, typeStringKindConName :: Name
+typeNatKindConName    = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "Nat")    typeNatKindConNameKey    typeNatKindCon
+typeStringKindConName = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "Symbol") typeStringKindConNameKey typeStringKindCon 
+
 -- For integer-gmp only:
 integerRealTyConName :: Name
 integerRealTyConName    = case cIntegerLibraryType of
@@ -277,16 +287,33 @@ pcDataConWithFixity' declared_infix dc_name wrk_key tyvars arg_tys tycon
                arg_tys (mkTyConApp tycon (mkTyVarTys tyvars)) 
                tycon
                []      -- No stupid theta
-               (mkDataConIds bogus_wrap_name wrk_name data_con)
-               
+                (mkDataConWorkId wrk_name data_con)
+               NoDataConRep    -- Wired-in types are too simple to need wrappers
 
     modu     = ASSERT( isExternalName dc_name ) 
               nameModule dc_name
     wrk_occ  = mkDataConWorkerOcc (nameOccName 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)
-       -- Wired-in types are too simple to need wrappers
+\end{code}
+
+
+%************************************************************************
+%*                                                                     *
+      Kinds
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+typeNatKindCon, typeStringKindCon :: TyCon 
+-- data Nat
+-- data Symbol
+typeNatKindCon    = pcNonRecDataTyCon typeNatKindConName    Nothing [] []
+typeStringKindCon = pcNonRecDataTyCon typeStringKindConName Nothing [] []
+
+typeNatKind, typeStringKind :: Kind
+typeNatKind    = TyConApp (promoteTyCon typeNatKindCon)    []
+typeStringKind = TyConApp (promoteTyCon typeStringKindCon) []
 \end{code}
 
 
index 9740c0a..65c03c8 100644 (file)
@@ -6,5 +6,6 @@ import {-# SOURCE #-} TypeRep    (Type)
 
 
 eqTyCon :: TyCon
+typeNatKind, typeStringKind :: Type
 mkBoxedTupleTy :: [Type] -> Type
 \end{code}
index ca78368..e4d21bd 100644 (file)
@@ -531,21 +531,26 @@ getLocalNonValBinders fixity_env
              ; return (AvailTC main_name names) }
 
     new_assoc :: LInstDecl RdrName -> RnM [AvailInfo]
-    new_assoc (L _ (FamInstD { lid_inst = d })) 
-      = do { avail <- new_ti Nothing d
+    new_assoc (L _ (TyFamInstD {})) = return []
+      -- type instances don't bind new names 
+    
+    new_assoc (L _ (DataFamInstD { dfid_inst = d }))
+      = do { avail <- new_di Nothing d
            ; return [avail] }
-    new_assoc (L _ (ClsInstD { cid_poly_ty = inst_ty, cid_fam_insts = ats }))
+    new_assoc (L _ (ClsInstD { cid_inst = ClsInstDecl
+                             { cid_poly_ty = inst_ty
+                             , cid_datafam_insts = adts } }))
       | Just (_, _, L loc cls_rdr, _) <- splitLHsInstDeclTy_maybe inst_ty
       = do { cls_nm <- setSrcSpan loc $ lookupGlobalOccRn cls_rdr
-           ; mapM (new_ti (Just cls_nm) . unLoc) ats }
+           ; mapM (new_di (Just cls_nm) . unLoc) adts }
       | otherwise
       = return []     -- Do not crash on ill-formed instances
                       -- Eg   instance !Show Int   Trac #3811c
 
-    new_ti :: Maybe Name -> FamInstDecl RdrName -> RnM AvailInfo
-    new_ti mb_cls ti_decl  -- ONLY for type/data instances
-        = do { main_name <- lookupFamInstName mb_cls (fid_tycon ti_decl)
-             ; sub_names <- mapM newTopSrcBinder (hsFamInstBinders ti_decl)
+    new_di :: Maybe Name -> DataFamInstDecl RdrName -> RnM AvailInfo
+    new_di mb_cls ti_decl
+        = do { main_name <- lookupFamInstName mb_cls (dfid_tycon ti_decl)
+             ; sub_names <- mapM newTopSrcBinder (hsDataFamInstBinders ti_decl)
              ; return (AvailTC (unLoc main_name) sub_names) }
                         -- main_name is not bound here!
 \end{code}
index e6abf7b..54cd9a2 100644 (file)
@@ -418,17 +418,28 @@ patchCCallTarget packageId callTarget =
 
 \begin{code}
 rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars)
-rnSrcInstDecl (FamInstD { lid_inst = fi })
-  = do { (fi', fvs) <- rnFamInstDecl Nothing fi
-       ; return (FamInstD { lid_inst = fi' }, fvs) }
-
-rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds
-                        , cid_sigs = uprags, cid_fam_insts = ats })
+rnSrcInstDecl (TyFamInstD { tfid_inst = tfi }) 
+  = do { (tfi', fvs) <- rnTyFamInstDecl Nothing tfi
+       ; return (TyFamInstD { tfid_inst = tfi' }, fvs) }
+
+rnSrcInstDecl (DataFamInstD { dfid_inst = dfi }) 
+  = do { (dfi', fvs) <- rnDataFamInstDecl Nothing dfi
+       ; return (DataFamInstD { dfid_inst = dfi' }, fvs) }
+
+rnSrcInstDecl (ClsInstD { cid_inst = cid })
+  = do { (cid', fvs) <- rnClsInstDecl cid
+       ; return (ClsInstD { cid_inst = cid' }, fvs) }
+
+rnClsInstDecl :: ClsInstDecl RdrName -> RnM (ClsInstDecl Name, FreeVars)
+rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
+                           , cid_sigs = uprags, cid_tyfam_insts = ats
+                           , cid_datafam_insts = adts })
         -- Used for both source and interface file decls
   = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "In an instance declaration") inst_ty
        ; case splitLHsInstDeclTy_maybe inst_ty' of {
-           Nothing -> return (ClsInstD { cid_poly_ty = inst_ty', cid_binds = emptyLHsBinds
-                                       , cid_sigs = [], cid_fam_insts = [] }
+           Nothing -> return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = emptyLHsBinds
+                                          , cid_sigs = [], cid_tyfam_insts = []
+                                          , cid_datafam_insts = [] }
                              , inst_fvs) ;
            Just (inst_tyvars, _, L _ cls,_) ->
 
@@ -438,12 +449,13 @@ rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds
        -- Rename the associated types, and type signatures
        -- Both need to have the instance type variables in scope
        ; traceRn (text "rnSrcInstDecl"  <+> ppr inst_ty' $$ ppr inst_tyvars $$ ppr ktv_names)
-       ; ((ats', other_sigs'), more_fvs)
+       ; ((ats', adts', other_sigs'), more_fvs) 
              <- extendTyVarEnvFVRn ktv_names $
-                do { (ats', at_fvs) <- rnATInstDecls cls inst_tyvars ats
+                do { (ats', at_fvs) <- rnATInstDecls rnTyFamInstDecl cls inst_tyvars ats
+                   ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls inst_tyvars adts
                    ; (other_sigs', sig_fvs) <- renameSigs (InstDeclCtxt cls) other_sigs
-                   ; return ( (ats', other_sigs')
-                            , at_fvs `plusFV` sig_fvs) }
+                   ; return ( (ats', adts', other_sigs')
+                            , at_fvs `plusFV` adt_fvs `plusFV` sig_fvs) }
 
         -- Rename the bindings
         -- The typechecker (not the renamer) checks that all
@@ -467,8 +479,9 @@ rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds
              all_fvs = meth_fvs `plusFV` more_fvs
                           `plusFV` spec_inst_fvs
                           `plusFV` inst_fvs
-       ; return (ClsInstD { cid_poly_ty = inst_ty', cid_binds = mbinds'
-                          , cid_sigs = uprags', cid_fam_insts = ats' },
+       ; return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = mbinds'
+                             , cid_sigs = uprags', cid_tyfam_insts = ats'
+                             , cid_datafam_insts = adts' },
                  all_fvs) } } }
              -- We return the renamed associated data type declarations so
              -- that they can be entered into the list of type declarations
@@ -481,10 +494,14 @@ rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds
              --     strange, but should not matter (and it would be more work
              --     to remove the context).
 
-rnFamInstDecl :: Maybe (Name, [Name]) -> FamInstDecl RdrName -> RnM (FamInstDecl Name, FreeVars)
-rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon
-                                  ,  fid_pats = HsWB { hswb_cts = pats }
-                                  , fid_defn = defn })
+rnFamInstDecl :: HsDocContext
+              -> Maybe (Name, [Name])
+              -> Located RdrName
+              -> [LHsType RdrName]
+              -> rhs
+              -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
+              -> RnM (Located Name, HsWithBndrs [LHsType Name], rhs', FreeVars)
+rnFamInstDecl doc mb_cls tycon pats payload rnPayload
   = do { tycon'   <- lookupFamInstName (fmap fst mb_cls) tycon
        ; let loc = case pats of
                      []             -> pprPanic "rnFamInstDecl" (ppr tycon)
@@ -498,11 +515,11 @@ rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon
        ; tv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) tv_rdr_names
              -- All the free vars of the family patterns
              -- with a sensible binding location
-       ; ((pats', defn'), fvs)
-              <- bindLocalNamesFV kv_names $
-                 bindLocalNamesFV tv_names $
-                 do { (pats', pat_fvs) <- rnLHsTypes (TyDataCtx tycon) pats
-                    ; (defn', rhs_fvs) <- rnTyDefn tycon defn
+       ; ((pats', payload'), fvs) 
+              <- bindLocalNamesFV kv_names $ 
+                 bindLocalNamesFV tv_names $ 
+                 do { (pats', pat_fvs) <- rnLHsTypes doc pats
+                    ; (payload', rhs_fvs) <- rnPayload doc payload
 
                          -- See Note [Renaming associated types]
                     ; let bad_tvs = case mb_cls of
@@ -511,42 +528,80 @@ rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon
                           is_bad tv = not (tv `elem` tv_names) && tv `elemNameSet` rhs_fvs
 
                     ; unless (null bad_tvs) (badAssocRhs bad_tvs)
-                    ; return ((pats', defn'), rhs_fvs `plusFV` pat_fvs) }
-
+                    ; return ((pats', payload'), rhs_fvs `plusFV` pat_fvs) }
+                              
 
        ; let all_fvs = fvs `addOneFV` unLoc tycon'
-       ; return ( FamInstDecl { fid_tycon = tycon'
-                              , fid_pats  = HsWB { hswb_cts = pats', hswb_kvs = kv_names, hswb_tvs = tv_names }
-                              , fid_defn  = defn', fid_fvs = all_fvs }
-                , all_fvs ) }
+       ; return (tycon',
+                 HsWB { hswb_cts = pats', hswb_kvs = kv_names, hswb_tvs = tv_names },
+                 payload',
+                 all_fvs) }
              -- type instance => use, hence addOneFV
+
+rnTyFamInstDecl :: Maybe (Name, [Name])
+                -> TyFamInstDecl RdrName
+                -> RnM (TyFamInstDecl Name, FreeVars)
+rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqns = eqns, tfid_group = group })
+  = do { (eqns', fvs) <- rnList (rnTyFamInstEqn mb_cls) eqns
+       ; return (TyFamInstDecl { tfid_eqns = eqns'
+                               , tfid_group = group
+                               , tfid_fvs = fvs }, fvs) }
+
+rnTyFamInstEqn :: Maybe (Name, [Name])
+               -> TyFamInstEqn RdrName
+               -> RnM (TyFamInstEqn Name, FreeVars)
+rnTyFamInstEqn mb_cls (TyFamInstEqn { tfie_tycon = tycon
+                                    , tfie_pats  = HsWB { hswb_cts = pats }
+                                    , tfie_rhs   = rhs })
+  = do { (tycon', pats', rhs', fvs) <-
+           rnFamInstDecl (TySynCtx tycon) mb_cls tycon pats rhs rnTySyn
+       ; return (TyFamInstEqn { tfie_tycon = tycon'
+                              , tfie_pats  = pats'
+                              , tfie_rhs   = rhs' }, fvs) }
+
+rnDataFamInstDecl :: Maybe (Name, [Name])
+                  -> DataFamInstDecl RdrName
+                  -> RnM (DataFamInstDecl Name, FreeVars)
+rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_tycon = tycon
+                                          , dfid_pats  = HsWB { hswb_cts = pats }
+                                          , dfid_defn  = defn })
+  = do { (tycon', pats', defn', fvs) <-
+           rnFamInstDecl (TyDataCtx tycon) mb_cls tycon pats defn rnDataDefn
+       ; return (DataFamInstDecl { dfid_tycon = tycon'
+                                 , dfid_pats  = pats'
+                                 , dfid_defn  = defn'
+                                 , dfid_fvs   = fvs }, fvs) }
 \end{code}
 
 Renaming of the associated types in instances.
 
 \begin{code}
+-- rename associated type family decl in class
 rnATDecls :: Name      -- Class
           -> LHsTyVarBndrs Name
-          -> [LTyClDecl RdrName]
-          -> RnM ([LTyClDecl Name], FreeVars)
+          -> [LFamilyDecl RdrName] 
+          -> RnM ([LFamilyDecl Name], FreeVars)
 rnATDecls cls hs_tvs at_decls
-  = rnList (rnTyClDecl (Just (cls, tv_ns))) at_decls
+  = rnList (rnFamDecl (Just (cls, tv_ns))) at_decls
   where
     tv_ns = hsLTyVarNames hs_tvs
     -- Type variable binders (but NOT kind variables)
     -- See Note [Renaming associated types] in RnTypes
 
-rnATInstDecls :: Name      -- Class
+rnATInstDecls :: (Maybe (Name, [Name]) ->    -- The function that renames
+                  decl RdrName ->            -- an instance. rnTyFamInstDecl
+                  RnM (decl Name, FreeVars)) -- or rnDataFamInstDecl
+              -> Name      -- Class
               -> LHsTyVarBndrs Name
-              -> [LFamInstDecl RdrName]
-              -> RnM ([LFamInstDecl Name], FreeVars)
--- Used for the family declarations and defaults in a class decl
+              -> [Located (decl RdrName)] 
+              -> RnM ([Located (decl Name)], FreeVars)
+-- Used for data and type family defaults in a class decl
 -- and the family instance declarations in an instance
 --
 -- NB: We allow duplicate associated-type decls;
 --     See Note [Associated type instances] in TcInstDcls
-rnATInstDecls cls hs_tvs at_insts
-  = rnList (rnFamInstDecl (Just (cls, tv_ns))) at_insts
+rnATInstDecls rnFun cls hs_tvs at_insts
+  = rnList (rnFun (Just (cls, tv_ns))) at_insts
   where
     tv_ns = hsLTyVarNames hs_tvs
     -- Type variable binders (but NOT kind variables)
@@ -820,7 +875,7 @@ rnTyClDecls :: [Name] -> [[LTyClDecl RdrName]]
             -> RnM ([[LTyClDecl Name]], FreeVars)
 -- Rename the declarations and do depedency analysis on them
 rnTyClDecls extra_deps tycl_ds
-  = do { ds_w_fvs <- mapM (wrapLocFstM (rnTyClDecl Nothing)) (concat tycl_ds)
+  = do { ds_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (concat tycl_ds)
        ; thisPkg  <- fmap thisPackage getDynFlags
        ; let add_boot_deps :: FreeVars -> FreeVars
              -- See Note [Extra dependencies from .hs-boot files]
@@ -840,13 +895,9 @@ rnTyClDecls extra_deps tycl_ds
        ; return (map flattenSCC sccs, all_fvs) }
 
 
-rnTyClDecl :: Maybe (Name, [Name])
-                    -- Just (cls,tvs) => this TyClDecl is nested
-                    --             inside an *instance decl* for cls
-                    --             used for associated types
-           -> TyClDecl RdrName
+rnTyClDecl :: TyClDecl RdrName 
            -> RnM (TyClDecl Name, FreeVars)
-rnTyClDecl (ForeignType {tcdLName = name, tcdExtName = ext_name})
+rnTyClDecl (ForeignType {tcdLName = name, tcdExtName = ext_name})
   = do { name' <- lookupLocatedTopBndrRn name
        ; return (ForeignType {tcdLName = name', tcdExtName = ext_name},
                  emptyFVs) }
@@ -854,32 +905,37 @@ rnTyClDecl _ (ForeignType {tcdLName = name, tcdExtName = ext_name})
 -- All flavours of type family declarations ("type family", "newtype family",
 -- and "data family"), both top level and (for an associated type)
 -- in a class decl
-rnTyClDecl mb_cls (TyFamily { tcdLName = tycon, tcdTyVars = tyvars
-                            , tcdFlavour = flav, tcdKindSig = kind })
-  = bindHsTyVars fmly_doc mb_cls kvs tyvars $ \tyvars' ->
-    do { tycon' <- lookupLocatedTopBndrRn tycon
-       ; (kind', fv_kind) <- rnLHsMaybeKind fmly_doc kind
-       ; return ( TyFamily { tcdLName = tycon', tcdTyVars = tyvars'
-                           , tcdFlavour = flav, tcdKindSig = kind' }
-                , fv_kind ) }
-  where
-     fmly_doc = TyFamilyCtx tycon
-     kvs = extractRdrKindSigVars kind
+rnTyClDecl (FamDecl { tcdFam = decl })
+  = do { (decl', fvs) <- rnFamDecl Nothing decl
+       ; return (FamDecl decl', fvs) }
+
+rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdRhs = rhs })
+  = do { tycon' <- lookupLocatedTopBndrRn tycon
+       ; let kvs = fst (extractHsTyRdrTyVars rhs)
+             doc = TySynCtx tycon
+       ; traceRn (text "rntycl-ty" <+> ppr tycon <+> ppr kvs)
+       ; ((tyvars', rhs'), fvs) <- bindHsTyVars doc Nothing kvs tyvars $
+                                    \ tyvars' ->
+                                    do { (rhs', fvs) <- rnTySyn doc rhs
+                                       ; return ((tyvars', rhs'), fvs) }
+       ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars'
+                        , tcdRhs = rhs', tcdFVs = fvs }, fvs) }
 
 -- "data", "newtype" declarations
 -- both top level and (for an associated type) in an instance decl
-rnTyClDecl mb_cls (TyDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdTyDefn = defn })
+rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdDataDefn = defn })
   = do { tycon' <- lookupLocatedTopBndrRn tycon
-       ; let kvs = extractTyDefnKindVars defn
-       ; traceRn (text "rntycl-ty" <+> ppr tycon <+> ppr kvs)
-       ; ((tyvars', defn'), fvs) <- bindHsTyVars (TyDataCtx tycon) mb_cls kvs tyvars $ \ tyvars' ->
-                                    do { (defn', fvs) <- rnTyDefn tycon defn
+       ; let kvs = extractDataDefnKindVars defn
+             doc = TyDataCtx tycon
+       ; traceRn (text "rntycl-data" <+> ppr tycon <+> ppr kvs)
+       ; ((tyvars', defn'), fvs) <- bindHsTyVars doc Nothing kvs tyvars $ \ tyvars' ->
+                                    do { (defn', fvs) <- rnDataDefn doc defn
                                        ; return ((tyvars', defn'), fvs) }
-       ; return (TyDecl { tcdLName = tycon', tcdTyVars = tyvars'
-                        , tcdTyDefn = defn', tcdFVs = fvs }, fvs) }
+       ; return (DataDecl { tcdLName = tycon', tcdTyVars = tyvars'
+                          , tcdDataDefn = defn', tcdFVs = fvs }, fvs) }
 
-rnTyClDecl mb_cls (ClassDecl {tcdCtxt = context, tcdLName = lcls,
-                              tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
+rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = lcls, 
+                              tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, 
                               tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
                               tcdDocs = docs})
   = do  { lcls' <- lookupLocatedTopBndrRn lcls
@@ -889,13 +945,13 @@ rnTyClDecl mb_cls (ClassDecl {tcdCtxt = context, tcdLName = lcls,
 
         -- Tyvars scope over superclass context and method signatures
         ; ((tyvars', context', fds', ats', at_defs', sigs'), stuff_fvs)
-            <- bindHsTyVars cls_doc mb_cls kvs tyvars $ \ tyvars' -> do
-                 -- Checks for distinct tyvars
+            <- bindHsTyVars cls_doc Nothing kvs tyvars $ \ tyvars' -> do
+                  -- Checks for distinct tyvars
              { (context', cxt_fvs) <- rnContext cls_doc context
              ; fds'  <- rnFds (docOfHsDocContext cls_doc) fds
                          -- The fundeps have no free variables
              ; (ats',     fv_ats)     <- rnATDecls cls' tyvars' ats
-             ; (at_defs', fv_at_defs) <- rnATInstDecls cls' tyvars' at_defs
+             ; (at_defs', fv_at_defs) <- rnATInstDecls rnTyFamInstDecl cls' tyvars' at_defs
              ; (sigs', sig_fvs) <- renameSigs (ClsDeclCtxt cls') sigs
              ; let fvs = cxt_fvs     `plusFV`
                          sig_fvs     `plusFV`
@@ -942,16 +998,19 @@ rnTyClDecl mb_cls (ClassDecl {tcdCtxt = context, tcdLName = lcls,
   where
     cls_doc  = ClassDeclCtx lcls
 
-
-rnTyDefn :: Located RdrName -> HsTyDefn RdrName -> RnM (HsTyDefn Name, FreeVars)
-rnTyDefn tycon (TyData { td_ND = new_or_data, td_cType = cType
-               , td_ctxt = context, td_cons = condecls
-               , td_kindSig = sig, td_derivs = derivs })
-  = do  { checkTc (h98_style || null (unLoc context))
-                  (badGadtStupidTheta tycon)
-
-        ; (sig', sig_fvs)  <- rnLHsMaybeKind data_doc sig
-        ; (context', fvs1) <- rnContext data_doc context
+-- "type" and "type instance" declarations
+rnTySyn :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
+rnTySyn doc rhs = rnLHsType doc rhs
+
+rnDataDefn :: HsDocContext -> HsDataDefn RdrName -> RnM (HsDataDefn Name, FreeVars)
+rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
+                           , dd_ctxt = context, dd_cons = condecls 
+                           , dd_kindSig = sig, dd_derivs = derivs })
+  = do  { checkTc (h98_style || null (unLoc context)) 
+                  (badGadtStupidTheta doc)
+
+        ; (sig', sig_fvs)  <- rnLHsMaybeKind doc sig
+        ; (context', fvs1) <- rnContext doc context
         ; (derivs',  fvs3) <- rn_derivs derivs
 
         -- For the constructor declarations, drop the LocalRdrEnv
@@ -967,9 +1026,9 @@ rnTyDefn tycon (TyData { td_ND = new_or_data, td_cType = cType
 
         ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`
                         con_fvs `plusFV` sig_fvs
-        ; return ( TyData { td_ND = new_or_data, td_cType = cType
-                          , td_ctxt = context', td_kindSig = sig'
-                          , td_cons = condecls', td_derivs = derivs' }
+        ; return ( HsDataDefn { dd_ND = new_or_data, dd_cType = cType
+                              , dd_ctxt = context', dd_kindSig = sig'
+                              , dd_cons = condecls', dd_derivs = derivs' }
                  , all_fvs )
         }
   where
@@ -977,24 +1036,33 @@ rnTyDefn tycon (TyData { td_ND = new_or_data, td_cType = cType
                      L _ (ConDecl { con_res = ResTyGADT {} }) : _  -> False
                      _                                             -> True
 
-    data_doc = TyDataCtx tycon
-
     rn_derivs Nothing   = return (Nothing, emptyFVs)
-    rn_derivs (Just ds) = do { (ds', fvs) <- rnLHsTypes data_doc ds
+    rn_derivs (Just ds) = do { (ds', fvs) <- rnLHsTypes doc ds
                              ; return (Just ds', fvs) }
 
--- "type" and "type instance" declarations
-rnTyDefn tycon (TySynonym { td_synRhs = ty })
-  = do { (ty', rhs_fvs) <- rnLHsType syn_doc ty
-       ; return ( TySynonym { td_synRhs = ty' }
-                , rhs_fvs) }
-  where
-    syn_doc = TySynCtx tycon
-
-badGadtStupidTheta :: Located RdrName -> SDoc
+badGadtStupidTheta :: HsDocContext -> SDoc
 badGadtStupidTheta _
   = vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"),
           ptext (sLit "(You can put a context on each contructor, though.)")]
+
+rnFamDecl :: Maybe (Name, [Name])
+                    -- Just (cls,tvs) => this FamilyDecl is nested 
+                    --             inside an *class decl* for cls
+                    --             used for associated types
+          -> FamilyDecl RdrName
+          -> RnM (FamilyDecl Name, FreeVars)
+rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
+                             , fdFlavour = flav, fdKindSig = kind })
+  = bindHsTyVars fmly_doc mb_cls kvs tyvars $ \tyvars' ->
+    do { tycon' <- lookupLocatedTopBndrRn tycon
+       ; (kind', fv_kind) <- rnLHsMaybeKind fmly_doc kind
+       ; return (FamilyDecl { fdLName = tycon', fdTyVars = tyvars'
+                            , fdFlavour = flav, fdKindSig = kind' }
+                , fv_kind ) }
+  where 
+     fmly_doc = TyFamilyCtx tycon
+     kvs = extractRdrKindSigVars kind
+
 \end{code}
 
 Note [Stupid theta]
@@ -1027,11 +1095,11 @@ depAnalTyClDecls ds_w_fvs
       (L _ d, _) <- ds_w_fvs
       case d of
         ClassDecl { tcdLName = L _ cls_name
-                  , tcdATs = ats }
-          -> do L _ assoc_decl <- ats
-                return (tcdName assoc_decl, cls_name)
-        TyDecl { tcdLName = L _ data_name
-               , tcdTyDefn = TyData { td_cons = cons } }
+                  , tcdATs = ats } 
+          -> do L _ (FamilyDecl { fdLName = L _ fam_name }) <- ats
+                return (fam_name, cls_name)
+        DataDecl { tcdLName = L _ data_name
+                 , tcdDataDefn = HsDataDefn { dd_cons = cons } } 
           -> do L _ dc <- cons
                 return (unLoc (con_name dc), data_name)
         _ -> []
@@ -1224,10 +1292,10 @@ extendRecordFieldEnv tycl_decls inst_decls
                     ; return $ unLoc x'}
 
     all_data_cons :: [ConDecl RdrName]
-    all_data_cons = [con | TyData { td_cons = cons } <- all_ty_defs
+    all_data_cons = [con | HsDataDefn { dd_cons = cons } <- all_ty_defs
                          , L _ con <- cons ]
-    all_ty_defs = [ defn | L _ (TyDecl { tcdTyDefn = defn }) <- concat tycl_decls ]
-               ++ map fid_defn (instDeclFamInsts inst_decls)  -- Do not forget associated types!
+    all_ty_defs = [ defn | L _ (DataDecl { tcdDataDefn = defn }) <- concat tycl_decls ]
+               ++ map dfid_defn (instDeclDataFamInsts inst_decls)  -- Do not forget associated types!
 
     get_con (ConDecl { con_name = con, con_details = RecCon flds })
             (RecFields env fld_set)
index b515f3a..eb78f0f 100644 (file)
@@ -28,7 +28,7 @@ module RnTypes (
         -- Binding related stuff
         bindSigTyVarsFV, bindHsTyVars, rnHsBndrSig,
         extractHsTyRdrTyVars, extractHsTysRdrTyVars,
-        extractRdrKindSigVars, extractTyDefnKindVars, filterInScope
+        extractRdrKindSigVars, extractDataDefnKindVars, filterInScope
   ) where
 
 import {-# SOURCE #-} RnExpr( rnLExpr )
@@ -958,14 +958,12 @@ extractRdrKindSigVars :: Maybe (LHsKind RdrName) -> [RdrName]
 extractRdrKindSigVars Nothing = []
 extractRdrKindSigVars (Just k) = nub (fst (extract_lkind k ([],[])))
 
-extractTyDefnKindVars :: HsTyDefn RdrName -> [RdrName]
+extractDataDefnKindVars :: HsDataDefn RdrName -> [RdrName]
 -- Get the scoped kind variables mentioned free in the constructor decls
 -- Eg    data T a = T1 (S (a :: k) | forall (b::k). T2 (S b)
 -- Here k should scope over the whole definition
-extractTyDefnKindVars (TySynonym { td_synRhs = ty}) 
-  = fst (extractHsTyRdrTyVars ty)
-extractTyDefnKindVars (TyData { td_ctxt = ctxt, td_kindSig = ksig
-                              , td_cons = cons, td_derivs = derivs })
+extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig
+                                    , dd_cons = cons, dd_derivs = derivs })
   = fst $ extract_lctxt ctxt $
           extract_mb extract_lkind ksig $
           extract_mb extract_ltys derivs $
index c2c2650..5726cf5 100644 (file)
@@ -922,8 +922,11 @@ argument to the plugin function so that we can turn this function into
 reinitializeGlobals :: CoreM ()
 reinitializeGlobals = do
     (sf_globals, linker_globals) <- read cr_globals
+    hsc_env <- getHscEnv
+    let dflags = hsc_dflags hsc_env
     liftIO $ restoreStaticFlagGlobals sf_globals
     liftIO $ restoreLinkerGlobals linker_globals
+    liftIO $ setUnsafeGlobalDynFlags dflags
 \end{code}
 
 %************************************************************************
index 1c50c6b..c8e8956 100644 (file)
@@ -23,7 +23,7 @@ import Name             ( mkSystemVarName, isExternalName )
 import Coercion hiding  ( substCo, substTy, substCoVar, extendTvSubst )
 import OptCoercion      ( optCoercion )
 import FamInstEnv       ( topNormaliseType )
-import DataCon          ( DataCon, dataConWorkId, dataConRepStrictness )
+import DataCon          ( DataCon, dataConWorkId, dataConRepStrictness, isMarkedStrict )
 import CoreMonad        ( Tick(..), SimplifierMode(..) )
 import CoreSyn
 import Demand           ( isStrictDmd, StrictSig(..), dmdTypeDepth )
@@ -33,7 +33,7 @@ import CoreUtils
 import qualified CoreSubst
 import CoreArity
 import Rules            ( lookupRule, getRules )
-import BasicTypes       ( isMarkedStrict, Arity )
+import BasicTypes       ( Arity )
 import TysPrim          ( realWorldStatePrimTy )
 import BasicTypes       ( TopLevelFlag(..), isTopLevel, RecFlag(..) )
 import MonadUtils       ( foldlM, mapAccumLM, liftIO )
index a8ee825..0ecefa7 100644 (file)
@@ -27,7 +27,7 @@ import PprCore
 import Coercion                ( isCoVarType )
 import CoreUtils       ( exprIsHNF, exprIsTrivial )
 import CoreArity       ( exprArity )
-import DataCon         ( dataConTyCon, dataConRepStrictness )
+import DataCon         ( dataConTyCon, dataConRepStrictness, isMarkedStrict )
 import TyCon           ( isProductTyCon, isRecursiveTyCon )
 import Id              ( Id, idType, idInlineActivation,
                          isDataConWorkId, isGlobalId, idArity,
@@ -45,7 +45,7 @@ import Type           ( isUnLiftedType, eqType, tyConAppTyCon_maybe )
 import Coercion         ( coercionKind )
 import Util
 import BasicTypes      ( Arity, TopLevelFlag(..), isTopLevel, isNeverActive,
-                         RecFlag(..), isRec, isMarkedStrict )
+                         RecFlag(..), isRec )
 import Maybes          ( orElse, expectJust )
 import Outputable
 import Pair
index 0ed650b..8aaa131 100644 (file)
@@ -19,20 +19,21 @@ import CoreSyn
 import CoreUtils       ( exprType )
 import Id              ( Id, idType, mkSysLocal, idDemandInfo, setIdDemandInfo,
                          isOneShotLambda, setOneShotLambda, setIdUnfolding,
-                          setIdInfo
+                          setIdInfo, setIdType
                        )
 import IdInfo          ( vanillaIdInfo )
 import DataCon
 import Demand          ( Demand(..), DmdResult(..), Demands(..) ) 
 import MkCore          ( mkRuntimeErrorApp, aBSENT_ERROR_ID )
-import MkId            ( realWorldPrimId, voidArgId
-                          mkUnpackCase, mkProductBox )
+import MkId            ( realWorldPrimId, voidArgId
+                        , wrapNewTypeBody, unwrapNewTypeBody )
 import TysPrim         ( realWorldStatePrimTy )
 import TysWiredIn      ( tupleCon )
 import Type
-import Coercion         ( mkSymCo, splitNewTypeRepCo_maybe )
+import Coercion         ( mkSymCo, instNewTyCon_maybe, splitNewTypeRepCo_maybe )
 import BasicTypes      ( TupleSort(..) )
 import Literal         ( absentLiteralOf )
+import TyCon
 import UniqSupply
 import Unique
 import Util            ( zipWithEqual )
@@ -416,6 +417,62 @@ nop_fn body = body
 \end{code}
 
 
+
+\begin{code}
+mkUnpackCase ::  Id -> CoreExpr -> [Id] -> DataCon -> CoreExpr -> CoreExpr
+-- (mkUnpackCase x e args Con body)
+--      returns
+-- case (e `cast` ...) of bndr { Con args -> body }
+-- 
+-- the type of the bndr passed in is irrelevent
+mkUnpackCase bndr arg unpk_args boxing_con body
+  = Case cast_arg (setIdType bndr bndr_ty) (exprType body) [(DataAlt boxing_con, unpk_args, body)]
+  where
+  (cast_arg, bndr_ty) = go (idType bndr) arg
+  go ty arg 
+    | (tycon, tycon_args, _, _)  <- splitProductType "mkUnpackCase" ty
+    , isNewTyCon tycon && not (isRecursiveTyCon tycon)
+    = go (newTyConInstRhs tycon tycon_args) 
+         (unwrapNewTypeBody tycon tycon_args arg)
+    | otherwise = (arg, ty)
+
+mkProductBox :: [Id] -> Type -> CoreExpr
+mkProductBox arg_ids ty 
+  = result_expr
+  where 
+    (tycon, tycon_args, pack_con, _con_arg_tys) = splitProductType "mkProductBox" ty
+
+    result_expr
+      | isNewTyCon tycon && not (isRecursiveTyCon tycon) 
+      = wrap (mkProductBox arg_ids (newTyConInstRhs tycon tycon_args))
+      | otherwise = mkConApp pack_con (map Type tycon_args ++ varsToCoreExprs arg_ids)
+
+    wrap expr = wrapNewTypeBody tycon tycon_args expr
+
+-- | As 'splitProductType_maybe', but in turn instantiates the 'TyCon' returned
+-- and hence recursively tries to unpack it as far as it able to
+deepSplitProductType_maybe :: Type -> Maybe (TyCon, [Type], DataCon, [Type])
+deepSplitProductType_maybe ty
+  = do { (res@(tycon, tycon_args, _, _)) <- splitProductType_maybe ty
+       ; let {result 
+             | Just (ty', _co) <- instNewTyCon_maybe tycon tycon_args
+            , not (isRecursiveTyCon tycon)
+             = deepSplitProductType_maybe ty'  -- Ignore the coercion?
+             | isNewTyCon tycon = Nothing  -- cannot unbox through recursive
+                                          -- newtypes nor through families
+             | otherwise = Just res}
+       ; result
+       }
+
+-- | As 'deepSplitProductType_maybe', but panics if the 'Type' is not a product type
+deepSplitProductType :: String -> Type -> (TyCon, [Type], DataCon, [Type])
+deepSplitProductType str ty 
+  = case deepSplitProductType_maybe ty of
+      Just stuff -> stuff
+      Nothing -> pprPanic (str ++ ": not a product") (pprType ty)
+\end{code}
+
+
 %************************************************************************
 %*                                                                     *
 \subsection{CPR stuff}
index 45ef026..b680198 100644 (file)
@@ -18,17 +18,19 @@ import HscTypes
 import FamInstEnv
 import LoadIface
 import TypeRep
-import TcMType
 import TcRnMonad
 import TyCon
+import CoAxiom
 import DynFlags
-import Name
 import Module
 import Outputable
 import UniqFM
 import FastString
 import Util
 import Maybes
+import TcMType
+import Type
+import VarSet (mkVarSet)
 import Control.Monad
 import Data.Map (Map)
 import qualified Data.Map as Map
@@ -169,7 +171,7 @@ then we have a coercion (ie, type instance of family instance coercion)
 which implies that :R42T was declared as 'data instance T [a]'.
 
 \begin{code}
-tcLookupFamInst :: TyCon -> [Type] -> TcM (Maybe (FamInst, [Type]))
+tcLookupFamInst :: TyCon -> [Type] -> TcM (Maybe FamInstMatch)
 tcLookupFamInst tycon tys
   | not (isFamilyTyCon tycon)
   = return Nothing
@@ -181,8 +183,8 @@ tcLookupFamInst tycon tys
 --                                  ppr mb_match $$ ppr instEnv)
        ; case mb_match of
           [] -> return Nothing
-          ((fam_inst, rep_tys):_) 
-              -> return $ Just (fam_inst, rep_tys)
+          (match:_) 
+              -> return $ Just match
        }
 
 tcLookupDataFamInst :: TyCon -> [Type] -> TcM (TyCon, [Type])
@@ -196,8 +198,12 @@ tcLookupDataFamInst tycon tys
     do { maybeFamInst <- tcLookupFamInst tycon tys
        ; case maybeFamInst of
            Nothing             -> famInstNotFound tycon tys
-           Just (famInst, tys) -> let tycon' = dataFamInstRepTyCon famInst
-                                  in return (tycon', tys) }
+           Just (FamInstMatch { fim_instance = famInst
+                              , fim_index    = index
+                              , fim_tys      = tys })
+             -> ASSERT( index == 0 )
+                let tycon' = dataFamInstRepTyCon famInst
+                in return (tycon', tys) }
 
 famInstNotFound :: TyCon -> [Type] -> TcM a
 famInstNotFound tycon tys 
@@ -238,7 +244,7 @@ with standalone deriving declrations.
 
 \begin{code}
 -- Add new locally-defined family instances
-tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a
+tcExtendLocalFamInstEnv :: [FamInst br] -> TcM a -> TcM a
 tcExtendLocalFamInstEnv fam_insts thing_inside
  = do { env <- getGblEnv
       ; (inst_env', fam_insts') <- foldlM addLocalFamInst  
@@ -251,32 +257,87 @@ tcExtendLocalFamInstEnv fam_insts thing_inside
 
 -- Check that the proposed new instance is OK, 
 -- and then add it to the home inst env
-addLocalFamInst :: (FamInstEnv,[FamInst]) -> FamInst -> TcM (FamInstEnv, [FamInst])
-addLocalFamInst (home_fie, my_fis) fam_inst 
+-- This must be lazy in the fam_inst arguments, see Note [Lazy axiom match]
+-- in FamInstEnv.lhs
+addLocalFamInst :: (FamInstEnv,[FamInst Branched]) -> FamInst br -> TcM (FamInstEnv, [FamInst Branched])
+addLocalFamInst (home_fie, my_fis) fam_inst
         -- home_fie includes home package and this module
         -- my_fies is just the ones from this module
   = do { traceTc "addLocalFamInst" (ppr fam_inst)
+
+           -- We wish to extend the instance envt with completely
+           -- fresh template variables. Otherwise, there may be
+           -- problems when we try to unify the template variables
+           -- with type family applications.
+
+           -- See also addLocalInst in Inst.lhs
+       ; (axBranches', fiBranches')
+           <- zipWithAndUnzipM mk_skolem_tyvars (fromBranchList $ coAxiomBranches axiom)
+                                                (fromBranchList fiBranches)
+       ; let axiom' = axiom { co_ax_branches = toBranchList axBranches' }
+             fam_inst' = fam_inst { fi_axiom = axiom'
+                                  , fi_branches = toBranchList fiBranches' }
+
        ; isGHCi <- getIsGHCi
  
            -- In GHCi, we *override* any identical instances
            -- that are also defined in the interactive context
        ; let (home_fie', my_fis') 
-               | isGHCi    = ( deleteFromFamInstEnv home_fie fam_inst 
-                             , filterOut (identicalFamInst fam_inst) my_fis)
+               | isGHCi    = ( deleteFromFamInstEnv home_fie fam_inst'
+                             , filterOut (identicalFamInst fam_inst') my_fis)
                | otherwise = (home_fie, my_fis)
 
            -- Load imported instances, so that we report
            -- overlaps correctly
        ; eps <- getEps
        ; let inst_envs  = (eps_fam_inst_env eps, home_fie')
-             home_fie'' = extendFamInstEnv home_fie fam_inst
+             home_fie'' = extendFamInstEnv home_fie fam_inst'
 
            -- Check for conflicting instance decls
-       ; no_conflict <- checkForConflicts inst_envs fam_inst
+       ; no_conflict <- checkForConflicts inst_envs fam_inst'
        ; if no_conflict then
-            return (home_fie'', fam_inst : my_fis')
+            return (home_fie'', fam_inst' : my_fis')
          else 
             return (home_fie,   my_fis) }
+
+  where
+    axiom = famInstAxiom fam_inst
+    fiBranches = famInstBranches fam_inst
+
+    zipWithAndUnzipM :: Monad m
+                     => (a -> b -> m (c, d))
+                     -> [a]
+                     -> [b]
+                     -> m ([c], [d])
+    zipWithAndUnzipM f as bs
+      = do { cds <- zipWithM f as bs
+           ; return $ unzip cds }
+
+    mk_skolem_tyvars :: CoAxBranch -> FamInstBranch
+                     -> TcM (CoAxBranch, FamInstBranch)
+    mk_skolem_tyvars axb fib
+      = do { (subst, skol_tvs) <- tcInstSkolTyVars (coAxBranchTyVars axb)
+           ; let axb' = coAxBranchSubst axb skol_tvs subst
+                 fib' = famInstBranchSubst fib skol_tvs subst
+           ; return (axb', fib') }
+
+    -- substitute the tyvars for a new set of tyvars
+    coAxBranchSubst :: CoAxBranch -> [TyVar] -> TvSubst -> CoAxBranch
+    coAxBranchSubst (CoAxBranch { cab_lhs = lhs
+                                , cab_rhs = rhs }) new_tvs subst
+      = CoAxBranch { cab_tvs = new_tvs
+                   , cab_lhs = substTys subst lhs
+                   , cab_rhs = substTy subst rhs }
+
+    -- substitute the current set of tyvars for another
+    famInstBranchSubst :: FamInstBranch -> [TyVar] -> TvSubst -> FamInstBranch
+    famInstBranchSubst fib@(FamInstBranch { fib_lhs = lhs
+                                          , fib_rhs = rhs }) new_tvs subst
+      = fib { fib_tvs = mkVarSet new_tvs
+            , fib_lhs = substTys subst lhs
+            , fib_rhs = substTy subst rhs }
+
+
 \end{code}
 
 %************************************************************************
@@ -289,35 +350,39 @@ Check whether a single family instance conflicts with those in two instance
 environments (one for the EPS and one for the HPT).
 
 \begin{code}
-checkForConflicts :: FamInstEnvs -> FamInst -> TcM Bool
-checkForConflicts inst_envs fam_inst
-  = do {       -- To instantiate the family instance type, extend the instance
-               -- envt with completely fresh template variables
-               -- This is important because the template variables must
-               -- not overlap with anything in the things being looked up
-               -- (since we do unification).  
-               -- We use tcInstSkolType because we don't want to allocate
-               -- fresh *meta* type variables.  
-
-       ; (_, skol_tvs) <- tcInstSkolTyVars (coAxiomTyVars (famInstAxiom fam_inst))
-       ; let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst skol_tvs
-             no_conflicts = null conflicts
+checkForConflicts :: FamInstEnvs -> FamInst Branched -> TcM Bool
+checkForConflicts inst_envs fam_inst@(FamInst { fi_branches = branches
+                                              , fi_group = group })
+  = do { let conflicts = brListMap (lookupFamInstEnvConflicts inst_envs group fam_tc) branches
+             no_conflicts =&