module Network.Routing.Dict
(
Dict
, ShowDict
, KV(..)
, empty
, type (</)
, add
, Member
, get
, Members
) where
import GHC.Exts(Constraint)
import Network.Routing.Tree
#if __GLASGOW_HASKELL__ > 707
import GHC.TypeLits
#endif
import Network.Routing.Compat
import Data.Typeable(typeOf, Typeable, TypeRep)
import Data.List(intercalate)
import Unsafe.Coerce
data KV v = Symbol := v
newtype Dict (kvs :: [KV *]) = Dict Tree
class ShowDict (kvs :: [KV *]) where
showDict :: Int -> Dict kvs -> [(String, String, TypeRep)]
instance ShowDict '[] where
showDict _ _ = []
instance (KnownSymbol k, Typeable v, Show v, ShowDict kvs) => ShowDict (k := v ': kvs) where
showDict i (Dict t) =
(symbolVal (Proxy :: Proxy k), show (unsafeCoerce $ index t i :: v), typeOf (undefined :: v)):
showDict (i + 1) (unsafeCoerce $ Dict t :: Dict kvs)
instance ShowDict kvs => Show (Dict kvs) where
show d = "Dict {" ++
(intercalate ", " . map (\(k, v, t) -> k ++ " = " ++ v ++ " :: " ++ show t) $ showDict 0 d)
++ "}"
empty :: Dict '[]
empty = Dict Tip
data HasKeyResult
= AlreadyExists Symbol
| Dictionary
#if __GLASGOW_HASKELL__ > 707
type family HasKey (k :: Symbol) (kvs :: [KV *]) :: HasKeyResult where
HasKey k '[] = AlreadyExists k
HasKey k (k := v ': kvs) = Dictionary
HasKey k (k' := v ': kvs) = HasKey k kvs
#else
type family HasKey (k :: Symbol) (kvs :: [KV *]) :: HasKeyResult
type instance HasKey k kvs = AlreadyExists k
#endif
type k </ v = HasKey k v ~ AlreadyExists k
add :: (k </ kvs) => proxy k -> v -> Dict kvs -> Dict (k := v ': kvs)
add _ v (Dict d) = Dict (unsafeCoerce v `cons` d)
#if __GLASGOW_HASKELL__ > 707
type family Ix (k :: Symbol) (kvs :: [KV *]) :: Nat where
Ix k (k := v ': kvs) = 0
Ix k (k' := v ': kvs) = 1 + Ix k kvs
getImpl :: forall proxy k kvs v. KnownNat (Ix k kvs) => proxy (k :: Symbol) -> Dict kvs -> v
getImpl _ (Dict d) = unsafeCoerce $ d `index` fromIntegral (natVal (Proxy :: Proxy (Ix k kvs)))
class Member (k :: Symbol) (v :: *) (kvs :: [KV *]) | k kvs -> v where
get' :: proxy k -> Dict kvs -> v
instance Member k v (k := v ': kvs) where
get' = getImpl
instance (Member k v kvs, KnownNat (Ix k (k' := v' ': kvs))) => Member k v (k' := v' ': kvs) where
get' = getImpl
get = get'
#else
class Member (k :: Symbol) (v :: *) (kvs :: [KV *]) | k kvs -> v where
get' :: Int -> proxy k -> Dict kvs -> v
instance Member k v (k := v ': kvs) where
get' !i _ (Dict d) = unsafeCoerce $ d `index` i
instance Member k v kvs => Member k v (k' := v' ': kvs) where
get' !i k d = get' (i + 1) k (unsafeCoerce d :: Dict kvs)
get = get' 0
#endif
get :: Member k v kvs => proxy k -> Dict kvs -> v
type family Members (kvs :: [KV *]) (prms :: [KV *]) :: Constraint
type instance Members '[] prms = ()
type instance Members (k := v ': kvs) prms = (Member k v prms, Members kvs prms)