Ticket #5936: 0001-Make-DeriveGeneric-support-data-families.patch

File 0001-Make-DeriveGeneric-support-data-families.patch, 3.0 KB (added by reinerp, 3 years ago)

Patch for ghc

  • compiler/typecheck/TcGenGenerics.lhs

    From 1ab776697851558981f709c4ec50d9717167a352 Mon Sep 17 00:00:00 2001
    From: Reiner Pope <[email protected]>
    Date: Tue, 13 Mar 2012 10:23:21 +1030
    Subject: [PATCH] Make DeriveGeneric support data families
    
    ---
     compiler/typecheck/TcGenGenerics.lhs |   28 ++++++++++++++++++++--------
     1 files changed, 20 insertions(+), 8 deletions(-)
    
    diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs
    index 9493669..3c19100 100644
    a b canDoGenerics tycon 
    193193              (if (not (null (tyConStupidTheta tycon)))
    194194                then (Just (ppr tycon <+> text "must not have a datatype context"))
    195195                else Nothing)
    196           -- We don't like type families
    197             : (if (isFamilyTyCon tycon)
    198                 then (Just (ppr tycon <+> text "must not be a family instance"))
    199                 else Nothing)
    200196          -- See comment below
    201197            : (map bad_con (tyConDataCons tycon)))
    202198  where
    tc_mkRepTyCon :: TyCon -- The type to generate representation for 
    260256               -> TcM FamInst     -- Generated representation0 coercion
    261257tc_mkRepTyCon tycon metaDts mod =
    262258-- Consider the example input tycon `D`, where data D a b = D_ a
     259-- Also consider `R:DInt`, where { data family D x y :: * -> *
     260--                               ; data instance D Int a b = D_ a }
    263261  do { -- `rep0` = GHC.Generics.Rep (type family)
    264262       rep0 <- tcLookupTyCon repTyConName
    265263
    tc_mkRepTyCon tycon metaDts mod = 
    273271     ; let -- `tyvars` = [a,b]
    274272           tyvars  = tyConTyVars tycon
    275273
    276            -- `appT` = D a b
    277            appT = [mkTyConApp tycon (mkTyVarTys tyvars)]
     274           -- `appT` = D a b        (normal case)
     275           -- `appT` = D Int a b    (data families case)
     276           appT = case tyConFamInst_maybe tycon of
     277             Just (famtycon, apps) ->
     278               -- `fam` = D
     279               -- `apps` = [Int, a]
     280               let allApps =
     281                     apps
     282                     ++ drop (length apps + length tyvars - tyConArity famtycon)
     283                             (mkTyVarTys tyvars)
     284               in [mkTyConApp famtycon allApps]
     285             Nothing -> [mkTyConApp tycon (mkTyVarTys tyvars)]
     286
    278287     ; return $ mkSynFamInst rep_name tyvars rep0 appT rep0Ty
    279288     }
    280289
    mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds) 
    397406        datacons      = tyConDataCons tycon
    398407        datasels      = map dataConFieldLabels datacons
    399408
    400         dtName_matches     = mkStringLHS . showPpr . nameOccName . tyConName
    401                            $ tycon
     409        tyConName_user = case tyConFamInst_maybe tycon of
     410          Just (ptycon, _) -> tyConName ptycon
     411          Nothing -> tyConName tycon
     412
     413        dtName_matches     = mkStringLHS . showPpr . nameOccName $ tyConName_user
    402414        moduleName_matches = mkStringLHS . moduleNameString . moduleName
    403415                           . nameModule . tyConName $ tycon
    404416