Permalink
Browse files

readd Append

  • Loading branch information...
1 parent 05fbaa5 commit 93ba4ae4612b9bc8bbc9bb31b40733a7bf36c292 @mikeplus64 committed Dec 14, 2012
Showing with 40 additions and 48 deletions.
  1. +40 −48 src/Data/Record.hs
View
88 src/Data/Record.hs
@@ -29,26 +29,23 @@ module Data.Record ( key
, access
, write
, alter
- -- , append
+ , append
, Record
, P
, (:=)
- -- , NotElem
- -- , AllNotElem
, type (++)
- , Keys ) where
-module Data.Record where
+ , Key ) where
+
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Lib
-import GHC.TypeLits
-- | A key of a record. This does not exist at runtime, and as a tradeoff,
-- you can't do field access from a string and a Typeable context, although
-- it would certainly be very nice.
data Key k
-key :: String -> Q Exp
+key :: String -> Q Exp
key s = [| undefined :: Key $(litT . return . StrTyLit $ s) |]
-- | See 'write'
@@ -66,32 +63,33 @@ alt = QuasiQuoter { quoteExp = \s -> [| alter $(key s) |], quoteType = undefine
get :: QuasiQuoter
get = QuasiQuoter { quoteExp = \s -> [| access $(key s) |], quoteType = undefined, quoteDec = undefined, quotePat = undefined }
--- | A field
+-- tuples are ugly
data F a b = F a b
type (:=) = 'F
-infixr 4 &
-
data P
type family Wrap (w :: a) x
type instance Wrap (w :: * -> *) x = w x
-type instance Wrap P x = x
+type instance Wrap P x = x
data Record w r where
C :: Wrap w e -> Record w r -> Record w (k := e ': r)
E :: Record w '[]
instance Show (Record w '[]) where
show _ = "end"
+
instance (Show a, Show (Record P xs)) => Show (Record P (k := a ': xs)) where
show (C x xs) = show x ++ " & " ++ show xs
+
instance (Show (w a), Show (Record w xs)) => Show (Record w (k := a ': xs)) where
show (C x xs) = show x ++ " & " ++ show xs
(&) :: Wrap w e -> Record w r -> Record w (k := e ': r)
(&) = C
+infixr 4 &
end :: Record w '[]
end = E
@@ -100,27 +98,31 @@ class Unbox r where
-- | "Unbox" every element of a record.
-- Great for cases where every element is wrapped by a newtype.
unbox :: (forall a. w a -> a) -> Record (w :: * -> *) r -> Record P r
+
instance Unbox '[] where
- {-# INLINE unbox #-}
unbox _ _ = end
+
instance Unbox xs => Unbox (x ': xs) where
- {-# INLINE unbox #-}
unbox f (C x xs) = f x & unbox f xs
class Box r where
-- | "Box" every element of a record.
-- Usually means applying a newtype wrapper to everything
box :: (forall a. a -> w a) -> Record P r -> Record (w :: * -> *) r
+
instance Box '[] where
box _ _ = end
+
instance Box xs => Box (x ': xs) where
box f (C x xs) = C (f x) (box f xs)
class Transform r where
-- | Change the type wrapping every element of a record
transform :: (forall a. (i :: * -> *) a -> (o :: * -> *) a) -> Record i r -> Record o r
+
instance Transform '[] where
transform _ _ = end
+
instance Transform xs => Transform (x ': xs) where
transform f (C x xs) = f x & transform f xs
@@ -129,8 +131,10 @@ class Run r where
-- Especially handy in situations like transforming a @Record IORef a@ to
-- @IO (Record P a)@, where you can simply use run . transform readIORef
run :: Monad m => Record m r -> m (Record P r)
+
instance Run '[] where
run _ = return end
+
instance Run xs => Run (x ': xs) where
run (C x xs) = do
y <- x
@@ -142,8 +146,10 @@ class Runtrans r where
-- Rewrite rules should transform @ run . transform f @ into a call
-- to @ runtrans f @
runtrans :: Monad o => (forall a. (i :: * -> *) a -> (o :: * -> *) a) -> Record i r -> o (Record P r)
+
instance Runtrans '[] where
runtrans _ _ = return end
+
instance Runtrans xs => Runtrans (x ': xs) where
runtrans f (C x xs) = do
y <- f x
@@ -156,9 +162,11 @@ instance Runtrans xs => Runtrans (x ': xs) where
class Access r k a | r k -> a where
access :: Key k -> Record w r -> Wrap w a
+
instance Access (k := a ': xs) k a where
{-# INLINE access #-}
access _ (C x _) = x
+
instance Access xs k a => Access (k0 := a0 ': xs) k a where
{-# INLINE access #-}
access n (C _ xs) = access n xs
@@ -168,55 +176,39 @@ class Update r k a | r k -> a where
write :: Key k -> Wrap w a -> Record w r -> Record w r
-- | Update a record's field
alter :: Key k -> (Wrap w a -> Wrap w a) -> Record w r -> Record w r
+
instance Update (k := a ': xs) k a where
{-# INLINE write #-}
{-# INLINE alter #-}
write _ x (C _ xs) = x & xs
alter _ f (C y ys) = f y & ys
+
instance Update xs k a => Update (k0 := a0 ': xs) k a where
{-# INLINE write #-}
{-# INLINE alter #-}
write n y (C x xs) = x & write n y xs
alter n f (C x xs) = x & alter n f xs
-{-
-class Change w r k where
- type New w r k a
- writep :: Key k -> a -> Record w r -> Record w (New w r k a)
-
+-- | Append two type-level lists
+type family (++) (x :: [a]) (y :: [a]) :: [a]
+type instance '[] ++ '[] = '[]
+type instance '[] ++ ys = ys
+type instance (x ': xs) ++ ys = x ': (xs ++ ys)
-class Is a b (t :: Bool)
-instance Is a a 'True
-instance Is a b 'False
+class Append r0 r1 where
+ -- | Make a record by appending 2.
+ append :: Record w r0 -> Record w r1 -> Record w (r0 ++ r1)
-class NotElem a as
-instance (NotElem a bs, Is a b 'False) => NotElem a (b ': bs)
-instance NotElem a '[]
+instance Append '[] '[] where
+ {-# INLINE append #-}
+ append _ _ = end
-class AllNotElem xs ys
-instance AllNotElem '[] ys
-instance (NotElem x ys, AllNotElem xs ys) => AllNotElem (x ': xs) ys
+instance Append '[] a where
+ {-# INLINE append #-}
+ append _ x = x
-type family Not (a :: Bool) :: Bool
-type instance Not 'True = 'False
-type instance Not 'False = 'True
+instance Append xs ys => Append (x ': xs) ys where
+ {-# INLINE append #-}
+ append (C x xs) ys = C x (append xs ys)
-type family Keys (xs :: [F k a]) :: [k]
-type instance Keys '[] = '[]
-type instance Keys (k := a ': xs) = k ': Keys xs
--- | Append two type-level lists
-type family (++) (x :: [a]) (y :: [a]) :: [a]
-type instance '[] ++ ys = ys
-type instance (x ': xs) ++ ys = x ': (xs ++ ys)
-
-class Append w r0 r1 where
- -- | Append two records, making sure first that there are no duplicate fields
- append :: AllNotElem (Keys r0) (Keys r1) => Record w r0 -> Record w r1 -> Record w (r0 ++ r1)
-instance Append w '[] ys where
- append _ ys = ys
-instance (AllNotElem (Keys xs) (Keys ys), Append P xs ys) => Append P (x ': xs) ys where
- append (C x xs) ys = C x (append xs ys)
-instance (AllNotElem (Keys xs) (Keys ys), Append (w :: * -> *) xs ys) => Append w (x ': xs) ys where
- append (C x xs) ys = C x (append xs ys)
--}

0 comments on commit 93ba4ae

Please sign in to comment.