module Data.Extensible.Record (
module Data.Extensible.Inclusion
, Record
, (<:)
, (<:*)
, (:*)(Nil)
, (@=)
, (<@=>)
, mkField
, recordType
, Field(..)
, FieldValue
, FieldLens
, FieldName
, Labelable(..)
, LabelPhantom
) where
import Data.Extensible.Product
import Data.Extensible.Internal
import Data.Extensible.Internal.Rig
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import GHC.TypeLits hiding (Nat)
import Data.Extensible.Inclusion
import Data.Extensible.Dictionary ()
type family FieldValue (s :: Symbol) :: *
data Field (s :: Symbol) = Field { getField :: FieldValue s }
type Record = (:*) Field
instance (KnownSymbol s, Show (FieldValue s)) => Show (Field s) where
showsPrec d f@(Field a) = showParen (d >= 1) $ showString (symbolVal f)
. showString " @= "
. showsPrec 1 a
type FieldLens s = forall f p xs. (Functor f, Labelable s p, s ∈ xs)
=> p (FieldValue s) (f (FieldValue s)) -> Record xs -> f (Record xs)
type FieldName s = LabelPhantom s (FieldValue s) (Proxy (FieldValue s))
-> Record '[s] -> Proxy (Record '[s])
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 s -> FieldValue s -> Field s
(@=) _ = Field
infix 1 @=
(<@=>) :: Functor f => FieldName s -> f (FieldValue s) -> Comp f Field s
(<@=>) _ = comp Field
infix 1 <@=>
mkField :: String -> TypeQ -> DecsQ
mkField s t = do
f <- newName "f"
let st = litT (strTyLit s)
let vt = conT ''FieldValue `appT` st
let fcon = sigE (conE 'Field) $ arrowT `appT` vt `appT` (conT ''Field `appT` st)
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 [tySynInstD ''FieldValue (tySynEqn [litT (strTyLit s)] t)
, sigD (mkName s)
$ conT ''FieldLens `appT` st
, funD (mkName s) [clause [varP f] (normalB $ varE 'sector `appE` wf) []]
, return $ PragmaD $ InlineP (mkName s) Inline FunLike AllPhases
]
recordType :: QuasiQuoter
recordType = QuasiQuoter { quoteType = appT (conT ''Record) . foldr (\e t -> promotedConsT `appT` e `appT` t)
promotedNilT . map (litT . strTyLit) . words
, quoteDec = error "Unsupported"
, quoteExp = error "Unsupported"
, quotePat = error "Unsupported" }