nevermind that's more trouble than it's worth

src/Data/Record.hs

@@ -20,7 +20,7 @@
 
 -- and in no particular order ...
 {-# LANGUAGE GADTs
-           , StandaloneDeriving
+           , ImplicitParams
            , TypeFamilies
            , ConstraintKinds
            , FlexibleInstances
@@ -46,6 +46,7 @@ module Data.Record
   , (&)
   , nil
 
+  , Wrap
   , Key
   , (:=)
 
@@ -85,9 +86,10 @@ module Data.Record
 import Language.Haskell.TH.Syntax
 import Language.Haskell.TH.Quote
 import Language.Haskell.TH.Lib
-import Control.Monad.Identity
+import Control.Monad
 import Data.Monoid
 import GHC.TypeLits
+import Unsafe.Coerce
 
 -- | 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
@@ -107,43 +109,41 @@ infixr 9 :.:
 compose :: (a -> w (m a)) -> a -> (w :.: m) a
 compose f = Wmx . f
 
+-- | Phantom type denoting a simple record without any transformations
+data Pure
+
+-- | 'Wrap' lets you not put a record's fields in some wrapper when you
+-- don't want it (e.g. 'Identity'). In general I find this is nicer to use.
+type family Wrap (w :: a) x
+type instance Wrap (w :: * -> *) x = w x
+type instance Wrap Pure          x = x
+
 -- | The base record transformer data type. Fields are indexed by type-level
 -- keys, which can be anything. It is very convenient to use
 -- 'GHC.TypeLits.Symbol' to index record fields, but it is just as valid to
 -- declare phantom types for them.
-data RecordT :: (* -> *) -> [F k *] -> * where 
-    C :: w e -> RecordT w r -> RecordT w (k := e ': r)
+data RecordT w r where 
+    C :: Wrap w e -> RecordT w r -> RecordT w (k := e ': r)
     E :: RecordT w '[]
 
-type Record = RecordT Identity
-
-class Build (w :: * -> *) (a :: *) x | w -> x where
-    (&) :: a -> RecordT w xs -> RecordT w (x ': xs)
+type Record = RecordT Pure
 
-instance Build Identity a (k := a) where
-    {-# INLINE (&) #-}
-    (&) x = C (Identity x)
+{-# INLINE (&) #-}
+(&) :: Wrap w e -> RecordT w r -> RecordT w (k := e ': r)
+(&) = C
+infixr 4 &
 
-instance Build w (w a) (k := a) where
-    {-# INLINE (&) #-}
-    (&) = C
-
-{-# INLINE nil #-}
 nil :: RecordT w '[]
 nil = E
 
-{-# INLINE cid #-}
-cid :: e -> Record r -> Record (k := e ': r)
-cid x y = C (Identity x) y
-
 --------------------------------------------------------------------------------
 --  Standard instances
 
 instance Eq (RecordT w '[]) where
     {-# INLINE (==) #-}
     _ == _ = True
 
-instance ( Eq (w x)
+instance ( Eq (Wrap w x)
          , Eq (RecordT w xs)) 
         => Eq (RecordT w (k := x ': xs)) where
     {-# INLINE (==) #-}
@@ -153,7 +153,7 @@ instance Ord (RecordT w '[]) where
     {-# INLINE compare #-}
     compare _ _ = EQ
 
-instance ( Ord (w x)
+instance ( Ord (Wrap w x)
          , Ord (RecordT w xs))
         => Ord (RecordT w (k := x ': xs)) where
     {-# INLINE compare #-}
@@ -165,7 +165,7 @@ instance Show (RecordT w '[]) where
 instance ( Show a
          , Show (Record xs)) 
         => Show (Record (k := a ': xs)) where
-    show (C x xs) = show (runIdentity x) ++ " & " ++ show xs
+    show (C x xs) = show x ++ " & " ++ show xs
 
 instance ( Show (w a)
          , Show (RecordT w xs)) 
@@ -178,18 +178,18 @@ instance Monoid (RecordT w '[]) where
     mappend _ _  = nil
     mempty       = nil
 
-instance ( Monoid (w x)
+instance ( Monoid (Wrap w x)
          , Monoid (RecordT w xs)) 
         => Monoid (RecordT w (k := x ': xs)) where
     {-# INLINE mappend #-}
     mappend (C x xs) (C y ys) = mappend x y & mappend xs ys
-    mempty                    = mempty     `C` mempty
+    mempty                    = mempty      & mempty
 
 --------------------------------------------------------------------------------
 --  Field accessors/setters
 
 class Access r k a | r k -> a where
-    access :: Key k -> RecordT w r -> w a
+    access :: Key k -> RecordT w r -> Wrap w a
 
 instance Access (k := a ': xs) k a where
     {-# INLINE access #-}
@@ -208,7 +208,7 @@ class Knock k r a | k r -> a where
     -- | Try ("knock politely") to get a field of a record.
     -- It's impossible to get proper "lookups" at runtime, so this function
     -- is probably not very useful.
-    knock :: Key k -> RecordT w r -> Maybe (w a)
+    knock :: Key k -> RecordT w r -> Maybe (Wrap w a)
 
 instance Has k r Nothing => Knock k r () where
     {-# INLINE knock #-}
@@ -220,9 +220,9 @@ instance Access r k a => Knock k r a where
 
 class Update r k a | r k -> a where
     -- | Write to a record's field
-    write :: Key k -> w a  -> RecordT w r -> RecordT w r
+    write :: Key k -> Wrap w a  -> RecordT w r -> RecordT w r
     -- | Update a record's field
-    alter :: Key k -> (w a -> w a) -> RecordT w r -> RecordT 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 #-}
@@ -242,7 +242,15 @@ instance Update xs k a => Update (k0 := a0 ': xs) k a where
 class Box w m r wm | w m -> wm where
     -- | "Box" every element of a record.
     -- Usually means applying a newtype wrapper to everything
-    box :: (forall a. m a -> w (m a)) -> RecordT m r -> RecordT wm r
+    box :: (forall a. Wrap m a -> w (Wrap m a)) -> RecordT m r -> RecordT wm r
+
+instance Box w Pure '[] w where
+    {-# INLINE box #-}
+    box _ _ = nil
+
+instance Box w Pure xs w => Box w Pure (x ': xs) w where
+    {-# INLINE box #-}
+    box f (C x xs) = C (f x) (box f xs)
 
 -- Compositions of the record wrapper types
 instance Box w m '[] (w :.: m) where
@@ -251,7 +259,8 @@ instance Box w m '[] (w :.: m) where
 
 instance Box (w :: * -> *) (m :: * -> *) xs (w :.: m) => Box w m (x ': xs) (w :.: m) where
     {-# INLINE box #-}
-    box f (C x xs) = Wmx (f x) & box f xs
+    box f (C x xs) = C (Wmx (f x)) (box f xs)
+
 
 class Transform r where
     -- | Change the type wrapping every element of a record
@@ -276,7 +285,7 @@ instance Run '[] where
 
 instance Run xs => Run (x ': xs) where
     {-# INLINE run #-}
-    run (C x xs) = liftM2 (&) x (run xs)
+    run (C x xs) = liftM2 C x (run xs)
 
 class Runtrans r where
     -- | Iterate over every element of a record. Logically similar to @ run . transform f @, but
@@ -289,7 +298,7 @@ instance Runtrans '[] where
 
 instance Runtrans xs => Runtrans (x ': xs) where
     {-# INLINE runtrans #-}
-    runtrans f (C x xs) = liftM2 (&) (f x) (runtrans f xs)
+    runtrans f (C x xs) = liftM2 C (f x) (runtrans f xs)
 
 class Transrun r where
     transrun :: Monad m => (forall a. a -> m (w a)) -> Record r -> m (RecordT w r)
@@ -300,7 +309,7 @@ instance Transrun '[] where
 
 instance Transrun xs => Transrun (x ': xs) where
     {-# INLINE transrun #-}
-    transrun f (C x xs) = liftM2 C (f (runIdentity x)) (transrun f xs)
+    transrun f (C x xs) = liftM2 C (f x) (transrun f xs)
 
 --------------------------------------------------------------------------------
 --  Unions
@@ -337,7 +346,7 @@ instance Union '[] a where
 
 instance (AllUnique xs ys, Union xs ys) => Union (x ': xs) ys where
     {-# INLINE union #-}
-    union (C x xs) ys = x & union xs ys
+    union (C x xs) ys = C x (union xs ys)
 
 --------------------------------------------------------------------------------
 --  Convenience QuasiQuoters