diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +# 0.1.0.0 + +Initial version. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,202 @@ + + 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 [yyyy] [name of copyright owner] + + 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/src/Data/Ten/HashMap.hs b/src/Data/Ten/HashMap.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ten/HashMap.hs @@ -0,0 +1,175 @@ +-- Copyright 2020-2021 Google LLC +-- +-- 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. + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +-- | A hash map linking keys' and values' type parameters existentially. + +module Data.Ten.HashMap + ( -- * HashMap10 + HashMap10, (:**)(..) + , empty, insert, lookup, findWithDefault + , toList, fromList + -- * Miscellaneous + , Hashable1, Show1, Portray1, Diff1 + ) where + +import Prelude hiding (lookup) + +import qualified Data.Foldable as F +import Data.Maybe (catMaybes, fromMaybe) +import Data.Semigroup (Any(..), All(..)) +import Data.Type.Equality ((:~:)(..), TestEquality(..)) +import GHC.Exts (IsList) +import qualified GHC.Exts as Exts +import GHC.Generics (Generic1, (:.:)(..)) + +import Data.GADT.Compare (GEq(..)) +import Data.Hashable (Hashable(..)) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM +import Data.Portray (Portray(..), Portrayal(..)) +import Data.Portray.Diff (Diff(..), diffVs) +import Data.Wrapped (Wrapped1(..)) + +import Data.Ten.Entails (Entails(..), (:!:)) +import Data.Ten.Exists (Exists(..)) +import Data.Ten.Foldable (Foldable10(..)) +import Data.Ten.Foldable.WithIndex (Foldable10WithIndex(..)) +import Data.Ten.Functor (Functor10(..)) +import Data.Ten.Functor.WithIndex (Index10, Functor10WithIndex(..)) +import Data.Ten.Traversable (Traversable10(..)) +import Data.Ten.Traversable.WithIndex (Traversable10WithIndex(..)) +import Data.Ten.Sigma ((:**)(..)) + +type Hashable1 k = forall x. Hashable (k x) +type Show1 k = forall x. Show (k x) +type Portray1 k = forall x. Portray (k x) +type Diff1 k = forall x. Diff (k x) + +type instance Index10 (HashMap10 k) = k + +-- | A "dependent" hash map, where elements' type parameters match their keys'. +newtype HashMap10 k m = HashMap10 (HashMap (Exists k) (k :** m)) + deriving Generic1 + deriving + ( Functor10, Foldable10, Traversable10 + ) via Wrapped1 Generic1 (HashMap10 k) + deriving + ( Functor10WithIndex, Foldable10WithIndex, Traversable10WithIndex + ) via HashMap (Exists k) :.: ((:**) k) + +deriving stock + instance (GEq k, Entails k (Eq :!: m)) => Eq (HashMap10 k m) + +deriving stock + instance (Show1 k, Entails k (Show :!: m)) => Show (HashMap10 k m) + +instance (GEq k, Hashable1 k) => IsList (HashMap10 k m) where + type Item (HashMap10 k m) = k :** m + toList = toList + fromList = fromList + +instance (Portray1 k, Entails k (Portray :!: m)) + => Portray (HashMap10 k m) where + portray = Apply "fromList" . pure . portray . toList + +data EntryDiff a = InLeft a | InBoth a a | InRight a + +diffToM :: Maybe Portrayal -> ((Any, All), Maybe Portrayal) +diffToM = \case + Nothing -> ((Any False, All False), Nothing) + Just d -> ((Any True, All True), Just d) + +diffM :: (Diff a, Portray a) => EntryDiff a -> ((Any, All), Maybe Portrayal) +diffM e = diffToM $ case e of + InLeft x -> Just $ portray x `diffVs` "_" + InBoth x y -> diff x y + InRight y -> Just $ "_" `diffVs` portray y + +instance ( TestEquality k, GEq k, Hashable1 k, Portray1 k, Diff1 k + , Entails k (Portray :!: m), Entails k (Diff :!: m) + ) + => Diff (HashMap10 k m) where + diff (HashMap10 l) (HashMap10 r) = + if anyDiff + then + Just $ Apply "fromList" $ pure $ List $ + (if allDiff then id else (++ ["..."])) $ + catMaybes $ F.toList diffs + else Nothing + where + ((Any anyDiff, All allDiff), diffs) = + traverse diffM $ + HM.unionWith (\ (InLeft x) (InRight y) -> InBoth x y) + (InLeft <$> l) + (InRight <$> r) + +-- | An empty 'HashMap10'. +empty :: HashMap10 k m +empty = HashMap10 HM.empty + +-- | Insert a new pair into a 'HashMap10' +insert + :: forall a k m + . (GEq k, Hashable1 k) + => k a -> m a -> HashMap10 k m -> HashMap10 k m +insert k m (HashMap10 h) = HashMap10 $ HM.insert (Exists k) (k :** m) h + +fromEntry + :: forall a k m + . GEq k + => k a -> k :** m -> m a +fromEntry k (k' :** m) = case geq k k' of + Just Refl -> m + Nothing -> error "Internal error: key mapped to entry of the wrong type." + +-- | Find an entry based on its key, if present. +lookup + :: forall a k m + . (GEq k, Hashable1 k) + => k a -> HashMap10 k m -> Maybe (m a) +lookup k (HashMap10 h) = fromEntry k <$> HM.lookup (Exists k) h + +-- | Find an entry based on its key, or return the given fallback value. +findWithDefault + :: forall a k m + . (GEq k, Hashable1 k) + => m a -> k a -> HashMap10 k m -> m a +findWithDefault m k = fromMaybe m . lookup k + +-- | Convert to a list of (':**') in unspecified order. +toList :: HashMap10 k m -> [k :** m] +toList (HashMap10 m) = F.toList m + +-- | Build a map from a list of (k ':**' m) entries. +fromList :: (GEq k, Hashable1 k) => [k :** m] -> HashMap10 k m +fromList = HashMap10 . HM.fromList . map (\ e@(k :** _) -> (Exists k, e)) diff --git a/ten-unordered-containers.cabal b/ten-unordered-containers.cabal new file mode 100644 --- /dev/null +++ b/ten-unordered-containers.cabal @@ -0,0 +1,75 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: bacdf6bf658e324e59d002464462008d6e6041183c60c073fc2f568c989d3873 + +name: ten-unordered-containers +version: 0.1.0.0 +synopsis: A package providing one unordered container. +description: This provides unordered (hash-based) containers of kind `(k -> Type) -> Type` + based on unordered-containers. Currently only HashMap10 is implemented. +category: Data +homepage: https://github.com/google/hs-ten#readme +bug-reports: https://github.com/google/hs-ten/issues +author: Andrew Pritchard +maintainer: Andrew Pritchard +copyright: 2020-2021 Google LLC +license: Apache-2.0 +license-file: LICENSE +build-type: Simple +extra-source-files: + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/google/hs-ten + subdir: ten-unordered-containers + +library + exposed-modules: + Data.Ten.HashMap + other-modules: + Paths_ten_unordered_containers + hs-source-dirs: + src + build-depends: + base >=4.12 && <4.16 + , hashable >=1.0 && <1.4 + , portray >=0.1 && <0.2 + , portray-diff >=0.1 && <0.2 + , some >=1.0 && <1.1 + , ten >=0.1 && <0.2 + , unordered-containers >=0.1 && <0.3 + , wrapped >=0.1 && <0.2 + default-language: Haskell2010 + +test-suite HashMap-test + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Paths_ten_unordered_containers + hs-source-dirs: + test + build-depends: + HUnit + , base >=4.12 && <4.16 + , hashable >=1.0 && <1.4 + , lens + , portray >=0.1 && <0.2 + , portray-diff >=0.1 && <0.2 + , portray-diff-hunit + , portray-pretty + , some >=1.0 && <1.1 + , ten >=0.1 && <0.2 + , ten-lens + , ten-unordered-containers + , test-framework + , test-framework-hunit + , text + , transformers + , unordered-containers >=0.1 && <0.3 + , wrapped >=0.1 && <0.2 + default-language: Haskell2010 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,164 @@ +-- Copyright 2021 Google LLC +-- +-- 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. + +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Main where + +import Control.Monad.Trans.Writer (runWriter, tell) +import Data.Functor.Const (Const(..)) +import Data.Functor.Identity (Identity(..)) +import Data.Kind (Type) +import Data.Monoid (Sum(..)) +import Data.Proxy (Proxy(..)) +import Data.Text (Text) +import Data.Type.Equality (TestEquality(..), (:~:)(..)) +import GHC.Generics (Generic, Generic1) +import Type.Reflection (TypeRep, Typeable, typeRep) + +import Control.Lens.TH (makeLenses) +import Data.Wrapped (Wrapped1(..)) +import Test.Framework (defaultMain) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@?=)) + +import Data.Portray (Portray) +import Data.Portray.Diff.HUnit ((@?-)) +import Data.Portray.Pretty (showPortrayal) + +import Data.Ten.HashMap as HM +import Data.Ten +import Data.Ten.Lens ((!=?), (!=)) + +data InnerRecord f = InnerRecord + { _irText :: Ap10 Text f + , _irText2 :: Ap10 Text f + } + deriving (Generic, Generic1) + deriving + ( Functor10, Foldable10, Traversable10, Constrained10 c + , Applicative10, Representable10, Update10, FieldPaths10 + ) via Wrapped1 Generic1 InnerRecord + +data ExampleRecord f = ExampleRecord + { _erInt :: Ap10 Int f + , _erBool :: Ap10 Bool f + , _erNest :: InnerRecord f + } + deriving (Generic, Generic1) + deriving + ( Functor10, Foldable10, Traversable10, Constrained10 c + , Applicative10, Representable10, Update10, FieldPaths10 + ) via Wrapped1 Generic1 ExampleRecord + deriving + ( Functor10WithIndex, Foldable10WithIndex, Traversable10WithIndex + ) via Wrapped1 Representable10 ExampleRecord + +type instance Index10 ExampleRecord = Field10 ExampleRecord + +$(makeLenses 'InnerRecord) +$(makeLenses 'ExampleRecord) + +dynProxy :: forall (a :: Type). Typeable a => TypeRep :** Proxy +dynProxy = typeRep @a :** Proxy @a + +dyn :: forall a. Typeable a => a -> TypeRep :** Identity +dyn x = typeRep @a :** Identity x + +exampleMap :: HM.HashMap10 (Field10 ExampleRecord) Identity +exampleMap = HM.fromList + [ erInt !=? 2 + , erBool !=? True + , erNest.irText !=? "aoeu" + ] + +main :: IO () +main = defaultMain + [ testCase "portray empty" $ + showPortrayal (HM.fromList @TypeRep @Proxy []) @?= "fromList []" + + , testCase "portray non-empty" $ + showPortrayal (HM.fromList [dynProxy @Int, dynProxy @(Int -> Int)]) @?= + "fromList\n\ + \ [ typeRep @Int :** Proxy, typeRep @(Int -> Int) :** Proxy ]" + + , testCase "portray Identity" $ + showPortrayal exampleMap @?= + "fromList\n\ + \ [ Field10 _erInt :** Identity 2\ + \, Field10 _erBool :** Identity True\n\ + \ , Field10 (_irText . _erNest) :** Identity \"aoeu\"\n\ + \ ]" + + , testCase "length10" $ + getSum @Int + (foldMap10 (const (Sum 1)) (HM.fromList @TypeRep @Proxy [])) @?= 0 + + , testCase "traverse10C" $ + runWriter + (traverse10C @Portray + (\ (Identity x) -> [x, x] <$ tell [showPortrayal x]) + exampleMap) @?- + ( HM.fromList + [ erInt != [2, 2] + , erBool != [True, True] + , erNest.irText != ["aoeu", "aoeu"] + ] + , ["2", "True", "\"aoeu\""] + ) + + , testCase "toHashMap" $ + ifoldr10 HM.insert HM.empty + (tabulate10 @Type @ExampleRecord (Const . showPortrayal)) @?- + HM.fromList + [ erInt != Const "Field10 _erInt" + , erBool != Const "Field10 _erBool" + , erNest.irText != Const "Field10 (_irText . _erNest)" + , erNest.irText2 != Const "Field10 (_irText2 . _erNest)" + ] + + , testCase "dyns" $ + HM.lookup (typeRep @Bool) + (HM.fromList [dyn True, dyn not, dyn (dyn @Int)]) @?= + Just (Identity True) + + , testCase "map dyns" $ + imap10 + (\ ty (Identity x) -> Const @String $ case ty of + _ + | Just Refl <- testEquality ty (typeRep @String) -> x + | Just Refl <- testEquality ty (typeRep @Bool) -> (show x) + | Just Refl <- testEquality ty (typeRep @(Bool -> Bool)) + -> "" + | otherwise -> "" + ) + (HM.fromList [dyn True, dyn @String "hi", dyn not, dyn 'a']) @?- + (HM.fromList + [ typeRep @String :** Const "hi" + , typeRep @Bool :** Const "True" + , typeRep @(Bool -> Bool) :** Const "" + , typeRep @Char :** Const "" + ]) + ]