diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,17 @@ `typerep-map` uses [PVP Versioning][1]. The changelog is available [on GitHub][2]. +## 0.3.3.0 — Apr 18, 2020 + +* [#83](https://github.com/kowainik/typerep-map/issues/83): + Support GHC-8.10. +* [#80](https://github.com/kowainik/typerep-map/issues/80): + Build on 32-bit platforms. +* [#78](https://github.com/kowainik/typerep-map/issues/78): + Support GHC-8.8.3. +* [#63](https://github.com/kowainik/typerep-map/pull/63): + Add invariant check. + ## 0.3.2 — Mar 27, 2019 * [#47](https://github.com/kowainik/typerep-map/issues/47): @@ -26,7 +37,6 @@ * [#30](https://github.com/kowainik/typerep-map/issues/30): Rewrite `fromSortedList` to use `Array` and `MutableArray` instead of `IntMap`. - ## 0.2.0 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,21 +1,373 @@ -MIT License +Mozilla Public License Version 2.0 +================================== -Copyright (c) 2017 Veronika Romashkina +1. Definitions +-------------- -Permission is hereby granted, free of charge, to any person obtaining a copy -of this software and associated documentation files (the "Software"), to deal -in the Software without restriction, including without limitation the rights -to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -copies of the Software, and to permit persons to whom the Software is -furnished to do so, subject to the following conditions: +1.1. "Contributor" + means each individual or legal entity that creates, contributes to + the creation of, or owns Covered Software. -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. +1.2. "Contributor Version" + means the combination of the Contributions of others (if any) used + by a Contributor and that particular Contributor's Contribution. -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -SOFTWARE. +1.3. "Contribution" + means Covered Software of a particular Contributor. + +1.4. "Covered Software" + means Source Code Form to which the initial Contributor has attached + the notice in Exhibit A, the Executable Form of such Source Code + Form, and Modifications of such Source Code Form, in each case + including portions thereof. + +1.5. "Incompatible With Secondary Licenses" + means + + (a) that the initial Contributor has attached the notice described + in Exhibit B to the Covered Software; or + + (b) that the Covered Software was made available under the terms of + version 1.1 or earlier of the License, but not also under the + terms of a Secondary License. + +1.6. "Executable Form" + means any form of the work other than Source Code Form. + +1.7. "Larger Work" + means a work that combines Covered Software with other material, in + a separate file or files, that is not Covered Software. + +1.8. "License" + means this document. + +1.9. "Licensable" + means having the right to grant, to the maximum extent possible, + whether at the time of the initial grant or subsequently, any and + all of the rights conveyed by this License. + +1.10. "Modifications" + means any of the following: + + (a) any file in Source Code Form that results from an addition to, + deletion from, or modification of the contents of Covered + Software; or + + (b) any new file in Source Code Form that contains any Covered + Software. + +1.11. "Patent Claims" of a Contributor + means any patent claim(s), including without limitation, method, + process, and apparatus claims, in any patent Licensable by such + Contributor that would be infringed, but for the grant of the + License, by the making, using, selling, offering for sale, having + made, import, or transfer of either its Contributions or its + Contributor Version. + +1.12. "Secondary License" + means either the GNU General Public License, Version 2.0, the GNU + Lesser General Public License, Version 2.1, the GNU Affero General + Public License, Version 3.0, or any later versions of those + licenses. + +1.13. "Source Code Form" + means the form of the work preferred for making modifications. + +1.14. "You" (or "Your") + means an individual or a legal entity exercising rights under this + License. For legal entities, "You" includes any entity that + controls, is controlled by, or is under common control with You. For + purposes of this definition, "control" means (a) the power, direct + or indirect, to cause the direction or management of such entity, + whether by contract or otherwise, or (b) ownership of more than + fifty percent (50%) of the outstanding shares or beneficial + ownership of such entity. + +2. License Grants and Conditions +-------------------------------- + +2.1. Grants + +Each Contributor hereby grants You a world-wide, royalty-free, +non-exclusive license: + +(a) under intellectual property rights (other than patent or trademark) + Licensable by such Contributor to use, reproduce, make available, + modify, display, perform, distribute, and otherwise exploit its + Contributions, either on an unmodified basis, with Modifications, or + as part of a Larger Work; and + +(b) under Patent Claims of such Contributor to make, use, sell, offer + for sale, have made, import, and otherwise transfer either its + Contributions or its Contributor Version. + +2.2. Effective Date + +The licenses granted in Section 2.1 with respect to any Contribution +become effective for each Contribution on the date the Contributor first +distributes such Contribution. + +2.3. Limitations on Grant Scope + +The licenses granted in this Section 2 are the only rights granted under +this License. No additional rights or licenses will be implied from the +distribution or licensing of Covered Software under this License. +Notwithstanding Section 2.1(b) above, no patent license is granted by a +Contributor: + +(a) for any code that a Contributor has removed from Covered Software; + or + +(b) for infringements caused by: (i) Your and any other third party's + modifications of Covered Software, or (ii) the combination of its + Contributions with other software (except as part of its Contributor + Version); or + +(c) under Patent Claims infringed by Covered Software in the absence of + its Contributions. + +This License does not grant any rights in the trademarks, service marks, +or logos of any Contributor (except as may be necessary to comply with +the notice requirements in Section 3.4). + +2.4. Subsequent Licenses + +No Contributor makes additional grants as a result of Your choice to +distribute the Covered Software under a subsequent version of this +License (see Section 10.2) or under the terms of a Secondary License (if +permitted under the terms of Section 3.3). + +2.5. Representation + +Each Contributor represents that the Contributor believes its +Contributions are its original creation(s) or it has sufficient rights +to grant the rights to its Contributions conveyed by this License. + +2.6. Fair Use + +This License is not intended to limit any rights You have under +applicable copyright doctrines of fair use, fair dealing, or other +equivalents. + +2.7. Conditions + +Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted +in Section 2.1. + +3. Responsibilities +------------------- + +3.1. Distribution of Source Form + +All distribution of Covered Software in Source Code Form, including any +Modifications that You create or to which You contribute, must be under +the terms of this License. You must inform recipients that the Source +Code Form of the Covered Software is governed by the terms of this +License, and how they can obtain a copy of this License. You may not +attempt to alter or restrict the recipients' rights in the Source Code +Form. + +3.2. Distribution of Executable Form + +If You distribute Covered Software in Executable Form then: + +(a) such Covered Software must also be made available in Source Code + Form, as described in Section 3.1, and You must inform recipients of + the Executable Form how they can obtain a copy of such Source Code + Form by reasonable means in a timely manner, at a charge no more + than the cost of distribution to the recipient; and + +(b) You may distribute such Executable Form under the terms of this + License, or sublicense it under different terms, provided that the + license for the Executable Form does not attempt to limit or alter + the recipients' rights in the Source Code Form under this License. + +3.3. Distribution of a Larger Work + +You may create and distribute a Larger Work under terms of Your choice, +provided that You also comply with the requirements of this License for +the Covered Software. If the Larger Work is a combination of Covered +Software with a work governed by one or more Secondary Licenses, and the +Covered Software is not Incompatible With Secondary Licenses, this +License permits You to additionally distribute such Covered Software +under the terms of such Secondary License(s), so that the recipient of +the Larger Work may, at their option, further distribute the Covered +Software under the terms of either this License or such Secondary +License(s). + +3.4. Notices + +You may not remove or alter the substance of any license notices +(including copyright notices, patent notices, disclaimers of warranty, +or limitations of liability) contained within the Source Code Form of +the Covered Software, except that You may alter any license notices to +the extent required to remedy known factual inaccuracies. + +3.5. Application of Additional Terms + +You may choose to offer, and to charge a fee for, warranty, support, +indemnity or liability obligations to one or more recipients of Covered +Software. However, You may do so only on Your own behalf, and not on +behalf of any Contributor. You must make it absolutely clear that any +such warranty, support, indemnity, or liability obligation is offered by +You alone, and You hereby agree to indemnify every Contributor for any +liability incurred by such Contributor as a result of warranty, support, +indemnity or liability terms You offer. You may include additional +disclaimers of warranty and limitations of liability specific to any +jurisdiction. + +4. Inability to Comply Due to Statute or Regulation +--------------------------------------------------- + +If it is impossible for You to comply with any of the terms of this +License with respect to some or all of the Covered Software due to +statute, judicial order, or regulation then You must: (a) comply with +the terms of this License to the maximum extent possible; and (b) +describe the limitations and the code they affect. Such description must +be placed in a text file included with all distributions of the Covered +Software under this License. Except to the extent prohibited by statute +or regulation, such description must be sufficiently detailed for a +recipient of ordinary skill to be able to understand it. + +5. Termination +-------------- + +5.1. The rights granted under this License will terminate automatically +if You fail to comply with any of its terms. However, if You become +compliant, then the rights granted under this License from a particular +Contributor are reinstated (a) provisionally, unless and until such +Contributor explicitly and finally terminates Your grants, and (b) on an +ongoing basis, if such Contributor fails to notify You of the +non-compliance by some reasonable means prior to 60 days after You have +come back into compliance. Moreover, Your grants from a particular +Contributor are reinstated on an ongoing basis if such Contributor +notifies You of the non-compliance by some reasonable means, this is the +first time You have received notice of non-compliance with this License +from such Contributor, and You become compliant prior to 30 days after +Your receipt of the notice. + +5.2. If You initiate litigation against any entity by asserting a patent +infringement claim (excluding declaratory judgment actions, +counter-claims, and cross-claims) alleging that a Contributor Version +directly or indirectly infringes any patent, then the rights granted to +You by any and all Contributors for the Covered Software under Section +2.1 of this License shall terminate. + +5.3. In the event of termination under Sections 5.1 or 5.2 above, all +end user license agreements (excluding distributors and resellers) which +have been validly granted by You or Your distributors under this License +prior to termination shall survive termination. + +************************************************************************ +* * +* 6. Disclaimer of Warranty * +* ------------------------- * +* * +* Covered Software is provided under this License on an "as is" * +* basis, without warranty of any kind, either expressed, implied, or * +* statutory, including, without limitation, warranties that the * +* Covered Software is free of defects, merchantable, fit for a * +* particular purpose or non-infringing. The entire risk as to the * +* quality and performance of the Covered Software is with You. * +* Should any Covered Software prove defective in any respect, You * +* (not any Contributor) assume the cost of any necessary servicing, * +* repair, or correction. This disclaimer of warranty constitutes an * +* essential part of this License. No use of any Covered Software is * +* authorized under this License except under this disclaimer. * +* * +************************************************************************ + +************************************************************************ +* * +* 7. Limitation of Liability * +* -------------------------- * +* * +* Under no circumstances and under no legal theory, whether tort * +* (including negligence), contract, or otherwise, shall any * +* Contributor, or anyone who distributes Covered Software as * +* permitted above, be liable to You for any direct, indirect, * +* special, incidental, or consequential damages of any character * +* including, without limitation, damages for lost profits, loss of * +* goodwill, work stoppage, computer failure or malfunction, or any * +* and all other commercial damages or losses, even if such party * +* shall have been informed of the possibility of such damages. This * +* limitation of liability shall not apply to liability for death or * +* personal injury resulting from such party's negligence to the * +* extent applicable law prohibits such limitation. Some * +* jurisdictions do not allow the exclusion or limitation of * +* incidental or consequential damages, so this exclusion and * +* limitation may not apply to You. * +* * +************************************************************************ + +8. Litigation +------------- + +Any litigation relating to this License may be brought only in the +courts of a jurisdiction where the defendant maintains its principal +place of business and such litigation shall be governed by laws of that +jurisdiction, without reference to its conflict-of-law provisions. +Nothing in this Section shall prevent a party's ability to bring +cross-claims or counter-claims. + +9. Miscellaneous +---------------- + +This License represents the complete agreement concerning the subject +matter hereof. If any provision of this License is held to be +unenforceable, such provision shall be reformed only to the extent +necessary to make it enforceable. Any law or regulation which provides +that the language of a contract shall be construed against the drafter +shall not be used to construe this License against a Contributor. + +10. Versions of the License +--------------------------- + +10.1. New Versions + +Mozilla Foundation is the license steward. Except as provided in Section +10.3, no one other than the license steward has the right to modify or +publish new versions of this License. Each version will be given a +distinguishing version number. + +10.2. Effect of New Versions + +You may distribute the Covered Software under the terms of the version +of the License under which You originally received the Covered Software, +or under the terms of any subsequent version published by the license +steward. + +10.3. Modified Versions + +If you create software not governed by this License, and you want to +create a new license for such software, you may create and use a +modified version of this License if you rename the license and remove +any references to the name of the license steward (except to note that +such modified license differs from this License). + +10.4. Distributing Source Code Form that is Incompatible With Secondary +Licenses + +If You choose to distribute Source Code Form that is Incompatible With +Secondary Licenses under the terms of this version of the License, the +notice described in Exhibit B of this License must be attached. + +Exhibit A - Source Code Form License Notice +------------------------------------------- + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at http://mozilla.org/MPL/2.0/. + +If it is not possible or desirable to put the notice in a particular +file, then You may include the notice in a location (such as a LICENSE +file in a relevant directory) where a recipient would be likely to look +for such a notice. + +You may add additional accurate notices of copyright ownership. + +Exhibit B - "Incompatible With Secondary Licenses" Notice +--------------------------------------------------------- + + This Source Code Form is "Incompatible With Secondary Licenses", as + defined by the Mozilla Public License, v. 2.0. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,14 +1,22 @@ # typerep-map -![electricity](https://user-images.githubusercontent.com/8126674/44323413-788dd700-a484-11e8-842e-f224cfaa4206.png) -[![Hackage](https://img.shields.io/hackage/v/typerep-map.svg)](https://hackage.haskell.org/package/typerep-map) -[![Build status](https://secure.travis-ci.org/kowainik/typerep-map.svg)](https://travis-ci.org/kowainik/typerep-map) -[![MIT license](https://img.shields.io/badge/license-MIT-blue.svg)](https://github.com/vrom911/typerep-map/blob/master/LICENSE) +![logo](https://user-images.githubusercontent.com/8126674/44323413-788dd700-a484-11e8-842e-f224cfaa4206.png) +[![GitHub CI](https://github.com/kowainik/typerep-map/workflows/CI/badge.svg)](https://github.com/kowainik/typerep-map/actions) +[![Build status](https://img.shields.io/travis/kowainik/typerep-map.svg?logo=travis)](https://travis-ci.org/kowainik/typerep-map) +[![Windows build status](https://ci.appveyor.com/api/projects/status/github/kowainik/typerep-map?branch=master&svg=true)](https://ci.appveyor.com/project/kowainik/typerep-map) +[![Hackage](https://img.shields.io/hackage/v/typerep-map.svg?logo=haskell)](https://hackage.haskell.org/package/typerep-map) +[![Stackage LTS](http://stackage.org/package/typerep-map/badge/lts)](http://stackage.org/lts/package/typerep-map) +[![Stackage Nightly](http://stackage.org/package/typerep-map/badge/nightly)](http://stackage.org/nightly/package/typerep-map) +[![MPL-2.0 license](https://img.shields.io/badge/license-MPL--2.0-blue.svg)](LICENSE) + + `typerep-map` introduces `TMap` and `TypeRepMap` — data structures like [`Map`](http://hackage.haskell.org/package/containers-0.6.0.1/docs/Data-Map-Lazy.html#t:Map), but where types serve as keys, and values have the types specified in the corresponding key spots. -For the more details on the implementation see [this blog post](https://kowainik.github.io/posts/2018-07-11-typerep-map-step-by-step). +For the more details on the implementation see the following blog post: +* [typerep-map step by step](https://kowainik.github.io/posts/2018-07-11-typerep-map-step-by-step) + ## Usage example ```haskell @@ -47,10 +55,10 @@ Tables below contain comparision with `DMap TypeRep` of ten `lookup` operations on structure with size `10^4`: -| | ghc-8.2.2 | ghc-8.4.3 | -|----------------|-----------|-----------| -| `DMap TypeRep` | 517.5 ns | 779.9 ns | -| `typerep-map` | 205.3 ns | 187.2 ns | +| | ghc-8.2.2 | ghc-8.4.3 | ghc-8.8.3 | ghc-8.10.1 | +|----------------|-----------|-----------|-----------|------------| +| `DMap TypeRep` | 517.5 ns | 779.9 ns | 1.559 μs | 1.786 μs | +| `typerep-map` | 205.3 ns | 187.2 ns | 190.1 ns | 169.1 ns | ghc-8.2.2 | ghc-8.4.3 :---------:|:-----------: diff --git a/benchmark/CMap.hs b/benchmark/CMap.hs --- a/benchmark/CMap.hs +++ b/benchmark/CMap.hs @@ -1,70 +1,77 @@ +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} + {-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} - module CMap - ( spec - ) where - -import Criterion.Main (bench, nf, env, whnf) + ( spec + ) where import Prelude hiding (lookup) -import Spec +import Criterion.Main (bench, env, nf, whnf) +import Data.Kind (Type) import Data.Maybe (fromJust) import Data.Proxy (Proxy (..)) import Data.Typeable (Typeable) -import GHC.TypeLits +import GHC.TypeLits (type (+), KnownNat, Nat) import Data.TypeRep.CMap (TypeRepMap (..), empty, insert, lookup) +import Spec (BenchSpec (..)) + + spec :: BenchSpec spec = BenchSpec - { benchLookup = Just $ \name -> - env (mkMap 10000) $ \ ~bigMap -> - bench name $ nf tenLookups bigMap - , benchInsertSmall = Just $ \name -> - bench name $ whnf (inserts empty 10) (Proxy @ 99999) - , benchInsertBig = Just $ \name -> - env (mkMap 10000) $ \ ~(bigMap) -> - bench name $ whnf (inserts bigMap 1) (Proxy @ 99999) - , benchUpdateSmall = Just $ \name -> - env (mkMap 10) $ \ ~(smallMap) -> - bench name $ whnf (inserts smallMap 10) (Proxy @ 0) - , benchUpdateBig = Just $ \name -> - env (mkMap 10000) $ \ ~(bigMap) -> - bench name $ whnf (inserts bigMap 10) (Proxy @ 0) - } + { benchLookup = Just $ \name -> + env (mkMap 10000) $ \ ~bigMap -> + bench name $ nf tenLookups bigMap + , benchInsertSmall = Just $ \name -> + bench name $ whnf (inserts empty 10) (Proxy @ 99999) + , benchInsertBig = Just $ \name -> + env (mkMap 10000) $ \ ~bigMap -> + bench name $ whnf (inserts bigMap 1) (Proxy @ 99999) + , benchUpdateSmall = Just $ \name -> + env (mkMap 10) $ \ ~smallMap -> + bench name $ whnf (inserts smallMap 10) (Proxy @ 0) + , benchUpdateBig = Just $ \name -> + env (mkMap 10000) $ \ ~bigMap -> + bench name $ whnf (inserts bigMap 10) (Proxy @ 0) + } -tenLookups :: TypeRepMap (Proxy :: Nat -> *) - -> ( Proxy 10, Proxy 20, Proxy 30, Proxy 40 - , Proxy 50, Proxy 60, Proxy 70, Proxy 80 - ) +tenLookups + :: TypeRepMap (Proxy :: Nat -> Type) + -> ( Proxy 10, Proxy 20, Proxy 30, Proxy 40 + , Proxy 50, Proxy 60, Proxy 70, Proxy 80 + ) tenLookups tmap = (lp, lp, lp, lp, lp, lp, lp, lp) where lp :: forall (a::Nat). Typeable a => Proxy a lp = fromJust $ lookup tmap -inserts :: forall a . (KnownNat a) - => TypeRepMap (Proxy :: Nat -> *) - -> Int - -> Proxy (a :: Nat) - -> TypeRepMap (Proxy :: Nat -> *) +inserts + :: forall a . (KnownNat a) + => TypeRepMap (Proxy :: Nat -> Type) + -> Int + -> Proxy (a :: Nat) + -> TypeRepMap (Proxy :: Nat -> Type) inserts !c 0 _ = c inserts !c n x = inserts - (insert x c) - (n-1) - (Proxy :: Proxy (a+1)) + (insert x c) + (n-1) + (Proxy :: Proxy (a+1)) -mkMap :: Int -> IO (TypeRepMap (Proxy :: Nat -> *)) +mkMap :: Int -> IO (TypeRepMap (Proxy :: Nat -> Type)) mkMap n = pure $ buildBigMap n (Proxy :: Proxy 0) empty -buildBigMap :: forall a . (KnownNat a) => Int -> Proxy (a :: Nat) -> TypeRepMap (Proxy :: Nat -> *) -> TypeRepMap (Proxy :: Nat -> *) +buildBigMap + :: forall a . (KnownNat a) + => Int + -> Proxy (a :: Nat) + -> TypeRepMap (Proxy :: Nat -> Type) + -> TypeRepMap (Proxy :: Nat -> Type) buildBigMap 1 x = insert x buildBigMap n x = insert x . buildBigMap (n - 1) (Proxy :: Proxy (a + 1)) diff --git a/benchmark/CacheMap.hs b/benchmark/CacheMap.hs --- a/benchmark/CacheMap.hs +++ b/benchmark/CacheMap.hs @@ -1,76 +1,79 @@ +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} + {-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} - module CacheMap - ( spec - ) where - -import Criterion.Main (bench, nf, whnf, env) -import Spec + ( spec + ) where import Prelude hiding (lookup) +import Criterion.Main (bench, env, nf, whnf) +import Data.Kind (Type) import Data.Maybe (fromJust) import Data.Proxy (Proxy (..)) import Data.Typeable (Typeable) import GHC.Exts (fromList) -import GHC.TypeLits +import GHC.TypeLits (type (+), KnownNat, Nat) -import Data.TypeRepMap.Internal (TypeRepMap (..), WrapTypeable (..), lookup, insert, empty) +import Data.TypeRepMap.Internal (TypeRepMap (..), WrapTypeable (..), empty, insert, lookup) +import Spec (BenchSpec (..)) + + spec :: BenchSpec spec = BenchSpec - { benchLookup = Just $ \name -> - env (mkMap 10000) $ \ ~bigMap -> - bench name $ nf tenLookups bigMap - , benchInsertSmall = Just $ \name -> - bench name $ whnf (inserts empty 10) (Proxy @ 99999) - , benchInsertBig = Just $ \name -> - env (mkMap 10000) $ \ ~(bigMap) -> - bench name $ whnf (inserts bigMap 1) (Proxy @ 99999) - , benchUpdateSmall = Just $ \name -> - env (mkMap 10) $ \ ~(smallMap) -> - bench name $ whnf (inserts smallMap 10) (Proxy @ 0) - , benchUpdateBig = Just $ \name -> - env (mkMap 10000) $ \ ~(bigMap) -> - bench name $ whnf (inserts bigMap 10) (Proxy @ 0) - } + { benchLookup = Just $ \name -> + env (mkMap 10000) $ \ ~bigMap -> + bench name $ nf tenLookups bigMap + , benchInsertSmall = Just $ \name -> + bench name $ whnf (inserts empty 10) (Proxy @ 99999) + , benchInsertBig = Just $ \name -> + env (mkMap 10000) $ \ ~bigMap -> + bench name $ whnf (inserts bigMap 1) (Proxy @ 99999) + , benchUpdateSmall = Just $ \name -> + env (mkMap 10) $ \ ~smallMap -> + bench name $ whnf (inserts smallMap 10) (Proxy @ 0) + , benchUpdateBig = Just $ \name -> + env (mkMap 10000) $ \ ~bigMap -> + bench name $ whnf (inserts bigMap 10) (Proxy @ 0) + } -tenLookups :: TypeRepMap (Proxy :: Nat -> *) - -> ( Proxy 10, Proxy 20, Proxy 30, Proxy 40 - , Proxy 50, Proxy 60, Proxy 70, Proxy 80 - ) +tenLookups + :: TypeRepMap (Proxy :: Nat -> Type) + -> ( Proxy 10, Proxy 20, Proxy 30, Proxy 40 + , Proxy 50, Proxy 60, Proxy 70, Proxy 80 + ) tenLookups tmap = (lp, lp, lp, lp, lp, lp, lp, lp) where - lp :: forall (a::Nat). Typeable a => Proxy a + lp :: forall (a :: Nat) . Typeable a => Proxy a lp = fromJust $ lookup tmap -inserts :: forall a . (KnownNat a) - => TypeRepMap (Proxy :: Nat -> *) - -> Int - -> Proxy (a :: Nat) - -> TypeRepMap (Proxy :: Nat -> *) +inserts + :: forall a . (KnownNat a) + => TypeRepMap (Proxy :: Nat -> Type) + -> Int + -> Proxy (a :: Nat) + -> TypeRepMap (Proxy :: Nat -> Type) inserts !c 0 _ = c inserts !c n x = inserts - (insert x c) - (n-1) - (Proxy :: Proxy (a+1)) + (insert x c) + (n-1) + (Proxy :: Proxy (a + 1)) -mkMap :: Int -> IO (TypeRepMap (Proxy :: Nat -> *)) +mkMap :: Int -> IO (TypeRepMap (Proxy :: Nat -> Type)) mkMap n = pure $ fromList $ buildBigMap n (Proxy :: Proxy 0) [] -buildBigMap :: forall a . (KnownNat a) - => Int - -> Proxy (a :: Nat) - -> [WrapTypeable (Proxy :: Nat -> *)] - -> [WrapTypeable (Proxy :: Nat -> *)] +buildBigMap + :: forall a . (KnownNat a) + => Int + -> Proxy (a :: Nat) + -> [WrapTypeable (Proxy :: Nat -> Type)] + -> [WrapTypeable (Proxy :: Nat -> Type)] buildBigMap 1 x = (WrapTypeable x :) buildBigMap n x = (WrapTypeable x :) . buildBigMap (n - 1) (Proxy :: Proxy (a + 1)) diff --git a/benchmark/DMap.hs b/benchmark/DMap.hs --- a/benchmark/DMap.hs +++ b/benchmark/DMap.hs @@ -1,79 +1,81 @@ +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} + {-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} - module DMap - ( spec - ) where - -import Criterion.Main (bench, env, nf, whnf) + ( spec + ) where import Prelude hiding (lookup) import Control.DeepSeq (NFData (..)) +import Criterion.Main (bench, env, nf, whnf) +import Data.Kind (Type) import Data.Maybe (fromJust) import Data.Proxy (Proxy (..)) -import GHC.TypeLits -import Spec +import GHC.TypeLits (type (+), KnownNat, Nat) import Type.Reflection (TypeRep, Typeable, typeRep) import Type.Reflection.Unsafe (typeRepFingerprint) import Data.Dependent.Map (DMap, empty, insert, keys, lookup) import Data.Some (Some (Some)) -type TypeRepMap = DMap TypeRep +import Spec (BenchSpec (..)) +type TypeRepMap = DMap TypeRep + spec :: BenchSpec spec = BenchSpec - { benchLookup = Just $ \name -> - env mkBigMap $ \ ~(DMapNF bigMap) -> - bench name $ nf tenLookups bigMap - , benchInsertSmall = Just $ \name -> - bench name $ whnf (inserts empty 10) (Proxy @ 99999) - , benchInsertBig = Just $ \name -> - env mkBigMap $ \ ~(DMapNF bigMap) -> - bench name $ whnf (inserts bigMap 1) (Proxy @ 99999) - , benchUpdateSmall = Nothing -- Not implemented - , benchUpdateBig = Nothing -- Not implemented - } + { benchLookup = Just $ \name -> + env mkBigMap $ \ ~(DMapNF bigMap) -> + bench name $ nf tenLookups bigMap + , benchInsertSmall = Just $ \name -> + bench name $ whnf (inserts empty 10) (Proxy @ 99999) + , benchInsertBig = Just $ \name -> + env mkBigMap $ \ ~(DMapNF bigMap) -> + bench name $ whnf (inserts bigMap 1) (Proxy @ 99999) + , benchUpdateSmall = Nothing -- Not implemented + , benchUpdateBig = Nothing -- Not implemented + } -tenLookups :: TypeRepMap (Proxy :: Nat -> *) - -> ( Proxy 10, Proxy 20, Proxy 30, Proxy 40 - , Proxy 50, Proxy 60, Proxy 70, Proxy 80 - ) +tenLookups + :: TypeRepMap (Proxy :: Nat -> Type) + -> ( Proxy 10, Proxy 20, Proxy 30, Proxy 40 + , Proxy 50, Proxy 60, Proxy 70, Proxy 80 + ) tenLookups tmap = (lp, lp, lp, lp, lp, lp, lp, lp) where lp :: forall (a :: Nat) . Typeable a => Proxy a lp = fromJust $ lookup (typeRep @a) tmap -inserts :: forall a . (KnownNat a) - => TypeRepMap (Proxy :: Nat -> *) - -> Int - -> Proxy (a :: Nat) - -> TypeRepMap (Proxy :: Nat -> *) +inserts + :: forall a . (KnownNat a) + => TypeRepMap (Proxy :: Nat -> Type) + -> Int + -> Proxy (a :: Nat) + -> TypeRepMap (Proxy :: Nat -> Type) inserts !c 0 _ = c inserts !c n x = inserts - (insert (typeRep @ a) x c) - (n-1) - (Proxy :: Proxy (a+1)) + (insert (typeRep @ a) x c) + (n-1) + (Proxy :: Proxy (a+1)) -- TypeRepMap of 10000 elements -mkBigMap :: IO (DMapNF (Proxy :: Nat -> *)) +mkBigMap :: IO (DMapNF (Proxy :: Nat -> Type)) mkBigMap = pure . DMapNF $ buildBigMap 10000 (Proxy :: Proxy 0) empty -buildBigMap :: forall a . (KnownNat a) - => Int - -> Proxy (a :: Nat) - -> TypeRepMap (Proxy :: Nat -> *) - -> TypeRepMap (Proxy :: Nat -> *) +buildBigMap + :: forall a . (KnownNat a) + => Int + -> Proxy (a :: Nat) + -> TypeRepMap (Proxy :: Nat -> Type) + -> TypeRepMap (Proxy :: Nat -> Type) buildBigMap 1 x = insert (typeRep @a) x buildBigMap n x = insert (typeRep @a) x . buildBigMap (n - 1) (Proxy @(a + 1)) @@ -82,5 +84,6 @@ newtype DMapNF f = DMapNF (TypeRepMap f) instance NFData (DMapNF f) where - rnf (DMapNF x) = - rnf . map (\(Some t) -> typeRepFingerprint t) $ keys x + rnf :: DMapNF f -> () + rnf (DMapNF x) = + rnf . map (\(Some t) -> typeRepFingerprint t) $ keys x diff --git a/benchmark/Main.hs b/benchmark/Main.hs --- a/benchmark/Main.hs +++ b/benchmark/Main.hs @@ -1,47 +1,52 @@ {-# LANGUAGE CPP #-} -module Main where +module Main + ( main + ) where -import Criterion.Main (defaultMain, bgroup) +import Criterion.Main (bgroup, defaultMain) -import Spec -import qualified CMap +import Spec (BenchSpec (..)) + import qualified CacheMap +import qualified CMap #if ( __GLASGOW_HASKELL__ >= 802 ) import qualified DMap #endif import qualified OptimalVector as OptVec + main :: IO () main = do - let specs = [("CMap", CMap.spec) - ,("CacheMap", CacheMap.spec) + let specs = [("CMap", CMap.spec) + ,("CacheMap", CacheMap.spec) #if ( __GLASGOW_HASKELL__ >= 802 ) - , ("DMap", DMap.spec) + , ("DMap", DMap.spec) #endif - , ("OptVec", OptVec.spec) - ] - -- This code creates a benchmark group. Given a getter - -- (that is test description) it gets a benchmark generation - -- function from each module spec. Benchmark generation - -- function takes a label and generate benchmarks. It's - -- possible to introduce parameters passing in the same way. - mkGroup getBenchmark = - [ mkBenchmark label - | (label, spec) <- specs - -- Here we use pure to force pattern matching in List - -- then in case of pattern match failure `mzero` will - -- be called, so benchmark will be ignored. - , Just mkBenchmark <- pure $ getBenchmark spec + , ("OptVec", OptVec.spec) + ] + {- This code creates a benchmark group. Given a getter + (that is test description) it gets a benchmark generation + function from each module spec. Benchmark generation + function takes a label and generate benchmarks. It's + possible to introduce parameters passing in the same way. + --} + let mkGroup getBenchmark = + [ mkBenchmark label + | (label, spec) <- specs + -- Here we use pure to force pattern matching in List + -- then in case of pattern match failure `mzero` will + -- be called, so benchmark will be ignored. + , Just mkBenchmark <- pure $ getBenchmark spec + ] + defaultMain + [ bgroup "lookup" $ mkGroup benchLookup + , bgroup "insert" + [ bgroup "10 elements to empty" $ mkGroup benchInsertSmall + , bgroup "1 element to big map" $ mkGroup benchInsertBig + ] + , bgroup "update" + [ bgroup "10 elements to empty" $ mkGroup benchUpdateSmall + , bgroup "1 element to big map" $ mkGroup benchUpdateBig + ] ] - defaultMain - [ bgroup "lookup" $ mkGroup benchLookup - , bgroup "insert" - [ bgroup "10 elements to empty" $ mkGroup benchInsertSmall - , bgroup "1 element to big map" $ mkGroup benchInsertBig - ] - , bgroup "update" - [ bgroup "10 elements to empty" $ mkGroup benchUpdateSmall - , bgroup "1 element to big map" $ mkGroup benchUpdateBig - ] - ] diff --git a/benchmark/OptimalVector.hs b/benchmark/OptimalVector.hs --- a/benchmark/OptimalVector.hs +++ b/benchmark/OptimalVector.hs @@ -1,59 +1,60 @@ +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} + {-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} - module OptimalVector ( spec ) where -import Spec -import Criterion.Main (bench, nf, env) - import Prelude hiding (lookup) +import Criterion.Main (bench, env, nf) +import Data.Kind (Type) import Data.Maybe (fromJust) import Data.Proxy (Proxy (..)) import Data.Typeable (Typeable) -import GHC.TypeLits +import GHC.TypeLits (type (+), KnownNat, Nat) import Data.TypeRep.OptimalVector (TF (..), TypeRepMap (..), fromList, lookup) +import Spec (BenchSpec (..)) + + spec :: BenchSpec spec = BenchSpec - { benchLookup = Just $ \name -> - env mkBigMap $ \ ~bigMap -> - bench name $ nf tenLookups bigMap - , benchInsertSmall = Nothing -- Not implemented - , benchInsertBig = Nothing -- Not implemented - , benchUpdateSmall = Nothing -- Not implemented - , benchUpdateBig = Nothing -- Not implemented - } - -tenLookups :: TypeRepMap (Proxy :: Nat -> *) - -> ( Proxy 10, Proxy 20, Proxy 30, Proxy 40 - , Proxy 50, Proxy 60, Proxy 70, Proxy 80 - ) + { benchLookup = Just $ \name -> + env mkBigMap $ \ ~bigMap -> + bench name $ nf tenLookups bigMap + , benchInsertSmall = Nothing -- Not implemented + , benchInsertBig = Nothing -- Not implemented + , benchUpdateSmall = Nothing -- Not implemented + , benchUpdateBig = Nothing -- Not implemented + } + +tenLookups + :: TypeRepMap (Proxy :: Nat -> Type) + -> ( Proxy 10, Proxy 20, Proxy 30, Proxy 40 + , Proxy 50, Proxy 60, Proxy 70, Proxy 80 + ) tenLookups tmap = (lp, lp, lp, lp, lp, lp, lp, lp) where lp :: forall (a::Nat). Typeable a => Proxy a lp = fromJust $ lookup tmap -- TypeRepMap of 10000 elements -mkBigMap :: IO (TypeRepMap (Proxy :: Nat -> *)) +mkBigMap :: IO (TypeRepMap (Proxy :: Nat -> Type)) mkBigMap = pure $ fromList $ buildBigMap 10000 (Proxy :: Proxy 0) [] -buildBigMap :: forall a . (KnownNat a) - => Int - -> Proxy (a :: Nat) - -> [TF (Proxy :: Nat -> *)] - -> [TF (Proxy :: Nat -> *)] +buildBigMap + :: forall a . (KnownNat a) + => Int + -> Proxy (a :: Nat) + -> [TF (Proxy :: Nat -> Type)] + -> [TF (Proxy :: Nat -> Type)] buildBigMap 1 x = (TF x :) buildBigMap n x = (TF x :) . buildBigMap (n - 1) (Proxy :: Proxy (a + 1)) - diff --git a/benchmark/Spec.hs b/benchmark/Spec.hs --- a/benchmark/Spec.hs +++ b/benchmark/Spec.hs @@ -1,53 +1,64 @@ --- | Specification of the benchmarks. --- This module keeps a list of all bencharks, this way --- we can group benchmark by the interesting function, not --- by the implementation. +{- | Specification of the benchmarks. + +This module keeps a list of all bencharks, this way +we can group benchmark by the interesting function, not +by the implementation. +-} module Spec - ( BenchSpec(..) - ) where + ( BenchSpec(..) + ) where -import Criterion +import Criterion (Benchmark) --- | List of benchmarks that each module should provide. --- If implementation can express the benchmark then it --- can return @Nothing@ in that benchmark. --- --- Map should contain elements from @1@ to @size of map@ --- inserted in ascending order (later that requirement may --- change). + +{- | List of benchmarks that each module should provide. +If implementation can express the benchmark then it +can return @Nothing@ in that benchmark. + +Map should contain elements from @1@ to @size of map@ +inserted in ascending order (later that requirement may +change). +-} data BenchSpec = BenchSpec - { benchLookup :: Maybe (String -> Benchmark) - -- ^ Basic lookup we look 10 values inside 10k map. - -- - -- Implementation may look like: - -- @ - -- tenLookups :: TypeRepMap (Proxy :: Nat -> *) - -- -> ( Proxy 10, Proxy 20, Proxy 30, Proxy 40 - -- , Proxy 50, Proxy 60, Proxy 70, Proxy 80 - -- ) - -- tenLookups tmap = (lp, lp, lp, lp, lp, lp, lp, lp) - -- @ - , benchInsertSmall :: Maybe (String -> Benchmark) - -- ^ Insert 10 elements into an empty map. - -- - -- Implementation may look like: - -- @ - -- inserts :: forall a . (KnownNat a) - -- => TypeRepMap (Proxy :: Nat -> *) - -- -> Int - -- -> Proxy (a :: Nat) - -- -> TypeRepMap (Proxy :: Nat -> *) - -- inserts !c 0 _ = c - -- inserts !c n x = inserts (insert x c) (n-1) (Proxy :: Proxy (a+1)) - -- @ - , benchInsertBig :: Maybe (String -> Benchmark) - -- ^ Insert 10 elements into a big map. Implementation is like - -- a small map, but should insert values into 10k elements map. - , benchUpdateSmall :: Maybe (String -> Benchmark) - -- ^ Insert 10 elements into map of 10 elements, where each key - -- was already inserted in the map - , benchUpdateBig :: Maybe (String -> Benchmark) - -- ^ Insert 10 elements into map of 10k elements, where each key - -- was already inserted in the map - } + { {- | Basic lookup we look 10 values inside 10k map. + Implementation may look like: + + @ + tenLookups :: TypeRepMap (Proxy :: Nat -> *) + -> ( Proxy 10, Proxy 20, Proxy 30, Proxy 40 + , Proxy 50, Proxy 60, Proxy 70, Proxy 80 + ) + tenLookups tmap = (lp, lp, lp, lp, lp, lp, lp, lp) + @ + -} + benchLookup :: Maybe (String -> Benchmark) + {- ^ Insert 10 elements into an empty map. + + Implementation may look like: + + @ + inserts + :: forall a . (KnownNat a) + => TypeRepMap (Proxy :: Nat -> *) + -> Int + -> Proxy (a :: Nat) + -> TypeRepMap (Proxy :: Nat -> *) + inserts !c 0 _ = c + inserts !c n x = inserts (insert x c) (n-1) (Proxy :: Proxy (a+1)) + @ + -} + , benchInsertSmall :: Maybe (String -> Benchmark) + {- ^ Insert 10 elements into a big map. Implementation is like + a small map, but should insert values into 10k elements map. + -} + , benchInsertBig :: Maybe (String -> Benchmark) + {- ^ Insert 10 elements into map of 10 elements, where each key + was already inserted in the map + -} + , benchUpdateSmall :: Maybe (String -> Benchmark) + {- ^ Insert 10 elements into map of 10k elements, where each key + was already inserted in the map + -} + , benchUpdateBig :: Maybe (String -> Benchmark) + } diff --git a/benchmark/Vector.hs b/benchmark/Vector.hs --- a/benchmark/Vector.hs +++ b/benchmark/Vector.hs @@ -1,32 +1,31 @@ +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} + {-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} - module Vector - ( benchVector - , prepareBenchVector - ) where - -import Criterion.Main (Benchmark, bench, bgroup, nf) + ( benchVector + , prepareBenchVector + ) where import Prelude hiding (lookup) import Control.DeepSeq (rnf) -import Control.Exception +import Control.Exception (evaluate) +import Criterion.Main (Benchmark, bench, bgroup, nf) +import Data.Kind (Type) import Data.Maybe (fromJust) import Data.Proxy (Proxy (..)) import Data.Typeable (Typeable) -import GHC.TypeLits +import GHC.TypeLits (type (+), KnownNat, Nat) -import Data.TypeRep.Vector +import Data.TypeRep.Vector (TF (..), TypeRepVector, fingerprints, fromList, lookup) + benchVector :: Benchmark benchVector = bgroup "vector" [ bench "lookup" $ nf tenLookups bigMap @@ -34,24 +33,26 @@ -- , bench "update old" $ whnf (\x -> rknf $ insert x bigMap) (Proxy :: Proxy 1) ] -tenLookups :: TypeRepVector (Proxy :: Nat -> *) - -> ( Proxy 10, Proxy 20, Proxy 30, Proxy 40 - , Proxy 50, Proxy 60, Proxy 70, Proxy 80 - ) +tenLookups + :: TypeRepVector (Proxy :: Nat -> Type) + -> ( Proxy 10, Proxy 20, Proxy 30, Proxy 40 + , Proxy 50, Proxy 60, Proxy 70, Proxy 80 + ) tenLookups tmap = (lp, lp, lp, lp, lp, lp, lp, lp) where lp :: forall (a::Nat). Typeable a => Proxy a lp = fromJust $ lookup tmap -- TypeRepMap of 10000 elements -bigMap :: TypeRepVector (Proxy :: Nat -> *) +bigMap :: TypeRepVector (Proxy :: Nat -> Type) bigMap = fromList $ buildBigMap 10000 (Proxy :: Proxy 0) [] -buildBigMap :: forall a . (KnownNat a) - => Int - -> Proxy (a :: Nat) - -> [TF (Proxy :: Nat -> *)] - -> [TF (Proxy :: Nat -> *)] +buildBigMap + :: forall a . (KnownNat a) + => Int + -> Proxy (a :: Nat) + -> [TF (Proxy :: Nat -> Type)] + -> [TF (Proxy :: Nat -> Type)] buildBigMap 1 x = (TF x :) buildBigMap n x = (TF x :) . buildBigMap (n - 1) (Proxy :: Proxy (a + 1)) diff --git a/src/Data/TMap.hs b/src/Data/TMap.hs --- a/src/Data/TMap.hs +++ b/src/Data/TMap.hs @@ -2,6 +2,10 @@ {-# LANGUAGE Rank2Types #-} {- | +Copyright: (c) 2017-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + 'TMap' is a heterogeneous data structure similar in its essence to 'Data.Map.Map' with types as keys, where each value has the type of its key. @@ -166,5 +170,5 @@ adjust f = F.adjust (liftToIdentity f) {-# INLINE adjust #-} -liftToIdentity :: forall a. Typeable a => (a -> a) -> Identity a -> Identity a +liftToIdentity :: forall a. (a -> a) -> Identity a -> Identity a liftToIdentity = coerce diff --git a/src/Data/TypeRepMap.hs b/src/Data/TypeRepMap.hs --- a/src/Data/TypeRepMap.hs +++ b/src/Data/TypeRepMap.hs @@ -1,45 +1,50 @@ {-# LANGUAGE NoImplicitPrelude #-} --- | A version of 'Data.TMap.TMap' parametrized by an interpretation @f@. This --- sort of parametrization may be familiar to users of @vinyl@ records. --- --- @'TypeRepMap' f@ is a more efficient replacement for @DMap --- 'Type.Reflection.TypeRep' f@ (where @DMap@ is from the @dependent-map@ --- package). --- --- Here is an example of using 'Prelude.Maybe' as an interpretation, with a --- comparison to 'Data.TMap.TMap': --- --- @ --- 'Data.TMap.TMap' 'TypeRepMap' 'Prelude.Maybe' --- -------------- ------------------- --- Int -> 5 Int -> Just 5 --- Bool -> True Bool -> Nothing --- Char -> \'x\' Char -> Just \'x\' --- @ --- --- In fact, a 'Data.TMap.TMap' is defined as 'TypeRepMap' --- 'Data.Functor.Identity'. --- --- Since 'Type.Reflection.TypeRep' is poly-kinded, the interpretation can use --- any kind for the keys. For instance, we can use the 'GHC.TypeLits.Symbol' --- kind to use 'TypeRepMap' as an extensible record: --- --- @ --- newtype Field name = F (FType name) --- --- type family FType (name :: Symbol) :: Type --- type instance FType "radius" = Double --- type instance FType "border-color" = RGB --- type instance FType "border-width" = Double --- --- 'TypeRepMap' Field --- -------------------------------------- --- "radius" -> F 5.7 --- "border-color" -> F (rgb 148 0 211) --- "border-width" -> F 0.5 --- @ --- +{- | +Copyright: (c) 2017-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + + A version of 'Data.TMap.TMap' parametrized by an interpretation @f@. This +sort of parametrization may be familiar to users of @vinyl@ records. + +@'TypeRepMap' f@ is a more efficient replacement for @DMap +'Type.Reflection.TypeRep' f@ (where @DMap@ is from the @dependent-map@ +package). + +Here is an example of using 'Prelude.Maybe' as an interpretation, with a +comparison to 'Data.TMap.TMap': + +@ + 'Data.TMap.TMap' 'TypeRepMap' 'Prelude.Maybe' +-------------- ------------------- + Int -> 5 Int -> Just 5 + Bool -> True Bool -> Nothing + Char -> \'x\' Char -> Just \'x\' +@ + +In fact, a 'Data.TMap.TMap' is defined as 'TypeRepMap' +'Data.Functor.Identity'. + +Since 'Type.Reflection.TypeRep' is poly-kinded, the interpretation can use +any kind for the keys. For instance, we can use the 'GHC.TypeLits.Symbol' +kind to use 'TypeRepMap' as an extensible record: + +@ +newtype Field name = F (FType name) + +type family FType (name :: Symbol) :: Type +type instance FType "radius" = Double +type instance FType "border-color" = RGB +type instance FType "border-width" = Double + + 'TypeRepMap' Field +-------------------------------------- + "radius" -> F 5.7 + "border-color" -> F (rgb 148 0 211) + "border-width" -> F 0.5 +@ +--} module Data.TypeRepMap ( -- * Map type TypeRepMap() diff --git a/src/Data/TypeRepMap/Internal.hs b/src/Data/TypeRepMap/Internal.hs --- a/src/Data/TypeRepMap/Internal.hs +++ b/src/Data/TypeRepMap/Internal.hs @@ -1,10 +1,11 @@ +{-# OPTIONS_GHC -Wno-missing-export-lists #-} + {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE Rank2Types #-} @@ -18,13 +19,20 @@ -- {-# OPTIONS_GHC -ddump-simpl -dsuppress-idinfo -dsuppress-coercions -dsuppress-type-applications -dsuppress-uniques -dsuppress-module-prefixes #-} -{- | Internal API for 'TypeRepMap' and operations on it. The functions here do +{- | +Copyright: (c) 2017-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +Internal API for 'TypeRepMap' and operations on it. The functions here do not have any stability guarantees and can change between minor versions. If you need to use this module for purposes other than tests, create an issue. -} +#include "MachDeps.h" + module Data.TypeRepMap.Internal where import Prelude hiding (lookup) @@ -36,14 +44,21 @@ import Data.Kind (Type) import Data.Type.Equality ((:~:) (..), TestEquality (..)) import Data.List (intercalate, nubBy) +import Data.Maybe (fromMaybe) import Data.Primitive.Array (Array, MutableArray, indexArray, mapArray', readArray, sizeofArray, thawArray, unsafeFreezeArray, writeArray) import Data.Primitive.PrimArray (PrimArray, indexPrimArray, sizeofPrimArray) -import Data.Semigroup (Semigroup (..)) +import Data.Semigroup (Semigroup (..), All(..)) import GHC.Base (Any, Int (..), Int#, (*#), (+#), (<#)) import GHC.Exts (IsList (..), inline, sortWith) import GHC.Fingerprint (Fingerprint (..)) +#if WORD_SIZE_IN_BITS >= 64 import GHC.Prim (eqWord#, ltWord#) +#else +import GHC.IntWord64 (eqWord64#, ltWord64#) +#define eqWord eqWord64 +#define ltWord ltWord64 +#endif import GHC.Word (Word64 (..)) import Type.Reflection (SomeTypeRep (..), TypeRep, Typeable, typeRep, withTypeable) import Type.Reflection.Unsafe (typeRepFingerprint) @@ -448,3 +463,61 @@ newFirst <- loop (2 * i + 1) first writeArray result i (indexArray origin newFirst) loop (2 * i + 2) (newFirst + 1) + +---------------------------------------------------------------------------- +-- Helper functions. +---------------------------------------------------------------------------- + +-- | Check that invariant of the structure is hold. +-- The structure maintains the following invariant. +-- For each element @A@ at index @i@: +-- +-- 1. if there is an element @B@ at index @2*i+1@, +-- then @B < A@. +-- +-- 2. if there is an element @C@ at index @2*i+2@, +-- then @A < C@. +-- +invariantCheck :: TypeRepMap f -> Bool +invariantCheck TypeRepMap{..} = getAll (check 0) + where + lastMay [] = Nothing + lastMay [x] = Just x + lastMay (_:xs) = lastMay xs + sz = sizeofPrimArray fingerprintAs + check i | i >= sz = All True + | otherwise = + let left = i*2+1 + right = i*2+2 + -- maximum value in the left branch + leftMax = + fmap (\j -> (indexPrimArray fingerprintAs j, indexPrimArray fingerprintBs j)) + $ lastMay + $ takeWhile ( j*2+2) left + -- minimum value in the right branch + rightMin = + fmap (\j -> (indexPrimArray fingerprintAs j, indexPrimArray fingerprintBs j)) + $ lastMay + $ takeWhile ( j*2+1) right + in mconcat + [ All $ + if left < sz + then + case indexPrimArray fingerprintAs i `compare` indexPrimArray fingerprintAs left of + LT -> False + EQ -> indexPrimArray fingerprintBs i >= indexPrimArray fingerprintBs left + GT -> True + else True + , All $ + if right < sz + then + case indexPrimArray fingerprintAs i `compare` indexPrimArray fingerprintAs right of + LT -> True + EQ -> indexPrimArray fingerprintBs i <= indexPrimArray fingerprintBs right + GT -> False + else True + , All $ fromMaybe True $ (<=) <$> leftMax <*> rightMin + , check (i+1) + ] diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -1,1 +1,21 @@ -{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-} +module Main + ( main + ) where + +import Test.Hspec (hspec) + +import Test.TypeRep.CMap (cMapSpec) +import Test.TypeRep.TypeRepMap (typeRepMapSpec) +import Test.TypeRep.TypeRepMapProperty (typeRepMapPropertySpec) +import Test.TypeRep.Vector (vectorSpec) +import Test.TypeRep.VectorOpt (optimalVectorSpec) + + +main :: IO () +main = hspec $ do + typeRepMapSpec + cMapSpec + vectorSpec + optimalVectorSpec + -- property + typeRepMapPropertySpec diff --git a/test/Test/TypeRep/CMap.hs b/test/Test/TypeRep/CMap.hs --- a/test/Test/TypeRep/CMap.hs +++ b/test/Test/TypeRep/CMap.hs @@ -1,16 +1,18 @@ -module Test.TypeRep.CMap where +module Test.TypeRep.CMap + ( cMapSpec + ) where import Prelude hiding (lookup) import Data.Functor.Identity (Identity (..)) +import Test.Hspec (Spec, describe, it, shouldBe) -import Test.Tasty.Hspec +import Data.TypeRep.CMap (TypeRepMap, empty, insert, lookup, size) -import Data.TypeRep.CMap --- Simple test for 'lookup', 'insert' and 'size' functions. -spec_insertLookup :: Spec -spec_insertLookup = do +-- | Simple test for 'lookup', 'insert' and 'size' functions. +cMapSpec :: Spec +cMapSpec = describe "Containers Map TypeRep" $ do describe "Lookup Test" $ do it "returns the inserted element" $ lookup (insert (Identity 'a') empty) `shouldBe` Just (Identity 'a') @@ -35,7 +37,7 @@ $ insert (Identity $ Just ()) $ insert (Identity [()]) $ insert (Identity ()) - $ insert (Identity "aaa") + $ insert (Identity @String "aaa") $ insert (Identity $ Just 'a') $ insert (Identity 'a') $ insert (Identity (11 :: Int)) empty diff --git a/test/Test/TypeRep/CacheMap.hs b/test/Test/TypeRep/CacheMap.hs deleted file mode 100644 --- a/test/Test/TypeRep/CacheMap.hs +++ /dev/null @@ -1,50 +0,0 @@ -module Test.TypeRep.CacheMap where - -import Prelude hiding (lookup) - -import Data.Functor.Identity (Identity (..)) -import GHC.Exts (fromList) -import Test.Tasty.Hspec (Spec, describe, it, shouldBe) - -import Data.TMap (TMap, empty, insert, lookup, one, size, union) -import Data.TypeRepMap.Internal (WrapTypeable (..)) - --- Simple test for 'lookup', 'insert' and 'size' functions. -spec_insertLookup :: Spec -spec_insertLookup = do - describe "Lookup Test" $ do - it "returns the inserted element" $ - lookup (fromList [WrapTypeable $ Identity 'a']) `shouldBe` Just 'a' - it "returns the second inserted value of the same type" $ - lookup (fromList [WrapTypeable (Identity 'b'), WrapTypeable (Identity 'a')]) `shouldBe` Just 'b' - - describe "Size Test" $ do - it "is empty" $ - size empty `shouldBe` 0 - it "is of size 1 when 1 element inserted" $ - size (one 'a') `shouldBe` 1 - it "doesn't increase size when element of the same type is added" $ - size (insert 'b' $ insert 'a' empty) `shouldBe` 1 - it "returns 10 when 10 different types are inserted" $ - size mapOf10 `shouldBe` 10 - - describe "Union test" $ do - let m = fromList [WrapTypeable $ Identity 'a', WrapTypeable $ Identity True] `union` - fromList [WrapTypeable $ Identity 'b'] - it "lookup works on union as expected" $ do - lookup m `shouldBe` Just 'a' - lookup m `shouldBe` Just True - lookup @Int m `shouldBe` Nothing - - -mapOf10 :: TMap -mapOf10 = insert True - $ insert [True, False] - $ insert (Just True) - $ insert (Just ()) - $ insert [()] - $ insert () - $ insert "aaa" - $ insert (Just 'a') - $ insert 'a' - $ insert (11 :: Int) empty diff --git a/test/Test/TypeRep/MapProperty.hs b/test/Test/TypeRep/MapProperty.hs deleted file mode 100644 --- a/test/Test/TypeRep/MapProperty.hs +++ /dev/null @@ -1,123 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE PolyKinds #-} - -{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} - -module Test.TypeRep.MapProperty where - -import Prelude hiding (lookup) - -import Data.Proxy (Proxy (..)) -import Data.Semigroup (Semigroup (..)) -import GHC.Exts (fromList) -import GHC.Stack (HasCallStack) -import GHC.TypeLits (Nat, SomeNat (..), someNatVal) -import Hedgehog (MonadGen, PropertyT, forAll, property, (===)) -import Test.Tasty (TestName, TestTree) -import Test.Tasty.Hedgehog (testProperty) - -import Data.TypeRepMap.Internal (TypeRepMap (..), WrapTypeable (..), delete, insert, lookup, member) - -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range - ----------------------------------------------------------------------------- --- Common utils ----------------------------------------------------------------------------- - -type PropertyTest = [TestTree] - -prop :: HasCallStack => TestName -> PropertyT IO () -> PropertyTest -prop testName = pure . testProperty testName . property - ----------------------------------------------------------------------------- --- Map modification properties ----------------------------------------------------------------------------- - -test_InsertLookup :: PropertyTest -test_InsertLookup = prop "lookup k (insert k v m) == Just v" $ do - m <- forAll genMap - WrapTypeable (proxy :: IntProxy n) <- forAll genTF - - lookup @n @IntProxy (insert proxy m) === Just proxy - -test_InsertInsert :: PropertyTest -test_InsertInsert = prop "insert k b . insert k a == insert k b" $ do - m <- forAll genMap - WrapTypeable a@(IntProxy (proxy :: Proxy n) i) <- forAll genTF - let b = IntProxy proxy (i + 1) - lookup @n @IntProxy (insert b $ insert a m) === Just b - -test_DeleteMember :: PropertyTest -test_DeleteMember = prop "member k . delete k == False" $ do - m <- forAll genMap - WrapTypeable (proxy :: IntProxy n) <- forAll genTF - shouldInsert <- forAll Gen.bool - - if shouldInsert then - member @n (delete @n $ insert proxy m) === False - else - member @n (delete @n m) === False - ----------------------------------------------------------------------------- --- Semigroup and Monoid laws ----------------------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ < 806 --- This newtype is used to compare 'TypeRepMap's using only 'Fingerprint's. It's --- not a good idea to write such `Eq` instance for `TypeRepMap` itself because --- it doesn't compare values so it's not true equality. But this should be --- enough for tests. -newtype FpMap f = FpMap (TypeRepMap f) - deriving (Show, Semigroup, Monoid) - -instance Eq (FpMap f) where - FpMap (TypeRepMap as1 bs1 _ _) == FpMap (TypeRepMap as2 bs2 _ _) = - as1 == as2 && bs1 == bs2 -#endif - -test_SemigroupAssoc :: PropertyTest -test_SemigroupAssoc = prop "x <> (y <> z) == (x <> y) <> z" $ do -#if __GLASGOW_HASKELL__ >= 806 - x <- forAll genMap - y <- forAll genMap - z <- forAll genMap -#else - x <- FpMap <$> forAll genMap - y <- FpMap <$> forAll genMap - z <- FpMap <$> forAll genMap -#endif - - (x <> (y <> z)) === ((x <> y) <> z) - -test_MonoidIdentity :: PropertyTest -test_MonoidIdentity = prop "x <> mempty == mempty <> x == x" $ do -#if __GLASGOW_HASKELL__ >= 806 - x <- forAll genMap -#else - x <- FpMap <$> forAll genMap -#endif - - x <> mempty === x - mempty <> x === x - ----------------------------------------------------------------------------- --- Generators ----------------------------------------------------------------------------- - -data IntProxy (n :: Nat) = IntProxy (Proxy n) Int - deriving (Show, Eq) - -genMap :: MonadGen m => m (TypeRepMap IntProxy) -genMap = fromList <$> Gen.list (Range.linear 0 1000) genTF - -genTF :: MonadGen m => m (WrapTypeable IntProxy) -genTF = do - randNat :: Integer <- Gen.integral (Range.linear 0 10000) - randInt <- Gen.int Range.constantBounded - case someNatVal randNat of - Just (SomeNat proxyNat) -> pure $ WrapTypeable $ IntProxy proxyNat randInt - Nothing -> error "Invalid test generator" diff --git a/test/Test/TypeRep/TypeRepMap.hs b/test/Test/TypeRep/TypeRepMap.hs new file mode 100644 --- /dev/null +++ b/test/Test/TypeRep/TypeRepMap.hs @@ -0,0 +1,53 @@ +module Test.TypeRep.TypeRepMap + ( typeRepMapSpec + ) where + +import Prelude hiding (lookup) + +import Data.Functor.Identity (Identity (..)) +import GHC.Exts (fromList) +import Test.Hspec (Spec, describe, it, shouldBe) + +import Data.TMap (TMap, empty, insert, lookup, one, size, union) +import Data.TypeRepMap.Internal (WrapTypeable (..)) + + +-- Simple test for 'lookup', 'insert' and 'size' functions. +typeRepMapSpec :: Spec +typeRepMapSpec = describe "TypeRepMap" $ do + describe "Lookup Test" $ do + it "returns the inserted element" $ + lookup (fromList [WrapTypeable $ Identity 'a']) `shouldBe` Just 'a' + it "returns the second inserted value of the same type" $ + lookup (fromList [WrapTypeable (Identity 'b'), WrapTypeable (Identity 'a')]) `shouldBe` Just 'b' + + describe "Size Test" $ do + it "is empty" $ + size empty `shouldBe` 0 + it "is of size 1 when 1 element inserted" $ + size (one 'a') `shouldBe` 1 + it "doesn't increase size when element of the same type is added" $ + size (insert 'b' $ insert 'a' empty) `shouldBe` 1 + it "returns 10 when 10 different types are inserted" $ + size mapOf10 `shouldBe` 10 + + describe "Union test" $ do + let m = fromList [WrapTypeable $ Identity 'a', WrapTypeable $ Identity True] `union` + fromList [WrapTypeable $ Identity 'b'] + it "lookup works on union as expected" $ do + lookup m `shouldBe` Just 'a' + lookup m `shouldBe` Just True + lookup @Int m `shouldBe` Nothing + + +mapOf10 :: TMap +mapOf10 = insert True + $ insert [True, False] + $ insert (Just True) + $ insert (Just ()) + $ insert [()] + $ insert () + $ insert @String "aaa" + $ insert (Just 'a') + $ insert 'a' + $ insert (11 :: Int) empty diff --git a/test/Test/TypeRep/TypeRepMapProperty.hs b/test/Test/TypeRep/TypeRepMapProperty.hs new file mode 100644 --- /dev/null +++ b/test/Test/TypeRep/TypeRepMapProperty.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PolyKinds #-} + +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} + +module Test.TypeRep.TypeRepMapProperty + ( typeRepMapPropertySpec + ) where + +import Prelude hiding (lookup) + +import Data.Proxy (Proxy (..)) +import Data.Semigroup (Semigroup (..)) +import GHC.Exts (fromList) +import GHC.TypeLits (Nat, SomeNat (..), someNatVal) +import Hedgehog (MonadGen, assert, forAll, (===)) +import Test.Hspec (Arg, Expectation, Spec, SpecWith, describe, it) +import Test.Hspec.Hedgehog (hedgehog) + +import Data.TypeRepMap.Internal (TypeRepMap (..), WrapTypeable (..), delete, insert, invariantCheck, + lookup, member) + +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + + +typeRepMapPropertySpec :: Spec +typeRepMapPropertySpec = describe "TypeRepMap Property tests" $ do + describe "Map modification properties" $ do + insertLookupSpec + insertInsertSpec + deleteMemberSpec + insertInvariantSpec + deleteInvariantSpec + describe "Instance Laws" $ do + semigroupAssocSpec + monoidIdentitySpec + +---------------------------------------------------------------------------- +-- Map modification properties +---------------------------------------------------------------------------- + +type Property = SpecWith (Arg Expectation) + +insertLookupSpec :: Property +insertLookupSpec = it "lookup k (insert k v m) == Just v" $ hedgehog $ do + m <- forAll genMap + WrapTypeable (proxy :: IntProxy n) <- forAll genTF + lookup @n @IntProxy (insert proxy m) === Just proxy + +insertInsertSpec :: Property +insertInsertSpec = it "insert k b . insert k a == insert k b" $ hedgehog $ do + m <- forAll genMap + WrapTypeable a@(IntProxy (proxy :: Proxy n) i) <- forAll genTF + let b = IntProxy proxy (i + 1) + lookup @n @IntProxy (insert b $ insert a m) === Just b + +deleteMemberSpec :: Property +deleteMemberSpec = it "member k . delete k == False" $ hedgehog $ do + m <- forAll genMap + WrapTypeable (proxy :: IntProxy n) <- forAll genTF + shouldInsert <- forAll Gen.bool + + if shouldInsert then + member @n (delete @n $ insert proxy m) === False + else + member @n (delete @n m) === False + +insertInvariantSpec :: Property +insertInvariantSpec = it "invariantCheck (insert k b) == True" $ hedgehog $ do + m <- forAll genMap + WrapTypeable a <- forAll genTF + assert $ invariantCheck (insert a m) + +deleteInvariantSpec :: Property +deleteInvariantSpec = it "invariantCheck (delete k b) == True" $ hedgehog $ do + m <- forAll genMap + WrapTypeable (_ :: IntProxy n) <- forAll genTF + assert $ invariantCheck (delete @n m) + +---------------------------------------------------------------------------- +-- Semigroup and Monoid laws +---------------------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ < 806 +{- | This newtype is used to compare 'TypeRepMap's using only 'Fingerprint's. +It's not a good idea to write such 'Eq' instance for 'TypeRepMap' itself because +it doesn't compare values so it's not true equality. But this should be enough +for tests. +-} +newtype FpMap f = FpMap (TypeRepMap f) + deriving newtype (Show, Semigroup, Monoid) + +instance Eq (FpMap f) where + FpMap (TypeRepMap as1 bs1 _ _) == FpMap (TypeRepMap as2 bs2 _ _) = + as1 == as2 && bs1 == bs2 +#endif + +semigroupAssocSpec :: Property +semigroupAssocSpec = it "x <> (y <> z) == (x <> y) <> z" $ hedgehog $ do +#if __GLASGOW_HASKELL__ >= 806 + x <- forAll genMap + y <- forAll genMap + z <- forAll genMap +#else + x <- FpMap <$> forAll genMap + y <- FpMap <$> forAll genMap + z <- FpMap <$> forAll genMap +#endif + (x <> (y <> z)) === ((x <> y) <> z) + +monoidIdentitySpec :: Property +monoidIdentitySpec = it "x <> mempty == mempty <> x == x" $ hedgehog $ do +#if __GLASGOW_HASKELL__ >= 806 + x <- forAll genMap +#else + x <- FpMap <$> forAll genMap +#endif + + x <> mempty === x + mempty <> x === x + +---------------------------------------------------------------------------- +-- Generators +---------------------------------------------------------------------------- + +data IntProxy (n :: Nat) = IntProxy (Proxy n) Int + deriving stock (Show, Eq) + +genMap :: MonadGen m => m (TypeRepMap IntProxy) +genMap = fromList <$> Gen.list (Range.linear 0 1000) genTF + +genTF :: MonadGen m => m (WrapTypeable IntProxy) +genTF = do + randNat :: Integer <- Gen.integral (Range.linear 0 10000) + randInt <- Gen.int Range.constantBounded + case someNatVal randNat of + Just (SomeNat proxyNat) -> pure $ WrapTypeable $ IntProxy proxyNat randInt + Nothing -> error "Invalid test generator" diff --git a/test/Test/TypeRep/Vector.hs b/test/Test/TypeRep/Vector.hs --- a/test/Test/TypeRep/Vector.hs +++ b/test/Test/TypeRep/Vector.hs @@ -1,16 +1,18 @@ -module Test.TypeRep.Vector where +module Test.TypeRep.Vector + ( vectorSpec + ) where import Prelude hiding (lookup) import Data.Functor.Identity (Identity (..)) +import Test.Hspec (Spec, describe, it, shouldBe) -import Test.Tasty.Hspec +import Data.TypeRep.Vector (TF (..), fromList, lookup) -import Data.TypeRep.Vector --- Simple test for 'lookup', 'insert' and 'size' functions. -spec_insertLookup :: Spec -spec_insertLookup = +-- | Simple test for 'lookup', 'insert' and 'size' functions. +vectorSpec :: Spec +vectorSpec = describe "Vector TypeRep" $ describe "Lookup Test" $ do it "returns the inserted element" $ lookup (fromList [TF (Identity 'a')]) `shouldBe` Just (Identity 'a') diff --git a/test/Test/TypeRep/VectorOpt.hs b/test/Test/TypeRep/VectorOpt.hs --- a/test/Test/TypeRep/VectorOpt.hs +++ b/test/Test/TypeRep/VectorOpt.hs @@ -1,16 +1,18 @@ -module Test.TypeRep.VectorOpt where +module Test.TypeRep.VectorOpt + ( optimalVectorSpec + ) where import Prelude hiding (lookup) import Data.Functor.Identity (Identity (..)) - -import Test.Tasty.Hspec +import Test.Hspec (Spec, describe, it, shouldBe) import Data.TypeRep.OptimalVector (TF (..), fromList, lookup) --- Simple test for 'lookup', 'insert' and 'size' functions. -spec_insertLookup :: Spec -spec_insertLookup = + +-- | Simple test for 'lookup', 'insert' and 'size' functions. +optimalVectorSpec :: Spec +optimalVectorSpec = describe "Optimal Vector TypeRep" $ describe "Lookup Test" $ do it "returns the inserted element" $ lookup (fromList [TF $ Identity 'a']) `shouldBe` Just (Identity 'a') diff --git a/typerep-extra-impls/Data/TypeRep/CMap.hs b/typerep-extra-impls/Data/TypeRep/CMap.hs --- a/typerep-extra-impls/Data/TypeRep/CMap.hs +++ b/typerep-extra-impls/Data/TypeRep/CMap.hs @@ -1,6 +1,13 @@ -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE PolyKinds #-} +{- | +Copyright: (c) 2017-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +TypeRepMap implementation based on @containers@ 'Map'. +-} + module Data.TypeRep.CMap ( TypeRepMap (..) , empty @@ -13,6 +20,7 @@ import Prelude hiding (lookup) import Control.DeepSeq +import Data.Kind (Type) import Data.Proxy (Proxy (..)) import Data.Typeable (TypeRep, Typeable, typeRep) import GHC.Base (Any) @@ -20,8 +28,9 @@ import qualified Data.Map.Lazy as LMap + -- | Map-like data structure with types served as the keys. -newtype TypeRepMap (f :: k -> *) = TypeRepMap +newtype TypeRepMap (f :: k -> Type) = TypeRepMap { unMap :: LMap.Map TypeRep Any } diff --git a/typerep-extra-impls/Data/TypeRep/OptimalVector.hs b/typerep-extra-impls/Data/TypeRep/OptimalVector.hs --- a/typerep-extra-impls/Data/TypeRep/OptimalVector.hs +++ b/typerep-extra-impls/Data/TypeRep/OptimalVector.hs @@ -1,10 +1,17 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{- | +Copyright: (c) 2017-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +TypeRepMap implementation based on the optimal Vector. +-} + module Data.TypeRep.OptimalVector ( -- * Map type TypeRepMap (..) @@ -36,6 +43,7 @@ import qualified Data.Vector as V import qualified Data.Vector.Unboxed as Unboxed + data TypeRepMap (f :: k -> Type) = TypeRepMap { fingerprintAs :: Unboxed.Vector Word64 , fingerprintBs :: Unboxed.Vector Word64 @@ -53,7 +61,7 @@ empty = TypeRepMap mempty mempty mempty -- | Inserts the value with its type as a key. -insert :: forall a f . Typeable a => a -> TypeRepMap f -> TypeRepMap f +insert :: forall a f . a -> TypeRepMap f -> TypeRepMap f insert = undefined -- | Looks up the value at the type. @@ -103,7 +111,7 @@ data TF f where TF :: Typeable a => f a -> TF f -fromF :: Typeable a => f a -> Proxy a +fromF :: f a -> Proxy a fromF _ = Proxy fromList :: forall f . [TF f] -> TypeRepMap f diff --git a/typerep-extra-impls/Data/TypeRep/Vector.hs b/typerep-extra-impls/Data/TypeRep/Vector.hs --- a/typerep-extra-impls/Data/TypeRep/Vector.hs +++ b/typerep-extra-impls/Data/TypeRep/Vector.hs @@ -7,6 +7,14 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} +{- | +Copyright: (c) 2017-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +TypeRepMap implementation based on Vector. +-} + module Data.TypeRep.Vector ( TypeRepVector (..) , TF (..) @@ -33,6 +41,7 @@ import qualified Data.Vector.Generic.Mutable as M import qualified Data.Vector.Unboxed as Unboxed + data instance Unboxed.MVector s Fingerprint = MFingerprintVector (Unboxed.MVector s Word64) (Unboxed.MVector s Word64) data instance Unboxed.Vector Fingerprint = FingerprintVector (Unboxed.Vector Word64) (Unboxed.Vector Word64) @@ -135,7 +144,7 @@ empty = TypeRepVect mempty mempty -- | Inserts the value with its type as a key. -insert :: forall a f . Typeable a => a -> TypeRepVector f -> TypeRepVector f +insert :: forall a f . a -> TypeRepVector f -> TypeRepVector f insert = undefined -- | Looks up the value at the type. @@ -155,7 +164,7 @@ data TF f where TF :: Typeable a => f a -> TF f -fromF :: Typeable a => f a -> Proxy a +fromF :: f a -> Proxy a fromF _ = Proxy fromList :: forall f . [TF f] -> TypeRepVector f diff --git a/typerep-map.cabal b/typerep-map.cabal --- a/typerep-map.cabal +++ b/typerep-map.cabal @@ -1,5 +1,6 @@ +cabal-version: 2.4 name: typerep-map -version: 0.3.2 +version: 0.3.3.0 synopsis: Efficient implementation of a dependent map with types as keys description: A dependent map from type representations to values of these types. @@ -18,107 +19,116 @@ homepage: https://github.com/kowainik/typerep-map bug-reports: https://github.com/kowainik/typerep-map/issues -license: MIT +license: MPL-2.0 license-file: LICENSE -author: Kowainik, Vladislav Zavialov -maintainer: xrom.xkov@gmail.com -copyright: 2017-2019 Kowainik +author: Veronika Romashkina, Vladislav Zavialov, Dmitrii Kovanikov +maintainer: Kowainik +copyright: 2017-2020 Kowainik category: Data, Data Structures, Types build-type: Simple extra-doc-files: README.md , CHANGELOG.md -cabal-version: 2.0 tested-with: GHC == 8.2.2 , GHC == 8.4.4 - , GHC == 8.6.3 + , GHC == 8.6.5 + , GHC == 8.8.3 + , GHC == 8.10.1 source-repository head type: git location: https://github.com/kowainik/typerep-map.git +common common-options + build-depends: base >= 4.10 && < 4.15 + + default-language: Haskell2010 + default-extensions: BangPatterns + DerivingStrategies + OverloadedStrings + RecordWildCards + ScopedTypeVariables + TypeApplications + ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + if impl(ghc >= 8.0) + ghc-options: -Wredundant-constraints + if impl(ghc >= 8.2) + ghc-options: -fhide-source-paths + if impl(ghc >= 8.4) + ghc-options: -Wmissing-export-lists + -Wpartial-fields + if impl(ghc >= 8.8) + ghc-options: -Wmissing-deriving-strategies + -Werror=missing-deriving-strategies + if impl(ghc >= 8.10) + ghc-options: -Wunused-packages + library + import: common-options hs-source-dirs: src exposed-modules: Data.TMap Data.TypeRepMap Data.TypeRepMap.Internal - ghc-options: -Wall - build-depends: base >= 4.10 && < 5 - , containers >= 0.5.10.2 && < 0.7 - , ghc-prim ^>= 0.5.1.1 - , primitive ^>= 0.6.4 + + build-depends: containers >= 0.5.10.2 && < 0.7 + , ghc-prim >= 0.5.1.1 && < 0.7 + , primitive ^>= 0.7.0 , deepseq ^>= 1.4 - default-extensions: OverloadedStrings - RecordWildCards - ScopedTypeVariables - TypeApplications - default-language: Haskell2010 library typerep-extra-impls + import: common-options hs-source-dirs: typerep-extra-impls exposed-modules: Data.TypeRep.CMap Data.TypeRep.OptimalVector Data.TypeRep.Vector - ghc-options: -Wall - build-depends: base >= 4.10 && < 5 - , containers >= 0.5.10.2 && < 0.7 + + build-depends: containers >= 0.5.10.2 && < 0.7 , vector ^>= 0.12.0.1 , deepseq ^>= 1.4 - default-extensions: OverloadedStrings - RecordWildCards - ScopedTypeVariables - TypeApplications - default-language: Haskell2010 - test-suite typerep-map-test + import: common-options type: exitcode-stdio-1.0 hs-source-dirs: test + main-is: Test.hs other-modules: Test.TypeRep.CMap - , Test.TypeRep.CacheMap - , Test.TypeRep.MapProperty + , Test.TypeRep.TypeRepMap + , Test.TypeRep.TypeRepMapProperty , Test.TypeRep.Vector , Test.TypeRep.VectorOpt - build-depends: base >= 4.10 && < 5 - , ghc-typelits-knownnat >= 0.4.2 && < 0.7 - , hedgehog >= 0.5.3 && < 0.7 + + build-depends: ghc-typelits-knownnat >= 0.4.2 && < 0.8 + , hedgehog ^>= 1.0 + , hspec ^>= 2.7.1 + , hspec-hedgehog ^>= 0.0.1 , typerep-map , typerep-extra-impls - , tasty >= 1.0.1.1 && < 1.3 - , tasty-discover >= 4.1.1 && < 4.3 - , tasty-hedgehog >= 0.1.0.2 && < 0.3 - , tasty-hspec ^>= 1.1.5 - , QuickCheck >= 2.11.3 && < 2.13 - build-tool-depends: tasty-discover:tasty-discover - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N - default-extensions: ScopedTypeVariables - TypeApplications - default-language: Haskell2010 + ghc-options: -threaded -rtsopts -with-rtsopts=-N benchmark typerep-map-benchmark + import: common-options type: exitcode-stdio-1.0 - default-language: Haskell2010 - ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N -freduction-depth=0 hs-source-dirs: benchmark + main-is: Main.hs other-modules: CMap , CacheMap + , DMap , Spec , Vector , OptimalVector - build-depends: base >= 4.10 && < 5 - , criterion >= 1.4.1.0 && < 1.6 + + build-depends: criterion >= 1.4.1.0 && < 1.6 , deepseq ^>= 1.4.3.0 , dependent-map >= 0.2.4.0 && < 0.5 - , dependent-sum ^>= 0.5 - , ghc-typelits-knownnat >= 0.4.2 && < 0.7 + , dependent-sum >= 0.5 && < 0.8 + , ghc-typelits-knownnat >= 0.4.2 && < 0.8 , typerep-map , typerep-extra-impls - default-extensions: OverloadedStrings - RecordWildCards - ScopedTypeVariables - TypeApplications - BangPatterns - if impl(ghc >= 8.2.2) - other-modules: DMap + + ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N -freduction-depth=0