{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE CPP #-}
module Text.Haiji.Dictionary
       ( Dict(..)
       , toDict
       , (:->)
       , empty
       , singleton
       , merge
       , Key(..)
       , retrieve
       ) where

import Data.Aeson (ToJSON(..), Value(..), encode, object, (.=))
import Data.Dynamic
import qualified Data.HashMap.Strict as M
import Data.Maybe
#if MIN_VERSION_base(4,11,0)
#else
import Data.Monoid
#endif
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LT
import Data.Type.Bool
import Data.Type.Equality
#if MIN_VERSION_base(4,9,0)
import Data.Kind
#define STAR Type
#else
#define STAR *
#endif
import GHC.TypeLits
import Text.Haiji.Utils (toKey)

data Key (k :: Symbol) where
  Key :: KnownSymbol k => Key k

infixl 2 :->
data (k :: Symbol) :-> (v :: STAR)

-- | Empty dictionary
empty :: Dict '[]
empty :: Dict '[]
empty = forall (kv :: [*]). HashMap String Dynamic -> Dict kv
Dict forall k v. HashMap k v
M.empty

singleton :: Typeable x => x -> Key k -> Dict '[ k :-> x ]
singleton :: forall x (k :: Symbol). Typeable x => x -> Key k -> Dict '[k :-> x]
singleton x
x Key k
k = forall (kv :: [*]). HashMap String Dynamic -> Dict kv
Dict forall a b. (a -> b) -> a -> b
$ forall k v. Hashable k => k -> v -> HashMap k v
M.singleton (forall (k :: Symbol). Key k -> String
keyVal Key k
k) (forall a. Typeable a => a -> Dynamic
toDyn x
x)

-- | Create single element dictionary (with TypeApplications extention)
toDict :: (KnownSymbol k, Typeable x) => x -> Dict '[ k :-> x ]
toDict :: forall (k :: Symbol) x.
(KnownSymbol k, Typeable x) =>
x -> Dict '[k :-> x]
toDict = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall x (k :: Symbol). Typeable x => x -> Key k -> Dict '[k :-> x]
singleton forall (k :: Symbol). KnownSymbol k => Key k
Key

keyVal :: Key k -> String
keyVal :: forall (k :: Symbol). Key k -> String
keyVal Key k
k = case Key k
k of Key k
Key -> forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal Key k
k

retrieve :: Typeable (Retrieve xs k) => Dict xs -> Key k -> Retrieve xs k
retrieve :: forall (xs :: [*]) (k :: Symbol).
Typeable (Retrieve xs k) =>
Dict xs -> Key k -> Retrieve xs k
retrieve (Dict HashMap String Dynamic
d) Key k
k = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall a. Typeable a => Dynamic -> Maybe a
fromDynamic forall a b. (a -> b) -> a -> b
$ HashMap String Dynamic
d forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
M.! forall (k :: Symbol). Key k -> String
keyVal Key k
k

type family Retrieve (a :: [STAR]) (b :: Symbol) where
  Retrieve ((kx :-> vx) ': xs) key = If (CmpSymbol kx key == 'EQ) vx (Retrieve xs key)

-- | Type level Dictionary
data Dict (kv :: [STAR]) = Dict (M.HashMap String Dynamic)

instance ToJSON (Dict '[]) where
  toJSON :: Dict '[] -> Value
toJSON Dict '[]
_ = [Pair] -> Value
object []

instance (ToJSON (Dict d), ToJSON v, KnownSymbol k, Typeable v) => ToJSON (Dict ((k :-> v) ': d)) where
  toJSON :: Dict ((k :-> v) : d) -> Value
toJSON Dict ((k :-> v) : d)
dict = Object -> Value
Object (Object
a forall a. Semigroup a => a -> a -> a
<> Object
b) where
    (Key k
x, v
v, Dict d
xs) = forall (k :: Symbol) v (d :: [*]).
(KnownSymbol k, Typeable v) =>
Dict ((k :-> v) : d) -> (Key k, v, Dict d)
headKV Dict ((k :-> v) : d)
dict
    Object Object
a = [Pair] -> Value
object [ String -> Key
toKey (forall (k :: Symbol). Key k -> String
keyVal Key k
x) forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= v
v ]
    Object Object
b = forall a. ToJSON a => a -> Value
toJSON Dict d
xs
    headKV :: (KnownSymbol k, Typeable v) => Dict ((k :-> v) ': d) -> (Key k, v, Dict d)
    headKV :: forall (k :: Symbol) v (d :: [*]).
(KnownSymbol k, Typeable v) =>
Dict ((k :-> v) : d) -> (Key k, v, Dict d)
headKV (Dict HashMap String Dynamic
d) = (Key k
k, forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall a. Typeable a => Dynamic -> Maybe a
fromDynamic forall a b. (a -> b) -> a -> b
$ HashMap String Dynamic
d forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
M.! forall (k :: Symbol). Key k -> String
keyVal Key k
k, forall (kv :: [*]). HashMap String Dynamic -> Dict kv
Dict forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
M.delete (forall (k :: Symbol). Key k -> String
keyVal Key k
k) HashMap String Dynamic
d) where
      k :: Key k
k = forall (k :: Symbol). KnownSymbol k => Key k
Key

instance ToJSON (Dict s) => Show (Dict s) where
  show :: Dict s -> String
show = Text -> String
LT.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
LT.decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
encode

merge :: Dict xs -> Dict ys -> Dict (Merge xs ys)
merge :: forall (xs :: [*]) (ys :: [*]).
Dict xs -> Dict ys -> Dict (Merge xs ys)
merge (Dict HashMap String Dynamic
x) (Dict HashMap String Dynamic
y) = forall (kv :: [*]). HashMap String Dynamic -> Dict kv
Dict (HashMap String Dynamic
y forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
`M.union` HashMap String Dynamic
x)

type family Merge a b :: [STAR] where
  Merge xs '[] = xs
  Merge '[] ys = ys
  Merge (x ': xs) (y ': ys) = If (Cmp x y == 'EQ) (y ': Merge xs ys) (If (Cmp x y == 'LT) (x ': Merge xs (y ': ys)) (y ': Merge (x ': xs) ys))

type family Cmp (a :: k) (b :: k) :: Ordering where
  Cmp (k1 :-> v1) (k2 :-> v2) = CmpSymbol k1 k2