#if __GLASGOW_HASKELL__ < 710
#endif
module Data.Hetero.Dict
(
Store(..)
, emptyStore
, add
, Dict
, mkDict'
, mkDict
, InDict
, get
, key
, KV(..)
, KVList(..)
, NotHasKey
, Ix
, ShowDict(..)
) where
import qualified Control.Monad.Primitive as P
import Control.Monad.ST (ST, runST)
import Data.Hetero.KVList
import Data.List (intercalate)
import qualified Data.Primitive.Array as P
import Data.Proxy
import Data.Typeable (TypeRep, Typeable, typeOf)
import GHC.Exts (Any)
import GHC.TypeLits
import Unsafe.Coerce
data Store kvs = Store
{ storeSize :: !Int
, storeBody :: KVList kvs
}
emptyStore :: Store '[]
emptyStore = Store 0 Empty
add :: (NotHasKey k kvs) => Proxy k -> v -> Store kvs -> Store (k ':= v ': kvs)
add _ v (Store l c) = Store (l + 1) (Cons v c)
newtype Dict (kvs :: [KV *]) = Dict (P.Array Any)
mkDict' :: forall s kvs. Store kvs -> ST s (Dict kvs)
mkDict' store = do
ary <- P.newArray (storeSize store) undefined
go ary
Dict `fmap` P.unsafeFreezeArray ary
where
go :: P.MutableArray (P.PrimState (ST s)) Any -> ST s ()
go array = loop 0 (storeBody store)
where
loop :: Int -> KVList kvs' -> ST s ()
loop !i (Cons v ss) = do
P.writeArray array i (unsafeCoerce v)
loop (i + 1) ss
loop _ Empty = return ()
mkDict :: Store kvs -> Dict kvs
mkDict store = runST $ mkDict' store
getImpl :: forall i k kvs v. ('Index i ~ Ix k kvs, KnownNat i) => Proxy (k :: Symbol) -> Dict kvs -> v
getImpl _ (Dict d) = unsafeCoerce $ d `P.indexArray` fromIntegral (natVal (Proxy :: Proxy i))
class InDict (k :: Symbol) (v :: *) (kvs :: [KV *]) | k kvs -> v where
get' :: Proxy k -> Dict kvs -> v
#if __GLASGOW_HASKELL__ >= 710
instance InDict k v (k ':= v ': kvs) where
#else
instance InDict k v (k ':= v ': kvs) where
#endif
get' = getImpl
instance (InDict k v kvs, 'Index i ~ Ix k (k' ':= v' ': kvs), KnownNat i) => InDict k v (k' ':= v' ': kvs) where
get' = getImpl
get :: InDict k v kvs => Proxy k -> Dict kvs -> v
get = get'
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 $ P.indexArray 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)
++ "}"
instance ShowDict kvs => Show (Store kvs) where
show d = "Store {" ++
(intercalate ", " . map (\(k, v, t) -> k ++ " = " ++ v ++ " :: " ++ show t) $ showDict 0 (mkDict d))
++ "}"