+type Alt = (LPat RdrName, LHsExpr RdrName)
+
+-- Bindings for the Representable0 instance
+mkBindsRep0 :: TyCon -> LHsBinds RdrName
+mkBindsRep0 tycon =
+ unitBag (L loc (mkFunBind (L loc from0_RDR) from0_matches))
+ `unionBags`
+ unitBag (L loc (mkFunBind (L loc to0_RDR) to0_matches))
+ where
+ from0_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from0_alts]
+ to0_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to0_alts ]
+ loc = srcLocSpan (getSrcLoc tycon)
+ datacons = tyConDataCons tycon
+
+ -- Recurse over the sum first
+ from0_alts, to0_alts :: [Alt]
+ (from0_alts, to0_alts) = mkSum (1 :: US) tycon datacons
+
+--------------------------------------------------------------------------------
+-- Type representation
+--------------------------------------------------------------------------------
+
+tc_mkRep0Ty :: -- The type to generate representation for
+ TyCon
+ -- Metadata datatypes to refer to
+ -> MetaTyCons
+ -- Generated representation0 type
+ -> TcM Type
+tc_mkRep0Ty tycon metaDts =
+ do
+ d1 <- tcLookupTyCon d1TyConName
+ c1 <- tcLookupTyCon c1TyConName
+ s1 <- tcLookupTyCon s1TyConName
+ nS1 <- tcLookupTyCon noSelTyConName
+ rec0 <- tcLookupTyCon rec0TyConName
+ par0 <- tcLookupTyCon par0TyConName
+ u1 <- tcLookupTyCon u1TyConName
+ v1 <- tcLookupTyCon v1TyConName
+ plus <- tcLookupTyCon sumTyConName
+ times <- tcLookupTyCon prodTyConName
+
+ let mkSum' a b = mkTyConApp plus [a,b]
+ mkProd a b = mkTyConApp times [a,b]
+ mkRec0 a = mkTyConApp rec0 [a]
+ mkPar0 a = mkTyConApp par0 [a]
+ mkD a = mkTyConApp d1 [metaDTyCon, sumP (tyConDataCons a)]
+ mkC i d a = mkTyConApp c1 [d, prod i (dataConOrigArgTys a)
+ (null (dataConFieldLabels a))]
+ -- This field has no label
+ mkS True _ a = mkTyConApp s1 [mkTyConTy nS1, a]
+ -- This field has a label
+ mkS False d a = mkTyConApp s1 [d, a]
+
+ sumP [] = mkTyConTy v1
+ sumP l = ASSERT (length metaCTyCons == length l)
+ foldBal mkSum' [ mkC i d a
+ | (d,(a,i)) <- zip metaCTyCons (zip l [0..])]
+ -- The Bool is True if this constructor has labelled fields
+ prod :: Int -> [Type] -> Bool -> Type
+ prod i [] _ = ASSERT (length metaSTyCons > i)
+ ASSERT (length (metaSTyCons !! i) == 0)
+ mkTyConTy u1
+ prod i l b = ASSERT (length metaSTyCons > i)
+ ASSERT (length l == length (metaSTyCons !! i))
+ foldBal mkProd [ arg d t b
+ | (d,t) <- zip (metaSTyCons !! i) l ]
+
+ arg :: Type -> Type -> Bool -> Type
+ arg d t b = mkS b d (recOrPar t (getTyVar_maybe t))
+ -- Argument is not a type variable, use Rec0
+ recOrPar t Nothing = mkRec0 t
+ -- Argument is a type variable, use Par0
+ recOrPar t (Just _) = mkPar0 t
+
+ metaDTyCon = mkTyConTy (metaD metaDts)
+ metaCTyCons = map mkTyConTy (metaC metaDts)
+ metaSTyCons = map (map mkTyConTy) (metaS metaDts)
+
+ return (mkD tycon)
+
+tc_mkRep0TyCon :: TyCon -- The type to generate representation for
+ -> MetaTyCons -- Metadata datatypes to refer to
+ -> TcM TyCon -- Generated representation0 type
+tc_mkRep0TyCon tycon metaDts =
+-- Consider the example input tycon `D`, where data D a b = D_ a
+ do
+ uniq1 <- newUnique
+ uniq2 <- newUnique
+ -- `rep0Ty` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
+ rep0Ty <- tc_mkRep0Ty tycon metaDts
+ -- `rep0` = GHC.Generics.Rep0 (type family)
+ rep0 <- tcLookupTyCon rep0TyConName
+
+ let modl = nameModule (tyConName tycon)
+ loc = nameSrcSpan (tyConName tycon)
+ -- `repName` is a name we generate for the synonym
+ repName = mkExternalName uniq1 modl (mkGenR0 (nameOccName (tyConName tycon))) loc
+ -- `coName` is a name for the coercion
+ coName = mkExternalName uniq2 modl (mkGenR0 (nameOccName (tyConName tycon))) loc
+ -- `tyvars` = [a,b]
+ tyvars = tyConTyVars tycon
+ -- `appT` = D a b
+ appT = [mkTyConApp tycon (mkTyVarTys tyvars)]
+ -- Result
+ res = mkSynTyCon repName
+ -- rep0Ty has kind `kind of D` -> *
+ (tyConKind tycon `mkArrowKind` liftedTypeKind)
+ tyvars (SynonymTyCon rep0Ty)
+ (FamInstTyCon rep0 appT
+ (mkCoercionTyCon coName (tyConArity tycon)
+ -- co : forall a b. Rep0 (D a b) ~ `rep0Ty` a b
+ (CoAxiom tyvars (mkTyConApp rep0 appT) rep0Ty)))
+
+ return res
+
+--------------------------------------------------------------------------------
+-- Meta-information
+--------------------------------------------------------------------------------
+
+data MetaTyCons = MetaTyCons { -- One meta datatype per dataype
+ metaD :: TyCon
+ -- One meta datatype per constructor
+ , metaC :: [TyCon]
+ -- One meta datatype per selector per constructor
+ , metaS :: [[TyCon]] }
+
+instance Outputable MetaTyCons where
+ ppr (MetaTyCons d c s) = ppr d <+> ppr c <+> ppr s
+
+metaTyCons2TyCons :: MetaTyCons -> [TyCon]
+metaTyCons2TyCons (MetaTyCons d c s) = d : c ++ concat s
+
+
+-- Bindings for Datatype, Constructor, and Selector instances
+mkBindsMetaD :: FixityEnv -> TyCon
+ -> ( LHsBinds RdrName -- Datatype instance
+ , [LHsBinds RdrName] -- Constructor instances
+ , [[LHsBinds RdrName]]) -- Selector instances
+mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds)
+ where
+ mkBag l = foldr1 unionBags
+ [ unitBag (L loc (mkFunBind (L loc name) matches))
+ | (name, matches) <- l ]
+ dtBinds = mkBag [ (datatypeName_RDR, dtName_matches)
+ , (moduleName_RDR, moduleName_matches)]
+
+ allConBinds = map conBinds datacons
+ conBinds c = mkBag ( [ (conName_RDR, conName_matches c)]
+ ++ ifElseEmpty (dataConIsInfix c)
+ [ (conFixity_RDR, conFixity_matches c) ]
+ ++ ifElseEmpty (length (dataConFieldLabels c) > 0)
+ [ (conIsRecord_RDR, conIsRecord_matches c) ]
+ )
+
+ ifElseEmpty p x = if p then x else []
+ fixity c = case lookupFixity fix_env (dataConName c) of
+ Fixity n InfixL -> buildFix n leftAssocDataCon_RDR
+ Fixity n InfixR -> buildFix n rightAssocDataCon_RDR
+ Fixity n InfixN -> buildFix n notAssocDataCon_RDR
+ buildFix n assoc = nlHsApps infixDataCon_RDR [nlHsVar assoc
+ , nlHsIntLit (toInteger n)]
+
+ allSelBinds = map (map selBinds) datasels
+ selBinds s = mkBag [(selName_RDR, selName_matches s)]
+
+ loc = srcLocSpan (getSrcLoc tycon)
+ mkStringLHS s = [mkSimpleHsAlt nlWildPat (nlHsLit (mkHsString s))]
+ datacons = tyConDataCons tycon
+ datasels = map dataConFieldLabels datacons
+
+ dtName_matches = mkStringLHS . showPpr . nameOccName . tyConName
+ $ tycon
+ moduleName_matches = mkStringLHS . moduleNameString . moduleName
+ . nameModule . tyConName $ tycon
+
+ conName_matches c = mkStringLHS . showPpr . nameOccName
+ . dataConName $ c
+ conFixity_matches c = [mkSimpleHsAlt nlWildPat (fixity c)]
+ conIsRecord_matches _ = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)]
+
+ selName_matches s = mkStringLHS (showPpr (nameOccName s))
+
+
+--------------------------------------------------------------------------------
+-- Dealing with sums
+--------------------------------------------------------------------------------
+
+mkSum :: 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 _us tycon [] = ([from_alt], [to_alt])
+ where
+ from_alt = (nlWildPat, mkM1_E (makeError errMsgFrom))
+ to_alt = (mkM1_P nlWildPat, makeError errMsgTo)
+ -- These M1s are meta-information for the datatype
+ makeError s = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString s))
+ errMsgFrom = "No generic representation for empty datatype " ++ showPpr tycon
+ errMsgTo = "No values for empty datatype " ++ showPpr tycon
+
+-- Datatype with at least one constructor
+mkSum us _tycon datacons =
+ unzip [ mk1Sum us i (length datacons) d | (d,i) <- zip datacons [1..] ]
+
+-- Build the sum for a particular constructor
+mk1Sum :: US -- Base for generating unique names
+ -> Int -- The index of this constructor
+ -> Int -- Total number of constructors
+ -> DataCon -- The data constructor
+ -> (Alt, -- Alternative for the T->Trep "from" function
+ Alt) -- Alternative for the Trep->T "to" function
+mk1Sum us i n datacon = (from_alt, to_alt)