{-# 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
  -- * Internal
  , LabelPhantom
  , Labelling
  , Inextensible
  ) where
import Control.DeepSeq (NFData)
import qualified Data.Aeson as J
import Data.Coerce
#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.Incremental (Incremental)
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 Test.QuickCheck.Arbitrary
import Type.Membership

-- | A @'Field' h (k ':> v)@ is @h v@ annotated with the field name @k@.
--
-- @'Field' :: (v -> Type) -> Assoc k v -> Type@
--
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 -> Type) k (kv :: Assoc k v) x.
Rep (Field h kv) x -> Field h kv
forall v (h :: v -> Type) k (kv :: Assoc k v) x.
Field h kv -> Rep (Field h kv) x
$cto :: forall v (h :: v -> Type) k (kv :: Assoc k v) x.
Rep (Field h kv) x -> Field h kv
$cfrom :: forall v (h :: v -> Type) 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
ND_Field(Incremental)
ND_Field(Lift)

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 :: Type -> Type -> Type) 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 Int
i Int
n (MV_Field v) = MVector s (h (TargetOf x)) -> MVector s (Field h x)
forall v k s (h :: v -> Type) (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 :: Type -> Type -> Type) 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 :: Type -> Type -> Type) 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 Int
n = MVector (PrimState m) (h (TargetOf x))
-> MVector (PrimState m) (Field h x)
forall v k s (h :: v -> Type) (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 :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> m (MVector (PrimState m) (h (TargetOf x)))
forall (v :: Type -> Type -> Type) a (m :: Type -> Type).
(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 :: Type -> Type -> Type) a (m :: Type -> Type).
(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 Int
n (Field h (TargetOf x)
x) = MVector (PrimState m) (h (TargetOf x))
-> MVector (PrimState m) (Field h x)
forall v k s (h :: v -> Type) (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 :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> h (TargetOf x) -> m (MVector (PrimState m) (h (TargetOf x)))
forall (v :: Type -> Type -> Type) a (m :: Type -> Type).
(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) Int
i = h (TargetOf x) -> Field h x
forall v k (h :: v -> Type) (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 :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> MVector (PrimState m) (h (TargetOf x)) -> Int -> m (h (TargetOf x))
forall (v :: Type -> Type -> Type) a (m :: Type -> Type).
(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) Int
i (Field h (TargetOf x)
x) = MVector (PrimState m) (h (TargetOf x))
-> Int -> h (TargetOf x) -> m ()
forall (v :: Type -> Type -> Type) a (m :: Type -> Type).
(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 :: Type -> Type -> Type) a (m :: Type -> Type).
(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 h (TargetOf x)
x) = MVector (PrimState m) (h (TargetOf x)) -> h (TargetOf x) -> m ()
forall (v :: Type -> Type -> Type) a (m :: Type -> Type).
(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 :: Type -> Type -> Type) a (m :: Type -> Type).
(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 :: Type -> Type -> Type) a (m :: Type -> Type).
(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) Int
n = MVector (PrimState m) (h (TargetOf x))
-> MVector (PrimState m) (Field h x)
forall v k s (h :: v -> Type) (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 :: Type -> Type) 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 :: Type -> Type -> Type) a (m :: Type -> Type).
(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 -> Type) (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 :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Mutable Vector (PrimState m) (h (TargetOf x))
-> m (Vector (h (TargetOf x)))
forall (v :: Type -> Type) a (m :: Type -> Type).
(Vector v a, PrimMonad m) =>
Mutable v (PrimState m) a -> m (v a)
G.basicUnsafeFreeze MVector (PrimState m) (h (TargetOf x))
Mutable Vector (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 -> Type) (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 :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector (h (TargetOf x))
-> m (Mutable Vector (PrimState m) (h (TargetOf x)))
forall (v :: Type -> Type) a (m :: Type -> Type).
(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 :: Type -> Type) 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 Int
i Int
n (V_Field v) = Vector (h (TargetOf x)) -> Vector (Field h x)
forall v k (h :: v -> Type) (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 :: Type -> Type) 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) Int
i = h (TargetOf x) -> Field h x
forall v k (h :: v -> Type) (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 :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector (h (TargetOf x)) -> Int -> m (h (TargetOf x))
forall (v :: Type -> Type) a (m :: Type -> Type).
(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 :: Type -> Type) a (m :: Type -> Type).
(Vector v a, PrimMonad m) =>
Mutable v (PrimState m) a -> v a -> m ()
G.basicUnsafeCopy MVector (PrimState m) (h (TargetOf x))
Mutable Vector (PrimState m) (h (TargetOf x))
mv Vector (h (TargetOf x))
v

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

-- | 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
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
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 :: Type -> Type -> Type) 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 -> Type) 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 :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap h (TargetOf v) -> Field h v
forall v k (h :: v -> Type) (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 -> Type) (f :: Type -> Type)
       (p :: Type -> Type -> Type) (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 Int
d (Field h (TargetOf (k ':> v))
a) = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString (Proxy k -> String
forall (n :: Symbol) (proxy :: Symbol -> Type).
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 String
" @= "
    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 Int
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 -> Type) (f :: Type -> Type)
       (p :: Type -> Type -> Type) (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 h (TargetOf (k ':> v))
a) = String -> Doc ann
forall a. IsString a => String -> a
fromString (Proxy k -> String
forall (n :: Symbol) (proxy :: Symbol -> Type).
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 -> 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 -> Type) -> [Assoc k v] -> Type@
--
type RecordOf h xs = xs :& Field h

-- | The dual of 'RecordOf'
--
-- @VariantOf :: (v -> Type) -> [Assoc k v] -> Type@
--
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 -> Type). '[] :& 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 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 -> Type) (g :: k -> Type) 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 -> Type) (g :: v -> Type) 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 -> Type) 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 Membership xs x
_ p (h x) (f (h x))
_ = String -> p (Inextensible xs h) (f (Inextensible xs h))
forall a. HasCallStack => String -> a
error String
"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 a -> b
_ c -> d
_ LabelPhantom s b c
_ = String -> LabelPhantom s a d
forall a. HasCallStack => String -> a
error String
"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)
(@=) FieldName k
_ = h v -> Field h (k ':> v)
forall v k (h :: v -> Type) (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 :: Type -> Type -> Type) a b c
       (q :: Type -> Type -> Type).
(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 -> Type) (f :: Type -> Type)
       (p :: Type -> Type -> Type) (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)
(<@=>) FieldName k
k = (Repr h v -> Field h (k ':> v))
-> f (Repr h v) -> Comp f (Field h) (k ':> v)
forall i (f :: Type -> Type) a (g :: i -> Type) (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 -> Type) (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)
(@:>) FieldName k
_ = h v -> Field h (k ':> v)
forall v k (h :: v -> Type) (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 -> Type) (k :: k) (v :: v).
Wrapper h =>
FieldName k -> Repr h v -> Field h (k ':> v)
(@=)
{-# INLINE (@==) #-}
infix 1 @==