Ticket #2820: RepSmall.hs

File RepSmall.hs, 14.3 KB (added by ben.kavanagh, 7 years ago)

Cut down version of RepLib library core. This is to show where the problem code was used originally.

Line 
1{-# LANGUAGE TemplateHaskell, UndecidableInstances #-}
2-- {-# OPTIONS -fglasgow-exts #-}
3{-# LANGUAGE ExistentialQuantification, TypeOperators, GADTs #-}
4{-# LANGUAGE RankNTypes, MultiParamTypeClasses, FlexibleInstances  #-}
5{-# LANGUAGE TypeSynonymInstances, ScopedTypeVariables  #-}
6
7
8-----------------------------------------------------------------------------
9-- |
10-- Module      :  Data.RepLib.R
11-- Copyright   :  (c) The University of Pennsylvania, 2006
12-- License     :  BSD
13--
14-- Maintainer  :  [email protected]
15-- Stability   :  experimental
16-- Portability :  non-portable
17--
18--
19--
20-----------------------------------------------------------------------------
21
22-- options for deletion. tuple commands, cast commands, Rep SYB ops.
23
24module Data.RepLib.RepCombined (
25
26  -- ** Operations for heterogeneous lists
27  findCon, Val(..), foldl_l, foldr_l, map_l, mapQ_l, mapM_l, 
28
29  -- Tuple ops
30  fromTup, fromTupM, toList,
31
32  -- ** SYB style operations (Rep)
33  Traversal, Query, MapM, 
34  gmapT, gmapQ, gmapM,
35
36  -- ** SYB style operations (Rep1)
37  Traversal1, Query1, MapM1,
38  gmapT1, gmapQ1, gmapM1,
39
40  -- ** SYB Reloaded
41
42  Typed(..),Spine(..), toSpine, fromSpine
43
44
45) where
46
47import Data.List
48-- import GHC.Base (unsafeCoerce#)
49
50
51data R a where
52   Int     :: R Int
53   Char    :: R Char 
54   Integer :: R Integer
55   Float   :: R Float
56   Double  :: R Double
57   Rational:: R Rational
58   IOError :: R IOError
59   IO      :: (Rep a) => R a -> R (IO a)
60   Arrow   :: (Rep a, Rep b) => R a -> R b -> R (a -> b)
61   Data    :: DT -> [Con R a] -> R a
62
63data Emb l a  = Emb { to     :: l -> a, 
64                      from   :: a -> Maybe l, 
65                      labels :: Maybe [String], 
66                      name   :: String,
67                                                         fixity :: Fixity
68                     }
69
70data Fixity =  Nonfix
71                | Infix      { prec      :: Int }
72                | Infixl     { prec      :: Int }
73                | Infixr     { prec      :: Int }
74
75
76data DT       = forall l. DT String (MTup R l)
77data Con r a  = forall l. Con (Emb l a) (MTup r l)
78
79
80data Nil = Nil 
81data a :*: l = a :*: l
82infixr 7 :*:
83
84data MTup r l where
85    MNil   :: MTup ctx Nil
86    (:+:)  :: (Rep a) => r a -> MTup r l -> MTup r (a :*: l)
87
88infixr 7 :+:
89
90class Rep a where rep :: R a
91
92------ Showing representations  (rewrite this with showsPrec?)
93
94instance Show (R a) where
95  show Int     = "Int"
96  show Char    = "Char"
97  show Integer = "Integer"
98  show Float   = "Float"
99  show Double  = "Double"
100  show Rational= "Rational"
101  show (IO t)  = "(IO " ++ show t ++ ")"
102  show IOError = "IOError"
103  show (Arrow r1 r2) = 
104     "(" ++ (show r1) ++ " -> " ++ (show r2) ++ ")"
105  show (Data dt _) = 
106     "(Data" ++ show dt ++ ")"
107
108instance Show DT where
109  show (DT str reps) = str ++ show reps
110 
111instance Show (MTup R l) where
112  show MNil         = ""
113  show (r :+: MNil) = show r
114  show (r :+: rs)   = " " ++ show r ++ show rs
115
116instance Eq (R a) where
117         r1 == r2 = True
118
119
120--- Representations for Haskell Prelude types
121
122instance Rep Int where rep = Int
123instance Rep Char where rep = Char
124instance Rep Double where rep = Double
125instance Rep Rational where rep = Rational
126instance Rep Float where rep = Float
127instance Rep Integer where rep = Integer
128instance Rep a => Rep (IO a) where rep = IO rep
129instance Rep IOError where rep = IOError
130instance (Rep a, Rep b) => Rep (a -> b) where rep = Arrow rep rep
131
132-- Booleans
133{-
134rTrueEmb :: Emb Nil Bool
135rTrueEmb =  Emb { to = \Nil -> True,
136                  from = \x -> if x then Just Nil else Nothing,
137                  labels = Nothing,
138                  name = "True",
139                                                fixity = Nonfix
140                 }
141
142rFalseEmb :: Emb Nil Bool
143rFalseEmb =  Emb { to = \Nil -> False,
144                   from = \x -> if x then Nothing else Just Nil,
145                   labels = Nothing,
146                   name = "False",
147                                                 fixity = Nonfix
148                  }
149
150rBool :: R Bool
151rBool = Data (DT "Bool" MNil) [Con rTrueEmb, Con rFalseEmb]
152
153instance Rep Bool where rep = rBool
154 -}
155     
156-- Unit
157
158rUnitEmb :: Emb Nil ()
159rUnitEmb = Emb { to = \Nil -> (), 
160                 from = \() -> Just Nil, 
161                                labels = Nothing, 
162                 name = "()", 
163                 fixity = Nonfix }
164
165rUnit :: R ()
166rUnit = Data (DT "()" MNil) 
167        [Con rUnitEmb MNil]
168 
169instance Rep () where rep = rUnit
170
171-- Tuples
172
173instance (Rep a, Rep b) => Rep (a,b) where
174   rep = rTup2
175
176rTup2 :: forall a b. (Rep a, Rep b) => R (a,b)
177rTup2 = let args =  ((rep :: R a) :+: (rep :: R b) :+: MNil) in
178                    Data (DT "," args) [ Con rPairEmb args ]
179
180rPairEmb :: Emb (a :*: b :*: Nil) (a,b)
181rPairEmb = 
182  Emb { to = \( t1 :*: t2 :*: Nil) -> (t1,t2),
183        from = \(a,b) -> Just (a :*: b :*: Nil),
184        labels = Nothing, 
185        name = "(,)",
186                  fixity = Nonfix -- ???
187      }
188
189-- Lists
190rList :: forall a. Rep a => R [a]
191rList = Data (DT "[]" ((rep :: R a) :+: MNil))
192             [ Con rNilEmb MNil, Con rConsEmb ((rep :: R a) :+: rList :+: MNil) ]
193
194rNilEmb :: Emb Nil [a]
195rNilEmb = Emb {   to   = \Nil -> [],
196                  from  = \x -> case x of 
197                           (x:xs) -> Nothing
198                           []     ->  Just Nil,
199                  labels = Nothing, 
200                  name = "[]",
201                                                fixity = Nonfix
202                                       
203                 }
204
205rConsEmb :: Emb (a :*: [a] :*: Nil) [a]
206rConsEmb = 
207   Emb { 
208            to   = (\ (hd :*: tl :*: Nil) -> (hd : tl)),
209            from  = \x -> case x of 
210                    (hd : tl) -> Just (hd :*: tl :*: Nil)
211                    []        -> Nothing,
212            labels = Nothing, 
213            name = ":",
214                                fixity = Nonfix -- ???
215          }
216
217instance Rep a => Rep [a] where
218   rep = rList
219
220{-
221-- Maybe representation
222
223rJust :: Rep a => Con (Maybe a)
224rJust = Con (rJustEmb)
225
226rJustEmb :: Emb (a :*: Nil) (Maybe a)
227rJustEmb = Emb
228  { to   = (\(x :*: Nil) -> Just x),
229    from  = \x -> case x of
230            (Just y) -> Just (y :*: Nil)
231            Nothing  -> Nothing,
232    labels = Nothing,
233    name = "Just"
234   }
235
236rNothing :: Con (Maybe a)
237rNothing = Con rNothingEmb
238
239rNothingEmb :: Emb Nil (Maybe a)
240rNothingEmb = Emb
241  { to   = \Nil -> Nothing,
242    from  = \x -> case x of
243             Nothing -> Just Nil
244             _       -> Nothing,
245    labels = Nothing,
246    name = "Nothing"
247  }
248
249rMaybe :: forall a. Rep a => R (Maybe a)
250rMaybe = Data (DT "Maybe" ((rep :: R a) :+: MNil))
251              [rJust, rNothing]
252
253instance Rep a => Rep (Maybe a) where
254   rep = rMaybe
255-}
256-- Ordering
257-- Either
258
259
260
261-- Parameterized rep
262data R1 ctx a where
263    Int1      :: R1 ctx Int
264    Char1     :: R1 ctx Char
265    Integer1  :: R1 ctx Integer
266    Float1    :: R1 ctx Float
267    Double1   :: R1 ctx Double
268    Rational1 :: R1 ctx Rational
269    IOError1  :: R1 ctx IOError
270    IO1       :: (Rep a) => ctx a -> R1 ctx (IO a)
271    Arrow1    :: (Rep a, Rep b) => ctx a -> ctx b -> R1 ctx (a -> b)
272    Data1     :: DT -> [Con ctx a] -> R1 ctx a
273
274class Sat a where dict :: a
275
276class Rep a => Rep1 ctx a where rep1 :: R1 ctx a
277
278instance Show (R1 c a) where
279    show Int1           = "Int1"
280    show Char1          = "Char1"
281    show Integer1       = "Integer1"
282    show Float1         = "Float1"
283    show Double1        = "Double1"
284    show Rational1      = "Rational1"
285    show IOError1       = "IOError1"
286    show (IO1 cb)       = "(IO1 " ++ show (getRep cb) ++ ")"
287    show (Arrow1 cb cc) = "(Arrow1 " ++ show (getRep cb) ++ " " ++ show (getRep cc) ++ ")" 
288    show (Data1 dt _)   = "(Data1 " ++ show dt ++ ")"
289
290-- | Access a representation, given a proxy
291getRep :: Rep b => c b -> R b
292getRep cb = rep
293
294-- | Transform a parameterized rep to a vanilla rep
295toR :: R1 c a -> R a
296toR Int1            = Int
297toR Char1           = Char
298toR Integer1        = Integer
299toR Float1          = Float
300toR Double1         = Double
301toR Rational1       = Rational
302toR IOError1        = IOError
303toR (Arrow1 t1 t2)  = Arrow (getRep t1) (getRep t2)
304toR (IO1 t1)        = IO (getRep t1)
305toR (Data1 dt cons) = (Data dt (map toCon cons))
306  where toCon (Con emb rec) = Con emb (toRs rec)
307        toRs           :: MTup c a -> MTup R a
308        toRs MNil      = MNil
309        toRs (c :+: l) = (getRep c :+: toRs l)
310
311---------------  Representations of Prelude types
312
313instance Rep1 ctx Int      where rep1 = Int1
314instance Rep1 ctx Char     where rep1 = Char1
315instance Rep1 ctx Integer  where rep1 = Integer1
316instance Rep1 ctx Float    where rep1 = Float1
317instance Rep1 ctx Double   where rep1 = Double1
318instance Rep1 ctx IOError  where rep1 = IOError1
319instance Rep1 ctx Rational where rep1 = Rational1
320instance (Rep a, Sat (ctx a)) => 
321         Rep1 ctx (IO a)   where rep1 = IO1 dict
322instance (Rep a, Rep b, Sat (ctx a), Sat (ctx b)) => 
323         Rep1 ctx (a -> b) where rep1 = Arrow1 dict dict
324
325
326-- Data structures
327
328-- unit
329instance Rep1 ctx ()   where 
330 rep1 = Data1 (DT "()" MNil)
331        [Con rUnitEmb MNil]
332
333-- pairs
334rTup2_1 :: forall a b ctx. (Rep a, Rep b) => ctx a -> ctx b -> R1 ctx (a,b)
335rTup2_1 ca cb = 
336  case (rep :: R (a,b)) of 
337     Data rdt _ -> Data1 rdt
338       [Con rPairEmb (ca :+: cb :+: MNil)]
339     
340instance (Rep a, Sat (ctx a), Rep b, Sat (ctx b)) => Rep1 ctx (a,b) where
341  rep1 = rTup2_1 dict dict
342
343
344-- Lists
345rList1 :: forall a ctx. 
346  Rep a => ctx a -> ctx [a] -> R1 ctx [a]
347rList1 ca cl = Data1 (DT "[]" ((rep :: R a) :+: MNil))
348                  [ rCons1 ca cl, rNil1 ]
349
350rNil1  :: Con ctx [a]
351rNil1  = Con rNilEmb MNil
352
353rCons1 :: Rep a => ctx a -> ctx [a] -> Con ctx [a]
354rCons1 ca cl = Con rConsEmb (ca :+: cl :+: MNil)
355
356instance (Rep a, Sat (ctx a), Sat (ctx [a])) => Rep1 ctx [a] where
357  rep1 = rList1 dict dict
358
359
360
361
362
363
364
365
366--------- Basic instances and library operations for heterogeneous lists ---------------
367
368-- | A datastructure to store the results of findCon
369data Val ctx a = forall l.  Val (Emb l a) (MTup ctx l) l
370
371-- | Given a list of constructor representations for a datatype,
372-- determine which constructor formed the datatype.
373findCon :: [Con ctx a] -> a -> Val ctx a
374findCon (Con rcd rec : rest) x = case (from rcd x) of 
375       Just ys -> Val rcd rec ys
376       Nothing -> findCon rest x
377
378-- | A fold right operation for heterogeneous lists, that folds a function
379-- expecting a type type representation across each element of the list.
380foldr_l :: (forall a. Rep a => ctx a -> a -> b -> b) -> b
381            -> (MTup ctx l) -> l -> b
382foldr_l f b MNil Nil = b
383foldr_l f b (ca :+: cl) (a :*: l) = f ca a (foldr_l f b cl l ) 
384
385-- | A fold left for heterogeneous lists
386foldl_l :: (forall a. Rep a => ctx a -> b -> a -> b) -> b
387            -> (MTup ctx l) ->  l -> b
388foldl_l f b MNil Nil = b
389foldl_l f b (ca :+: cl) (a :*: l) = foldl_l f (f ca b a) cl l
390
391-- | A map for heterogeneous lists
392map_l :: (forall a. Rep a => ctx a -> a -> a) 
393           -> (MTup ctx l) ->  l ->  l
394map_l f MNil Nil = Nil
395map_l f (ca :+: cl) (a :*: l) = (f ca a) :*: (map_l f cl l)
396
397-- | Transform a heterogeneous list in to a standard list
398mapQ_l :: (forall a. Rep a => ctx a -> a -> r) -> MTup ctx l -> l -> [r]
399mapQ_l q MNil Nil = []
400mapQ_l q (r :+: rs) (a :*: l) = q r a : mapQ_l q rs l
401
402-- | mapM for heterogeneous lists
403mapM_l :: (Monad m) => (forall a. Rep a => ctx a -> a -> m a) -> MTup ctx l -> l -> m l
404mapM_l f MNil Nil = return Nil
405mapM_l f (ca :+: cl) (a :*: l) = do 
406  x1 <- f ca a
407  x2 <- mapM_l f cl l
408  return (x1 :*: x2)
409
410
411
412-- | Generate a heterogeneous list from metadata
413fromTup :: (forall a. Rep a => ctx a -> a) -> MTup ctx l -> l
414fromTup f MNil = Nil
415fromTup f (b :+: l) = (f b) :*: (fromTup f l)
416
417-- | Generate a heterogeneous list from metadata, in a monad
418fromTupM :: (Monad m) => (forall a. Rep a => ctx a -> m a) -> MTup ctx l -> m l
419fromTupM f MNil = return Nil
420fromTupM f (b :+: l) = do hd <- f b
421                          tl <- fromTupM f l
422                          return (hd :*: tl)
423
424-- | Generate a normal lists from metadata
425toList :: (forall a. Rep a => ctx a -> b) -> MTup ctx l -> [b]
426toList f MNil = []
427toList f (b :+: l) = f b : toList f l
428
429
430---------------------  SYB style operations --------------------------
431
432-- | A SYB style traversal
433type Traversal = forall a. Rep a => a -> a
434
435-- | Map a traversal across the kids of a data structure
436gmapT :: forall a. Rep a => Traversal -> a -> a
437gmapT t = 
438  case (rep :: R a) of 
439   (Data dt cons) -> \x -> 
440     case (findCon cons x) of 
441      Val emb reps ys -> to emb (map_l (const t) reps ys)
442   _ -> id
443
444
445-- | SYB style query type
446type Query r = forall a. Rep a => a -> r
447
448gmapQ :: forall a r. Rep a => Query r -> a -> [r]
449gmapQ q =
450  case (rep :: R a) of 
451    (Data dt cons) -> \x -> case (findCon cons x) of 
452                Val emb reps ys -> mapQ_l (const q) reps ys
453    _ -> const []
454
455
456-- | SYB style monadic map type
457type MapM m = forall a. Rep a => a -> m a
458
459gmapM   :: forall a m. (Rep a, Monad m) => MapM m -> a -> m a
460gmapM m = case (rep :: R a) of
461   (Data dt cons) -> \x -> case (findCon cons x) of 
462     Val emb reps ys -> do l <- mapM_l (const m) reps ys
463                           return (to emb l)
464   _ -> return
465
466
467-------------- Generalized  SYB ops ---------------------------
468
469type Traversal1 ctx = forall a. Rep a => ctx a -> a -> a
470gmapT1 :: forall a ctx. (Rep1 ctx a) => Traversal1 ctx -> a -> a
471gmapT1 t = 
472  case (rep1 :: R1 ctx a) of 
473   (Data1 dt cons) -> \x -> 
474     case (findCon cons x) of 
475      Val emb recs kids -> to emb (map_l t recs kids)
476   _ -> id
477
478type Query1 ctx r = forall a. Rep a => ctx a -> a -> r
479gmapQ1 :: forall a ctx r. (Rep1 ctx a) => Query1 ctx r -> a -> [r]
480gmapQ1 q  =
481  case (rep1 :: R1 ctx a) of 
482    (Data1 dt cons) -> \x -> case (findCon cons x) of 
483                Val emb recs kids -> mapQ_l q recs kids
484    _ -> const []
485
486type MapM1 ctx m = forall a. Rep a => ctx a -> a -> m a
487gmapM1  :: forall a ctx m. (Rep1 ctx a, Monad m) => MapM1 ctx m -> a -> m a
488gmapM1 m = case (rep1 :: R1 ctx a) of
489   (Data1 dt cons) -> \x -> case (findCon cons x) of 
490     Val emb rec ys -> do l <- mapM_l m rec ys
491                          return (to emb l)
492   _ -> return
493
494-------------- Spine from SYB Reloaded ---------------------------
495
496data Typed a = a ::: R a
497infixr 7 :::
498
499data Spine a where
500         Constr :: a -> Spine a
501         (:<>)  :: Spine (a -> b) -> Typed a -> Spine b
502
503toSpineR :: R a -> a -> Spine a
504toSpineR (Data _ cons) a = 
505         case (findCon cons a) of 
506            Val emb reps kids -> toSpineRl reps kids (to emb)
507toSpineR _ a = Constr a
508
509toSpineRl :: MTup R l -> l -> (l -> a) -> Spine a
510toSpineRl MNil Nil into = Constr (into Nil)
511toSpineRl (ra :+: rs) (a :*: l) into = 
512         (toSpineRl rs l into') :<> (a ::: ra)
513                  where into' tl1 x1 = into (x1 :*: tl1)
514
515toSpine :: Rep a => a -> Spine a
516toSpine = toSpineR rep
517
518fromSpine :: Spine a -> a
519fromSpine (Constr x) = x
520fromSpine (x :<> (y:::_)) = fromSpine x y
521
522
523