#if __GLASGOW_HASKELL__ >= 800
#endif
module Data.Extensible.Field (
Field(..)
, (@=)
, (<@=>)
, (@:>)
, (@==)
, FieldOptic
, FieldName
, liftField
, liftField2
, RecordOf
, Record
, emptyRecord
, VariantOf
, Variant
, matchWithField
, matchField
, AssocKey
, AssocValue
, KeyValue
, proxyAssocKey
, LabelPhantom
, Labelling
, Inextensible
) where
import Control.DeepSeq (NFData)
import Data.Coerce
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 Data.Semigroup
import Data.Typeable (Typeable)
import Foreign.Storable (Storable)
import GHC.Generics (Generic)
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) }
deriving (Typeable, Generic)
#define ND_Field(c) deriving instance c (h (AssocValue kv)) => c (Field h kv)
ND_Field(Eq)
ND_Field(Ord)
ND_Field(Num)
ND_Field(Integral)
ND_Field(Fractional)
ND_Field(Floating)
ND_Field(Real)
ND_Field(RealFloat)
ND_Field(RealFrac)
ND_Field(Semigroup)
ND_Field(Storable)
ND_Field(Monoid)
ND_Field(Enum)
ND_Field(Bounded)
ND_Field(NFData)
liftField :: (g (AssocValue kv) -> h (AssocValue kv)) -> Field g kv -> Field h kv
liftField = coerce
liftField2 :: (f (AssocValue kv) -> g (AssocValue kv) -> h (AssocValue kv))
-> Field f kv -> Field g kv -> Field h kv
liftField2 = coerce
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)
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 (k @=)
infix 1 <@=>
(@:>) :: FieldName k -> h v -> Field h (k ':> v)
(@:>) _ = Field
infix 1 @:>
(@==) :: FieldName (k :: Symbol) -> v -> Field Identity (k ':> v)
(@==) = (@=)
infix 1 @==