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

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

Patch for ghc

  • compiler/typecheck/TcGenGenerics.lhs

    From 1ab776697851558981f709c4ec50d9717167a352 Mon Sep 17 00:00:00 2001
    From: Reiner Pope <reiner.pope@gmail.com>
    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