{-| This library provide a brief implementation for extensible records.
  It is sensitive to the ordering of key-value items, but has simple type constraints and provides short compile time.
-}

{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ApplicativeDo #-}

module Data.KVList
  (
  -- * Constructors
  -- $setup
    KVList
  , (:=)((:=))
  , (&=)
  , (&=>)
  , kvcons
  , empty
  , singleton
  , ListKey(..)

  -- * Operators
  , get
  , HasKey
  , (&.)
  , (&.?)
  , (&.??)
  )
where

import Prelude

import Data.Functor ((<&>))
import qualified Data.List as List
import Data.Kind (Constraint, Type)
import Data.Typeable (Typeable, typeOf)
import Data.Proxy (Proxy(Proxy))
import GHC.TypeLits (KnownSymbol, Symbol, TypeError, ErrorMessage(Text), symbolVal)
import GHC.OverloadedLabels (IsLabel(..))
import Unsafe.Coerce (unsafeCoerce)


-- Constructors

{- $setup #constructors#
  We can create type level KV list as follows.

  >>> :set -XOverloadedLabels -XTypeOperators
  >>> import Prelude
  >>> import Data.KVList (empty, KVList, (:=)((:=)), (&.), (&=))
  >>> import qualified Data.KVList as KVList
  >>> let sampleList = KVList.empty &= #foo := "str" &= #bar := 34
  >>> type SampleList = KVList '[ "foo" := String, "bar" := Int ]
-}

{-| A value with type level key.
-}
data KVList (kvs :: [Type]) where
  KVNil :: KVList '[]
  KVCons :: (KnownSymbol key) => key := v -> KVList xs -> KVList ((key := v) ': xs)

instance Eq (KVList '[]) where
  == :: KVList '[] -> KVList '[] -> Bool
(==) KVList '[]
_ KVList '[]
_ = Bool
True

instance (Eq v, Eq (KVList kvs)) => Eq (KVList ((k := v) ': kvs)  ) where
  == :: KVList ((k := v) : kvs) -> KVList ((k := v) : kvs) -> Bool
(==) (KVCons (ListKey key
_ := v
v1) KVList xs
next1) (KVCons (ListKey key
_ := v
v2) KVList xs
next2) = v
v1 forall a. Eq a => a -> a -> Bool
== v
v2 Bool -> Bool -> Bool
&& KVList xs
next1 forall a. Eq a => a -> a -> Bool
== KVList xs
next2

{-| -}
instance ShowFields (KVList kvs) => Show (KVList kvs) where
  show :: KVList kvs -> String
show KVList kvs
kvs =
    ( [String] -> String
List.unwords forall a b. (a -> b) -> a -> b
$
      String
"(KVList.empty" forall a. a -> [a] -> [a]
: forall a. ShowFields a => a -> [String]
showFields KVList kvs
kvs
    ) forall a. [a] -> [a] -> [a]
++ String
")"

class ShowFields a where
  showFields :: a -> [String]

instance ShowFields (KVList '[]) where
  showFields :: KVList '[] -> [String]
showFields KVList '[]
_ = []

instance ( ShowFields (KVList kvs)
         , Show v
         ) => ShowFields (KVList ((k := v) ': kvs)) where
  showFields :: KVList ((k := v) : kvs) -> [String]
showFields (KVCons (ListKey key
k := v
v) KVList xs
next) =
    let
      firstLine :: ShowS
firstLine String
str =
        [String] -> String
List.unwords
          [ String
"&="
          , String
"#" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ListKey key
k
          , String
":="
          , String
str
          ]
    in
    ( case String -> [String]
List.lines forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show v
v of
        [] -> [ ShowS
firstLine String
"" ]
        [String
a] -> [ ShowS
firstLine String
a ]
        [String]
as ->
          forall (t :: * -> *) a. Foldable t => t [a] -> [a]
List.concat
            [ [ ShowS
firstLine String
"(" ]
            , [String]
as forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \String
x -> String
"  " forall a. [a] -> [a] -> [a]
++ String
x
            , [ String
")" ]
            ]
    ) forall a. [a] -> [a] -> [a]
++ forall a. ShowFields a => a -> [String]
showFields KVList xs
next

{-| -}
empty :: KVList '[]
empty :: KVList '[]
empty = KVList '[]
KVNil

{-| -}
(&=) :: (KnownSymbol k, Appended kvs '[k := v] ~ appended) => KVList kvs -> (k := v) -> KVList appended
&= :: forall (k :: Symbol) (kvs :: [*]) v (appended :: [*]).
(KnownSymbol k, Appended kvs '[k := v] ~ appended) =>
KVList kvs -> (k := v) -> KVList appended
(&=) KVList kvs
kvs k := v
kv = forall (kvs1 :: [*]) (kvs2 :: [*]) (appended :: [*]).
(Appended kvs1 kvs2 ~ appended) =>
KVList kvs1 -> KVList kvs2 -> KVList appended
append KVList kvs
kvs (forall (k :: Symbol) v.
KnownSymbol k =>
(k := v) -> KVList '[k := v]
singleton k := v
kv)
{-# INLINE (&=) #-}

infixl 1 &=

{-| Applicative version of '(&=)'.

>>> import Data.KVList ((&=>))
>>> :{
  pure KVList.empty
    &=> #foo := (Just 3)
    &=> #bar := (Just "bar")
:}
Just (KVList.empty &= #foo := 3 &= #bar := "bar")

>>> :{
  pure KVList.empty
    &=> #foo := (Just 3)
    &=> #bar := Nothing
:}
Nothing

-}
(&=>) :: (Applicative f, KnownSymbol k, Appended kvs '[k := v] ~ appended) => f (KVList kvs) -> (k := f v) -> f (KVList appended)
&=> :: forall (f :: * -> *) (k :: Symbol) (kvs :: [*]) v
       (appended :: [*]).
(Applicative f, KnownSymbol k,
 Appended kvs '[k := v] ~ appended) =>
f (KVList kvs) -> (k := f v) -> f (KVList appended)
(&=>) f (KVList kvs)
fkvs (ListKey k
k := f v
fv) = do
  KVList kvs
kvs <- f (KVList kvs)
fkvs
  v
v <- f v
fv
  pure $ forall (k :: Symbol) (kvs :: [*]) v (appended :: [*]).
(KnownSymbol k, Appended kvs '[k := v] ~ appended) =>
KVList kvs -> (k := v) -> KVList appended
(&=) KVList kvs
kvs (ListKey k
k forall (a :: Symbol) b. ListKey a -> b -> a := b
:= v
v)
{-# INLINE (&=>) #-}

infixl 1 &=>

{-| -}
kvcons :: (KnownSymbol k) => (k := v) -> KVList kvs -> KVList ((k := v) ': kvs)
kvcons :: forall (k :: Symbol) v (kvs :: [*]).
KnownSymbol k =>
(k := v) -> KVList kvs -> KVList ((k := v) : kvs)
kvcons = forall (k :: Symbol) v (kvs :: [*]).
KnownSymbol k =>
(k := v) -> KVList kvs -> KVList ((k := v) : kvs)
KVCons

{-| -}
data (key :: Symbol) := (value :: Type) where
  (:=) :: ListKey a -> b -> a := b
infix 2 :=

deriving instance (KnownSymbol key, Show value) => Show (key := value)

{-| -}
type HasKey (key :: Symbol) (kvs :: [Type]) (v :: Type) = HasKey_ key kvs kvs v

type family HasKey_ (key :: Symbol) (kvs :: [Type]) (orig :: [Type]) (v :: Type) :: Constraint where
  HasKey_ key '[] '[] v = TypeError ('Text "The KVList is empty.")
  HasKey_ key '[] orig v = TypeError ('Text "The Key is not in the KVList.")
  HasKey_ key ((key := val) ': _) _ v = (val ~ v)
  HasKey_ key (_ ': kvs) orig v = HasKey_ key kvs orig v

{-| -}
type family Appended kvs1 kv2 :: [Type] where
  Appended '[] kv2 = kv2
  Appended (kv ': kvs) kv2 =
    kv ': Appended kvs kv2

{-| -}
append :: (Appended kvs1 kvs2 ~ appended) => KVList kvs1 -> KVList kvs2 -> KVList appended
append :: forall (kvs1 :: [*]) (kvs2 :: [*]) (appended :: [*]).
(Appended kvs1 kvs2 ~ appended) =>
KVList kvs1 -> KVList kvs2 -> KVList appended
append KVList kvs1
KVNil KVList kvs2
kvs2 = KVList kvs2
kvs2
append (KVCons key := v
kv KVList xs
kvs) KVList kvs2
kvs2 = forall (k :: Symbol) v (kvs :: [*]).
KnownSymbol k =>
(k := v) -> KVList kvs -> KVList ((k := v) : kvs)
KVCons key := v
kv (forall (kvs1 :: [*]) (kvs2 :: [*]) (appended :: [*]).
(Appended kvs1 kvs2 ~ appended) =>
KVList kvs1 -> KVList kvs2 -> KVList appended
append KVList xs
kvs KVList kvs2
kvs2)


{-| -}
singleton :: (KnownSymbol k) => (k := v) -> KVList '[ k := v ]
singleton :: forall (k :: Symbol) v.
KnownSymbol k =>
(k := v) -> KVList '[k := v]
singleton k := v
kv = forall (k :: Symbol) v (kvs :: [*]).
KnownSymbol k =>
(k := v) -> KVList kvs -> KVList ((k := v) : kvs)
KVCons k := v
kv KVList '[]
KVNil


{-| -}
get :: (KnownSymbol key, HasKey key kvs v) => ListKey key -> KVList kvs -> v
get :: forall (key :: Symbol) (kvs :: [*]) v.
(KnownSymbol key, HasKey key kvs v) =>
ListKey key -> KVList kvs -> v
get ListKey key
p KVList kvs
kvs = forall (key :: Symbol) (orig :: [*]) v (kvs :: [*]).
(KnownSymbol key, HasKey key orig v) =>
ListKey key -> KVList kvs -> KVList orig -> v
get_ ListKey key
p KVList kvs
kvs KVList kvs
kvs

get_ :: (KnownSymbol key, HasKey key orig v) => ListKey key -> KVList kvs -> KVList orig -> v
get_ :: forall (key :: Symbol) (orig :: [*]) v (kvs :: [*]).
(KnownSymbol key, HasKey key orig v) =>
ListKey key -> KVList kvs -> KVList orig -> v
get_ ListKey key
_ KVList kvs
KVNil KVList orig
KVNil = forall a. HasCallStack => String -> a
error String
"Unreachable: The KVList is empty."
get_ ListKey key
_ KVList kvs
KVNil KVList orig
_ = forall a. HasCallStack => String -> a
error String
"Unreachable: The Key is not in the KVList."
get_ ListKey key
p (KVCons (ListKey key
k := v
v) KVList xs
kvs) KVList orig
orig =
  if forall a. Typeable a => a -> TypeRep
typeOf ListKey key
p forall a. Eq a => a -> a -> Bool
== forall a. Typeable a => a -> TypeRep
typeOf ListKey key
k then
    forall a b. a -> b
unsafeCoerce v
v
  else
    forall (key :: Symbol) (orig :: [*]) v (kvs :: [*]).
(KnownSymbol key, HasKey key orig v) =>
ListKey key -> KVList kvs -> KVList orig -> v
get_ ListKey key
p KVList xs
kvs KVList orig
orig


{-| -}
(&.) :: (KnownSymbol key, HasKey key kvs v) => KVList kvs -> ListKey key -> v
&. :: forall (key :: Symbol) (kvs :: [*]) v.
(KnownSymbol key, HasKey key kvs v) =>
KVList kvs -> ListKey key -> v
(&.) KVList kvs
kvs ListKey key
k = forall (key :: Symbol) (kvs :: [*]) v.
(KnownSymbol key, HasKey key kvs v) =>
ListKey key -> KVList kvs -> v
get ListKey key
k KVList kvs
kvs
infixl 9 &.

{-| Helper operator for optional chain.

@
(&.?) mkvs k = fmap (&. k) mkvs
@

>>> import Data.KVList ((&.?))
>>> :{
  ( KVList.empty
    &= #foo := Just
      (KVList.empty
        &= #bar := "bar"
      )
  ) &. #foo &.? #bar
:}
Just "bar"

-}
(&.?) :: (KnownSymbol key, HasKey key kvs v, Functor f) => f (KVList kvs) -> ListKey key -> f v
&.? :: forall (key :: Symbol) (kvs :: [*]) v (f :: * -> *).
(KnownSymbol key, HasKey key kvs v, Functor f) =>
f (KVList kvs) -> ListKey key -> f v
(&.?) f (KVList kvs)
mkvs ListKey key
k = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (key :: Symbol) (kvs :: [*]) v.
(KnownSymbol key, HasKey key kvs v) =>
KVList kvs -> ListKey key -> v
&. ListKey key
k) f (KVList kvs)
mkvs
infixl 9 &.?

{-| Helper operator for optional chain.

@
(&.??) mkvs k = (&. k) =<< mkvs
@

>>> import Data.KVList ((&.??))
>>> :{
  ( KVList.empty
    &= #foo := Just
      (KVList.empty
        &= #bar := Just "bar"
      )
  ) &. #foo &.?? #bar
:}
Just "bar"

-}
(&.??) :: (KnownSymbol key, HasKey key kvs (m v), Monad m) => m (KVList kvs) -> ListKey key -> m v
&.?? :: forall (key :: Symbol) (kvs :: [*]) (m :: * -> *) v.
(KnownSymbol key, HasKey key kvs (m v), Monad m) =>
m (KVList kvs) -> ListKey key -> m v
(&.??) m (KVList kvs)
mkvs ListKey key
k = (forall (key :: Symbol) (kvs :: [*]) v.
(KnownSymbol key, HasKey key kvs v) =>
KVList kvs -> ListKey key -> v
&. ListKey key
k) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (KVList kvs)
mkvs
infixl 9 &.??

{-| 'ListKey' is just a proxy, but needed to implement a non-orphan 'IsLabel' instance.
In most cases, you only need to create a `ListKey` instance with @OverloadedLabels@, such as `#foo`.
-}
data ListKey (t :: Symbol)
    = ListKey
    deriving (ListKey t -> ListKey t -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (t :: Symbol). ListKey t -> ListKey t -> Bool
/= :: ListKey t -> ListKey t -> Bool
$c/= :: forall (t :: Symbol). ListKey t -> ListKey t -> Bool
== :: ListKey t -> ListKey t -> Bool
$c== :: forall (t :: Symbol). ListKey t -> ListKey t -> Bool
Eq, Typeable)

instance (KnownSymbol t) => Show (ListKey t) where
  show :: ListKey t -> String
show ListKey t
_ = forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy t)

instance l ~ l' => IsLabel (l :: Symbol) (ListKey l') where
#if MIN_VERSION_base(4, 10, 0)
    fromLabel :: ListKey l'
fromLabel = forall (t :: Symbol). ListKey t
ListKey
#else
    fromLabel _ = ListKey
#endif