{-# LANGUAGE MultiParamTypeClasses, UndecidableInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ScopedTypeVariables, TypeFamilies #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableSuperClasses, TypeInType #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Extensible.Field
-- Copyright   :  (c) Fumiaki Kinoshita 2018
-- License     :  BSD3
--
-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
--
-- Flexible records and variants
------------------------------------------------------------------------
module Data.Extensible.Field (
  Field(..)
  , (@=)
  , (<@=>)
  , (@:>)
  , (@==)
  , FieldOptic
  , FieldName
  , liftField
  , liftField2
  -- * Records and variants
  , RecordOf
  , Record
  , emptyRecord
  , VariantOf
  , Variant
  -- * Matching
  , matchWithField
  , matchField
  -- * Key / value
  , KeyOf
  , proxyKeyOf
  , stringKeyOf
  , TargetOf
  , proxyTargetOf
  , KeyIs
  , TargetIs
  , KeyTargetAre
  -- * deprecated
  , AssocKey
  , AssocValue
  , ValueIs
  , KeyValue
  , proxyAssocKey
  , stringAssocKey
  , proxyAssocValue
  -- * Internal
  , LabelPhantom
  , Labelling
  , Inextensible
  ) where
import Control.DeepSeq (NFData)
import qualified Data.Aeson as J
import Data.Coerce
#if __GLASGOW_HASKELL__ < 802
import Data.Constraint
#endif
#ifdef CASSAVA
import qualified Data.Csv as Csv
#endif
import Data.Extensible.Class
import Data.Extensible.Sum
import Data.Extensible.Match
import Data.Extensible.Product
import Data.Extensible.Internal.Rig
import Data.Kind
import Data.Profunctor.Unsafe
import Data.Extensible.Wrapper
import Data.Functor.Identity
import Data.Hashable
import Data.String
import Data.Text.Prettyprint.Doc
import qualified Data.Vector.Generic as G
import qualified Data.Vector.Generic.Mutable as M
import qualified Data.Vector.Unboxed as U
import Foreign.Storable (Storable)
import GHC.Generics (Generic)
import GHC.TypeLits hiding (Nat)
import Language.Haskell.TH.Lift
import Language.Haskell.TH (appE, conE)
import Test.QuickCheck.Arbitrary
import Type.Membership

-- | A @'Field' h (k ':> v)@ is @h v@ annotated with the field name @k@.
--
-- @'Field' :: (v -> *) -> Assoc k v -> *@
--
newtype Field (h :: v -> Type) (kv :: Assoc k v)
  = Field { Field h kv -> h (TargetOf kv)
getField :: h (TargetOf kv) }

  deriving ((forall x. Field h kv -> Rep (Field h kv) x)
-> (forall x. Rep (Field h kv) x -> Field h kv)
-> Generic (Field h kv)
forall x. Rep (Field h kv) x -> Field h kv
forall x. Field h kv -> Rep (Field h kv) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall v (h :: v -> *) k (kv :: Assoc k v) x.
Rep (Field h kv) x -> Field h kv
forall v (h :: v -> *) k (kv :: Assoc k v) x.
Field h kv -> Rep (Field h kv) x
$cto :: forall v (h :: v -> *) k (kv :: Assoc k v) x.
Rep (Field h kv) x -> Field h kv
$cfrom :: forall v (h :: v -> *) k (kv :: Assoc k v) x.
Field h kv -> Rep (Field h kv) x
Generic)

#define ND_Field(c) deriving instance c (h (TargetOf 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)
ND_Field(Arbitrary)
ND_Field(Hashable)
ND_Field(J.FromJSON)
ND_Field(J.ToJSON)
#ifdef CASSAVA
ND_Field(Csv.FromField)
ND_Field(Csv.ToField)
#endif

newtype instance U.MVector s (Field h x) = MV_Field (U.MVector s (h (TargetOf x)))
newtype instance U.Vector (Field h x) = V_Field (U.Vector (h (TargetOf x)))

instance (U.Unbox (h (TargetOf x))) => M.MVector U.MVector (Field h x) where
  {-# INLINE basicLength #-}
  {-# INLINE basicUnsafeSlice #-}
  {-# INLINE basicOverlaps #-}
  {-# INLINE basicUnsafeNew #-}
  {-# INLINE basicUnsafeReplicate #-}
  {-# INLINE basicUnsafeRead #-}
  {-# INLINE basicUnsafeWrite #-}
  {-# INLINE basicClear #-}
  {-# INLINE basicSet #-}
  {-# INLINE basicUnsafeCopy #-}
  {-# INLINE basicUnsafeGrow #-}
  basicLength :: MVector s (Field h x) -> Int
basicLength (MV_Field v) = MVector s (h (TargetOf x)) -> Int
forall (v :: * -> * -> *) a s. MVector v a => v s a -> Int
M.basicLength MVector s (h (TargetOf x))
v
  basicUnsafeSlice :: Int -> Int -> MVector s (Field h x) -> MVector s (Field h x)
basicUnsafeSlice i :: Int
i n :: Int
n (MV_Field v) = MVector s (h (TargetOf x)) -> MVector s (Field h x)
forall v k s (h :: v -> *) (x :: Assoc k v).
MVector s (h (TargetOf x)) -> MVector s (Field h x)
MV_Field (MVector s (h (TargetOf x)) -> MVector s (Field h x))
-> MVector s (h (TargetOf x)) -> MVector s (Field h x)
forall a b. (a -> b) -> a -> b
$ Int
-> Int -> MVector s (h (TargetOf x)) -> MVector s (h (TargetOf x))
forall (v :: * -> * -> *) a s.
MVector v a =>
Int -> Int -> v s a -> v s a
M.basicUnsafeSlice Int
i Int
n MVector s (h (TargetOf x))
v
  basicOverlaps :: MVector s (Field h x) -> MVector s (Field h x) -> Bool
basicOverlaps (MV_Field v1) (MV_Field v2) = MVector s (h (TargetOf x)) -> MVector s (h (TargetOf x)) -> Bool
forall (v :: * -> * -> *) a s.
MVector v a =>
v s a -> v s a -> Bool
M.basicOverlaps MVector s (h (TargetOf x))
v1 MVector s (h (TargetOf x))
v2
  basicUnsafeNew :: Int -> m (MVector (PrimState m) (Field h x))
basicUnsafeNew n :: Int
n = MVector (PrimState m) (h (TargetOf x))
-> MVector (PrimState m) (Field h x)
forall v k s (h :: v -> *) (x :: Assoc k v).
MVector s (h (TargetOf x)) -> MVector s (Field h x)
MV_Field (MVector (PrimState m) (h (TargetOf x))
 -> MVector (PrimState m) (Field h x))
-> m (MVector (PrimState m) (h (TargetOf x)))
-> m (MVector (PrimState m) (Field h x))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> m (MVector (PrimState m) (h (TargetOf x)))
forall (v :: * -> * -> *) a (m :: * -> *).
(MVector v a, PrimMonad m) =>
Int -> m (v (PrimState m) a)
M.basicUnsafeNew Int
n
#if MIN_VERSION_vector(0,11,0)
  basicInitialize :: MVector (PrimState m) (Field h x) -> m ()
basicInitialize (MV_Field v) = MVector (PrimState m) (h (TargetOf x)) -> m ()
forall (v :: * -> * -> *) a (m :: * -> *).
(MVector v a, PrimMonad m) =>
v (PrimState m) a -> m ()
M.basicInitialize MVector (PrimState m) (h (TargetOf x))
v
  {-# INLINE basicInitialize #-}
#endif
  basicUnsafeReplicate :: Int -> Field h x -> m (MVector (PrimState m) (Field h x))
basicUnsafeReplicate n :: Int
n (Field x :: h (TargetOf x)
x) = MVector (PrimState m) (h (TargetOf x))
-> MVector (PrimState m) (Field h x)
forall v k s (h :: v -> *) (x :: Assoc k v).
MVector s (h (TargetOf x)) -> MVector s (Field h x)
MV_Field (MVector (PrimState m) (h (TargetOf x))
 -> MVector (PrimState m) (Field h x))
-> m (MVector (PrimState m) (h (TargetOf x)))
-> m (MVector (PrimState m) (Field h x))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> h (TargetOf x) -> m (MVector (PrimState m) (h (TargetOf x)))
forall (v :: * -> * -> *) a (m :: * -> *).
(MVector v a, PrimMonad m) =>
Int -> a -> m (v (PrimState m) a)
M.basicUnsafeReplicate Int
n h (TargetOf x)
x
  basicUnsafeRead :: MVector (PrimState m) (Field h x) -> Int -> m (Field h x)
basicUnsafeRead (MV_Field v) i :: Int
i = h (TargetOf x) -> Field h x
forall v k (h :: v -> *) (kv :: Assoc k v).
h (TargetOf kv) -> Field h kv
Field (h (TargetOf x) -> Field h x)
-> m (h (TargetOf x)) -> m (Field h x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVector (PrimState m) (h (TargetOf x)) -> Int -> m (h (TargetOf x))
forall (v :: * -> * -> *) a (m :: * -> *).
(MVector v a, PrimMonad m) =>
v (PrimState m) a -> Int -> m a
M.basicUnsafeRead MVector (PrimState m) (h (TargetOf x))
v Int
i
  basicUnsafeWrite :: MVector (PrimState m) (Field h x) -> Int -> Field h x -> m ()
basicUnsafeWrite (MV_Field v) i :: Int
i (Field x :: h (TargetOf x)
x) = MVector (PrimState m) (h (TargetOf x))
-> Int -> h (TargetOf x) -> m ()
forall (v :: * -> * -> *) a (m :: * -> *).
(MVector v a, PrimMonad m) =>
v (PrimState m) a -> Int -> a -> m ()
M.basicUnsafeWrite MVector (PrimState m) (h (TargetOf x))
v Int
i h (TargetOf x)
x
  basicClear :: MVector (PrimState m) (Field h x) -> m ()
basicClear (MV_Field v) = MVector (PrimState m) (h (TargetOf x)) -> m ()
forall (v :: * -> * -> *) a (m :: * -> *).
(MVector v a, PrimMonad m) =>
v (PrimState m) a -> m ()
M.basicClear MVector (PrimState m) (h (TargetOf x))
v
  basicSet :: MVector (PrimState m) (Field h x) -> Field h x -> m ()
basicSet (MV_Field v) (Field x :: h (TargetOf x)
x) = MVector (PrimState m) (h (TargetOf x)) -> h (TargetOf x) -> m ()
forall (v :: * -> * -> *) a (m :: * -> *).
(MVector v a, PrimMonad m) =>
v (PrimState m) a -> a -> m ()
M.basicSet MVector (PrimState m) (h (TargetOf x))
v h (TargetOf x)
x
  basicUnsafeCopy :: MVector (PrimState m) (Field h x)
-> MVector (PrimState m) (Field h x) -> m ()
basicUnsafeCopy (MV_Field v1) (MV_Field v2) = MVector (PrimState m) (h (TargetOf x))
-> MVector (PrimState m) (h (TargetOf x)) -> m ()
forall (v :: * -> * -> *) a (m :: * -> *).
(MVector v a, PrimMonad m) =>
v (PrimState m) a -> v (PrimState m) a -> m ()
M.basicUnsafeCopy MVector (PrimState m) (h (TargetOf x))
v1 MVector (PrimState m) (h (TargetOf x))
v2
  basicUnsafeMove :: MVector (PrimState m) (Field h x)
-> MVector (PrimState m) (Field h x) -> m ()
basicUnsafeMove (MV_Field v1) (MV_Field v2) = MVector (PrimState m) (h (TargetOf x))
-> MVector (PrimState m) (h (TargetOf x)) -> m ()
forall (v :: * -> * -> *) a (m :: * -> *).
(MVector v a, PrimMonad m) =>
v (PrimState m) a -> v (PrimState m) a -> m ()
M.basicUnsafeMove MVector (PrimState m) (h (TargetOf x))
v1 MVector (PrimState m) (h (TargetOf x))
v2
  basicUnsafeGrow :: MVector (PrimState m) (Field h x)
-> Int -> m (MVector (PrimState m) (Field h x))
basicUnsafeGrow (MV_Field v) n :: Int
n = MVector (PrimState m) (h (TargetOf x))
-> MVector (PrimState m) (Field h x)
forall v k s (h :: v -> *) (x :: Assoc k v).
MVector s (h (TargetOf x)) -> MVector s (Field h x)
MV_Field (MVector (PrimState m) (h (TargetOf x))
 -> MVector (PrimState m) (Field h x))
-> m (MVector (PrimState m) (h (TargetOf x)))
-> m (MVector (PrimState m) (Field h x))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVector (PrimState m) (h (TargetOf x))
-> Int -> m (MVector (PrimState m) (h (TargetOf x)))
forall (v :: * -> * -> *) a (m :: * -> *).
(MVector v a, PrimMonad m) =>
v (PrimState m) a -> Int -> m (v (PrimState m) a)
M.basicUnsafeGrow MVector (PrimState m) (h (TargetOf x))
v Int
n

instance (U.Unbox (h (TargetOf x))) => G.Vector U.Vector (Field h x) where
  {-# INLINE basicUnsafeFreeze #-}
  {-# INLINE basicUnsafeThaw #-}
  {-# INLINE basicLength #-}
  {-# INLINE basicUnsafeSlice #-}
  {-# INLINE basicUnsafeIndexM #-}
  basicUnsafeFreeze :: Mutable Vector (PrimState m) (Field h x) -> m (Vector (Field h x))
basicUnsafeFreeze (MV_Field v) = Vector (h (TargetOf x)) -> Vector (Field h x)
forall v k (h :: v -> *) (x :: Assoc k v).
Vector (h (TargetOf x)) -> Vector (Field h x)
V_Field (Vector (h (TargetOf x)) -> Vector (Field h x))
-> m (Vector (h (TargetOf x))) -> m (Vector (Field h x))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mutable Vector (PrimState m) (h (TargetOf x))
-> m (Vector (h (TargetOf x)))
forall (v :: * -> *) a (m :: * -> *).
(Vector v a, PrimMonad m) =>
Mutable v (PrimState m) a -> m (v a)
G.basicUnsafeFreeze Mutable Vector (PrimState m) (h (TargetOf x))
MVector (PrimState m) (h (TargetOf x))
v
  basicUnsafeThaw :: Vector (Field h x) -> m (Mutable Vector (PrimState m) (Field h x))
basicUnsafeThaw (V_Field v) = MVector (PrimState m) (h (TargetOf x))
-> MVector (PrimState m) (Field h x)
forall v k s (h :: v -> *) (x :: Assoc k v).
MVector s (h (TargetOf x)) -> MVector s (Field h x)
MV_Field (MVector (PrimState m) (h (TargetOf x))
 -> MVector (PrimState m) (Field h x))
-> m (MVector (PrimState m) (h (TargetOf x)))
-> m (MVector (PrimState m) (Field h x))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector (h (TargetOf x))
-> m (Mutable Vector (PrimState m) (h (TargetOf x)))
forall (v :: * -> *) a (m :: * -> *).
(Vector v a, PrimMonad m) =>
v a -> m (Mutable v (PrimState m) a)
G.basicUnsafeThaw Vector (h (TargetOf x))
v
  basicLength :: Vector (Field h x) -> Int
basicLength (V_Field v) = Vector (h (TargetOf x)) -> Int
forall (v :: * -> *) a. Vector v a => v a -> Int
G.basicLength Vector (h (TargetOf x))
v
  basicUnsafeSlice :: Int -> Int -> Vector (Field h x) -> Vector (Field h x)
basicUnsafeSlice i :: Int
i n :: Int
n (V_Field v) = Vector (h (TargetOf x)) -> Vector (Field h x)
forall v k (h :: v -> *) (x :: Assoc k v).
Vector (h (TargetOf x)) -> Vector (Field h x)
V_Field (Vector (h (TargetOf x)) -> Vector (Field h x))
-> Vector (h (TargetOf x)) -> Vector (Field h x)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Vector (h (TargetOf x)) -> Vector (h (TargetOf x))
forall (v :: * -> *) a. Vector v a => Int -> Int -> v a -> v a
G.basicUnsafeSlice Int
i Int
n Vector (h (TargetOf x))
v
  basicUnsafeIndexM :: Vector (Field h x) -> Int -> m (Field h x)
basicUnsafeIndexM (V_Field v) i :: Int
i = h (TargetOf x) -> Field h x
forall v k (h :: v -> *) (kv :: Assoc k v).
h (TargetOf kv) -> Field h kv
Field (h (TargetOf x) -> Field h x)
-> m (h (TargetOf x)) -> m (Field h x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector (h (TargetOf x)) -> Int -> m (h (TargetOf x))
forall (v :: * -> *) a (m :: * -> *).
(Vector v a, Monad m) =>
v a -> Int -> m a
G.basicUnsafeIndexM Vector (h (TargetOf x))
v Int
i
  basicUnsafeCopy :: Mutable Vector (PrimState m) (Field h x)
-> Vector (Field h x) -> m ()
basicUnsafeCopy (MV_Field mv) (V_Field v) = Mutable Vector (PrimState m) (h (TargetOf x))
-> Vector (h (TargetOf x)) -> m ()
forall (v :: * -> *) a (m :: * -> *).
(Vector v a, PrimMonad m) =>
Mutable v (PrimState m) a -> v a -> m ()
G.basicUnsafeCopy Mutable Vector (PrimState m) (h (TargetOf x))
MVector (PrimState m) (h (TargetOf x))
mv Vector (h (TargetOf x))
v

instance (U.Unbox (h (TargetOf x))) => U.Unbox (Field h x)

instance Lift (h (TargetOf x)) => Lift (Field h x) where
  lift :: Field h x -> Q Exp
lift = Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
conE 'Field) (Q Exp -> Q Exp) -> (Field h x -> Q Exp) -> Field h x -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. h (TargetOf x) -> Q Exp
forall t. Lift t => t -> Q Exp
lift (h (TargetOf x) -> Q Exp)
-> (Field h x -> h (TargetOf x)) -> Field h x -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field h x -> h (TargetOf x)
forall v (h :: v -> *) k (kv :: Assoc k v).
Field h kv -> h (TargetOf kv)
getField

-- | Lift a function for the content.
liftField :: (g (TargetOf kv) -> h (TargetOf kv)) -> Field g kv -> Field h kv
liftField :: (g (TargetOf kv) -> h (TargetOf kv)) -> Field g kv -> Field h kv
liftField = (g (TargetOf kv) -> h (TargetOf kv)) -> Field g kv -> Field h kv
forall a b. Coercible a b => a -> b
coerce
{-# INLINE liftField #-}

-- | Lift a function for the content.
liftField2 :: (f (TargetOf kv) -> g (TargetOf kv) -> h (TargetOf kv))
    -> Field f kv -> Field g kv -> Field h kv
liftField2 :: (f (TargetOf kv) -> g (TargetOf kv) -> h (TargetOf kv))
-> Field f kv -> Field g kv -> Field h kv
liftField2 = (f (TargetOf kv) -> g (TargetOf kv) -> h (TargetOf kv))
-> Field f kv -> Field g kv -> Field h kv
forall a b. Coercible a b => a -> b
coerce
{-# INLINE liftField2 #-}

instance Wrapper h => Wrapper (Field h) where
  type Repr (Field h) kv = Repr h (TargetOf kv)
  _Wrapper :: Optic' p f (Field h v) (Repr (Field h) v)
_Wrapper = (Field h v -> h (TargetOf v))
-> (f (h (TargetOf v)) -> f (Field h v))
-> p (h (TargetOf v)) (f (h (TargetOf v)))
-> p (Field h v) (f (Field h v))
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap Field h v -> h (TargetOf v)
forall v (h :: v -> *) k (kv :: Assoc k v).
Field h kv -> h (TargetOf kv)
getField ((h (TargetOf v) -> Field h v)
-> f (h (TargetOf v)) -> f (Field h v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap h (TargetOf v) -> Field h v
forall v k (h :: v -> *) (kv :: Assoc k v).
h (TargetOf kv) -> Field h kv
Field) (p (h (TargetOf v)) (f (h (TargetOf v)))
 -> p (Field h v) (f (Field h v)))
-> (p (Repr h (TargetOf v)) (f (Repr h (TargetOf v)))
    -> p (h (TargetOf v)) (f (h (TargetOf v))))
-> p (Repr h (TargetOf v)) (f (Repr h (TargetOf v)))
-> p (Field h v) (f (Field h v))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p (Repr h (TargetOf v)) (f (Repr h (TargetOf v)))
-> p (h (TargetOf v)) (f (h (TargetOf v)))
forall k (h :: k -> *) (f :: * -> *) (p :: * -> * -> *) (v :: k).
(Wrapper h, Functor f, Profunctor p) =>
Optic' p f (h v) (Repr h v)
_Wrapper
  {-# INLINE _Wrapper #-}

-- | Shows in @field \@= value@ style instead of the derived one.
instance (KnownSymbol k, Wrapper h, Show (Repr h v)) => Show (Field h (k ':> v)) where
  showsPrec :: Int -> Field h (k ':> v) -> ShowS
showsPrec d :: Int
d (Field a :: h (TargetOf (k ':> v))
a) = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 1) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString (Proxy k -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy k
forall k (t :: k). Proxy t
Proxy :: Proxy k))
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString " @= "
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Repr h v -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec 1 (Optic' (->) (Const (Repr h v)) (h v) (Repr h v) -> h v -> Repr h v
forall a s. Optic' (->) (Const a) s a -> s -> a
view Optic' (->) (Const (Repr h v)) (h v) (Repr h v)
forall k (h :: k -> *) (f :: * -> *) (p :: * -> * -> *) (v :: k).
(Wrapper h, Functor f, Profunctor p) =>
Optic' p f (h v) (Repr h v)
_Wrapper h v
h (TargetOf (k ':> v))
a)

instance (KnownSymbol k, Pretty (h v)) => Pretty (Field h (k ':> v)) where
  pretty :: Field h (k ':> v) -> Doc ann
pretty (Field a :: h (TargetOf (k ':> v))
a) = String -> Doc ann
forall a. IsString a => String -> a
fromString (Proxy k -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy k
forall k (t :: k). Proxy t
Proxy :: Proxy k))
    Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> ": "
    Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> h v -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty h v
h (TargetOf (k ':> v))
a

-- | The type of records which contain several fields.
--
-- @RecordOf :: (v -> *) -> [Assoc k v] -> *@
--
type RecordOf h xs = xs :& Field h

-- | The dual of 'RecordOf'
--
-- @VariantOf :: (v -> *) -> [Assoc k v] -> *@
--
type VariantOf h xs = xs :/ Field h

-- | Simple record
type Record xs = RecordOf Identity xs

-- | Simple variant
type Variant xs = VariantOf Identity xs

-- | An empty 'Record'.
emptyRecord :: Record '[]
emptyRecord :: Record '[]
emptyRecord = Record '[]
forall k (h :: k -> *). '[] :& h
nil
{-# INLINE emptyRecord #-}

-- | Select a corresponding field of a variant.
matchWithField :: (forall x. f x -> g x -> r) -> RecordOf f xs -> VariantOf g xs -> r
matchWithField :: (forall (x :: v). f x -> g x -> r)
-> RecordOf f xs -> VariantOf g xs -> r
matchWithField h :: forall (x :: v). f x -> g x -> r
h = (forall (x :: Assoc k v). Field f x -> Field g x -> r)
-> RecordOf f xs -> VariantOf g xs -> r
forall k (f :: k -> *) (g :: k -> *) r (xs :: [k]).
(forall (x :: k). f x -> g x -> r) -> (xs :& f) -> (xs :/ g) -> r
matchWith (\(Field x) (Field y) -> f (TargetOf x) -> g (TargetOf x) -> r
forall (x :: v). f x -> g x -> r
h f (TargetOf x)
x g (TargetOf x)
y)
{-# INLINE matchWithField #-}

-- | Pattern matching on a 'Variant'
matchField :: RecordOf (Match h r) xs -> VariantOf h xs -> r
matchField :: RecordOf (Match h r) xs -> VariantOf h xs -> r
matchField = (forall (x :: v). Match h r x -> h x -> r)
-> RecordOf (Match h r) xs -> VariantOf h xs -> r
forall v k (f :: v -> *) (g :: v -> *) r (xs :: [Assoc k v]).
(forall (x :: v). f x -> g x -> r)
-> RecordOf f xs -> VariantOf g xs -> r
matchWithField forall (x :: v). Match h r x -> h x -> r
forall k (h :: k -> *) r (x :: k). Match h r x -> h x -> r
runMatch
{-# INLINE matchField #-}

-- | @FieldOptic s@ is a type of optics that points a field/constructor named @s@.
--
-- The yielding fields can be
-- <http://hackage.haskell.org/package/lens/docs/Control-Lens-Lens.html#t:Lens Lens>es
-- for 'Record's and
-- <http://hackage.haskell.org/package/lens/docs/Control-Lens-Lens.html#t:Prism Prism>s
-- for 'Variant's.
--
-- @
-- 'FieldOptic' "foo" = Lookup xs "foo" a => Lens' ('Record' xs) a
-- 'FieldOptic' "foo" = Lookup xs "foo" a => Prism' ('Variant' xs) a
-- @
--
-- 'FieldOptic's can be generated using 'mkField' defined in the "Data.Extensible.TH" module.
--
type FieldOptic k = forall kind. forall f p t xs (h :: kind -> Type) (v :: kind).
  (Extensible f p t
  , ExtensibleConstr t xs (Field h) (k ':> v)
  , Lookup xs k v
  , Labelling k p
  , Wrapper h)
  => Optic' p f (t xs (Field h)) (Repr h v)

-- | The trivial inextensible data type
data Inextensible (xs :: [k]) (h :: k -> Type)

instance (Functor f, Profunctor p) => Extensible f p Inextensible where
  pieceAt :: Membership xs x -> Optic' p f (Inextensible xs h) (h x)
pieceAt _ _ = String -> p (Inextensible xs h) (f (Inextensible xs h))
forall a. HasCallStack => String -> a
error "Impossible"

-- | When you see this type as an argument, it expects a 'FieldLens'.
-- This type is used to resolve the name of the field internally.
type FieldName k = Optic' (LabelPhantom k) Proxy (Inextensible '[k ':> ()] (Field Proxy)) ()

-- | Signifies a field name internally
type family Labelling s p :: Constraint where
  Labelling s (LabelPhantom t) = s ~ t
  Labelling s p = ()

-- | A ghostly type which spells the field name
data LabelPhantom s a b

instance Profunctor (LabelPhantom s) where
  dimap :: (a -> b) -> (c -> d) -> LabelPhantom s b c -> LabelPhantom s a d
dimap _ _ _ = String -> LabelPhantom s a d
forall a. HasCallStack => String -> a
error "Impossible"

-- | Annotate a value by the field name.
--
-- @
-- foo :: 'Record' '["num" >: Int, "str" >: String]
-- foo = #num \@= 42
--   <: #str \@= "foo"
--   <: nil
-- @
(@=) :: Wrapper h => FieldName k -> Repr h v -> Field h (k ':> v)
@= :: FieldName k -> Repr h v -> Field h (k ':> v)
(@=) _ = h v -> Field h (k ':> v)
forall v k (h :: v -> *) (kv :: Assoc k v).
h (TargetOf kv) -> Field h kv
Field (h v -> Field h (k ':> v))
-> (Repr h v -> h v) -> Repr h v -> Field h (k ':> v)
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. Optic' Tagged Identity (h v) (Repr h v) -> Repr h v -> h v
forall s a. Optic' Tagged Identity s a -> a -> s
review Optic' Tagged Identity (h v) (Repr h v)
forall k (h :: k -> *) (f :: * -> *) (p :: * -> * -> *) (v :: k).
(Wrapper h, Functor f, Profunctor p) =>
Optic' p f (h v) (Repr h v)
_Wrapper
{-# INLINE (@=) #-}
infix 1 @=

-- | Lifted ('@=')
--
-- @
-- foo :: IO ('Record' '["num" >: Int, "str" >: String])
-- foo = hsequence
--   $ #num \<\@=\> readLn
--   <: #str \<\@=\> getLine
--   <: nil
-- @
(<@=>) :: (Functor f, Wrapper h) => FieldName k -> f (Repr h v) -> Comp f (Field h) (k ':> v)
<@=> :: FieldName k -> f (Repr h v) -> Comp f (Field h) (k ':> v)
(<@=>) k :: FieldName k
k = (Repr h v -> Field h (k ':> v))
-> f (Repr h v) -> Comp f (Field h) (k ':> v)
forall i (f :: * -> *) a (g :: i -> *) (b :: i).
Functor f =>
(a -> g b) -> f a -> Comp f g b
comp (FieldName k
k FieldName k -> Repr h v -> Field h (k ':> v)
forall v k (h :: v -> *) (k :: k) (v :: v).
Wrapper h =>
FieldName k -> Repr h v -> Field h (k ':> v)
@=)
{-# INLINE (<@=>) #-}
infix 1 <@=>

-- | Annotate a value by the field name without 'Wrapper'.
(@:>) :: FieldName k -> h v -> Field h (k ':> v)
@:> :: FieldName k -> h v -> Field h (k ':> v)
(@:>) _ = h v -> Field h (k ':> v)
forall v k (h :: v -> *) (kv :: Assoc k v).
h (TargetOf kv) -> Field h kv
Field
infix 1 @:>

-- | Kind-monomorphic, unwrapped version of '@='
(@==) :: FieldName (k :: Symbol) -> v -> Field Identity (k ':> v)
@== :: FieldName k -> v -> Field Identity (k ':> v)
(@==) = FieldName k -> v -> Field Identity (k ':> v)
forall v k (h :: v -> *) (k :: k) (v :: v).
Wrapper h =>
FieldName k -> Repr h v -> Field h (k ':> v)
(@=)
{-# INLINE (@==) #-}
infix 1 @==

type AssocKey kv = KeyOf kv
{-# DEPRECATED AssocKey "Use KeyOf instead" #-}

type AssocValue kv = TargetOf kv
{-# DEPRECATED AssocValue "Use TargetOf instead" #-}

type ValueIs = TargetIs
{-# DEPRECATED ValueIs "Use TargetIs instead" #-}

type KeyValue = KeyTargetAre
{-# DEPRECATED KeyValue "Use KeyTargetAre instead" #-}

proxyAssocKey :: proxy kv -> Proxy (KeyOf kv)
proxyAssocKey :: proxy kv -> Proxy (KeyOf kv)
proxyAssocKey = proxy kv -> Proxy (KeyOf kv)
forall k v (proxy :: Assoc k v -> *) (kv :: Assoc k v).
proxy kv -> Proxy (KeyOf kv)
proxyKeyOf
{-# INLINE proxyAssocKey #-}
{-# DEPRECATED proxyAssocKey "Use proxyKeyOf instead" #-}

proxyAssocValue :: proxy kv -> Proxy (TargetOf kv)
proxyAssocValue :: proxy kv -> Proxy (TargetOf kv)
proxyAssocValue = proxy kv -> Proxy (TargetOf kv)
forall k1 k2 (proxy :: Assoc k1 k2 -> *) (kv :: Assoc k1 k2).
proxy kv -> Proxy (TargetOf kv)
proxyTargetOf
{-# INLINE proxyAssocValue #-}
{-# DEPRECATED proxyAssocValue "Use proxyTargetOf instead" #-}

stringAssocKey :: (IsString a, KnownSymbol (KeyOf kv)) => proxy kv -> a
stringAssocKey :: proxy kv -> a
stringAssocKey = proxy kv -> a
forall v a (kv :: Assoc Symbol v) (proxy :: Assoc Symbol v -> *).
(IsString a, KnownSymbol (KeyOf kv)) =>
proxy kv -> a
stringKeyOf
{-# INLINE stringAssocKey #-}
{-# DEPRECATED stringAssocKey "Use stringKeyOf instead" #-}