Ticket #92: Data.Record.hs

{-# OPTIONS -fglasgow-exts #-}
{-# OPTIONS -fallow-overlapping-instances #-}
{-# OPTIONS -fallow-undecidable-instances #-}

{- 
   poor man's records using nested tuples and declared labels:

   apart from record extension (,), we've got field selection (#?), 
   field removal (#-), field update (#!), field renaming (#@),
   symmetric record concatenation (##), .. anything missing?

   see main at the bottom for examples of use.

   submitted to support proposal for first class labels in Haskell'.

   Claus Reinke, February 2006
-}

module Data.Record where

-- | field selection
infixl #?

class Select label val rec | label rec -> val where
  (#?) :: rec -> label -> val

instance Select label val ((label,val),r) where
  ((_,val),_) #? label = val

instance Select label val r => Select label val (l,r) where
  (_,r)       #? label = r #? label

-- | field removal
infixl #-

class Remove label rec rec' | label rec -> rec' where
  (#-) :: rec -> label -> rec'  

instance Remove label () () where
  () #- label = ()

{- why do things the easy way if there's a complicated way, too? -}

data LTrue  = LTrue deriving Show
data LFalse = LFalse deriving Show

class    MkBool lbool  where mkBool :: lbool
instance MkBool LTrue  where mkBool = LTrue
instance MkBool LFalse where mkBool = LFalse

class    Has label rec lbool | label rec -> lbool
instance Has label () LFalse
instance Has label ((label,val),r) LTrue
instance Has label r lbool => Has label (l,r) lbool

instance (RHead r h, MkBool lbool, Has label h lbool, RemoveAux label r r' lbool) 
         => Remove label r r' where
  rec #- label = removeAux rec label (mkBool::lbool)

class RHead r h | r -> h

instance RHead ((l,v),r) ((l,v),())

class RemoveAux label rec rec' lbool | label rec lbool -> rec' where
  removeAux :: rec -> label -> lbool -> rec'  

instance RemoveAux label (l,r) r LTrue where
  removeAux (l,r) label LTrue = r

instance Remove label r r' => RemoveAux label (l,r) (l,r') LFalse where
  removeAux (l,r) label LFalse = (l, r #- label)

{-
  wouldn't this be nice and simple? unfortunately, GHC
  complains that the very one substitution instance of the
  3rd rule that we are not interested in is in conflict
  with the functional dependency..

class Remove label rec rec' | label rec -> rec' where
  (#-) :: rec -> label -> rec'  

instance Remove label () () where
  () #- label = ()

instance Remove label ((label,val),r) r where
  (_,r) #- label = r

instance Remove label r r' => Remove label (l,r) (l,r') where
  (l,r) #- label = (l,r #- label)
-}

-- | field update
infix #!

rec #! label = \value->((label,value),rec #- label)

-- | field renaming
infix #@

rec #@ newlabel = \oldlabel->((newlabel,rec #? oldlabel),rec #- oldlabel)

-- | symmetric record concatenation
infixr ##

class Concat recA recB recAB | recA recB -> recAB where
  (##) :: recA -> recB -> recAB

instance Concat (lA,()) recB (lA,recB) where
  (lA,()) ## recB = (lA,recB)

instance Concat rA recB recRAB => Concat (lA,rA) recB (lA,recRAB) where
  (lA,rA) ## recB = (lA,rA ## recB)

-- some labels and examples

data A = A deriving Show
data B = B deriving Show
data C = C deriving Show
data D = D deriving Show

r1 = ((A,True),((B,'a'),((C,1),())))

r2 = ((A,False),((B,'b'),((C,2),r1)))

r3 = ((D,"hi there"),((B,["who's calling"]),()))

r4a = r1 ## r3
r4b = r3 ## r1

x1 r = (r #? B, r #? C, r #? A)

x2 r = (r #? B, r #? D)

x3 r = r #- D #- B

main = do
  putStrLn "\nrecords\n"
  putStrLn $ "r1 : "++ show r1
  putStrLn $ "r2 : "++ show r2
  putStrLn $ "r3 : "++ show r3
  putStrLn "\nsymmetric record concatenation\n"
  putStrLn $ "r4a = r1 ## r3:\n\t"++ show r4a
  putStrLn $ "r4b = r3 ## r1:\n\t"++ show r4b
  putStrLn "\nrecord selection\n"
  putStrLn "\nx1 r = (r #? B, r #? C, r #? A)\n"
  putStrLn $ "x1 r1: "++ show (x1 r1)
  putStrLn $ "x1 r2: "++ show (x1 r2)
  putStrLn $ "x1 r4a: "++ show (x1 r4a)
  putStrLn $ "x1 r4b: "++ show (x1 r4b)
  putStrLn "\nx2 r = (r #? B, r #? D)\n"
  putStrLn $ "x2 r4a: "++ show (x2 r4a)
  putStrLn $ "x2 r4b: "++ show (x2 r4b)
  putStrLn "\nrecord field removal\n"
  putStrLn "\nx3 r = r #- D #- B\n"
  putStrLn $ "x3 r1: "++ show (x3 r1)
  putStrLn $ "x3 r2: "++ show (x3 r2)
  putStrLn $ "x3 r3: "++ show (x3 r3)
  putStrLn $ "x3 r4a: "++ show (x3 r4a)
  putStrLn $ "x3 r4b: "++ show (x3 r4b)
  putStrLn "\nrecord field update\n"
  putStrLn $ "\n(r2 #! B) \"dingbats\":\n\t"++ show ((r2 #! B) "dingbats")
  putStrLn "\nrecord field renaming\n"
  putStrLn $ "\n(r2 #@ D) C:\n\t"++ show ((r2 #@ D) C)