{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.KVList
(
KVList
, (:=)((:=))
, (&=)
, kvcons
, empty
, singleton
, ListKey(..)
, get
, HasKey
, (&.)
)
where
import Prelude
import Data.Kind (Constraint, Type)
import Data.Typeable (Typeable, typeOf)
import GHC.TypeLits (KnownSymbol, Symbol, TypeError, ErrorMessage(Text))
import GHC.OverloadedLabels (IsLabel(..))
import Unsafe.Coerce (unsafeCoerce)
data KVList (kvs :: [Type]) where
KVNil :: KVList '[]
KVCons :: (KnownSymbol key) => key := v -> KVList xs -> KVList ((key := v) ': xs)
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 &=
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 (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 &.
data ListKey (t :: Symbol)
= ListKey
deriving (Int -> ListKey t -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (t :: Symbol). Int -> ListKey t -> ShowS
forall (t :: Symbol). [ListKey t] -> ShowS
forall (t :: Symbol). ListKey t -> String
showList :: [ListKey t] -> ShowS
$cshowList :: forall (t :: Symbol). [ListKey t] -> ShowS
show :: ListKey t -> String
$cshow :: forall (t :: Symbol). ListKey t -> String
showsPrec :: Int -> ListKey t -> ShowS
$cshowsPrec :: forall (t :: Symbol). Int -> ListKey t -> ShowS
Show, 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 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