diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +# 0.0.0.0 + +- Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +# `monoidmap-examples` + +Examples for the [`monoidmap`](https://github.com/jonathanknowles/monoidmap) package. + + diff --git a/components/monoidmap-examples-test/Data/MonoidMap/Examples/MultiMapSpec.hs b/components/monoidmap-examples-test/Data/MonoidMap/Examples/MultiMapSpec.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-examples-test/Data/MonoidMap/Examples/MultiMapSpec.hs @@ -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 diff --git a/components/monoidmap-examples-test/Spec.hs b/components/monoidmap-examples-test/Spec.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-examples-test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/components/monoidmap-examples-test/SpecHook.hs b/components/monoidmap-examples-test/SpecHook.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-examples-test/SpecHook.hs @@ -0,0 +1,6 @@ +module SpecHook where + +import Test.Hspec + +hook :: Spec -> Spec +hook = parallel diff --git a/components/monoidmap-examples/Data/MonoidMap/Examples/MultiMap.hs b/components/monoidmap-examples/Data/MonoidMap/Examples/MultiMap.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-examples/Data/MonoidMap/Examples/MultiMap.hs @@ -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 ) diff --git a/components/monoidmap-examples/Data/MonoidMap/Examples/MultiMap/Class.hs b/components/monoidmap-examples/Data/MonoidMap/Examples/MultiMap/Class.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-examples/Data/MonoidMap/Examples/MultiMap/Class.hs @@ -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 diff --git a/components/monoidmap-examples/Data/MonoidMap/Examples/MultiMap/Instances/MultiMap1.hs b/components/monoidmap-examples/Data/MonoidMap/Examples/MultiMap/Instances/MultiMap1.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-examples/Data/MonoidMap/Examples/MultiMap/Instances/MultiMap1.hs @@ -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 diff --git a/components/monoidmap-examples/Data/MonoidMap/Examples/MultiMap/Instances/MultiMap2.hs b/components/monoidmap-examples/Data/MonoidMap/Examples/MultiMap/Instances/MultiMap2.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-examples/Data/MonoidMap/Examples/MultiMap/Instances/MultiMap2.hs @@ -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 diff --git a/components/monoidmap-examples/Data/MonoidMap/Examples/MultiMap/Instances/MultiMap3.hs b/components/monoidmap-examples/Data/MonoidMap/Examples/MultiMap/Instances/MultiMap3.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-examples/Data/MonoidMap/Examples/MultiMap/Instances/MultiMap3.hs @@ -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) diff --git a/components/monoidmap-examples/Data/MonoidMap/Examples/MultiMap/Instances/MultiMap4.hs b/components/monoidmap-examples/Data/MonoidMap/Examples/MultiMap/Instances/MultiMap4.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-examples/Data/MonoidMap/Examples/MultiMap/Instances/MultiMap4.hs @@ -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) diff --git a/components/monoidmap-examples/Data/MonoidMap/Examples/MultiSet.hs b/components/monoidmap-examples/Data/MonoidMap/Examples/MultiSet.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-examples/Data/MonoidMap/Examples/MultiSet.hs @@ -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 = () diff --git a/components/monoidmap-examples/Data/MonoidMap/Examples/NestedMonoidMap.hs b/components/monoidmap-examples/Data/MonoidMap/Examples/NestedMonoidMap.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-examples/Data/MonoidMap/Examples/NestedMonoidMap.hs @@ -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 diff --git a/components/monoidmap-examples/Data/MonoidMap/Examples/Set/NonEmpty.hs b/components/monoidmap-examples/Data/MonoidMap/Examples/Set/NonEmpty.hs new file mode 100644 --- /dev/null +++ b/components/monoidmap-examples/Data/MonoidMap/Examples/Set/NonEmpty.hs @@ -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 diff --git a/monoidmap-examples.cabal b/monoidmap-examples.cabal new file mode 100644 --- /dev/null +++ b/monoidmap-examples.cabal @@ -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.*