Dict.hs

{-# LANGUAGE GADTs, MagicHash, KindSignatures #-}

module Dict where

import Data.Map (Map)
import Data.Map as Map
import GHC.Prim
import GHC.Types
import Unsafe.Coerce

newtype Dict (tag :: * -> *) = Dict { unDict :: Map Int Any }

empty :: Dict tag
empty = Dict Map.empty

dataToTag :: a -> Int
dataToTag a = I# (dataToTag# a)

insert :: tag a -> a -> Dict tag -> Dict tag
insert k v (Dict dict) = Dict $ Map.insert (dataToTag k) (unsafeCoerce v) dict

lookup :: tag a -> Dict tag -> Maybe a
lookup k (Dict dict) = case Map.lookup (dataToTag k) dict of
  Nothing -> Nothing
  Just v -> Just (unsafeCoerce v)

delete :: tag a -> Dict tag -> Dict tag
delete k (Dict dict) = Dict $ Map.delete (dataToTag k) dict

ghci.hs

ghci> D.dataToTag HintPort
0
ghci> D.dataToTag HintHost
1
ghci> D.dataToTag HintTeapot
2
ghci> let dict = D.insert HintTeapot 7 $ D.insert HintPort 99 $ D.insert HintPort 7 D.empty
ghci> D.lookup HintTeapot dict
Just 7
ghci> D.lookup HintHost dict
Nothing
ghci> D.lookup HintPort dict
Just 99

Test.hs

{-# LANGUAGE GADTs #-}

module Test where

import Dict (Dict)
import qualified Dict as D

data Hint a where
  HintPort   :: Hint Int
  HintHost   :: Hint String
  HintTeapot :: Hint Int