{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ApplicativeDo #-}
module Data.KVList
(
KVList
, (:=)((:=))
, (&=)
, (&=>)
, kvcons
, empty
, singleton
, ListKey(..)
, 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)
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 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 &.
(&.?) :: (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 &.?
(&.??) :: (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 &.??
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