Deriving for phantom and empty types
[ghc.git] / compiler / typecheck / TcGenGenerics.hs
index 5757e98..51451a6 100644 (file)
@@ -17,6 +17,7 @@ import HsSyn
 import Type
 import TcType
 import TcGenDeriv
+import TcGenFunctor
 import DataCon
 import TyCon
 import FamInstEnv       ( FamInst, FamFlavor(..), mkSingleCoAxiom )
@@ -329,7 +330,8 @@ mkBindsRep gk tycon =
         -- across all cases of a from/to definition, and can be factored out
         -- to save some allocations during typechecking.
         -- See Note [Generics compilation speed tricks]
-        from_eqn = mkHsCaseAlt x_Pat $ mkM1_E $ nlHsCase x_Expr from_matches
+        from_eqn = mkHsCaseAlt x_Pat $ mkM1_E
+                                       $ nlHsPar $ nlHsCase x_Expr from_matches
         to_eqn   = mkHsCaseAlt (mkM1_P x_Pat) $ nlHsCase x_Expr to_matches
 
         from_matches  = [mkHsCaseAlt pat rhs | (pat,rhs) <- from_alts]
@@ -343,7 +345,7 @@ mkBindsRep gk tycon =
 
         -- Recurse over the sum first
         from_alts, to_alts :: [Alt]
-        (from_alts, to_alts) = mkSum gk_ (1 :: US) tycon datacons
+        (from_alts, to_alts) = mkSum gk_ (1 :: US) datacons
           where gk_ = case gk of
                   Gen0 -> Gen0_
                   Gen1 -> ASSERT(length tyvars >= 1)
@@ -691,24 +693,19 @@ mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k ty
 
 mkSum :: GenericKind_ -- Generic or Generic1?
       -> US          -- Base for generating unique names
-      -> TyCon       -- The type constructor
       -> [DataCon]   -- The data constructors
       -> ([Alt],     -- Alternatives for the T->Trep "from" function
           [Alt])     -- Alternatives for the Trep->T "to" function
 
 -- Datatype without any constructors
-mkSum _ _ tycon [] = ([from_alt], [to_alt])
+mkSum _ _ [] = ([from_alt], [to_alt])
   where
-    from_alt = (nlWildPat, makeError errMsgFrom)
-    to_alt   = (nlWildPat, makeError errMsgTo)
+    from_alt = (x_Pat, nlHsCase x_Expr [])
+    to_alt   = (x_Pat, nlHsCase x_Expr [])
                -- These M1s are meta-information for the datatype
-    makeError s = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString s))
-    tyConStr   = occNameString (nameOccName (tyConName tycon))
-    errMsgFrom = "No generic representation for empty datatype " ++ tyConStr
-    errMsgTo   = "No values for empty datatype " ++ tyConStr
 
 -- Datatype with at least one constructor
-mkSum gk_ us datacons =
+mkSum gk_ us datacons =
   -- switch the payload of gk_ to be datacon-centric instead of tycon-centric
  unzip [ mk1Sum (gk2gkDC gk_ d) us i (length datacons) d
            | (d,i) <- zip datacons [1..] ]
@@ -759,8 +756,8 @@ genLR_P :: Int -> Int -> LPat RdrName -> LPat RdrName
 genLR_P i n p
   | n == 0       = error "impossible"
   | n == 1       = p
-  | i <= div n 2 = nlConPat l1DataCon_RDR [genLR_P i     (div n 2) p]
-  | otherwise    = nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m)     p]
+  | i <= div n 2 = nlParPat $ nlConPat l1DataCon_RDR [genLR_P i     (div n 2) p]
+  | otherwise    = nlParPat $ nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m)     p]
                      where m = div n 2
 
 -- Generates the L1/R1 sum expression
@@ -768,8 +765,10 @@ genLR_E :: Int -> Int -> LHsExpr RdrName -> LHsExpr RdrName
 genLR_E i n e
   | n == 0       = error "impossible"
   | n == 1       = e
-  | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp` genLR_E i     (div n 2) e
-  | otherwise    = nlHsVar r1DataCon_RDR `nlHsApp` genLR_E (i-m) (n-m)     e
+  | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp`
+                                            nlHsPar (genLR_E i     (div n 2) e)
+  | otherwise    = nlHsVar r1DataCon_RDR `nlHsApp`
+                                            nlHsPar (genLR_E (i-m) (n-m)     e)
                      where m = div n 2
 
 --------------------------------------------------------------------------------
@@ -831,12 +830,12 @@ mkProd_P gk _ varTys = mkM1_P (foldBal prod appVars)
                      -- These M1s are meta-information for the constructor
   where
     appVars = unzipWith (wrapArg_P gk) varTys
-    prod a b = prodDataCon_RDR `nlConPat` [a,b]
+    prod a b = nlParPat $ prodDataCon_RDR `nlConPat` [a,b]
 
 wrapArg_P :: GenericKind -> RdrName -> Type -> LPat RdrName
-wrapArg_P Gen0 v ty = mkM1_P (boxRepRDR ty `nlConVarPat` [v])
+wrapArg_P Gen0 v ty = mkM1_P (nlParPat $ boxRepRDR ty `nlConVarPat` [v])
                    -- This M1 is meta-information for the selector
-wrapArg_P Gen1 v _  = m1DataCon_RDR `nlConVarPat` [v]
+wrapArg_P Gen1 v _  = nlParPat $ m1DataCon_RDR `nlConVarPat` [v]
 
 mkGenericLocal :: US -> RdrName
 mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
@@ -854,7 +853,7 @@ mkM1_E :: LHsExpr RdrName -> LHsExpr RdrName
 mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e
 
 mkM1_P :: LPat RdrName -> LPat RdrName
-mkM1_P p = m1DataCon_RDR `nlConPat` [p]
+mkM1_P p = nlParPat $ m1DataCon_RDR `nlConPat` [p]
 
 nlHsCompose :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
 nlHsCompose x y = compose_RDR `nlHsApps` [x, y]