monoidmap-examples (empty) → 0.0.0.0
raw patch · 16 files changed
+2069/−0 lines, 16 filesdep +QuickCheckdep +basedep +containers
Dependencies added: QuickCheck, base, containers, hspec, monoid-subclasses, monoidmap, monoidmap-examples
Files
- CHANGELOG.md +3/−0
- LICENSE +201/−0
- README.md +5/−0
- components/monoidmap-examples-test/Data/MonoidMap/Examples/MultiMapSpec.hs +728/−0
- components/monoidmap-examples-test/Spec.hs +1/−0
- components/monoidmap-examples-test/SpecHook.hs +6/−0
- components/monoidmap-examples/Data/MonoidMap/Examples/MultiMap.hs +46/−0
- components/monoidmap-examples/Data/MonoidMap/Examples/MultiMap/Class.hs +180/−0
- components/monoidmap-examples/Data/MonoidMap/Examples/MultiMap/Instances/MultiMap1.hs +61/−0
- components/monoidmap-examples/Data/MonoidMap/Examples/MultiMap/Instances/MultiMap2.hs +80/−0
- components/monoidmap-examples/Data/MonoidMap/Examples/MultiMap/Instances/MultiMap3.hs +85/−0
- components/monoidmap-examples/Data/MonoidMap/Examples/MultiMap/Instances/MultiMap4.hs +59/−0
- components/monoidmap-examples/Data/MonoidMap/Examples/MultiSet.hs +156/−0
- components/monoidmap-examples/Data/MonoidMap/Examples/NestedMonoidMap.hs +314/−0
- components/monoidmap-examples/Data/MonoidMap/Examples/Set/NonEmpty.hs +44/−0
- monoidmap-examples.cabal +100/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+# 0.0.0.0++- Initial release.
+ LICENSE view
@@ -0,0 +1,201 @@+ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "[]"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++ Copyright © 2022–2025 Jonathan Knowles++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.
+ README.md view
@@ -0,0 +1,5 @@+# `monoidmap-examples`++Examples for the [`monoidmap`](https://github.com/jonathanknowles/monoidmap) package.++<a href="https://jonathanknowles.github.io/monoidmap-examples/"><img src="https://img.shields.io/badge/Examples-Documentation-227755" /></a>
+ components/monoidmap-examples-test/Data/MonoidMap/Examples/MultiMapSpec.hs view
@@ -0,0 +1,728 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{- HLINT ignore "Redundant bracket" -}+{- HLINT ignore "Use any" -}+{- HLINT ignore "Use null" -}++-- |+-- Copyright: © 2022–2025 Jonathan Knowles+-- License: Apache-2.0+--+module Data.MonoidMap.Examples.MultiMapSpec+ where++import Prelude++import Data.Function+ ( (&) )+import Data.Maybe+ ( isJust, isNothing )+import Data.Proxy+ ( Proxy (..) )+import Data.Set+ ( Set )+import Data.Typeable+ ( Typeable, typeRep )+import Data.MonoidMap.Examples.MultiMap.Class+ ( MultiMap )+import Data.MonoidMap.Examples.MultiMap.Instances.MultiMap1+ ( MultiMap1 )+import Data.MonoidMap.Examples.MultiMap.Instances.MultiMap2+ ( MultiMap2 )+import Data.MonoidMap.Examples.MultiMap.Instances.MultiMap3+ ( MultiMap3 )+import Data.MonoidMap.Examples.MultiMap.Instances.MultiMap4+ ( MultiMap4 )+import Test.Hspec+ ( Spec, describe, it )+import Test.QuickCheck+ ( Arbitrary (..)+ , Property+ , Testable+ , checkCoverage+ , counterexample+ , cover+ , (.||.)+ , (===)+ )++import qualified Data.Foldable as F+import qualified Data.Set as Set+import qualified Data.MonoidMap.Examples.MultiMap.Class as M+import qualified Test.QuickCheck as QC++spec :: Spec+spec = do++ -- Uncomment the following line to see property test failures for an+ -- unlawful implementation of 'MultiMap':+ --+ -- specFor (Proxy @(MultiMap1 Int Int))++ specFor (Proxy @(MultiMap2 Int Int))+ specFor (Proxy @(MultiMap3 Int Int))+ specFor (Proxy @(MultiMap4 Int Int))++type Test m k v =+ ( Arbitrary k+ , Arbitrary v+ , MultiMap m k v+ , Show (m k v)+ , Show k+ , Show v+ , Typeable m+ , Typeable k+ , Typeable v+ )++specFor :: forall m k v. Test m k v => Proxy (m k v) -> Spec+specFor multimapType = do++ let description = show (typeRep multimapType)++ let property :: Testable t => t -> Property+ property = checkCoverage . QC.property++ describe description $ do++ describe "Validity properties" $ do++ it "prop_fromList_valid" $+ prop_fromList_valid+ @m @k @v & property+ it "prop_update_valid" $+ prop_update_valid+ @m @k @v & property+ it "prop_insert_valid" $+ prop_insert_valid+ @m @k @v & property+ it "prop_remove_valid" $+ prop_remove_valid+ @m @k @v & property+ it "prop_union_valid" $+ prop_union_valid+ @m @k @v & property+ it "prop_intersection_valid" $+ prop_intersection_valid+ @m @k @v & property++ describe "General properties" $ do++ it "prop_fromList_filter" $+ prop_fromList_filter+ @m @k @v & property+ it "prop_toList_filter" $+ prop_toList_filter+ @m @k @v & property+ it "prop_empty_fromList" $+ prop_empty_fromList+ @m @k @v & property+ it "prop_lookup_filter_fold" $+ prop_lookup_filter_fold+ @m @k @v & property+ it "prop_null_lookup" $+ prop_null_lookup+ @m @k @v & property+ it "prop_nonNull_lookup" $+ prop_nonNull_lookup+ @m @k @v & property+ it "prop_nonNullKey_lookup" $+ prop_nonNullKey_lookup+ @m @k @v & property+ it "prop_nonNullKeys_nonNullKey" $+ prop_nonNullKeys_nonNullKey+ @m @k @v & property+ it "prop_nonNullCount_nonNullKeys" $+ prop_nonNullCount_nonNullKeys+ @m @k @v & property+ it "prop_isSubmapOf_lookup" $+ prop_isSubmapOf_lookup+ @m @k @v & property+ it "prop_update_lookup" $+ prop_update_lookup+ @m @k @v & property+ it "prop_insert_lookup" $+ prop_insert_lookup+ @m @k @v & property+ it "prop_remove_lookup" $+ prop_remove_lookup+ @m @k @v & property+ it "prop_union_idempotence" $+ prop_union_idempotence+ @m @k @v & property+ it "prop_union_identity_left" $+ prop_union_identity_left+ @m @k @v & property+ it "prop_union_identity_right" $+ prop_union_identity_right+ @m @k @v & property+ it "prop_union_commutativity" $+ prop_union_commutativity+ @m @k @v & property+ it "prop_union_associativity" $+ prop_union_associativity+ @m @k @v & property+ it "prop_union_containment_left" $+ prop_union_containment_left+ @m @k @v & property+ it "prop_union_containment_right" $+ prop_union_containment_right+ @m @k @v & property+ it "prop_union_distributivity" $+ prop_union_distributivity+ @m @k @v & property+ it "prop_intersection_idempotence" $+ prop_intersection_idempotence+ @m @k @v & property+ it "prop_intersection_identity_left" $+ prop_intersection_identity_left+ @m @k @v & property+ it "prop_intersection_identity_right" $+ prop_intersection_identity_right+ @m @k @v & property+ it "prop_intersection_commutativity" $+ prop_intersection_commutativity+ @m @k @v & property+ it "prop_intersection_associativity" $+ prop_intersection_associativity+ @m @k @v & property+ it "prop_intersection_containment_left" $+ prop_intersection_containment_left+ @m @k @v & property+ it "prop_intersection_containment_right" $+ prop_intersection_containment_right+ @m @k @v & property+ it "prop_intersection_distributivity" $+ prop_intersection_distributivity+ @m @k @v & property++--------------------------------------------------------------------------------+-- Validity properties+--------------------------------------------------------------------------------++-- A multimap is valid if (and only if):+--+-- - all keys included in 'nonNullKeys' are associated with non-empty sets.+-- - all keys included in 'toList' are associated with non-empty sets.++prop_valid+ :: Test m k v => m k v -> Property+prop_valid m = QC.conjoin+ [ counterexample+ "prop_valid_nonNullKeys"+ (prop_valid_nonNullKeys)+ , counterexample+ "prop_valid_toList"+ (prop_valid_toList)+ ]+ & cover 1+ (M.null m)+ "M.null m"+ & cover 1+ (M.nonNull m)+ "M.nonNull m"+ where+ prop_valid_nonNullKeys =+ all (\k -> M.lookup k m /= Set.empty) (M.nonNullKeys m)+ prop_valid_toList =+ all (\(_, v) -> v /= Set.empty) (M.toList m)++--------------------------------------------------------------------------------+-- Validity of operations that produce multimaps+--------------------------------------------------------------------------------++prop_fromList_valid+ :: forall m k v. Test m k v+ => [(k, Set v)]+ -> Property+prop_fromList_valid kvs =+ prop_valid @m @k @v (M.fromList kvs)++prop_update_valid+ :: forall m k v. Test m k v+ => k+ -> Set v+ -> [(k, Set v)]+ -> Property+prop_update_valid k vs kvs =+ prop_valid @m @k @v (M.update k vs (M.fromList kvs))++prop_insert_valid+ :: forall m k v. Test m k v+ => k+ -> Set v+ -> [(k, Set v)]+ -> Property+prop_insert_valid k vs kvs =+ prop_valid @m @k @v (M.insert k vs (M.fromList kvs))++prop_remove_valid+ :: forall m k v. Test m k v+ => k+ -> Set v+ -> [(k, Set v)]+ -> Property+prop_remove_valid k vs kvs =+ prop_valid @m @k @v (M.remove k vs (M.fromList kvs))++prop_union_valid+ :: forall m k v. Test m k v+ => [(k, Set v)]+ -> [(k, Set v)]+ -> Property+prop_union_valid kvs1 kvs2 =+ prop_valid @m @k @v (M.union (M.fromList kvs1) (M.fromList kvs2))++prop_intersection_valid+ :: forall m k v. Test m k v+ => [(k, Set v)]+ -> [(k, Set v)]+ -> Property+prop_intersection_valid kvs1 kvs2 =+ prop_valid @m @k @v (M.intersection (M.fromList kvs1) (M.fromList kvs2))++--------------------------------------------------------------------------------+-- General properties+--------------------------------------------------------------------------------++prop_fromList_filter+ :: forall m k v. Test m k v+ => [(k, Set v)]+ -> Property+prop_fromList_filter kvs =+ M.fromList @m @k @v kvs === M.fromList (filter ((/= Set.empty) . snd) kvs)++prop_toList_filter+ :: forall m k v. Test m k v+ => [(k, Set v)]+ -> Property+prop_toList_filter kvs =+ M.toList m === filter ((/= Set.empty) . snd) (M.toList m)+ where+ m :: m k v+ m = M.fromList kvs++prop_empty_fromList+ :: forall m k v. Test m k v+ => Property+prop_empty_fromList =+ M.empty @m @k @v === M.fromList []++prop_lookup_filter_fold+ :: forall m k v. Test m k v+ => k+ -> [(k, Set v)]+ -> Property+prop_lookup_filter_fold k kvs =+ M.lookup k m === F.foldMap snd (filter ((== k) . fst) kvs)+ & cover 10+ (isJust (lookup k kvs))+ "isJust (lookup k kvs)"+ & cover 10+ (isNothing (lookup k kvs))+ "isNothing (lookup k kvs)"+ where+ m :: m k v+ m = M.fromList kvs++prop_null_lookup+ :: forall m k v. Test m k v+ => k+ -> [(k, Set v)]+ -> Property+prop_null_lookup k kvs =+ M.null m ==> M.lookup k m == Set.empty+ & cover 2+ (M.lookup k m == Set.empty && M.null m)+ "M.lookup k m == Set.empty && M.null m"+ & cover 2+ (M.lookup k m == Set.empty && M.nonNull m)+ "M.lookup k m == Set.empty && M.nonNull m"+ & cover 2+ (M.lookup k m /= Set.empty && M.nonNull m)+ "M.lookup k m /= Set.empty && M.nonNull m"+ where+ m :: m k v+ m = M.fromList kvs++prop_nonNull_lookup+ :: forall m k v. Test m k v+ => k+ -> [(k, Set v)]+ -> Property+prop_nonNull_lookup k kvs =+ M.lookup k m /= Set.empty ==> M.nonNull m+ & cover 2+ (M.lookup k m == Set.empty && M.null m)+ "M.lookup k m == Set.empty && M.null m"+ & cover 2+ (M.lookup k m == Set.empty && M.nonNull m)+ "M.lookup k m == Set.empty && M.nonNull m"+ & cover 2+ (M.lookup k m /= Set.empty && M.nonNull m)+ "M.lookup k m /= Set.empty && M.nonNull m"+ where+ m :: m k v+ m = M.fromList kvs++prop_nonNullKey_lookup+ :: forall m k v. Test m k v+ => k+ -> [(k, Set v)]+ -> Property+prop_nonNullKey_lookup k kvs =+ M.nonNullKey k m === (M.lookup k m /= Set.empty)+ & cover 2+ (M.lookup k m == Set.empty && M.null m)+ "M.lookup k m == Set.empty && M.null m"+ & cover 2+ (M.lookup k m == Set.empty && M.nonNull m)+ "M.lookup k m == Set.empty && M.nonNull m"+ & cover 2+ (M.lookup k m /= Set.empty && M.nonNull m)+ "M.lookup k m /= Set.empty && M.nonNull m"+ where+ m :: m k v+ m = M.fromList kvs++prop_nonNullKeys_nonNullKey+ :: forall m k v. Test m k v+ => [(k, Set v)]+ -> Property+prop_nonNullKeys_nonNullKey kvs = QC.property $+ all (`M.nonNullKey` m) (M.nonNullKeys m)+ & cover 2+ (M.null m)+ "M.null m"+ & cover 2+ (M.nonNull m)+ "M.nonNull m"+ where+ m :: m k v+ m = M.fromList kvs++prop_nonNullCount_nonNullKeys+ :: forall m k v. Test m k v+ => [(k, Set v)]+ -> Property+prop_nonNullCount_nonNullKeys kvs =+ M.nonNullCount m === Set.size (M.nonNullKeys m)+ & cover 1+ (M.nonNullCount m == 0)+ "M.nonNullCount m == 0"+ & cover 1+ (M.nonNullCount m == 1)+ "M.nonNullCount m == 1"+ & cover 1+ (M.nonNullCount m == 2)+ "M.nonNullCount m == 2"+ & cover 1+ (M.nonNullCount m >= 3)+ "M.nonNullCount m >= 3"+ where+ m :: m k v+ m = M.fromList kvs++prop_isSubmapOf_lookup+ :: forall m k v. Test m k v+ => k+ -> [(k, Set v)]+ -> [(k, Set v)]+ -> Property+prop_isSubmapOf_lookup k kvs1 kvs2 =+ m1 `M.isSubmapOf` m2+ ==>+ M.lookup k m1 `Set.isSubsetOf` M.lookup k m2+ & cover 1+ (m1 `M.isSubmapOf` m2)+ "m1 `M.isSubmapOf` m2"+ where+ m1, m2 :: m k v+ m1 = M.fromList kvs1+ m2 = M.fromList kvs2++prop_update_lookup+ :: forall m k v. Test m k v+ => k+ -> k+ -> Set v+ -> [(k, Set v)]+ -> Property+prop_update_lookup k1 k2 vs kvs =+ M.lookup k1 (M.update k2 vs m) === (if k1 == k2 then vs else M.lookup k1 m)+ & cover 1+ (k1 == k2)+ "k1 == k2"+ & cover 10+ (k1 /= k2)+ "k1 /= k2"+ where+ m :: m k v+ m = M.fromList kvs++prop_insert_lookup+ :: forall m k v. Test m k v+ => k+ -> k+ -> Set v+ -> [(k, Set v)]+ -> Property+prop_insert_lookup k1 k2 vs kvs =+ M.lookup k1 (M.insert k2 vs m) ===+ (if k1 == k2 then M.lookup k1 m `Set.union` vs else M.lookup k1 m)+ & cover 1+ (k1 == k2)+ "k1 == k2"+ & cover 10+ (k1 /= k2)+ "k1 /= k2"+ where+ m :: m k v+ m = M.fromList kvs++prop_remove_lookup+ :: forall m k v. Test m k v+ => k+ -> k+ -> Set v+ -> [(k, Set v)]+ -> Property+prop_remove_lookup k1 k2 vs kvs =+ M.lookup k1 (M.remove k2 vs m) ===+ (if k1 == k2 then M.lookup k1 m `Set.difference` vs else M.lookup k1 m)+ & cover 1+ (k1 == k2)+ "k1 == k2"+ & cover 10+ (k1 /= k2)+ "k1 /= k2"+ where+ m :: m k v+ m = M.fromList kvs++prop_union_idempotence+ :: forall m k v. Test m k v+ => [(k, Set v)]+ -> Property+prop_union_idempotence kvs =+ M.union m m === m+ where+ m :: m k v+ m = M.fromList kvs++prop_union_identity_left+ :: forall m k v. Test m k v+ => [(k, Set v)]+ -> Property+prop_union_identity_left kvs =+ M.union m M.empty === m+ where+ m :: m k v+ m = M.fromList kvs++prop_union_identity_right+ :: forall m k v. Test m k v+ => [(k, Set v)]+ -> Property+prop_union_identity_right kvs =+ M.union M.empty m === m+ where+ m :: m k v+ m = M.fromList kvs++prop_union_commutativity+ :: forall m k v. Test m k v+ => [(k, Set v)]+ -> [(k, Set v)]+ -> Property+prop_union_commutativity kvs1 kvs2 =+ M.union m1 m2 === M.union m2 m1+ where+ m1, m2 :: m k v+ m1 = M.fromList kvs1+ m2 = M.fromList kvs2++prop_union_associativity+ :: forall m k v. Test m k v+ => [(k, Set v)]+ -> [(k, Set v)]+ -> [(k, Set v)]+ -> Property+prop_union_associativity kvs1 kvs2 kvs3 =+ M.union m1 (M.union m2 m3)+ === M.union (M.union m1 m2) m3+ where+ m1, m2, m3 :: m k v+ m1 = M.fromList kvs1+ m2 = M.fromList kvs2+ m3 = M.fromList kvs3++prop_union_containment_left+ :: forall m k v. Test m k v+ => [(k, Set v)]+ -> [(k, Set v)]+ -> Property+prop_union_containment_left kvs1 kvs2 = QC.property $+ m1 `M.isSubmapOf` M.union m1 m2+ where+ m1, m2 :: m k v+ m1 = M.fromList kvs1+ m2 = M.fromList kvs2++prop_union_containment_right+ :: forall m k v. Test m k v+ => [(k, Set v)]+ -> [(k, Set v)]+ -> Property+prop_union_containment_right kvs1 kvs2 = QC.property $+ m2 `M.isSubmapOf` M.union m1 m2+ where+ m1, m2 :: m k v+ m1 = M.fromList kvs1+ m2 = M.fromList kvs2++prop_union_distributivity+ :: forall m k v. Test m k v+ => k+ -> [(k, Set v)]+ -> [(k, Set v)]+ -> Property+prop_union_distributivity k kvs1 kvs2 =+ M.lookup k (M.union m1 m2) === Set.union (M.lookup k m1) (M.lookup k m2)+ & cover 1+ (M.nonNullKey k (M.union m1 m2))+ "M.nonNullKey k (M.union m1 m2)"+ where+ m1, m2 :: m k v+ m1 = M.fromList kvs1+ m2 = M.fromList kvs2++prop_intersection_idempotence+ :: forall m k v. Test m k v+ => [(k, Set v)]+ -> Property+prop_intersection_idempotence kvs =+ M.intersection m m === m+ where+ m :: m k v+ m = M.fromList kvs++prop_intersection_identity_left+ :: forall m k v. Test m k v+ => [(k, Set v)]+ -> Property+prop_intersection_identity_left kvs =+ M.intersection m M.empty === M.empty+ where+ m :: m k v+ m = M.fromList kvs++prop_intersection_identity_right+ :: forall m k v. Test m k v+ => [(k, Set v)]+ -> Property+prop_intersection_identity_right kvs =+ M.intersection M.empty m === M.empty+ where+ m :: m k v+ m = M.fromList kvs++prop_intersection_commutativity+ :: forall m k v. Test m k v+ => [(k, Set v)]+ -> [(k, Set v)]+ -> Property+prop_intersection_commutativity kvs1 kvs2 =+ M.intersection m1 m2 === M.intersection m2 m1+ & cover 1+ (M.nonNull (M.intersection m1 m2))+ "M.nonNull (M.intersection m1 m2)"+ & cover 1+ (M.nonNull (M.intersection m2 m1))+ "M.nonNull (M.intersection m2 m1)"+ where+ m1, m2 :: m k v+ m1 = M.fromList kvs1+ m2 = M.fromList kvs2++prop_intersection_associativity+ :: forall m k v. Test m k v+ => [(k, Set v)]+ -> [(k, Set v)]+ -> [(k, Set v)]+ -> Property+prop_intersection_associativity kvs1 kvs2 kvs3 =+ M.intersection m1 (M.intersection m2 m3)+ === M.intersection (M.intersection m1 m2) m3+ & cover 1+ (M.nonNull (M.intersection m1 (M.intersection m2 m3)))+ "M.nonNull (M.intersection m1 (M.intersection m2 m3))"+ & cover 1+ (M.nonNull (M.intersection (M.intersection m1 m2) m3))+ "M.nonNull (M.intersection (M.intersection m1 m2) m3)"+ where+ m1, m2, m3 :: m k v+ m1 = M.fromList kvs1+ m2 = M.fromList kvs2+ m3 = M.fromList kvs3++prop_intersection_containment_left+ :: forall m k v. Test m k v+ => [(k, Set v)]+ -> [(k, Set v)]+ -> Property+prop_intersection_containment_left kvs1 kvs2 = QC.property $+ M.intersection m1 m2 `M.isSubmapOf` m1+ & cover 1+ (M.nonNull (M.intersection m1 m2))+ "M.nonNull (M.intersection m1 m2)"+ where+ m1, m2 :: m k v+ m1 = M.fromList kvs1+ m2 = M.fromList kvs2++prop_intersection_containment_right+ :: forall m k v. Test m k v+ => [(k, Set v)]+ -> [(k, Set v)]+ -> Property+prop_intersection_containment_right kvs1 kvs2 = QC.property $+ M.intersection m1 m2 `M.isSubmapOf` m2+ & cover 1+ (M.nonNull (M.intersection m1 m2))+ "M.nonNull (M.intersection m1 m2)"+ where+ m1, m2 :: m k v+ m1 = M.fromList kvs1+ m2 = M.fromList kvs2++prop_intersection_distributivity+ :: forall m k v. Test m k v+ => k+ -> [(k, Set v)]+ -> [(k, Set v)]+ -> Property+prop_intersection_distributivity k kvs1 kvs2 =+ M.lookup k (M.intersection m1 m2)+ === Set.intersection (M.lookup k m1) (M.lookup k m2)+ & cover 1+ (M.nonNullKey k (M.intersection m1 m2))+ "M.nonNullKey k (M.intersection m1 m2)"+ where+ m1, m2 :: m k v+ m1 = M.fromList kvs1+ m2 = M.fromList kvs2++--------------------------------------------------------------------------------+-- Utilities+--------------------------------------------------------------------------------++infixr 3 ==>+(==>) :: Bool -> Bool -> Property+a ==> b = not a .||. b++_preventRedundantImportErrors :: ()+_preventRedundantImportErrors = ()+ where+ _multiMap1 :: MultiMap1 () ()+ _multiMap1 = M.empty
+ components/monoidmap-examples-test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ components/monoidmap-examples-test/SpecHook.hs view
@@ -0,0 +1,6 @@+module SpecHook where++import Test.Hspec++hook :: Spec -> Spec+hook = parallel
+ components/monoidmap-examples/Data/MonoidMap/Examples/MultiMap.hs view
@@ -0,0 +1,46 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+-- |+-- Copyright: © 2022–2025 Jonathan Knowles+-- License: Apache-2.0+--+-- Provides the 'MultiMap' class, which models a total relation from unique+-- keys to sets of values.+--+-- = Implementations+--+-- The following example implementations are provided:+--+-- +----------------+------------------------+---------++-- | Implementation | Types used | Lawful? |+-- +================+=============+==========+=========++-- | 'MultiMap1' | 'Map' | 'Set' | 💥 No |+-- +----------------+-------------+----------+---------++-- | 'MultiMap2' | 'Map' | 'Set' | ✅ Yes |+-- +----------------+-------------+----------+---------++-- | 'MultiMap3' | 'Map' | 'NESet' | ✅ Yes |+-- +----------------+-------------+----------+---------++-- | 'MultiMap4' | 'MonoidMap' | 'Set' | ✅ Yes |+-- +----------------+-------------+----------+---------++--+module Data.MonoidMap.Examples.MultiMap+ ( MultiMap (..)+ ) where++import Data.Map.Strict+ ( Map )+import Data.MonoidMap+ ( MonoidMap )+import Data.Set+ ( Set )+import Data.MonoidMap.Examples.Set.NonEmpty+ ( NESet )+import Data.MonoidMap.Examples.MultiMap.Class+ ( MultiMap (..) )+import Data.MonoidMap.Examples.MultiMap.Instances.MultiMap1+ ( MultiMap1 )+import Data.MonoidMap.Examples.MultiMap.Instances.MultiMap2+ ( MultiMap2 )+import Data.MonoidMap.Examples.MultiMap.Instances.MultiMap3+ ( MultiMap3 )+import Data.MonoidMap.Examples.MultiMap.Instances.MultiMap4+ ( MultiMap4 )
+ components/monoidmap-examples/Data/MonoidMap/Examples/MultiMap/Class.hs view
@@ -0,0 +1,180 @@+-- |+-- Copyright: © 2022–2025 Jonathan Knowles+-- License: Apache-2.0+--+-- Provides the 'MultiMap' class, which models a total relation from unique+-- keys to sets of values.+--+module Data.MonoidMap.Examples.MultiMap.Class where++import Data.Set+ ( Set )+import Prelude hiding+ ( lookup )++-- | Models a total relation from unique keys to sets of values.+--+class (Eq (m k v), Ord k, Ord v) => MultiMap m k v where++ -- | Constructs a multimap from a list of key to value set mappings.+ --+ -- Removing empty sets from the input list does not affect the result:+ --+ -- > fromList ≡ fromList . filter ((/= Set.empty) . snd)+ --+ fromList :: [(k, Set v)] -> m k v++ -- | Converts a multimap to a list of key to value-set mappings.+ --+ -- Removing empty sets from the output list does not affect the result:+ --+ -- > toList ≡ filter ((/= Set.empty) . snd) . toList+ --+ -- The resulting list can be used to reconstruct the original multimap:+ --+ -- > fromList . toList ≡ id+ --+ toList :: m k v -> [(k, Set v)]++ -- | Constructs an empty multimap.+ --+ -- > empty ≡ fromList []+ --+ empty :: m k v++ -- | Returns the set of values associated with a given key.+ --+ -- > lookup k (fromList kvs) ≡ foldMap snd (filter ((== k) . fst) kvs)+ --+ lookup :: k -> m k v -> Set v++ -- | Indicates whether or not a multimap is empty.+ --+ -- > null m ≡ (∀ k. lookup k m == Set.empty)+ --+ null :: m k v -> Bool++ -- | Indicates whether or not a multimap is non-empty.+ --+ -- > nonNull m ≡ (∃ k. lookup k m /= Set.empty)+ --+ nonNull :: m k v -> Bool++ -- | Returns 'True' iff. the given key is associated with a non-empty set.+ --+ -- > nonNullKey k m ≡ (lookup k m /= Set.empty)+ --+ nonNullKey :: k -> m k v -> Bool++ -- | Returns the set of keys that are associated with non-empty sets.+ --+ -- > all (`nonNullKey` m) (nonNullKeys m)+ --+ nonNullKeys :: m k v -> Set k++ -- | Indicates how many keys are associated with non-empty sets.+ --+ -- > nonNullCount m ≡ Set.size (nonNullKeys m)+ --+ nonNullCount :: m k v -> Int++ -- | Indicates whether or not the first map is a sub-map of the second.+ --+ -- > m1 `isSubmapOf` m2 ≡ ∀ k. (lookup k m1 `Set.isSubsetOf` lookup k m2)+ --+ isSubmapOf :: m k v -> m k v -> Bool++ -- | Updates the set of values associated with a given key.+ --+ -- > lookup k1 (update k2 vs m) ≡+ -- > if k1 == k2+ -- > then vs+ -- > else lookup k1 m+ --+ update :: k -> Set v -> m k v -> m k v++ -- | Inserts values into the set of values associated with a given key.+ --+ -- > lookup k1 (insert k2 vs m) ≡+ -- > if k1 == k2+ -- > then lookup k1 m `Set.union` vs+ -- > else lookup k1 m+ --+ insert :: k -> Set v -> m k v -> m k v++ -- | Removes values from the set of values associated with a given key.+ --+ -- > lookup k1 (remove k2 vs m) ≡+ -- > if k1 == k2+ -- > then lookup k1 m `Set.difference` vs+ -- > else lookup k1 m+ --+ remove :: k -> Set v -> m k v -> m k v++ -- | Computes the union of two multimaps.+ --+ -- Instances must satisfy the following properties:+ --+ -- __/Idempotence/__+ --+ -- > union m m ≡ m+ --+ -- __/Identity/__+ --+ -- > union empty m ≡ m+ -- > union m empty ≡ m+ --+ -- __/Commutativity/__+ --+ -- > union m1 m2 ≡ union m2 m1+ --+ -- __/Associativity/__+ --+ -- > union m1 (union m2 m3) ≡+ -- > union (union m1 m2) m3+ --+ -- __/Containment/__+ --+ -- > m1 `isSubmapOf` union m1 m2+ -- > m2 `isSubmapOf` union m1 m2+ --+ -- __/Distributivity/__+ --+ -- > lookup k (union m1 m2) ≡ Set.union (lookup k m1)+ -- > (lookup k m2)+ --+ union :: m k v -> m k v -> m k v++ -- | Computes the intersection of two multimaps.+ --+ -- Instances must satisfy the following properties:+ --+ -- __/Idempotence/__+ --+ -- > intersection m m ≡ m+ --+ -- __/Identity/__+ --+ -- > intersection empty m ≡ empty+ -- > intersection m empty ≡ empty+ --+ -- __/Commutativity/__+ --+ -- > intersection m1 m2 ≡ intersection m2 m1+ --+ -- __/Associativity/__+ --+ -- > intersection m1 (intersection m2 m3) ≡+ -- > intersection (intersection m1 m2) m3+ --+ -- __/Containment/__+ --+ -- > intersection m1 m2 `isSubmapOf` m1+ -- > intersection m1 m2 `isSubmapOf` m2+ --+ -- __/Distributivity/__+ --+ -- > lookup k (intersection m1 m2) ≡ Set.intersection (lookup k m1)+ -- > (lookup k m2)+ --+ intersection :: m k v -> m k v -> m k v
+ components/monoidmap-examples/Data/MonoidMap/Examples/MultiMap/Instances/MultiMap1.hs view
@@ -0,0 +1,61 @@+-- |+-- Copyright: © 2022–2025 Jonathan Knowles+-- License: Apache-2.0+--+-- An __unlawful__ implementation of 'MultiMap', implemented in terms of 'Map'+-- and 'Set'.+--+-- This implementation has several subtle bugs. 💥+--+module Data.MonoidMap.Examples.MultiMap.Instances.MultiMap1 where++import Prelude++import Data.Map.Strict+ ( Map )+import Data.Set+ ( Set )++import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Data.MonoidMap.Examples.MultiMap.Class as Class++newtype MultiMap1 k v = MultiMap (Map k (Set v))+ deriving stock (Eq, Show)++instance (Ord k, Ord v) => Class.MultiMap MultiMap1 k v where++ fromList = MultiMap . Map.fromList++ toList (MultiMap m) = Map.toList m++ empty = MultiMap Map.empty++ lookup k (MultiMap m) = Map.findWithDefault Set.empty k m++ null (MultiMap m) = Map.null m++ nonNull (MultiMap m) = not (Map.null m)++ nonNullKey k (MultiMap m) = Map.member k m++ nonNullKeys (MultiMap m) = Map.keysSet m++ nonNullCount (MultiMap m) = Map.size m++ isSubmapOf (MultiMap m1) (MultiMap m2) =+ Map.isSubmapOfBy Set.isSubsetOf m1 m2++ update k vs (MultiMap m) = MultiMap (Map.insert k vs m)++ insert k vs (MultiMap m) = MultiMap $+ Map.insert k (Map.findWithDefault Set.empty k m `Set.union` vs) m++ remove k vs (MultiMap m) = MultiMap $+ Map.insert k (Map.findWithDefault Set.empty k m `Set.difference` vs) m++ union (MultiMap m1) (MultiMap m2) = MultiMap $+ Map.unionWith Set.union m1 m2++ intersection (MultiMap m1) (MultiMap m2) = MultiMap $+ Map.intersectionWith Set.intersection m1 m2
+ components/monoidmap-examples/Data/MonoidMap/Examples/MultiMap/Instances/MultiMap2.hs view
@@ -0,0 +1,80 @@+-- |+-- Copyright: © 2022–2025 Jonathan Knowles+-- License: Apache-2.0+--+-- A __lawful__ implementation of 'MultiMap', implemented in terms of 'Map' and+-- 'Set'.+--+module Data.MonoidMap.Examples.MultiMap.Instances.MultiMap2 where++import Prelude++import Data.Map.Strict+ ( Map )+import Data.Set+ ( Set )++import qualified Data.Map.Merge.Strict as Map+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Data.MonoidMap.Examples.MultiMap.Class as Class++newtype MultiMap2 k v = MultiMap (Map k (Set v))+ deriving stock (Eq, Show)++instance (Ord k, Ord v) => Class.MultiMap MultiMap2 k v where++ fromList = MultiMap . Map.fromListWith (<>) . filter ((/= mempty) . snd)++ toList (MultiMap m) = Map.toList m++ empty = MultiMap Map.empty++ lookup k (MultiMap m) = Map.findWithDefault Set.empty k m++ null (MultiMap m) = Map.null m++ nonNull (MultiMap m) = not (Map.null m)++ nonNullKey k (MultiMap m) = Map.member k m++ nonNullKeys (MultiMap m) = Map.keysSet m++ nonNullCount (MultiMap m) = Map.size m++ isSubmapOf (MultiMap m1) (MultiMap m2) =+ Map.isSubmapOfBy Set.isSubsetOf m1 m2++ update k vs (MultiMap m)+ | Set.null vs = MultiMap (Map.delete k m)+ | otherwise = MultiMap (Map.insert k vs m)++ insert k vs (MultiMap m)+ | Set.null xs = MultiMap (Map.delete k m)+ | otherwise = MultiMap (Map.insert k xs m)+ where+ xs = Map.findWithDefault Set.empty k m `Set.union` vs++ remove k vs (MultiMap m)+ | Set.null xs = MultiMap (Map.delete k m)+ | otherwise = MultiMap (Map.insert k xs m)+ where+ xs = Map.findWithDefault Set.empty k m `Set.difference` vs++ union (MultiMap m1) (MultiMap m2) = MultiMap $+ Map.unionWith Set.union m1 m2++ intersection (MultiMap m1) (MultiMap m2) = MultiMap $+ Map.merge+ Map.dropMissing+ Map.dropMissing+ (Map.zipWithMaybeMatched mergeValues)+ m1+ m2+ where+ mergeValues :: k -> Set v -> Set v -> Maybe (Set v)+ mergeValues _k s1 s2+ | Set.null s3 = Nothing+ | otherwise = Just s3+ where+ s3 = Set.intersection s1 s2
+ components/monoidmap-examples/Data/MonoidMap/Examples/MultiMap/Instances/MultiMap3.hs view
@@ -0,0 +1,85 @@+-- |+-- Copyright: © 2022–2025 Jonathan Knowles+-- License: Apache-2.0+--+-- A __lawful__ implementation of 'MultiMap', implemented in terms of 'Map' and+-- 'NESet'.+--+module Data.MonoidMap.Examples.MultiMap.Instances.MultiMap3 where++import Prelude++import Data.Map.Strict+ ( Map )+import Data.Maybe+ ( mapMaybe )+import Data.MonoidMap.Examples.Set.NonEmpty+ ( NESet )++import qualified Data.Map.Merge.Strict as Map+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Data.MonoidMap.Examples.Set.NonEmpty as NESet+import qualified Data.MonoidMap.Examples.MultiMap.Class as Class++newtype MultiMap3 k v = MultiMap (Map k (NESet v))+ deriving stock (Eq, Show)++instance (Ord k, Ord v) => Class.MultiMap MultiMap3 k v where++ fromList+ = MultiMap+ . Map.fromListWith (<>)+ . mapMaybe (traverse NESet.nonEmptySet)++ toList (MultiMap m) = fmap NESet.toSet <$> Map.toList m++ empty = MultiMap Map.empty++ lookup k (MultiMap m) = maybe Set.empty NESet.toSet (Map.lookup k m)++ null (MultiMap m) = Map.null m++ nonNull (MultiMap m) = not (Map.null m)++ nonNullKey k (MultiMap m) = Map.member k m++ nonNullKeys (MultiMap m) = Map.keysSet m++ nonNullCount (MultiMap m) = Map.size m++ isSubmapOf (MultiMap m1) (MultiMap m2) =+ Map.isSubmapOfBy NESet.isSubsetOf m1 m2++ update k vs (MultiMap m) =+ case NESet.nonEmptySet vs of+ Nothing -> MultiMap (Map.delete k m)+ Just ys -> MultiMap (Map.insert k ys m)++ insert k vs (MultiMap m) =+ case NESet.nonEmptySet xs of+ Nothing -> MultiMap (Map.delete k m)+ Just ys -> MultiMap (Map.insert k ys m)+ where+ xs = maybe Set.empty NESet.toSet (Map.lookup k m) `Set.union` vs++ remove k vs (MultiMap m) =+ case NESet.nonEmptySet xs of+ Nothing -> MultiMap (Map.delete k m)+ Just ys -> MultiMap (Map.insert k ys m)+ where+ xs = maybe Set.empty NESet.toSet (Map.lookup k m) `Set.difference` vs++ union (MultiMap m1) (MultiMap m2) = MultiMap $+ Map.unionWith NESet.union m1 m2++ intersection (MultiMap m1) (MultiMap m2) = MultiMap $+ Map.merge+ Map.dropMissing+ Map.dropMissing+ (Map.zipWithMaybeMatched mergeValues)+ m1+ m2+ where+ mergeValues :: Ord v => k -> NESet v -> NESet v -> Maybe (NESet v)+ mergeValues _k s1 s2 = NESet.nonEmptySet (NESet.intersection s1 s2)
+ components/monoidmap-examples/Data/MonoidMap/Examples/MultiMap/Instances/MultiMap4.hs view
@@ -0,0 +1,59 @@+-- |+-- Copyright: © 2022–2025 Jonathan Knowles+-- License: Apache-2.0+--+-- A __lawful__ implementation of 'MultiMap', implemented in terms of+-- 'MonoidMap' and 'Set'.+--+module Data.MonoidMap.Examples.MultiMap.Instances.MultiMap4 where++import Prelude++import Data.MonoidMap+ ( MonoidMap )+import Data.Set+ ( Set )++import qualified Data.MonoidMap as MonoidMap+import qualified Data.Set as Set+import qualified Data.MonoidMap.Examples.MultiMap.Class as Class++newtype MultiMap4 k v = MultiMap (MonoidMap k (Set v))+ deriving stock (Eq, Show)++instance (Ord k, Ord v) => Class.MultiMap MultiMap4 k v where++ fromList = MultiMap . MonoidMap.fromListWith (<>)++ toList (MultiMap m) = MonoidMap.toList m++ empty = MultiMap MonoidMap.empty++ lookup k (MultiMap m) = MonoidMap.get k m++ null (MultiMap m) = MonoidMap.null m++ nonNull (MultiMap m) = MonoidMap.nonNull m++ nonNullKey k (MultiMap m) = MonoidMap.nonNullKey k m++ nonNullKeys (MultiMap m) = MonoidMap.nonNullKeys m++ nonNullCount (MultiMap m) = MonoidMap.nonNullCount m++ isSubmapOf (MultiMap m1) (MultiMap m2) = m1 `MonoidMap.isSubmapOf` m2++ update k vs (MultiMap m) =+ MultiMap (MonoidMap.set k vs m)++ insert k vs (MultiMap m) =+ MultiMap (MonoidMap.adjust (`Set.union` vs) k m)++ remove k vs (MultiMap m) =+ MultiMap (MonoidMap.adjust (`Set.difference` vs) k m)++ union (MultiMap m1) (MultiMap m2) =+ MultiMap (MonoidMap.union m1 m2)++ intersection (MultiMap m1) (MultiMap m2) =+ MultiMap (MonoidMap.intersection m1 m2)
+ components/monoidmap-examples/Data/MonoidMap/Examples/MultiSet.hs view
@@ -0,0 +1,156 @@+-- |+-- Copyright: © 2022–2025 Jonathan Knowles+-- License: Apache-2.0+--+-- A multiset type, implemented in terms of 'MonoidMap'.+--+-- See: https://en.wikipedia.org/wiki/Multiset+--+module Data.MonoidMap.Examples.MultiSet+ ( fromList+ , toList+ , null+ , member+ , multiplicity+ , root+ , cardinality+ , dimension+ , height+ , isSubsetOf+ , intersection+ , union+ , disjointUnion+ , add+ , subtract+ , subtractMaybe+ )+ where++import Prelude hiding+ ( null, subtract )++import Data.Function+ ( on )+import Data.Monoid+ ( Sum (..) )+import Data.Monoid.GCD+ ( DistributiveGCDMonoid+ , GCDMonoid+ , LeftDistributiveGCDMonoid+ , LeftGCDMonoid+ , OverlappingGCDMonoid+ , RightDistributiveGCDMonoid+ , RightGCDMonoid+ )+import Data.Monoid.LCM+ ( DistributiveLCMMonoid, LCMMonoid )+import Data.Monoid.Monus+ ( Monus ((<\>)) )+import Data.Monoid.Null+ ( MonoidNull, PositiveMonoid )+import Data.MonoidMap+ ( MonoidMap )+import Data.Semigroup.Cancellative+ ( Cancellative+ , Commutative+ , LeftCancellative+ , LeftReductive+ , Reductive ((</>))+ , RightCancellative+ , RightReductive+ )+import Data.Set+ ( Set )+import Numeric.Natural+ ( Natural )+import Text.Read+ ( Read (..) )++import qualified Data.Foldable as F+import qualified Data.MonoidMap as MonoidMap++newtype MultiSet a = MultiSet+ { unMultiSet :: MonoidMap a (Sum Natural)+ }+ deriving newtype+ ( Eq+ , Semigroup+ , Commutative+ , Monoid+ , MonoidNull+ , PositiveMonoid+ , LeftReductive+ , LeftCancellative+ , LeftGCDMonoid+ , LeftDistributiveGCDMonoid+ , RightReductive+ , RightCancellative+ , RightGCDMonoid+ , RightDistributiveGCDMonoid+ , Reductive+ , Cancellative+ , GCDMonoid+ , LCMMonoid+ , DistributiveGCDMonoid+ , DistributiveLCMMonoid+ , OverlappingGCDMonoid+ , Monus+ )++instance (Ord a, Read a) => Read (MultiSet a) where+ readPrec = fromList <$> readPrec++instance Show a => Show (MultiSet a) where+ show = show . toList++fromList :: Ord a => [(a, Natural)] -> MultiSet a+fromList = MultiSet . MonoidMap.fromList . fmap (fmap Sum)++toList :: MultiSet a -> [(a, Natural)]+toList = fmap (fmap getSum) . MonoidMap.toList . unMultiSet++null :: MultiSet a -> Bool+null = MonoidMap.null . unMultiSet++member :: Ord a => a -> MultiSet a -> Bool+member a = MonoidMap.nonNullKey a . unMultiSet++multiplicity :: Ord a => a -> MultiSet a -> Natural+multiplicity a = getSum . MonoidMap.get a . unMultiSet++root :: Ord a => MultiSet a -> Set a+root = MonoidMap.nonNullKeys . unMultiSet++cardinality :: MultiSet a -> Natural+cardinality = getSum . F.fold . unMultiSet++dimension :: MultiSet a -> Natural+dimension = fromIntegral . MonoidMap.nonNullCount . unMultiSet++height :: Ord a => MultiSet a -> Natural+height s+ | null s = 0+ | otherwise = getSum $ F.maximum $ unMultiSet s++isSubsetOf :: Ord a => MultiSet a -> MultiSet a -> Bool+isSubsetOf = MonoidMap.isSubmapOf `on` unMultiSet++intersection :: Ord a => MultiSet a -> MultiSet a -> MultiSet a+intersection (MultiSet s1) (MultiSet s2) =+ MultiSet (MonoidMap.intersection s1 s2)++union :: Ord a => MultiSet a -> MultiSet a -> MultiSet a+union (MultiSet s1) (MultiSet s2) =+ MultiSet (MonoidMap.union s1 s2)++disjointUnion :: Ord a => MultiSet a -> MultiSet a -> MultiSet a+disjointUnion m1 m2 = (m1 <\> m2) <> (m2 <\> m1)++add :: Ord a => MultiSet a -> MultiSet a -> MultiSet a+add = (<>)++subtract :: Ord a => MultiSet a -> MultiSet a -> MultiSet a+subtract = (<\>)++subtractMaybe :: Ord a => MultiSet a -> MultiSet a -> Maybe (MultiSet a)+subtractMaybe = (</>)
+ components/monoidmap-examples/Data/MonoidMap/Examples/NestedMonoidMap.hs view
@@ -0,0 +1,314 @@+{-# LANGUAGE TypeSynonymInstances #-}++-- |+-- Copyright: © 2022–2025 Jonathan Knowles+-- License: Apache-2.0+--+-- A nested map with compound keys, implemented in terms of 'MonoidMap'.+--+module Data.MonoidMap.Examples.NestedMonoidMap+ (+ -- * Type+ NestedMonoidMap++ -- * Construction+ , fromFlatList+ , fromFlatMap+ , fromNestedList+ , fromNestedMap++ -- * Deconstruction+ , toFlatList+ , toFlatMap+ , toNestedList+ , toNestedMap++ -- * Basic operations+ , get+ , set+ , adjust+ , nullify++ -- * Membership+ , nonNullCount+ , nonNullKey+ , nonNullKeys++ -- * Intersection+ , intersection+ , intersectionWith++ -- * Union+ , union+ , unionWith++ -- * Comparison+ , isSubmapOf+ , isSubmapOfBy+ , disjoint+ , disjointBy+ )+ where++import Prelude++import Data.Map.Strict+ ( Map )+import Data.Monoid+ ( Sum (..) )+import Data.Monoid.GCD+ ( GCDMonoid, LeftGCDMonoid, OverlappingGCDMonoid, RightGCDMonoid )+import Data.Monoid.LCM+ ( LCMMonoid )+import Data.Monoid.Monus+ ( Monus )+import Data.Monoid.Null+ ( MonoidNull, PositiveMonoid )+import Data.MonoidMap+ ( MonoidMap )+import Data.Semigroup.Cancellative+ ( Cancellative+ , Commutative+ , LeftCancellative+ , LeftReductive+ , Reductive+ , RightCancellative+ , RightReductive+ )+import Data.Set+ ( Set )+import GHC.Exts+ ( IsList (..) )++import qualified Data.Foldable as F+import qualified Data.Map.Strict as Map+import qualified Data.MonoidMap as MonoidMap+import qualified Data.Set as Set++--------------------------------------------------------------------------------+-- Type+--------------------------------------------------------------------------------++newtype NestedMonoidMap k1 k2 v =+ NestedMonoidMap (MonoidMap k1 (MonoidMap k2 v))+ deriving stock Eq+ deriving newtype+ ( Cancellative+ , Commutative+ , GCDMonoid+ , LCMMonoid+ , LeftCancellative+ , LeftGCDMonoid+ , LeftReductive+ , Monoid+ , MonoidNull+ , Monus+ , OverlappingGCDMonoid+ , PositiveMonoid+ , Reductive+ , RightCancellative+ , RightGCDMonoid+ , RightReductive+ , Semigroup+ , Show+ )++--------------------------------------------------------------------------------+-- Construction+--------------------------------------------------------------------------------++fromFlatList+ :: (Ord k1, Ord k2, MonoidNull v)+ => [((k1, k2), v)]+ -> NestedMonoidMap k1 k2 v+fromFlatList = F.foldl' acc mempty+ where+ acc m ((k1, k2), v) = adjust (<> v) k1 k2 m++fromFlatMap+ :: (Ord k1, Ord k2, MonoidNull v)+ => Map (k1, k2) v+ -> NestedMonoidMap k1 k2 v+fromFlatMap = fromFlatList . Map.toList++fromNestedList+ :: (Ord k1, Ord k2, MonoidNull v)+ => [(k1, [(k2, v)])]+ -> NestedMonoidMap k1 k2 v+fromNestedList entries =+ fromFlatList [((k1, k2), v) | (k1, n) <- entries, (k2, v) <- n]++fromNestedMap+ :: (Ord k2, MonoidNull v)+ => Map k1 (Map k2 v)+ -> NestedMonoidMap k1 k2 v+fromNestedMap = NestedMonoidMap . MonoidMap.fromMap . fmap MonoidMap.fromMap++--------------------------------------------------------------------------------+-- Deconstruction+--------------------------------------------------------------------------------++toFlatList+ :: (Ord k1, Ord k2, MonoidNull v)+ => NestedMonoidMap k1 k2 v+ -> [((k1, k2), v)]+toFlatList m = [((k1, k2), v) | (k1, n) <- toNestedList m, (k2, v) <- toList n]++toFlatMap+ :: (Ord k1, Ord k2, MonoidNull v)+ => NestedMonoidMap k1 k2 v+ -> Map (k1, k2) v+toFlatMap = Map.fromList . toFlatList++toNestedList+ :: (Ord k1, Ord k2, MonoidNull v)+ => NestedMonoidMap k1 k2 v+ -> [(k1, [(k2, v)])]+toNestedList (NestedMonoidMap m) = fmap toList <$> toList m++toNestedMap+ :: NestedMonoidMap k1 k2 v+ -> Map k1 (Map k2 v)+toNestedMap (NestedMonoidMap m) = MonoidMap.toMap <$> MonoidMap.toMap m++--------------------------------------------------------------------------------+-- Basic operations+--------------------------------------------------------------------------------++get :: (Ord k1, Ord k2, MonoidNull v)+ => k1+ -> k2+ -> NestedMonoidMap k1 k2 v+ -> v+get k1 k2 (NestedMonoidMap m) = MonoidMap.get k2 (MonoidMap.get k1 m)++set :: (Ord k1, Ord k2, MonoidNull v)+ => k1+ -> k2+ -> v+ -> NestedMonoidMap k1 k2 v+ -> NestedMonoidMap k1 k2 v+set k1 k2 v (NestedMonoidMap m) =+ NestedMonoidMap $ MonoidMap.adjust (MonoidMap.set k2 v) k1 m++adjust+ :: (Ord k1, Ord k2, MonoidNull v)+ => (v -> v)+ -> k1+ -> k2+ -> NestedMonoidMap k1 k2 v+ -> NestedMonoidMap k1 k2 v+adjust f k1 k2 (NestedMonoidMap m) =+ NestedMonoidMap $ MonoidMap.adjust (MonoidMap.adjust f k2) k1 m++nullify+ :: (Ord k1, Ord k2, MonoidNull v)+ => k1+ -> k2+ -> NestedMonoidMap k1 k2 v+ -> NestedMonoidMap k1 k2 v+nullify k1 k2 (NestedMonoidMap m) =+ NestedMonoidMap $ MonoidMap.adjust (MonoidMap.nullify k2) k1 m++--------------------------------------------------------------------------------+-- Membership+--------------------------------------------------------------------------------++nonNullCount :: NestedMonoidMap k1 k2 v -> Int+nonNullCount (NestedMonoidMap m) =+ getSum $ F.foldMap (Sum . MonoidMap.nonNullCount) m++nonNullKey+ :: (Ord k1, Ord k2, MonoidNull v)+ => k1+ -> k2+ -> NestedMonoidMap k1 k2 v+ -> Bool+nonNullKey k1 k2 (NestedMonoidMap m) =+ MonoidMap.nonNullKey k2 (MonoidMap.get k1 m)++nonNullKeys+ :: (Ord k1, Ord k2, MonoidNull v)+ => NestedMonoidMap k1 k2 v+ -> Set (k1, k2)+nonNullKeys = Set.fromList . fmap fst . toFlatList++--------------------------------------------------------------------------------+-- Intersection+--------------------------------------------------------------------------------++intersection+ :: (Ord k1, Ord k2, MonoidNull v, GCDMonoid v)+ => NestedMonoidMap k1 k2 v+ -> NestedMonoidMap k1 k2 v+ -> NestedMonoidMap k1 k2 v+intersection (NestedMonoidMap m1) (NestedMonoidMap m2) = NestedMonoidMap $+ MonoidMap.intersection m1 m2++intersectionWith+ :: (Ord k1, Ord k2, MonoidNull v)+ => (v -> v -> v)+ -> NestedMonoidMap k1 k2 v+ -> NestedMonoidMap k1 k2 v+ -> NestedMonoidMap k1 k2 v+intersectionWith f (NestedMonoidMap m1) (NestedMonoidMap m2) = NestedMonoidMap $+ MonoidMap.intersectionWith (MonoidMap.intersectionWith f) m1 m2++--------------------------------------------------------------------------------+-- Union+--------------------------------------------------------------------------------++union+ :: (Ord k1, Ord k2, MonoidNull v, LCMMonoid v)+ => NestedMonoidMap k1 k2 v+ -> NestedMonoidMap k1 k2 v+ -> NestedMonoidMap k1 k2 v+union (NestedMonoidMap m1) (NestedMonoidMap m2) = NestedMonoidMap $+ MonoidMap.union m1 m2++unionWith+ :: (Ord k1, Ord k2, MonoidNull v)+ => (v -> v -> v)+ -> NestedMonoidMap k1 k2 v+ -> NestedMonoidMap k1 k2 v+ -> NestedMonoidMap k1 k2 v+unionWith f (NestedMonoidMap m1) (NestedMonoidMap m2) = NestedMonoidMap $+ MonoidMap.unionWith (MonoidMap.unionWith f) m1 m2++--------------------------------------------------------------------------------+-- Comparison+--------------------------------------------------------------------------------++isSubmapOf+ :: (Ord k1, Ord k2, MonoidNull v, Reductive v)+ => NestedMonoidMap k1 k2 v+ -> NestedMonoidMap k1 k2 v+ -> Bool+isSubmapOf (NestedMonoidMap m1) (NestedMonoidMap m2) =+ MonoidMap.isSubmapOf m1 m2++isSubmapOfBy+ :: (Ord k1, Ord k2, MonoidNull v, Reductive v)+ => (v -> v -> Bool)+ -> NestedMonoidMap k1 k2 v+ -> NestedMonoidMap k1 k2 v+ -> Bool+isSubmapOfBy f (NestedMonoidMap m1) (NestedMonoidMap m2) =+ MonoidMap.isSubmapOfBy (MonoidMap.isSubmapOfBy f) m1 m2++disjoint+ :: (Ord k1, Ord k2, MonoidNull v, GCDMonoid v)+ => NestedMonoidMap k1 k2 v+ -> NestedMonoidMap k1 k2 v+ -> Bool+disjoint (NestedMonoidMap m1) (NestedMonoidMap m2) =+ MonoidMap.disjoint m1 m2++disjointBy+ :: (Ord k1, Ord k2, MonoidNull v, GCDMonoid v)+ => (v -> v -> Bool)+ -> NestedMonoidMap k1 k2 v+ -> NestedMonoidMap k1 k2 v+ -> Bool+disjointBy f (NestedMonoidMap m1) (NestedMonoidMap m2) =+ MonoidMap.disjointBy (MonoidMap.disjointBy f) m1 m2
+ components/monoidmap-examples/Data/MonoidMap/Examples/Set/NonEmpty.hs view
@@ -0,0 +1,44 @@+-- |+-- Copyright: © 2022–2025 Jonathan Knowles+-- License: Apache-2.0+--+-- A minimal non-empty variant of the 'Set' data type.+--+module Data.MonoidMap.Examples.Set.NonEmpty+ ( NESet+ , nonEmptySet+ , toSet+ , isSubsetOf+ , union+ , intersection+ ) where++import Prelude++import Data.Coerce+ ( coerce )+import Data.Set+ ( Set )++import qualified Data.Set as Set++newtype NESet v = NESet (Set v)+ deriving stock Eq+ deriving newtype (Semigroup, Show)++nonEmptySet :: Set v -> Maybe (NESet v)+nonEmptySet s+ | Set.null s = Nothing+ | otherwise = Just (NESet s)++toSet :: NESet v -> Set v+toSet = coerce++isSubsetOf :: Ord v => NESet v -> NESet v -> Bool+isSubsetOf = coerce Set.isSubsetOf++union :: Ord v => NESet v -> NESet v -> NESet v+union = coerce Set.union++intersection :: Ord v => NESet v -> NESet v -> Set v+intersection = coerce Set.intersection
+ monoidmap-examples.cabal view
@@ -0,0 +1,100 @@+cabal-version: 3.0+name: monoidmap-examples+version: 0.0.0.0+bug-reports: https://github.com/jonathanknowles/monoidmap-examples/issues+license: Apache-2.0+license-file: LICENSE+author: Jonathan Knowles+maintainer: mail@jonathanknowles.net+copyright: 2022–2025 Jonathan Knowles+category: Data Structures+synopsis: Examples for monoidmap.+description: Examples for the monoidmap package.++extra-doc-files:+ CHANGELOG.md+ README.md++common dependency-base+ build-depends:base >= 4.14.3.0 && < 4.22+common dependency-containers+ build-depends:containers >= 0.6.5.1 && < 0.8+common dependency-hspec+ build-depends:hspec >= 2.10.9 && < 2.12+common dependency-monoid-subclasses+ build-depends:monoid-subclasses >= 1.2.3 && < 1.3+common dependency-monoidmap+ build-depends:monoidmap >= 0.0.4.4 && < 0.1+common dependency-QuickCheck+ build-depends:QuickCheck >= 2.14.2 && < 2.16++common extensions+ default-extensions:+ BangPatterns+ ConstraintKinds+ DerivingStrategies+ DerivingVia+ FlexibleContexts+ FlexibleInstances+ GeneralizedNewtypeDeriving+ LambdaCase+ MultiParamTypeClasses+ NoImplicitPrelude+ NumericUnderscores+ ScopedTypeVariables+ TupleSections+ TypeApplications+ TypeFamilies+ TypeOperators+ ViewPatterns++source-repository head+ type: git+ location: https://github.com/jonathanknowles/monoidmap++library+ import:+ , dependency-base+ , dependency-containers+ , dependency-monoid-subclasses+ , dependency-monoidmap+ , extensions+ hs-source-dirs:+ components/monoidmap-examples+ exposed-modules:+ Data.MonoidMap.Examples.MultiMap+ Data.MonoidMap.Examples.MultiMap.Class+ Data.MonoidMap.Examples.MultiMap.Instances.MultiMap1+ Data.MonoidMap.Examples.MultiMap.Instances.MultiMap2+ Data.MonoidMap.Examples.MultiMap.Instances.MultiMap3+ Data.MonoidMap.Examples.MultiMap.Instances.MultiMap4+ Data.MonoidMap.Examples.MultiSet+ Data.MonoidMap.Examples.NestedMonoidMap+ Data.MonoidMap.Examples.Set.NonEmpty+ default-language:+ Haskell2010++test-suite monoidmap-examples-test+ import:+ , dependency-base+ , dependency-containers+ , dependency-hspec+ , dependency-QuickCheck+ , extensions+ build-depends:+ , monoidmap-examples+ ghc-options:+ -threaded -with-rtsopts=-N+ main-is:+ Spec.hs+ hs-source-dirs:+ components/monoidmap-examples-test+ other-modules:+ Data.MonoidMap.Examples.MultiMapSpec+ SpecHook+ type:+ exitcode-stdio-1.0+ default-language:+ Haskell2010+ build-tool-depends:+ hspec-discover:hspec-discover ==2.*