├── .github ├── CODEOWNERS ├── dependabot.yml └── workflows │ └── ci.yml ├── .gitignore ├── .headroom.yaml ├── .hlint.yaml ├── .stylish-haskell.yaml ├── CHANGELOG.md ├── LICENSE ├── README.md ├── benchmark ├── CMap.hs ├── CacheMap.hs ├── DMap.hs ├── Main.hs ├── OptimalVector.hs ├── Spec.hs └── Vector.hs ├── src └── Data │ ├── TMap.hs │ ├── TypeRepMap.hs │ └── TypeRepMap │ └── Internal.hs ├── stack.yaml ├── test ├── Test.hs └── Test │ └── TypeRep │ ├── CMap.hs │ ├── TypeRepMap.hs │ ├── TypeRepMapProperty.hs │ ├── Vector.hs │ └── VectorOpt.hs ├── typerep-extra-impls └── Data │ └── TypeRep │ ├── CMap.hs │ ├── OptimalVector.hs │ └── Vector.hs └── typerep-map.cabal /.github/CODEOWNERS: -------------------------------------------------------------------------------- 1 | * @chshersh @vrom911 -------------------------------------------------------------------------------- /.github/dependabot.yml: -------------------------------------------------------------------------------- 1 | version: 2 2 | updates: 3 | - package-ecosystem: "github-actions" 4 | directory: "/" 5 | schedule: 6 | interval: "daily" 7 | commit-message: 8 | prefix: "GA" 9 | include: "scope" 10 | labels: 11 | - "CI" 12 | - "dependencies" -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | workflow_dispatch: 5 | pull_request: 6 | types: [synchronize, opened, reopened] 7 | push: 8 | branches: [main] 9 | schedule: 10 | # additionally run once per week (At 00:00 on Sunday) to maintain cache 11 | - cron: '0 0 * * 0' 12 | 13 | jobs: 14 | cabal: 15 | name: ${{ matrix.os }} / ghc ${{ matrix.ghc }} 16 | runs-on: ${{ matrix.os }} 17 | strategy: 18 | matrix: 19 | os: [ubuntu-latest, macOS-latest, windows-latest] 20 | cabal: ["3.8"] 21 | ghc: 22 | - "8.2.2" 23 | - "8.4.4" 24 | - "8.6.5" 25 | - "8.8.4" 26 | - "8.10.7" 27 | - "9.0.2" 28 | - "9.2.4" 29 | - "9.4.2" 30 | exclude: 31 | - os: macOS-latest 32 | ghc: 9.2.4 33 | - os: macOS-latest 34 | ghc: 9.0.2 35 | - os: macOS-latest 36 | ghc: 8.10.7 37 | - os: macOS-latest 38 | ghc: 8.8.4 39 | - os: macOS-latest 40 | ghc: 8.6.5 41 | - os: macOS-latest 42 | ghc: 8.4.4 43 | - os: macOS-latest 44 | ghc: 8.2.2 45 | 46 | - os: windows-latest 47 | ghc: 9.2.4 48 | - os: windows-latest 49 | ghc: 9.0.2 50 | - os: windows-latest 51 | ghc: 8.10.7 52 | - os: windows-latest 53 | ghc: 8.8.4 54 | - os: windows-latest 55 | ghc: 8.6.5 56 | - os: windows-latest 57 | ghc: 8.4.4 58 | - os: windows-latest 59 | ghc: 8.2.2 60 | 61 | steps: 62 | - uses: actions/checkout@v4 63 | 64 | - uses: haskell/actions/setup@v2 65 | id: setup-haskell-cabal 66 | name: Setup Haskell 67 | with: 68 | ghc-version: ${{ matrix.ghc }} 69 | cabal-version: ${{ matrix.cabal }} 70 | 71 | - name: Configure 72 | run: | 73 | cabal configure --enable-tests --enable-benchmarks --test-show-details=direct --write-ghc-environment-files=always 74 | 75 | - name: Freeze 76 | run: | 77 | cabal freeze 78 | 79 | - uses: actions/cache@v3 80 | name: Cache ~/.cabal/store 81 | with: 82 | path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 83 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} 84 | 85 | - name: Install dependencies 86 | run: | 87 | cabal build all --only-dependencies 88 | 89 | - name: Build 90 | run: | 91 | cabal build all 92 | 93 | - name: Test 94 | run: | 95 | cabal test all 96 | 97 | - name: Documentation 98 | run: | 99 | cabal haddock 100 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | ### Haskell 2 | dist 3 | dist-* 4 | cabal-dev 5 | *.o 6 | *.hi 7 | *.chi 8 | *.chs.h 9 | *.dyn_o 10 | *.dyn_hi 11 | *.prof 12 | *.aux 13 | *.hp 14 | *.eventlog 15 | .virtualenv 16 | .hsenv 17 | .hpc 18 | .cabal-sandbox/ 19 | cabal.sandbox.config 20 | cabal.config 21 | cabal.project.local 22 | .HTF/ 23 | .ghc.environment.* 24 | 25 | # Stack 26 | .stack-work/ 27 | stack.yaml.lock 28 | 29 | ### IDE/support 30 | # Vim 31 | [._]*.s[a-v][a-z] 32 | [._]*.sw[a-p] 33 | [._]s[a-v][a-z] 34 | [._]sw[a-p] 35 | *~ 36 | tags 37 | 38 | # IntellijIDEA 39 | .idea/ 40 | .ideaHaskellLib/ 41 | *.iml 42 | 43 | # Atom 44 | .haskell-ghc-mod.json 45 | 46 | # VS 47 | .vscode/ 48 | 49 | # Emacs 50 | *# 51 | .dir-locals.el 52 | TAGS 53 | 54 | # other 55 | .DS_Store 56 | -------------------------------------------------------------------------------- /.headroom.yaml: -------------------------------------------------------------------------------- 1 | ## This is the configuration file for Headroom. 2 | ## See https://github.com/vaclavsvejcar/headroom for more details. 3 | version: 0.4.0.0 4 | 5 | run-mode: replace 6 | 7 | source-paths: 8 | - src/ 9 | 10 | excluded-paths: [] 11 | 12 | template-paths: 13 | - https://raw.githubusercontent.com/kowainik/org/main/headroom-templates/haskell.mustache 14 | 15 | variables: 16 | author: Kowainik 17 | email: xrom.xkov@gmail.com 18 | _haskell_module_copyright: "(c) {{ _current_year }} {{ author }}" 19 | 20 | license-headers: 21 | haskell: 22 | put-after: ["^{-#"] 23 | margin-bottom-code: 1 24 | margin-top-code: 1 25 | block-comment: 26 | starts-with: ^{- \| 27 | ends-with: (? import Data.TMap 20 | 21 | ghci> tm = insert True $ one (42 :: Int) 22 | 23 | ghci> size tm 24 | 2 25 | 26 | ghci> res = lookup tm 27 | 28 | ghci> res :: Maybe Int 29 | Just 42 30 | 31 | ghci> res :: Maybe Bool 32 | Just True 33 | 34 | ghci> res :: Maybe String 35 | Nothing 36 | 37 | ghci> lookup (insert "hello" tm) :: Maybe String 38 | Just "hello" 39 | 40 | ghci> member @Int tm 41 | True 42 | 43 | ghci> tm' = delete @Int tm 44 | 45 | ghci> member @Int tm' 46 | False 47 | ``` 48 | 49 | ## Benchmarks 50 | 51 | Tables below contain comparision with `DMap TypeRep` of ten `lookup` operations 52 | on structure with size `10^4`: 53 | 54 | | | ghc-8.2.2 | ghc-8.4.3 | ghc-8.8.3 | ghc-8.10.1 | 55 | |----------------|-----------|-----------|-----------|------------| 56 | | `DMap TypeRep` | 517.5 ns | 779.9 ns | 1.559 μs | 1.786 μs | 57 | | `typerep-map` | 205.3 ns | 187.2 ns | 190.1 ns | 169.1 ns | 58 | 59 | ghc-8.2.2 | ghc-8.4.3 60 | :---------:|:-----------: 61 | ![DMap 8.2.2](https://user-images.githubusercontent.com/4276606/42495129-c700f21e-8454-11e8-98b4-ba080259c712.png) | ![DMap 8.4.3](https://user-images.githubusercontent.com/4276606/42495168-ebb1d13c-8454-11e8-9d17-f6da29d2169a.png) 62 | ![TMap 8.2.2](https://user-images.githubusercontent.com/4276606/42494935-3a352d96-8454-11e8-985e-ebc77cc51ca0.png) | ![TMap 8.4.3](https://user-images.githubusercontent.com/4276606/42495147-d884bdf4-8454-11e8-887f-9815fd2b8d68.png) 63 | -------------------------------------------------------------------------------- /benchmark/CMap.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} 2 | 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE PolyKinds #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | 9 | module CMap 10 | ( spec 11 | ) where 12 | 13 | import Prelude hiding (lookup) 14 | 15 | import Criterion.Main (bench, env, nf, whnf) 16 | import Data.Kind (Type) 17 | import Data.Maybe (fromJust) 18 | import Data.Proxy (Proxy (..)) 19 | import Data.Typeable (Typeable) 20 | import GHC.TypeLits (KnownNat, Nat, type (+)) 21 | 22 | import Data.TypeRep.CMap (TypeRepMap (..), empty, insert, lookup) 23 | 24 | import Spec (BenchSpec (..)) 25 | 26 | 27 | spec :: BenchSpec 28 | spec = BenchSpec 29 | { benchLookup = Just $ \name -> 30 | env (mkMap 10000) $ \ ~bigMap -> 31 | bench name $ nf tenLookups bigMap 32 | , benchInsertSmall = Just $ \name -> 33 | bench name $ whnf (inserts empty 10) (Proxy @99999) 34 | , benchInsertBig = Just $ \name -> 35 | env (mkMap 10000) $ \ ~bigMap -> 36 | bench name $ whnf (inserts bigMap 1) (Proxy @99999) 37 | , benchUpdateSmall = Just $ \name -> 38 | env (mkMap 10) $ \ ~smallMap -> 39 | bench name $ whnf (inserts smallMap 10) (Proxy @0) 40 | , benchUpdateBig = Just $ \name -> 41 | env (mkMap 10000) $ \ ~bigMap -> 42 | bench name $ whnf (inserts bigMap 10) (Proxy @0) 43 | } 44 | 45 | tenLookups 46 | :: TypeRepMap (Proxy :: Nat -> Type) 47 | -> ( Proxy 10, Proxy 20, Proxy 30, Proxy 40 48 | , Proxy 50, Proxy 60, Proxy 70, Proxy 80 49 | ) 50 | tenLookups tmap = (lp, lp, lp, lp, lp, lp, lp, lp) 51 | where 52 | lp :: forall (a :: Nat) . Typeable a => Proxy a 53 | lp = fromJust $ lookup tmap 54 | 55 | inserts 56 | :: forall a . (KnownNat a) 57 | => TypeRepMap (Proxy :: Nat -> Type) 58 | -> Int 59 | -> Proxy (a :: Nat) 60 | -> TypeRepMap (Proxy :: Nat -> Type) 61 | inserts !c 0 _ = c 62 | inserts c n x = inserts 63 | (insert x c) 64 | (n - 1) 65 | (Proxy :: Proxy (a + 1)) 66 | 67 | mkMap :: Int -> IO (TypeRepMap (Proxy :: Nat -> Type)) 68 | mkMap n = pure $ buildBigMap n (Proxy :: Proxy 0) empty 69 | 70 | buildBigMap 71 | :: forall a . (KnownNat a) 72 | => Int 73 | -> Proxy (a :: Nat) 74 | -> TypeRepMap (Proxy :: Nat -> Type) 75 | -> TypeRepMap (Proxy :: Nat -> Type) 76 | buildBigMap 1 x = insert x 77 | buildBigMap n x = insert x . buildBigMap (n - 1) (Proxy :: Proxy (a + 1)) 78 | -------------------------------------------------------------------------------- /benchmark/CacheMap.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} 2 | 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE PolyKinds #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | 9 | module CacheMap 10 | ( spec 11 | ) where 12 | 13 | import Prelude hiding (lookup) 14 | 15 | import Criterion.Main (bench, env, nf, whnf) 16 | import Data.Kind (Type) 17 | import Data.Maybe (fromJust) 18 | import Data.Proxy (Proxy (..)) 19 | import Data.Typeable (Typeable) 20 | import GHC.Exts (fromList) 21 | import GHC.TypeLits (KnownNat, Nat, type (+)) 22 | 23 | import Data.TypeRepMap.Internal (TypeRepMap (..), WrapTypeable (..), empty, insert, lookup) 24 | 25 | import Spec (BenchSpec (..)) 26 | 27 | 28 | spec :: BenchSpec 29 | spec = BenchSpec 30 | { benchLookup = Just $ \name -> 31 | env (mkMap 10000) $ \ ~bigMap -> 32 | bench name $ nf tenLookups bigMap 33 | , benchInsertSmall = Just $ \name -> 34 | bench name $ whnf (inserts empty 10) (Proxy @99999) 35 | , benchInsertBig = Just $ \name -> 36 | env (mkMap 10000) $ \ ~bigMap -> 37 | bench name $ whnf (inserts bigMap 1) (Proxy @99999) 38 | , benchUpdateSmall = Just $ \name -> 39 | env (mkMap 10) $ \ ~smallMap -> 40 | bench name $ whnf (inserts smallMap 10) (Proxy @0) 41 | , benchUpdateBig = Just $ \name -> 42 | env (mkMap 10000) $ \ ~bigMap -> 43 | bench name $ whnf (inserts bigMap 10) (Proxy @0) 44 | } 45 | 46 | tenLookups 47 | :: TypeRepMap (Proxy :: Nat -> Type) 48 | -> ( Proxy 10, Proxy 20, Proxy 30, Proxy 40 49 | , Proxy 50, Proxy 60, Proxy 70, Proxy 80 50 | ) 51 | tenLookups tmap = (lp, lp, lp, lp, lp, lp, lp, lp) 52 | where 53 | lp :: forall (a :: Nat) . Typeable a => Proxy a 54 | lp = fromJust $ lookup tmap 55 | 56 | inserts 57 | :: forall a . (KnownNat a) 58 | => TypeRepMap (Proxy :: Nat -> Type) 59 | -> Int 60 | -> Proxy (a :: Nat) 61 | -> TypeRepMap (Proxy :: Nat -> Type) 62 | inserts !c 0 _ = c 63 | inserts c n x = inserts 64 | (insert x c) 65 | (n - 1) 66 | (Proxy :: Proxy (a + 1)) 67 | 68 | mkMap :: Int -> IO (TypeRepMap (Proxy :: Nat -> Type)) 69 | mkMap n = pure $ fromList $ buildBigMap n (Proxy :: Proxy 0) [] 70 | 71 | 72 | buildBigMap 73 | :: forall a . (KnownNat a) 74 | => Int 75 | -> Proxy (a :: Nat) 76 | -> [WrapTypeable (Proxy :: Nat -> Type)] 77 | -> [WrapTypeable (Proxy :: Nat -> Type)] 78 | buildBigMap 1 x = (WrapTypeable x :) 79 | buildBigMap n x = (WrapTypeable x :) . buildBigMap (n - 1) (Proxy :: Proxy (a + 1)) 80 | -------------------------------------------------------------------------------- /benchmark/DMap.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} 2 | 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE InstanceSigs #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | module DMap 11 | ( spec 12 | ) where 13 | 14 | import Prelude hiding (lookup) 15 | 16 | import Control.DeepSeq (NFData (..)) 17 | import Criterion.Main (bench, env, nf, whnf) 18 | import Data.Kind (Type) 19 | import Data.Maybe (fromJust) 20 | import Data.Proxy (Proxy (..)) 21 | import GHC.TypeLits (KnownNat, Nat, type (+)) 22 | import Type.Reflection (TypeRep, Typeable, typeRep) 23 | import Type.Reflection.Unsafe (typeRepFingerprint) 24 | 25 | import Data.Dependent.Map (DMap, empty, insert, keys, lookup) 26 | import Data.Some (Some (Some)) 27 | 28 | import Spec (BenchSpec (..)) 29 | 30 | 31 | type TypeRepMap = DMap TypeRep 32 | 33 | spec :: BenchSpec 34 | spec = BenchSpec 35 | { benchLookup = Just $ \name -> 36 | env mkBigMap $ \ ~(DMapNF bigMap) -> 37 | bench name $ nf tenLookups bigMap 38 | , benchInsertSmall = Just $ \name -> 39 | bench name $ whnf (inserts empty 10) (Proxy @99999) 40 | , benchInsertBig = Just $ \name -> 41 | env mkBigMap $ \ ~(DMapNF bigMap) -> 42 | bench name $ whnf (inserts bigMap 1) (Proxy @99999) 43 | , benchUpdateSmall = Nothing -- Not implemented 44 | , benchUpdateBig = Nothing -- Not implemented 45 | } 46 | 47 | tenLookups 48 | :: TypeRepMap (Proxy :: Nat -> Type) 49 | -> ( Proxy 10, Proxy 20, Proxy 30, Proxy 40 50 | , Proxy 50, Proxy 60, Proxy 70, Proxy 80 51 | ) 52 | tenLookups tmap = (lp, lp, lp, lp, lp, lp, lp, lp) 53 | where 54 | lp :: forall (a :: Nat) . Typeable a => Proxy a 55 | lp = fromJust $ lookup (typeRep @a) tmap 56 | 57 | inserts 58 | :: forall a . (KnownNat a) 59 | => TypeRepMap (Proxy :: Nat -> Type) 60 | -> Int 61 | -> Proxy (a :: Nat) 62 | -> TypeRepMap (Proxy :: Nat -> Type) 63 | inserts !c 0 _ = c 64 | inserts c n x = inserts 65 | (insert (typeRep @a) x c) 66 | (n - 1) 67 | (Proxy :: Proxy (a + 1)) 68 | 69 | -- TypeRepMap of 10000 elements 70 | mkBigMap :: IO (DMapNF (Proxy :: Nat -> Type)) 71 | mkBigMap = pure . DMapNF $ buildBigMap 10000 (Proxy :: Proxy 0) empty 72 | 73 | buildBigMap 74 | :: forall a . (KnownNat a) 75 | => Int 76 | -> Proxy (a :: Nat) 77 | -> TypeRepMap (Proxy :: Nat -> Type) 78 | -> TypeRepMap (Proxy :: Nat -> Type) 79 | buildBigMap 1 x = insert (typeRep @a) x 80 | buildBigMap n x = insert (typeRep @a) x 81 | . buildBigMap (n - 1) (Proxy @(a + 1)) 82 | 83 | -- | Wrapper that provides NFData instance to the 'DMap' structure. 84 | newtype DMapNF f = DMapNF (TypeRepMap f) 85 | 86 | instance NFData (DMapNF f) where 87 | rnf :: DMapNF f -> () 88 | rnf (DMapNF x) = 89 | rnf . map (\(Some t) -> typeRepFingerprint t) $ keys x 90 | -------------------------------------------------------------------------------- /benchmark/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Main 4 | ( main 5 | ) where 6 | 7 | import Criterion.Main (bgroup, defaultMain) 8 | 9 | import Spec (BenchSpec (..)) 10 | 11 | import qualified CacheMap 12 | import qualified CMap 13 | #if ( __GLASGOW_HASKELL__ >= 802 ) 14 | import qualified DMap 15 | #endif 16 | import qualified OptimalVector as OptVec 17 | 18 | 19 | main :: IO () 20 | main = do 21 | let specs = [("CMap", CMap.spec) 22 | ,("CacheMap", CacheMap.spec) 23 | #if ( __GLASGOW_HASKELL__ >= 802 ) 24 | , ("DMap", DMap.spec) 25 | #endif 26 | , ("OptVec", OptVec.spec) 27 | ] 28 | {- This code creates a benchmark group. Given a getter 29 | (that is test description) it gets a benchmark generation 30 | function from each module spec. Benchmark generation 31 | function takes a label and generate benchmarks. It's 32 | possible to introduce parameters passing in the same way. 33 | --} 34 | let mkGroup getBenchmark = 35 | [ mkBenchmark label 36 | | (label, spec) <- specs 37 | -- Here we use pure to force pattern matching in List 38 | -- then in case of pattern match failure `mzero` will 39 | -- be called, so benchmark will be ignored. 40 | , Just mkBenchmark <- pure $ getBenchmark spec 41 | ] 42 | defaultMain 43 | [ bgroup "lookup" $ mkGroup benchLookup 44 | , bgroup "insert" 45 | [ bgroup "10 elements to empty" $ mkGroup benchInsertSmall 46 | , bgroup "1 element to big map" $ mkGroup benchInsertBig 47 | ] 48 | , bgroup "update" 49 | [ bgroup "10 elements to empty" $ mkGroup benchUpdateSmall 50 | , bgroup "1 element to big map" $ mkGroup benchUpdateBig 51 | ] 52 | ] 53 | -------------------------------------------------------------------------------- /benchmark/OptimalVector.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} 2 | 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE PolyKinds #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | module OptimalVector 11 | ( spec 12 | ) where 13 | 14 | import Prelude hiding (lookup) 15 | 16 | import Criterion.Main (bench, env, nf) 17 | import Data.Kind (Type) 18 | import Data.Maybe (fromJust) 19 | import Data.Proxy (Proxy (..)) 20 | import Data.Typeable (Typeable) 21 | import GHC.TypeLits (type (+), KnownNat, Nat) 22 | 23 | import Data.TypeRep.OptimalVector (TF (..), TypeRepMap (..), fromList, lookup) 24 | 25 | import Spec (BenchSpec (..)) 26 | 27 | 28 | spec :: BenchSpec 29 | spec = BenchSpec 30 | { benchLookup = Just $ \name -> 31 | env mkBigMap $ \ ~bigMap -> 32 | bench name $ nf tenLookups bigMap 33 | , benchInsertSmall = Nothing -- Not implemented 34 | , benchInsertBig = Nothing -- Not implemented 35 | , benchUpdateSmall = Nothing -- Not implemented 36 | , benchUpdateBig = Nothing -- Not implemented 37 | } 38 | 39 | tenLookups 40 | :: TypeRepMap (Proxy :: Nat -> Type) 41 | -> ( Proxy 10, Proxy 20, Proxy 30, Proxy 40 42 | , Proxy 50, Proxy 60, Proxy 70, Proxy 80 43 | ) 44 | tenLookups tmap = (lp, lp, lp, lp, lp, lp, lp, lp) 45 | where 46 | lp :: forall (a::Nat). Typeable a => Proxy a 47 | lp = fromJust $ lookup tmap 48 | 49 | -- TypeRepMap of 10000 elements 50 | mkBigMap :: IO (TypeRepMap (Proxy :: Nat -> Type)) 51 | mkBigMap = pure $ fromList $ buildBigMap 10000 (Proxy :: Proxy 0) [] 52 | 53 | buildBigMap 54 | :: forall a . (KnownNat a) 55 | => Int 56 | -> Proxy (a :: Nat) 57 | -> [TF (Proxy :: Nat -> Type)] 58 | -> [TF (Proxy :: Nat -> Type)] 59 | buildBigMap 1 x = (TF x :) 60 | buildBigMap n x = (TF x :) . buildBigMap (n - 1) (Proxy :: Proxy (a + 1)) 61 | -------------------------------------------------------------------------------- /benchmark/Spec.hs: -------------------------------------------------------------------------------- 1 | {- | Specification of the benchmarks. 2 | 3 | This module keeps a list of all bencharks, this way 4 | we can group benchmark by the interesting function, not 5 | by the implementation. 6 | -} 7 | module Spec 8 | ( BenchSpec(..) 9 | ) where 10 | 11 | import Criterion (Benchmark) 12 | 13 | 14 | {- | List of benchmarks that each module should provide. 15 | If implementation can express the benchmark then it 16 | can return @Nothing@ in that benchmark. 17 | 18 | Map should contain elements from @1@ to @size of map@ 19 | inserted in ascending order (later that requirement may 20 | change). 21 | -} 22 | data BenchSpec = BenchSpec 23 | { {- | Basic lookup we look 10 values inside 10k map. 24 | 25 | Implementation may look like: 26 | 27 | @ 28 | tenLookups :: TypeRepMap (Proxy :: Nat -> *) 29 | -> ( Proxy 10, Proxy 20, Proxy 30, Proxy 40 30 | , Proxy 50, Proxy 60, Proxy 70, Proxy 80 31 | ) 32 | tenLookups tmap = (lp, lp, lp, lp, lp, lp, lp, lp) 33 | @ 34 | -} 35 | benchLookup :: Maybe (String -> Benchmark) 36 | {- ^ Insert 10 elements into an empty map. 37 | 38 | Implementation may look like: 39 | 40 | @ 41 | inserts 42 | :: forall a . (KnownNat a) 43 | => TypeRepMap (Proxy :: Nat -> *) 44 | -> Int 45 | -> Proxy (a :: Nat) 46 | -> TypeRepMap (Proxy :: Nat -> *) 47 | inserts !c 0 _ = c 48 | inserts !c n x = inserts (insert x c) (n-1) (Proxy :: Proxy (a+1)) 49 | @ 50 | -} 51 | , benchInsertSmall :: Maybe (String -> Benchmark) 52 | {- ^ Insert 10 elements into a big map. Implementation is like 53 | a small map, but should insert values into 10k elements map. 54 | -} 55 | , benchInsertBig :: Maybe (String -> Benchmark) 56 | {- ^ Insert 10 elements into map of 10 elements, where each key 57 | was already inserted in the map 58 | -} 59 | , benchUpdateSmall :: Maybe (String -> Benchmark) 60 | {- ^ Insert 10 elements into map of 10k elements, where each key 61 | was already inserted in the map 62 | -} 63 | , benchUpdateBig :: Maybe (String -> Benchmark) 64 | } 65 | -------------------------------------------------------------------------------- /benchmark/Vector.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} 2 | 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE PolyKinds #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | module Vector 11 | ( benchVector 12 | , prepareBenchVector 13 | ) where 14 | 15 | import Prelude hiding (lookup) 16 | 17 | import Control.DeepSeq (rnf) 18 | import Control.Exception (evaluate) 19 | import Criterion.Main (Benchmark, bench, bgroup, nf) 20 | import Data.Kind (Type) 21 | import Data.Maybe (fromJust) 22 | import Data.Proxy (Proxy (..)) 23 | import Data.Typeable (Typeable) 24 | import GHC.TypeLits (type (+), KnownNat, Nat) 25 | 26 | import Data.TypeRep.Vector (TF (..), TypeRepVector, fingerprints, fromList, lookup) 27 | 28 | 29 | benchVector :: Benchmark 30 | benchVector = bgroup "vector" 31 | [ bench "lookup" $ nf tenLookups bigMap 32 | -- , bench "insert new" $ whnf (\x -> rknf $ insert x bigMap) (Proxy :: Proxy 9999999999) 33 | -- , bench "update old" $ whnf (\x -> rknf $ insert x bigMap) (Proxy :: Proxy 1) 34 | ] 35 | 36 | tenLookups 37 | :: TypeRepVector (Proxy :: Nat -> Type) 38 | -> ( Proxy 10, Proxy 20, Proxy 30, Proxy 40 39 | , Proxy 50, Proxy 60, Proxy 70, Proxy 80 40 | ) 41 | tenLookups tmap = (lp, lp, lp, lp, lp, lp, lp, lp) 42 | where 43 | lp :: forall (a::Nat). Typeable a => Proxy a 44 | lp = fromJust $ lookup tmap 45 | 46 | -- TypeRepMap of 10000 elements 47 | bigMap :: TypeRepVector (Proxy :: Nat -> Type) 48 | bigMap = fromList $ buildBigMap 10000 (Proxy :: Proxy 0) [] 49 | 50 | buildBigMap 51 | :: forall a . (KnownNat a) 52 | => Int 53 | -> Proxy (a :: Nat) 54 | -> [TF (Proxy :: Nat -> Type)] 55 | -> [TF (Proxy :: Nat -> Type)] 56 | buildBigMap 1 x = (TF x :) 57 | buildBigMap n x = (TF x :) . buildBigMap (n - 1) (Proxy :: Proxy (a + 1)) 58 | 59 | rknf :: TypeRepVector f -> () 60 | rknf = rnf . fingerprints 61 | 62 | prepareBenchVector :: IO () 63 | prepareBenchVector = evaluate (rknf bigMap) 64 | -------------------------------------------------------------------------------- /src/Data/TMap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE Rank2Types #-} 3 | 4 | {- | 5 | Module : Data.TMap 6 | Copyright : (c) 2017-2022 Kowainik 7 | SPDX-License-Identifier : MPL-2.0 8 | Maintainer : Kowainik 9 | Stability : Stable 10 | Portability : Portable 11 | 12 | 'TMap' is a heterogeneous data structure similar in its essence to 13 | 'Data.Map.Map' with types as keys, where each value has the type of its key. 14 | 15 | Here is an example of a 'TMap' with a comparison to 'Data.Map.Map': 16 | 17 | @ 18 | 'Data.Map.Map' 'Prelude.String' 'Prelude.String' 'TMap' 19 | -------------------- ----------------- 20 | \"Int\" -> \"5\" 'Prelude.Int' -> 5 21 | \"Bool\" -> \"True\" 'Prelude.Bool' -> 'Prelude.True' 22 | \"Char\" -> \"\'x\'\" 'Prelude.Char' -> \'x\' 23 | @ 24 | 25 | The runtime representation of 'TMap' is an array, not a tree. This makes 26 | 'lookup' significantly more efficient. 27 | -} 28 | 29 | module Data.TMap 30 | ( -- * Map type 31 | TMap 32 | 33 | -- * Construction 34 | , empty 35 | , one 36 | 37 | -- * Modification 38 | , insert 39 | , delete 40 | , unionWith 41 | , union 42 | , intersectionWith 43 | , intersection 44 | , map 45 | , adjust 46 | , alter 47 | 48 | -- * Query 49 | , lookup 50 | , member 51 | , size 52 | , keys 53 | , keysWith 54 | , toListWith 55 | ) where 56 | 57 | import Prelude hiding (lookup, map) 58 | 59 | import Data.Functor.Identity (Identity (..)) 60 | import Data.Typeable (Typeable) 61 | import GHC.Exts (coerce) 62 | import Type.Reflection (SomeTypeRep, TypeRep) 63 | 64 | import qualified Data.TypeRepMap as F 65 | 66 | -- | 'TMap' is a special case of 'F.TypeRepMap' when the interpretation is 67 | -- 'Identity'. 68 | type TMap = F.TypeRepMap Identity 69 | 70 | {- | 71 | 72 | A 'TMap' with no values stored in it. 73 | 74 | prop> size empty == 0 75 | prop> member @a empty == False 76 | 77 | -} 78 | empty :: TMap 79 | empty = F.empty 80 | {-# INLINE empty #-} 81 | 82 | {- | 83 | 84 | Construct a 'TMap' with a single element. 85 | 86 | prop> size (one x) == 1 87 | prop> member @a (one (x :: a)) == True 88 | 89 | -} 90 | one :: forall a . Typeable a => a -> TMap 91 | one x = coerce (F.one @a @Identity $ coerce x) 92 | {-# INLINE one #-} 93 | 94 | {- | 95 | 96 | Insert a value into a 'TMap'. 97 | TMap optimizes for fast reads rather than inserts, as a trade-off inserts are @O(n)@. 98 | 99 | prop> size (insert v tm) >= size tm 100 | prop> member @a (insert (x :: a) tm) == True 101 | 102 | -} 103 | insert :: forall a . Typeable a => a -> TMap -> TMap 104 | insert x = coerce (F.insert @a @Identity $ coerce x) 105 | {-# INLINE insert #-} 106 | 107 | {- | Delete a value from a 'TMap'. 108 | 109 | TMap optimizes for fast reads rather than modifications, as a trade-off deletes are @O(n)@, 110 | with an @O(log(n))@ optimization for when the element is already missing. 111 | 112 | prop> size (delete @a tm) <= size tm 113 | prop> member @a (delete @a tm) == False 114 | 115 | >>> tm = delete @Bool $ insert True $ one 'a' 116 | >>> size tm 117 | 1 118 | >>> member @Bool tm 119 | False 120 | >>> member @Char tm 121 | True 122 | -} 123 | delete :: forall a . Typeable a => TMap -> TMap 124 | delete = F.delete @a @Identity 125 | {-# INLINE delete #-} 126 | 127 | -- | The union of two 'TMap's using a combining function. 128 | unionWith :: (forall x . Typeable x => x -> x -> x) -> TMap -> TMap -> TMap 129 | unionWith f = F.unionWith fId 130 | where 131 | fId :: forall y . Typeable y => Identity y -> Identity y -> Identity y 132 | fId y1 y2 = Identity $ f (coerce y1) (coerce y2) 133 | {-# INLINE unionWith #-} 134 | 135 | -- | The (left-biased) union of two 'TMap's. It prefers the first map when 136 | -- duplicate keys are encountered, i.e. @'union' == 'unionWith' const@. 137 | union :: TMap -> TMap -> TMap 138 | union = F.union 139 | {-# INLINE union #-} 140 | 141 | -- | The intersection of two 'TMap's using a combining function. 142 | -- 143 | -- @O(n + m)@ 144 | intersectionWith :: (forall x . Typeable x => x -> x -> x) -> TMap -> TMap -> TMap 145 | intersectionWith f = F.intersectionWith fId 146 | where 147 | fId :: forall y . Typeable y => Identity y -> Identity y -> Identity y 148 | fId y1 y2 = f (coerce y1) (coerce y2) 149 | {-# INLINE intersectionWith #-} 150 | 151 | -- | The intersection of two 'TMap's. 152 | -- It keeps all values from the first map whose keys are present in the second. 153 | -- 154 | -- @O(n + m)@ 155 | intersection :: TMap -> TMap -> TMap 156 | intersection = F.intersection 157 | {-# INLINE intersection #-} 158 | 159 | {- | Lookup a value of the given type in a 'TMap'. 160 | 161 | >>> x = lookup $ insert (11 :: Int) empty 162 | >>> x :: Maybe Int 163 | Just 11 164 | >>> x :: Maybe () 165 | Nothing 166 | -} 167 | lookup :: forall a . Typeable a => TMap -> Maybe a 168 | lookup = coerce (F.lookup @a @Identity) 169 | {-# INLINE lookup #-} 170 | 171 | {- | Check if a value of the given type is present in a 'TMap'. 172 | 173 | >>> member @Char $ one 'a' 174 | True 175 | >>> member @Bool $ one 'a' 176 | False 177 | -} 178 | member :: forall a . Typeable a => TMap -> Bool 179 | member = F.member @a @Identity 180 | {-# INLINE member #-} 181 | 182 | -- | Get the amount of elements in a 'TMap'. 183 | size :: TMap -> Int 184 | size = F.size 185 | {-# INLINE size #-} 186 | 187 | -- | Returns the list of 'SomeTypeRep's from keys. 188 | keys :: TMap -> [SomeTypeRep] 189 | keys = F.keys 190 | {-# INLINE keys #-} 191 | 192 | -- | Return the list of keys by wrapping them with a user-provided function. 193 | keysWith :: (forall a . TypeRep a -> r) -> TMap -> [r] 194 | keysWith = F.keysWith 195 | {-# INLINE keysWith #-} 196 | 197 | -- | Return the list of key-value pairs by wrapping them with a user-provided function. 198 | toListWith :: (forall a . Typeable a => a -> r) -> TMap -> [r] 199 | toListWith f = F.toListWith (f . runIdentity) 200 | {-# INLINE toListWith #-} 201 | 202 | -- | Map a function over the values. 203 | map :: (forall a . Typeable a => a -> a) -> TMap -> TMap 204 | map f = F.hoistWithKey (liftToIdentity f) 205 | {-# INLINE map #-} 206 | 207 | -- | Update a value with the result of the provided function. 208 | adjust :: Typeable a => (a -> a) -> TMap -> TMap 209 | adjust f = F.adjust (liftToIdentity f) 210 | {-# INLINE adjust #-} 211 | 212 | -- | Updates a value at a specific key, whether or not it exists. 213 | -- This can be used to insert, delete, or update a value of a given type in the map. 214 | alter :: Typeable a => (Maybe a -> Maybe a) -> TMap -> TMap 215 | alter f = F.alter (liftF f) 216 | where 217 | liftF :: forall a . (Maybe a -> Maybe a) -> Maybe (Identity a) -> Maybe (Identity a) 218 | liftF = coerce 219 | {-# INLINE alter #-} 220 | 221 | liftToIdentity :: forall a . (a -> a) -> Identity a -> Identity a 222 | liftToIdentity = coerce 223 | -------------------------------------------------------------------------------- /src/Data/TypeRepMap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | {- | 4 | Module : Data.TypeRepMap 5 | Copyright : (c) 2017-2022 Kowainik 6 | SPDX-License-Identifier : MPL-2.0 7 | Maintainer : Kowainik 8 | Stability : Stable 9 | Portability : Portable 10 | 11 | A version of 'Data.TMap.TMap' parametrized by an interpretation @f@. This 12 | sort of parametrization may be familiar to users of @vinyl@ records. 13 | 14 | @'TypeRepMap' f@ is a more efficient replacement for @DMap 15 | 'Type.Reflection.TypeRep' f@ (where @DMap@ is from the @dependent-map@ 16 | package). 17 | 18 | Here is an example of using 'Prelude.Maybe' as an interpretation, with a 19 | comparison to 'Data.TMap.TMap': 20 | 21 | @ 22 | 'Data.TMap.TMap' 'TypeRepMap' 'Prelude.Maybe' 23 | -------------- ------------------- 24 | Int -> 5 Int -> Just 5 25 | Bool -> True Bool -> Nothing 26 | Char -> \'x\' Char -> Just \'x\' 27 | @ 28 | 29 | In fact, a 'Data.TMap.TMap' is defined as 'TypeRepMap' 30 | 'Data.Functor.Identity'. 31 | 32 | Since 'Type.Reflection.TypeRep' is poly-kinded, the interpretation can use 33 | any kind for the keys. For instance, we can use the 'GHC.TypeLits.Symbol' 34 | kind to use 'TypeRepMap' as an extensible record: 35 | 36 | @ 37 | newtype Field name = F (FType name) 38 | 39 | type family FType (name :: Symbol) :: Type 40 | type instance FType "radius" = Double 41 | type instance FType "border-color" = RGB 42 | type instance FType "border-width" = Double 43 | 44 | 'TypeRepMap' Field 45 | -------------------------------------- 46 | "radius" -> F 5.7 47 | "border-color" -> F (rgb 148 0 211) 48 | "border-width" -> F 0.5 49 | @ 50 | -} 51 | 52 | module Data.TypeRepMap 53 | ( -- * Map type 54 | TypeRepMap() 55 | 56 | -- * Construction 57 | , empty 58 | , one 59 | 60 | -- * Modification 61 | , insert 62 | , delete 63 | , adjust 64 | , alter 65 | , hoist 66 | , hoistA 67 | , hoistWithKey 68 | , unionWith 69 | , union 70 | , intersectionWith 71 | , intersection 72 | 73 | -- * Query 74 | , lookup 75 | , member 76 | , size 77 | , keys 78 | , keysWith 79 | , toListWith 80 | 81 | -- * 'IsList' 82 | , WrapTypeable (..) 83 | ) where 84 | 85 | import Data.TypeRepMap.Internal 86 | -------------------------------------------------------------------------------- /src/Data/TypeRepMap/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-export-lists #-} 2 | 3 | {-# LANGUAGE AllowAmbiguousTypes #-} 4 | {-# LANGUAGE BangPatterns #-} 5 | {-# LANGUAGE CPP #-} 6 | {-# LANGUAGE DataKinds #-} 7 | {-# LANGUAGE GADTs #-} 8 | {-# LANGUAGE InstanceSigs #-} 9 | {-# LANGUAGE MagicHash #-} 10 | {-# LANGUAGE PolyKinds #-} 11 | {-# LANGUAGE Rank2Types #-} 12 | {-# LANGUAGE RoleAnnotations #-} 13 | {-# LANGUAGE TypeFamilies #-} 14 | {-# LANGUAGE TypeInType #-} 15 | {-# LANGUAGE ViewPatterns #-} 16 | 17 | #if __GLASGOW_HASKELL__ >= 806 18 | {-# LANGUAGE QuantifiedConstraints #-} 19 | #endif 20 | 21 | -- {-# OPTIONS_GHC -ddump-simpl -dsuppress-idinfo -dsuppress-coercions -dsuppress-type-applications -dsuppress-uniques -dsuppress-module-prefixes #-} 22 | 23 | {- | 24 | Module : Data.TypeRepMap.Internal 25 | Copyright : (c) 2017-2022 Kowainik 26 | SPDX-License-Identifier : MPL-2.0 27 | Maintainer : Kowainik 28 | Stability : Stable 29 | Portability : Portable 30 | 31 | Internal API for 'TypeRepMap' and operations on it. The functions here do 32 | not have any stability guarantees and can change between minor versions. 33 | 34 | If you need to use this module for purposes other than tests, 35 | create an issue. 36 | -} 37 | 38 | #include "MachDeps.h" 39 | 40 | module Data.TypeRepMap.Internal where 41 | 42 | import Prelude hiding (lookup) 43 | 44 | import Control.DeepSeq 45 | import Control.Monad.ST (ST, runST) 46 | import Control.Monad.Zip (mzip) 47 | import Data.Function (on) 48 | import Data.Kind (Type) 49 | import Data.List (intercalate, nubBy) 50 | import Data.Maybe (fromMaybe) 51 | import Data.Primitive.Array (Array, MutableArray, indexArray, mapArray', sizeofArray, thawArray, 52 | unsafeFreezeArray, writeArray) 53 | import Data.Primitive.PrimArray (MutablePrimArray, PrimArray, indexPrimArray, newPrimArray, 54 | primArrayFromListN, primArrayToList, sizeofPrimArray, 55 | unsafeFreezePrimArray, writePrimArray) 56 | import Data.Semigroup (All (..), Semigroup (..)) 57 | import Data.Type.Equality (TestEquality (..), (:~:) (..)) 58 | import GHC.Base (Any, Int (..), Int#, (*#), (+#), (<#)) 59 | #if MIN_VERSION_base(4,17,0) 60 | import GHC.Base (word64ToWord#) 61 | #endif 62 | import GHC.Exts (IsList (..), inline, sortWith) 63 | import GHC.Fingerprint (Fingerprint (..)) 64 | #if WORD_SIZE_IN_BITS >= 64 65 | import GHC.Prim (eqWord#, ltWord#) 66 | #else 67 | import GHC.IntWord64 (eqWord64#, ltWord64#) 68 | #define eqWord eqWord64 69 | #define ltWord ltWord64 70 | #endif 71 | import GHC.Word (Word64 (..)) 72 | import Type.Reflection (SomeTypeRep (..), TypeRep, Typeable, typeRep, withTypeable) 73 | import Type.Reflection.Unsafe (typeRepFingerprint) 74 | import Unsafe.Coerce (unsafeCoerce) 75 | 76 | import qualified GHC.Exts as GHC (fromList, toList) 77 | 78 | {- | 79 | 80 | 'TypeRepMap' is a heterogeneous data structure similar in its essence to 81 | 'Data.Map.Map' with types as keys, where each value has the type of its key. In 82 | addition to that, each value is wrapped in an interpretation @f@. 83 | 84 | Here is an example of using 'Prelude.Maybe' as an interpretation, with a 85 | comparison to 'Data.Map.Map': 86 | 87 | @ 88 | 'Data.Map.Map' 'Prelude.String' ('Prelude.Maybe' 'Prelude.String') 'TypeRepMap' 'Prelude.Maybe' 89 | --------------------------- --------------------- 90 | \"Int\" -> Just \"5\" 'Prelude.Int' -> Just 5 91 | \"Bool\" -> Just \"True\" 'Prelude.Bool' -> Just 'Prelude.True' 92 | \"Char\" -> Nothing 'Prelude.Char' -> Nothing 93 | @ 94 | 95 | The runtime representation of 'TypeRepMap' is an array, not a tree. This makes 96 | 'lookup' significantly more efficient. 97 | 98 | -} 99 | type role TypeRepMap representational 100 | data TypeRepMap (f :: k -> Type) = 101 | TypeRepMap 102 | { fingerprintAs :: {-# UNPACK #-} !(PrimArray Word64) -- ^ first components of key fingerprints 103 | , fingerprintBs :: {-# UNPACK #-} !(PrimArray Word64) -- ^ second components of key fingerprints 104 | , trAnys :: {-# UNPACK #-} !(Array Any) -- ^ values stored in the map 105 | , trKeys :: {-# UNPACK #-} !(Array Any) -- ^ typerep keys 106 | } 107 | -- ^ an unsafe constructor for 'TypeRepMap' 108 | 109 | instance NFData (TypeRepMap f) where 110 | rnf x = rnf (keys x) `seq` () 111 | 112 | -- | Shows only keys. 113 | instance Show (TypeRepMap f) where 114 | show TypeRepMap{..} = "TypeRepMap [" ++ showKeys ++ "]" 115 | where 116 | showKeys :: String 117 | showKeys = intercalate ", " $ toList $ mapArray' (show . anyToTypeRep) trKeys 118 | 119 | -- | Uses 'union' to combine 'TypeRepMap's. 120 | instance Semigroup (TypeRepMap f) where 121 | (<>) :: TypeRepMap f -> TypeRepMap f -> TypeRepMap f 122 | (<>) = union 123 | {-# INLINE (<>) #-} 124 | 125 | instance Monoid (TypeRepMap f) where 126 | mempty = TypeRepMap mempty mempty mempty mempty 127 | mappend = (<>) 128 | {-# INLINE mempty #-} 129 | {-# INLINE mappend #-} 130 | 131 | #if __GLASGOW_HASKELL__ >= 806 132 | instance (forall a. Typeable a => Eq (f a)) => Eq (TypeRepMap f) where 133 | tm1 == tm2 = size tm1 == size tm2 && go 0 134 | where 135 | go :: Int -> Bool 136 | go i 137 | | i == size tm1 = True 138 | | otherwise = case testEquality tr1i tr2i of 139 | Nothing -> False 140 | Just Refl -> repEq tr1i (fromAny tv1i) (fromAny tv2i) && go (i + 1) 141 | where 142 | tr1i :: TypeRep x 143 | tr1i = anyToTypeRep $ indexArray (trKeys tm1) i 144 | 145 | tr2i :: TypeRep y 146 | tr2i = anyToTypeRep $ indexArray (trKeys tm2) i 147 | 148 | tv1i, tv2i :: Any 149 | tv1i = indexArray (trAnys tm1) i 150 | tv2i = indexArray (trAnys tm2) i 151 | 152 | repEq :: TypeRep x -> f x -> f x -> Bool 153 | repEq tr = withTypeable tr (==) 154 | #endif 155 | 156 | -- | Returns the list of 'Fingerprint's from 'TypeRepMap'. 157 | toFingerprints :: TypeRepMap f -> [Fingerprint] 158 | toFingerprints TypeRepMap{..} = 159 | zipWith Fingerprint (GHC.toList fingerprintAs) (GHC.toList fingerprintBs) 160 | 161 | {- | 162 | 163 | A 'TypeRepMap' with no values stored in it. 164 | 165 | prop> size empty == 0 166 | prop> member @a empty == False 167 | 168 | -} 169 | empty :: TypeRepMap f 170 | empty = mempty 171 | {-# INLINE empty #-} 172 | 173 | {- | 174 | 175 | Construct a 'TypeRepMap' with a single element. 176 | 177 | prop> size (one x) == 1 178 | prop> member @a (one (x :: f a)) == True 179 | 180 | -} 181 | one :: forall a f . Typeable a => f a -> TypeRepMap f 182 | one x = TypeRepMap (primArrayFromListN 1 [fa]) 183 | (primArrayFromListN 1 [fb]) 184 | (pure @Array v) 185 | (pure @Array k) 186 | where 187 | (Fingerprint fa fb, v, k) = (calcFp @a, toAny x, unsafeCoerce $ typeRep @a) 188 | {-# INLINE one #-} 189 | 190 | {- | 191 | 192 | Insert a value into a 'TypeRepMap'. 193 | TypeRepMap optimizes for fast reads rather than inserts, as a trade-off inserts are @O(n)@. 194 | 195 | prop> size (insert v tm) >= size tm 196 | prop> member @a (insert (x :: f a) tm) == True 197 | 198 | -} 199 | insert :: forall a f . Typeable a => f a -> TypeRepMap f -> TypeRepMap f 200 | insert x m 201 | | size m == 0 = one x 202 | | otherwise = case cachedBinarySearch (typeFp @a) (fingerprintAs m) (fingerprintBs m) of 203 | Nothing -> union m $ one x 204 | Just i -> m {trAnys = changeAnyArr i (trAnys m)} 205 | where 206 | changeAnyArr :: Int -> Array Any -> Array Any 207 | changeAnyArr i trAs = runST $ do 208 | let n = sizeofArray trAs 209 | mutArr <- thawArray trAs 0 n 210 | writeArray mutArr i $ toAny x 211 | unsafeFreezeArray mutArr 212 | {-# INLINE insert #-} 213 | 214 | -- Extract the kind of a type. We use it to work around lack of syntax for 215 | -- inferred type variables (which are not subject to type applications). 216 | type KindOf (a :: k) = k 217 | 218 | type ArgKindOf (f :: k -> l) = k 219 | 220 | {- | Delete a value from a 'TypeRepMap'. 221 | 222 | TypeRepMap optimizes for fast reads rather than modifications, as a trade-off deletes are 223 | @O(n)@, with an @O(log(n))@ optimization for when the element is already missing. 224 | 225 | prop> size (delete @a tm) <= size tm 226 | prop> member @a (delete @a tm) == False 227 | 228 | >>> tm = delete @Bool $ insert (Just True) $ one (Just 'a') 229 | >>> size tm 230 | 1 231 | >>> member @Bool tm 232 | False 233 | >>> member @Char tm 234 | True 235 | -} 236 | delete :: forall a (f :: KindOf a -> Type) . Typeable a => TypeRepMap f -> TypeRepMap f 237 | delete m 238 | -- Lookups are fast, so check if we even have the element first. 239 | | not (member @a m) = m 240 | -- We know we have the element, If the map has exactly one element, we can return the empty map 241 | | size m == 1 = empty 242 | -- Otherwise, filter out the element in linear time. 243 | | otherwise = fromSortedTriples . deleteFirst ((== typeFp @a) . fst3) . toSortedTriples $ m 244 | {-# INLINE delete #-} 245 | 246 | deleteFirst :: (a -> Bool) -> [a] -> [a] 247 | deleteFirst _ [] = [] 248 | deleteFirst p (x : xs) = if p x then xs else x : deleteFirst p xs 249 | 250 | {- | 251 | Update a value at a specific key with the result of the provided function. 252 | When the key is not a member of the map, the original map is returned. 253 | 254 | >>> trmap = fromList @(TypeRepMap Identity) [WrapTypeable $ Identity "a"] 255 | >>> lookup @String $ adjust (fmap (++ "ww")) trmap 256 | Just (Identity "aww") 257 | -} 258 | adjust :: forall a f . Typeable a => (f a -> f a) -> TypeRepMap f -> TypeRepMap f 259 | adjust fun = alter (fmap fun) 260 | {-# INLINE adjust #-} 261 | 262 | {- | 263 | Updates a value at a specific key, whether or not it exists. 264 | This can be used to insert, delete, or update a value of a given type in the map. 265 | 266 | >>> func = (\case Nothing -> Just (Identity "new"); Just (Identity s) -> Just (Identity (reverse s))) 267 | >>> lookup @String $ alter func empty 268 | Just (Identity "new") 269 | >>> trmap = fromList @(TypeRepMap Identity) [WrapTypeable $ Identity "helllo"] 270 | >>> lookup @String $ alter func trmap 271 | >>> Just (Identity "olleh") 272 | -} 273 | alter :: forall a f . Typeable a => (Maybe (f a) -> Maybe (f a)) -> TypeRepMap f -> TypeRepMap f 274 | alter fun tr = case cachedBinarySearch (typeFp @a) (fingerprintAs tr) (fingerprintBs tr) of 275 | Nothing -> 276 | case (fun Nothing) of 277 | Nothing -> tr 278 | Just v -> insert v tr 279 | Just i -> 280 | case fun (Just . fromAny $ indexArray (trAnys tr) i) of 281 | Nothing -> delete @a tr 282 | Just v -> tr{trAnys = replaceAnyAt i (toAny v) (trAnys tr)} 283 | where 284 | replaceAnyAt :: Int -> Any -> Array Any -> Array Any 285 | replaceAnyAt i v trAs = runST $ do 286 | let n = sizeofArray trAs 287 | mutArr <- thawArray trAs 0 n 288 | writeArray mutArr i v 289 | unsafeFreezeArray mutArr 290 | {-# INLINE alter #-} 291 | 292 | {- | Map over the elements of a 'TypeRepMap'. 293 | 294 | >>> tm = insert (Identity True) $ one (Identity 'a') 295 | >>> lookup @Bool tm 296 | Just (Identity True) 297 | >>> lookup @Char tm 298 | Just (Identity 'a') 299 | >>> tm2 = hoist ((:[]) . runIdentity) tm 300 | >>> lookup @Bool tm2 301 | Just [True] 302 | >>> lookup @Char tm2 303 | Just "a" 304 | -} 305 | hoist :: (forall x. f x -> g x) -> TypeRepMap f -> TypeRepMap g 306 | hoist f (TypeRepMap as bs ans ks) = TypeRepMap as bs (mapArray' (toAny . f . fromAny) ans) ks 307 | {-# INLINE hoist #-} 308 | 309 | hoistA :: (Applicative t) => (forall x. f x -> t (g x)) -> TypeRepMap f -> t (TypeRepMap g) 310 | hoistA f (TypeRepMap as bs (toList -> ans) ks) = (\l -> TypeRepMap as bs (fromList $ map toAny l) ks) 311 | <$> traverse (f . fromAny) ans 312 | {-# INLINE hoistA #-} 313 | 314 | hoistWithKey :: forall f g. (forall x. Typeable x => f x -> g x) -> TypeRepMap f -> TypeRepMap g 315 | hoistWithKey f (TypeRepMap as bs ans ks) = TypeRepMap as bs newAns ks 316 | where 317 | newAns = mapArray' mapAns (mzip ans ks) 318 | mapAns (a, k) = toAny $ withTr (unsafeCoerce k) $ fromAny a 319 | 320 | withTr :: forall x. TypeRep x -> f x -> g x 321 | withTr t = withTypeable t f 322 | {-# INLINE hoistWithKey #-} 323 | 324 | -- | The union of two 'TypeRepMap's using a combining function for conflicting entries. @O(n + m)@ 325 | unionWith :: forall f. (forall x. Typeable x => f x -> f x -> f x) -> TypeRepMap f -> TypeRepMap f -> TypeRepMap f 326 | unionWith f ma mb = do 327 | fromSortedTriples $ mergeMaps (toSortedTriples ma) (toSortedTriples mb) 328 | where 329 | f' :: forall x. TypeRep x -> f x -> f x -> f x 330 | f' tr = withTypeable tr f 331 | 332 | combine :: (Fingerprint, Any, Any) -> (Fingerprint, Any, Any) -> (Fingerprint, Any, Any) 333 | combine (fp, av, ak) (_, bv, _) = (fp, toAny $ f' (fromAny ak) (fromAny av) (fromAny bv), ak) 334 | 335 | -- Merges two typrepmaps into a sorted, dedup'd list of triples. 336 | -- Using 'toSortedTriples' allows us to assume the triples are sorted by fingerprint, 337 | -- Given O(n) performance from 'toSortedTriples', and given that we can merge-sort in 338 | -- O(n + m) time, then can '.fromSortedTriples' back into cachedBinarySearch order in O(n + m) 339 | -- that gives a total of O(n + m). 340 | mergeMaps :: [(Fingerprint, Any, Any)] -> [(Fingerprint, Any, Any)] -> [(Fingerprint, Any, Any)] 341 | -- We've addressed all elements from both maps 342 | mergeMaps as [] = as 343 | mergeMaps [] bs = bs 344 | -- Merge 345 | mergeMaps (a@(af, _, _) : as) (b@(bf, _, _) : bs) = 346 | case compare af bf of 347 | -- Fingerprints are equal, union the elements using our function 348 | -- If the incoming maps were de-duped, there shouldn't be any other equivalent 349 | -- fingerprints 350 | EQ -> combine a b : mergeMaps as bs 351 | -- First fingerprint must not be in the second map or we would have seen it by now 352 | -- Add it to the result as-is 353 | LT -> a : mergeMaps as (b : bs) 354 | -- Second fingerprint must not be in the first map or we would have seen it by now 355 | -- Add it to the result as-is 356 | GT -> b : mergeMaps (a:as) bs 357 | {-# INLINE unionWith #-} 358 | 359 | -- | The (left-biased) union of two 'TypeRepMap's in @O(n + m)@. It prefers the first map when 360 | -- duplicate keys are encountered, i.e. @'union' == 'unionWith' const@. 361 | union :: TypeRepMap f -> TypeRepMap f -> TypeRepMap f 362 | union = unionWith const 363 | {-# INLINE union #-} 364 | 365 | -- | The 'intersection' of two 'TypeRepMap's using a combining function 366 | -- 367 | -- @O(n + m)@ 368 | intersectionWith :: forall f. (forall x. Typeable x => f x -> f x -> f x) -> TypeRepMap f -> TypeRepMap f -> TypeRepMap f 369 | intersectionWith f ma mb = 370 | fromSortedTriples $ mergeMaps (toSortedTriples ma) (toSortedTriples mb) 371 | where 372 | f' :: forall x. TypeRep x -> f x -> f x -> f x 373 | f' tr = withTypeable tr f 374 | 375 | combine :: (Fingerprint, Any, Any) -> (Fingerprint, Any, Any) -> (Fingerprint, Any, Any) 376 | combine (fp, av, ak) (_, bv, _) = (fp, toAny $ f' (fromAny ak) (fromAny av) (fromAny bv), ak) 377 | 378 | -- Merges two typrepmaps into a sorted, dedup'd list of triples. 379 | mergeMaps :: [(Fingerprint, Any, Any)] -> [(Fingerprint, Any, Any)] -> [(Fingerprint, Any, Any)] 380 | -- If either list is empty, the intersection must be finished. 381 | mergeMaps _ [] = [] 382 | mergeMaps [] _ = [] 383 | -- Merge the two maps considering one element at a time. 384 | mergeMaps (a@(af, _, _) : as) (b@(bf, _, _) : bs) = 385 | case compare af bf of 386 | -- Fingerprints are equal, union the elements using our function 387 | -- If the incoming maps were de-duped, there shouldn't be any other equivalent 388 | -- fingerprints 389 | EQ -> combine a b : mergeMaps as bs 390 | -- First fingerprint must not be in the second map or we would have seen it by now 391 | -- Skip it an move on 392 | LT -> mergeMaps as (b : bs) 393 | -- Second fingerprint must not be in the first map or we would have seen it by now 394 | -- Skip it an move on 395 | GT -> mergeMaps (a:as) bs 396 | {-# INLINE intersectionWith #-} 397 | 398 | -- | The intersection of two 'TypeRepMap's. 399 | -- It keeps all values from the first map whose keys are present in the second. 400 | -- 401 | -- @O(n + m)@ 402 | intersection :: TypeRepMap f -> TypeRepMap f -> TypeRepMap f 403 | intersection = intersectionWith const 404 | {-# INLINE intersection #-} 405 | 406 | 407 | {- | Check if a value of the given type is present in a 'TypeRepMap'. 408 | 409 | >>> member @Char $ one (Identity 'a') 410 | True 411 | >>> member @Bool $ one (Identity 'a') 412 | False 413 | -} 414 | member :: forall a (f :: KindOf a -> Type) . Typeable a => TypeRepMap f -> Bool 415 | member tm = case lookup @a tm of 416 | Nothing -> False 417 | Just _ -> True 418 | {-# INLINE member #-} 419 | 420 | {- | Lookup a value of the given type in a 'TypeRepMap'. 421 | 422 | >>> x = lookup $ insert (Identity (11 :: Int)) empty 423 | >>> x :: Maybe (Identity Int) 424 | Just (Identity 11) 425 | >>> x :: Maybe (Identity ()) 426 | Nothing 427 | -} 428 | lookup :: forall a f . Typeable a => TypeRepMap f -> Maybe (f a) 429 | lookup tVect = fromAny . (trAnys tVect `indexArray`) 430 | <$> cachedBinarySearch (typeFp @a) 431 | (fingerprintAs tVect) 432 | (fingerprintBs tVect) 433 | {-# INLINE lookup #-} 434 | 435 | -- | Get the amount of elements in a 'TypeRepMap'. 436 | size :: TypeRepMap f -> Int 437 | size = sizeofPrimArray . fingerprintAs 438 | {-# INLINE size #-} 439 | 440 | -- | Return the list of 'SomeTypeRep' from the keys. 441 | keys :: TypeRepMap f -> [SomeTypeRep] 442 | keys = keysWith SomeTypeRep 443 | {-# INLINE keys #-} 444 | 445 | -- | Return the list of keys by wrapping them with a user-provided function. 446 | keysWith :: (forall (a :: ArgKindOf f). TypeRep a -> r) -> TypeRepMap f -> [r] 447 | keysWith f TypeRepMap{..} = f . anyToTypeRep <$> toList trKeys 448 | {-# INLINE keysWith #-} 449 | 450 | -- | Return the list of key-value pairs by wrapping them with a user-provided function. 451 | toListWith :: forall f r . (forall (a :: ArgKindOf f) . Typeable a => f a -> r) -> TypeRepMap f -> [r] 452 | toListWith f = map toF . toTriples 453 | where 454 | withTypeRep :: TypeRep a -> f a -> r 455 | withTypeRep tr an = withTypeable tr $ f an 456 | toF (_, an, k) = withTypeRep (unsafeCoerce k) (fromAny an) 457 | 458 | -- | Binary searched based on this article 459 | -- http://bannalia.blogspot.com/2015/06/cache-friendly-binary-search.html 460 | -- with modification for our two-vector search case. 461 | cachedBinarySearch :: Fingerprint -> PrimArray Word64 -> PrimArray Word64 -> Maybe Int 462 | cachedBinarySearch (Fingerprint (W64# a) (W64# b)) fpAs fpBs = inline (go 0#) 463 | where 464 | go :: Int# -> Maybe Int 465 | #if MIN_VERSION_base(4,17,0) 466 | go i = case i <# len of 467 | 0# -> Nothing 468 | _ -> 469 | let !(W64# (word64ToWord# -> valA)) = indexPrimArray fpAs (I# i) 470 | !a' = word64ToWord# a 471 | !b' = word64ToWord# b 472 | in 473 | case a' `ltWord#` valA of 474 | 0# -> 475 | case a' `eqWord#` valA of 476 | 0# -> go (2# *# i +# 2#) 477 | _ -> 478 | let !(W64# valB) = indexPrimArray fpBs (I# i) 479 | in 480 | case word64ToWord# b `eqWord#` word64ToWord# valB of 481 | 0# -> 482 | case b' `ltWord#` word64ToWord# valB of 483 | 0# -> go (2# *# i +# 2#) 484 | _ -> go (2# *# i +# 1#) 485 | _ -> Just (I# i) 486 | _ -> go (2# *# i +# 1#) 487 | #else 488 | go i = case i <# len of 489 | 0# -> Nothing 490 | _ -> 491 | let !(W64# valA) = indexPrimArray fpAs (I# i) 492 | in 493 | case a `ltWord#` valA of 494 | 0# -> 495 | case a `eqWord#` valA of 496 | 0# -> go (2# *# i +# 2#) 497 | _ -> 498 | let !(W64# valB) = indexPrimArray fpBs (I# i) 499 | in 500 | case b `eqWord#` valB of 501 | 0# -> 502 | case b `ltWord#` valB of 503 | 0# -> go (2# *# i +# 2#) 504 | _ -> go (2# *# i +# 1#) 505 | _ -> Just (I# i) 506 | _ -> go (2# *# i +# 1#) 507 | #endif 508 | 509 | len :: Int# 510 | len = let !(I# l) = sizeofPrimArray fpAs in l 511 | {-# INLINE cachedBinarySearch #-} 512 | 513 | ---------------------------------------------------------------------------- 514 | -- Internal functions 515 | ---------------------------------------------------------------------------- 516 | 517 | toAny :: f a -> Any 518 | toAny = unsafeCoerce 519 | 520 | fromAny :: Any -> f a 521 | fromAny = unsafeCoerce 522 | 523 | anyToTypeRep :: Any -> TypeRep f 524 | anyToTypeRep = unsafeCoerce 525 | 526 | typeFp :: forall a . Typeable a => Fingerprint 527 | typeFp = typeRepFingerprint $ typeRep @a 528 | {-# INLINE typeFp #-} 529 | 530 | toTriples :: TypeRepMap f -> [(Fingerprint, Any, Any)] 531 | toTriples tm = zip3 (toFingerprints tm) (GHC.toList $ trAnys tm) (GHC.toList $ trKeys tm) 532 | 533 | -- | Efficiently get sorted triples from a map in O(n) time 534 | -- 535 | -- We assume the incoming TypeRepMap is already sorted into 'cachedBinarySearch' order using fromSortedList. 536 | -- Then we can construct the index mapping from the "cached" ordering into monotonically 537 | -- increasing order using 'generateOrderMapping' with the length of the TRM. This takes @O(n). 538 | -- We then pull those indexes from the source TRM to get the sorted triples in a total of @O(n). 539 | toSortedTriples :: TypeRepMap f -> [(Fingerprint, Any, Any)] 540 | toSortedTriples tm = trip <$> ordering 541 | where 542 | trip i = ( Fingerprint (indexPrimArray (fingerprintAs tm) i) (indexPrimArray (fingerprintBs tm) i) 543 | , indexArray (trAnys tm) i 544 | , indexArray (trKeys tm) i) 545 | ordering :: [ Int ] 546 | ordering = generateOrderMapping (size tm) 547 | 548 | nubByFst :: (Eq a) => [(a, b, c)] -> [(a, b, c)] 549 | nubByFst = nubBy ((==) `on` fst3) 550 | 551 | fst3 :: (a, b, c) -> a 552 | fst3 (a, _, _) = a 553 | 554 | ---------------------------------------------------------------------------- 555 | -- Functions for testing and benchmarking 556 | ---------------------------------------------------------------------------- 557 | 558 | -- | Existential wrapper around 'Typeable' indexed by @f@ type parameter. 559 | -- Useful for 'TypeRepMap' structure creation form list of 'WrapTypeable's. 560 | data WrapTypeable f where 561 | WrapTypeable :: Typeable a => f a -> WrapTypeable f 562 | 563 | instance Show (WrapTypeable f) where 564 | show (WrapTypeable (_ :: f a)) = show $ calcFp @a 565 | 566 | {- | 567 | 568 | prop> fromList . toList == 'id' 569 | 570 | Creates 'TypeRepMap' from a list of 'WrapTypeable's. 571 | 572 | >>> show $ fromList [WrapTypeable $ Identity True, WrapTypeable $ Identity 'a'] 573 | TypeRepMap [Bool, Char] 574 | 575 | 576 | -} 577 | instance IsList (TypeRepMap f) where 578 | type Item (TypeRepMap f) = WrapTypeable f 579 | 580 | fromList :: [WrapTypeable f] -> TypeRepMap f 581 | fromList = fromTriples . map (\x -> (fp x, an x, k x)) 582 | where 583 | fp :: WrapTypeable f -> Fingerprint 584 | fp (WrapTypeable (_ :: f a)) = calcFp @a 585 | 586 | an :: WrapTypeable f -> Any 587 | an (WrapTypeable x) = toAny x 588 | 589 | k :: WrapTypeable f -> Any 590 | k (WrapTypeable (_ :: f a)) = unsafeCoerce $ typeRep @a 591 | 592 | toList :: TypeRepMap f -> [WrapTypeable f] 593 | toList = toListWith WrapTypeable 594 | 595 | calcFp :: forall a . Typeable a => Fingerprint 596 | calcFp = typeRepFingerprint $ typeRep @a 597 | 598 | fromTriples :: [(Fingerprint, Any, Any)] -> TypeRepMap f 599 | fromTriples = fromSortedTriples . sortWith fst3 . nubByFst 600 | 601 | fromSortedTriples :: [(Fingerprint, Any, Any)] -> TypeRepMap f 602 | fromSortedTriples kvs = TypeRepMap (GHC.fromList fpAs) (GHC.fromList fpBs) (GHC.fromList ans) (GHC.fromList ks) 603 | where 604 | (fpAs, fpBs) = unzip $ map (\(Fingerprint a b) -> (a, b)) fps 605 | (fps, ans, ks) = unzip3 $ fromSortedList kvs 606 | 607 | ---------------------------------------------------------------------------- 608 | -- Tree-like conversion 609 | ---------------------------------------------------------------------------- 610 | 611 | fromSortedList :: forall a . [a] -> [a] 612 | fromSortedList l = runST $ do 613 | let n = length l 614 | let arrOrigin = fromListN n l 615 | arrResult <- thawArray arrOrigin 0 n 616 | go n arrResult arrOrigin 617 | toList <$> unsafeFreezeArray arrResult 618 | where 619 | -- state monad could be used here, but it's another dependency 620 | go :: forall s . Int -> MutableArray s a -> Array a -> ST s () 621 | go len result origin = () <$ loop 0 0 622 | where 623 | loop :: Int -> Int -> ST s Int 624 | loop i first = 625 | if i >= len 626 | then pure first 627 | else do 628 | newFirst <- loop (2 * i + 1) first 629 | writeArray result i (indexArray origin newFirst) 630 | loop (2 * i + 2) (newFirst + 1) 631 | 632 | -- Returns a list of indexes which represents the "sorted" order of an array generated by 633 | -- fromSortedList of the provided length. 634 | -- I.e. fmap (fromSortedList [1, 2, 3, 4, 5, 6] !!) (generateOrderMapping 6) == [1, 2, 3, 4, 5, 6] 635 | -- 636 | -- >>> generateOrderMapping 6 637 | -- [3,1,4,0,5,2] 638 | -- 639 | -- >>> generateOrderMapping 8 640 | -- [7,3,1,4,0,5,2,6] 641 | generateOrderMapping :: Int -> [Int] 642 | generateOrderMapping len = runST $ do 643 | orderMappingArr <- newPrimArray len 644 | _ <- loop orderMappingArr 0 0 645 | primArrayToList <$> unsafeFreezePrimArray orderMappingArr 646 | where 647 | loop :: MutablePrimArray s Int -> Int -> Int -> ST s Int 648 | loop result i first = 649 | if i >= len 650 | then pure first 651 | else do 652 | newFirst <- loop result (2 * i + 1) first 653 | writePrimArray result newFirst i 654 | loop result (2 * i + 2) (newFirst + 1) 655 | 656 | ---------------------------------------------------------------------------- 657 | -- Helper functions. 658 | ---------------------------------------------------------------------------- 659 | 660 | -- | Check that invariant of the structure holds. 661 | -- The structure maintains the following invariant. 662 | -- For each element @A@ at index @i@: 663 | -- 664 | -- 1. if there is an element @B@ at index @2*i+1@, 665 | -- then @B < A@. 666 | -- 667 | -- 2. if there is an element @C@ at index @2*i+2@, 668 | -- then @A < C@. 669 | -- 670 | invariantCheck :: TypeRepMap f -> Bool 671 | invariantCheck TypeRepMap{..} = getAll (check 0) 672 | where 673 | lastMay [] = Nothing 674 | lastMay [x] = Just x 675 | lastMay (_:xs) = lastMay xs 676 | sz = sizeofPrimArray fingerprintAs 677 | check i | i >= sz = All True 678 | | otherwise = 679 | let left = i * 2 + 1 680 | right = i * 2 + 2 681 | -- maximum value in the left branch 682 | leftMax = 683 | fmap (\j -> (indexPrimArray fingerprintAs j, indexPrimArray fingerprintBs j)) 684 | $ lastMay 685 | $ takeWhile (< sz) 686 | $ iterate (\j -> j * 2 + 2) left 687 | -- minimum value in the right branch 688 | rightMin = 689 | fmap (\j -> (indexPrimArray fingerprintAs j, indexPrimArray fingerprintBs j)) 690 | $ lastMay 691 | $ takeWhile (< sz) 692 | $ iterate (\j -> j * 2 + 1) right 693 | in mconcat 694 | [ All $ 695 | if left < sz 696 | then 697 | case indexPrimArray fingerprintAs i `compare` indexPrimArray fingerprintAs left of 698 | LT -> False 699 | EQ -> indexPrimArray fingerprintBs i >= indexPrimArray fingerprintBs left 700 | GT -> True 701 | else True 702 | , All $ 703 | if right < sz 704 | then 705 | case indexPrimArray fingerprintAs i `compare` indexPrimArray fingerprintAs right of 706 | LT -> True 707 | EQ -> indexPrimArray fingerprintBs i <= indexPrimArray fingerprintBs right 708 | GT -> False 709 | else True 710 | , All $ fromMaybe True $ (<=) <$> leftMax <*> rightMin 711 | , check (i + 1) 712 | ] 713 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-18.5 2 | -------------------------------------------------------------------------------- /test/Test.hs: -------------------------------------------------------------------------------- 1 | module Main 2 | ( main 3 | ) where 4 | 5 | import Test.Hspec (hspec) 6 | 7 | import Test.TypeRep.CMap (cMapSpec) 8 | import Test.TypeRep.TypeRepMap (typeRepMapSpec) 9 | import Test.TypeRep.TypeRepMapProperty (typeRepMapPropertySpec) 10 | import Test.TypeRep.Vector (vectorSpec) 11 | import Test.TypeRep.VectorOpt (optimalVectorSpec) 12 | 13 | 14 | main :: IO () 15 | main = hspec $ do 16 | typeRepMapSpec 17 | cMapSpec 18 | vectorSpec 19 | optimalVectorSpec 20 | -- property 21 | typeRepMapPropertySpec 22 | -------------------------------------------------------------------------------- /test/Test/TypeRep/CMap.hs: -------------------------------------------------------------------------------- 1 | module Test.TypeRep.CMap 2 | ( cMapSpec 3 | ) where 4 | 5 | import Prelude hiding (lookup) 6 | 7 | import Data.Functor.Identity (Identity (..)) 8 | import Test.Hspec (Spec, describe, it, shouldBe) 9 | 10 | import Data.TypeRep.CMap (TypeRepMap, empty, insert, lookup, size) 11 | 12 | 13 | -- | Simple test for 'lookup', 'insert' and 'size' functions. 14 | cMapSpec :: Spec 15 | cMapSpec = describe "Containers Map TypeRep" $ do 16 | describe "Lookup Test" $ do 17 | it "returns the inserted element" $ 18 | lookup (insert (Identity 'a') empty) `shouldBe` Just (Identity 'a') 19 | it "returns the second inserted value of the same type" $ 20 | lookup (insert (Identity 'b') $ insert (Identity 'a') empty) `shouldBe` Just (Identity 'b') 21 | 22 | describe "Size Test" $ do 23 | it "is empty" $ 24 | size empty `shouldBe` 0 25 | it "is of size 1 when 1 element inserted" $ 26 | size (insert (Identity 'a') empty) `shouldBe` 1 27 | it "doesn't increase size when element of the same type is added" $ 28 | size (insert (Identity 'b') $ insert (Identity 'a') empty) `shouldBe` 1 29 | it "returns 10 when 10 different types are inserted" $ 30 | size mapOf10 `shouldBe` 10 31 | 32 | 33 | mapOf10 :: TypeRepMap Identity 34 | mapOf10 = insert (Identity True) 35 | $ insert (Identity [True, False]) 36 | $ insert (Identity $ Just True) 37 | $ insert (Identity $ Just ()) 38 | $ insert (Identity [()]) 39 | $ insert (Identity ()) 40 | $ insert (Identity @String "aaa") 41 | $ insert (Identity $ Just 'a') 42 | $ insert (Identity 'a') 43 | $ insert (Identity (11 :: Int)) empty 44 | -------------------------------------------------------------------------------- /test/Test/TypeRep/TypeRepMap.hs: -------------------------------------------------------------------------------- 1 | module Test.TypeRep.TypeRepMap 2 | ( typeRepMapSpec 3 | ) where 4 | 5 | import Prelude hiding (lookup) 6 | 7 | import Data.Functor.Identity (Identity (..)) 8 | import Data.List (sortBy) 9 | import Data.Ord (comparing) 10 | import Data.Typeable (cast) 11 | import GHC.Exts (fromList, toList) 12 | import Type.Reflection (SomeTypeRep(..), typeRep) 13 | import Test.Hspec (Spec, describe, it, shouldBe, shouldMatchList, shouldSatisfy, expectationFailure) 14 | 15 | import Data.TMap (TMap, empty, insert, lookup, one, size, union, keys) 16 | import Data.TypeRepMap.Internal (WrapTypeable (..)) 17 | 18 | 19 | -- Simple test for 'lookup', 'insert', 'size', 'keys', 'toList' functions. 20 | typeRepMapSpec :: Spec 21 | typeRepMapSpec = describe "TypeRepMap" $ do 22 | describe "Lookup Test" $ do 23 | it "returns the inserted element" $ 24 | lookup (fromList [WrapTypeable $ Identity 'a']) `shouldBe` Just 'a' 25 | it "returns the second inserted value of the same type" $ 26 | lookup (fromList [WrapTypeable (Identity 'b'), WrapTypeable (Identity 'a')]) `shouldBe` Just 'b' 27 | 28 | describe "Size Test" $ do 29 | it "is empty" $ 30 | size empty `shouldBe` 0 31 | it "is of size 1 when 1 element inserted" $ 32 | size (one 'a') `shouldBe` 1 33 | it "doesn't increase size when element of the same type is added" $ 34 | size (insert 'b' $ insert 'a' empty) `shouldBe` 1 35 | it "returns 10 when 10 different types are inserted" $ 36 | size mapOf10 `shouldBe` 10 37 | 38 | describe "Union test" $ do 39 | let m = fromList [WrapTypeable $ Identity 'a', WrapTypeable $ Identity True] `union` 40 | fromList [WrapTypeable $ Identity 'b'] 41 | it "lookup works on union as expected" $ do 42 | lookup m `shouldBe` Just 'a' 43 | lookup m `shouldBe` Just True 44 | lookup @Int m `shouldBe` Nothing 45 | 46 | describe "Keys Test" $ do 47 | it "returns nothing on empty map" $ 48 | keys empty `shouldBe` [] 49 | it "returns the correct TypeRep" $ 50 | keys (one 'a') `shouldBe` [SomeTypeRep $ typeRep @Char] 51 | it "returns the correct TypeReps for 10 different types" $ 52 | keys mapOf10 `shouldMatchList` 53 | [ SomeTypeRep $ typeRep @Bool 54 | , SomeTypeRep $ typeRep @[Bool] 55 | , SomeTypeRep $ typeRep @(Maybe Bool) 56 | , SomeTypeRep $ typeRep @(Maybe ()) 57 | , SomeTypeRep $ typeRep @[()] 58 | , SomeTypeRep $ typeRep @() 59 | , SomeTypeRep $ typeRep @String 60 | , SomeTypeRep $ typeRep @(Maybe Char) 61 | , SomeTypeRep $ typeRep @Char 62 | , SomeTypeRep $ typeRep @Int 63 | ] 64 | 65 | describe "ToList Test" $ do 66 | it "returns nothing on empty map" $ 67 | toList empty `shouldSatisfy` null 68 | it "returns correct result when 1 element is inserted" $ 69 | case toList (one 'a') of 70 | [WrapTypeable (Identity x)] -> cast x `shouldBe` Just 'a' 71 | _ -> expectationFailure "did not return exactly 1 result" 72 | it "returns correct result when 10 elements are inserted" $ do 73 | let 74 | getTypeRep (WrapTypeable (Identity (_ :: a))) = SomeTypeRep $ typeRep @a 75 | got = sortBy (comparing getTypeRep) (toList mapOf10) 76 | expected = sortBy (comparing fst) 77 | [ (SomeTypeRep $ typeRep @Bool, 78 | \(WrapTypeable (Identity x)) -> cast x `shouldBe` Just True) 79 | , (SomeTypeRep $ typeRep @[Bool], 80 | \(WrapTypeable (Identity x)) -> cast x `shouldBe` Just [True, False]) 81 | , (SomeTypeRep $ typeRep @(Maybe Bool), 82 | \(WrapTypeable (Identity x)) -> cast x `shouldBe` Just (Just True)) 83 | , (SomeTypeRep $ typeRep @(Maybe ()), 84 | \(WrapTypeable (Identity x)) -> cast x `shouldBe` Just (Just ())) 85 | , (SomeTypeRep $ typeRep @[()], 86 | \(WrapTypeable (Identity x)) -> cast x `shouldBe` Just [()]) 87 | , (SomeTypeRep $ typeRep @(), 88 | \(WrapTypeable (Identity x)) -> cast x `shouldBe` Just ()) 89 | , (SomeTypeRep $ typeRep @String, 90 | \(WrapTypeable (Identity x)) -> cast x `shouldBe` Just ("aaa" :: String)) 91 | , (SomeTypeRep $ typeRep @(Maybe Char), 92 | \(WrapTypeable (Identity x)) -> cast x `shouldBe` Just (Just 'a')) 93 | , (SomeTypeRep $ typeRep @Char, 94 | \(WrapTypeable (Identity x)) -> cast x `shouldBe` Just 'a') 95 | , (SomeTypeRep $ typeRep @Int, 96 | \(WrapTypeable (Identity x)) -> cast x `shouldBe` Just (11 :: Int)) 97 | ] 98 | length got `shouldBe` 10 99 | sequence_ $ zipWith snd expected got 100 | 101 | mapOf10 :: TMap 102 | mapOf10 = insert True 103 | $ insert [True, False] 104 | $ insert (Just True) 105 | $ insert (Just ()) 106 | $ insert [()] 107 | $ insert () 108 | $ insert @String "aaa" 109 | $ insert (Just 'a') 110 | $ insert 'a' 111 | $ insert (11 :: Int) empty 112 | -------------------------------------------------------------------------------- /test/Test/TypeRep/TypeRepMapProperty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE PolyKinds #-} 5 | 6 | {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} 7 | 8 | module Test.TypeRep.TypeRepMapProperty 9 | ( typeRepMapPropertySpec 10 | ) where 11 | 12 | import Prelude hiding (lookup) 13 | 14 | import Data.Proxy (Proxy (..)) 15 | import Data.Semigroup (Semigroup (..)) 16 | import GHC.Exts (fromList) 17 | import GHC.TypeLits (Nat, SomeNat (..), someNatVal) 18 | import Hedgehog (MonadGen, assert, forAll, (===)) 19 | import Test.Hspec (Arg, Expectation, Spec, SpecWith, describe, it) 20 | import Test.Hspec.Hedgehog (hedgehog) 21 | 22 | import Data.TypeRepMap.Internal (TypeRepMap (..), WrapTypeable (..), delete, insert, invariantCheck, 23 | lookup, member, union, generateOrderMapping, fromSortedList, 24 | adjust, alter, intersection) 25 | 26 | import qualified Hedgehog.Gen as Gen 27 | import qualified Hedgehog.Range as Range 28 | 29 | 30 | typeRepMapPropertySpec :: Spec 31 | typeRepMapPropertySpec = describe "TypeRepMap Property tests" $ do 32 | describe "Map modification properties" $ do 33 | insertLookupSpec 34 | insertInsertSpec 35 | deleteMemberSpec 36 | insertInvariantSpec 37 | deleteInvariantSpec 38 | alterInsertSpec 39 | alterDeleteSpec 40 | alterAdjustSpec 41 | alterModifySpec 42 | intersectionSpec 43 | describe "Internal helpers" $ do 44 | generateOrderMappingInvariantSpec 45 | describe "Instance Laws" $ do 46 | semigroupAssocSpec 47 | monoidIdentitySpec 48 | 49 | ---------------------------------------------------------------------------- 50 | -- Map modification properties 51 | ---------------------------------------------------------------------------- 52 | 53 | type Property = SpecWith (Arg Expectation) 54 | 55 | insertLookupSpec :: Property 56 | insertLookupSpec = it "lookup k (insert k v m) == Just v" $ hedgehog $ do 57 | m <- forAll genMap 58 | WrapTypeable (proxy :: IntProxy n) <- forAll genTF 59 | lookup @n @IntProxy (insert proxy m) === Just proxy 60 | 61 | insertInsertSpec :: Property 62 | insertInsertSpec = it "insert k b . insert k a == insert k b" $ hedgehog $ do 63 | m <- forAll genMap 64 | WrapTypeable a@(IntProxy (proxy :: Proxy n) i) <- forAll genTF 65 | let b = IntProxy proxy (i + 1) 66 | lookup @n @IntProxy (insert b $ insert a m) === Just b 67 | 68 | deleteMemberSpec :: Property 69 | deleteMemberSpec = it "member k . delete k == False" $ hedgehog $ do 70 | m <- forAll genMap 71 | WrapTypeable (proxy :: IntProxy n) <- forAll genTF 72 | shouldInsert <- forAll Gen.bool 73 | 74 | if shouldInsert then 75 | member @n (delete @n $ insert proxy m) === False 76 | else 77 | member @n (delete @n m) === False 78 | 79 | insertInvariantSpec :: Property 80 | insertInvariantSpec = it "invariantCheck (insert k b) == True" $ hedgehog $ do 81 | m <- forAll genMap 82 | WrapTypeable a <- forAll genTF 83 | assert $ invariantCheck (insert a m) 84 | 85 | deleteInvariantSpec :: Property 86 | deleteInvariantSpec = it "invariantCheck (delete k b) == True" $ hedgehog $ do 87 | m <- forAll genMap 88 | WrapTypeable (_ :: IntProxy n) <- forAll genTF 89 | assert $ invariantCheck (delete @n m) 90 | 91 | alterInsertSpec :: Property 92 | alterInsertSpec = it "insert proxy m === alter (const (Just proxy)) m" $ hedgehog $ do 93 | m <- forAll genMap 94 | WrapTypeable (proxy :: IntProxy n) <- forAll genTF 95 | insert proxy m === alter (const (Just proxy)) m 96 | 97 | alterDeleteSpec :: Property 98 | alterDeleteSpec = it "delete proxy m === alter (const Nothing) m" $ hedgehog $ do 99 | WrapTypeable (proxy :: IntProxy n) <- forAll genTF 100 | m <- insert proxy <$> forAll genMap 101 | delete @n @IntProxy m === alter @n @IntProxy (const Nothing) m 102 | 103 | alterAdjustSpec :: Property 104 | alterAdjustSpec = it "adjust f m == alter (fmap f) m" $ hedgehog $ do 105 | m <- forAll genMap 106 | WrapTypeable (_ :: IntProxy n) <- forAll genTF 107 | let f (IntProxy p n) = IntProxy p (n * 10) 108 | adjust @n @IntProxy f m === alter @n @IntProxy (fmap f) m 109 | 110 | alterModifySpec :: Property 111 | alterModifySpec = it "lookup k (alter f) == f (lookup k m)" $ hedgehog $ do 112 | m <- forAll genMap 113 | WrapTypeable (_ :: IntProxy n) <- forAll genTF 114 | randInt <- forAll (Gen.int Range.constantBounded) 115 | -- Function with some interesting behaviour, which inserts, seletes and modifies 116 | let f Nothing = Just (IntProxy Proxy randInt) 117 | f (Just (IntProxy p n)) 118 | | even n = Nothing 119 | | otherwise = Just $ IntProxy p (n * 10) 120 | lookup @n @IntProxy (alter @n f m) === f (lookup @n @IntProxy m) 121 | 122 | intersectionSpec :: Property 123 | intersectionSpec = it "m `intersection` (m `union` n) == m" $ hedgehog $ do 124 | m <- forAll genMap 125 | n <- forAll genMap 126 | m `intersection` (m `union` n) === m 127 | 128 | ---------------------------------------------------------------------------- 129 | -- Internal helpers 130 | ---------------------------------------------------------------------------- 131 | generateOrderMappingInvariantSpec :: Property 132 | generateOrderMappingInvariantSpec = 133 | it "fmap (fromSortedList [1 .. n] !!) (generateOrderMapping n) == [1 .. n]" $ hedgehog $ do 134 | n <- forAll $ Gen.int (Range.linear 0 100) 135 | fmap (fromSortedList [1 .. n] !!) (generateOrderMapping n) === [1 .. n] 136 | 137 | ---------------------------------------------------------------------------- 138 | -- Semigroup and Monoid laws 139 | ---------------------------------------------------------------------------- 140 | 141 | semigroupAssocSpec :: Property 142 | semigroupAssocSpec = it "x <> (y <> z) == (x <> y) <> z" $ hedgehog $ do 143 | x <- forAll genMap 144 | y <- forAll genMap 145 | z <- forAll genMap 146 | (x <> (y <> z)) === ((x <> y) <> z) 147 | 148 | monoidIdentitySpec :: Property 149 | monoidIdentitySpec = it "x <> mempty == mempty <> x == x" $ hedgehog $ do 150 | x <- forAll genMap 151 | x <> mempty === x 152 | mempty <> x === x 153 | 154 | ---------------------------------------------------------------------------- 155 | -- Generators 156 | ---------------------------------------------------------------------------- 157 | 158 | data IntProxy (n :: Nat) = IntProxy (Proxy n) Int 159 | deriving stock (Show, Eq) 160 | 161 | genMap :: MonadGen m => m (TypeRepMap IntProxy) 162 | genMap = fromList <$> Gen.list (Range.linear 0 1000) genTF 163 | 164 | genTF :: MonadGen m => m (WrapTypeable IntProxy) 165 | genTF = do 166 | randNat :: Integer <- Gen.integral (Range.linear 0 10000) 167 | randInt <- Gen.int Range.constantBounded 168 | case someNatVal randNat of 169 | Just (SomeNat proxyNat) -> pure $ WrapTypeable $ IntProxy proxyNat randInt 170 | Nothing -> error "Invalid test generator" 171 | 172 | ---------------------------------------------------------------------------- 173 | -- Helpers 174 | ---------------------------------------------------------------------------- 175 | #if __GLASGOW_HASKELL__ < 806 176 | {- | We add an orphan Eq instance for old GHC versions just to make testing easier. 177 | It's not a good idea to write such 'Eq' instance for 'TypeRepMap' itself because 178 | it doesn't compare values so it's not true equality. But this should be enough 179 | for tests. 180 | -} 181 | instance Eq (TypeRepMap f) where 182 | TypeRepMap as1 bs1 _ _ == TypeRepMap as2 bs2 _ _ = 183 | as1 == as2 && bs1 == bs2 184 | #endif 185 | -------------------------------------------------------------------------------- /test/Test/TypeRep/Vector.hs: -------------------------------------------------------------------------------- 1 | module Test.TypeRep.Vector 2 | ( vectorSpec 3 | ) where 4 | 5 | import Prelude hiding (lookup) 6 | 7 | import Data.Functor.Identity (Identity (..)) 8 | import Test.Hspec (Spec, describe, it, shouldBe) 9 | 10 | import Data.TypeRep.Vector (TF (..), fromList, lookup) 11 | 12 | 13 | -- | Simple test for 'lookup', 'insert' and 'size' functions. 14 | vectorSpec :: Spec 15 | vectorSpec = describe "Vector TypeRep" $ 16 | describe "Lookup Test" $ do 17 | it "returns the inserted element" $ 18 | lookup (fromList [TF (Identity 'a')]) `shouldBe` Just (Identity 'a') 19 | it "returns the second inserted value of the same type" $ 20 | lookup (fromList [TF (Identity 'b'), TF (Identity 'a')]) `shouldBe` Just (Identity 'b') 21 | -------------------------------------------------------------------------------- /test/Test/TypeRep/VectorOpt.hs: -------------------------------------------------------------------------------- 1 | module Test.TypeRep.VectorOpt 2 | ( optimalVectorSpec 3 | ) where 4 | 5 | import Prelude hiding (lookup) 6 | 7 | import Data.Functor.Identity (Identity (..)) 8 | import Test.Hspec (Spec, describe, it, shouldBe) 9 | 10 | import Data.TypeRep.OptimalVector (TF (..), fromList, lookup) 11 | 12 | 13 | -- | Simple test for 'lookup', 'insert' and 'size' functions. 14 | optimalVectorSpec :: Spec 15 | optimalVectorSpec = describe "Optimal Vector TypeRep" $ 16 | describe "Lookup Test" $ do 17 | it "returns the inserted element" $ 18 | lookup (fromList [TF $ Identity 'a']) `shouldBe` Just (Identity 'a') 19 | it "returns the second inserted value of the same type" $ 20 | lookup (fromList [TF (Identity 'b'), TF (Identity 'a')]) `shouldBe` Just (Identity 'b') 21 | -------------------------------------------------------------------------------- /typerep-extra-impls/Data/TypeRep/CMap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PolyKinds #-} 2 | 3 | {- | 4 | Copyright: (c) 2017-2020 Kowainik 5 | SPDX-License-Identifier: MPL-2.0 6 | Maintainer: Kowainik 7 | 8 | TypeRepMap implementation based on @containers@ 'Map'. 9 | -} 10 | 11 | module Data.TypeRep.CMap 12 | ( TypeRepMap (..) 13 | , empty 14 | , insert 15 | , keys 16 | , lookup 17 | , size 18 | ) where 19 | 20 | import Prelude hiding (lookup) 21 | 22 | import Control.DeepSeq 23 | import Data.Kind (Type) 24 | import Data.Proxy (Proxy (..)) 25 | import Data.Typeable (TypeRep, Typeable, typeRep) 26 | import GHC.Base (Any) 27 | import Unsafe.Coerce (unsafeCoerce) 28 | 29 | import qualified Data.Map.Lazy as LMap 30 | 31 | 32 | -- | Map-like data structure with types served as the keys. 33 | newtype TypeRepMap (f :: k -> Type) = TypeRepMap 34 | { unMap :: LMap.Map TypeRep Any 35 | } 36 | 37 | instance NFData (TypeRepMap f) where 38 | rnf x = rnf (keys x) `seq` () 39 | 40 | -- | Empty structure. 41 | empty :: TypeRepMap f 42 | empty = TypeRepMap mempty 43 | 44 | -- | Inserts the value with its type as a key. 45 | insert :: forall a f . Typeable a => f a -> TypeRepMap f -> TypeRepMap f 46 | insert val = TypeRepMap . LMap.insert (typeRep (Proxy :: Proxy a)) (unsafeCoerce val) . unMap 47 | 48 | -- | Looks up the value at the type. 49 | -- >>> let x = lookup $ insert (11 :: Int) empty 50 | -- >>> x :: Maybe Int 51 | -- Just 11 52 | -- >>> x :: Maybe () 53 | -- Nothing 54 | lookup :: forall a f . Typeable a => TypeRepMap f -> Maybe (f a) 55 | lookup = fmap unsafeCoerce . LMap.lookup (typeRep (Proxy :: Proxy a)) . unMap 56 | 57 | size :: TypeRepMap f -> Int 58 | size = LMap.size . unMap 59 | 60 | keys :: TypeRepMap f -> [TypeRep] 61 | keys = LMap.keys . unMap 62 | -------------------------------------------------------------------------------- /typerep-extra-impls/Data/TypeRep/OptimalVector.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE MagicHash #-} 4 | {-# LANGUAGE PolyKinds #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | 7 | {- | 8 | Copyright: (c) 2017-2020 Kowainik 9 | SPDX-License-Identifier: MPL-2.0 10 | Maintainer: Kowainik 11 | 12 | TypeRepMap implementation based on the optimal Vector. 13 | -} 14 | 15 | module Data.TypeRep.OptimalVector 16 | ( -- * Map type 17 | TypeRepMap (..) 18 | 19 | -- 'TypeRepMap' interface 20 | , empty 21 | , insert 22 | , lookup 23 | , size 24 | 25 | -- * Helpful testing functions 26 | , TF (..) 27 | , fromList 28 | ) where 29 | 30 | import Prelude hiding (lookup) 31 | 32 | import Control.Arrow ((&&&)) 33 | import Control.DeepSeq 34 | import Data.Kind (Type) 35 | import Data.Proxy (Proxy (..)) 36 | import Data.Typeable (Typeable, typeRep, typeRepFingerprint) 37 | import Data.Word (Word64) 38 | import GHC.Base (Any, Int (..), Int#, uncheckedIShiftRA#, (+#), (-#), (<#)) 39 | import GHC.Exts (inline, sortWith) 40 | import GHC.Fingerprint (Fingerprint (..)) 41 | import Unsafe.Coerce (unsafeCoerce) 42 | 43 | import qualified Data.Vector as V 44 | import qualified Data.Vector.Unboxed as Unboxed 45 | 46 | 47 | data TypeRepMap (f :: k -> Type) = TypeRepMap 48 | { fingerprintAs :: Unboxed.Vector Word64 49 | , fingerprintBs :: Unboxed.Vector Word64 50 | , anys :: V.Vector Any 51 | } 52 | 53 | instance NFData (TypeRepMap f) where 54 | rnf x = x `seq` () 55 | 56 | fromAny :: Any -> f a 57 | fromAny = unsafeCoerce 58 | 59 | -- | Empty structure. 60 | empty :: TypeRepMap f 61 | empty = TypeRepMap mempty mempty mempty 62 | 63 | -- | Inserts the value with its type as a key. 64 | insert :: forall a f . a -> TypeRepMap f -> TypeRepMap f 65 | insert = undefined 66 | 67 | -- | Looks up the value at the type. 68 | -- >>> let x = lookup $ insert (11 :: Int) empty 69 | -- >>> x :: Maybe Int 70 | -- Just 11 71 | -- >>> x :: Maybe () 72 | -- Nothing 73 | lookup :: forall a f . Typeable a => TypeRepMap f -> Maybe (f a) 74 | lookup tVect = fromAny . (anys tVect V.!) 75 | <$> binarySearch (typeRepFingerprint $ typeRep $ Proxy @a) 76 | (fingerprintAs tVect) 77 | (fingerprintBs tVect) 78 | 79 | -- | Returns the size of the 'TypeRepMap'. 80 | size :: TypeRepMap f -> Int 81 | size = Unboxed.length . fingerprintAs 82 | 83 | -- | Returns the index is found. 84 | binarySearch :: Fingerprint -> Unboxed.Vector Word64 -> Unboxed.Vector Word64 -> Maybe Int 85 | binarySearch (Fingerprint a b) fpAs fpBs = 86 | let 87 | !(I# len) = Unboxed.length fpAs 88 | checkfpBs :: Int# -> Maybe Int 89 | checkfpBs i = 90 | case i <# len of 91 | 0# -> Nothing 92 | _ | a /= Unboxed.unsafeIndex fpAs (I# i) -> Nothing 93 | | b == Unboxed.unsafeIndex fpBs (I# i) -> Just (I# i) 94 | | otherwise -> checkfpBs (i +# 1#) 95 | in 96 | inline (checkfpBs (binSearchHelp (-1#) len)) 97 | where 98 | binSearchHelp :: Int# -> Int# -> Int# 99 | binSearchHelp l r = case l <# (r -# 1#) of 100 | 0# -> r 101 | _ -> 102 | let m = uncheckedIShiftRA# (l +# r) 1# in 103 | if Unboxed.unsafeIndex fpAs (I# m) < a 104 | then binSearchHelp m r 105 | else binSearchHelp l m 106 | 107 | ---------------------------------------------------------------------------- 108 | -- Functions for testing and benchmarking 109 | ---------------------------------------------------------------------------- 110 | 111 | data TF f where 112 | TF :: Typeable a => f a -> TF f 113 | 114 | fromF :: f a -> Proxy a 115 | fromF _ = Proxy 116 | 117 | fromList :: forall f . [TF f] -> TypeRepMap f 118 | fromList tfs = TypeRepMap (Unboxed.fromList fpAs) (Unboxed.fromList fpBs) (V.fromList ans) 119 | where 120 | (fpAs, fpBs) = unzip $ fmap (\(Fingerprint a b) -> (a, b)) fps 121 | (fps, ans) = unzip $ sortWith fst $ map (fp &&& an) tfs 122 | 123 | fp :: TF f -> Fingerprint 124 | fp (TF x) = typeRepFingerprint $ typeRep $ fromF x 125 | 126 | an :: TF f -> Any 127 | an (TF x) = unsafeCoerce x 128 | -------------------------------------------------------------------------------- /typerep-extra-impls/Data/TypeRep/Vector.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | {-# LANGUAGE BangPatterns #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE MagicHash #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE PolyKinds #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | 10 | {- | 11 | Copyright: (c) 2017-2020 Kowainik 12 | SPDX-License-Identifier: MPL-2.0 13 | Maintainer: Kowainik 14 | 15 | TypeRepMap implementation based on Vector. 16 | -} 17 | 18 | module Data.TypeRep.Vector 19 | ( TypeRepVector (..) 20 | , TF (..) 21 | , empty 22 | , insert 23 | , lookup 24 | , size 25 | , fromList 26 | ) where 27 | 28 | import Prelude hiding (lookup) 29 | 30 | import Control.Arrow ((&&&)) 31 | import Data.Proxy (Proxy (..)) 32 | import Data.Typeable (Typeable, typeRep, typeRepFingerprint) 33 | import Data.Word (Word64) 34 | import GHC.Base hiding (empty) 35 | import GHC.Exts (sortWith) 36 | import GHC.Fingerprint (Fingerprint (..)) 37 | import Unsafe.Coerce (unsafeCoerce) 38 | 39 | import qualified Data.Vector as V 40 | import qualified Data.Vector.Generic as G 41 | import qualified Data.Vector.Generic.Mutable as M 42 | import qualified Data.Vector.Unboxed as Unboxed 43 | 44 | 45 | data instance Unboxed.MVector s Fingerprint = MFingerprintVector (Unboxed.MVector s Word64) (Unboxed.MVector s Word64) 46 | data instance Unboxed.Vector Fingerprint = FingerprintVector (Unboxed.Vector Word64) (Unboxed.Vector Word64) 47 | 48 | instance Unboxed.Unbox Fingerprint 49 | 50 | instance M.MVector Unboxed.MVector Fingerprint where 51 | {-# INLINE basicLength #-} 52 | basicLength (MFingerprintVector x _) = M.basicLength x 53 | {-# INLINE basicUnsafeSlice #-} 54 | basicUnsafeSlice i m (MFingerprintVector a b) = 55 | MFingerprintVector (M.basicUnsafeSlice i m a) (M.basicUnsafeSlice i m b) 56 | {-# INLINE basicOverlaps #-} 57 | basicOverlaps (MFingerprintVector as1 bs1) (MFingerprintVector as2 bs2) = 58 | M.basicOverlaps as1 as2 || M.basicOverlaps bs1 bs2 59 | {-# INLINE basicUnsafeNew #-} 60 | basicUnsafeNew n_ = do 61 | as <- M.basicUnsafeNew n_ 62 | bs <- M.basicUnsafeNew n_ 63 | return $ MFingerprintVector as bs 64 | {-# INLINE basicInitialize #-} 65 | basicInitialize (MFingerprintVector as bs) = do 66 | M.basicInitialize as 67 | M.basicInitialize bs 68 | {-# INLINE basicUnsafeReplicate #-} 69 | basicUnsafeReplicate n_ (Fingerprint a b) = do 70 | as <- M.basicUnsafeReplicate n_ a 71 | bs <- M.basicUnsafeReplicate n_ b 72 | return $ MFingerprintVector as bs 73 | {-# INLINE basicUnsafeRead #-} 74 | basicUnsafeRead (MFingerprintVector as bs) i_ = do 75 | a <- M.basicUnsafeRead as i_ 76 | b <- M.basicUnsafeRead bs i_ 77 | return (Fingerprint a b) 78 | {-# INLINE basicUnsafeWrite #-} 79 | basicUnsafeWrite (MFingerprintVector as bs) i_ (Fingerprint a b) = do 80 | M.basicUnsafeWrite as i_ a 81 | M.basicUnsafeWrite bs i_ b 82 | {-# INLINE basicClear #-} 83 | basicClear (MFingerprintVector as bs) = do 84 | M.basicClear as 85 | M.basicClear bs 86 | {-# INLINE basicSet #-} 87 | basicSet (MFingerprintVector as bs) (Fingerprint a b) = do 88 | M.basicSet as a 89 | M.basicSet bs b 90 | {-# INLINE basicUnsafeCopy #-} 91 | basicUnsafeCopy (MFingerprintVector as1 bs1) (MFingerprintVector as2 bs2) = do 92 | M.basicUnsafeCopy as1 as2 93 | M.basicUnsafeCopy bs1 bs2 94 | {-# INLINE basicUnsafeMove #-} 95 | basicUnsafeMove (MFingerprintVector as1 bs1) (MFingerprintVector as2 bs2) = do 96 | M.basicUnsafeMove as1 as2 97 | M.basicUnsafeMove bs1 bs2 98 | {-# INLINE basicUnsafeGrow #-} 99 | basicUnsafeGrow (MFingerprintVector as bs) m_ = do 100 | as' <- M.basicUnsafeGrow as m_ 101 | bs' <- M.basicUnsafeGrow bs m_ 102 | return $ MFingerprintVector as' bs' 103 | 104 | instance G.Vector Unboxed.Vector Fingerprint where 105 | {-# INLINE basicUnsafeFreeze #-} 106 | basicUnsafeFreeze (MFingerprintVector as bs) = do 107 | as' <- G.basicUnsafeFreeze as 108 | bs' <- G.basicUnsafeFreeze bs 109 | return $ FingerprintVector as' bs' 110 | {-# INLINE basicUnsafeThaw #-} 111 | basicUnsafeThaw (FingerprintVector as bs) = do 112 | as' <- G.basicUnsafeThaw as 113 | bs' <- G.basicUnsafeThaw bs 114 | return $ MFingerprintVector as' bs' 115 | {-# INLINE basicLength #-} 116 | basicLength (FingerprintVector x _) = G.basicLength x 117 | {-# INLINE basicUnsafeSlice #-} 118 | basicUnsafeSlice i_ m_ (FingerprintVector as bs) = 119 | FingerprintVector (G.basicUnsafeSlice i_ m_ as) (G.basicUnsafeSlice i_ m_ bs) 120 | {-# INLINE basicUnsafeIndexM #-} 121 | basicUnsafeIndexM (FingerprintVector as bs) i_ = do 122 | a <- G.basicUnsafeIndexM as i_ 123 | b <- G.basicUnsafeIndexM bs i_ 124 | return (Fingerprint a b) 125 | {-# INLINE basicUnsafeCopy #-} 126 | basicUnsafeCopy (MFingerprintVector as1 bs1) (FingerprintVector as2 bs2) = do 127 | G.basicUnsafeCopy as1 as2 128 | G.basicUnsafeCopy bs1 bs2 129 | {-# INLINE elemseq #-} 130 | elemseq _ (Fingerprint a b) 131 | = G.elemseq (undefined :: Unboxed.Vector a) a 132 | . G.elemseq (undefined :: Unboxed.Vector b) b 133 | 134 | data TypeRepVector f = TypeRepVect 135 | { fingerprints :: Unboxed.Vector Fingerprint 136 | , anys :: V.Vector Any 137 | } 138 | 139 | fromAny :: Any -> f a 140 | fromAny = unsafeCoerce 141 | 142 | -- | Empty structure. 143 | empty :: TypeRepVector f 144 | empty = TypeRepVect mempty mempty 145 | 146 | -- | Inserts the value with its type as a key. 147 | insert :: forall a f . a -> TypeRepVector f -> TypeRepVector f 148 | insert = undefined 149 | 150 | -- | Looks up the value at the type. 151 | -- >>> let x = lookup $ insert (11 :: Int) empty 152 | -- >>> x :: Maybe Int 153 | -- Just 11 154 | -- >>> x :: Maybe () 155 | -- Nothing 156 | lookup :: forall a f . Typeable a => TypeRepVector f -> Maybe (f a) 157 | lookup tVect = fromAny . (anys tVect V.!) 158 | <$> binarySearch (typeRepFingerprint (typeRep (Proxy :: Proxy a))) (fingerprints tVect) 159 | 160 | -- | Returns the size of the 'TypeRepVect'. 161 | size :: TypeRepVector f -> Int 162 | size = Unboxed.length . fingerprints 163 | 164 | data TF f where 165 | TF :: Typeable a => f a -> TF f 166 | 167 | fromF :: f a -> Proxy a 168 | fromF _ = Proxy 169 | 170 | fromList :: forall f . [TF f] -> TypeRepVector f 171 | fromList tfs = TypeRepVect (Unboxed.fromList fps) (V.fromList ans) 172 | where 173 | (fps, ans) = unzip $ sortWith fst $ map (fp &&& an) tfs 174 | 175 | fp :: TF f -> Fingerprint 176 | fp (TF x) = typeRepFingerprint $ typeRep $ fromF x 177 | 178 | an :: TF f -> Any 179 | an (TF x) = unsafeCoerce x 180 | 181 | -- | Returns the index is found. 182 | binarySearch :: Fingerprint -> Unboxed.Vector Fingerprint -> Maybe Int 183 | binarySearch fp fpVect = 184 | let 185 | !(I# len) = Unboxed.length fpVect 186 | ind = I# (binSearchHelp (-1#) len) 187 | in 188 | if fp == (fpVect Unboxed.! ind) then Just ind else Nothing 189 | where 190 | binSearchHelp :: Int# -> Int# -> Int# 191 | binSearchHelp l r = case l <# (r -# 1#) of 192 | 0# -> r 193 | _ -> 194 | let m = uncheckedIShiftRA# (l +# r) 1# in 195 | if Unboxed.unsafeIndex fpVect (I# m) < fp 196 | then binSearchHelp m r 197 | else binSearchHelp l m 198 | -------------------------------------------------------------------------------- /typerep-map.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: typerep-map 3 | version: 0.6.0.0 4 | synopsis: Efficient implementation of a dependent map with types as keys 5 | description: 6 | A dependent map from type representations to values of these types. 7 | . 8 | Here is an illustration of such a map: 9 | . 10 | > TMap 11 | > --------------- 12 | > Int -> 5 13 | > Bool -> True 14 | > Char -> 'x' 15 | . 16 | In addition to @TMap@, we provide @TypeRepMap@ parametrized by a 17 | @vinyl@-style interpretation. This data structure is equivalent to @DMap 18 | TypeRep@, but with significantly more efficient lookups. 19 | 20 | homepage: https://github.com/kowainik/typerep-map 21 | bug-reports: https://github.com/kowainik/typerep-map/issues 22 | license: MPL-2.0 23 | license-file: LICENSE 24 | author: Veronika Romashkina, Vladislav Zavialov, Dmitrii Kovanikov 25 | maintainer: Kowainik 26 | copyright: 2017-2022 Kowainik 27 | category: Data, Data Structures, Types 28 | build-type: Simple 29 | extra-doc-files: README.md 30 | , CHANGELOG.md 31 | tested-with: GHC == 8.2.2 32 | , GHC == 8.4.4 33 | , GHC == 8.6.5 34 | , GHC == 8.8.4 35 | , GHC == 8.10.7 36 | , GHC == 9.0.2 37 | , GHC == 9.2.4 38 | , GHC == 9.4.2 39 | 40 | source-repository head 41 | type: git 42 | location: https://github.com/kowainik/typerep-map.git 43 | 44 | common common-options 45 | build-depends: base >= 4.10 && < 4.18 46 | 47 | default-language: Haskell2010 48 | default-extensions: BangPatterns 49 | DerivingStrategies 50 | OverloadedStrings 51 | RecordWildCards 52 | ScopedTypeVariables 53 | TypeApplications 54 | ghc-options: -Wall 55 | -Wcompat 56 | -Widentities 57 | -Wincomplete-uni-patterns 58 | -Wincomplete-record-updates 59 | -Wredundant-constraints 60 | -fhide-source-paths 61 | if impl(ghc >= 8.4) 62 | ghc-options: -Wmissing-export-lists 63 | -Wpartial-fields 64 | if impl(ghc >= 8.8) 65 | ghc-options: -Wmissing-deriving-strategies 66 | -Werror=missing-deriving-strategies 67 | if impl(ghc >= 8.10) 68 | ghc-options: -Wunused-packages 69 | if impl(ghc >= 9.0) 70 | ghc-options: -Winvalid-haddock 71 | if impl(ghc >= 9.2) 72 | ghc-options: -Wredundant-bang-patterns 73 | -Woperator-whitespace 74 | 75 | library 76 | import: common-options 77 | hs-source-dirs: src 78 | exposed-modules: Data.TMap 79 | Data.TypeRepMap 80 | Data.TypeRepMap.Internal 81 | 82 | build-depends: ghc-prim >= 0.5.1.1 && < 0.10 83 | , primitive ^>= 0.7.0 84 | , deepseq ^>= 1.4 85 | 86 | library typerep-extra-impls 87 | import: common-options 88 | hs-source-dirs: typerep-extra-impls 89 | exposed-modules: Data.TypeRep.CMap 90 | Data.TypeRep.OptimalVector 91 | Data.TypeRep.Vector 92 | 93 | build-depends: containers >= 0.5.10.2 && < 0.7 94 | , vector >= 0.12.0.1 && < 0.14 95 | , deepseq ^>= 1.4 96 | 97 | test-suite typerep-map-test 98 | import: common-options 99 | type: exitcode-stdio-1.0 100 | hs-source-dirs: test 101 | 102 | main-is: Test.hs 103 | other-modules: Test.TypeRep.CMap 104 | , Test.TypeRep.TypeRepMap 105 | , Test.TypeRep.TypeRepMapProperty 106 | , Test.TypeRep.Vector 107 | , Test.TypeRep.VectorOpt 108 | 109 | build-depends: ghc-typelits-knownnat >= 0.4.2 && < 0.8 110 | , hedgehog >= 1.0 && < 1.3 111 | , hspec >= 2.7.1 && < 2.11 112 | , hspec-hedgehog ^>= 0.0.1 113 | , typerep-map 114 | , typerep-extra-impls 115 | 116 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 117 | 118 | benchmark typerep-map-benchmark 119 | import: common-options 120 | type: exitcode-stdio-1.0 121 | hs-source-dirs: benchmark 122 | 123 | main-is: Main.hs 124 | other-modules: CMap 125 | , CacheMap 126 | , DMap 127 | , Spec 128 | , Vector 129 | , OptimalVector 130 | 131 | build-depends: criterion >= 1.4.1.0 && < 1.7 132 | , deepseq ^>= 1.4.3.0 133 | , dependent-map >= 0.2.4.0 && < 0.5 134 | , dependent-sum >= 0.5 && < 0.8 135 | , ghc-typelits-knownnat >= 0.4.2 && < 0.8 136 | , typerep-map 137 | , typerep-extra-impls 138 | 139 | ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N -freduction-depth=0 140 | --------------------------------------------------------------------------------