#if __GLASGOW_HASKELL__ >= 800
#endif
module Data.Extensible.Field (
Field(..)
, (@=)
, (<@=>)
, (@:>)
, FieldOptic
, FieldName
, RecordOf
, Record
, emptyRecord
, VariantOf
, Variant
, matchWithField
, matchField
, AssocKey
, AssocValue
, KeyValue
, proxyAssocKey
, LabelPhantom
, Labelling
, Inextensible
) where
import Data.Extensible.Class
import Data.Extensible.Sum
import Data.Extensible.Match
import Data.Extensible.Product
import Data.Extensible.Internal
import Data.Extensible.Internal.Rig
import Data.Profunctor.Unsafe
import Data.Constraint
import Data.Extensible.Wrapper
import Data.Functor.Identity
import GHC.TypeLits hiding (Nat)
type family AssocKey (kv :: Assoc k v) :: k where
AssocKey (k ':> v) = k
proxyAssocKey :: proxy kv -> Proxy (AssocKey kv)
proxyAssocKey _ = Proxy
type family AssocValue (kv :: Assoc k v) :: v where
AssocValue (k ':> v) = v
class (pk (AssocKey kv), pv (AssocValue kv)) => KeyValue pk pv kv where
instance (pk k, pv v) => KeyValue pk pv (k ':> v)
newtype Field (h :: v -> *) (kv :: Assoc k v) = Field { getField :: h (AssocValue kv) }
instance Wrapper h => Wrapper (Field h) where
type Repr (Field h) kv = Repr h (AssocValue kv)
_Wrapper = dimap getField (fmap Field) . _Wrapper
instance (KnownSymbol k, Wrapper h, Show (Repr h v)) => Show (Field h (k ':> v)) where
showsPrec d (Field a) = showParen (d >= 1) $ showString (symbolVal (Proxy :: Proxy k))
. showString " @= "
. showsPrec 1 (view _Wrapper a)
instance Monoid (h (AssocValue kv)) => Monoid (Field h kv) where
mempty = Field mempty
Field a `mappend` Field b = Field (mappend a b)
type RecordOf h = (:*) (Field h)
type VariantOf h = (:|) (Field h)
type Record = RecordOf Identity
type Variant = VariantOf Identity
emptyRecord :: Record '[]
emptyRecord = Nil
matchWithField :: (forall x. f x -> g x -> r) -> RecordOf f xs -> VariantOf g xs -> r
matchWithField h = matchWith (\(Field x) (Field y) -> h x y)
matchField :: RecordOf (Match h r) xs -> VariantOf h xs -> r
matchField = matchWithField runMatch
#if __GLASGOW_HASKELL__ >= 800
type FieldOptic k = forall kind. forall f p t xs (h :: kind -> *) (v :: kind).
#else
type FieldOptic k = forall f p t xs (h :: kind -> *) (v :: kind).
#endif
(Extensible f p t
, Associate k v xs
, Labelling k p
, Wrapper h)
=> Optic' p f (t (Field h) xs) (Repr h v)
data Inextensible (h :: k -> *) (xs :: [k])
instance (Functor f, Profunctor p) => Extensible f p Inextensible where
pieceAt _ _ = error "Impossible"
type FieldName k = Optic' (LabelPhantom k) Proxy (Inextensible (Field Proxy) '[k ':> ()]) ()
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"
(@=) :: Wrapper h => FieldName k -> Repr h v -> Field h (k ':> v)
(@=) _ = Field #. review _Wrapper
infix 1 @=
(<@=>) :: (Functor f, Wrapper h) => FieldName k -> f (Repr h v) -> Comp f (Field h) (k ':> v)
(<@=>) k = Comp #. fmap (k @=)
infix 1 <@=>
(@:>) :: FieldName k -> h v -> Field h (k ':> v)
(@:>) _ = Field
infix 1 @:>