Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

use RecordT for so-called record transformers, and Record = RecordT Pure

  • Loading branch information...
commit b8422b98a115de2c81141be95e29c680cd51086b 1 parent 9b51fbd
@mikeplus64 authored
Showing with 49 additions and 48 deletions.
  1. +49 −48 src/Data/Record.hs
View
97 src/Data/Record.hs
@@ -16,7 +16,7 @@
, ScopedTypeVariables
, ExplicitNamespaces #-}
-module Data.Record ( key
+module Data.RecordT ( key
, set
, alt
, get
@@ -31,9 +31,9 @@ module Data.Record ( key
, write
, alter
, append
- , Record
+ , RecordT
, runcomp
- , P
+ , Pure
, (:=)
, type (++)
, Key ) where
@@ -41,68 +41,50 @@ module Data.Record ( key
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Lib
-import Control.Category ((.))
import Control.Monad
-import Prelude hiding ((.))
-- | 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 s = [| undefined :: Key $(litT . return . StrTyLit $ s) |]
-
--- | See 'write'
--- [set|x|] == write (undefined :: Key x)
-set :: QuasiQuoter
-set = QuasiQuoter { quoteExp = \s -> [| write $(key s) |], quoteType = undefined, quoteDec = undefined, quotePat = undefined }
-
--- | See 'alter'
--- > [alt|x|] == alter (undefined :: Key x)
-alt :: QuasiQuoter
-alt = QuasiQuoter { quoteExp = \s -> [| alter $(key s) |], quoteType = undefined, quoteDec = undefined, quotePat = undefined }
-
--- | See 'access'.
--- > [get|x|] == access (undefined :: Key x)
-get :: QuasiQuoter
-get = QuasiQuoter { quoteExp = \s -> [| access $(key s) |], quoteType = undefined, quoteDec = undefined, quotePat = undefined }
-
-- tuples are ugly
data F a b = F a b
type (:=) = 'F
-data P
+data Pure
+
+newtype Flip f a b = Flip (f b a)
type family Wrap (w :: a) x
type instance Wrap (w :: * -> *) x = w x
-type instance Wrap P x = x
+type instance Wrap Pure x = x
-data Record w r where
- C :: Wrap w e -> Record w r -> Record w (k := e ': r)
- E :: Record w '[]
+type Record = RecordT Pure
-instance Show (Record w '[]) where
- show _ = "end"
+data RecordT w r where
+ C :: Wrap w e -> RecordT w r -> RecordT w (k := e ': r)
+ E :: RecordT w '[]
-instance (Show a, Show (Record P xs)) => Show (Record P (k := a ': xs)) where
+instance Show (RecordT w '[]) where
+ show _ = "end"
+instance (Show a, Show (Record xs)) => Show (Record (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
+instance (Show (w a), Show (RecordT w xs)) => Show (RecordT w (k := a ': xs)) where
show (C x xs) = show x ++ " & " ++ show xs
-(&) :: Wrap w e -> Record w r -> Record w (k := e ': r)
+(&) :: Wrap w e -> RecordT w r -> RecordT w (k := e ': r)
(&) = C
infixr 4 &
-end :: Record w '[]
+end :: RecordT w '[]
end = E
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
+ unbox :: (forall a. w a -> a) -> RecordT (w :: * -> *) r -> Record r
instance Unbox '[] where
{-# INLINE unbox #-}
@@ -115,7 +97,7 @@ instance Unbox xs => Unbox (x ': xs) where
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
+ box :: (forall a. a -> w a) -> Record r -> RecordT (w :: * -> *) r
instance Box '[] where
{-# INLINE box #-}
@@ -127,7 +109,7 @@ instance Box xs => Box (x ': xs) where
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
+ transform :: (forall a. (i :: * -> *) a -> (o :: * -> *) a) -> RecordT i r -> RecordT o r
instance Transform '[] where
{-# INLINE transform #-}
@@ -138,10 +120,10 @@ instance Transform xs => Transform (x ': xs) where
transform f (C x xs) = f x & transform f xs
class Run r where
- -- | Iterate over a Record's elements, and use a monad to unbox them
- -- 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)
+ -- | Iterate over a RecordT's elements, and use a monad to unbox them
+ -- Especially handy in situations like transforming a @RecordT IORef a@ to
+ -- @IO (Record a)@, where you can simply use run . transform readIORef
+ run :: Monad m => RecordT m r -> m (Record r)
instance Run '[] where
run _ = return end
@@ -153,7 +135,7 @@ class Runtrans r where
-- | A more efficient implementation of @ run . transform f @.
-- 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)
+ runtrans :: Monad o => (forall a. (i :: * -> *) a -> (o :: * -> *) a) -> RecordT i r -> o (Record r)
instance Runtrans '[] where
{-# INLINE runtrans #-}
@@ -164,7 +146,7 @@ instance Runtrans xs => Runtrans (x ': xs) where
runtrans f (C x xs) = liftM2 C (f x) (runtrans f xs)
class Access r k a | r k -> a where
- access :: Key k -> Record w r -> Wrap w a
+ access :: Key k -> RecordT w r -> Wrap w a
instance Access (k := a ': xs) k a where
{-# INLINE access #-}
@@ -176,9 +158,9 @@ instance Access xs k a => Access (k0 := a0 ': xs) k a where
class Update r k a | r k -> a where
-- | Write to a record's field
- write :: Key k -> Wrap w a -> Record w r -> Record w r
+ write :: Key k -> Wrap w a -> RecordT w r -> RecordT w r
-- | Update a record's field
- alter :: Key k -> (Wrap w a -> Wrap w a) -> Record w r -> Record w r
+ alter :: Key k -> (Wrap w a -> Wrap w a) -> RecordT w r -> RecordT w r
instance Update (k := a ': xs) k a where
{-# INLINE write #-}
@@ -200,7 +182,7 @@ type instance (x ': xs) ++ ys = x ': (xs ++ ys)
class Append r0 r1 where
-- | Make a record by appending 2.
- append :: Record w r0 -> Record w r1 -> Record w (r0 ++ r1)
+ append :: RecordT w r0 -> RecordT w r1 -> RecordT w (r0 ++ r1)
instance Append '[] '[] where
{-# INLINE append #-}
@@ -215,7 +197,7 @@ instance Append xs ys => Append (x ': xs) ys where
append (C x xs) ys = C x (append xs ys)
class RunComp r where
- runcomp :: (Functor m, Monad m) => (forall a. a -> m (w a)) -> Record P r -> m (Record w r)
+ runcomp :: (Functor m, Monad m) => (forall a. a -> m (w a)) -> Record r -> m (RecordT w r)
instance RunComp '[] where
{-# INLINE runcomp #-}
@@ -225,3 +207,22 @@ instance RunComp xs => RunComp (x ': xs) where
{-# INLINE runcomp #-}
runcomp f (C x xs) = liftM2 C (f x) (runcomp f xs)
+key :: String -> Q Exp
+key s = [| undefined :: Key $(litT . return . StrTyLit $ s) |]
+
+-- | See 'write'
+-- [set|x|] == write (undefined :: Key x)
+set :: QuasiQuoter
+set = QuasiQuoter { quoteExp = \s -> [| write $(key s) |], quoteType = undefined, quoteDec = undefined, quotePat = undefined }
+
+-- | See 'alter'
+-- > [alt|x|] == alter (undefined :: Key x)
+alt :: QuasiQuoter
+alt = QuasiQuoter { quoteExp = \s -> [| alter $(key s) |], quoteType = undefined, quoteDec = undefined, quotePat = undefined }
+
+-- | See 'access'.
+-- > [get|x|] == access (undefined :: Key x)
+get :: QuasiQuoter
+get = QuasiQuoter { quoteExp = \s -> [| access $(key s) |], quoteType = undefined, quoteDec = undefined, quotePat = undefined }
+
+
Please sign in to comment.
Something went wrong with that request. Please try again.