content: {-# LANGUAGE MultiParamTypeClasses, UndecidableInstances #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE StandaloneDeriving #-}
  {-# LANGUAGE ScopedTypeVariables, TypeFamilies #-}
  {-# LANGUAGE CPP #-}
  {-# LANGUAGE UndecidableSuperClasses #-}
  {-# LANGUAGE PolyKinds #-}
  -----------------------------------------------------------------------------
  -- |
  -- 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
    , xlb
    , liftField
    , liftField2
    -- * Records and variants
    , RecordOf
    , Record
    , emptyRecord
    , VariantOf
    , Variant
    -- * Matching
    , matchWithField
    , matchField
    -- * Key / value
    , KeyOf
    , proxyKeyOf
    , stringKeyOf
    , TargetOf
    , proxyTargetOf
    , KeyIs
    , TargetIs
    , KeyTargetAre
    ) 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.Compose
  import Data.Functor.Identity
  import Data.Hashable
  import Data.Incremental (Incremental)
  import Data.String
  import Prettyprinter
  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.OverloadedLabels
  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 { getField :: h (TargetOf kv) }
  
    deriving (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 (MV_Field v) = M.basicLength v
    basicUnsafeSlice i n (MV_Field v) = MV_Field $ M.basicUnsafeSlice i n v
    basicOverlaps (MV_Field v1) (MV_Field v2) = M.basicOverlaps v1 v2
    basicUnsafeNew n = MV_Field <$> M.basicUnsafeNew n
  #if MIN_VERSION_vector(0,11,0)
    basicInitialize (MV_Field v) = M.basicInitialize v
    {-# INLINE basicInitialize #-}
  #endif
    basicUnsafeReplicate n (Field x) = MV_Field <$> M.basicUnsafeReplicate n x
    basicUnsafeRead (MV_Field v) i = Field <$> M.basicUnsafeRead v i
    basicUnsafeWrite (MV_Field v) i (Field x) = M.basicUnsafeWrite v i x
    basicClear (MV_Field v) = M.basicClear v
    basicSet (MV_Field v) (Field x) = M.basicSet v x
    basicUnsafeCopy (MV_Field v1) (MV_Field v2) = M.basicUnsafeCopy v1 v2
    basicUnsafeMove (MV_Field v1) (MV_Field v2) = M.basicUnsafeMove v1 v2
    basicUnsafeGrow (MV_Field v) n = MV_Field <$> M.basicUnsafeGrow v 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 (MV_Field v) = V_Field <$> G.basicUnsafeFreeze v
    basicUnsafeThaw (V_Field v) = MV_Field <$> G.basicUnsafeThaw v
    basicLength (V_Field v) = G.basicLength v
    basicUnsafeSlice i n (V_Field v) = V_Field $ G.basicUnsafeSlice i n v
    basicUnsafeIndexM (V_Field v) i = Field <$> G.basicUnsafeIndexM v i
    basicUnsafeCopy (MV_Field mv) (V_Field v) = G.basicUnsafeCopy mv 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 = 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 = coerce
  {-# INLINE liftField2 #-}
  
  instance Wrapper h => Wrapper (Field h) where
    type Repr (Field h) kv = Repr h (TargetOf kv)
    _Wrapper = dimap getField (fmap Field) . _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 d (Field a) = showParen (d >= 1) $ showString (symbolVal (Proxy :: Proxy k))
      . showString " @= "
      . showsPrec 1 (view _Wrapper a)
  
  instance (KnownSymbol k, Pretty (h v)) => Pretty (Field h (k ':> v)) where
    pretty (Field a) = fromString (symbolVal (Proxy :: Proxy k))
      <> ": "
      <> pretty 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 = 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 h = matchWith (\(Field x) (Field y) -> h x y)
  {-# INLINE matchWithField #-}
  
  -- | Pattern matching on a 'Variant'
  matchField :: RecordOf (Match h r) xs -> VariantOf h xs -> r
  matchField = matchWithField 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
    , Wrapper h)
    => Optic' p f (t xs (Field h)) (Repr h v)
  
  instance k ~ l => IsLabel k (Proxy l) where
    fromLabel = Proxy
  
  -- | Specialised version of 'itemAssoc'. Stands for "eXtensible LaBel"
  xlb :: Proxy k -> FieldOptic k
  xlb t = itemAssoc t
  
  -- | Annotate a value by the field name.
  --
  -- @
  -- foo :: 'Record' '["num" >: Int, "str" >: String]
  -- foo = #num \@= 42
  --   <: #str \@= "foo"
  --   <: nil
  -- @
  (@=) :: Wrapper h => Proxy k -> Repr h v -> Field h (k ':> v)
  (@=) _ = Field #. review _Wrapper
  {-# INLINE (@=) #-}
  infix 1 @=
  
  -- | Lifted ('@=')
  --
  -- @
  -- foo :: IO ('Record' '["num" >: Int, "str" >: String])
  -- foo = hsequence
  --   $ #num \<\@=\> readLn
  --   <: #str \<\@=\> getLine
  --   <: nil
  -- @
  (<@=>) :: (Functor f, Wrapper h) => Proxy k -> f (Repr h v) -> Compose f (Field h) (k ':> v)
  (<@=>) k = comp (k @=)
  {-# INLINE (<@=>) #-}
  infix 1 <@=>
  
  -- | Annotate a value by the field name without 'Wrapper'.
  (@:>) :: Proxy k -> h v -> Field h (k ':> v)
  (@:>) _ = Field
  infix 1 @:>
  
  -- | Kind-monomorphic, unwrapped version of '@='
  (@==) :: Proxy (k :: Symbol) -> v -> Field Identity (k ':> v)
  (@==) = (@=)
  {-# INLINE (@==) #-}
  infix 1 @==
  