@@ -1,4 +1,5 @@
11{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE DataKinds #-}
23{-# LANGUAGE GADTs #-}
34{-# LANGUAGE KindSignatures #-}
45{-# LANGUAGE MagicHash #-}
@@ -20,12 +21,17 @@ module Data.TypeRep.CacheMap
2021 -- * Helpful testing functions
2122 , TF (..)
2223 , fromList
24+ , toFps
2325 ) where
2426
2527import Prelude hiding (lookup)
2628
2729import Control.Arrow ((&&&))
30+import Data.Function (on)
31+import Data.IntMap.Strict (IntMap)
2832import Data.Kind (Type)
33+import Data.List (nubBy)
34+import Data.Maybe (fromJust)
2935import Data.Proxy (Proxy (..))
3036import Data.Typeable (Typeable, typeRep, typeRepFingerprint)
3137import Data.Word (Word64)
@@ -36,6 +42,7 @@ import GHC.Prim (eqWord#, ltWord#)
3642import GHC.Word (Word64 (..))
3743import Unsafe.Coerce (unsafeCoerce)
3844
45+import qualified Data.IntMap.Strict as IM
3946import qualified Data.Vector as V
4047import qualified Data.Vector.Unboxed as Unboxed
4148
@@ -45,6 +52,14 @@ data TypeRepMap (f :: k -> Type) = TypeRepMap
4552 , anys :: V.Vector Any
4653 }
4754
55+instance Show (TypeRepMap f) where
56+ show = show . toFps
57+
58+toFps :: TypeRepMap f -> [Fingerprint]
59+toFps TypeRepMap{..} = zipWith Fingerprint
60+ (Unboxed.toList fingerprintAs)
61+ (Unboxed.toList fingerprintBs)
62+
4863fromAny :: Any -> f a
4964fromAny = unsafeCoerce
5065
@@ -57,10 +72,7 @@ insert :: forall a f . Typeable a => f a -> TypeRepMap f -> TypeRepMap f
5772insert x = fromListPairs . addX . toPairList
5873 where
5974 toPairList :: TypeRepMap f -> [(Fingerprint, Any)]
60− toPairList (TypeRepMap as bs ans) = zip (zipWith Fingerprint
61− (Unboxed.toList as)
62− (Unboxed.toList bs))
63− (V.toList ans)
75+ toPairList trMap = zip (toFps trMap) (V.toList $ anys trMap)
6476
6577 pairX :: (Fingerprint, Any)
6678 pairX@(fpX, _) = (calcFp x, unsafeCoerce x)
@@ -114,7 +126,10 @@ cachedBinarySearch (Fingerprint (W64# a) (W64# b)) fpAs fpBs = inline (go 0#)
114126----------------------------------------------------------------------------
115127
116128data TF f where
117− TF :: Typeable a => f a -> TF f
129+ TF :: Typeable a => f a -> TF f
130+
131+instance Show (TF f) where
132+ show (TF tf) = show $ calcFp tf
118133
119134fromF :: Typeable a => f a -> Proxy a
120135fromF _ = Proxy
@@ -126,7 +141,7 @@ fromListPairs :: [(Fingerprint, Any)] -> TypeRepMap f
126141fromListPairs kvs = TypeRepMap (Unboxed.fromList fpAs) (Unboxed.fromList fpBs) (V.fromList ans)
127142 where
128143 (fpAs, fpBs) = unzip $ map (\(Fingerprint a b) -> (a, b)) fps
129− (fps, ans) = unzip $ breadthFirst $ fromListToTree $ sortWith fst kvs
144+ (fps, ans) = unzip $ fromSortedList $ sortWith fst $ nubPairs kvs
130145
131146fromList :: forall f . [TF f] -> TypeRepMap f
132147fromList = fromListPairs . map (fp &&& an)
@@ -137,34 +152,22 @@ fromList = fromListPairs . map (fp &&& an)
137152 an :: TF f -> Any
138153 an (TF x) = unsafeCoerce x
139154
155+nubPairs :: (Eq a) => [(a, b)] -> [(a, b)]
156+nubPairs = nubBy ((==) `on` fst)
157+
140158----------------------------------------------------------------------------
141−-- Tree
159+-- Tree-like conversion
142160----------------------------------------------------------------------------
143161
144−data Tree a = Leaf | Node a (Tree a) (Tree a)
145− deriving (Show)
146−
147−fromListToTree :: [a] -> Tree a
148−fromListToTree [] = Leaf
149−fromListToTree xs =
150− let len = length xs
151− in case splitAt (len `div` 2) xs of
152− ([], []) -> Leaf
153− (ls, []) -> Node (last ls) (fromListToTree $ init ls) Leaf
154− ([], (r:rs)) -> Node r Leaf $ fromListToTree rs
155− (ls, r:rs) -> Node r (fromListToTree ls) (fromListToTree rs)
156−
157−breadthFirst :: Tree a -> [a]
158−breadthFirst tree = bf [tree]
162+fromSortedList :: forall a . [a] -> [a]
163+fromSortedList l = IM.elems $ fst $ go 0 0 mempty (IM.fromList $ zip [0..] l)
159164 where
160− bf :: [Tree a] -> [a]
161− bf [] = []
162− bf xs = mapValue xs ++ bf (concatMap children xs)
163−
164− mapValue :: [Tree a] -> [a]
165− mapValue [] = []
166− mapValue (Leaf : xs) = mapValue xs
167− mapValue (Node a _ _ : xs) = a : mapValue xs
168−
169− children Leaf = []
170− children (Node _ l r) = [l, r]
165+ -- state monad could be used here, but it's another dependency
166+ go :: Int -> Int -> IntMap a -> IntMap a -> (IntMap a, Int)
167+ go i first result vector =
168+ if i >= IM.size vector
169+ then (result, first)
170+ else do
171+ let (newResult, newFirst) = go (2 * i + 1) first result vector
172+ let withCur = IM.insert i (fromJust $ IM.lookup newFirst vector) newResult
173+ go (2 * i + 2) (newFirst + 1) withCur vector