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/finite-table.cabal b/finite-table.cabal new file mode 100644 --- /dev/null +++ b/finite-table.cabal @@ -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 +maintainer: Andrew Pritchard +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 diff --git a/src/Data/Finite.hs b/src/Data/Finite.hs new file mode 100644 --- /dev/null +++ b/src/Data/Finite.hs @@ -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)) diff --git a/src/Data/Finite/Table.hs b/src/Data/Finite/Table.hs new file mode 100644 --- /dev/null +++ b/src/Data/Finite/Table.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 @() + ] + ]