module Data.Extensible.Record (
module Data.Extensible.Class
, module Data.Extensible.Inclusion
, (@=)
, (<@=>)
, mkField
, Field(..)
, getField
, FieldOptic
, FieldName
, fieldOptic
, Record
, (<:)
, (:*)(Nil)
, Variant
, LabelPhantom
, Labelling
) where
import Data.Extensible.Class
import Data.Extensible.Sum
import Data.Extensible.Product
import Data.Extensible.Internal
import Data.Extensible.Internal.Rig
import Language.Haskell.TH
import GHC.TypeLits hiding (Nat)
import Data.Extensible.Inclusion
import Data.Extensible.Dictionary ()
import Control.Monad
import Data.Profunctor
import Data.Constraint
data Field kv where
Field :: v -> Field (k ':> v)
getField :: Field (k ':> v) -> v
getField (Field v) = v
type Record = (:*) Field
type Variant = (:|) Field
instance (KnownSymbol k, Show v) => Show (Field (k ':> v)) where
showsPrec d (Field a) = showParen (d >= 1) $ showString (symbolVal (Proxy :: Proxy k))
. showString " @= "
. showsPrec 1 a
type FieldOptic k = forall f p q t xs v. (Functor f
, Profunctor p
, Extensible f p q t
, Associate k v xs
, Labelling k p)
=> p v (f v) -> q (t Field xs) (f (t Field xs))
type FieldName k = forall v. LabelPhantom k v (Proxy v)
-> Record '[k ':> v] -> Proxy (Record '[k ':> v])
type family Labelling s p :: Constraint where
Labelling s (LabelPhantom t) = s ~ t
Labelling s p = ()
data LabelPhantom s a b
instance Profunctor (LabelPhantom s) where
dimap _ _ _ = error "Impossible"
instance Extensible f (LabelPhantom s) q t where
pieceAt _ _ = error "Impossible"
(@=) :: FieldName k -> v -> Field (k ':> v)
(@=) _ = Field
infix 1 @=
(<@=>) :: Functor f => FieldName k -> f v -> Comp f Field (k ':> v)
(<@=>) _ = comp Field
infix 1 <@=>
fieldOptic :: forall proxy k. proxy k -> FieldOptic k
fieldOptic _ = pieceAssoc . dimap getField (fmap (Field :: v -> Field (k ':> v)))
mkField :: String -> DecsQ
mkField str = fmap concat $ forM (words str) $ \s -> do
let st = litT (strTyLit s)
let lbl = conE 'Proxy `sigE` (conT ''Proxy `appT` st)
sequence [sigD (mkName s) $ conT ''FieldOptic `appT` st
, valD (varP (mkName s)) (normalB $ varE 'fieldOptic `appE` lbl) []
, return $ PragmaD $ InlineP (mkName s) Inline FunLike AllPhases
]