Embrace -XTypeInType, add -XStarIsType
[ghc.git] / testsuite / tests / overloadedrecflds / should_run / overloadedrecflds_generics.hs
1 -- Test that DuplicateRecordFields doesn't affect the metadata
2 -- generated by GHC.Generics or Data.Data
3
4 -- Based on a Stack Overflow post by bennofs
5 -- (http://stackoverflow.com/questions/24474581)
6 -- licensed under cc by-sa 3.0
7
8 {-# LANGUAGE DuplicateRecordFields #-}
9 {-# LANGUAGE FlexibleContexts #-}
10 {-# LANGUAGE DataKinds #-}
11 {-# LANGUAGE DeriveDataTypeable #-}
12 {-# LANGUAGE DeriveGeneric #-}
13 {-# LANGUAGE ScopedTypeVariables #-}
14 {-# LANGUAGE TypeOperators #-}
15 {-# LANGUAGE TypeFamilies #-}
16
17 import GHC.Generics
18 import Data.Data
19 import Data.Proxy
20 import Data.Kind
21
22 type family FirstSelector (f :: Type -> Type) :: Meta
23 type instance FirstSelector (M1 D x f) = FirstSelector f
24 type instance FirstSelector (M1 C x f) = FirstSelector f
25 type instance FirstSelector (a :*: b) = FirstSelector a
26 type instance FirstSelector (M1 S s f) = s
27
28 data SelectorProxy (s :: Meta) (f :: Type -> Type) a = SelectorProxy
29 type SelectorProxy' (s :: Meta) = SelectorProxy s Proxy ()
30
31 -- Extract the first selector name using GHC.Generics
32 firstSelectorName :: forall a. Selector (FirstSelector (Rep a))
33 => Proxy a -> String
34 firstSelectorName _ =
35 selName (SelectorProxy :: SelectorProxy' (FirstSelector (Rep a)))
36
37 -- Extract the list of selector names for a constructor using Data.Data
38 selectorNames :: Data a => a -> [String]
39 selectorNames = constrFields . toConstr
40
41 data T = MkT { foo :: Int } deriving (Data, Generic)
42 data U = MkU { foo :: Int, bar :: Bool } deriving (Data, Generic)
43
44 main = do -- This should yield "foo", not "$sel:foo:MkT"
45 print (firstSelectorName (Proxy :: Proxy T))
46 -- Similarly this should yield "foo"
47 print (firstSelectorName (Proxy :: Proxy U))
48 -- This should yield ["foo"]
49 print (selectorNames (MkT 3))
50 -- And this should yield ["foo","bar"]
51 print (selectorNames (MkU 3 True))