Commit 96fa2292 authored by Fumiaki Kinoshita's avatar Fumiaki Kinoshita 💬
Browse files

WIP

parent e40feab0
......@@ -511,8 +511,9 @@ functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar
| xc || yc = (caseFun xr yr,True)
where (xr,xc) = go (not co) x
(yr,yc) = go co y
go co (AppTy x y) | xc = (caseWrongArg, True)
| yc = (caseTyApp x y yr, True)
go co (AppTy x y)
-- | xc = (caseWrongArg, True)
| yc = (caseTyApp x y yr, True)
where (_, xc) = go co x
(yr,yc) = go co y
go co ty@(TyConApp con args)
......
......@@ -264,7 +264,6 @@ canDoGenerics1 rep_tc =
| otherwise = NotValid $ DerivErrGenericsMustNotHaveExistentials con
bmzero = CCDG1 False IsValid
bmbad con = CCDG1 True $ NotValid (DerivErrGenericsWrongArgKind con)
bmplus (CCDG1 b1 m1) (CCDG1 b2 m2) = CCDG1 (b1 || b2) (m1 `andValid` m2)
-- check (e) from Note [Requirements for deriving Generic and Rep]
......@@ -276,21 +275,17 @@ canDoGenerics1 rep_tc =
, ft_var = caseVar, ft_co_var = caseVar
-- (component_0,component_1,...,component_n)
, ft_tup = \_ components -> if any _ccdg1_hasParam (init components)
then bmbad con
else foldr bmplus bmzero components
, ft_tup = \_ components -> foldr bmplus bmzero components
-- (dom -> rng), where the head of ty is not a tuple tycon
, ft_fun = \dom rng -> -- cf #8516
if _ccdg1_hasParam dom
then bmbad con
else bmplus dom rng
bmplus dom rng
-- (ty arg), where head of ty is neither (->) nor a tuple constructor and
-- the parameter of interest does not occur in ty
, ft_ty_app = \_ _ arg -> arg
, ft_bad_app = bmbad con
, ft_bad_app = panic "Generic1"
, ft_forall = \_ body -> body -- polytypes are handled elsewhere
}
where
......
......@@ -128,3 +128,4 @@ test('T17880', normal, compile, [''])
test('T18055', normal, compile, [''])
test('T18321', normal, compile, [''])
test('T18914', normal, compile, [''])
test('generic1-poly', normal, compile, [''])
\ No newline at end of file
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -ddump-deriv #-}
module Foo where
import GHC.Generics
import Data.Kind
import qualified GHC.Types
import qualified GHC.Maybe
data HKD (f :: Type -> Type) = Foo (f Int) (f Double)
| Bar (f Bool)
-- deriving Generic1
instance Generic1 HKD where
type Rep1 Foo.HKD = D1
('MetaData "HKD" "Foo" "main" 'GHC.Types.False)
(C1
('MetaCons
"Foo" 'PrefixI 'GHC.Types.False)
(S1
('MetaSel
'GHC.Maybe.Nothing
'NoSourceUnpackedness
'NoSourceStrictness
'DecidedLazy)
(Rec0 (GHC.Types.Any GHC.Types.Int))
:*: S1
('MetaSel
'GHC.Maybe.Nothing
'NoSourceUnpackedness
'NoSourceStrictness
'DecidedLazy)
(Rec0
(GHC.Types.Any GHC.Types.Double)))
:+: C1
('MetaCons
"Bar"
'PrefixI
'GHC.Types.False)
(S1
('MetaSel
'GHC.Maybe.Nothing
'NoSourceUnpackedness
'NoSourceStrictness
'DecidedLazy)
(Rec0
(GHC.Types.Any GHC.Types.Bool))))
from1 x_a1Ek
= M1
(case x_a1Ek of
Foo g1_a1El g2_a1Em
-> L1
(M1
((:*:)
(M1 (K1 g1_a1El))
(M1 (K1 g2_a1Em))))
Bar g1_a1En
-> R1
(M1 (M1 (K1 g1_a1En))))
to1 (M1 x_a1Eo)
= case x_a1Eo of
(L1 (M1 ((:*:) (M1 g1_a1Ep)
(M1 g2_a1Eq))))
-> Foo (unK1 g1_a1Ep) (unK1 g2_a1Eq)
(R1 (M1 (M1 g1_a1Er)))
-> Bar (unK1 g1_a1Er)
\ No newline at end of file
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment