#if __GLASGOW_HASKELL__ < 710
#endif
module Data.Hetero.DynDict
(
DynDict
, empty
, add
, InDict
, get
, modify
, set
, size
, key
, KV(..)
, KVList(..)
, NotHasKey
, Ix
) where
import Data.Hetero.KVList
import Data.Hetero.Dict (Store(..), ShowDict(..), mkDict)
import Data.List (intercalate)
import GHC.TypeLits
import Data.Proxy (Proxy(..))
import Data.Aeson (ToJSON(..), FromJSON(..), Value(Object))
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
newtype DynDict (kvs :: [KV *]) = DynDict (KVList kvs)
empty :: DynDict '[]
empty = DynDict Empty
add :: (NotHasKey k kvs) => Proxy k -> v -> DynDict kvs -> DynDict (k ':= v ': kvs)
add _ v (DynDict kvs) = DynDict (Cons v kvs)
class InDict (k :: Symbol) (v :: *) (kvs :: [KV *]) | k kvs -> v where
get' :: Proxy k -> DynDict kvs -> v
modify' :: Proxy k -> (v -> v) -> DynDict kvs -> DynDict kvs
#if __GLASGOW_HASKELL__ >= 710
instance InDict k v (k ':= v ': kvs) where
#else
instance InDict k v (k ':= v ': kvs) where
#endif
get' _ (DynDict (Cons v _)) = v
modify' _ f (DynDict (Cons v kvs)) = DynDict $ Cons (f v) kvs
instance (InDict k v kvs, 'Index i ~ Ix k (k' ':= v' ': kvs), KnownNat i) => InDict k v (k' ':= v' ': kvs) where
get' p (DynDict (Cons _ kvs)) = get' p (DynDict kvs)
modify' p f (DynDict (Cons v kvs)) =
let DynDict kvs' = modify' p f (DynDict kvs)
in DynDict (Cons v kvs')
get :: InDict k v kvs => Proxy k -> DynDict kvs -> v
get = get'
modify :: (InDict k v kvs) => Proxy k -> (v -> v) -> DynDict kvs -> DynDict kvs
modify = modify'
set :: (InDict k v kvs) => Proxy k -> v -> DynDict kvs -> DynDict kvs
set p v = modify' p (const v)
size :: DynDict kvs -> Int
size (DynDict Empty) = 0
size (DynDict (Cons _ kvs)) = 1 + size (DynDict kvs)
instance ShowDict kvs => Show (DynDict kvs) where
show d@(DynDict kvs) = "DynDict {" ++
(intercalate ", " . map (\(k, v, t) -> k ++ " = " ++ v ++ " :: " ++ show t) $ showDict 0 (mkDict s))
++ "}"
where
s = Store (size d) kvs
instance ToJSON (DynDict '[]) where
toJSON _ = Object HM.empty
instance (KnownSymbol k, ToJSON v, ToJSON (DynDict kvs)) => ToJSON (DynDict (k ':= v ': kvs)) where
toJSON (DynDict (Cons v kvs)) =
let (Object obj) = toJSON (DynDict kvs)
k = T.pack (symbolVal (Proxy :: Proxy k))
obj' = HM.insert k (toJSON v) obj
in Object obj'
instance FromJSON (DynDict '[]) where
parseJSON (Object _) = return (DynDict Empty)
parseJSON _ = fail "expect an object"
instance (KnownSymbol k, FromJSON v, FromJSON (DynDict kvs)) => FromJSON (DynDict (k ':= v ': kvs)) where
parseJSON v@(Object obj) =
let kString = symbolVal (Proxy :: Proxy k)
k = T.pack kString
in case HM.lookup k obj of
Just v' -> do
DynDict kvs <- parseJSON v
v'' <- parseJSON v'
return (DynDict (Cons v'' kvs))
Nothing -> fail ("missing key: " ++ kString)
parseJSON _ = fail "expect an object"