finite-table (empty) → 0.1.0.0
raw patch · 6 files changed
+897/−0 lines, 6 filesdep +QuickCheckdep +adjunctionsdep +base
Dependencies added: QuickCheck, adjunctions, base, cereal, data-default-class, deepseq, distributive, fin-int, finite-table, indexed-traversable, lens, portray, portray-diff, short-vec, short-vec-lens, sint, test-framework, test-framework-quickcheck2, wrapped
Files
- CHANGELOG.md +3/−0
- LICENSE +202/−0
- finite-table.cabal +84/−0
- src/Data/Finite.hs +313/−0
- src/Data/Finite/Table.hs +218/−0
- test/Main.hs +77/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+# 0.1.0.0++Initial version.
+ LICENSE view
@@ -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.
+ finite-table.cabal view
@@ -0,0 +1,84 @@+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: 846224cc1ea6987d33f8472ae781836cc87ccbf4e2cf71fda8e537b8ce9d56c0++name: finite-table+version: 0.1.0.0+synopsis: Types isomorphic to Fin, and Tables indexed by them.+description: This provides a class `Finite` for types isomorphic to some `Fin n`, and+ uses it to implement array-backed total maps (`Table`s) indexed by them.+category: Data+homepage: https://github.com/google/hs-fin-vec#readme+bug-reports: https://github.com/google/hs-fin-vec/issues+author: Andrew Pritchard <awpr@google.com>+maintainer: Andrew Pritchard <awpr@google.com>+copyright: 2017-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-fin-vec+ subdir: finite-table++library+ exposed-modules:+ Data.Finite+ Data.Finite.Table+ other-modules:+ Paths_finite_table+ hs-source-dirs:+ src+ build-depends:+ adjunctions >=4.4 && <4.5+ , base >=4.12 && <4.16+ , cereal >=0.5 && <0.6+ , data-default-class >=0.0 && <0.2+ , deepseq >=1.1 && <1.5+ , distributive >=0.1 && <0.7+ , fin-int >=0.1 && <0.2+ , indexed-traversable >=0.1 && <0.2+ , lens >=4.15 && <5.1+ , portray >=0.1 && <0.2+ , portray-diff >=0.1 && <0.2+ , short-vec >=0.1 && <0.2+ , short-vec-lens >=0.1 && <0.2+ , sint >=0.1 && <0.2+ , wrapped >=0.1 && <0.2+ default-language: Haskell2010++test-suite Finite-test+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ Paths_finite_table+ hs-source-dirs:+ test+ build-depends:+ QuickCheck+ , adjunctions >=4.4 && <4.5+ , base >=4.12 && <4.16+ , cereal >=0.5 && <0.6+ , data-default-class >=0.0 && <0.2+ , deepseq >=1.1 && <1.5+ , distributive >=0.1 && <0.7+ , fin-int >=0.1 && <0.2+ , finite-table+ , indexed-traversable >=0.1 && <0.2+ , lens >=4.15 && <5.1+ , portray >=0.1 && <0.2+ , portray-diff >=0.1 && <0.2+ , short-vec >=0.1 && <0.2+ , short-vec-lens >=0.1 && <0.2+ , sint >=0.1 && <0.2+ , test-framework+ , test-framework-quickcheck2+ , wrapped >=0.1 && <0.2+ default-language: Haskell2010
+ src/Data/Finite.hs view
@@ -0,0 +1,313 @@+-- Copyright 2019-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 BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoStarIsType #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Provides a class of types isomorphic to some statically-known @'Fin' n@.+--+-- This comes with Generics-based generated instances, and can be used to+-- generate instances of 'Enum' and 'Bounded' (for which the stock deriving+-- only supports sum types with no fields).+--+-- Since this is all still represented by 'Int' internally, things will start+-- raising 'error's if your type has more values than can fit in positive+-- 'Int's. It's not recommended to use this on large types, and there's not+-- much reason to want to anyway, as its main uses are to derive 'Enum' (which+-- is also based on 'Int') and to make the type compatible with+-- 'Data.Finite.Table.Table' (which would be impractically large for a key type+-- with too many values to represent as 'Int').+--+-- The most common way to get a 'Finite' instance for a type is to tack on a+-- @deriving Finite via 'Wrapped' 'Generic' MyType@ clause, which results in an+-- automatically-generated instance based on the type's ADT structure.+--+-- This also provides instances @'Enum' (Wrapped Finite a)@ and+-- @'Bounded' (Wrapped Finite a)@, so some types that would otherwise not be+-- compatible with derived 'Enum' instances can get them by adding a+-- @deriving (Enum, Bounded) via Wrapped Finite MyType@ clause.++module Data.Finite+ ( -- * Finite Enumerations+ Finite(..), cardinality, enumerate, asFin+ -- * Implementation Details+ , SC, GFinite(..), GCardinality+ ) where++import Data.Functor.Identity (Identity)+import Data.Int (Int8, Int16)+import Data.Proxy (Proxy(..))+import Data.Semigroup (WrappedMonoid, Min, Max, First, Last)+import Data.Void (Void)+import Data.Word (Word8, Word16)+import GHC.Generics+ ( Generic(..), V1, U1(..), M1(..), K1(..), (:+:)(..), (:*:)(..)+ )+import GHC.TypeNats (type (+), type (*), type (<=), KnownNat, Nat, natVal)++import Control.Lens (Iso', iso)+import Data.SInt (SInt, sintVal, addSInt, mulSInt, staticSIntVal, reifySInt)++import Data.Fin.Int.Explicit+ ( enumFin, concatFin, splitFin, crossFin, divModFin, minFin, maxFin+ , fin+ )+import Data.Fin.Int (Fin, finToInt, unsafeFin)+import qualified Data.Vec.Short as V+import Data.Wrapped (Wrapped(..))++-- | A typeclass of finite enumerable types.+--+-- These allow constructing 'Data.Functor.Rep.Representable' Functors using a+-- simple 'Data.Vec.Short.Vec' as the underlying storage, with constant-time+-- lookup and efficient traversals.+--+-- Note that since 'Fin' is (currently) represented by 'Int', any type with+-- more values than 'Int' can't have an instance. This means we can't have+-- instances for 32- and 64-bit arithmetic types, since 'Int' is only required+-- to have 30 bits of precision.+--+-- Annoyingly, we also can't have an instance for 'Int' and 'Word', because+-- 'Fin' wastes one bit of the 'Int' by forbidding negative values. The+-- cardinality of 'Int' and 'Word' would need to be twice as large as we can+-- actually represent in a 'Fin'. Another obstacle is that their cardinality+-- varies between implementations and architectures; it's possible to work+-- around this by making their Cardinality an irreducible type family+-- application, and using 'Data.SInt.SI#' to plug in a value at runtime, but+-- this makes the 'Fin's related to 'Int' and 'Word' annoying to work with,+-- since their bound is only known at runtime.+--+-- Fortunately, those instances are unlikely to be important, since a table of+-- 2^32 elements is moderately impractical (32GiB of pointers alone), and a+-- table of 2^64 elements is unrepresentable in current computer architectures.+--+-- 'toFin' and 'fromFin' shall be total functions and shall be the two sides of+-- an isomorphism.+class Finite a where+ type Cardinality a :: Nat+ -- | A witness that the cardinality is known at runtime.+ --+ -- This isn't part of the class context because we can only perform+ -- arithmetic on 'KnownNat' instances in expression context; that is, we+ -- can't convince GHC that an instance with+ -- @type Cardinality (Maybe a) = Cardinality a + 1@ is valid if the+ -- 'KnownNat' is in the class context. Instead, we use 'SInt' to allow+ -- computing the cardinality at runtime.+ cardinality' :: SC a (Cardinality a)++ toFin :: a -> Fin (Cardinality a)+ fromFin :: Fin (Cardinality a) -> a++-- | A wrapper type around @'Cardinality' a@ to support DerivingVia on GHC 8.6.+--+-- Instance methods that don't mention the instance head outside of type+-- families / aliases don't work with DerivingVia on GHC 8.6 because it uses+-- type signatures rather than TypeApplications to choose the instance to call+-- into.+newtype SC a n = SC { getSC :: SInt n }++-- | A witness that the cardinality of @a@ is known at runtime.+cardinality :: forall a. Finite a => SInt (Cardinality a)+cardinality = getSC (cardinality' @a)++-- | Generate a list containing every value of @a@.+enumerate :: forall a. Finite a => [a]+enumerate = fromFin <$> enumFin (cardinality @a)++-- | Implement 'toFin' by 'fromEnum'.+--+-- This should only be used for types with 'fromEnum' range @0..Cardinality a@;+-- this is notably not the case for signed integer types, which have negative+-- 'fromEnum' values.+toFinEnum :: Enum a => SInt (Cardinality a) -> a -> Fin (Cardinality a)+toFinEnum sn = fin sn . fromEnum++-- | Implement 'fromFin' by 'toEnum'.+--+-- The same restrictions apply as for 'toFinEnum'.+fromFinEnum :: Enum a => Fin (Cardinality a) -> a+fromFinEnum = toEnum . finToInt++instance Finite Char where+ type Cardinality Char = 1114112 -- According to 'minBound' and 'maxBound'+ cardinality' = SC staticSIntVal+ toFin = toFinEnum staticSIntVal+ fromFin = fromFinEnum++toFinExcessK+ :: forall n a. (KnownNat n, Integral a) => a -> Fin (Cardinality a)+toFinExcessK =+ unsafeFin . (+ (fromIntegral (natVal @n Proxy) :: Int)) . fromIntegral++fromFinExcessK+ :: forall n a. (KnownNat n, Integral a) => Fin (Cardinality a) -> a+fromFinExcessK =+ subtract (fromIntegral (natVal @n Proxy)) . fromIntegral . finToInt++instance Finite Int8 where+ type Cardinality Int8 = 256+ cardinality' = SC staticSIntVal+ toFin = toFinExcessK @128+ fromFin = fromFinExcessK @128++instance Finite Int16 where+ type Cardinality Int16 = 65536+ cardinality' = SC staticSIntVal+ toFin = toFinExcessK @32768+ fromFin = fromFinExcessK @32768++instance Finite Word8 where+ type Cardinality Word8 = 256+ cardinality' = SC staticSIntVal+ toFin = unsafeFin . id @Int . fromIntegral+ fromFin = fromIntegral . finToInt++instance Finite Word16 where+ type Cardinality Word16 = 65536+ cardinality' = SC staticSIntVal+ toFin = unsafeFin . id @Int . fromIntegral+ fromFin = fromIntegral . finToInt++instance KnownNat n => Finite (Fin n) where+ type Cardinality (Fin n) = n+ cardinality' = SC sintVal+ toFin = id+ fromFin = id++-- Aesthetics: make more derived instances fit on one line.+type G = Wrapped Generic++deriving via G () instance Finite ()+deriving via G Bool instance Finite Bool+deriving via G Ordering instance Finite Ordering+deriving via G Void instance Finite Void+deriving via G (Identity a) instance Finite a => Finite (Identity a)+deriving via G (WrappedMonoid a) instance Finite a => Finite (WrappedMonoid a)+deriving via G (Last a) instance Finite a => Finite (Last a)+deriving via G (First a) instance Finite a => Finite (First a)+deriving via G (Max a) instance Finite a => Finite (Max a)+deriving via G (Min a) instance Finite a => Finite (Min a)+deriving via G (Maybe a) instance Finite a => Finite (Maybe a)+deriving via G (Either a b) instance (Finite a, Finite b) => Finite (Either a b)++deriving via G (a, b) instance (Finite a, Finite b) => Finite (a, b)+deriving via G (a, b, c)+ instance (Finite a, Finite b, Finite c) => Finite (a, b, c)++deriving via G (a, b, c, d)+ instance (Finite a, Finite b, Finite c, Finite d) => Finite (a, b, c, d)+deriving via G (a, b, c, d, e)+ instance (Finite a, Finite b, Finite c, Finite d, Finite e)+ => Finite (a, b, c, d, e)++instance (Generic a, GFinite (Rep a)) => Finite (Wrapped Generic a) where+ type Cardinality (Wrapped Generic a) = GCardinality (Rep a)+ cardinality' = SC $ gcardinality @(Rep a)+ toFin = gtoFin . from . unWrapped+ fromFin = Wrapped . to . gfromFin++-- | The derived cardinality of a generic representation type.+type family GCardinality a where+ GCardinality V1 = 0+ GCardinality U1 = 1+ GCardinality (K1 i a) = Cardinality a+ GCardinality (M1 i c f) = GCardinality f+ GCardinality (f :+: g) = GCardinality f + GCardinality g+ GCardinality (f :*: g) = GCardinality f * GCardinality g++-- | The derived 'Finite' implementation of a generic representation type.+class GFinite a where+ gcardinality :: SInt (GCardinality a)+ gtoFin :: a p -> Fin (GCardinality a)+ gfromFin :: Fin (GCardinality a) -> a p++instance GFinite V1 where+ gcardinality = staticSIntVal+ gtoFin x = case x of {}+ gfromFin x = V.nil V.! x++instance GFinite U1 where+ gcardinality = staticSIntVal+ gtoFin U1 = minFin+ gfromFin !_ = U1++instance Finite a => GFinite (K1 i a) where+ gcardinality = cardinality @a+ gtoFin = toFin . unK1+ gfromFin = K1 . fromFin++instance GFinite f => GFinite (M1 i c f) where+ gcardinality = gcardinality @f+ gtoFin = gtoFin . unM1+ gfromFin = M1 . gfromFin++instance (GFinite f, GFinite g) => GFinite (f :+: g) where+ gcardinality = gcardinality @f `addSInt` gcardinality @g+ gtoFin x = concatFin (gcardinality @f) $ case x of+ L1 f -> Left $ gtoFin f+ R1 g -> Right $ gtoFin g+ gfromFin =+ either (L1 . gfromFin) (R1 . gfromFin) . splitFin (gcardinality @f)+ {-# INLINE gtoFin #-}+ {-# INLINE gfromFin #-}++instance (GFinite f, GFinite g) => GFinite (f :*: g) where+ gcardinality = gcardinality @f `mulSInt` gcardinality @g+ gtoFin (f :*: g) = crossFin (gcardinality @g) (gtoFin f) (gtoFin g)+ gfromFin x =+ let (f, g) = divModFin (gcardinality @g) x+ in gfromFin f :*: gfromFin g+ {-# INLINE gtoFin #-}+ {-# INLINE gfromFin #-}++-- | An 'Control.Lens.Iso' between @a@ and the corresponding 'Fin' type.+asFin :: Finite a => Iso' a (Fin (Cardinality a))+asFin = iso toFin fromFin++instance Finite a => Enum (Wrapped Finite a) where+ toEnum = Wrapped . fromFin . fin (cardinality @a)+ fromEnum = finToInt . toFin . unWrapped+ enumFrom = reifySInt (cardinality @a) $+ fmap (Wrapped . fromFin) . enumFrom . toFin . unWrapped+ enumFromThen (Wrapped x) = reifySInt (cardinality @a) $+ fmap (Wrapped . fromFin) . enumFromThen (toFin x) . toFin . unWrapped+ enumFromTo (Wrapped x) = reifySInt (cardinality @a) $+ fmap (Wrapped . fromFin) . enumFromTo (toFin x) . toFin . unWrapped+ enumFromThenTo (Wrapped x) (Wrapped y) = reifySInt (cardinality @a) $+ fmap (Wrapped . fromFin) . enumFromThenTo (toFin x) (toFin y) .+ toFin . unWrapped++instance (Finite a, 1 <= Cardinality a) => Bounded (Wrapped Finite a) where+ minBound = Wrapped $ fromFin minFin+ maxBound = Wrapped $ fromFin (maxFin (cardinality @a))
+ src/Data/Finite/Table.hs view
@@ -0,0 +1,218 @@+-- Copyright 2019-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 CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoStarIsType #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-- | Provides 'Vec'-backed tables indexed by 'Finite' types.+--+-- Combined with 'Data.Finite' and its Generics-based derivation, this can+-- effectively provide an array-backed container indexed by finite type. This+-- is a low-syntactic-overhead way to create 'Representable' functors of any+-- desired shape: just define the index type, tack on the requisite @deriving@+-- clauses, and start using @'Table' MyType@.+--+-- @+-- data PrimaryColor = R | G | B+-- deriving Generic+-- deriving (Finite, Portray) via Wrapped Generic PrimaryColor+--+-- newtype Color = Color { getComponents :: Table PrimaryColor Int8 }+--+-- magenta :: Color+-- magenta = Color (Table $ Vec.fromList [255, 0, 255])+--+-- cyan :: Color+-- cyan = Color $ tabulate (\\case { R -> 0; G -> 255; B -> 255 })+--+-- main = pp $ getComponents magenta+-- -- "mkTable (\\case { R -> 255; G -> 0; B -> 255 })"+-- @++module Data.Finite.Table+ ( -- * Tables+ Table(..), (!), ix, idTable, mkTable, lmapTable, composeTable+ -- * Function Utilities+ , memoize, traverseRep+ -- * Representable Utilities+ , tabulateA, retabulated+ ) where++import Control.Applicative (Applicative(..))+import Data.Foldable (toList, traverse_)+import Data.Maybe (catMaybes, isJust)+import Data.Semigroup (Any(..), All(..))+import Control.DeepSeq (NFData(..))+import GHC.Generics (Generic)++import Control.Lens (Iso, Lens', from, lens, (&), (.~))+import Data.Default.Class (Default(..))+import Data.Distributive (Distributive(..))+import Data.Foldable.WithIndex (FoldableWithIndex(..))+import Data.Functor.Rep+ ( Representable(..), ifoldMapRep, imapRep, itraverseRep+ , tabulated+ )+import Data.Functor.WithIndex (FunctorWithIndex(..))+import Data.Portray (Portray(..), Portrayal(..))+import Data.Portray.Diff (Diff(..))+import Data.Serialize (Serialize(..))+import Data.Traversable.WithIndex (TraversableWithIndex(..))++import Data.Vec.Short (Vec)+import qualified Data.Vec.Short as V+import qualified Data.Vec.Short.Explicit as VE+import qualified Data.Vec.Short.Lens as V (ix)++import Data.Finite++#if !MIN_VERSION_lens(5,0,0)+import qualified Control.Lens as L+#endif++-- | A compact array of @b@s indexed by @a@, according to @'Finite' a@.+newtype Table a b = Table (Vec (Cardinality a) b)+ deriving (Eq, Ord, Show, Functor, Foldable, Generic)++-- | Pretty-print a Table as a 'mkTable' expression.+--+-- @+-- λ> pp $ (tabulate (even . finToInt) :: Table (Fin 3) Bool )+-- mkTable (\\case { 0 -> True; 1 -> False; 2 -> True })+-- @+instance (Finite a, Portray a, Portray b) => Portray (Table a b) where+ portray (Table xs) = Apply "mkTable" $ pure $ LambdaCase $+ zipWith (\a b -> (portray a, portray b)) (enumerate @a) (toList xs)++instance (Finite a, Portray a, Diff b) => Diff (Table a b) where+ diff (Table xs) (Table ys) =+ if hasDiff+ then Just $ Apply "mkTable" $ pure $ LambdaCase $+ (if allDiff then id else (++ [("_", "_")])) $+ catMaybes labeledDiffs+ else Nothing+ where+ (Any hasDiff, All allDiff) = foldMap+ (\x -> (Any (isJust x), All (isJust x)))+ labeledDiffs+ labeledDiffs = zipWith3+ (\a x y -> sequenceA (portray a, diff x y))+ (enumerate @a)+ (toList xs)+ (toList ys)++instance NFData a => NFData (Table k a) where+ rnf (Table vec) = rnf vec++instance (Finite k, Serialize a) => Serialize (Table k a) where+ get = sequenceA $ mkTable (const get)+ put = traverse_ put++instance Finite a => Applicative (Table a) where+ pure = tabulate . const+ liftA2 f x y = tabulate (liftA2 f (index x) (index y))+ f <*> x = tabulate (index f <*> index x)++instance (Finite a, Default b) => Default (Table a b) where+ def = pure def++-- | 'Data.Profunctor.lmap' for a constrained 'Data.Profunctor.Profunctor'.+lmapTable :: (Finite b, Finite c) => (b -> c) -> Table c a -> Table b a+lmapTable f t = tabulate $ \x -> t `index` f x++instance Finite a => Traversable (Table a) where+ traverse f (Table vec) = Table <$> traverse f vec++instance Finite a => Distributive (Table a) where+ collect f fa =+ let fgb = f <$> fa+ in Table $ VE.mkVec (cardinality @a) (\i -> flip index (fromFin i) <$> fgb)++instance Finite a => Representable (Table a) where+ type Rep (Table a) = a+ tabulate f = Table $ VE.mkVec (cardinality @a) (f . fromFin)+ index (Table vec) i = vec V.! toFin i++instance Finite a => FunctorWithIndex a (Table a) where imap = imapRep+instance Finite a => FoldableWithIndex a (Table a) where ifoldMap = ifoldMapRep+instance Finite a => TraversableWithIndex a (Table a) where+ itraverse = itraverseRep++#if !MIN_VERSION_lens(5,0,0)+instance Finite a => L.FunctorWithIndex a (Table a) where imap = imapRep+instance Finite a => L.FoldableWithIndex a (Table a) where ifoldMap = ifoldMapRep+instance Finite a => L.TraversableWithIndex a (Table a) where+ itraverse = itraverseRep+#endif++-- | The identity morphism of a constrained category of 'Table's.+idTable :: Finite a => Table a a+idTable = tabulate id++-- | The composition of a constrained category of 'Table's.+composeTable :: (Finite a, Finite b) => Table b c -> Table a b -> Table a c+composeTable tbc tab = tabulate $ index tbc . index tab++-- | 'traverse' a function whose argument is a finite enumerable type.+traverseRep+ :: forall x a b f+ . (Finite x, Applicative f)+ => (a -> f b) -> (x -> a) -> f (x -> b)+traverseRep f = fmap index . traverse f . tabulate @(Table _)++-- | Memoize a function by using a 'Vec' as a lazy lookup table.+--+-- Given a function whose argument is a 'Finite' type, return a new function+-- that looks up the argument in a table constructed by applying the original+-- function to every possible value. Since 'Vec' stores its elements boxed,+-- none of the applications of @f@ in the table are forced until they're forced+-- by calling the memoized function and forcing the result.+memoize :: Finite a => (a -> b) -> a -> b+memoize = index . tabulate @(Table _)++-- | An 'Iso' between two 'Representable' Functors with the same 'Rep' type.+retabulated+ :: (Representable f, Representable g, Rep f ~ Rep g)+ => Iso (f a) (f b) (g a) (g b)+retabulated = from tabulated . tabulated++-- | Infix 'index', monomorphized.+(!) :: Finite a => Table a b -> a -> b+(!) = index++-- | Lens on a single element.+ix :: Finite a => a -> Lens' (Table a b) b+ix a = a `seq` lens (! a) (\(Table vec) b -> Table (vec & V.ix (toFin a) .~ b))++-- | Monomorphized 'tabulate'. Can be useful for type ambiguity reasons.+mkTable :: Finite a => (a -> b) -> Table a b+mkTable = tabulate++-- | Convenience function for building any 'Representable' as if by 'traverse'.+--+-- > tabulateA f = sequenceA (tabulate f) = traverse f (tabulate id)+tabulateA+ :: (Traversable t, Representable t, Applicative f)+ => (Rep t -> f b) -> f (t b)+tabulateA = sequenceA . tabulate
+ test/Main.hs view
@@ -0,0 +1,77 @@+-- 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 DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}++module Main where++import Data.Int (Int8)+import Data.Word (Word8)+import GHC.Generics (Generic)++import Data.Wrapped (Wrapped(..))+import Test.Framework (defaultMain, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck ((===), Property, forAll, arbitraryBoundedEnum)++import Data.Fin.Int (Fin)+import Data.Finite++data EnumType = Cyan | Magenta | Yellow | Key+ deriving (Eq, Show, Generic)+ deriving Finite via Wrapped Generic EnumType+ deriving (Bounded, Enum) via Wrapped Finite EnumType++data ProductType = ProductType EnumType EnumType+ deriving (Eq, Show, Generic)+ deriving Finite via Wrapped Generic ProductType+ deriving (Bounded, Enum) via Wrapped Finite ProductType++data SumType = SumL EnumType | SumR EnumType+ deriving (Eq, Show, Generic)+ deriving Finite via Wrapped Generic SumType+ deriving (Bounded, Enum) via Wrapped Finite SumType++testToFrom :: forall a. (Eq a, Show a, Finite a, Bounded a, Enum a) => Property+testToFrom = forAll arbitraryBoundedEnum $ \x -> x === fromFin (toFin @a x)++testFromTo :: forall a. Finite a => Fin (Cardinality a) -> Property+testFromTo x = x === toFin (fromFin @a x)++main :: IO ()+main = defaultMain+ [ testGroup "toFin . fromFin" $+ [ testProperty "EnumType" $ testFromTo @EnumType+ , testProperty "ProductType" $ testFromTo @ProductType+ , testProperty "SumType" $ testFromTo @SumType+ , testProperty "Int8" $ testFromTo @Int8+ , testProperty "Word8" $ testFromTo @Word8+ , testProperty "()" $ testFromTo @()+ ]++ , testGroup "fromFin . toFin" $+ [ testProperty "EnumType" $ testToFrom @EnumType+ , testProperty "ProductType" $ testToFrom @ProductType+ , testProperty "SumType" $ testToFrom @SumType+ , testProperty "Int8" $ testToFrom @Int8+ , testProperty "Word8" $ testToFrom @Word8+ , testProperty "()" $ testToFrom @()+ ]+ ]