Add tuple sections as a new feature

[ghc-hetmet.git] / compiler / typecheck / TcGenDeriv.lhs

diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs
index ba1c001..2192531 100644 (file)
--- a/compiler/typecheck/TcGenDeriv.lhs
+++ b/compiler/typecheck/TcGenDeriv.lhs
@@ -42,7 +42,6 @@ import Name
 import HscTypes
 import PrelInfo
 import PrelNames
-import MkId
 import PrimOp
 import SrcLoc
 import TyCon
@@ -58,9 +57,7 @@ import Util
 import MonadUtils
 import Outputable
 import FastString
-import OccName
 import Bag
-
 import Data.List       ( partition, intersperse )
 \end{code}
 
@@ -721,7 +718,7 @@ gen_Ix_binds loc tycon
 
        mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
                                 (nlHsApp (nlHsVar range_RDR) 
-                                       (nlTuple [nlHsVar a, nlHsVar b] Boxed))
+                                         (mkLHsVarTuple [a,b]))
 
     ----------------
     single_con_index
@@ -743,11 +740,11 @@ gen_Ix_binds loc tycon
            ) plus_RDR (
                genOpApp (
                    (nlHsApp (nlHsVar unsafeRangeSize_RDR) 
-                          (nlTuple [nlHsVar l, nlHsVar u] Boxed))
+                            (mkLHsVarTuple [l,u]))
                ) times_RDR (mk_index rest)
           )
        mk_one l u i
-         = nlHsApps unsafeIndex_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed, nlHsVar i]
+         = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i]
 
     ------------------
     single_con_inRange
@@ -756,8 +753,7 @@ gen_Ix_binds loc tycon
                 con_pat cs_needed] $
          foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
       where
-       in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed,
-                                              nlHsVar c]
+       in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c]
 \end{code}
 
 %************************************************************************
@@ -835,9 +831,8 @@ gen_Read_binds get_fixity loc tycon
             _     -> [nlHsApp (nlHsVar choose_RDR) 
                              (nlList (map mk_pair nullary_cons))]
     
-    mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)), 
-                          result_expr con []]
-                         Boxed
+    mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)), 
+                                 result_expr con []]
     
     read_non_nullary_con data_con
       | is_infix  = mk_parser infix_prec  infix_stmts  body
@@ -1098,7 +1093,7 @@ gen_Typeable_binds loc tycon
                [nlWildPat] 
                (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
   where
-    tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
+    tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
 
 mk_typeOf_RDR :: TyCon -> RdrName
 -- Use the arity of the TyCon to make the right typeOfn function
@@ -1142,13 +1137,18 @@ we generate
     
     dataTypeOf _ = $dT
 
+    dataCast1 = gcast1   -- If T :: * -> *
+    dataCast2 = gcast2   -- if T :: * -> * -> *
+
+    
 \begin{code}
 gen_Data_binds :: SrcSpan
               -> TyCon 
               -> (LHsBinds RdrName,    -- The method bindings
                   DerivAuxBinds)       -- Auxiliary bindings
 gen_Data_binds loc tycon
-  = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind],
+  = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
+     `unionBags` gcast_binds,
                -- Auxiliary definitions: the data type and constructors
      MkTyCon tycon : map MkDataCon data_cons)
   where
@@ -1200,13 +1200,31 @@ gen_Data_binds loc tycon
                        [nlWildPat]
                         (nlHsVar (mk_data_type_name tycon))
 
+       ------------ gcast1/2
+    tycon_kind = tyConKind tycon
+    gcast_binds | tycon_kind `eqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR
+               | tycon_kind `eqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR
+               | otherwise           = emptyBag
+    mk_gcast dataCast_RDR gcast_RDR 
+      = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR] 
+                                 (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))
+
+
+kind1, kind2 :: Kind
+kind1 = liftedTypeKind `mkArrowKind` liftedTypeKind
+kind2 = liftedTypeKind `mkArrowKind` kind1
 
 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
-    mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR :: RdrName
+    mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
+    dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR :: RdrName
 gfoldl_RDR     = varQual_RDR gENERICS (fsLit "gfoldl")
 gunfold_RDR    = varQual_RDR gENERICS (fsLit "gunfold")
 toConstr_RDR   = varQual_RDR gENERICS (fsLit "toConstr")
 dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
+dataCast1_RDR  = varQual_RDR gENERICS (fsLit "dataCast1")
+dataCast2_RDR  = varQual_RDR gENERICS (fsLit "dataCast2")
+gcast1_RDR     = varQual_RDR tYPEABLE (fsLit "gcast1")
+gcast2_RDR     = varQual_RDR tYPEABLE (fsLit "gcast2")
 mkConstr_RDR   = varQual_RDR gENERICS (fsLit "mkConstr")
 mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
 conIndex_RDR   = varQual_RDR gENERICS (fsLit "constrIndex")
@@ -1218,7 +1236,10 @@ infix_RDR      = dataQual_RDR gENERICS (fsLit "Infix")
 
 %************************************************************************
 %*                                                                     *
-       Functor instances
+                       Functor instances
+
+ see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
+
 %*                                                                     *
 %************************************************************************
 
@@ -1421,7 +1442,10 @@ mkSimpleTupleCase match_for_con boxity insides x = do
 
 %************************************************************************
 %*                                                                     *
-       Foldable instances
+                       Foldable instances
+
+ see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
+
 %*                                                                     *
 %************************************************************************
 
@@ -1449,7 +1473,7 @@ gen_Foldable_binds loc tycon
   where
     data_cons = tyConDataCons tycon
 
-    foldr_bind = L loc $ mkFunBind (L loc foldr_RDR) (map foldr_eqn data_cons)
+    foldr_bind = L loc $ mkFunBind (L loc foldable_foldr_RDR) (map foldr_eqn data_cons)
     foldr_eqn con = evalState (match_for_con z_Expr [f_Pat,z_Pat] con parts) bs_RDRs
       where 
         parts = foldDataConArgs ft_foldr con
@@ -1471,7 +1495,9 @@ gen_Foldable_binds loc tycon
 
 %************************************************************************
 %*                                                                     *
-       Traversable instances
+                       Traversable instances
+
+ see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
 %*                                                                     *
 %************************************************************************
 
@@ -1600,7 +1626,7 @@ genAuxBind loc (GenMaxTag tycon)
 genAuxBind loc (MkTyCon tycon) --  $dT
   = mkVarBind loc (mk_data_type_name tycon)
                  ( nlHsVar mkDataType_RDR 
-                    `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
+                    `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
                     `nlHsApp` nlList constrs )
   where
     constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]