module Data.Extensible.Record (
module Data.Extensible.Inclusion
, Record
, (<:)
, (<:*)
, (:*)(Nil)
, (@=)
, (<@=>)
, mkField
, Field(..)
, getField
, FieldLens
, FieldName
, Labelable(..)
, LabelPhantom
) where
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
data Field kv where
Field :: v -> Field (k ':> v)
getField :: Field (k ':> v) -> v
getField (Field v) = v
type Record = (:*) 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 FieldLens k = forall f p xs v. (Functor f, Labelable k p, Associate k v xs)
=> p v (f v) -> Record xs -> f (Record xs)
type FieldName k = forall v. LabelPhantom k v (Proxy v)
-> Record '[k ':> v] -> Proxy (Record '[k ':> v])
data LabelPhantom s a b
class Labelable s p where
unlabel :: proxy s -> p a b -> a -> b
instance Labelable s (->) where
unlabel _ = id
instance (s ~ t) => Labelable s (LabelPhantom t) where
unlabel _ = 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 <@=>
type Assoc_ a b = a ':> b
mkField :: String -> DecsQ
mkField str = fmap concat $ forM (words str) $ \s -> do
f <- newName "f"
let st = litT (strTyLit s)
let vt = varT (mkName "v")
let fcon = sigE (conE 'Field) $ forallT [PlainTV $ mkName "v"] (return []) $ arrowT `appT` vt `appT` (conT ''Field `appT` (conT ''Assoc_ `appT` st `appT` vt))
let lbl = conE 'Proxy `sigE` (conT ''Proxy `appT` st)
let wf = varE '(.) `appE` (varE 'fmap `appE` fcon)
`appE` (varE '(.) `appE` (varE 'unlabel `appE` lbl `appE` varE f) `appE` varE 'getField)
sequence [sigD (mkName s) $ conT ''FieldLens `appT` st
, funD (mkName s) [clause [varP f] (normalB $ varE 'sectorAssoc `appE` wf) []]
, return $ PragmaD $ InlineP (mkName s) Inline FunLike AllPhases
]