Ticket #3087: TestDerivingData.hs

File TestDerivingData.hs, 4.1 KB (added by dreixel, 6 years ago)

Example code

Line 
1{-# LANGUAGE DeriveDataTypeable  #-}
2{-# LANGUAGE Rank2Types          #-}
3
4module TestDerivingData where
5
6import Data.Generics
7
8{-
9-- Data instances for Maybe and Either, from Data.Data:
10nothingConstr :: Constr
11nothingConstr = mkConstr maybeDataType "Nothing" [] Prefix
12justConstr :: Constr
13justConstr    = mkConstr maybeDataType "Just"    [] Prefix
14
15maybeDataType :: DataType
16maybeDataType = mkDataType "Prelude.Maybe" [nothingConstr,justConstr]
17
18instance Data a => Data (Maybe a) where
19  gfoldl _ z Nothing  = z Nothing
20  gfoldl f z (Just x) = z Just `f` x
21  toConstr Nothing  = nothingConstr
22  toConstr (Just _) = justConstr
23  gunfold k z c = case constrIndex c of
24                    1 -> z Nothing
25                    2 -> k (z Just)
26                    _ -> error "gunfold"
27  dataTypeOf _ = maybeDataType
28  dataCast1 f  = gcast1 f
29
30
31tuple2Constr :: Constr
32tuple2Constr = mkConstr tuple2DataType "(,)" [] Infix
33
34tuple2DataType :: DataType
35tuple2DataType = mkDataType "Prelude.(,)" [tuple2Constr]
36
37instance (Data a, Data b) => Data (a,b) where
38  gfoldl f z (a,b) = z (,) `f` a `f` b
39  toConstr (_,_) = tuple2Constr
40  gunfold k z c | constrIndex c == 1 = k (k (z (,)))
41  gunfold _ _ _ = error "gunfold"
42  dataTypeOf _  = tuple2DataType
43  dataCast2 f   = gcast2 f
44-}
45
46data MyMaybe a = MyNothing | MyJust a deriving (Data, Typeable)
47
48test1 :: ()
49test1 = undefined `ext1Q` (\ (Just _) -> ()) $ Just ()
50
51test1' :: ()
52test1' = undefined `ext1Q` (\ (MyJust _) -> ()) $ MyJust ()
53
54
55newtype Q r a = Q { unQ :: a -> r }
56ext2Q :: (Data d, Typeable2 t)
57      => (d -> q) -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q) -> d -> q
58ext2Q def ext arg =
59  case dataCast2 (Q ext) of
60    Just (Q ext') -> ext' arg
61    Nothing       -> def arg
62
63data MyPair a b = MyPair a b deriving (Data, Typeable)
64
65test2 :: ()
66test2 = undefined `ext2Q` (\(_,_) -> ()) $ ((),())
67
68test2' :: ()
69test2' = undefined `ext2Q` (\(MyPair _ _) -> ()) $ MyPair () ()
70
71{-
72Reason: With -ddump-deriv we obtain:
73==================== Derived instances ====================
74InstInfo: Data.Typeable.Typeable2 Test.MyPair
75  { Data.Typeable.typeOf2 (_)
76                            = Data.Typeable.mkTyConApp
77                                (Data.Typeable.mkTyCon "Test.MyPair") [] }
78InstInfo: Data.Typeable.Typeable1 Test.MyMaybe
79  { Data.Typeable.typeOf1 (_)
80                            = Data.Typeable.mkTyConApp
81                                (Data.Typeable.mkTyCon "Test.MyMaybe") [] }
82InstInfo: forall a_a5hl b_a5hm.
83          (Data.Data.Data a_a5hl, Data.Data.Data b_a5hm) =>
84          Data.Data.Data (Test.MyPair a_a5hl b_a5hm)
85  { Data.Data.dataTypeOf (_) = Test.$tMyPair
86    Data.Data.toConstr (Test.MyPair _ _) = Test.$cMyPair
87    Data.Data.gunfold k_a5iz z_a5iB (_)
88                        = k_a5iz (k_a5iz (z_a5iB Test.MyPair))
89    Data.Data.gfoldl k_a5ir z_a5it (Test.MyPair a1_a5iv a2_a5ix)
90                       = ((z_a5it Test.MyPair `k_a5ir` a1_a5iv) `k_a5ir` a2_a5ix
91) }
92
93-- We're lacking dataCast2.
94
95
96InstInfo: forall a_a5hp.
97          (Data.Data.Data a_a5hp) =>
98          Data.Data.Data (Test.MyMaybe a_a5hp)
99  { Data.Data.dataTypeOf (_) = Test.$tMyMaybe
100    Data.Data.toConstr (Test.MyNothing) = Test.$cMyNothing
101    Data.Data.toConstr (Test.MyJust _) = Test.$cMyJust
102    Data.Data.gunfold k_a5iN z_a5iP c_a5iR
103                        = case Data.Data.constrIndex c_a5iR of {
104                            GHC.Types.I# 1# -> z_a5iP Test.MyNothing
105                            _ -> k_a5iN (z_a5iP Test.MyJust) }
106    Data.Data.gfoldl k_a5iD z_a5iF (Test.MyNothing)
107                       = z_a5iF Test.MyNothing
108    Data.Data.gfoldl k_a5iH z_a5iJ (Test.MyJust a1_a5iL)
109                       = (z_a5iJ Test.MyJust `k_a5iH` a1_a5iL) }
110                       
111-- We're lacking dataCast1.
112
113
114Test.$cMyPair = Data.Data.mkConstr
115                  Test.$tMyPair "MyPair" [] Data.Data.Prefix
116Test.$tMyPair = Data.Data.mkDataType "Test.MyPair" [Test.$cMyPair]
117Test.$cMyJust = Data.Data.mkConstr
118                  Test.$tMyMaybe "MyJust" [] Data.Data.Prefix
119Test.$tMyMaybe = Data.Data.mkDataType
120                   "Test.MyMaybe" [Test.$cMyNothing, Test.$cMyJust]
121Test.$cMyNothing = Data.Data.mkConstr
122                     Test.$tMyMaybe "MyNothing" [] Data.Data.Prefix
123-}