Ticket #92: Data.Record.hs

File Data.Record.hs, 4.6 KB (added by claus.reinke@…, 11 years ago)

Poor man's polymorphic extensible records

Line 
1{-# OPTIONS -fglasgow-exts #-}
2{-# OPTIONS -fallow-overlapping-instances #-}
3{-# OPTIONS -fallow-undecidable-instances #-}
4
5{-
6   poor man's records using nested tuples and declared labels:
7
8   apart from record extension (,), we've got field selection (#?),
9   field removal (#-), field update (#!), field renaming (#@),
10   symmetric record concatenation (##), .. anything missing?
11
12   see main at the bottom for examples of use.
13
14   submitted to support proposal for first class labels in Haskell'.
15
16   Claus Reinke, February 2006
17-}
18
19module Data.Record where
20
21-- | field selection
22infixl #?
23
24class Select label val rec | label rec -> val where
25  (#?) :: rec -> label -> val
26
27instance Select label val ((label,val),r) where
28  ((_,val),_) #? label = val
29
30instance Select label val r => Select label val (l,r) where
31  (_,r)       #? label = r #? label
32
33-- | field removal
34infixl #-
35
36class Remove label rec rec' | label rec -> rec' where
37  (#-) :: rec -> label -> rec' 
38
39instance Remove label () () where
40  () #- label = ()
41
42{- why do things the easy way if there's a complicated way, too? -}
43
44data LTrue  = LTrue deriving Show
45data LFalse = LFalse deriving Show
46
47class    MkBool lbool  where mkBool :: lbool
48instance MkBool LTrue  where mkBool = LTrue
49instance MkBool LFalse where mkBool = LFalse
50
51class    Has label rec lbool | label rec -> lbool
52instance Has label () LFalse
53instance Has label ((label,val),r) LTrue
54instance Has label r lbool => Has label (l,r) lbool
55
56instance (RHead r h, MkBool lbool, Has label h lbool, RemoveAux label r r' lbool) 
57         => Remove label r r' where
58  rec #- label = removeAux rec label (mkBool::lbool)
59
60class RHead r h | r -> h
61
62instance RHead ((l,v),r) ((l,v),())
63
64class RemoveAux label rec rec' lbool | label rec lbool -> rec' where
65  removeAux :: rec -> label -> lbool -> rec' 
66
67instance RemoveAux label (l,r) r LTrue where
68  removeAux (l,r) label LTrue = r
69
70instance Remove label r r' => RemoveAux label (l,r) (l,r') LFalse where
71  removeAux (l,r) label LFalse = (l, r #- label)
72
73{-
74  wouldn't this be nice and simple? unfortunately, GHC
75  complains that the very one substitution instance of the
76  3rd rule that we are not interested in is in conflict
77  with the functional dependency..
78
79class Remove label rec rec' | label rec -> rec' where
80  (#-) :: rec -> label -> rec' 
81
82instance Remove label () () where
83  () #- label = ()
84
85instance Remove label ((label,val),r) r where
86  (_,r) #- label = r
87
88instance Remove label r r' => Remove label (l,r) (l,r') where
89  (l,r) #- label = (l,r #- label)
90-}
91
92-- | field update
93infix #!
94
95rec #! label = \value->((label,value),rec #- label)
96
97-- | field renaming
98infix #@
99
100rec #@ newlabel = \oldlabel->((newlabel,rec #? oldlabel),rec #- oldlabel)
101
102-- | symmetric record concatenation
103infixr ##
104
105class Concat recA recB recAB | recA recB -> recAB where
106  (##) :: recA -> recB -> recAB
107
108instance Concat (lA,()) recB (lA,recB) where
109  (lA,()) ## recB = (lA,recB)
110
111instance Concat rA recB recRAB => Concat (lA,rA) recB (lA,recRAB) where
112  (lA,rA) ## recB = (lA,rA ## recB)
113
114-- some labels and examples
115
116data A = A deriving Show
117data B = B deriving Show
118data C = C deriving Show
119data D = D deriving Show
120
121r1 = ((A,True),((B,'a'),((C,1),())))
122
123r2 = ((A,False),((B,'b'),((C,2),r1)))
124
125r3 = ((D,"hi there"),((B,["who's calling"]),()))
126
127r4a = r1 ## r3
128r4b = r3 ## r1
129
130x1 r = (r #? B, r #? C, r #? A)
131
132x2 r = (r #? B, r #? D)
133
134x3 r = r #- D #- B
135
136main = do
137  putStrLn "\nrecords\n"
138  putStrLn $ "r1 : "++ show r1
139  putStrLn $ "r2 : "++ show r2
140  putStrLn $ "r3 : "++ show r3
141  putStrLn "\nsymmetric record concatenation\n"
142  putStrLn $ "r4a = r1 ## r3:\n\t"++ show r4a
143  putStrLn $ "r4b = r3 ## r1:\n\t"++ show r4b
144  putStrLn "\nrecord selection\n"
145  putStrLn "\nx1 r = (r #? B, r #? C, r #? A)\n"
146  putStrLn $ "x1 r1: "++ show (x1 r1)
147  putStrLn $ "x1 r2: "++ show (x1 r2)
148  putStrLn $ "x1 r4a: "++ show (x1 r4a)
149  putStrLn $ "x1 r4b: "++ show (x1 r4b)
150  putStrLn "\nx2 r = (r #? B, r #? D)\n"
151  putStrLn $ "x2 r4a: "++ show (x2 r4a)
152  putStrLn $ "x2 r4b: "++ show (x2 r4b)
153  putStrLn "\nrecord field removal\n"
154  putStrLn "\nx3 r = r #- D #- B\n"
155  putStrLn $ "x3 r1: "++ show (x3 r1)
156  putStrLn $ "x3 r2: "++ show (x3 r2)
157  putStrLn $ "x3 r3: "++ show (x3 r3)
158  putStrLn $ "x3 r4a: "++ show (x3 r4a)
159  putStrLn $ "x3 r4b: "++ show (x3 r4b)
160  putStrLn "\nrecord field update\n"
161  putStrLn $ "\n(r2 #! B) \"dingbats\":\n\t"++ show ((r2 #! B) "dingbats")
162  putStrLn "\nrecord field renaming\n"
163  putStrLn $ "\n(r2 #@ D) C:\n\t"++ show ((r2 #@ D) C)