From b35696741c58d6aeed20111d89468dcc8327fbfb Mon Sep 17 00:00:00 2001 From: Ilias Tsitsimpis Date: Fri, 6 Oct 2023 21:12:28 +0300 Subject: [PATCH 1/1] Import haskell-parameterized-utils_2.1.7.0.orig.tar.gz [dgit import orig haskell-parameterized-utils_2.1.7.0.orig.tar.gz] --- Changelog.md | 285 ++++ LICENSE | 30 + parameterized-utils.cabal | 151 ++ src/Data/Parameterized.hs | 19 + src/Data/Parameterized/All.hs | 69 + src/Data/Parameterized/Axiom.hs | 48 + src/Data/Parameterized/BoolRepr.hs | 118 ++ src/Data/Parameterized/Classes.hs | 368 +++++ src/Data/Parameterized/ClassesC.hs | 54 + src/Data/Parameterized/Compose.hs | 39 + src/Data/Parameterized/Context.hs | 560 +++++++ src/Data/Parameterized/Context/Safe.hs | 1081 ++++++++++++++ src/Data/Parameterized/Context/Unsafe.hs | 1304 +++++++++++++++++ src/Data/Parameterized/Ctx.hs | 109 ++ src/Data/Parameterized/Ctx/Proofs.hs | 24 + src/Data/Parameterized/DataKind.hs | 54 + src/Data/Parameterized/DecidableEq.hs | 41 + src/Data/Parameterized/Fin.hs | 148 ++ src/Data/Parameterized/FinMap.hs | 79 + src/Data/Parameterized/FinMap/Safe.hs | 248 ++++ src/Data/Parameterized/FinMap/Unsafe.hs | 249 ++++ src/Data/Parameterized/HashTable.hs | 99 ++ src/Data/Parameterized/List.hs | 426 ++++++ src/Data/Parameterized/Map.hs | 718 +++++++++ src/Data/Parameterized/NatRepr.hs | 650 ++++++++ src/Data/Parameterized/NatRepr/Internal.hs | 100 ++ src/Data/Parameterized/Nonce.hs | 167 +++ src/Data/Parameterized/Nonce/Transformers.hs | 72 + src/Data/Parameterized/Nonce/Unsafe.hs | 96 ++ src/Data/Parameterized/Pair.hs | 53 + src/Data/Parameterized/Peano.hs | 498 +++++++ src/Data/Parameterized/Some.hs | 73 + src/Data/Parameterized/SymbolRepr.hs | 125 ++ src/Data/Parameterized/TH/GADT.hs | 785 ++++++++++ src/Data/Parameterized/TraversableF.hs | 191 +++ src/Data/Parameterized/TraversableFC.hs | 208 +++ .../Parameterized/TraversableFC/WithIndex.hs | 175 +++ src/Data/Parameterized/Utils/BinTree.hs | 368 +++++ src/Data/Parameterized/Utils/Endian.hs | 16 + src/Data/Parameterized/Vector.hs | 754 ++++++++++ src/Data/Parameterized/WithRepr.hs | 116 ++ test/Test/Context.hs | 615 ++++++++ test/Test/Fin.hs | 87 ++ test/Test/FinMap.hs | 393 +++++ test/Test/List.hs | 29 + test/Test/NatRepr.hs | 27 + test/Test/Some.hs | 74 + test/Test/SymbolRepr.hs | 33 + test/Test/TH.hs | 83 ++ test/Test/Vector.hs | 338 +++++ test/UnitTest.hs | 36 + 51 files changed, 12483 insertions(+) create mode 100644 Changelog.md create mode 100644 LICENSE create mode 100644 parameterized-utils.cabal create mode 100644 src/Data/Parameterized.hs create mode 100644 src/Data/Parameterized/All.hs create mode 100644 src/Data/Parameterized/Axiom.hs create mode 100644 src/Data/Parameterized/BoolRepr.hs create mode 100644 src/Data/Parameterized/Classes.hs create mode 100644 src/Data/Parameterized/ClassesC.hs create mode 100644 src/Data/Parameterized/Compose.hs create mode 100644 src/Data/Parameterized/Context.hs create mode 100644 src/Data/Parameterized/Context/Safe.hs create mode 100644 src/Data/Parameterized/Context/Unsafe.hs create mode 100644 src/Data/Parameterized/Ctx.hs create mode 100644 src/Data/Parameterized/Ctx/Proofs.hs create mode 100644 src/Data/Parameterized/DataKind.hs create mode 100644 src/Data/Parameterized/DecidableEq.hs create mode 100644 src/Data/Parameterized/Fin.hs create mode 100644 src/Data/Parameterized/FinMap.hs create mode 100644 src/Data/Parameterized/FinMap/Safe.hs create mode 100644 src/Data/Parameterized/FinMap/Unsafe.hs create mode 100644 src/Data/Parameterized/HashTable.hs create mode 100644 src/Data/Parameterized/List.hs create mode 100644 src/Data/Parameterized/Map.hs create mode 100644 src/Data/Parameterized/NatRepr.hs create mode 100644 src/Data/Parameterized/NatRepr/Internal.hs create mode 100644 src/Data/Parameterized/Nonce.hs create mode 100644 src/Data/Parameterized/Nonce/Transformers.hs create mode 100644 src/Data/Parameterized/Nonce/Unsafe.hs create mode 100644 src/Data/Parameterized/Pair.hs create mode 100644 src/Data/Parameterized/Peano.hs create mode 100644 src/Data/Parameterized/Some.hs create mode 100644 src/Data/Parameterized/SymbolRepr.hs create mode 100644 src/Data/Parameterized/TH/GADT.hs create mode 100644 src/Data/Parameterized/TraversableF.hs create mode 100644 src/Data/Parameterized/TraversableFC.hs create mode 100644 src/Data/Parameterized/TraversableFC/WithIndex.hs create mode 100644 src/Data/Parameterized/Utils/BinTree.hs create mode 100644 src/Data/Parameterized/Utils/Endian.hs create mode 100644 src/Data/Parameterized/Vector.hs create mode 100644 src/Data/Parameterized/WithRepr.hs create mode 100644 test/Test/Context.hs create mode 100644 test/Test/Fin.hs create mode 100644 test/Test/FinMap.hs create mode 100644 test/Test/List.hs create mode 100644 test/Test/NatRepr.hs create mode 100644 test/Test/Some.hs create mode 100644 test/Test/SymbolRepr.hs create mode 100644 test/Test/TH.hs create mode 100644 test/Test/Vector.hs create mode 100644 test/UnitTest.hs diff --git a/Changelog.md b/Changelog.md new file mode 100644 index 0000000..a084f26 --- /dev/null +++ b/Changelog.md @@ -0,0 +1,285 @@ +# Changelog for the `parameterized-utils` package + +## 2.1.7.0 -- *2023 Jul 28* + + * Add support for GHC 9.6. + * Allow building with `base-orphans-0.9.*`, `mtl-2.3.*`, and + `th-abstraction-0.5.*`. + * Mark `Data.Parameterized.ClassesC` as `Trustworthy` to restore the ability + to build `parameterized-utils` with versions of `lens` older than `lens-5`. + +## 2.1.6.0 -- *2022 Dec 18* + + * Added `FinMap`: an integer map with a statically-known maximum size. + * Added `someLens` to `Some` to create a parameterized lens. + * Allow building with `hashable-1.4.*`. Because `hashable-1.4.0.0` adds an + `Eq` superclass to `Hashable`, some instances of `Hashable` in + `parameterized-utils` now require additional `TestEquality` constraints, as + the corresponding `Eq` instances for these data types also require + `TestEquality` constraints. + * Bump constraints to allow: vector-0.13, lens-5.2, tasty-hedgehog-1.3.0.0--1.4.0.0, GHC-9.4 + +## 2.1.5.0 -- *2022 Mar 08* + + * Add support for GHC 9.2. Drop support for GHC 8.4 (or earlier). + * Add a `Data.Parameterized.NatRepr.leqZero :: LeqProof 0 n` function. + Starting with GHC 9.2, GHC is no longer able to conclude that + `forall (n :: Nat). 0 <= n` due to changes in how the `(<=)` type family + works. As a result, this fact must be asserted as an axiom, which the + `leqZero` function accomplishes. + +## 2.1.4.0 -- *2021 Oct 1* + + * Added the `ifoldLM` and `fromSomeList`, `fromListWith`, and + `fromListWithM` functions to the `List` module. + * Fix the description of the laws of the `OrdF` class. + * Fix a bug in which `Data.Parameterized.Vector.{join,joinWith,joinWithM}` + and `Data.Parameterized.NatRepr.plusAssoc` could crash at runtime if + compiled without optimizations. + * Add a `Data.Parameterized.Axiom` module providing `unsafeAxiom` and + `unsafeHeteroAxiom`, which can construct proofs of equality between types + that GHC isn't able to prove on its own. These functions are unsafe if used + improperly, so the responsibility is on the programmer to ensure that these + functions are used appropriately. + * Various `Proxy` enhancements: adds `KnownRepr`, `EqF`, and `ShowF` instances. + * Adds `mkRepr` and `mkKnownReprs` Template Haskell functions. + * Added `TraversableFC.WithIndex` module which provides the + `FunctorFCWithIndex`, `FoldableFCWithIndex`, and + `TraversableFCWithIndex` classes, with instances defined for + `Assignment` and `List`. + * Added `indicesUpTo`, and `indicesOf` as well as `iterateN` and `iterateNM` + for the `Vector` module. + * Added `Data.Parameterized.Fin` for finite types which can be used + to index into a `Vector n` or other size-indexed datatypes. + + +## 2.1.3.0 -- *2021 Mar 23* + + * Add support for GHC 9. + * In the `Context` module: + * Added `sizeToNatRepr` function for converting a `Context` `Size`. + * Added `unzip` to unzip an `Assignment` of `Product(Pair)` into a + separate `Assignment` for each element of the `Pair` (the + inverse of the `zipWith Pair` operation). + * Added `flattenAssignment` to convert an `Assignment` of + `Assignment` into an `Assignment` of `CtxFlatten`. Also adds + `flattenSize` to combine the sizes of each context into the size + of the corresponding `CtxFlatten`. + * In the `Vector` module: + * Added `fromAssignment` and `toAssignment` to allow conversions + between `Assignment` and `Vector`. + * Added `unsnoc`, `unfoldr`, `unfoldrM`, `unfoldrWithIndex`, and + `unfoldrWithIndexM` functions. + * Various haddock documentation updates and corrections. + * Updated the Cabal specification to Cabal-version 2.2. + + +## 2.1.2 -- *2021 Jan 25* + + * Added `SomeSym` and `viewSomeSym` for existentially hidden Symbol + values which retain the `KnownSymbol` constraint. + * Added `leftIndex` and `rightIndex` for re-casting indexes of the + individual parts of an Assignment into the concatenated + Assignment. + * Additional tests and updated documentation. + +## 2.1.1 -- *2020 Jul 30* + + * Added `drop` and `appendEmbeddingLeft` functions to the `Context` module. + * Fixes/updates to haddock documentation (fixing Issue #74). + * Allow tasty v1.3 for testing (thanks to felixonmars) + +## 2.1.0 -- *2020 May 08* + + * Added `plusAssoc` to the `NatRepr` module to produce `+` associativity evidence. + * Changed the `HashTable` module to use the Basic instead of the Cuckoo + implementation strategy. + * Added explicit kind parameters to various definitions to support + GHC 8.10's adoption of [proposal 103](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0103-no-kind-vars.rst). + This is a modification to the type signatures which _may impact_ + backward-compatibility and require updates, especially for any + uses of + [`TypeApplications`](https://gitlab.haskell.org/ghc/ghc/-/wikis/type-application). + * No longer verifying support for GHC 8.2 or earlier. + * Updated the minimum cabal version to 1.10 and specify the + default-language as Haskell2010. + +## 2.0.2 -- *2020 Feb 10* + + * Add the `dropPrefix` operation to `Context` which splits an `Assignment`. + * Add `intersectWithKeyMaybe` and `mergeWithKey` to `Map`. + * Add `mapAt`, `mapAtM`, and `replace` to `Vector`. + * Add dependency on `base-orphans` to handle the `TestEquality` + instance for `Compose`; needed for GHC 8.10. + * Bump upper limit of `lens` dependency to allow 4.19. + +## 2.0.1 -- *2019 Nov 06* + + * Documentation updates + * Dependency constraint updates: constraints, lens, th-abstraction, hashable, hashtables, and vector. + * Now supports building under GHC 8.8.1. + * Added monadic folds and more traversals: + * lazy folds: `foldlMF`, `foldrMF`, `foldlMFC`, `foldrMFC` + * strict folds: `foldlMF'`, `foldrMF'`, `foldlMFC'`, `foldrMFC'` + * `forF`, `forF_` + * `forFC`, `forFC_` + * `lengthF` + * Added monadic folds, ascending or descending list conversions to `Parameterized.Map`: + * Added monadic folds: `foldlMWithKey`, `foldrMWithKey` + * Added ascending or descending list conversions: `toAscList` (equivalent to existing `toList`) and `toDescList`. + * Added `findWithDefault` to lookup a key or return a default value. + * Added `traverseMaybeWithKey`. + * Fixes traverse to do an in-order rather than a pre-order traversal. + * Added the `Data.Parameterized.All` module for universal quantification/parametricity over a type variable. + * Additions to `Data.Parameterized.Context`: + * Added `IndexView` type and `viewIndex` functions. + * Added `addDiff` function to explicitly describe the (flipped) binary operator for the `Diff` instance of the `Category` class from `Control.Category`. + * Added `traverseWithIndex_` + * Added `Data.Parameterized.DataKind` providing the `PairRepr` type with associated `fst` and `snd` functions. + * Added `TypeAp` to `Data.Parameterized.Classes` + * Added `runSTNonceGenerator` to `Data.Parameterized.Nonce` for a *global* ST generator. + * Added a `Hashable` instance for list `Index l x` types. + * Changes in GADT TH code generator: + * Added `structuralHashWithSalt` to + * Fixed off by one bug in output + * Fixed generation and constructor generation to use constructor type arguments, not type parameters. + * The `Some` type is now an instance of `FunctorF`, `FoldableF`, and `TraversableF`. + * Adjusted `structuralShowsPrec` precedence to match GHC derived `Show` instances. + * The `Data.Parameterized.Nonce.Unsafe` module is now deprecated: clients should switch to `Data.Parameterized.Nonce`. + +## 2.0 -- *2019 Apr 03* + + * Drop support for GHC versions prior to GHC 8.2 + * Various Haddock and module updates. + * Data.Parameterized.Classes + - Added function: `ordFCompose` + - Added `OrdF` instance for `Compose` + * Data.Parameterized.ClassesC + - Marked as `Safe` haskell via pragma + - Added `OrdC` instance for `Some` + * Data.Parameterized.Compose + - Update `testEqualityComposeBare` to be more kind-polymorphic. + - Marked as `Safe` haskell via pragma + * Data.Parameterized.Context + - Added `diffIsAppend` function to extract the contextual + difference between two `Context`s (as a `Diff`) as an `IsAppend` + (new) data value if the left is a sub-context of the right. + * Data.Parameterized.NatRepr + - Change runtime representation from `Int` to `Natural` + - Add function `intValue` to recover an `Int` from a `NatRepr`. + - Add constructor function `mkNatRepr` to construct a `NatRepr` + from a `Natural`. + - Removed awkward backdoor for directly creating `NatRepr` values; + the single needed internal usage is now handled internally. + * Data.Parameterized.Peano + - Newly added module. + - Defines a type `Peano` and `PeanoRepr` for representing a + type-level natural at runtime. + - The runtime representation of `PeanoRepr` is `Word64` + - Has both safe and unsafe implementations. + * Data.Parameterized.WithRepr + - Newly added module. + - This module declares a class `IsRepr` with a single method + `withRepr` that can be used to derive a 'KnownRepr' constraint + from an explicit 'Repr' argument. Clients of this method need + only create an empty instance. The default implementation + suffices. + +## 1.0.8 -- *2019 Feb 01* + + * Data.Parameterized.Map + - Fixed `MapF` functions `filter` and `filterWithKey` + - Added `MapF` function: `mapWithKey` + * Data.Parameterized.NatRepr + - Un-deprecate `withKnownNat` + * Data.Parameterized.Context + - Updated some haddock documentation (esp. `CtxEmbedding` data structure). + * Data.Parameterized.Nonce + - Fixed `newIONonceGenerator` haddock documentation (IO monad, not ST monad). + - Added `countNoncesGenerated` for profiling Nonce usage. + * Data.Parameterized.TraversableF + - Added `FunctorF`, `FoldableF`, and `TraversableF` instances for + `Compose` from Data.Functor.Compose + * Data.Parameterized.ClassesC + - Newly added module. + - Declares `TestEqualityC` and `OrdC` classes for working with + types that have kind `(k -> *) -> *` for any `k`. + * Data.Parameterized.Compose + - Newly added module. + - Orphan instance and `testEqualityComposeBare` function for + working with Data.Functor.Compose. + * Data.Parameterized.TestEquality + - Newly added module. + - Utilities for working with Data.Type.TestEquality. + +## 1.0.7 -- *2018 Nov 17* + + * Data.Parameterized.Map + - Added `MapF` functions: + - `filter` + - `filterWithKey` + +## 1.0.6 -- *2018 Nov 19* + + * Add support for GHC 8.6. + * Data.Parameterized.Map + - Added functions: + - `foldlWithKey` and `foldlWithKey'` (strict) + - `foldrWithKey` and `foldrWithKey'` (strict) + - `mapMaybeWithKey` + +## 1.0.5 -- *2018 Sep 04* + + * Data.Parameterized.Context + - Add function: `take`, `appendEmbedding`, `appendDiff` + - Diff is type role nominal in both parameters. + +## 1.0.4 -- *2018 Aug 29* + + * Data.Parameterized.Context + - Add `traverseAndCollect`. Allows traversal of an Assignment in + order from left to right, collecting the results of a visitor + function monoidically. + * Data.Parameterized.DecidableEq + - Newly added module. The `DecidableEq` class represents + decideable equality on a type family as a superclass of + `TestEquality`, where the latter cannot provide evidence of + non-equality. + * Data.Parameterized.NatRepr + - Add `DecidableEq` instance for NatRepr. + - Add functions: + - `decideLeq` + - `isZeroOrGT1` + - `lessThanIrreflexive` + - `lessThanAsymmetric` + - `natRecStrong` -- recursor with strong induction + - `natRecBounded` -- bounded recursor + - `natFromZero` + * Data.Parameterized.Vector + - Add construction functions: `singleton`, `cons`, `snoc`, `generate`, and `generateM` + - Add functions: `splitWithA` (applicative `splitWith`). + +## 1.0.3 -- *2018 Aug 24* + + * Move `lemmaMul` from Vector to NatRepr. + * Add stricter role annotations: + - `NatRepr` is nominal. + - `Vector` is nominal in the first parameter and representational in the second. + * Data.Parameterized.NatRepr + - Provide a backdoor for directly creating `NatRepr` values. Use carefully. + * Data.Parameterized.Vector + - Add Show and Eq instances + - Add functions: `joinWithM`, `reverse` + +## 1.0.2 -- *2018 Aug 23* + + * Allow function passed to `traverseF_`, `traverseFC_`, and + `forMFC_` to return a value instead of null (`()`). + * Data.Parameterized.Vector + - Newly added module. A fixed-size vector of typed elements. + * Data.Parameterized.Utils.Endian + - Newly added module. Used in Vector. + +## 1.0.1 -- *2018 Aug 13* + + Baseline for changelog tracking. diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..38f956b --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013-2022 Galois Inc. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + + * Neither the name of Galois, Inc. nor the names of its contributors + may be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git a/parameterized-utils.cabal b/parameterized-utils.cabal new file mode 100644 index 0000000..7fc1f54 --- /dev/null +++ b/parameterized-utils.cabal @@ -0,0 +1,151 @@ +Cabal-version: 2.2 +Name: parameterized-utils +Version: 2.1.7.0 +Author: Galois Inc. +Maintainer: kquick@galois.com +stability: stable +Build-type: Simple +Copyright: ©2016-2022 Galois, Inc. +License: BSD-3-Clause +License-file: LICENSE +category: Data Structures, Dependent Types +Synopsis: Classes and data structures for working with data-kind indexed types +Description: + This package contains collection classes and type representations + used for working with values that have a single parameter. It's + intended for things like expression libraries where one wishes + to leverage the Haskell type-checker to improve type-safety by encoding + the object language type system into data kinds. +extra-source-files: Changelog.md +homepage: https://github.com/GaloisInc/parameterized-utils +bug-reports: https://github.com/GaloisInc/parameterized-utils/issues +tested-with: GHC==8.6.5, GHC==8.8.4, GHC==8.10.7, GHC==9.0.2, GHC==9.2.1, GHC==9.4.3 + +-- Many (but not all, sadly) uses of unsafe operations are +-- controlled by this compile flag. When this flag is set +-- to False, alternate implementations are used to avoid +-- Unsafe.Coerce and Data.Coerce. These alternate implementations +-- impose a significant performance hit. +flag unsafe-operations + Description: Use unsafe operations (e.g. coercions) to improve performance + Default: True + +source-repository head + type: git + location: https://github.com/GaloisInc/parameterized-utils + + +common bldflags + ghc-options: -Wall + -Wcompat + -Wpartial-fields + -Wincomplete-uni-patterns + -Werror=incomplete-patterns + -Werror=missing-methods + -Werror=overlapping-patterns + -Wno-trustworthy-safe + -fhide-source-paths + default-language: Haskell2010 + + +library + import: bldflags + build-depends: base >= 4.10 && < 5 + , base-orphans >=0.8.2 && <0.10 + , th-abstraction >=0.4.2 && <0.6 + , constraints >=0.10 && <0.14 + , containers + , deepseq + , ghc-prim + , hashable >=1.2 && <1.5 + , hashtables >=1.2 && <1.4 + , indexed-traversable + , lens >=4.16 && <5.3 + , mtl + , profunctors >=5.6 && < 5.7 + , template-haskell + , text + , vector >=0.12 && < 0.14 + + hs-source-dirs: src + + exposed-modules: + Data.Parameterized + Data.Parameterized.All + Data.Parameterized.Axiom + Data.Parameterized.BoolRepr + Data.Parameterized.Classes + Data.Parameterized.ClassesC + Data.Parameterized.Compose + Data.Parameterized.Context + Data.Parameterized.Context.Safe + Data.Parameterized.Context.Unsafe + Data.Parameterized.Ctx + Data.Parameterized.Ctx.Proofs + Data.Parameterized.DataKind + Data.Parameterized.DecidableEq + Data.Parameterized.Fin + Data.Parameterized.FinMap + Data.Parameterized.FinMap.Safe + Data.Parameterized.FinMap.Unsafe + Data.Parameterized.HashTable + Data.Parameterized.List + Data.Parameterized.Map + Data.Parameterized.NatRepr + Data.Parameterized.Nonce + Data.Parameterized.Nonce.Transformers + Data.Parameterized.Nonce.Unsafe + Data.Parameterized.Pair + Data.Parameterized.Peano + Data.Parameterized.Some + Data.Parameterized.SymbolRepr + Data.Parameterized.TH.GADT + Data.Parameterized.TraversableF + Data.Parameterized.TraversableFC + Data.Parameterized.TraversableFC.WithIndex + Data.Parameterized.Utils.BinTree + Data.Parameterized.Utils.Endian + Data.Parameterized.Vector + Data.Parameterized.WithRepr + + other-modules: + Data.Parameterized.NatRepr.Internal + + if flag(unsafe-operations) + cpp-options: -DUNSAFE_OPS + + +test-suite parameterizedTests + import: bldflags + type: exitcode-stdio-1.0 + hs-source-dirs: test + + main-is: UnitTest.hs + other-modules: + Test.Context + Test.Fin + Test.FinMap + Test.List + Test.NatRepr + Test.Some + Test.SymbolRepr + Test.TH + Test.Vector + + build-depends: base + , hashable + , hashtables + , hedgehog + , indexed-traversable + , ghc-prim + , lens + , mtl + , parameterized-utils + , tasty >= 1.2 && < 1.5 + , tasty-ant-xml == 1.1.* + , tasty-hunit >= 0.9 && < 0.11 + , tasty-hedgehog >= 1.2 + + if impl(ghc >= 8.6) + build-depends: + hedgehog-classes diff --git a/src/Data/Parameterized.hs b/src/Data/Parameterized.hs new file mode 100644 index 0000000..cc01fe2 --- /dev/null +++ b/src/Data/Parameterized.hs @@ -0,0 +1,19 @@ +module Data.Parameterized +( module Data.Parameterized.Classes +, module Data.Parameterized.Ctx +, module Data.Parameterized.TraversableF +, module Data.Parameterized.TraversableFC +, module Data.Parameterized.NatRepr +, module Data.Parameterized.Pair +, module Data.Parameterized.Some +, module Data.Parameterized.SymbolRepr +) where + +import Data.Parameterized.Classes +import Data.Parameterized.Ctx +import Data.Parameterized.TraversableF +import Data.Parameterized.TraversableFC +import Data.Parameterized.NatRepr +import Data.Parameterized.Pair +import Data.Parameterized.Some +import Data.Parameterized.SymbolRepr diff --git a/src/Data/Parameterized/All.hs b/src/Data/Parameterized/All.hs new file mode 100644 index 0000000..0c585f0 --- /dev/null +++ b/src/Data/Parameterized/All.hs @@ -0,0 +1,69 @@ +------------------------------------------------------------------------ +-- | +-- Module : Data.Parameterized.All +-- Copyright : (c) Galois, Inc 2019 +-- Maintainer : Langston Barrett +-- Description : Universal quantification, in a datatype +-- +-- This module provides 'All', a GADT that encodes universal +-- quantification/parametricity over a type variable. +-- +-- The following is an example of a situation in which it might be necessary +-- to use 'All' (though it is a bit contrived): +-- +-- @ +-- {-# LANGUAGE FlexibleInstances #-} +-- {-# LANGUAGE GADTs #-} +-- +-- data F (x :: Bool) where +-- FTrue :: F 'True +-- FFalse :: F 'False +-- FIndeterminate :: F b +-- +-- data Value = +-- VAllF (All F) +-- +-- class Valuable a where +-- valuation :: a -> Value +-- +-- instance Valuable (All F) where +-- valuation = VAllF +-- +-- val1 :: Value +-- val1 = valuation (All FIndeterminate) +-- @ +-- +-- For a less contrived but more complex example, see this blog +-- post: http://comonad.com/reader/2008/rotten-bananas/ +------------------------------------------------------------------------ + +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} + +module Data.Parameterized.All + ( All(..) + , allConst + ) where + +import Data.Functor.Const (Const(..)) +import Data.Kind + +import Data.Parameterized.Classes +import Data.Parameterized.TraversableF + +newtype All (f :: k -> Type) = All { getAll :: forall x. f x } + +instance FunctorF All where + fmapF f (All a) = All (f a) + +instance FoldableF All where + foldMapF toMonoid (All x) = toMonoid x + +instance ShowF f => Show (All f) where + show (All fa) = showF fa + +instance EqF f => Eq (All f) where + (All x) == (All y) = eqF x y + +allConst :: a -> All (Const a) +allConst a = All (Const a) diff --git a/src/Data/Parameterized/Axiom.hs b/src/Data/Parameterized/Axiom.hs new file mode 100644 index 0000000..569b7a7 --- /dev/null +++ b/src/Data/Parameterized/Axiom.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE Unsafe #-} +{-| +Copyright : (c) Galois, Inc 2014-2021 + +An unsafe module that provides functionality for constructing equality proofs +that GHC cannot prove on its own. +-} +module Data.Parameterized.Axiom + ( unsafeAxiom, unsafeHeteroAxiom + ) where + +import Data.Type.Equality +import Unsafe.Coerce (unsafeCoerce) + +-- | Assert a proof of equality between two types. +-- This is unsafe if used improperly, so use this with caution! +unsafeAxiom :: forall a b. a :~: b +unsafeAxiom = unsafeCoerce (Refl @a) +{-# NOINLINE unsafeAxiom #-} -- Note [Mark unsafe axioms as NOINLINE] + +-- | Assert a proof of heterogeneous equality between two types. +-- This is unsafe if used improperly, so use this with caution! +unsafeHeteroAxiom :: forall a b. a :~~: b +unsafeHeteroAxiom = unsafeCoerce (HRefl @a) +{-# NOINLINE unsafeHeteroAxiom #-} -- Note [Mark unsafe axioms as NOINLINE] + +{- +Note [Mark unsafe axioms as NOINLINE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We take care to mark definitions that use unsafeCoerce to construct proofs +(e.g., unsafeAxiom = unsafeCoerce Refl) as NOINLINE. There are at least two +good reasons to do so: + +1. On old version of GHC (prior to 9.0), GHC was liable to optimize + `unsafeCoerce` too aggressively, leading to unsound runtime behavior. + See https://gitlab.haskell.org/ghc/ghc/-/issues/16893 for an example. + +2. If GHC too heavily optimizes a program which cases on a proof of equality, + where the equality is between two types that can be determined not to be + equal statically (e.g., case (unsafeAxiom :: Bool :~: Int) of ...), then the + optimized program can crash at runtime. See + https://gitlab.haskell.org/ghc/ghc/-/issues/16310. Using NOINLINE is + sufficient to work around the issue. +-} diff --git a/src/Data/Parameterized/BoolRepr.hs b/src/Data/Parameterized/BoolRepr.hs new file mode 100644 index 0000000..1534c34 --- /dev/null +++ b/src/Data/Parameterized/BoolRepr.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Data.Parameterized.BoolRepr + ( module Data.Type.Bool + , BoolRepr(..) + , ifRepr, notRepr, (%&&), (%||) + , KnownBool + + , someBool + + -- * Re-exports + , TestEquality(..) + , (:~:)(..) + , Data.Parameterized.Some.Some + ) +where + +import Data.Parameterized.Classes +import Data.Parameterized.DecidableEq +import Data.Parameterized.Some + +import Data.Type.Bool + +-- | A Boolean flag +data BoolRepr (b :: Bool) where + FalseRepr :: BoolRepr 'False + TrueRepr :: BoolRepr 'True + +-- | conditional +ifRepr :: BoolRepr a -> BoolRepr b -> BoolRepr c -> BoolRepr (If a b c) +ifRepr TrueRepr b _ = b +ifRepr FalseRepr _ c = c + +-- | negation +notRepr :: BoolRepr b -> BoolRepr (Not b) +notRepr TrueRepr = FalseRepr +notRepr FalseRepr = TrueRepr + +-- | Conjunction +(%&&) :: BoolRepr a -> BoolRepr b -> BoolRepr (a && b) +FalseRepr %&& _ = FalseRepr +TrueRepr %&& a = a +infixr 3 %&& + +-- | Disjunction +(%||) :: BoolRepr a -> BoolRepr b -> BoolRepr (a || b) +FalseRepr %|| a = a +TrueRepr %|| _ = TrueRepr +infixr 2 %|| + +instance Hashable (BoolRepr n) where + hashWithSalt i TrueRepr = hashWithSalt i True + hashWithSalt i FalseRepr = hashWithSalt i False + + +instance Eq (BoolRepr m) where + _ == _ = True + +instance TestEquality BoolRepr where + testEquality TrueRepr TrueRepr = Just Refl + testEquality FalseRepr FalseRepr = Just Refl + testEquality _ _ = Nothing + +instance DecidableEq BoolRepr where + decEq TrueRepr TrueRepr = Left Refl + decEq FalseRepr FalseRepr = Left Refl + decEq TrueRepr FalseRepr = Right $ \case {} + decEq FalseRepr TrueRepr = Right $ \case {} + +instance OrdF BoolRepr where + compareF TrueRepr TrueRepr = EQF + compareF FalseRepr FalseRepr = EQF + compareF TrueRepr FalseRepr = GTF + compareF FalseRepr TrueRepr = LTF + +instance PolyEq (BoolRepr m) (BoolRepr n) where + polyEqF x y = (\Refl -> Refl) <$> testEquality x y + +instance Show (BoolRepr m) where + show FalseRepr = "FalseRepr" + show TrueRepr = "TrueRepr" + +instance ShowF BoolRepr + +instance HashableF BoolRepr where + hashWithSaltF = hashWithSalt + +---------------------------------------------------------- +-- * Implicit runtime booleans + +type KnownBool = KnownRepr BoolRepr + +instance KnownRepr BoolRepr 'True where + knownRepr = TrueRepr +instance KnownRepr BoolRepr 'False where + knownRepr = FalseRepr + +someBool :: Bool -> Some BoolRepr +someBool True = Some TrueRepr +someBool False = Some FalseRepr diff --git a/src/Data/Parameterized/Classes.hs b/src/Data/Parameterized/Classes.hs new file mode 100644 index 0000000..df1072a --- /dev/null +++ b/src/Data/Parameterized/Classes.hs @@ -0,0 +1,368 @@ +{-| +Description : Classes for working with type of kind @k -> *@ +Copyright : (c) Galois, Inc 2014-2019 +Maintainer : Joe Hendrix + +This module declares classes for working with types with the kind +@k -> *@ for any kind @k@. These are generalizations of the +"Data.Functor.Classes" types as they work with any kind @k@, and are +not restricted to '*'. +-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Data.Parameterized.Classes + ( -- * Equality exports + Equality.TestEquality(..) + , (Equality.:~:)(..) + , EqF(..) + , PolyEq(..) + -- * Ordering generalization + , OrdF(..) + , lexCompareF + , OrderingF(..) + , joinOrderingF + , orderingF_refl + , toOrdering + , fromOrdering + , ordFCompose + -- * Typeclass generalizations + , ShowF(..) + , showsF + , HashableF(..) + , CoercibleF(..) + -- * Type function application constructor + , TypeAp(..) + -- * Optics generalizations + , IndexF + , IxValueF + , IxedF(..) + , IxedF'(..) + , AtF(..) + -- * KnownRepr + , KnownRepr(..) + -- * Re-exports + , Data.Hashable.Hashable(..) + , Data.Maybe.isJust + ) where + +import Data.Functor.Const +import Data.Functor.Compose (Compose(..)) +import Data.Kind +import Data.Hashable +import Data.Maybe (isJust) +import Data.Proxy +import Data.Type.Equality as Equality + +import Data.Parameterized.Compose () + +-- We define these type alias here to avoid importing Control.Lens +-- modules, as this apparently causes problems with the safe Hasekll +-- checking. +type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s +type Traversal' s a = forall f. Applicative f => (a -> f a) -> s -> f s + +------------------------------------------------------------------------ +-- CoercibleF + +-- | An instance of 'CoercibleF' gives a way to coerce between +-- all the types of a family. We generally use this to witness +-- the fact that the type parameter to @rtp@ is a phantom type +-- by giving an implementation in terms of Data.Coerce.coerce. +class CoercibleF (rtp :: k -> Type) where + coerceF :: rtp a -> rtp b + +instance CoercibleF (Const x) where + coerceF (Const x) = Const x + +------------------------------------------------------------------------ +-- EqF + +-- | @EqF@ provides a method @eqF@ for testing whether two parameterized +-- types are equal. +-- +-- Unlike 'TestEquality', this only works when the type arguments are +-- the same, and does not provide a proof that the types have the same +-- type when they are equal. Thus this can be implemented over +-- parameterized types that are unable to provide evidence that their +-- type arguments are equal. +class EqF (f :: k -> Type) where + eqF :: f a -> f a -> Bool + +instance Eq a => EqF (Const a) where + eqF (Const x) (Const y) = x == y + +instance EqF Proxy where + eqF _ _ = True + +------------------------------------------------------------------------ +-- PolyEq + +-- | A polymorphic equality operator that generalizes 'TestEquality'. +class PolyEq u v where + polyEqF :: u -> v -> Maybe (u :~: v) + + polyEq :: u -> v -> Bool + polyEq x y = isJust (polyEqF x y) + +------------------------------------------------------------------------ +-- Ordering + +-- | Ordering over two distinct types with a proof they are equal. +data OrderingF x y where + LTF :: OrderingF x y + EQF :: OrderingF x x + GTF :: OrderingF x y + +orderingF_refl :: OrderingF x y -> Maybe (x :~: y) +orderingF_refl o = + case o of + LTF -> Nothing + EQF -> Just Refl + GTF -> Nothing + +-- | Convert 'OrderingF' to standard ordering. +toOrdering :: OrderingF x y -> Ordering +toOrdering LTF = LT +toOrdering EQF = EQ +toOrdering GTF = GT + +-- | Convert standard ordering to 'OrderingF'. +fromOrdering :: Ordering -> OrderingF x x +fromOrdering LT = LTF +fromOrdering EQ = EQF +fromOrdering GT = GTF + +-- | @joinOrderingF x y@ first compares on @x@, returning an +-- equivalent value if it is not `EQF`. If it is `EQF`, it returns @y@. +joinOrderingF :: forall j k (a :: j) (b :: j) (c :: k) (d :: k) + . OrderingF a b + -> (a ~ b => OrderingF c d) + -> OrderingF c d +joinOrderingF EQF y = y +joinOrderingF LTF _ = LTF +joinOrderingF GTF _ = GTF + +------------------------------------------------------------------------ +-- OrdF + +-- | The `OrdF` class is a total ordering over parameterized types so +-- that types with different parameters can be compared. +-- +-- Instances of `OrdF` are expected to satisfy the following laws: +-- +-- [__Transitivity__]: if @leqF x y && leqF y z@ = 'True', then @leqF x = z@ = @True@ +-- [__Reflexivity__]: @leqF x x@ = @True@ +-- [__Antisymmetry__]: if @leqF x y && leqF y x@ = 'True', then @testEquality x y@ = @Just Refl@ +-- +-- Note that the following operator interactions are expected to hold: +-- +-- * @geqF x y@ iff @leqF y x@ +-- * @ltF x y@ iff @leqF x y && testEquality x y = Nothing@ +-- * @gtF x y@ iff @ltF y x@ +-- * @ltF x y@ iff @compareF x y == LTF@ +-- * @gtF x y@ iff @compareF x y == GTF@ +-- * @isJust (testEquality x y)@ iff @compareF x y == EQF@ +-- +-- Furthermore, when @x@ and @y@ both have type @(k tp)@, we expect: +-- +-- * @toOrdering (compareF x y)@ equals @compare x y@ when @Ord (k tp)@ has an instance. +-- * @isJust (testEquality x y)@ equals @x == y@ when @Eq (k tp)@ has an instance. +-- +-- Minimal complete definition: either 'compareF' or 'leqF'. +-- Using 'compareF' can be more efficient for complex types. +class TestEquality ktp => OrdF (ktp :: k -> Type) where + {-# MINIMAL compareF | leqF #-} + + compareF :: ktp x -> ktp y -> OrderingF x y + compareF x y = + case testEquality x y of + Just Refl -> EQF + Nothing | leqF x y -> LTF + | otherwise -> GTF + + leqF :: ktp x -> ktp y -> Bool + leqF x y = + case compareF x y of + LTF -> True + EQF -> True + GTF -> False + + ltF :: ktp x -> ktp y -> Bool + ltF x y = + case compareF x y of + LTF -> True + EQF -> False + GTF -> False + + geqF :: ktp x -> ktp y -> Bool + geqF x y = + case compareF x y of + LTF -> False + EQF -> True + GTF -> True + + gtF :: ktp x -> ktp y -> Bool + gtF x y = + case compareF x y of + LTF -> False + EQF -> False + GTF -> True + +-- | Compare two values, and if they are equal compare the next values, +-- otherwise return LTF or GTF +lexCompareF :: forall j k (f :: j -> Type) (a :: j) (b :: j) (c :: k) (d :: k) + . OrdF f + => f a + -> f b + -> (a ~ b => OrderingF c d) + -> OrderingF c d +lexCompareF x y = joinOrderingF (compareF x y) + +-- | If the \"outer\" functor has an 'OrdF' instance, then one can be generated +-- for the \"inner\" functor. The type-level evidence of equality is deduced +-- via generativity of @g@, e.g. the inference @g x ~ g y@ implies @x ~ y@. +ordFCompose :: forall k l (f :: k -> Type) (g :: l -> k) x y. + (forall w z. f w -> f z -> OrderingF w z) + -> Compose f g x + -> Compose f g y + -> OrderingF x y +ordFCompose ordF_ (Compose x) (Compose y) = + case ordF_ x y of + LTF -> LTF + GTF -> GTF + EQF -> EQF + +instance OrdF f => OrdF (Compose f g) where + compareF x y = ordFCompose compareF x y + +------------------------------------------------------------------------ +-- ShowF + +-- | A parameterized type that can be shown on all instances. +-- +-- To implement @'ShowF' g@, one should implement an instance @'Show' +-- (g tp)@ for all argument types @tp@, then write an empty instance +-- @instance 'ShowF' g@. +class ShowF (f :: k -> Type) where + -- | Provides a show instance for each type. + withShow :: p f -> q tp -> (Show (f tp) => a) -> a + + default withShow :: Show (f tp) => p f -> q tp -> (Show (f tp) => a) -> a + withShow _ _ x = x + + showF :: forall tp . f tp -> String + showF x = withShow (Proxy :: Proxy f) (Proxy :: Proxy tp) (show x) + + -- | Like 'showsPrec', the precedence argument is /one more/ than the + -- precedence of the enclosing context. + showsPrecF :: forall tp. Int -> f tp -> String -> String + showsPrecF p x = withShow (Proxy :: Proxy f) (Proxy :: Proxy tp) (showsPrec p x) + +showsF :: ShowF f => f tp -> String -> String +showsF x = showsPrecF 0 x + +instance Show x => ShowF (Const x) + +instance ShowF Proxy + +------------------------------------------------------------------------ +-- IxedF + +type family IndexF (m :: Type) :: k -> Type +type family IxValueF (m :: Type) :: k -> Type + +-- | Parameterized generalization of the lens @Ixed@ class. +class IxedF k m where + -- | Given an index into a container, build a traversal that visits + -- the given element in the container, if it exists. + ixF :: forall (x :: k). IndexF m x -> Traversal' m (IxValueF m x) + +-- | Parameterized generalization of the lens @Ixed@ class, +-- but with the guarantee that indexes exist in the container. +class IxedF k m => IxedF' k m where + -- | Given an index into a container, build a lens that + -- points into the given element in the container. + ixF' :: forall (x :: k). IndexF m x -> Lens' m (IxValueF m x) + +------------------------------------------------------------------------ +-- AtF + +-- | Parameterized generalization of the lens @At@ class. +class IxedF k m => AtF k m where + -- | Given an index into a container, build a lens that points into + -- the given position in the container, whether or not it currently + -- exists. Setting values of @atF@ to a @Just@ value will insert + -- the value if it does not already exist. + atF :: forall (x :: k). IndexF m x -> Lens' m (Maybe (IxValueF m x)) + +------------------------------------------------------------------------ +-- HashableF + +-- | A default salt used in the implementation of 'hash'. +defaultSalt :: Int +#if WORD_SIZE_IN_BITS == 64 +defaultSalt = 0xdc36d1615b7400a4 +#else +defaultSalt = 0x087fc72c +#endif +{-# INLINE defaultSalt #-} + +-- | A parameterized type that is hashable on all instances. +class HashableF (f :: k -> Type) where + hashWithSaltF :: Int -> f tp -> Int + + -- | Hash with default salt. + hashF :: f tp -> Int + hashF = hashWithSaltF defaultSalt + +instance Hashable a => HashableF (Const a) where + hashWithSaltF s (Const x) = hashWithSalt s x + +------------------------------------------------------------------------ +-- TypeAp + +-- | Captures the value obtained from applying a type to a function so +-- that we can use parameterized class instance to provide unparameterized +-- instances for specific types. +-- +-- This is the same as `Ap` from @Control.Applicative@, but we introduce +-- our own new type to avoid orphan instances. +newtype TypeAp (f :: k -> Type) (tp :: k) = TypeAp (f tp) + +instance TestEquality f => Eq (TypeAp f tp) where + TypeAp x == TypeAp y = isJust $ testEquality x y + +instance OrdF f => Ord (TypeAp f tp) where + compare (TypeAp x) (TypeAp y) = toOrdering (compareF x y) + +instance ShowF f => Show (TypeAp f tp) where + showsPrec p (TypeAp x) = showsPrecF p x + +instance (HashableF f, TestEquality f) => Hashable (TypeAp f tp) where + hashWithSalt s (TypeAp x) = hashWithSaltF s x + +------------------------------------------------------------------------ +-- KnownRepr + +-- | This class is parameterized by a kind @k@ (typically a data +-- kind), a type constructor @f@ of kind @k -> *@ (typically a GADT of +-- singleton types indexed by @k@), and an index parameter @ctx@ of +-- kind @k@. +class KnownRepr (f :: k -> Type) (ctx :: k) where + knownRepr :: f ctx + +instance KnownRepr Proxy ctx where + knownRepr = Proxy diff --git a/src/Data/Parameterized/ClassesC.hs b/src/Data/Parameterized/ClassesC.hs new file mode 100644 index 0000000..aa39793 --- /dev/null +++ b/src/Data/Parameterized/ClassesC.hs @@ -0,0 +1,54 @@ +{-| +Description : Classes for working with type of kind @(k -> *) -> *@ +Copyright : (c) Galois, Inc 2014-2019 +Maintainer : Langston Barrett + +This module declares classes for working with types with the kind +@(k -> *) -> *@ for any kind @k@. + +These classes generally require type-level evidence for operations +on their subterms, but don't actually provide it themselves (because +their types are not themselves parameterized, unlike those in +"Data.Parameterized.TraversableFC"). + +Note that there is still some ambiguity around naming conventions, see +. +-} + +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Parameterized.ClassesC + ( TestEqualityC(..) + , OrdC(..) + ) where + +import Data.Type.Equality ((:~:)(..)) +import Data.Kind +import Data.Maybe (isJust) +import Data.Parameterized.Classes (OrderingF, toOrdering) +import Data.Parameterized.Some (Some(..)) + +class TestEqualityC (t :: (k -> Type) -> Type) where + testEqualityC :: (forall x y. f x -> f y -> Maybe (x :~: y)) + -> t f + -> t f + -> Bool + +class TestEqualityC t => OrdC (t :: (k -> Type) -> Type) where + compareC :: (forall x y. f x -> g y -> OrderingF x y) + -> t f + -> t g + -> Ordering + +-- | This instance demonstrates where the above class is useful: namely, in +-- types with existential quantification. +instance TestEqualityC Some where + testEqualityC subterms (Some someone) (Some something) = + isJust (subterms someone something) + +instance OrdC Some where + compareC subterms (Some someone) (Some something) = + toOrdering (subterms someone something) diff --git a/src/Data/Parameterized/Compose.hs b/src/Data/Parameterized/Compose.hs new file mode 100644 index 0000000..bfc9bcd --- /dev/null +++ b/src/Data/Parameterized/Compose.hs @@ -0,0 +1,39 @@ +{-| +Description : utilities for working with "Data.Functor.Compose" +Copyright : (c) Galois, Inc 2014-2019 +Maintainer : Langston Barrett + +Utilities for working with "Data.Functor.Compose". + +NB: This module contains an orphan instance. It will be included in GHC 8.10, +see https://gitlab.haskell.org/ghc/ghc/merge_requests/273 and also +https://github.com/haskell-compat/base-orphans/issues/49. +-} + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE Safe #-} +module Data.Parameterized.Compose + ( testEqualityComposeBare + ) where + +import Data.Functor.Compose +import Data.Kind +import Data.Orphans () -- For the TestEquality (Compose f g) instance +import Data.Type.Equality + +-- | The deduction (via generativity) that if @g x :~: g y@ then @x :~: y@. +-- +-- See https://gitlab.haskell.org/ghc/ghc/merge_requests/273. +testEqualityComposeBare :: forall k l (f :: k -> Type) (g :: l -> k) x y. + (forall w z. f w -> f z -> Maybe (w :~: z)) + -> Compose f g x + -> Compose f g y + -> Maybe (x :~: y) +testEqualityComposeBare testEquality_ (Compose x) (Compose y) = + case (testEquality_ x y :: Maybe (g x :~: g y)) of + Just Refl -> Just (Refl :: x :~: y) + Nothing -> Nothing diff --git a/src/Data/Parameterized/Context.hs b/src/Data/Parameterized/Context.hs new file mode 100644 index 0000000..fb6ca61 --- /dev/null +++ b/src/Data/Parameterized/Context.hs @@ -0,0 +1,560 @@ +{-| +Module : Data.Parameterized.Context +Copyright : (c) Galois, Inc 2014-2019 +Maintainer : Joe Hendrix + +This module reexports either "Data.Parameterized.Context.Safe" +or "Data.Parameterized.Context.Unsafe" depending on the +the unsafe-operations compile-time flag. + +It also defines some utility typeclasses for transforming +between curried and uncurried versions of functions over contexts. + +The 'Assignment' type is isomorphic to the 'Data.Parameterized.List' +type, except 'Assignment's construct lists from the right-hand side, +and instead of using type-level @'[]@-style lists, an 'Assignment' is +indexed by a type-level 'Data.Parameterized.Context.Ctx'. The +implementation of 'Assignment's is also more efficent than +'Data.Parameterized.List' for lists of many elements, as it uses a +balanced binary tree representation rather than a linear-time +list. For a motivating example, see 'Data.Parameterized.List'. + +-} + +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE ViewPatterns #-} +module Data.Parameterized.Context + ( +#ifdef UNSAFE_OPS + module Data.Parameterized.Context.Unsafe +#else + module Data.Parameterized.Context.Safe +#endif + , singleton + , toVector + , pattern (:>) + , pattern Empty + , decompose + , Data.Parameterized.Context.null + , Data.Parameterized.Context.init + , Data.Parameterized.Context.last + , Data.Parameterized.Context.view + , Data.Parameterized.Context.take + , Data.Parameterized.Context.drop + , forIndexM + , generateSome + , generateSomeM + , fromList + , traverseAndCollect + , traverseWithIndex_ + , dropPrefix + , unzip + , flattenAssignment + , flattenSize + + -- * Context extension and embedding utilities + , CtxEmbedding(..) + , ExtendContext(..) + , ExtendContext'(..) + , ApplyEmbedding(..) + , ApplyEmbedding'(..) + , identityEmbedding + , extendEmbeddingRightDiff + , extendEmbeddingRight + , extendEmbeddingBoth + , appendEmbedding + , appendEmbeddingLeft + , ctxeSize + , ctxeAssignment + + -- * Static indexing and lenses for assignments + , Idx + , field + , natIndex + , natIndexProxy + -- * Currying and uncurrying for assignments + , CurryAssignment + , CurryAssignmentClass(..) + -- * Size and Index values + , size1, size2, size3, size4, size5, size6 + , i1of2, i2of2 + , i1of3, i2of3, i3of3 + , i1of4, i2of4, i3of4, i4of4 + , i1of5, i2of5, i3of5, i4of5, i5of5 + , i1of6, i2of6, i3of6, i4of6, i5of6, i6of6 + ) where + +import Prelude hiding (unzip) + +import qualified Control.Applicative as App (liftA2) +import Control.Lens hiding (Index, (:>), Empty) +import Data.Functor (void) +import Data.Functor.Product (Product(Pair)) +import Data.Kind +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as MV +import GHC.TypeLits (Nat, type (-)) + +import Data.Parameterized.Classes +import Data.Parameterized.Some +import Data.Parameterized.TraversableFC + +#ifdef UNSAFE_OPS +import Data.Parameterized.Context.Unsafe +#else +import Data.Parameterized.Context.Safe +#endif + + +-- | Create a single element context. +singleton :: f tp -> Assignment f (EmptyCtx ::> tp) +singleton = (empty :>) + +-- |'forIndexM sz f' calls 'f' on indices '[0..sz-1]'. +forIndexM :: forall ctx m + . Applicative m + => Size ctx + -> (forall tp . Index ctx tp -> m ()) + -> m () +forIndexM sz f = forIndexRange 0 sz (\i r -> f i *> r) (pure ()) + +-- | Generate an assignment with some context type that is not known. +generateSome :: forall f + . Int + -> (Int -> Some f) + -> Some (Assignment f) +generateSome n f = go n + where go :: Int -> Some (Assignment f) + go 0 = Some empty + go i = (\(Some a) (Some e) -> Some (a `extend` e)) (go (i-1)) (f (i-1)) + +-- | Generate an assignment with some context type that is not known. +generateSomeM :: forall m f + . Applicative m + => Int + -> (Int -> m (Some f)) + -> m (Some (Assignment f)) +generateSomeM n f = go n + where go :: Int -> m (Some (Assignment f)) + go 0 = pure (Some empty) + go i = (\(Some a) (Some e) -> Some (a `extend` e)) <$> go (i-1) <*> f (i-1) + +-- | Convert the assignment to a vector. +toVector :: Assignment f tps -> (forall tp . f tp -> e) -> V.Vector e +toVector a f = V.create $ do + vm <- MV.new (sizeInt (size a)) + forIndexM (size a) $ \i -> do + MV.write vm (indexVal i) (f (a ! i)) + return vm +{-# INLINABLE toVector #-} + +-- | Utility function for testing if @xs@ is an assignment with +-- `prefix` as a prefix, and computing the tail of xs +-- not in the prefix, if so. +dropPrefix :: forall f xs prefix a. + TestEquality f => + Assignment f xs {- ^ Assignment to split -} -> + Assignment f prefix {- ^ Expected prefix -} -> + a {- ^ error continuation -} -> + (forall addl. (xs ~ (prefix <+> addl)) => Assignment f addl -> a) + {- ^ success continuation -} -> + a +dropPrefix xs0 prefix err = go xs0 (sizeInt (size xs0)) + where + sz_prefix = sizeInt (size prefix) + + go :: forall ys. + Assignment f ys -> + Int -> + (forall addl. (ys ~ (prefix <+> addl)) => Assignment f addl -> a) -> + a + + go (xs' :> z) sz_x success | sz_x > sz_prefix = + go xs' (sz_x-1) (\zs -> success (zs :> z)) + + go xs _ success = + case testEquality xs prefix of + Just Refl -> success Empty + Nothing -> err + +-- | Unzip an assignment of pairs into a pair of assignments. +-- +-- This is the inverse of @'zipWith' 'Pair'@. +unzip :: Assignment (Product f g) ctx -> (Assignment f ctx, Assignment g ctx) +unzip fgs = + case viewAssign fgs of + AssignEmpty -> (empty, empty) + AssignExtend rest (Pair f g) -> + let (fs, gs) = unzip rest + in (extend fs f, extend gs g) + +-- | Flattens a nested assignment over a context of contexts @ctxs :: Ctx (Ctx +-- a)@ into a flat assignment over the flattened context @CtxFlatten ctxs@. +flattenAssignment :: + Assignment (Assignment f) ctxs -> + Assignment f (CtxFlatten ctxs) +flattenAssignment ctxs = + case viewAssign ctxs of + AssignEmpty -> empty + AssignExtend ctxs' ctx -> flattenAssignment ctxs' <++> ctx + +-- | Given the size of each context in @ctxs@, returns the size of @CtxFlatten +-- ctxs@. You can obtain the former from any nested assignment @Assignment +-- (Assignment f) ctxs@, by calling @fmapFC size@. +flattenSize :: + Assignment Size ctxs -> + Size (CtxFlatten ctxs) +flattenSize a = + case viewAssign a of + AssignEmpty -> zeroSize + AssignExtend b s -> addSize (flattenSize b) s + + +-------------------------------------------------------------------------------- +-- Patterns + +-- | Pattern synonym for the empty assignment +pattern Empty :: () => ctx ~ EmptyCtx => Assignment f ctx +pattern Empty <- (viewAssign -> AssignEmpty) + where Empty = empty + +infixl :> + +-- | Pattern synonym for extending an assignment on the right +pattern (:>) :: () => ctx' ~ (ctx ::> tp) => Assignment f ctx -> f tp -> Assignment f ctx' +pattern (:>) a v <- (viewAssign -> AssignExtend a v) + where a :> v = extend a v + +{-# COMPLETE (:>), Empty :: Assignment #-} + +-------------------------------------------------------------------------------- +-- Views + +-- | Return true if assignment is empty. +null :: Assignment f ctx -> Bool +null a = + case viewAssign a of + AssignEmpty -> True + AssignExtend{} -> False + +decompose :: Assignment f (ctx ::> tp) -> (Assignment f ctx, f tp) +decompose x = (Data.Parameterized.Context.init x, Data.Parameterized.Context.last x) + +-- | Return assignment with all but the last block. +init :: Assignment f (ctx '::> tp) -> Assignment f ctx +init x = + case viewAssign x of + AssignExtend t _ -> t + +-- | Return the last element in the assignment. +last :: Assignment f (ctx '::> tp) -> f tp +last x = + case viewAssign x of + AssignExtend _ e -> e + +{-# DEPRECATED view "Use viewAssign or the Empty and :> patterns instead." #-} +-- | View an assignment as either empty or an assignment with one appended. +view :: forall f ctx . Assignment f ctx -> AssignView f ctx +view = viewAssign + +-- | Return the prefix of an appended 'Assignment' +take :: forall f ctx ctx'. Size ctx -> Size ctx' -> Assignment f (ctx <+> ctx') -> Assignment f ctx +take sz sz' asgn = + let diff = appendDiff sz' in + generate sz (\i -> asgn ! extendIndex' diff i) + +-- | Return the suffix of an appended 'Assignment' +drop :: forall f ctx ctx'. Size ctx -> Size ctx' -> Assignment f (ctx <+> ctx') -> Assignment f ctx' +drop sz sz' asgn = generate sz' (\i -> asgn ! extendIndexAppendLeft sz sz' i) + +-------------------------------------------------------------------------------- +-- Context embedding. + +-- | This datastructure contains a proof that the first context is +-- embeddable in the second. This is useful if we want to add extend +-- an existing term under a larger context. + +data CtxEmbedding (ctx :: Ctx k) (ctx' :: Ctx k) + = CtxEmbedding { _ctxeSize :: Size ctx' + , _ctxeAssignment :: Assignment (Index ctx') ctx + } + +-- Alternate encoding? +-- data CtxEmbedding ctx ctx' where +-- EIdentity :: CtxEmbedding ctx ctx +-- ExtendBoth :: CtxEmbedding ctx ctx' -> CtxEmbedding (ctx ::> tp) (ctx' ::> tp) +-- ExtendOne :: CtxEmbedding ctx ctx' -> CtxEmbedding ctx (ctx' ::> tp) + +ctxeSize :: Simple Lens (CtxEmbedding ctx ctx') (Size ctx') +ctxeSize = lens _ctxeSize (\s v -> s { _ctxeSize = v }) + +ctxeAssignment :: Lens (CtxEmbedding ctx1 ctx') (CtxEmbedding ctx2 ctx') + (Assignment (Index ctx') ctx1) (Assignment (Index ctx') ctx2) +ctxeAssignment = lens _ctxeAssignment (\s v -> s { _ctxeAssignment = v }) + +class ApplyEmbedding (f :: Ctx k -> Type) where + applyEmbedding :: CtxEmbedding ctx ctx' -> f ctx -> f ctx' + +class ApplyEmbedding' (f :: Ctx k -> k' -> Type) where + applyEmbedding' :: CtxEmbedding ctx ctx' -> f ctx v -> f ctx' v + +class ExtendContext (f :: Ctx k -> Type) where + extendContext :: Diff ctx ctx' -> f ctx -> f ctx' + +class ExtendContext' (f :: Ctx k -> k' -> Type) where + extendContext' :: Diff ctx ctx' -> f ctx v -> f ctx' v + +instance ApplyEmbedding' Index where + applyEmbedding' ctxe idx = (ctxe ^. ctxeAssignment) ! idx + +instance ExtendContext' Index where + extendContext' = extendIndex' + +-- -- This is the inefficient way of doing things. A better way is to +-- -- just have a map between indices. +-- applyEmbedding :: CtxEmbedding ctx ctx' +-- -> Index ctx tp -> Index ctx' tp +-- applyEmbedding ctxe idx = (ctxe ^. ctxeAssignment) ! idx + +identityEmbedding :: Size ctx -> CtxEmbedding ctx ctx +identityEmbedding sz = CtxEmbedding sz (generate sz id) + +-- emptyEmbedding :: CtxEmbedding EmptyCtx EmptyCtx +-- emptyEmbedding = identityEmbedding knownSize + +extendEmbeddingRightDiff :: forall ctx ctx' ctx''. + Diff ctx' ctx'' + -> CtxEmbedding ctx ctx' + -> CtxEmbedding ctx ctx'' +extendEmbeddingRightDiff diff (CtxEmbedding sz' assgn) = CtxEmbedding (extSize sz' diff) updated + where + updated :: Assignment (Index ctx'') ctx + updated = fmapFC (extendIndex' diff) assgn + +extendEmbeddingRight :: CtxEmbedding ctx ctx' -> CtxEmbedding ctx (ctx' ::> tp) +extendEmbeddingRight = extendEmbeddingRightDiff knownDiff + +-- | Prove that the prefix of an appended context is embeddable in it +appendEmbedding :: Size ctx -> Size ctx' -> CtxEmbedding ctx (ctx <+> ctx') +appendEmbedding sz sz' = CtxEmbedding (addSize sz sz') (generate sz (extendIndex' diff)) + where + diff = appendDiff sz' + +-- | Prove that the suffix of an appended context is embeddable in it +appendEmbeddingLeft :: Size ctx -> Size ctx' -> CtxEmbedding ctx' (ctx <+> ctx') +appendEmbeddingLeft sz sz' = CtxEmbedding (addSize sz sz') (generate sz' (extendIndexAppendLeft sz sz')) + +extendEmbeddingBoth :: forall ctx ctx' tp. CtxEmbedding ctx ctx' -> CtxEmbedding (ctx ::> tp) (ctx' ::> tp) +extendEmbeddingBoth ctxe = updated & ctxeAssignment %~ flip extend (nextIndex (ctxe ^. ctxeSize)) + where + updated :: CtxEmbedding ctx (ctx' ::> tp) + updated = extendEmbeddingRight ctxe + +-------------------------------------------------------------------------------- +-- Static indexing based on type-level naturals + +-- | Get a lens for an position in an 'Assignment' by zero-based, left-to-right position. +-- The position must be specified using @TypeApplications@ for the @n@ parameter. +field :: forall n ctx f r. Idx n ctx r => Lens' (Assignment f ctx) (f r) +field = ixF' (natIndex @n) + +-- | Constraint synonym used for getting an 'Index' into a 'Ctx'. +-- @n@ is the zero-based, left-counted index into the list of types +-- @ctx@ which has the type @r@. +type Idx n ctx r = (ValidIx n ctx, Idx' (FromLeft ctx n) ctx r) + +-- | Compute an 'Index' value for a particular position in a 'Ctx'. The +-- @TypeApplications@ extension will be needed to disambiguate the choice +-- of the type @n@. +natIndex :: forall n ctx r. Idx n ctx r => Index ctx r +natIndex = natIndex' @_ @(FromLeft ctx n) + +-- | This version of 'natIndex' is suitable for use without the @TypeApplications@ +-- extension. +natIndexProxy :: forall n ctx r proxy. Idx n ctx r => proxy n -> Index ctx r +natIndexProxy _ = natIndex @n + +------------------------------------------------------------------------ +-- Implementation +------------------------------------------------------------------------ + +-- | Class for computing 'Index' values for positions in a 'Ctx'. +class KnownContext ctx => Idx' (n :: Nat) (ctx :: Ctx k) (r :: k) | n ctx -> r where + natIndex' :: Index ctx r + +-- | Base-case +instance KnownContext xs => Idx' 0 (xs '::> x) x where + natIndex' = lastIndex knownSize + +-- | Inductive-step +instance {-# Overlaps #-} (KnownContext xs, Idx' (n-1) xs r) => + Idx' n (xs '::> x) r where + + natIndex' = skipIndex (natIndex' @_ @(n-1)) + + +-------------------------------------------------------------------------------- +-- * CurryAssignment + +-- | This type family is used to define currying\/uncurrying operations +-- on assignments. It is best understood by seeing its evaluation on +-- several examples: +-- +-- > CurryAssignment EmptyCtx f x = x +-- > CurryAssignment (EmptyCtx ::> a) f x = f a -> x +-- > CurryAssignment (EmptyCtx ::> a ::> b) f x = f a -> f b -> x +-- > CurryAssignment (EmptyCtx ::> a ::> b ::> c) f x = f a -> f b -> f c -> x +type family CurryAssignment (ctx :: Ctx k) (f :: k -> Type) (x :: Type) :: Type where + CurryAssignment EmptyCtx f x = x + CurryAssignment (ctx ::> a) f x = CurryAssignment ctx f (f a -> x) + +-- | This class implements two methods that witness the isomorphism between +-- curried and uncurried functions. +class CurryAssignmentClass (ctx :: Ctx k) where + + -- | Transform a function that accepts an assignment into one with a separate + -- variable for each element of the assignment. + curryAssignment :: (Assignment f ctx -> x) -> CurryAssignment ctx f x + + -- | Transform a curried function into one that accepts an assignment value. + uncurryAssignment :: CurryAssignment ctx f x -> (Assignment f ctx -> x) + +instance CurryAssignmentClass EmptyCtx where + curryAssignment k = k empty + uncurryAssignment k _ = k + +instance CurryAssignmentClass ctx => CurryAssignmentClass (ctx ::> a) where + curryAssignment k = curryAssignment (\asgn a -> k (asgn :> a)) + uncurryAssignment k asgn = + case viewAssign asgn of + AssignExtend asgn' x -> uncurryAssignment k asgn' x + +-- | Create an assignment from a list of values. +fromList :: [Some f] -> Some (Assignment f) +fromList = go empty + where go :: Assignment f ctx -> [Some f] -> Some (Assignment f) + go prev [] = Some prev + go prev (Some g:next) = (go $! prev `extend` g) next + + +newtype Collector m w a = Collector { runCollector :: m w } +instance Functor (Collector m w) where + fmap _ (Collector x) = Collector x +instance (Applicative m, Monoid w) => Applicative (Collector m w) where + pure _ = Collector (pure mempty) + Collector x <*> Collector y = Collector (App.liftA2 (<>) x y) + +-- | Visit each of the elements in an @Assignment@ in order +-- from left to right and collect the results using the provided @Monoid@. +traverseAndCollect :: + (Monoid w, Applicative m) => + (forall tp. Index ctx tp -> f tp -> m w) -> + Assignment f ctx -> + m w +traverseAndCollect f = + runCollector . traverseWithIndex (\i x -> Collector (f i x)) + +-- | Visit each of the elements in an @Assignment@ in order +-- from left to right, executing an action with each. +traverseWithIndex_ :: Applicative m + => (forall tp . Index ctx tp -> f tp -> m ()) + -> Assignment f ctx + -> m () +traverseWithIndex_ f = void . traverseAndCollect f + +-------------------------------------------------------------------------------- +-- Size and Index values + +size1 :: Size (EmptyCtx ::> a) +size1 = incSize zeroSize + +size2 :: Size (EmptyCtx ::> a ::> b) +size2 = incSize size1 + +size3 :: Size (EmptyCtx ::> a ::> b ::> c) +size3 = incSize size2 + +size4 :: Size (EmptyCtx ::> a ::> b ::> c ::> d) +size4 = incSize size3 + +size5 :: Size (EmptyCtx ::> a ::> b ::> c ::> d ::> e) +size5 = incSize size4 + +size6 :: Size (EmptyCtx ::> a ::> b ::> c ::> d ::> e ::> f) +size6 = incSize size5 + +i1of2 :: Index (EmptyCtx ::> a ::> b) a +i1of2 = skipIndex baseIndex + +i2of2 :: Index (EmptyCtx ::> a ::> b) b +i2of2 = nextIndex size1 + +i1of3 :: Index (EmptyCtx ::> a ::> b ::> c) a +i1of3 = skipIndex i1of2 + +i2of3 :: Index (EmptyCtx ::> a ::> b ::> c) b +i2of3 = skipIndex i2of2 + +i3of3 :: Index (EmptyCtx ::> a ::> b ::> c) c +i3of3 = nextIndex size2 + +i1of4 :: Index (EmptyCtx ::> a ::> b ::> c ::> d) a +i1of4 = skipIndex i1of3 + +i2of4 :: Index (EmptyCtx ::> a ::> b ::> c ::> d) b +i2of4 = skipIndex i2of3 + +i3of4 :: Index (EmptyCtx ::> a ::> b ::> c ::> d) c +i3of4 = skipIndex i3of3 + +i4of4 :: Index (EmptyCtx ::> a ::> b ::> c ::> d) d +i4of4 = nextIndex size3 + +i1of5 :: Index (EmptyCtx ::> a ::> b ::> c ::> d ::> e) a +i1of5 = skipIndex i1of4 + +i2of5 :: Index (EmptyCtx ::> a ::> b ::> c ::> d ::> e) b +i2of5 = skipIndex i2of4 + +i3of5 :: Index (EmptyCtx ::> a ::> b ::> c ::> d ::> e) c +i3of5 = skipIndex i3of4 + +i4of5 :: Index (EmptyCtx ::> a ::> b ::> c ::> d ::> e) d +i4of5 = skipIndex i4of4 + +i5of5 :: Index (EmptyCtx ::> a ::> b ::> c ::> d ::> e) e +i5of5 = nextIndex size4 + +i1of6 :: Index (EmptyCtx ::> a ::> b ::> c ::> d ::> e ::> f) a +i1of6 = skipIndex i1of5 + +i2of6 :: Index (EmptyCtx ::> a ::> b ::> c ::> d ::> e ::> f) b +i2of6 = skipIndex i2of5 + +i3of6 :: Index (EmptyCtx ::> a ::> b ::> c ::> d ::> e ::> f) c +i3of6 = skipIndex i3of5 + +i4of6 :: Index (EmptyCtx ::> a ::> b ::> c ::> d ::> e ::> f) d +i4of6 = skipIndex i4of5 + +i5of6 :: Index (EmptyCtx ::> a ::> b ::> c ::> d ::> e ::> f) e +i5of6 = skipIndex i5of5 + +i6of6 :: Index (EmptyCtx ::> a ::> b ::> c ::> d ::> e ::> f) f +i6of6 = nextIndex size5 diff --git a/src/Data/Parameterized/Context/Safe.hs b/src/Data/Parameterized/Context/Safe.hs new file mode 100644 index 0000000..25f6728 --- /dev/null +++ b/src/Data/Parameterized/Context/Safe.hs @@ -0,0 +1,1081 @@ +------------------------------------------------------------------------ +-- | +-- Module : Data.Parameterized.Context.Safe +-- Copyright : (c) Galois, Inc 2014-2015 +-- Maintainer : Joe Hendrix +-- +-- This module defines type contexts as a data-kind that consists of +-- a list of types. Indexes are defined with respect to these contexts. +-- In addition, finite dependent products (Assignments) are defined over +-- type contexts. The elements of an assignment can be accessed using +-- appropriately-typed indexes. +-- +-- This module is intended to export exactly the same API as module +-- "Data.Parameterized.Context.Unsafe", so that they can be used +-- interchangeably. +-- +-- This implementation is entirely typesafe, and provides a proof that +-- the signature implemented by this module is consistent. Contexts, +-- indexes, and assignments are represented naively by linear sequences. +-- +-- Compared to the implementation in "Data.Parameterized.Context.Unsafe", +-- this one suffers from the fact that the operation of extending an +-- the context of an index is /not/ a no-op. We therefore cannot use +-- 'Data.Coerce.coerce' to understand indexes in a new context without +-- actually breaking things. +-------------------------------------------------------------------------- +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE StandaloneDeriving #-} +#if __GLASGOW_HASKELL__ < 806 +{-# LANGUAGE TypeInType #-} +#endif +{-# OPTIONS_HADDOCK hide #-} +module Data.Parameterized.Context.Safe + ( module Data.Parameterized.Ctx + -- * Size + , Size + , sizeInt + , zeroSize + , incSize + , decSize + , extSize + , addSize + , SizeView(..) + , viewSize + , sizeToNatRepr + , KnownContext(..) + -- * Diff + , Diff + , noDiff + , addDiff + , extendRight + , appendDiff + , DiffView(..) + , viewDiff + , KnownDiff(..) + , IsAppend(..) + , diffIsAppend + -- * Indexing + , Index + , indexVal + , baseIndex + , skipIndex + , lastIndex + , nextIndex + , leftIndex + , rightIndex + , extendIndex + , extendIndex' + , extendIndexAppendLeft + , forIndex + , forIndexRange + , intIndex + , IndexView(..) + , viewIndex + -- * Assignments + , Assignment + , size + , Data.Parameterized.Context.Safe.replicate + , generate + , generateM + , empty + , extend + , adjust + , update + , adjustM + , AssignView(..) + , viewAssign + , (!) + , (!^) + , zipWith + , zipWithM + , (<++>) + , traverseWithIndex + ) where + +import qualified Control.Category as Cat +import Control.DeepSeq +import qualified Control.Lens as Lens +import Control.Monad.Identity (Identity(..)) +import Data.Hashable +import Data.List (intercalate) +import Data.Maybe (listToMaybe) +import Data.Type.Equality +import Prelude hiding (init, map, null, replicate, succ, zipWith) +import Data.Kind(Type) + +import Data.Parameterized.Classes +import Data.Parameterized.Ctx +import Data.Parameterized.NatRepr +import Data.Parameterized.Some +import Data.Parameterized.TraversableFC +import Data.Parameterized.TraversableFC.WithIndex + +------------------------------------------------------------------------ +-- Size + +-- | An indexed singleton type representing the size of a context. +data Size (ctx :: Ctx k) where + SizeZero :: Size 'EmptyCtx + SizeSucc :: !(Size ctx) -> Size (ctx '::> tp) + +-- | Renders as integer literal +instance Show (Size ctx) where + show = show . sizeInt + +instance ShowF Size + +-- | Convert a context size to an 'Int'. +sizeInt :: Size ctx -> Int +sizeInt SizeZero = 0 +sizeInt (SizeSucc sz) = (+1) $! sizeInt sz + +-- | The size of an empty context. +zeroSize :: Size 'EmptyCtx +zeroSize = SizeZero + +-- | Increment the size to the next value. +incSize :: Size ctx -> Size (ctx '::> tp) +incSize sz = SizeSucc sz + +decSize :: Size (ctx '::> tp) -> Size ctx +decSize (SizeSucc sz) = sz + +-- | The total size of two concatenated contexts. +addSize :: Size x -> Size y -> Size (x <+> y) +addSize sx SizeZero = sx +addSize sx (SizeSucc sy) = SizeSucc (addSize sx sy) + +-- | Allows interpreting a size. +data SizeView (ctx :: Ctx k) where + ZeroSize :: SizeView 'EmptyCtx + IncSize :: !(Size ctx) -> SizeView (ctx '::> tp) + +-- | View a size as either zero or a smaller size plus one. +viewSize :: Size ctx -> SizeView ctx +viewSize SizeZero = ZeroSize +viewSize (SizeSucc s) = IncSize s + +-- | Convert a 'Size' into a 'NatRepr'. +sizeToNatRepr :: Size items -> NatRepr (CtxSize items) +sizeToNatRepr sz = + case viewSize sz of + ZeroSize -> knownRepr + IncSize sz' -> + let oldRep = sizeToNatRepr sz' + in case plusComm (knownRepr :: NatRepr 1) oldRep of + Refl -> incNat oldRep + +------------------------------------------------------------------------ +-- Size + +-- | A context that can be determined statically at compiler time. +class KnownContext (ctx :: Ctx k) where + knownSize :: Size ctx + +instance KnownContext 'EmptyCtx where + knownSize = zeroSize + +instance KnownContext ctx => KnownContext (ctx '::> tp) where + knownSize = incSize knownSize + +------------------------------------------------------------------------ +-- Diff + +-- | Difference in number of elements between two contexts. +-- The first context must be a sub-context of the other. +data Diff (l :: Ctx k) (r :: Ctx k) where + DiffHere :: Diff ctx ctx + DiffThere :: Diff ctx1 ctx2 -> Diff ctx1 (ctx2 '::> tp) + +-- | The identity difference. Identity element of 'Category' instance. +noDiff :: Diff l l +noDiff = DiffHere + +-- | The addition of differences. Flipped binary operation +-- of 'Category' instance. +addDiff :: Diff a b -> Diff b c -> Diff a c +addDiff x DiffHere = x +addDiff x (DiffThere y) = DiffThere (addDiff x y) + +-- | Extend the difference to a sub-context of the right side. +extendRight :: Diff l r -> Diff l (r '::> tp) +extendRight diff = DiffThere diff + +appendDiff :: Size r -> Diff l (l <+> r) +appendDiff SizeZero = DiffHere +appendDiff (SizeSucc sz) = DiffThere (appendDiff sz) + +-- | Implemented with 'noDiff' and 'addDiff' +instance Cat.Category Diff where + id = DiffHere + d1 . d2 = addDiff d2 d1 + +-- | Extend the size by a given difference. +extSize :: Size l -> Diff l r -> Size r +extSize sz DiffHere = sz +extSize sz (DiffThere diff) = incSize (extSize sz diff) + +-- | Proof that @r = l <+> app@ for some @app@ +data IsAppend l r where + IsAppend :: Size app -> IsAppend l (l <+> app) + +-- | If @l@ is a sub-context of @r@ then extract out their "contextual +-- difference", i.e., the @app@ such that @r = l <+> app@ +diffIsAppend :: Diff l r -> IsAppend l r +diffIsAppend DiffHere = IsAppend zeroSize +diffIsAppend (DiffThere diff) = + case diffIsAppend diff of + IsAppend sz -> IsAppend (incSize sz) + +data DiffView a b where + NoDiff :: DiffView a a + ExtendRightDiff :: Diff a b -> DiffView a (b ::> r) + +viewDiff :: Diff a b -> DiffView a b +viewDiff DiffHere = NoDiff +viewDiff (DiffThere diff) = ExtendRightDiff diff + +------------------------------------------------------------------------ +-- KnownDiff + +-- | A difference that can be automatically inferred at compile time. +class KnownDiff (l :: Ctx k) (r :: Ctx k) where + knownDiff :: Diff l r + +instance KnownDiff l l where + knownDiff = noDiff + +instance KnownDiff l r => KnownDiff l (r '::> tp) where + knownDiff = extendRight knownDiff + +------------------------------------------------------------------------ +-- Index + +-- | An index is a reference to a position with a particular type in a +-- context. +data Index (ctx :: Ctx k) (tp :: k) where + IndexHere :: Size ctx -> Index (ctx '::> tp) tp + IndexThere :: !(Index ctx tp) -> Index (ctx '::> tp') tp + +-- | Convert an index to an 'Int', where the index of the left-most type in the context is 0. +indexVal :: Index ctx tp -> Int +indexVal (IndexHere sz) = sizeInt sz +indexVal (IndexThere idx) = indexVal idx + +instance Eq (Index ctx tp) where + idx1 == idx2 = isJust (testEquality idx1 idx2) + +instance TestEquality (Index ctx) where + testEquality (IndexHere _) (IndexHere _) = Just Refl + testEquality (IndexHere _) (IndexThere _) = Nothing + testEquality (IndexThere _) (IndexHere _) = Nothing + testEquality (IndexThere idx1) (IndexThere idx2) = + case testEquality idx1 idx2 of + Just Refl -> Just Refl + Nothing -> Nothing + +instance Ord (Index ctx tp) where + compare i j = toOrdering (compareF i j) + +instance OrdF (Index ctx) where + compareF (IndexHere _) (IndexHere _) = EQF + compareF (IndexThere _) (IndexHere _) = LTF + compareF (IndexHere _) (IndexThere _) = GTF + compareF (IndexThere idx1) (IndexThere idx2) = lexCompareF idx1 idx2 $ EQF + +-- | Index for first element in context. +baseIndex :: Index ('EmptyCtx '::> tp) tp +baseIndex = IndexHere SizeZero + +-- | Increase context while staying at same index. +skipIndex :: Index ctx x -> Index (ctx '::> y) x +skipIndex idx = IndexThere idx + +-- | Return the index of an element one past the size. +nextIndex :: Size ctx -> Index (ctx '::> tp) tp +nextIndex sz = IndexHere sz + +-- | Return the last index of a element. +lastIndex :: Size (ctx ::> tp) -> Index (ctx ::> tp) tp +lastIndex (SizeSucc s) = IndexHere s + +-- | Adapts an index in the left hand context of an append operation. +leftIndex :: Size r -> Index l tp -> Index (l <+> r) tp +leftIndex sr il = extendIndex' (appendDiff sr) il + +-- | Adapts an index in the right hand context of an append operation. +rightIndex :: Size l -> Size r -> Index r tp -> Index (l <+> r) tp +rightIndex sl sr ir = + case viewIndex sr ir of + IndexViewInit i -> skipIndex (rightIndex sl (decSize sr) i) + IndexViewLast s -> lastIndex (incSize (addSize sl s)) + +{-# INLINE extendIndex #-} +extendIndex :: KnownDiff l r => Index l tp -> Index r tp +extendIndex = extendIndex' knownDiff + +{-# INLINE extendIndex' #-} +-- | Compute an 'Index' into a context @r@ from an 'Index' into +-- a sub-context @l@ of @r@. +extendIndex' :: Diff l r -> Index l tp -> Index r tp +extendIndex' DiffHere idx = idx +extendIndex' (DiffThere diff) idx = IndexThere (extendIndex' diff idx) + +{-# INLINE extendIndexAppendLeft #-} +-- | Compute an 'Index' into an appended context from an 'Index' into +-- its suffix. +extendIndexAppendLeft :: Size l -> Size r -> Index r tp -> Index (l <+> r) tp +extendIndexAppendLeft sz sz' idx = case viewIndex sz' idx of + IndexViewLast _ -> lastIndex (addSize sz sz') + IndexViewInit idx' -> skipIndex (extendIndexAppendLeft sz (decSize sz') idx') + +-- | Given a size @n@, a function @f@, and an initial value @v0@, the +-- expression @forIndex n f v0@ calls @f@ on each index less than @n@ +-- starting from @0@ and @v0@, with the value @v@ obtained from the +-- last call. +forIndex :: forall ctx r + . Size ctx + -> (forall tp . r -> Index ctx tp -> r) + -> r + -> r +forIndex sz_top f = go id sz_top + where go :: forall ctx'. (forall tp. Index ctx' tp -> Index ctx tp) -> Size ctx' -> r -> r + go _ SizeZero = id + go g (SizeSucc sz) = \r -> go (\i -> g (IndexThere i)) sz $ f r (g (IndexHere sz)) + +data LDiff (l :: Ctx k) (r :: Ctx k) where + LDiffHere :: LDiff a a + LDiffThere :: !(LDiff (a::>x) b) -> LDiff a b + +ldiffIndex :: Index a tp -> LDiff a b -> Index b tp +ldiffIndex i LDiffHere = i +ldiffIndex i (LDiffThere d) = ldiffIndex (IndexThere i) d + +forIndexLDiff :: Size a + -> LDiff a b + -> (forall tp . Index b tp -> r -> r) + -> r + -> r +forIndexLDiff _ LDiffHere _ r = r +forIndexLDiff sz (LDiffThere d) f r = + forIndexLDiff (SizeSucc sz) d f (f (ldiffIndex (IndexHere sz) d) r) + +forIndexRangeImpl :: Int + -> Size a + -> LDiff a b + -> (forall tp . Index b tp -> r -> r) + -> r + -> r +forIndexRangeImpl 0 sz d f r = forIndexLDiff sz d f r +forIndexRangeImpl _ SizeZero _ _ r = r +forIndexRangeImpl i (SizeSucc sz) d f r = + forIndexRangeImpl (i-1) sz (LDiffThere d) f r + +-- | Given an index @i@, size @n@, a function @f@, and a value @v@, +-- the expression @forIndexRange i n f v@ is equivalent +-- to @v@ when @i >= sizeInt n@, and @f i (forIndexRange (i+1) n f v)@ +-- otherwise. +forIndexRange :: Int + -> Size ctx + -> (forall tp . Index ctx tp -> r -> r) + -> r + -> r +forIndexRange i sz f r = forIndexRangeImpl i sz LDiffHere f r + +indexList :: forall ctx. Size ctx -> [Some (Index ctx)] +indexList sz_top = go id [] sz_top + where go :: (forall tp. Index ctx' tp -> Index ctx tp) + -> [Some (Index ctx)] + -> Size ctx' + -> [Some (Index ctx)] + go _ ls SizeZero = ls + go g ls (SizeSucc sz) = go (\i -> g (IndexThere i)) (Some (g (IndexHere sz)) : ls) sz + +-- | Return index at given integer or nothing if integer is out of bounds. +intIndex :: Int -> Size ctx -> Maybe (Some (Index ctx)) +intIndex n sz = listToMaybe $ drop n $ indexList sz + +-- | Renders as integer literal +instance Show (Index ctx tp) where + show = show . indexVal + +instance ShowF (Index ctx) + +-- | View of indexes as pointing to the last element in the +-- index range or pointing to an earlier element in a smaller +-- range. +data IndexView ctx tp where + IndexViewLast :: Size ctx -> IndexView (ctx '::> t) t + IndexViewInit :: Index ctx t -> IndexView (ctx '::> u) t + +instance ShowF (IndexView ctx) +deriving instance Show (IndexView ctx tp) + +-- | Project an index +viewIndex :: Size ctx -> Index ctx tp -> IndexView ctx tp +viewIndex _ (IndexHere sz) = IndexViewLast sz +viewIndex _ (IndexThere i) = IndexViewInit i +-- NB: the unused size parameter is needed in the Unsafe module + +------------------------------------------------------------------------ +-- Assignment + +-- | An assignment is a sequence that maps each index with type 'tp' to +-- a value of type 'f tp'. +data Assignment (f :: k -> Type) (ctx :: Ctx k) where + AssignmentEmpty :: Assignment f EmptyCtx + AssignmentExtend :: Assignment f ctx -> f tp -> Assignment f (ctx ::> tp) + +-- | View an assignment as either empty or an assignment with one appended. +data AssignView (f :: k -> Type) (ctx :: Ctx k) where + AssignEmpty :: AssignView f EmptyCtx + AssignExtend :: Assignment f ctx -> f tp -> AssignView f (ctx::>tp) + +viewAssign :: forall f ctx . Assignment f ctx -> AssignView f ctx +viewAssign AssignmentEmpty = AssignEmpty +viewAssign (AssignmentExtend asgn x) = AssignExtend asgn x + +instance NFData (Assignment f ctx) where + rnf AssignmentEmpty = () + rnf (AssignmentExtend asgn x) = rnf asgn `seq` x `seq` () + +-- | Return number of elements in assignment. +size :: Assignment f ctx -> Size ctx +size AssignmentEmpty = SizeZero +size (AssignmentExtend asgn _) = SizeSucc (size asgn) + +-- | Generate an assignment +generate :: forall ctx f + . Size ctx + -> (forall tp . Index ctx tp -> f tp) + -> Assignment f ctx +generate sz_top f = go id sz_top + where go :: forall ctx' + . (forall tp. Index ctx' tp -> Index ctx tp) + -> Size ctx' + -> Assignment f ctx' + go _ SizeZero = AssignmentEmpty + go g (SizeSucc sz) = + let ctx = go (\i -> g (IndexThere i)) sz + x = f (g (IndexHere sz)) + in AssignmentExtend ctx x + +-- | Generate an assignment +generateM :: forall ctx m f + . Applicative m + => Size ctx + -> (forall tp . Index ctx tp -> m (f tp)) + -> m (Assignment f ctx) +generateM sz_top f = go id sz_top + where go :: forall ctx'. (forall tp. Index ctx' tp -> Index ctx tp) -> Size ctx' -> m (Assignment f ctx') + go _ SizeZero = pure AssignmentEmpty + go g (SizeSucc sz) = + AssignmentExtend <$> (go (\i -> g (IndexThere i)) sz) <*> f (g (IndexHere sz)) + +-- | @replicate n@ make a context with different copies of the same +-- polymorphic value. +replicate :: Size ctx -> (forall tp . f tp) -> Assignment f ctx +replicate n c = generate n (\_ -> c) + +-- | Create empty indexed vector. +empty :: Assignment f 'EmptyCtx +empty = AssignmentEmpty + +-- n.b. see 'singleton' in Data/Parameterized/Context.hs + +-- | Extend an indexed vector with a new entry. +extend :: Assignment f ctx -> f tp -> Assignment f (ctx '::> tp) +extend asgn e = AssignmentExtend asgn e + +{-# DEPRECATED adjust "Replace 'adjust f i asgn' with 'Lens.over (ixF i) f asgn' instead." #-} +adjust :: forall f ctx tp. (f tp -> f tp) -> Index ctx tp -> Assignment f ctx -> Assignment f ctx +adjust f idx asgn = runIdentity (adjustM (Identity . f) idx asgn) + +{-# DEPRECATED update "Replace 'update idx val asgn' with 'Lens.set (ixF idx) val asgn' instead." #-} +update :: forall f ctx tp. Index ctx tp -> f tp -> Assignment f ctx -> Assignment f ctx +update i v a = adjust (\_ -> v) i a + +adjustM :: forall m f ctx tp. Functor m => (f tp -> m (f tp)) -> Index ctx tp -> Assignment f ctx -> m (Assignment f ctx) +adjustM f = go (\x -> x) + where + go :: (forall tp'. g tp' -> f tp') -> Index ctx' tp -> Assignment g ctx' -> m (Assignment f ctx') + go g (IndexHere _) (AssignmentExtend asgn x) = AssignmentExtend (map g asgn) <$> f (g x) + go g (IndexThere idx) (AssignmentExtend asgn x) = flip AssignmentExtend (g x) <$> go g idx asgn + +type instance IndexF (Assignment (f :: k -> Type) ctx) = Index ctx +type instance IxValueF (Assignment (f :: k -> Type) ctx) = f + +instance forall k (f :: k -> Type) ctx. IxedF k (Assignment f ctx) where + ixF :: Index ctx x -> Lens.Traversal' (Assignment f ctx) (f x) + ixF idx f = adjustM f idx + +instance forall k (f :: k -> Type) ctx. IxedF' k (Assignment f ctx) where + ixF' :: Index ctx x -> Lens.Lens' (Assignment f ctx) (f x) + ixF' idx f = adjustM f idx + +idxlookup :: (forall tp. a tp -> b tp) -> Assignment a ctx -> forall tp. Index ctx tp -> b tp +idxlookup f (AssignmentExtend _ x) (IndexHere _) = f x +idxlookup f (AssignmentExtend ctx _) (IndexThere idx) = idxlookup f ctx idx +idxlookup _ AssignmentEmpty idx = case idx of {} + +-- | Return value of assignment. +(!) :: Assignment f ctx -> Index ctx tp -> f tp +(!) asgn idx = idxlookup id asgn idx + +-- | Return value of assignment, where the index is into an +-- initial sequence of the assignment. +(!^) :: KnownDiff l r => Assignment f r -> Index l tp -> f tp +a !^ i = a ! extendIndex i + +instance TestEquality f => Eq (Assignment f ctx) where + x == y = isJust (testEquality x y) + +testEq :: (forall x y. f x -> f y -> Maybe (x :~: y)) + -> Assignment f cxt1 -> Assignment f cxt2 -> Maybe (cxt1 :~: cxt2) +testEq _ AssignmentEmpty AssignmentEmpty = Just Refl +testEq test (AssignmentExtend ctx1 x1) (AssignmentExtend ctx2 x2) = + case testEq test ctx1 ctx2 of + Nothing -> Nothing + Just Refl -> + case test x1 x2 of + Nothing -> Nothing + Just Refl -> Just Refl +testEq _ AssignmentEmpty AssignmentExtend{} = Nothing +testEq _ AssignmentExtend{} AssignmentEmpty = Nothing + +instance TestEqualityFC Assignment where + testEqualityFC f = testEq f +instance TestEquality f => TestEquality (Assignment f) where + testEquality x y = testEq testEquality x y +instance TestEquality f => PolyEq (Assignment f x) (Assignment f y) where + polyEqF x y = fmap (\Refl -> Refl) $ testEquality x y + +compareAsgn :: (forall x y. f x -> f y -> OrderingF x y) + -> Assignment f ctx1 -> Assignment f ctx2 -> OrderingF ctx1 ctx2 +compareAsgn _ AssignmentEmpty AssignmentEmpty = EQF +compareAsgn _ AssignmentEmpty _ = GTF +compareAsgn _ _ AssignmentEmpty = LTF +compareAsgn test (AssignmentExtend ctx1 x) (AssignmentExtend ctx2 y) = + case compareAsgn test ctx1 ctx2 of + LTF -> LTF + GTF -> GTF + EQF -> case test x y of + LTF -> LTF + GTF -> GTF + EQF -> EQF + +instance OrdFC Assignment where + compareFC f = compareAsgn f + +instance OrdF f => OrdF (Assignment f) where + compareF = compareAsgn compareF + +instance OrdF f => Ord (Assignment f ctx) where + compare x y = toOrdering (compareF x y) + + +instance Hashable (Index ctx tp) where + hashWithSalt = hashWithSaltF +instance HashableF (Index ctx) where + hashWithSaltF s i = hashWithSalt s (indexVal i) + +instance (HashableF f, TestEquality f) => HashableF (Assignment f) where + hashWithSaltF = hashWithSalt + +instance (HashableF f, TestEquality f) => Hashable (Assignment f ctx) where + hashWithSalt s AssignmentEmpty = s + hashWithSalt s (AssignmentExtend asgn x) = (s `hashWithSalt` asgn) `hashWithSaltF` x + +instance ShowF f => Show (Assignment f ctx) where + show a = "[" ++ intercalate ", " (toList showF a) ++ "]" + +instance ShowF f => ShowF (Assignment f) + +instance FunctorFC Assignment where + fmapFC = fmapFCDefault + +instance FoldableFC Assignment where + foldMapFC = foldMapFCDefault + +instance TraversableFC Assignment where + traverseFC f = traverseF f + +instance FunctorFCWithIndex Assignment where + imapFC = imapFCDefault + +instance FoldableFCWithIndex Assignment where + ifoldMapFC = ifoldMapFCDefault + +instance TraversableFCWithIndex Assignment where + itraverseFC = traverseWithIndex + +-- | Map assignment +map :: (forall tp . f tp -> g tp) -> Assignment f c -> Assignment g c +map f = fmapFC f + +traverseF :: forall k (f:: k -> Type) (g::k -> Type) (m:: Type -> Type) (c::Ctx k) + . Applicative m + => (forall tp . f tp -> m (g tp)) + -> Assignment f c + -> m (Assignment g c) +traverseF _ AssignmentEmpty = pure AssignmentEmpty +traverseF f (AssignmentExtend asgn x) = pure AssignmentExtend <*> traverseF f asgn <*> f x + +-- | Convert assignment to list. +toList :: (forall tp . f tp -> a) + -> Assignment f c + -> [a] +toList f = toListFC f + +zipWithM :: Applicative m + => (forall tp . f tp -> g tp -> m (h tp)) + -> Assignment f c + -> Assignment g c + -> m (Assignment h c) +zipWithM f x y = go x y + where go AssignmentEmpty AssignmentEmpty = pure AssignmentEmpty + go (AssignmentExtend asgn1 x1) (AssignmentExtend asgn2 x2) = + AssignmentExtend <$> (zipWithM f asgn1 asgn2) <*> (f x1 x2) + +zipWith :: (forall x . f x -> g x -> h x) + -> Assignment f a + -> Assignment g a + -> Assignment h a +zipWith f = \x y -> runIdentity $ zipWithM (\u v -> pure (f u v)) x y +{-# INLINE zipWith #-} + +-- | This is a specialization of 'itraverseFC'. +traverseWithIndex :: Applicative m + => (forall tp . Index ctx tp -> f tp -> m (g tp)) + -> Assignment f ctx + -> m (Assignment g ctx) +traverseWithIndex f a = generateM (size a) $ \i -> f i (a ! i) + +(<++>) :: Assignment f x -> Assignment f y -> Assignment f (x <+> y) +x <++> AssignmentEmpty = x +x <++> AssignmentExtend y t = AssignmentExtend (x <++> y) t + +------------------------------------------------------------------------ +-- KnownRepr instances + +instance (KnownRepr (Assignment f) ctx, KnownRepr f bt) + => KnownRepr (Assignment f) (ctx ::> bt) where + knownRepr = knownRepr `extend` knownRepr + +instance KnownRepr (Assignment f) EmptyCtx where + knownRepr = empty + +-------------------------------------------------------------------------------------- +-- lookups and update for lenses + +data MyNat where + MyZ :: MyNat + MyS :: MyNat -> MyNat + +type MyZ = 'MyZ +type MyS = 'MyS + +data MyNatRepr :: MyNat -> Type where + MyZR :: MyNatRepr MyZ + MySR :: MyNatRepr n -> MyNatRepr (MyS n) + +type family StrongCtxUpdate (n::MyNat) (ctx::Ctx k) (z::k) :: Ctx k where + StrongCtxUpdate n EmptyCtx z = EmptyCtx + StrongCtxUpdate MyZ (ctx::>x) z = ctx ::> z + StrongCtxUpdate (MyS n) (ctx::>x) z = (StrongCtxUpdate n ctx z) ::> x + +type family MyNatLookup (n::MyNat) (ctx::Ctx k) (f::k -> Type) :: Type where + MyNatLookup n EmptyCtx f = () + MyNatLookup MyZ (ctx::>x) f = f x + MyNatLookup (MyS n) (ctx::>x) f = MyNatLookup n ctx f + +mynat_lookup :: MyNatRepr n -> Assignment f ctx -> MyNatLookup n ctx f +mynat_lookup _ AssignmentEmpty = () +mynat_lookup MyZR (AssignmentExtend _ x) = x +mynat_lookup (MySR n) (AssignmentExtend asgn _) = mynat_lookup n asgn + +strong_ctx_update :: MyNatRepr n -> Assignment f ctx -> f tp -> Assignment f (StrongCtxUpdate n ctx tp) +strong_ctx_update _ AssignmentEmpty _ = AssignmentEmpty +strong_ctx_update MyZR (AssignmentExtend asgn _) z = AssignmentExtend asgn z +strong_ctx_update (MySR n) (AssignmentExtend asgn x) z = AssignmentExtend (strong_ctx_update n asgn z) x + +------------------------------------------------------------------------ +-- 1 field lens combinators + +type Assignment1 f x1 = Assignment f ('EmptyCtx '::> x1) + +instance Lens.Field1 (Assignment1 f t) (Assignment1 f u) (f t) (f u) where + + _1 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MyZR + +------------------------------------------------------------------------ +-- 2 field lens combinators + +type Assignment2 f x1 x2 + = Assignment f ('EmptyCtx '::> x1 '::> x2) + +instance Lens.Field1 (Assignment2 f t x2) (Assignment2 f u x2) (f t) (f u) where + _1 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MyZR + +instance Lens.Field2 (Assignment2 f x1 t) (Assignment2 f x1 u) (f t) (f u) where + _2 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MyZR + + +------------------------------------------------------------------------ +-- 3 field lens combinators + +type Assignment3 f x1 x2 x3 + = Assignment f ('EmptyCtx '::> x1 '::> x2 '::> x3) + +instance Lens.Field1 (Assignment3 f t x2 x3) + (Assignment3 f u x2 x3) + (f t) + (f u) where + _1 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MySR $ MyZR + +instance Lens.Field2 (Assignment3 f x1 t x3) + (Assignment3 f x1 u x3) + (f t) + (f u) where + _2 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MyZR + +instance Lens.Field3 (Assignment3 f x1 x2 t) + (Assignment3 f x1 x2 u) + (f t) + (f u) where + _3 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MyZR + +------------------------------------------------------------------------ +-- 4 field lens combinators + +type Assignment4 f x1 x2 x3 x4 + = Assignment f ('EmptyCtx '::> x1 '::> x2 '::> x3 '::> x4) + +instance Lens.Field1 (Assignment4 f t x2 x3 x4) + (Assignment4 f u x2 x3 x4) + (f t) + (f u) where + _1 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MySR $ MySR $ MyZR + +instance Lens.Field2 (Assignment4 f x1 t x3 x4) + (Assignment4 f x1 u x3 x4) + (f t) + (f u) where + _2 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MySR $ MyZR + +instance Lens.Field3 (Assignment4 f x1 x2 t x4) + (Assignment4 f x1 x2 u x4) + (f t) + (f u) where + _3 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MyZR + +instance Lens.Field4 (Assignment4 f x1 x2 x3 t) + (Assignment4 f x1 x2 x3 u) + (f t) + (f u) where + _4 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MyZR + + +------------------------------------------------------------------------ +-- 5 field lens combinators + +type Assignment5 f x1 x2 x3 x4 x5 + = Assignment f ('EmptyCtx '::> x1 '::> x2 '::> x3 '::> x4 '::> x5) + +instance Lens.Field1 (Assignment5 f t x2 x3 x4 x5) + (Assignment5 f u x2 x3 x4 x5) + (f t) + (f u) where + _1 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MySR $ MySR $ MySR $ MyZR + +instance Lens.Field2 (Assignment5 f x1 t x3 x4 x5) + (Assignment5 f x1 u x3 x4 x5) + (f t) + (f u) where + _2 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MySR $ MySR $ MyZR + +instance Lens.Field3 (Assignment5 f x1 x2 t x4 x5) + (Assignment5 f x1 x2 u x4 x5) + (f t) + (f u) where + _3 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MySR $ MyZR + +instance Lens.Field4 (Assignment5 f x1 x2 x3 t x5) + (Assignment5 f x1 x2 x3 u x5) + (f t) + (f u) where + _4 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MyZR + +instance Lens.Field5 (Assignment5 f x1 x2 x3 x4 t) + (Assignment5 f x1 x2 x3 x4 u) + (f t) + (f u) where + _5 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MyZR + +------------------------------------------------------------------------ +-- 6 field lens combinators + +type Assignment6 f x1 x2 x3 x4 x5 x6 + = Assignment f ('EmptyCtx '::> x1 '::> x2 '::> x3 '::> x4 '::> x5 '::> x6) + +instance Lens.Field1 (Assignment6 f t x2 x3 x4 x5 x6) + (Assignment6 f u x2 x3 x4 x5 x6) + (f t) + (f u) where + _1 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MySR $ MySR $ MySR $ MySR $ MyZR + +instance Lens.Field2 (Assignment6 f x1 t x3 x4 x5 x6) + (Assignment6 f x1 u x3 x4 x5 x6) + (f t) + (f u) where + _2 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MySR $ MySR $ MySR $ MyZR + +instance Lens.Field3 (Assignment6 f x1 x2 t x4 x5 x6) + (Assignment6 f x1 x2 u x4 x5 x6) + (f t) + (f u) where + _3 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MySR $ MySR $ MyZR + +instance Lens.Field4 (Assignment6 f x1 x2 x3 t x5 x6) + (Assignment6 f x1 x2 x3 u x5 x6) + (f t) + (f u) where + _4 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MySR $ MyZR + +instance Lens.Field5 (Assignment6 f x1 x2 x3 x4 t x6) + (Assignment6 f x1 x2 x3 x4 u x6) + (f t) + (f u) where + _5 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MyZR + +instance Lens.Field6 (Assignment6 f x1 x2 x3 x4 x5 t) + (Assignment6 f x1 x2 x3 x4 x5 u) + (f t) + (f u) where + _6 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MyZR + +------------------------------------------------------------------------ +-- 7 field lens combinators + +type Assignment7 f x1 x2 x3 x4 x5 x6 x7 + = Assignment f ('EmptyCtx '::> x1 '::> x2 '::> x3 '::> x4 '::> x5 '::> x6 '::> x7) + +instance Lens.Field1 (Assignment7 f t x2 x3 x4 x5 x6 x7) + (Assignment7 f u x2 x3 x4 x5 x6 x7) + (f t) + (f u) where + _1 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MySR $ MySR $ MySR $ MySR $ MySR $ MyZR + +instance Lens.Field2 (Assignment7 f x1 t x3 x4 x5 x6 x7) + (Assignment7 f x1 u x3 x4 x5 x6 x7) + (f t) + (f u) where + _2 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MySR $ MySR $ MySR $ MySR $ MyZR + +instance Lens.Field3 (Assignment7 f x1 x2 t x4 x5 x6 x7) + (Assignment7 f x1 x2 u x4 x5 x6 x7) + (f t) + (f u) where + _3 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MySR $ MySR $ MySR $ MyZR + +instance Lens.Field4 (Assignment7 f x1 x2 x3 t x5 x6 x7) + (Assignment7 f x1 x2 x3 u x5 x6 x7) + (f t) + (f u) where + _4 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MySR $ MySR $ MyZR + +instance Lens.Field5 (Assignment7 f x1 x2 x3 x4 t x6 x7) + (Assignment7 f x1 x2 x3 x4 u x6 x7) + (f t) + (f u) where + _5 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MySR $ MyZR + +instance Lens.Field6 (Assignment7 f x1 x2 x3 x4 x5 t x7) + (Assignment7 f x1 x2 x3 x4 x5 u x7) + (f t) + (f u) where + _6 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MyZR + +instance Lens.Field7 (Assignment7 f x1 x2 x3 x4 x5 x6 t) + (Assignment7 f x1 x2 x3 x4 x5 x6 u) + (f t) + (f u) where + _7 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MyZR + +------------------------------------------------------------------------ +-- 8 field lens combinators + +type Assignment8 f x1 x2 x3 x4 x5 x6 x7 x8 + = Assignment f ('EmptyCtx '::> x1 '::> x2 '::> x3 '::> x4 '::> x5 '::> x6 '::> x7 '::> x8) + +instance Lens.Field1 (Assignment8 f t x2 x3 x4 x5 x6 x7 x8) + (Assignment8 f u x2 x3 x4 x5 x6 x7 x8) + (f t) + (f u) where + _1 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MySR $ MySR $ MySR $ MySR $ MySR $ MySR $ MyZR + + +instance Lens.Field2 (Assignment8 f x1 t x3 x4 x5 x6 x7 x8) + (Assignment8 f x1 u x3 x4 x5 x6 x7 x8) + (f t) + (f u) where + _2 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MySR $ MySR $ MySR $ MySR $ MySR $ MyZR + +instance Lens.Field3 (Assignment8 f x1 x2 t x4 x5 x6 x7 x8) + (Assignment8 f x1 x2 u x4 x5 x6 x7 x8) + (f t) + (f u) where + _3 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MySR $ MySR $ MySR $ MySR $ MyZR + +instance Lens.Field4 (Assignment8 f x1 x2 x3 t x5 x6 x7 x8) + (Assignment8 f x1 x2 x3 u x5 x6 x7 x8) + (f t) + (f u) where + _4 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MySR $ MySR $ MySR $ MyZR + +instance Lens.Field5 (Assignment8 f x1 x2 x3 x4 t x6 x7 x8) + (Assignment8 f x1 x2 x3 x4 u x6 x7 x8) + (f t) + (f u) where + _5 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MySR $ MySR $ MyZR + +instance Lens.Field6 (Assignment8 f x1 x2 x3 x4 x5 t x7 x8) + (Assignment8 f x1 x2 x3 x4 x5 u x7 x8) + (f t) + (f u) where + _6 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MySR $ MyZR + +instance Lens.Field7 (Assignment8 f x1 x2 x3 x4 x5 x6 t x8) + (Assignment8 f x1 x2 x3 x4 x5 x6 u x8) + (f t) + (f u) where + _7 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MyZR + +instance Lens.Field8 (Assignment8 f x1 x2 x3 x4 x5 x6 x7 t) + (Assignment8 f x1 x2 x3 x4 x5 x6 x7 u) + (f t) + (f u) where + _8 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MyZR + +------------------------------------------------------------------------ +-- 9 field lens combinators + +type Assignment9 f x1 x2 x3 x4 x5 x6 x7 x8 x9 + = Assignment f ('EmptyCtx '::> x1 '::> x2 '::> x3 '::> x4 '::> x5 '::> x6 '::> x7 '::> x8 '::> x9) + + +instance Lens.Field1 (Assignment9 f t x2 x3 x4 x5 x6 x7 x8 x9) + (Assignment9 f u x2 x3 x4 x5 x6 x7 x8 x9) + (f t) + (f u) where + _1 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MySR $ MySR $ MySR $ MySR $ MySR $ MySR $ MySR $ MyZR + +instance Lens.Field2 (Assignment9 f x1 t x3 x4 x5 x6 x7 x8 x9) + (Assignment9 f x1 u x3 x4 x5 x6 x7 x8 x9) + (f t) + (f u) where + _2 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MySR $ MySR $ MySR $ MySR $ MySR $ MySR $ MyZR + +instance Lens.Field3 (Assignment9 f x1 x2 t x4 x5 x6 x7 x8 x9) + (Assignment9 f x1 x2 u x4 x5 x6 x7 x8 x9) + (f t) + (f u) where + _3 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MySR $ MySR $ MySR $ MySR $ MySR $ MyZR + +instance Lens.Field4 (Assignment9 f x1 x2 x3 t x5 x6 x7 x8 x9) + (Assignment9 f x1 x2 x3 u x5 x6 x7 x8 x9) + (f t) + (f u) where + _4 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MySR $ MySR $ MySR $ MySR $ MyZR + +instance Lens.Field5 (Assignment9 f x1 x2 x3 x4 t x6 x7 x8 x9) + (Assignment9 f x1 x2 x3 x4 u x6 x7 x8 x9) + (f t) + (f u) where + _5 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MySR $ MySR $ MySR $ MyZR + +instance Lens.Field6 (Assignment9 f x1 x2 x3 x4 x5 t x7 x8 x9) + (Assignment9 f x1 x2 x3 x4 x5 u x7 x8 x9) + (f t) + (f u) where + _6 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MySR $ MySR $ MyZR + +instance Lens.Field7 (Assignment9 f x1 x2 x3 x4 x5 x6 t x8 x9) + (Assignment9 f x1 x2 x3 x4 x5 x6 u x8 x9) + (f t) + (f u) where + _7 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MySR $ MyZR + +instance Lens.Field8 (Assignment9 f x1 x2 x3 x4 x5 x6 x7 t x9) + (Assignment9 f x1 x2 x3 x4 x5 x6 x7 u x9) + (f t) + (f u) where + _8 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MySR $ MyZR + +instance Lens.Field9 (Assignment9 f x1 x2 x3 x4 x5 x6 x7 x8 t) + (Assignment9 f x1 x2 x3 x4 x5 x6 x7 x8 u) + (f t) + (f u) where + _9 = Lens.lens (mynat_lookup n) (strong_ctx_update n) + where n = MyZR diff --git a/src/Data/Parameterized/Context/Unsafe.hs b/src/Data/Parameterized/Context/Unsafe.hs new file mode 100644 index 0000000..3eedbc3 --- /dev/null +++ b/src/Data/Parameterized/Context/Unsafe.hs @@ -0,0 +1,1304 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +#if __GLASGOW_HASKELL__ < 806 +{-# LANGUAGE TypeInType #-} +#endif +{-# OPTIONS_HADDOCK hide #-} +module Data.Parameterized.Context.Unsafe + ( module Data.Parameterized.Ctx + , KnownContext(..) + -- * Size + , Size + , sizeInt + , zeroSize + , incSize + , decSize + , extSize + , addSize + , SizeView(..) + , viewSize + , sizeToNatRepr + -- * Diff + , Diff + , noDiff + , addDiff + , extendRight + , appendDiff + , DiffView(..) + , viewDiff + , KnownDiff(..) + , IsAppend(..) + , diffIsAppend + -- * Indexing + , Index + , indexVal + , baseIndex + , skipIndex + , lastIndex + , nextIndex + , leftIndex + , rightIndex + , extendIndex + , extendIndex' + , extendIndexAppendLeft + , forIndex + , forIndexRange + , intIndex + , IndexView(..) + , viewIndex + -- ** IndexRange + , IndexRange + , allRange + , indexOfRange + , dropHeadRange + , dropTailRange + -- * Assignments + , Assignment + , size + , Data.Parameterized.Context.Unsafe.replicate + , generate + , generateM + , empty + , extend + , adjust + , update + , adjustM + , AssignView(..) + , viewAssign + , (!) + , (!^) + , Data.Parameterized.Context.Unsafe.zipWith + , zipWithM + , (<++>) + , traverseWithIndex + ) where + +import qualified Control.Category as Cat +import Control.DeepSeq +import Control.Exception +import qualified Control.Lens as Lens +import Control.Monad.Identity (Identity(..)) +import Data.Bits +import Data.Coerce +import Data.Hashable +import Data.List (intercalate) +import Data.Proxy +import Unsafe.Coerce +import Data.Kind(Type) + +import Data.Parameterized.Axiom +import Data.Parameterized.Classes +import Data.Parameterized.Ctx +import Data.Parameterized.Ctx.Proofs +import Data.Parameterized.NatRepr +import Data.Parameterized.NatRepr.Internal (NatRepr(NatRepr)) +import Data.Parameterized.Some +import Data.Parameterized.TraversableFC +import Data.Parameterized.TraversableFC.WithIndex + +------------------------------------------------------------------------ +-- Size + +-- | Represents the size of a context. +newtype Size (ctx :: Ctx k) = Size Int + +type role Size nominal + +-- | Convert a context size to an 'Int'. +sizeInt :: Size ctx -> Int +sizeInt (Size n) = n + +-- | The size of an empty context. +zeroSize :: Size 'EmptyCtx +zeroSize = Size 0 + +-- | Increment the size to the next value. +incSize :: Size ctx -> Size (ctx '::> tp) +incSize (Size n) = Size (n+1) + +decSize :: Size (ctx '::> tp) -> Size ctx +decSize (Size n) = assert (n > 0) (Size (n-1)) + +-- | Allows interpreting a size. +data SizeView (ctx :: Ctx k) where + ZeroSize :: SizeView 'EmptyCtx + IncSize :: !(Size ctx) -> SizeView (ctx '::> tp) + +-- | Project a size +viewSize :: Size ctx -> SizeView ctx +viewSize (Size 0) = unsafeCoerce ZeroSize +viewSize (Size n) = assert (n > 0) (unsafeCoerce (IncSize (Size (n-1)))) + +-- | Convert a 'Size' into a 'NatRepr'. +sizeToNatRepr :: Size items -> NatRepr (CtxSize items) +sizeToNatRepr (Size n) = NatRepr (fromIntegral n) + +instance Show (Size ctx) where + show (Size i) = show i + +instance ShowF Size + +-- | A context that can be determined statically at compiler time. +class KnownContext (ctx :: Ctx k) where + knownSize :: Size ctx + +instance KnownContext 'EmptyCtx where + knownSize = zeroSize + +instance KnownContext ctx => KnownContext (ctx '::> tp) where + knownSize = incSize knownSize + +------------------------------------------------------------------------ +-- Diff + +-- | Difference in number of elements between two contexts. +-- The first context must be a sub-context of the other. +newtype Diff (l :: Ctx k) (r :: Ctx k) + = Diff { _contextExtSize :: Int } + +type role Diff nominal nominal + +-- | The identity difference. Identity element of 'Category' instance. +noDiff :: Diff l l +noDiff = Diff 0 +{-# INLINE noDiff #-} + +-- | The addition of differences. Flipped binary operation +-- of 'Category' instance. +addDiff :: Diff a b -> Diff b c -> Diff a c +addDiff (Diff x) (Diff y) = Diff (x + y) +{-# INLINE addDiff #-} + +-- | Extend the difference to a sub-context of the right side. +extendRight :: Diff l r -> Diff l (r '::> tp) +extendRight (Diff i) = Diff (i+1) + +appendDiff :: Size r -> Diff l (l <+> r) +appendDiff (Size r) = Diff r + +-- | Implemented with 'noDiff' and 'addDiff' +instance Cat.Category Diff where + id = noDiff + j . i = addDiff i j + +-- | Extend the size by a given difference. +extSize :: Size l -> Diff l r -> Size r +extSize (Size i) (Diff j) = Size (i+j) + +-- | The total size of two concatenated contexts. +addSize :: Size x -> Size y -> Size (x <+> y) +addSize (Size x) (Size y) = Size (x + y) + + +-- | Proof that @r = l <+> app@ for some @app@ +data IsAppend l r where + IsAppend :: Size app -> IsAppend l (l <+> app) + +-- | If @l@ is a sub-context of @r@ then extract out their "contextual +-- difference", i.e., the @app@ such that @r = l <+> app@ +diffIsAppend :: Diff l r -> IsAppend l r +diffIsAppend (Diff i) = unsafeCoerce $ IsAppend (Size i) + +data DiffView a b where + NoDiff :: DiffView a a + ExtendRightDiff :: Diff a b -> DiffView a (b ::> r) + +viewDiff :: Diff a b -> DiffView a b +viewDiff (Diff i) + | i == 0 = unsafeCoerce NoDiff + | otherwise = assert (i > 0) $ unsafeCoerce $ ExtendRightDiff (Diff (i-1)) + +------------------------------------------------------------------------ +-- KnownDiff + +-- | A difference that can be automatically inferred at compile time. +class KnownDiff (l :: Ctx k) (r :: Ctx k) where + knownDiff :: Diff l r + +instance KnownDiff l l where + knownDiff = noDiff + +instance {-# INCOHERENT #-} KnownDiff l r => KnownDiff l (r '::> tp) where + knownDiff = extendRight knownDiff + +------------------------------------------------------------------------ +-- Index + +-- | An index is a reference to a position with a particular type in a +-- context. +newtype Index (ctx :: Ctx k) (tp :: k) = Index { indexVal :: Int } + +type role Index nominal nominal + +instance Eq (Index ctx tp) where + Index i == Index j = i == j + +instance TestEquality (Index ctx) where + testEquality (Index i) (Index j) + | i == j = Just unsafeAxiom + | otherwise = Nothing + +instance Ord (Index ctx tp) where + Index i `compare` Index j = compare i j + +instance OrdF (Index ctx) where + compareF (Index i) (Index j) + | i < j = LTF + | i == j = unsafeCoerce EQF + | otherwise = GTF + +-- | Index for first element in context. +baseIndex :: Index ('EmptyCtx '::> tp) tp +baseIndex = Index 0 + +-- | Increase context while staying at same index. +skipIndex :: Index ctx x -> Index (ctx '::> y) x +skipIndex (Index i) = Index i + +-- | Return the index of a element one past the size. +nextIndex :: Size ctx -> Index (ctx ::> tp) tp +nextIndex n = Index (sizeInt n) + +-- | Return the last index of a element. +lastIndex :: Size (ctx ::> tp) -> Index (ctx ::> tp) tp +lastIndex n = Index (sizeInt n - 1) + +-- | Adapts an index in the left hand context of an append operation. +leftIndex :: Size r -> Index l tp -> Index (l <+> r) tp +leftIndex _ (Index il) = Index il + +-- | Adapts an index in the right hand context of an append operation. +rightIndex :: Size l -> Size r -> Index r tp -> Index (l <+> r) tp +rightIndex (Size sl) _ (Index ir) = Index (sl + ir) + +{-# INLINE extendIndex #-} +extendIndex :: KnownDiff l r => Index l tp -> Index r tp +extendIndex = extendIndex' knownDiff + +{-# INLINE extendIndex' #-} +-- | Compute an 'Index' into a context @r@ from an 'Index' into +-- a sub-context @l@ of @r@. +extendIndex' :: Diff l r -> Index l tp -> Index r tp +extendIndex' _ = unsafeCoerce + +{-# INLINE extendIndexAppendLeft #-} +-- | Compute an 'Index' into an appended context from an 'Index' into +-- its suffix. +extendIndexAppendLeft :: Size l -> Size r -> Index r tp -> Index (l <+> r) tp +extendIndexAppendLeft (Size l) _ (Index idx) = Index (idx + l) + +-- | Given a size @n@, a function @f@, and an initial value @v0@, the +-- expression @forIndex n f v0@ is equivalent to @v0@ when @n@ is +-- zero, and @f (forIndex (n-1) f v0) n@ otherwise. Unlike the safe +-- version, which starts from 'Index' @0@ and increments 'Index' +-- values, this version starts at 'Index' @(n-1)@ and decrements +-- 'Index' values to 'Index' @0@. +forIndex :: forall ctx r + . Size ctx + -> (forall tp . r -> Index ctx tp -> r) + -> r + -> r +forIndex n f r = + case viewSize n of + ZeroSize -> r + IncSize p -> f (forIndex p (coerce f) r) (nextIndex p) + +-- | Given an index @i@, size @n@, a function @f@, and a value @v@, +-- the expression @forIndex i n f v@ is equivalent to +-- @v@ when @i >= sizeInt n@, and @f i (forIndexRange (i+1) n f v)@ +-- otherwise. +forIndexRange :: forall ctx r + . Int + -> Size ctx + -> (forall tp . Index ctx tp -> r -> r) + -> r + -> r +forIndexRange i (Size n) f r + | i >= n = r + | otherwise = f (Index i) (forIndexRange (i+1) (Size n) f r) + +-- | Return index at given integer or nothing if integer is out of bounds. +intIndex :: Int -> Size ctx -> Maybe (Some (Index ctx)) +intIndex i n | 0 <= i && i < sizeInt n = Just (Some (Index i)) + | otherwise = Nothing + +instance Show (Index ctx tp) where + show = show . indexVal + +instance ShowF (Index ctx) + +-- | View of indexes as pointing to the last element in the +-- index range or pointing to an earlier element in a smaller +-- range. +data IndexView ctx tp where + IndexViewLast :: !(Size ctx ) -> IndexView (ctx '::> t) t + IndexViewInit :: !(Index ctx t) -> IndexView (ctx '::> u) t + +deriving instance Show (IndexView ctx tp) +instance ShowF (IndexView ctx) + +-- | Project an index +viewIndex :: Size ctx -> Index ctx tp -> IndexView ctx tp +viewIndex (Size sz) (Index i) + | sz' == i = unsafeCoerce (IndexViewLast (Size sz')) + | otherwise = unsafeCoerce (IndexViewInit (Index i)) + where + sz' = sz-1 + +------------------------------------------------------------------------ +-- IndexRange + +-- | This represents a contiguous range of indices. +data IndexRange (ctx :: Ctx k) (sub :: Ctx k) + = IndexRange {-# UNPACK #-} !Int + {-# UNPACK #-} !Int + +-- | Return a range containing all indices in the context. +allRange :: Size ctx -> IndexRange ctx ctx +allRange (Size n) = IndexRange 0 n + +-- | `indexOfRange` returns the only index in a range. +indexOfRange :: IndexRange ctx (EmptyCtx ::> e) -> Index ctx e +indexOfRange (IndexRange i n) = assert (n == 1) $ Index i + +-- | @dropTailRange r n@ drops the last @n@ elements in @r@. +dropTailRange :: IndexRange ctx (x <+> y) -> Size y -> IndexRange ctx x +dropTailRange (IndexRange i n) (Size j) = assert (n >= j) $ IndexRange i (n - j) + +-- | @dropHeadRange r n@ drops the first @n@ elements in @r@. +dropHeadRange :: IndexRange ctx (x <+> y) -> Size x -> IndexRange ctx y +dropHeadRange (IndexRange i n) (Size j) = assert (i' >= i && n >= j) $ IndexRange i' (n - j) + where i' = i + j + +------------------------------------------------------------------------ +-- Height + +data Height = Zero | Succ Height + +type family Pred (k :: Height) :: Height +type instance Pred ('Succ h) = h + +------------------------------------------------------------------------ +-- * BalancedTree + +-- | A balanced tree where all leaves are at the same height. +-- +-- The first parameter is the height of the tree. +-- The second is the parameterized value. +data BalancedTree h (f :: k -> Type) (p :: Ctx k) where + BalLeaf :: !(f x) -> BalancedTree 'Zero f (SingleCtx x) + BalPair :: !(BalancedTree h f x) + -> !(BalancedTree h f y) + -> BalancedTree ('Succ h) f (x <+> y) + +bal_size :: BalancedTree h f p -> Int +bal_size (BalLeaf _) = 1 +bal_size (BalPair x y) = bal_size x + bal_size y + + +instance TestEqualityFC (BalancedTree h) where + testEqualityFC test (BalLeaf x) (BalLeaf y) = do + Refl <- test x y + return Refl + testEqualityFC test (BalPair x1 x2) (BalPair y1 y2) = do + Refl <- testEqualityFC test x1 y1 + Refl <- testEqualityFC test x2 y2 + return Refl + +instance OrdFC (BalancedTree h) where + compareFC test (BalLeaf x) (BalLeaf y) = + joinOrderingF (test x y) $ EQF + compareFC test (BalPair x1 x2) (BalPair y1 y2) = + joinOrderingF (compareFC test x1 y1) $ + joinOrderingF (compareFC test x2 y2) $ + EQF + +instance HashableF f => HashableF (BalancedTree h f) where + hashWithSaltF s t = + case t of + BalLeaf x -> s `hashWithSaltF` x + BalPair x y -> s `hashWithSaltF` x `hashWithSaltF` y + +fmap_bal :: (forall tp . f tp -> g tp) + -> BalancedTree h f c + -> BalancedTree h g c +fmap_bal = go + where go :: (forall tp . f tp -> g tp) + -> BalancedTree h f c + -> BalancedTree h g c + go f (BalLeaf x) = BalLeaf (f x) + go f (BalPair x y) = BalPair (go f x) (go f y) +{-# INLINABLE fmap_bal #-} + +traverse_bal :: Applicative m + => (forall tp . f tp -> m (g tp)) + -> BalancedTree h f c + -> m (BalancedTree h g c) +traverse_bal = go + where go :: Applicative m + => (forall tp . f tp -> m (g tp)) + -> BalancedTree h f c + -> m (BalancedTree h g c) + go f (BalLeaf x) = BalLeaf <$> f x + go f (BalPair x y) = BalPair <$> go f x <*> go f y +{-# INLINABLE traverse_bal #-} + +instance ShowF f => Show (BalancedTree h f tp) where + show (BalLeaf x) = showF x + show (BalPair x y) = "BalPair " Prelude.++ show x Prelude.++ " " Prelude.++ show y + +instance ShowF f => ShowF (BalancedTree h f) + +unsafe_bal_generate :: forall ctx h f t + . Int -- ^ Height of tree to generate + -> Int -- ^ Starting offset for entries. + -> (forall tp . Index ctx tp -> f tp) + -> BalancedTree h f t +unsafe_bal_generate h o f + | h < 0 = error "unsafe_bal_generate given negative height" + | h == 0 = unsafeCoerce $ BalLeaf (f (Index o)) + | otherwise = + let l = unsafe_bal_generate (h-1) o f + o' = o + 1 `shiftL` (h-1) + u = assert (o + bal_size l == o') $ unsafe_bal_generate (h-1) o' f + in unsafeCoerce $ BalPair l u + +unsafe_bal_generateM :: forall m ctx h f t + . Applicative m + => Int -- ^ Height of tree to generate + -> Int -- ^ Starting offset for entries. + -> (forall x . Index ctx x -> m (f x)) + -> m (BalancedTree h f t) +unsafe_bal_generateM h o f + | h == 0 = unsafeCoerce . BalLeaf <$> f (Index o) + | otherwise = + let o' = o + 1 `shiftL` (h-1) + g lv uv = assert (o' == o + bal_size lv) $ + unsafeCoerce (BalPair lv uv) + in g <$> unsafe_bal_generateM (h-1) o f + <*> unsafe_bal_generateM (h-1) o' f + +-- | Lookup index in tree. +unsafe_bal_index :: BalancedTree h f a -- ^ Tree to lookup. + -> Int -- ^ Index to lookup. + -> Int -- ^ Height of tree + -> f tp +unsafe_bal_index _ j i + | seq j $ seq i $ False = error "bad unsafe_bal_index" +unsafe_bal_index (BalLeaf u) _ i = assert (i == 0) $ unsafeCoerce u +unsafe_bal_index (BalPair x y) j i + | j `testBit` (i-1) = unsafe_bal_index y j $! (i-1) + | otherwise = unsafe_bal_index x j $! (i-1) + +-- | Update value at index in tree. +unsafe_bal_adjust :: Functor m + => (f x -> m (f y)) + -> BalancedTree h f a -- ^ Tree to update + -> Int -- ^ Index to lookup. + -> Int -- ^ Height of tree + -> m (BalancedTree h f b) +unsafe_bal_adjust f (BalLeaf u) _ i = assert (i == 0) $ + (unsafeCoerce . BalLeaf <$> (f (unsafeCoerce u))) +unsafe_bal_adjust f (BalPair x y) j i + | j `testBit` (i-1) = (unsafeCoerce . BalPair x <$> (unsafe_bal_adjust f y j (i-1))) + | otherwise = (unsafeCoerce . flip BalPair y <$> (unsafe_bal_adjust f x j (i-1))) + +{-# SPECIALIZE unsafe_bal_adjust + :: (f x -> Identity (f y)) + -> BalancedTree h f a + -> Int + -> Int + -> Identity (BalancedTree h f b) + #-} + +-- | Zip two balanced trees together. +bal_zipWithM :: Applicative m + => (forall x . f x -> g x -> m (h x)) + -> BalancedTree u f a + -> BalancedTree u g a + -> m (BalancedTree u h a) +bal_zipWithM f (BalLeaf x) (BalLeaf y) = BalLeaf <$> f x y +bal_zipWithM f (BalPair x1 x2) (BalPair y1 y2) = + BalPair <$> bal_zipWithM f x1 (unsafeCoerce y1) + <*> bal_zipWithM f x2 (unsafeCoerce y2) +{-# INLINABLE bal_zipWithM #-} + +------------------------------------------------------------------------ +-- * BinomialTree + +data BinomialTree (h::Height) (f :: k -> Type) :: Ctx k -> Type where + Empty :: BinomialTree h f EmptyCtx + + -- Contains size of the subtree, subtree, then element. + PlusOne :: !Int + -> !(BinomialTree ('Succ h) f x) + -> !(BalancedTree h f y) + -> BinomialTree h f (x <+> y) + + -- Contains size of the subtree, subtree, then element. + PlusZero :: !Int + -> !(BinomialTree ('Succ h) f x) + -> BinomialTree h f x + +tsize :: BinomialTree h f a -> Int +tsize Empty = 0 +tsize (PlusOne s _ _) = 2*s+1 +tsize (PlusZero s _) = 2*s + +t_cnt_size :: BinomialTree h f a -> Int +t_cnt_size Empty = 0 +t_cnt_size (PlusOne _ l r) = t_cnt_size l + bal_size r +t_cnt_size (PlusZero _ l) = t_cnt_size l + +-- | Concatenate a binomial tree and a balanced tree. +append :: BinomialTree h f x + -> BalancedTree h f y + -> BinomialTree h f (x <+> y) +append Empty y = PlusOne 0 Empty y +append (PlusOne _ t x) y = + case assoc t x y of + Refl -> + let t' = append t (BalPair x y) + in PlusZero (tsize t') t' +append (PlusZero s t) x = PlusOne s t x + +instance TestEqualityFC (BinomialTree h) where + testEqualityFC _ Empty Empty = return Refl + testEqualityFC test (PlusZero _ x1) (PlusZero _ y1) = do + Refl <- testEqualityFC test x1 y1 + return Refl + testEqualityFC test (PlusOne _ x1 x2) (PlusOne _ y1 y2) = do + Refl <- testEqualityFC test x1 y1 + Refl <- testEqualityFC test x2 y2 + return Refl + testEqualityFC _ _ _ = Nothing + +instance OrdFC (BinomialTree h) where + compareFC _ Empty Empty = EQF + compareFC _ Empty _ = LTF + compareFC _ _ Empty = GTF + + compareFC test (PlusZero _ x1) (PlusZero _ y1) = + joinOrderingF (compareFC test x1 y1) $ EQF + compareFC _ PlusZero{} _ = LTF + compareFC _ _ PlusZero{} = GTF + + compareFC test (PlusOne _ x1 x2) (PlusOne _ y1 y2) = + joinOrderingF (compareFC test x1 y1) $ + joinOrderingF (compareFC test x2 y2) $ + EQF + +instance HashableF f => HashableF (BinomialTree h f) where + hashWithSaltF s t = + case t of + Empty -> s + PlusZero _ x -> s `hashWithSaltF` x + PlusOne _ x y -> s `hashWithSaltF` x `hashWithSaltF` y + +-- | Map over a binary tree. +fmap_bin :: (forall tp . f tp -> g tp) + -> BinomialTree h f c + -> BinomialTree h g c +fmap_bin _ Empty = Empty +fmap_bin f (PlusOne s t x) = PlusOne s (fmap_bin f t) (fmap_bal f x) +fmap_bin f (PlusZero s t) = PlusZero s (fmap_bin f t) +{-# INLINABLE fmap_bin #-} + +traverse_bin :: Applicative m + => (forall tp . f tp -> m (g tp)) + -> BinomialTree h f c + -> m (BinomialTree h g c) +traverse_bin _ Empty = pure Empty +traverse_bin f (PlusOne s t x) = PlusOne s <$> traverse_bin f t <*> traverse_bal f x +traverse_bin f (PlusZero s t) = PlusZero s <$> traverse_bin f t +{-# INLINABLE traverse_bin #-} + +unsafe_bin_generate :: forall h f ctx t + . Int -- ^ Size of tree to generate + -> Int -- ^ Height of each element. + -> (forall x . Index ctx x -> f x) + -> BinomialTree h f t +unsafe_bin_generate sz h f + | sz == 0 = unsafeCoerce Empty + | sz `testBit` 0 = + let s = sz `shiftR` 1 + t = unsafe_bin_generate s (h+1) f + o = s * 2^(h+1) + u = assert (o == t_cnt_size t) $ unsafe_bal_generate h o f + in unsafeCoerce (PlusOne s t u) + | otherwise = + let s = sz `shiftR` 1 + t = unsafe_bin_generate (sz `shiftR` 1) (h+1) f + r :: BinomialTree h f t + r = PlusZero s t + in r + +unsafe_bin_generateM :: forall m h f ctx t + . Applicative m + => Int -- ^ Size of tree to generate + -> Int -- ^ Height of each element. + -> (forall x . Index ctx x -> m (f x)) + -> m (BinomialTree h f t) +unsafe_bin_generateM sz h f + | sz == 0 = pure (unsafeCoerce Empty) + | sz `testBit` 0 = + let s = sz `shiftR` 1 + t = unsafe_bin_generateM s (h+1) f + -- Next offset + o = s * 2^(h+1) + u = unsafe_bal_generateM h o f + r = unsafeCoerce (PlusOne s) <$> t <*> u + in r + | otherwise = + let s = sz `shiftR` 1 + t = unsafe_bin_generateM s (h+1) f + r :: m (BinomialTree h f t) + r = PlusZero s <$> t + in r + +------------------------------------------------------------------------ +-- Dropping + +data DropResult f (ctx :: Ctx k) where + DropEmpty :: DropResult f EmptyCtx + DropExt :: BinomialTree 'Zero f x + -> f y + -> DropResult f (x ::> y) + +-- | @bal_drop x y@ returns the tree formed @append x (init y)@ +bal_drop :: forall h f x y + . BinomialTree h f x + -- ^ Bina + -> BalancedTree h f y + -> DropResult f (x <+> y) +bal_drop t (BalLeaf e) = DropExt t e +bal_drop t (BalPair x y) = + unsafeCoerce (bal_drop (PlusOne (tsize t) (unsafeCoerce t) x) y) + +bin_drop :: forall h f ctx + . BinomialTree h f ctx + -> DropResult f ctx +bin_drop Empty = DropEmpty +bin_drop (PlusZero _ u) = bin_drop u +bin_drop (PlusOne s t u) = + let m = case t of + Empty -> Empty + _ -> PlusZero s t + in bal_drop m u + +------------------------------------------------------------------------ +-- Indexing + +-- | Lookup value in tree. +unsafe_bin_index :: BinomialTree h f a -- ^ Tree to lookup in. + -> Int + -> Int -- ^ Size of tree + -> f u +unsafe_bin_index _ _ i + | seq i False = error "bad unsafe_bin_index" +unsafe_bin_index Empty _ _ = error "unsafe_bin_index reached end of list" +unsafe_bin_index (PlusOne sz t u) j i + | sz == j `shiftR` (1+i) = unsafe_bal_index u j i + | otherwise = unsafe_bin_index t j $! (1+i) +unsafe_bin_index (PlusZero sz t) j i + | sz == j `shiftR` (1+i) = error "unsafe_bin_index stopped at PlusZero" + | otherwise = unsafe_bin_index t j $! (1+i) + +-- | Lookup value in tree. +unsafe_bin_adjust :: forall m h f x y a b + . Functor m + => (f x -> m (f y)) + -> BinomialTree h f a -- ^ Tree to lookup in. + -> Int + -> Int -- ^ Size of tree + -> m (BinomialTree h f b) +unsafe_bin_adjust _ Empty _ _ = error "unsafe_bin_adjust reached end of list" +unsafe_bin_adjust f (PlusOne sz t u) j i + | sz == j `shiftR` (1+i) = + unsafeCoerce . PlusOne sz t <$> (unsafe_bal_adjust f u j i) + | otherwise = + unsafeCoerce . flip (PlusOne sz) u <$> (unsafe_bin_adjust f t j (i+1)) +unsafe_bin_adjust f (PlusZero sz t) j i + | sz == j `shiftR` (1+i) = error "unsafe_bin_adjust stopped at PlusZero" + | otherwise = PlusZero sz <$> (unsafe_bin_adjust f t j (i+1)) + + +{-# SPECIALIZE unsafe_bin_adjust + :: (f x -> Identity (f y)) + -> BinomialTree h f a + -> Int + -> Int + -> Identity (BinomialTree h f b) + #-} + +tree_zipWithM :: Applicative m + => (forall x . f x -> g x -> m (h x)) + -> BinomialTree u f a + -> BinomialTree u g a + -> m (BinomialTree u h a) +tree_zipWithM _ Empty Empty = pure Empty +tree_zipWithM f (PlusOne s x1 x2) (PlusOne _ y1 y2) = + PlusOne s <$> tree_zipWithM f x1 (unsafeCoerce y1) + <*> bal_zipWithM f x2 (unsafeCoerce y2) +tree_zipWithM f (PlusZero s x1) (PlusZero _ y1) = + PlusZero s <$> tree_zipWithM f x1 y1 +tree_zipWithM _ _ _ = error "ilegal args to tree_zipWithM" +{-# INLINABLE tree_zipWithM #-} + +------------------------------------------------------------------------ +-- * Assignment + +-- | An assignment is a sequence that maps each index with type @tp@ to +-- a value of type @f tp@. +-- +-- This assignment implementation uses a binomial tree implementation +-- that offers lookups and updates in time and space logarithmic with +-- respect to the number of elements in the context. +newtype Assignment (f :: k -> Type) (ctx :: Ctx k) + = Assignment (BinomialTree 'Zero f ctx) + +type role Assignment nominal nominal + +instance NFData (Assignment f ctx) where + rnf a = seq a () + +-- | Return number of elements in assignment. +size :: Assignment f ctx -> Size ctx +size (Assignment t) = Size (tsize t) + +-- | @replicate n@ make a context with different copies of the same +-- polymorphic value. +replicate :: Size ctx -> (forall tp . f tp) -> Assignment f ctx +replicate n c = generate n (\_ -> c) + +-- | Generate an assignment +generate :: Size ctx + -> (forall tp . Index ctx tp -> f tp) + -> Assignment f ctx +generate n f = Assignment r + where r = unsafe_bin_generate (sizeInt n) 0 f +{-# NOINLINE generate #-} + +-- | Generate an assignment in an 'Applicative' context +generateM :: Applicative m + => Size ctx + -> (forall tp . Index ctx tp -> m (f tp)) + -> m (Assignment f ctx) +generateM n f = Assignment <$> unsafe_bin_generateM (sizeInt n) 0 f +{-# NOINLINE generateM #-} + +-- | Return empty assignment +empty :: Assignment f EmptyCtx +empty = Assignment Empty + +-- n.b. see 'singleton' in Data/Parameterized/Context.hs + +-- | Extend an indexed vector with a new entry. +extend :: Assignment f ctx -> f x -> Assignment f (ctx ::> x) +extend (Assignment x) y = Assignment $ append x (BalLeaf y) + +-- | Unexported index that returns an arbitrary type of expression. +unsafeIndex :: proxy u -> Int -> Assignment f ctx -> f u +unsafeIndex _ idx (Assignment t) = seq t $ unsafe_bin_index t idx 0 + +-- | Return value of assignment. +(!) :: Assignment f ctx -> Index ctx tp -> f tp +a ! Index i = assert (0 <= i && i < sizeInt (size a)) $ + unsafeIndex Proxy i a + +-- | Return value of assignment, where the index is into an +-- initial sequence of the assignment. +(!^) :: KnownDiff l r => Assignment f r -> Index l tp -> f tp +a !^ i = a ! extendIndex i + +instance TestEqualityFC Assignment where + testEqualityFC test (Assignment x) (Assignment y) = do + Refl <- testEqualityFC test x y + return Refl + +instance TestEquality f => TestEquality (Assignment f) where + testEquality = testEqualityFC testEquality + +instance TestEquality f => Eq (Assignment f ctx) where + x == y = isJust (testEquality x y) + +instance OrdFC Assignment where + compareFC test (Assignment x) (Assignment y) = + joinOrderingF (compareFC test x y) $ EQF + +instance OrdF f => OrdF (Assignment f) where + compareF = compareFC compareF + +instance OrdF f => Ord (Assignment f ctx) where + compare x y = toOrdering (compareF x y) + +instance HashableF (Index ctx) where + hashWithSaltF s i = hashWithSalt s (indexVal i) + +instance Hashable (Index ctx tp) where + hashWithSalt = hashWithSaltF + +instance (HashableF f, TestEquality f) => Hashable (Assignment f ctx) where + hashWithSalt s (Assignment a) = hashWithSaltF s a + +instance (HashableF f, TestEquality f) => HashableF (Assignment f) where + hashWithSaltF = hashWithSalt + +instance ShowF f => Show (Assignment f ctx) where + show a = "[" Prelude.++ intercalate ", " (toListFC showF a) Prelude.++ "]" + +instance ShowF f => ShowF (Assignment f) + +{-# DEPRECATED adjust "Replace 'adjust f i asgn' with 'Lens.over (ixF i) f asgn' instead." #-} +adjust :: (f tp -> f tp) -> Index ctx tp -> Assignment f ctx -> Assignment f ctx +adjust f idx asgn = runIdentity (adjustM (Identity . f) idx asgn) + +{-# DEPRECATED update "Replace 'update idx val asgn' with 'Lens.set (ixF idx) val asgn' instead." #-} +update :: Index ctx tp -> f tp -> Assignment f ctx -> Assignment f ctx +update i v a = adjust (\_ -> v) i a + +-- | Modify the value of an assignment at a particular index. +adjustM :: Functor m => (f tp -> m (f tp)) -> Index ctx tp -> Assignment f ctx -> m (Assignment f ctx) +adjustM f (Index i) (Assignment a) = Assignment <$> (unsafe_bin_adjust f a i 0) +{-# SPECIALIZE adjustM :: (f tp -> Identity (f tp)) -> Index ctx tp -> Assignment f ctx -> Identity (Assignment f ctx) #-} + +type instance IndexF (Assignment f ctx) = Index ctx +type instance IxValueF (Assignment f ctx) = f + +instance forall k (f :: k -> Type) ctx. IxedF' k (Assignment (f :: k -> Type) ctx) where + ixF' :: Index ctx x -> Lens.Lens' (Assignment f ctx) (f x) + ixF' idx f = adjustM f idx + +instance forall k (f :: k -> Type) ctx. IxedF k (Assignment f ctx) where + ixF idx = ixF' idx + +-- This is an unsafe version of update that changes the type of the expression. +unsafeUpdate :: Int -> Assignment f ctx -> f u -> Assignment f ctx' +unsafeUpdate i (Assignment a) e = Assignment (runIdentity (unsafe_bin_adjust (\_ -> Identity e) a i 0)) + +-- | Represent an assignment as either empty or an assignment with one appended. +data AssignView f ctx where + AssignEmpty :: AssignView f EmptyCtx + AssignExtend :: Assignment f ctx + -> f tp + -> AssignView f (ctx::>tp) + +-- | View an assignment as either empty or an assignment with one appended. +viewAssign :: forall f ctx . Assignment f ctx -> AssignView f ctx +viewAssign (Assignment x) = + case bin_drop x of + DropEmpty -> AssignEmpty + DropExt t v -> AssignExtend (Assignment t) v + +zipWith :: (forall x . f x -> g x -> h x) + -> Assignment f a + -> Assignment g a + -> Assignment h a +zipWith f = \x y -> runIdentity $ zipWithM (\u v -> pure (f u v)) x y +{-# INLINE zipWith #-} + +zipWithM :: Applicative m + => (forall x . f x -> g x -> m (h x)) + -> Assignment f a + -> Assignment g a + -> m (Assignment h a) +zipWithM f (Assignment x) (Assignment y) = Assignment <$> tree_zipWithM f x y +{-# INLINABLE zipWithM #-} + +instance FunctorFC Assignment where + fmapFC = \f (Assignment x) -> Assignment (fmap_bin f x) + {-# INLINE fmapFC #-} + +instance FoldableFC Assignment where + foldMapFC = foldMapFCDefault + {-# INLINE foldMapFC #-} + +instance TraversableFC Assignment where + traverseFC = \f (Assignment x) -> Assignment <$> traverse_bin f x + {-# INLINE traverseFC #-} + +instance FunctorFCWithIndex Assignment where + imapFC = imapFCDefault + +instance FoldableFCWithIndex Assignment where + ifoldMapFC = ifoldMapFCDefault + +instance TraversableFCWithIndex Assignment where + itraverseFC = traverseWithIndex + + +traverseWithIndex :: Applicative m + => (forall tp . Index ctx tp -> f tp -> m (g tp)) + -> Assignment f ctx + -> m (Assignment g ctx) +traverseWithIndex f a = generateM (size a) $ \i -> f i (a ! i) + +------------------------------------------------------------------------ +-- Appending + +appendBal :: Assignment f x -> BalancedTree h f y -> Assignment f (x <+> y) +appendBal x (BalLeaf a) = x `extend` a +appendBal x (BalPair y z) = + case assoc x y z of + Refl -> x `appendBal` y `appendBal` z + +appendBin :: Assignment f x -> BinomialTree h f y -> Assignment f (x <+> y) +appendBin x Empty = x +appendBin x (PlusOne _ y z) = + case assoc x y z of + Refl -> x `appendBin` y `appendBal` z +appendBin x (PlusZero _ y) = x `appendBin` y + +(<++>) :: Assignment f x -> Assignment f y -> Assignment f (x <+> y) +x <++> Assignment y = x `appendBin` y + +------------------------------------------------------------------------ +-- KnownRepr instances + +instance (KnownRepr (Assignment f) ctx, KnownRepr f bt) + => KnownRepr (Assignment f) (ctx ::> bt) where + knownRepr = knownRepr `extend` knownRepr + +instance KnownRepr (Assignment f) EmptyCtx where + knownRepr = empty + +------------------------------------------------------------------------ +-- Lens combinators + +unsafeLens :: Int -> Lens.Lens (Assignment f ctx) (Assignment f ctx') (f tp) (f u) +unsafeLens idx = + Lens.lens (unsafeIndex Proxy idx) (unsafeUpdate idx) + +------------------------------------------------------------------------ +-- 1 field lens combinators + +type Assignment1 f x1 = Assignment f ('EmptyCtx '::> x1) + +instance Lens.Field1 (Assignment1 f t) (Assignment1 f u) (f t) (f u) where + _1 = unsafeLens 0 + +------------------------------------------------------------------------ +-- 2 field lens combinators + +type Assignment2 f x1 x2 + = Assignment f ('EmptyCtx '::> x1 '::> x2) + +instance Lens.Field1 (Assignment2 f t x2) (Assignment2 f u x2) (f t) (f u) where + _1 = unsafeLens 0 + +instance Lens.Field2 (Assignment2 f x1 t) (Assignment2 f x1 u) (f t) (f u) where + _2 = unsafeLens 1 + +------------------------------------------------------------------------ +-- 3 field lens combinators + +type Assignment3 f x1 x2 x3 + = Assignment f ('EmptyCtx '::> x1 '::> x2 '::> x3) + +instance Lens.Field1 (Assignment3 f t x2 x3) + (Assignment3 f u x2 x3) + (f t) + (f u) where + _1 = unsafeLens 0 + + +instance Lens.Field2 (Assignment3 f x1 t x3) + (Assignment3 f x1 u x3) + (f t) + (f u) where + _2 = unsafeLens 1 + +instance Lens.Field3 (Assignment3 f x1 x2 t) + (Assignment3 f x1 x2 u) + (f t) + (f u) where + _3 = unsafeLens 2 + +------------------------------------------------------------------------ +-- 4 field lens combinators + +type Assignment4 f x1 x2 x3 x4 + = Assignment f ('EmptyCtx '::> x1 '::> x2 '::> x3 '::> x4) + +instance Lens.Field1 (Assignment4 f t x2 x3 x4) + (Assignment4 f u x2 x3 x4) + (f t) + (f u) where + _1 = unsafeLens 0 + + +instance Lens.Field2 (Assignment4 f x1 t x3 x4) + (Assignment4 f x1 u x3 x4) + (f t) + (f u) where + _2 = unsafeLens 1 + +instance Lens.Field3 (Assignment4 f x1 x2 t x4) + (Assignment4 f x1 x2 u x4) + (f t) + (f u) where + _3 = unsafeLens 2 + +instance Lens.Field4 (Assignment4 f x1 x2 x3 t) + (Assignment4 f x1 x2 x3 u) + (f t) + (f u) where + _4 = unsafeLens 3 + +------------------------------------------------------------------------ +-- 5 field lens combinators + +type Assignment5 f x1 x2 x3 x4 x5 + = Assignment f ('EmptyCtx '::> x1 '::> x2 '::> x3 '::> x4 '::> x5) + +instance Lens.Field1 (Assignment5 f t x2 x3 x4 x5) + (Assignment5 f u x2 x3 x4 x5) + (f t) + (f u) where + _1 = unsafeLens 0 + +instance Lens.Field2 (Assignment5 f x1 t x3 x4 x5) + (Assignment5 f x1 u x3 x4 x5) + (f t) + (f u) where + _2 = unsafeLens 1 + +instance Lens.Field3 (Assignment5 f x1 x2 t x4 x5) + (Assignment5 f x1 x2 u x4 x5) + (f t) + (f u) where + _3 = unsafeLens 2 + +instance Lens.Field4 (Assignment5 f x1 x2 x3 t x5) + (Assignment5 f x1 x2 x3 u x5) + (f t) + (f u) where + _4 = unsafeLens 3 + +instance Lens.Field5 (Assignment5 f x1 x2 x3 x4 t) + (Assignment5 f x1 x2 x3 x4 u) + (f t) + (f u) where + _5 = unsafeLens 4 + +------------------------------------------------------------------------ +-- 6 field lens combinators + +type Assignment6 f x1 x2 x3 x4 x5 x6 + = Assignment f ('EmptyCtx '::> x1 '::> x2 '::> x3 '::> x4 '::> x5 '::> x6) + +instance Lens.Field1 (Assignment6 f t x2 x3 x4 x5 x6) + (Assignment6 f u x2 x3 x4 x5 x6) + (f t) + (f u) where + _1 = unsafeLens 0 + + +instance Lens.Field2 (Assignment6 f x1 t x3 x4 x5 x6) + (Assignment6 f x1 u x3 x4 x5 x6) + (f t) + (f u) where + _2 = unsafeLens 1 + +instance Lens.Field3 (Assignment6 f x1 x2 t x4 x5 x6) + (Assignment6 f x1 x2 u x4 x5 x6) + (f t) + (f u) where + _3 = unsafeLens 2 + +instance Lens.Field4 (Assignment6 f x1 x2 x3 t x5 x6) + (Assignment6 f x1 x2 x3 u x5 x6) + (f t) + (f u) where + _4 = unsafeLens 3 + +instance Lens.Field5 (Assignment6 f x1 x2 x3 x4 t x6) + (Assignment6 f x1 x2 x3 x4 u x6) + (f t) + (f u) where + _5 = unsafeLens 4 + +instance Lens.Field6 (Assignment6 f x1 x2 x3 x4 x5 t) + (Assignment6 f x1 x2 x3 x4 x5 u) + (f t) + (f u) where + _6 = unsafeLens 5 + +------------------------------------------------------------------------ +-- 7 field lens combinators + +type Assignment7 f x1 x2 x3 x4 x5 x6 x7 + = Assignment f ('EmptyCtx '::> x1 '::> x2 '::> x3 '::> x4 '::> x5 '::> x6 '::> x7) + +instance Lens.Field1 (Assignment7 f t x2 x3 x4 x5 x6 x7) + (Assignment7 f u x2 x3 x4 x5 x6 x7) + (f t) + (f u) where + _1 = unsafeLens 0 + + +instance Lens.Field2 (Assignment7 f x1 t x3 x4 x5 x6 x7) + (Assignment7 f x1 u x3 x4 x5 x6 x7) + (f t) + (f u) where + _2 = unsafeLens 1 + +instance Lens.Field3 (Assignment7 f x1 x2 t x4 x5 x6 x7) + (Assignment7 f x1 x2 u x4 x5 x6 x7) + (f t) + (f u) where + _3 = unsafeLens 2 + +instance Lens.Field4 (Assignment7 f x1 x2 x3 t x5 x6 x7) + (Assignment7 f x1 x2 x3 u x5 x6 x7) + (f t) + (f u) where + _4 = unsafeLens 3 + +instance Lens.Field5 (Assignment7 f x1 x2 x3 x4 t x6 x7) + (Assignment7 f x1 x2 x3 x4 u x6 x7) + (f t) + (f u) where + _5 = unsafeLens 4 + +instance Lens.Field6 (Assignment7 f x1 x2 x3 x4 x5 t x7) + (Assignment7 f x1 x2 x3 x4 x5 u x7) + (f t) + (f u) where + _6 = unsafeLens 5 + +instance Lens.Field7 (Assignment7 f x1 x2 x3 x4 x5 x6 t) + (Assignment7 f x1 x2 x3 x4 x5 x6 u) + (f t) + (f u) where + _7 = unsafeLens 6 + +------------------------------------------------------------------------ +-- 8 field lens combinators + +type Assignment8 f x1 x2 x3 x4 x5 x6 x7 x8 + = Assignment f ('EmptyCtx '::> x1 '::> x2 '::> x3 '::> x4 '::> x5 '::> x6 '::> x7 '::> x8) + +instance Lens.Field1 (Assignment8 f t x2 x3 x4 x5 x6 x7 x8) + (Assignment8 f u x2 x3 x4 x5 x6 x7 x8) + (f t) + (f u) where + _1 = unsafeLens 0 + + +instance Lens.Field2 (Assignment8 f x1 t x3 x4 x5 x6 x7 x8) + (Assignment8 f x1 u x3 x4 x5 x6 x7 x8) + (f t) + (f u) where + _2 = unsafeLens 1 + +instance Lens.Field3 (Assignment8 f x1 x2 t x4 x5 x6 x7 x8) + (Assignment8 f x1 x2 u x4 x5 x6 x7 x8) + (f t) + (f u) where + _3 = unsafeLens 2 + +instance Lens.Field4 (Assignment8 f x1 x2 x3 t x5 x6 x7 x8) + (Assignment8 f x1 x2 x3 u x5 x6 x7 x8) + (f t) + (f u) where + _4 = unsafeLens 3 + +instance Lens.Field5 (Assignment8 f x1 x2 x3 x4 t x6 x7 x8) + (Assignment8 f x1 x2 x3 x4 u x6 x7 x8) + (f t) + (f u) where + _5 = unsafeLens 4 + +instance Lens.Field6 (Assignment8 f x1 x2 x3 x4 x5 t x7 x8) + (Assignment8 f x1 x2 x3 x4 x5 u x7 x8) + (f t) + (f u) where + _6 = unsafeLens 5 + +instance Lens.Field7 (Assignment8 f x1 x2 x3 x4 x5 x6 t x8) + (Assignment8 f x1 x2 x3 x4 x5 x6 u x8) + (f t) + (f u) where + _7 = unsafeLens 6 + +instance Lens.Field8 (Assignment8 f x1 x2 x3 x4 x5 x6 x7 t) + (Assignment8 f x1 x2 x3 x4 x5 x6 x7 u) + (f t) + (f u) where + _8 = unsafeLens 7 + +------------------------------------------------------------------------ +-- 9 field lens combinators + +type Assignment9 f x1 x2 x3 x4 x5 x6 x7 x8 x9 + = Assignment f ('EmptyCtx '::> x1 '::> x2 '::> x3 '::> x4 '::> x5 '::> x6 '::> x7 '::> x8 '::> x9) + + +instance Lens.Field1 (Assignment9 f t x2 x3 x4 x5 x6 x7 x8 x9) + (Assignment9 f u x2 x3 x4 x5 x6 x7 x8 x9) + (f t) + (f u) where + _1 = unsafeLens 0 + +instance Lens.Field2 (Assignment9 f x1 t x3 x4 x5 x6 x7 x8 x9) + (Assignment9 f x1 u x3 x4 x5 x6 x7 x8 x9) + (f t) + (f u) where + _2 = unsafeLens 1 + +instance Lens.Field3 (Assignment9 f x1 x2 t x4 x5 x6 x7 x8 x9) + (Assignment9 f x1 x2 u x4 x5 x6 x7 x8 x9) + (f t) + (f u) where + _3 = unsafeLens 2 + +instance Lens.Field4 (Assignment9 f x1 x2 x3 t x5 x6 x7 x8 x9) + (Assignment9 f x1 x2 x3 u x5 x6 x7 x8 x9) + (f t) + (f u) where + _4 = unsafeLens 3 + +instance Lens.Field5 (Assignment9 f x1 x2 x3 x4 t x6 x7 x8 x9) + (Assignment9 f x1 x2 x3 x4 u x6 x7 x8 x9) + (f t) + (f u) where + _5 = unsafeLens 4 + +instance Lens.Field6 (Assignment9 f x1 x2 x3 x4 x5 t x7 x8 x9) + (Assignment9 f x1 x2 x3 x4 x5 u x7 x8 x9) + (f t) + (f u) where + _6 = unsafeLens 5 + +instance Lens.Field7 (Assignment9 f x1 x2 x3 x4 x5 x6 t x8 x9) + (Assignment9 f x1 x2 x3 x4 x5 x6 u x8 x9) + (f t) + (f u) where + _7 = unsafeLens 6 + +instance Lens.Field8 (Assignment9 f x1 x2 x3 x4 x5 x6 x7 t x9) + (Assignment9 f x1 x2 x3 x4 x5 x6 x7 u x9) + (f t) + (f u) where + _8 = unsafeLens 7 + +instance Lens.Field9 (Assignment9 f x1 x2 x3 x4 x5 x6 x7 x8 t) + (Assignment9 f x1 x2 x3 x4 x5 x6 x7 x8 u) + (f t) + (f u) where + _9 = unsafeLens 8 diff --git a/src/Data/Parameterized/Ctx.hs b/src/Data/Parameterized/Ctx.hs new file mode 100644 index 0000000..f48eab2 --- /dev/null +++ b/src/Data/Parameterized/Ctx.hs @@ -0,0 +1,109 @@ +{-| +Description : Type-level lists. +Copyright : (c) Galois, Inc 2015-2019 +Maintainer : Joe Hendrix + +This module defines type-level lists used for representing the type of +variables in a context. + +A 'Ctx' is never intended to be manipulated at the value level; it is +used purely as a type-level list, just like @'[]@. To see how it is +used, see the module header for "Data.Parameterized.Context". +-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module Data.Parameterized.Ctx + ( type Ctx(..) + , EmptyCtx + , SingleCtx + , (::>) + , type (<+>) + + -- * Type context manipulation + , CtxSize + , CtxLookup + , CtxUpdate + , CtxLookupRight + , CtxUpdateRight + , CtxFlatten + , CheckIx + , ValidIx + , FromLeft + ) where + +import Data.Kind (Constraint) +import GHC.TypeLits (Nat, type (+), type (-), type (<=?), TypeError, ErrorMessage(..)) + +------------------------------------------------------------------------ +-- Ctx + +type EmptyCtx = 'EmptyCtx +type (c :: Ctx k) ::> (a::k) = c '::> a + +type SingleCtx x = EmptyCtx ::> x + +-- | Kind @'Ctx' k@ comprises lists of types of kind @k@. +data Ctx k + = EmptyCtx + | Ctx k ::> k + +-- | Append two type-level contexts. +type family (<+>) (x :: Ctx k) (y :: Ctx k) :: Ctx k where + x <+> EmptyCtx = x + x <+> (y ::> e) = (x <+> y) ::> e + + +-- | This type family computes the number of elements in a 'Ctx' +type family CtxSize (a :: Ctx k) :: Nat where + CtxSize 'EmptyCtx = 0 + CtxSize (xs '::> x) = 1 + CtxSize xs + +-- | Helper type family used to generate descriptive error messages when +-- an index is larger than the length of the 'Ctx' being indexed. +type family CheckIx (ctx :: Ctx k) (n :: Nat) (b :: Bool) :: Constraint where + CheckIx ctx n 'True = () + CheckIx ctx n 'False = TypeError ('Text "Index " ':<>: 'ShowType n + ':<>: 'Text " out of range in " ':<>: 'ShowType ctx) + +-- | A constraint that checks that the nat @n@ is a valid index into the +-- context @ctx@, and raises a type error if not. +type ValidIx (n :: Nat) (ctx :: Ctx k) + = CheckIx ctx n (n+1 <=? CtxSize ctx) + +-- | 'Ctx' is a snoc-list. In order to use the more intuitive left-to-right +-- ordering of elements the desired index is subtracted from the total +-- number of elements. +type FromLeft ctx n = CtxSize ctx - 1 - n + +-- | Lookup the value in a context by number, from the right +type family CtxLookupRight (n :: Nat) (ctx :: Ctx k) :: k where + CtxLookupRight 0 (ctx '::> r) = r + CtxLookupRight n (ctx '::> r) = CtxLookupRight (n-1) ctx + +-- | Update the value in a context by number, from the right. If the index +-- is out of range, the context is unchanged. +type family CtxUpdateRight (n :: Nat) (x::k) (ctx :: Ctx k) :: Ctx k where + CtxUpdateRight n x 'EmptyCtx = 'EmptyCtx + CtxUpdateRight 0 x (ctx '::> old) = ctx '::> x + CtxUpdateRight n x (ctx '::> y) = CtxUpdateRight (n-1) x ctx '::> y + +-- | Lookup the value in a context by number, from the left. +-- Produce a type error if the index is out of range. +type CtxLookup (n :: Nat) (ctx :: Ctx k) + = CtxLookupRight (FromLeft ctx n) ctx + +-- | Update the value in a context by number, from the left. If the index +-- is out of range, the context is unchanged. +type CtxUpdate (n :: Nat) (x :: k) (ctx :: Ctx k) + = CtxUpdateRight (FromLeft ctx n) x ctx + +-- | Flatten a nested context +type family CtxFlatten (ctx :: Ctx (Ctx a)) :: Ctx a where + CtxFlatten EmptyCtx = EmptyCtx + CtxFlatten (ctxs ::> ctx) = CtxFlatten ctxs <+> ctx diff --git a/src/Data/Parameterized/Ctx/Proofs.hs b/src/Data/Parameterized/Ctx/Proofs.hs new file mode 100644 index 0000000..ec59ff5 --- /dev/null +++ b/src/Data/Parameterized/Ctx/Proofs.hs @@ -0,0 +1,24 @@ +{-| +Description : type-level proofs involving contexts +Copyright : (c) Galois, Inc 2015-2019 +Maintainer : Joe Hendrix + +This reflects type level proofs involving contexts. +-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeOperators #-} +module Data.Parameterized.Ctx.Proofs + ( leftId + , assoc + ) where + +import Data.Type.Equality + +import Data.Parameterized.Axiom +import Data.Parameterized.Ctx + +leftId :: p x -> (EmptyCtx <+> x) :~: x +leftId _ = unsafeAxiom + +assoc :: p x -> q y -> r z -> x <+> (y <+> z) :~: (x <+> y) <+> z +assoc _ _ _ = unsafeAxiom diff --git a/src/Data/Parameterized/DataKind.hs b/src/Data/Parameterized/DataKind.hs new file mode 100644 index 0000000..b826c33 --- /dev/null +++ b/src/Data/Parameterized/DataKind.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Data.Parameterized.DataKind + ( PairRepr(..), Fst, Snd, fst, snd + ) where + +import Data.Parameterized.Classes +import qualified Data.Parameterized.TH.GADT as TH + +import Data.Kind +import Prelude hiding ( fst, snd ) + +data PairRepr (f :: k1 -> Type) (g :: k2 -> Type) (p :: (k1, k2)) where + PairRepr :: f a -> g b -> PairRepr f g '(a, b) + +type family Fst (pair :: (k1, k2)) where + Fst '(a, _) = a +type family Snd (pair :: (k1, k2)) where + Snd '(_, b) = b + +fst :: PairRepr f g p -> f (Fst p) +fst (PairRepr a _) = a + +snd :: PairRepr f g p -> g (Snd p) +snd (PairRepr _ b) = b + +$(return []) + +instance ( ShowF f, ShowF g ) => Show (PairRepr f g p) where + show (PairRepr a b) = showChar '(' . showsF a . showChar ',' . showsF b $ ")" +instance ( ShowF f, ShowF g ) => ShowF (PairRepr f g) + +deriving instance ( Eq (f a), Eq (g b) ) => Eq (PairRepr f g '(a, b)) +instance ( TestEquality f, TestEquality g ) => TestEquality (PairRepr f g) where + testEquality = + $(TH.structuralTypeEquality [t|PairRepr|] + [ + ( TH.DataArg 0 `TH.TypeApp` TH.AnyType, [|testEquality|] ) + , ( TH.DataArg 1 `TH.TypeApp` TH.AnyType, [|testEquality|] ) + ]) + +deriving instance ( Ord (f a), Ord (g b) ) => Ord (PairRepr f g '(a, b)) +instance ( OrdF f, OrdF g ) => OrdF (PairRepr f g) where + compareF = + $(TH.structuralTypeOrd [t|PairRepr|] + [ ( TH.DataArg 0 `TH.TypeApp` TH.AnyType, [|compareF|] ) + , ( TH.DataArg 1 `TH.TypeApp` TH.AnyType, [|compareF|] ) + ]) diff --git a/src/Data/Parameterized/DecidableEq.hs b/src/Data/Parameterized/DecidableEq.hs new file mode 100644 index 0000000..083db0f --- /dev/null +++ b/src/Data/Parameterized/DecidableEq.hs @@ -0,0 +1,41 @@ +{-| +Description : Decideable equality (i.e. evidence of non-equality) on type families +Copyright : (c) Galois, Inc 2014-2019 +Maintainer : Langston Barrett + +This defines a class @DecidableEq@, which represents decidable equality on a +type family. + +This is different from GHC's @TestEquality@ in that it provides evidence +of non-equality. In fact, it is a superclass of @TestEquality@. +-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE Safe #-} +#if __GLASGOW_HASKELL__ < 806 +{-# LANGUAGE TypeInType #-} +#endif +module Data.Parameterized.DecidableEq + ( DecidableEq(..) + ) where + +import Data.Void (Void) +import Data.Type.Equality ((:~:)) + +-- | Decidable equality. +class DecidableEq f where + decEq :: f a -> f b -> Either (a :~: b) ((a :~: b) -> Void) + +-- TODO: instances for sums, products of types with decidable equality + +-- import Data.Type.Equality ((:~:), TestEquality(..)) +-- instance (DecidableEq f) => TestEquality f where +-- testEquality a b = +-- case decEq a b of +-- Left prf -> Just prf +-- Right _ -> Nothing diff --git a/src/Data/Parameterized/Fin.hs b/src/Data/Parameterized/Fin.hs new file mode 100644 index 0000000..eaa48ce --- /dev/null +++ b/src/Data/Parameterized/Fin.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Copyright : (c) Galois, Inc 2021 + +@'Fin' n@ is a finite type with exactly @n@ elements. Essentially, they bundle a +'NatRepr' that has an existentially-quantified type parameter with a proof that +its parameter is less than some fixed natural. + +They are useful in combination with types of a fixed size. For example 'Fin' is +used as the index in the 'Data.Functor.WithIndex.FunctorWithIndex' instance for +'Data.Parameterized.Vector'. As another example, a @Map ('Fin' n) a@ is a @Map@ +that naturally has a fixed size bound of @n@. +-} +module Data.Parameterized.Fin + ( Fin + , mkFin + , buildFin + , countFin + , viewFin + , finToNat + , embed + , tryEmbed + , minFin + , incFin + , fin0Void + , fin1Unit + , fin2Bool + ) where + +import Control.Lens.Iso (Iso', iso) +import GHC.TypeNats (KnownNat) +import Numeric.Natural (Natural) +import Data.Void (Void, absurd) + +import Data.Parameterized.NatRepr + +-- | The type @'Fin' n@ has exactly @n@ inhabitants. +data Fin n = + -- GHC 8.6 and 8.4 require parentheses around 'i + 1 <= n' + forall i. (i + 1 <= n) => Fin { _getFin :: NatRepr i } + +instance Eq (Fin n) where + i == j = finToNat i == finToNat j + +instance Ord (Fin n) where + compare i j = compare (finToNat i) (finToNat j) + +instance (1 <= n, KnownNat n) => Bounded (Fin n) where + minBound = Fin (knownNat @0) + maxBound = + case minusPlusCancel (knownNat @n) (knownNat @1) of + Refl -> Fin (decNat (knownNat @n)) + +-- | Non-lawful instance, intended only for testing. +instance Show (Fin n) where + show i = "Fin " ++ show (finToNat i) + +mkFin :: forall i n. (i + 1 <= n) => NatRepr i -> Fin n +mkFin = Fin +{-# INLINE mkFin #-} + +newtype Fin' n = Fin' { getFin' :: Fin (n + 1) } + +buildFin :: + forall m. + NatRepr m -> + (forall n. (n + 1 <= m) => NatRepr n -> Fin (n + 1) -> Fin (n + 1 + 1)) -> + Fin (m + 1) +buildFin m f = + let f' :: forall k. (k + 1 <= m) => NatRepr k -> Fin' k -> Fin' (k + 1) + f' = (\n (Fin' fin) -> Fin' (f n fin)) + in getFin' (natRecStrictlyBounded m (Fin' minFin) f') + +-- | Count all of the numbers up to @m@ that meet some condition. +countFin :: + NatRepr m -> + (forall n. (n + 1 <= m) => NatRepr n -> Fin (n + 1) -> Bool) -> + Fin (m + 1) +countFin m f = + buildFin m $ + \n count -> + if f n count + then incFin count + else case leqSucc count of + LeqProof -> embed count + +viewFin :: (forall i. (i + 1 <= n) => NatRepr i -> r) -> Fin n -> r +viewFin f (Fin i) = f i + +finToNat :: Fin n -> Natural +finToNat (Fin i) = natValue i +{-# INLINABLE finToNat #-} + +embed :: forall n m. (n <= m) => Fin n -> Fin m +embed = + viewFin + (\(x :: NatRepr o) -> + case leqTrans (LeqProof :: LeqProof (o + 1) n) (LeqProof :: LeqProof n m) of + LeqProof -> Fin x + ) + +tryEmbed :: NatRepr n -> NatRepr m -> Fin n -> Maybe (Fin m) +tryEmbed n m i = + case testLeq n m of + Just LeqProof -> Just (embed i) + Nothing -> Nothing + +-- | The smallest element of @'Fin' n@ +minFin :: (1 <= n) => Fin n +minFin = Fin (knownNat @0) +{-# INLINABLE minFin #-} + +incFin :: forall n. Fin n -> Fin (n + 1) +incFin (Fin (i :: NatRepr i)) = + case leqAdd2 (LeqProof :: LeqProof (i + 1) n) (LeqProof :: LeqProof 1 1) of + LeqProof -> mkFin (incNat i) + +fin0Void :: Iso' (Fin 0) Void +fin0Void = + iso + (viewFin + (\(x :: NatRepr o) -> + case plusComm x (knownNat @1) of + Refl -> + case addIsLeqLeft1 @1 @o @0 LeqProof of {})) + absurd + +fin1Unit :: Iso' (Fin 1) () +fin1Unit = iso (const ()) (const minFin) + +fin2Bool :: Iso' (Fin 2) Bool +fin2Bool = + iso + (viewFin + (\n -> + case isZeroNat n of + ZeroNat -> False + NonZeroNat -> True)) + (\b -> if b then maxBound else minBound) diff --git a/src/Data/Parameterized/FinMap.hs b/src/Data/Parameterized/FinMap.hs new file mode 100644 index 0000000..d95b40b --- /dev/null +++ b/src/Data/Parameterized/FinMap.hs @@ -0,0 +1,79 @@ +{-| +Copyright : (c) Galois, Inc 2022 + +@'FinMap' n a@ conceptually (see NOTE) a map with @'Data.Parameterized.Fin.Fin' +n@ keys, implying a maximum size of @n@. Here's how 'FinMap' compares to other +map-like types: + +* @'FinMap' n a@ is conceptually isomorphic to a + @'Data.Parameterized.Vector' n ('Maybe' a)@, but can be more space-efficient + especially if @n@ is large and the vector is populated with a small number of + 'Just' values. +* @'FinMap'@ is less general than 'Data.Map.Map', because it has a fixed key + type (@'Data.Parameterized.Fin.Fin' n@). +* @'FinMap' n a@ is similar to @'Data.IntMap.IntMap' a@, but it provides a + static guarantee of a maximum size, and its operations (such as 'size') allow + the recovery of more type-level information. +* @'FinMap'@ is dissimilar from "Data.Parameterized.Map.MapF" in that neither + the key nor value type of 'FinMap' is parameterized. + +The type parameter @n@ doesn't track the /current/ number of key-value pairs in +a @'FinMap' n@ (i.e., the size of the map), but rather /an upper bound/. +'insert' and 'delete' don't alter @n@, whereas 'incMax' does - despite the fact +that it has no effect on the keys and values in the 'FinMap'. + +The 'FinMap' interface has two implementations: + +* The implementation in "Data.Parameterized.FinMap.Unsafe" is backed by an + 'Data.IntMap.IntMap', and must have a size of at most @'maxBound' :: 'Int'@. + This module uses unsafe operations like 'Unsafe.Coerce.unsafeCoerce' + internally for the sake of time and space efficiency. +* The implementation in "Data.Parameterized.FinMap.Safe" is backed by an + @'Data.Map.Map' ('Data.Parameterized.Fin.Fin' n)@. All of its functions are + implemented using safe operations. + +The implementation in 'Data.Parameterized.FinMap.Unsafe.FinMap' is property +tested against that in 'Data.Parameterized.FinMap.Safe.FinMap' to ensure +they have the same behavior. + +In this documentation, /W/ is used in big-O notations the same way as in the +"Data.IntMap" documentation. + +NOTE: Where the word "conceptually" is used, it implies that this correspondence +is not literally true, but is true modulo some details such as differences +between bounded types like 'Int' and unbounded types like 'Integer'. + +Several of the functions in both implementations are marked @INLINE@ or +@INLINABLE@. There are three reasons for this: + +* Some of these just have very small definitions and so inlining is likely more + beneficial than harmful. +* Some participate in @RULES@ relevant to functions used in their + implementations. +* They are thin wrappers (often just newtype wrappers) around functions marked + @INLINE@, which should therefore also be inlined. +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Parameterized.FinMap + ( +#ifdef UNSAFE_OPS + module Data.Parameterized.FinMap.Unsafe +#else + module Data.Parameterized.FinMap.Safe +#endif + ) where + +#ifdef UNSAFE_OPS +import Data.Parameterized.FinMap.Unsafe +#else +import Data.Parameterized.FinMap.Safe +#endif diff --git a/src/Data/Parameterized/FinMap/Safe.hs b/src/Data/Parameterized/FinMap/Safe.hs new file mode 100644 index 0000000..23bc0b3 --- /dev/null +++ b/src/Data/Parameterized/FinMap/Safe.hs @@ -0,0 +1,248 @@ +{-| +Copyright : (c) Galois, Inc 2022 + +See "Data.Parameterized.FinMap". +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Parameterized.FinMap.Safe + ( FinMap + -- * Query + , null + , lookup + , size + -- * Construction + , incMax + , embed + , empty + , singleton + , insert + , buildFinMap + , append + , fromVector + -- * Operations + , delete + , decMax + , mapWithKey + , unionWithKey + , unionWith + , union + ) where + +import Prelude hiding (lookup, null) + +import Data.Foldable.WithIndex (FoldableWithIndex(ifoldMap)) +import Data.Functor.WithIndex (FunctorWithIndex(imap)) +import Data.Maybe (isJust) +import Data.Proxy (Proxy(Proxy)) +import Data.Map (Map) +import qualified Data.Map as Map +import GHC.TypeLits (KnownNat, Nat) + +import Data.Parameterized.Fin (Fin) +import qualified Data.Parameterized.Fin as Fin +import Data.Parameterized.NatRepr (NatRepr, type (+), type (<=)) +import qualified Data.Parameterized.NatRepr as NatRepr +import Data.Parameterized.Vector (Vector) +import qualified Data.Parameterized.Vector as Vec + +------------------------------------------------------------------------ +-- Type + +-- | @'FinMap' n a@ is a map with @'Fin' n@ keys and @a@ values. +data FinMap (n :: Nat) a = + FinMap + { getFinMap :: Map (Fin n) a + , maxSize :: NatRepr n + } + +instance Eq a => Eq (FinMap n a) where + fm1 == fm2 = getFinMap fm1 == getFinMap fm2 + {-# INLINABLE (==) #-} + +instance Semigroup (FinMap n a) where + (<>) = union + {-# INLINE (<>) #-} + +instance KnownNat n => Monoid (FinMap n a) where + mempty = empty + {-# INLINE mempty #-} + +instance Functor (FinMap n) where + fmap f fm = fm { getFinMap = fmap f (getFinMap fm) } + {-# INLINABLE fmap #-} + +instance Foldable (FinMap n) where + foldMap f = foldMap f . getFinMap + {-# INLINABLE foldMap #-} + +instance Traversable (FinMap n) where + traverse f fm = FinMap <$> traverse f (getFinMap fm) <*> pure (maxSize fm) + +instance FunctorWithIndex (Fin n) (FinMap n) where + imap f fm = fm { getFinMap = Map.mapWithKey f (getFinMap fm) } + -- Inline so that RULES for Map.mapWithKey can fire + {-# INLINE imap #-} + +instance FoldableWithIndex (Fin n) (FinMap n) where + ifoldMap f = Map.foldMapWithKey f . getFinMap + {-# INLINABLE ifoldMap #-} + +-- | Non-lawful instance, provided for testing +instance Show a => Show (FinMap n a) where + show fm = show (getFinMap fm) + {-# INLINABLE show #-} + +------------------------------------------------------------------------ +-- Query + +-- | /O(1)/. Is the map empty? +null :: FinMap n a -> Bool +null = Map.null . getFinMap +{-# INLINABLE null #-} + +-- | /O(log n)/. Fetch the value at the given key in the map. +lookup :: Fin n -> FinMap n a -> Maybe a +lookup k = Map.lookup k . getFinMap +{-# INLINABLE lookup #-} + +-- | /O(nlog(n))/. Number of elements in the map. +-- +-- This operation is much slower than 'Data.Parameterized.FinMap.Unsafe.size' +-- because its implementation must provide significant evidence to the +-- type-checker, and the easiest way to do that is fairly inefficient. +-- If speed is a concern, use "Data.Parameterized.FinMap.Unsafe". +size :: forall n a. FinMap n a -> Fin (n + 1) +size fm = + Fin.countFin (maxSize fm) (\k _count -> isJust (lookup (Fin.mkFin k) fm)) + +------------------------------------------------------------------------ +-- Construction + +-- | /O(n log n)/. Increase maximum key/size by 1. +-- +-- This does not alter the key-value pairs in the map, but rather increases the +-- maximum number of key-value pairs that the map can hold. See +-- "Data.Parameterized.FinMap" for more information. +-- +-- Requires @n + 1 < (maxBound :: Int)@. +incMax :: forall n a. FinMap n a -> FinMap (n + 1) a +incMax fm = + case NatRepr.leqSucc (Proxy :: Proxy n) of + NatRepr.LeqProof -> embed (NatRepr.incNat (maxSize fm)) fm + +-- | /O(n log n)/. Increase maximum key/size. +-- +-- Requires @m < (maxBound :: Int)@. +embed :: (n <= m) => NatRepr m -> FinMap n a -> FinMap m a +embed m fm = + FinMap + { getFinMap = Map.mapKeys Fin.embed (getFinMap fm) + , maxSize = m + } + +-- | /O(1)/. The empty map. +empty :: KnownNat n => FinMap n a +empty = FinMap Map.empty NatRepr.knownNat +{-# INLINABLE empty #-} + +-- | /O(1)/. A map with one element. +singleton :: a -> FinMap 1 a +singleton item = + FinMap + { getFinMap = Map.singleton (Fin.mkFin (NatRepr.knownNat :: NatRepr 0)) item + , maxSize = NatRepr.knownNat :: NatRepr 1 + } + +-- | /O(log n)/. +insert :: Fin n -> a -> FinMap n a -> FinMap n a +insert k v fm = fm { getFinMap = Map.insert k v (getFinMap fm) } +{-# INLINABLE insert #-} + +-- buildFinMap, append, and fromVector are duplicated exactly between the safe +-- and unsafe modules because they are used in comparative testing (and so +-- implementations must be available for both types). + +newtype FinMap' a (n :: Nat) = FinMap' { unFinMap' :: FinMap n a } + +buildFinMap :: + forall m a. + NatRepr m -> + (forall n. (n + 1 <= m) => NatRepr n -> FinMap n a -> FinMap (n + 1) a) -> + FinMap m a +buildFinMap m f = + let f' :: forall k. (k + 1 <= m) => NatRepr k -> FinMap' a k -> FinMap' a (k + 1) + f' = (\n (FinMap' fin) -> FinMap' (f n fin)) + in unFinMap' (NatRepr.natRecStrictlyBounded m (FinMap' empty) f') + +-- | /O(min(n,W))/. +append :: NatRepr n -> a -> FinMap n a -> FinMap (n + 1) a +append k v fm = + case NatRepr.leqSucc k of + NatRepr.LeqProof -> insert (Fin.mkFin k) v (incMax fm) + +fromVector :: forall n a. Vector n (Maybe a) -> FinMap n a +fromVector v = + buildFinMap + (Vec.length v) + (\k m -> + case Vec.elemAt k v of + Just e -> append k e m + Nothing -> incMax m) + +------------------------------------------------------------------------ +-- Operations + +-- | /O(log n)/. +delete :: Fin n -> FinMap n a -> FinMap n a +delete k fm = fm { getFinMap = Map.delete k (getFinMap fm) } +{-# INLINABLE delete #-} + +-- | Decrement the key/size, removing the item at key @n + 1@ if present. +decMax :: NatRepr n -> FinMap (n + 1) a -> FinMap n a +decMax n fm = + FinMap + { getFinMap = maybeMapKeys (Fin.tryEmbed sz n) (getFinMap fm) + , maxSize = n + } + where + sz = maxSize fm + + maybeMapKeys :: Ord k2 => (k1 -> Maybe k2) -> Map k1 a -> Map k2 a + maybeMapKeys f m = + Map.foldrWithKey + (\k v accum -> + case f k of + Just k' -> Map.insert k' v accum + Nothing -> accum) + Map.empty + m + +mapWithKey :: (Fin n -> a -> b) -> FinMap n a -> FinMap n b +mapWithKey f fm = fm { getFinMap = Map.mapWithKey f (getFinMap fm) } +-- Inline so that RULES for Map.mapWithKey can fire +{-# INLINE mapWithKey #-} + +-- | /O(n+m)/. +unionWithKey :: (Fin n -> a -> a -> a) -> FinMap n a -> FinMap n a -> FinMap n a +unionWithKey f fm1 fm2 = + FinMap + { getFinMap = Map.unionWithKey f (getFinMap fm1) (getFinMap fm2) + , maxSize = maxSize fm1 + } + +-- | /O(n+m)/. +unionWith :: (a -> a -> a) -> FinMap n a -> FinMap n a -> FinMap n a +unionWith f = unionWithKey (\_ v1 v2 -> f v1 v2) + +-- | /O(n+m)/. Left-biased union, i.e. (@'union' == 'unionWith' 'const'@). +union :: FinMap n a -> FinMap n a -> FinMap n a +union = unionWith const diff --git a/src/Data/Parameterized/FinMap/Unsafe.hs b/src/Data/Parameterized/FinMap/Unsafe.hs new file mode 100644 index 0000000..09fdf28 --- /dev/null +++ b/src/Data/Parameterized/FinMap/Unsafe.hs @@ -0,0 +1,249 @@ +{-| +Copyright : (c) Galois, Inc 2022 + +See "Data.Parameterized.FinMap". +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Parameterized.FinMap.Unsafe + ( FinMap + -- * Query + , null + , lookup + , size + -- * Construction + , incMax + , embed + , empty + , singleton + , insert + , buildFinMap + , append + , fromVector + -- * Operations + , delete + , decMax + , mapWithKey + , unionWithKey + , unionWith + , union + ) where + +import Prelude hiding (lookup, null) + +import Data.Functor.WithIndex (FunctorWithIndex(imap)) +import Data.Foldable.WithIndex (FoldableWithIndex(ifoldMap)) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import GHC.TypeLits (KnownNat, Nat) +import Numeric.Natural (Natural) +import Unsafe.Coerce (unsafeCoerce) + +import Data.Parameterized.Fin (Fin, mkFin) +import qualified Data.Parameterized.Fin as Fin +import Data.Parameterized.NatRepr (LeqProof, NatRepr, type (+), type (<=)) +import qualified Data.Parameterized.NatRepr as NatRepr +import Data.Parameterized.Some (Some(Some)) +import Data.Parameterized.Vector (Vector) +import qualified Data.Parameterized.Vector as Vec + +-- This is pulled out as a function so that it's obvious that its use is safe +-- (since Natural is unbounded). +intToNat :: Int -> Natural +intToNat = fromIntegral +{-# INLINE intToNat #-} + +-- These are pulled out as functions so that it's obvious that their use is +-- unsafe (since Natural is unbounded). + +unsafeFinToInt :: Fin n -> Int +unsafeFinToInt = fromIntegral . Fin.finToNat +{-# INLINE unsafeFinToInt #-} + +unsafeNatReprToInt :: NatRepr n -> Int +unsafeNatReprToInt = fromIntegral . NatRepr.natValue +{-# INLINE unsafeNatReprToInt #-} + +------------------------------------------------------------------------ +-- Type + +-- This datatype has two important invariants: +-- +-- * Its keys must be less than the nat in its type. +-- * Its size must be less than the maximum Int. +-- +-- If these invariants hold, all of the unsafe operations in this module +-- (fromJust, unsafeCoerce) will work as intended. + +-- | @'FinMap' n a@ is a map with @'Fin' n@ keys and @a@ values. +newtype FinMap (n :: Nat) a = FinMap { getFinMap :: IntMap a } + +instance Eq a => Eq (FinMap n a) where + fm1 == fm2 = getFinMap fm1 == getFinMap fm2 + {-# INLINABLE (==) #-} + +instance Semigroup (FinMap n a) where + (<>) = union + {-# INLINE (<>) #-} + +instance KnownNat n => Monoid (FinMap n a) where + mempty = empty + {-# INLINE mempty #-} + +instance Functor (FinMap n) where + fmap f = FinMap . fmap f . getFinMap + {-# INLINABLE fmap #-} + +instance Foldable (FinMap n) where + foldMap f = foldMap f . getFinMap + {-# INLINABLE foldMap #-} + +instance Traversable (FinMap n) where + traverse f fm = FinMap <$> traverse f (getFinMap fm) + +instance FunctorWithIndex (Fin n) (FinMap n) where + imap f = FinMap . IntMap.mapWithKey (f . unsafeFin) . getFinMap + -- Inline so that RULES for IntMap.mapWithKey can fire + {-# INLINE imap #-} + +instance FoldableWithIndex (Fin n) (FinMap n) where + ifoldMap f = IntMap.foldMapWithKey (f . unsafeFin) . getFinMap + +-- | Non-lawful instance, provided for testing +instance Show a => Show (FinMap n a) where + show fm = show (getFinMap fm) + {-# INLINABLE show #-} + +------------------------------------------------------------------------ +-- Query + +-- | /O(1)/. Is the map empty? +null :: FinMap n a -> Bool +null = IntMap.null . getFinMap +{-# INLINABLE null #-} + +-- | /O(min(n,W))/. Fetch the value at the given key in the map. +lookup :: Fin n -> FinMap n a -> Maybe a +lookup k = IntMap.lookup (unsafeFinToInt k) . getFinMap +{-# INLINABLE lookup #-} + +-- | Unsafely create a @'Fin' n@ from an 'Int' which is known to be less than +-- @n@ for reasons not visible to the type system. +unsafeFin :: forall n. Int -> Fin n +unsafeFin i = + case NatRepr.mkNatRepr (intToNat i) of + Some (repr :: NatRepr m) -> + case unsafeCoerce (NatRepr.LeqProof :: LeqProof 0 0) :: LeqProof (m + 1) n of + NatRepr.LeqProof -> mkFin @m @n repr + +-- | /O(1)/. Number of elements in the map. +size :: forall n a. FinMap n a -> Fin (n + 1) +size = unsafeFin . IntMap.size . getFinMap +{-# INLINEABLE size #-} + +------------------------------------------------------------------------ +-- Construction + +-- | /O(1)/. Increase maximum key/size by 1. +-- +-- This does not alter the key-value pairs in the map, but rather increases the +-- maximum number of key-value pairs that the map can hold. See +-- "Data.Parameterized.FinMap" for more information. +-- +-- Requires @n + 1 < (maxBound :: Int)@. +incMax :: FinMap n a -> FinMap (n + 1) a +incMax = FinMap . getFinMap +{-# INLINE incMax #-} + +-- | /O(1)/. Increase maximum key/size. +-- +-- Requires @m < (maxBound :: Int)@. +embed :: (n <= m) => NatRepr m -> FinMap n a -> FinMap m a +embed _ = FinMap . getFinMap +{-# INLINE embed #-} + +-- | /O(1)/. The empty map. +empty :: KnownNat n => FinMap n a +empty = FinMap IntMap.empty +{-# INLINE empty #-} + +-- | /O(1)/. A map with one element. +singleton :: a -> FinMap 1 a +singleton = FinMap . IntMap.singleton 0 +{-# INLINABLE singleton #-} + +-- | /O(min(n,W))/. +insert :: Fin n -> a -> FinMap n a -> FinMap n a +insert k v = FinMap . IntMap.insert (unsafeFinToInt k) v . getFinMap +{-# INLINABLE insert #-} + +-- buildFinMap, append, and fromVector are duplicated exactly between the safe +-- and unsafe modules because they are used in comparative testing (and so +-- implementations must be available for both types). + +newtype FinMap' a (n :: Nat) = FinMap' { unFinMap' :: FinMap n a } + +buildFinMap :: + forall m a. + NatRepr m -> + (forall n. (n + 1 <= m) => NatRepr n -> FinMap n a -> FinMap (n + 1) a) -> + FinMap m a +buildFinMap m f = + let f' :: forall k. (k + 1 <= m) => NatRepr k -> FinMap' a k -> FinMap' a (k + 1) + f' = (\n (FinMap' fin) -> FinMap' (f n fin)) + in unFinMap' (NatRepr.natRecStrictlyBounded m (FinMap' empty) f') + +-- | /O(min(n,W))/. +append :: NatRepr n -> a -> FinMap n a -> FinMap (n + 1) a +append k v fm = + case NatRepr.leqSucc k of + NatRepr.LeqProof -> insert (mkFin k) v (incMax fm) + +fromVector :: forall n a. Vector n (Maybe a) -> FinMap n a +fromVector v = + buildFinMap + (Vec.length v) + (\k m -> + case Vec.elemAt k v of + Just e -> append k e m + Nothing -> incMax m) + +------------------------------------------------------------------------ +-- Operations + +-- | /O(min(n,W))/. +delete :: Fin n -> FinMap n a -> FinMap n a +delete k = FinMap . IntMap.delete (unsafeFinToInt k) . getFinMap +{-# INLINABLE delete #-} + +-- | Decrement the key/size, removing the item at key @n + 1@ if present. +decMax :: NatRepr n -> FinMap (n + 1) a -> FinMap n a +decMax k = FinMap . IntMap.delete (unsafeNatReprToInt k) . getFinMap +{-# INLINABLE decMax #-} + +mapWithKey :: (Fin n -> a -> b) -> FinMap n a -> FinMap n b +mapWithKey f = FinMap . IntMap.mapWithKey (f . unsafeFin) . getFinMap +-- Inline so that RULES for IntMap.mapWithKey can fire +{-# INLINE mapWithKey #-} + +-- | /O(n+m)/. +unionWithKey :: (Fin n -> a -> a -> a) -> FinMap n a -> FinMap n a -> FinMap n a +unionWithKey f fm1 fm2 = + FinMap (IntMap.unionWithKey (f . unsafeFin) (getFinMap fm1) (getFinMap fm2)) + +-- | /O(n+m)/. +unionWith :: (a -> a -> a) -> FinMap n a -> FinMap n a -> FinMap n a +unionWith f = unionWithKey (\_ v1 v2 -> f v1 v2) + +-- | /O(n+m)/. Left-biased union, i.e. (@'union' == 'unionWith' 'const'@). +union :: FinMap n a -> FinMap n a -> FinMap n a +union = unionWith const diff --git a/src/Data/Parameterized/HashTable.hs b/src/Data/Parameterized/HashTable.hs new file mode 100644 index 0000000..adf52d9 --- /dev/null +++ b/src/Data/Parameterized/HashTable.hs @@ -0,0 +1,99 @@ +------------------------------------------------------------------------ +-- | +-- Module : Data.Parameterized.HashTable +-- Description : a hash table for parameterized keys and values +-- Copyright : (c) Galois, Inc 2014-2019 +-- Maintainer : Joe Hendrix +-- +-- This module provides a 'ST'-based hashtable for parameterized keys and values. +-- +-- NOTE: This API makes use of 'unsafeCoerce' to implement the parameterized +-- hashtable abstraction. This should be type-safe provided that the +-- 'TestEquality' instance on the key type is implemented soundly. +------------------------------------------------------------------------ +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Trustworthy #-} +module Data.Parameterized.HashTable + ( HashTable + , new + , newSized + , clone + , lookup + , insert + , member + , delete + , clear + , Data.Parameterized.Classes.HashableF(..) + , Control.Monad.ST.RealWorld + ) where + +import Control.Applicative +import Control.Monad.ST +import qualified Data.HashTable.ST.Basic as H +import Data.Kind +import GHC.Exts (Any) +import Unsafe.Coerce + +import Prelude hiding (lookup) + +import Data.Parameterized.Classes +import Data.Parameterized.Some + +-- | A hash table mapping nonces to values. +newtype HashTable s (key :: k -> Type) (val :: k -> Type) + = HashTable (H.HashTable s (Some key) Any) + +-- | Create a new empty table. +new :: ST s (HashTable s key val) +new = HashTable <$> H.new + +-- | Create a new empty table to hold 'n' elements. +newSized :: Int -> ST s (HashTable s k v) +newSized n = HashTable <$> H.newSized n + +-- | Create a hash table that is a copy of the current one. +clone :: (HashableF key, TestEquality key) + => HashTable s key val + -> ST s (HashTable s key val) +clone (HashTable tbl) = do + -- Create a new table + r <- H.new + -- Insert existing elements in + H.mapM_ (uncurry (H.insert r)) tbl + -- Return table + return $! HashTable r + +-- | Lookup value of key in table. +lookup :: (HashableF key, TestEquality key) + => HashTable s key val + -> key tp + -> ST s (Maybe (val tp)) +lookup (HashTable h) k = fmap unsafeCoerce <$> H.lookup h (Some k) +{-# INLINE lookup #-} + +-- | Insert new key and value mapping into table. +insert :: (HashableF key, TestEquality key) + => HashTable s (key :: k -> Type) (val :: k -> Type) + -> key tp + -> val tp + -> ST s () +insert (HashTable h) k v = H.insert h (Some k) (unsafeCoerce v) + +-- | Return true if the key is in the hash table. +member :: (HashableF key, TestEquality key) + => HashTable s (key :: k -> Type) (val :: k -> Type) + -> key (tp :: k) + -> ST s Bool +member (HashTable h) k = isJust <$> H.lookup h (Some k) + +-- | Delete an element from the hash table. +delete :: (HashableF key, TestEquality key) + => HashTable s (key :: k -> Type) (val :: k -> Type) + -> key (tp :: k) + -> ST s () +delete (HashTable h) k = H.delete h (Some k) + +clear :: (HashableF key, TestEquality key) + => HashTable s (key :: k -> Type) (val :: k -> Type) -> ST s () +clear (HashTable h) = H.mapM_ (\(k,_) -> H.delete h k) h diff --git a/src/Data/Parameterized/List.hs b/src/Data/Parameterized/List.hs new file mode 100644 index 0000000..e9f7432 --- /dev/null +++ b/src/Data/Parameterized/List.hs @@ -0,0 +1,426 @@ +{-| +Description : A type-indexed parameterized list +Copyright : (c) Galois, Inc 2017-2019 +Maintainer : Joe Hendrix + +This module defines a list over two parameters. The first +is a fixed type-level function @k -> *@ for some kind @k@, and the +second is a list of types with kind @k@ that provide the indices for +the values in the list. + +This type is closely related to the +'Data.Parameterized.Context.Assignment' type in +"Data.Parameterized.Context". + += Motivating example - the 'Data.Parameterized.List.List' type + +For this example, we need the following extensions: + +@ +\{\-\# LANGUAGE DataKinds \#\-\} +\{\-\# LANGUAGE GADTs \#\-\} +\{\-\# LANGUAGE KindSignatures \#\-\} +\{\-\# LANGUAGE TypeOperators \#\-\} +@ + +We also require the following imports: + +@ +import Data.Parameterized +import Data.Parameterized.List +import GHC.TypeLits +@ + +Suppose we have a bitvector type: + +@ +data BitVector (w :: Nat) :: * where + BV :: NatRepr w -> Integer -> BitVector w +@ + +This type contains a 'Data.Parameterized.NatRepr.NatRepr', a value-level +representative of the vector width, and an 'Integer', containing the +actual value of the bitvector. We can create values of this type as +follows: + +@ +BV (knownNat @8) 0xAB +@ + +We can also create a smart constructor to handle the +'Data.Parameterized.NatRepr.NatRepr' automatically, when the width is known +from the type context: + +@ +bitVector :: KnownNat w => Integer -> BitVector w +bitVector x = BV knownNat x +@ + +Note that this does not check that the value can be represented in the +given number of bits; that is not important for this example. + +If we wish to construct a list of @BitVector@s of a particular length, +we can do: + +@ +[bitVector 0xAB, bitVector 0xFF, bitVector 0] :: BitVector 8 +@ + +However, what if we wish to construct a list of 'BitVector's of +different lengths? We could try: + +@ +[bitVector 0xAB :: BitVector 8, bitVector 0x1234 :: BitVector 16] +@ + +However, this gives us an error: + +@ +\:3:33: error: + • Couldn't match type ‘16’ with ‘8’ + Expected type: BitVector 8 + Actual type: BitVector 16 + • In the expression: bitVector 0x1234 :: BitVector 16 + In the expression: + [bitVector 0xAB :: BitVector 8, bitVector 0x1234 :: BitVector 16] + In an equation for ‘it’: + it + = [bitVector 0xAB :: BitVector 8, bitVector 0x1234 :: BitVector 16] +@ + +A vanilla Haskell list cannot contain two elements of different types, +and even though the two elements here are both @BitVector@s, they do +not have the same type! One solution is to use the +'Data.Parameterized.Some.Some' type: + +@ +[Some (bitVector 0xAB :: BitVector 8), Some (bitVector 0x1234 :: BitVector 16)] +@ + +The type of the above expression is @[Some BitVector]@, which may be +perfectly acceptable. However, there is nothing in this type that +tells us what the widths of the bitvectors are, or what the length of +the overall list is. If we want to actually track that information on +the type level, we can use the 'List' type from this module. + +@ +(bitVector 0xAB :: BitVector 8) :< (bitVector 0x1234 :: BitVector 16) :< Nil +@ + +The type of the above expression is @List BitVector '[8, 16]@ -- That +is, a two-element list of @BitVector@s, where the first element has +width 8 and the second has width 16. + +== Summary + +In general, if we have a type constructor @Foo@ of kind @k -> *@ (in +our example, @Foo@ is just @BitVector@, and we want to create a list +of @Foo@s where the parameter @k@ varies, /and/ we wish to keep track +of what each value of @k@ is inside the list at compile time, we can +use the 'Data.Parameterized.List.List' type for this purpose. + +-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Data.Parameterized.List + ( List(..) + , fromSomeList + , fromListWith + , fromListWithM + , Index(..) + , indexValue + , (!!) + , update + , indexed + , imap + , ifoldlM + , ifoldr + , izipWith + , itraverse + -- * Constants + , index0 + , index1 + , index2 + , index3 + ) where + +import qualified Control.Lens as Lens +import Data.Foldable +import Data.Kind +import Prelude hiding ((!!)) +import Unsafe.Coerce (unsafeCoerce) + +import Data.Parameterized.Classes +import Data.Parameterized.Some +import Data.Parameterized.TraversableFC +import Data.Parameterized.TraversableFC.WithIndex + +-- | Parameterized list of elements. +data List :: (k -> Type) -> [k] -> Type where + Nil :: List f '[] + (:<) :: f tp -> List f tps -> List f (tp : tps) + +infixr 5 :< + +instance ShowF f => Show (List f sh) where + showsPrec _ Nil = showString "Nil" + showsPrec p (elt :< rest) = showParen (p > precCons) $ + -- Unlike a derived 'Show' instance, we don't print parens implied + -- by right associativity. + showsPrecF (precCons+1) elt . showString " :< " . showsPrec 0 rest + where + precCons = 5 + +instance ShowF f => ShowF (List f) + +instance FunctorFC List where + fmapFC _ Nil = Nil + fmapFC f (x :< xs) = f x :< fmapFC f xs + +instance FoldableFC List where + foldrFC _ z Nil = z + foldrFC f z (x :< xs) = f x (foldrFC f z xs) + +instance TraversableFC List where + traverseFC _ Nil = pure Nil + traverseFC f (h :< r) = (:<) <$> f h <*> traverseFC f r + +type instance IndexF (List (f :: k -> Type) sh) = Index sh +type instance IxValueF (List (f :: k -> Type) sh) = f + +instance FunctorFCWithIndex List where + imapFC = imap + +instance FoldableFCWithIndex List where + ifoldrFC = ifoldr + +instance TraversableFCWithIndex List where + itraverseFC = itraverse + +instance TestEquality f => TestEquality (List f) where + testEquality Nil Nil = Just Refl + testEquality (xh :< xl) (yh :< yl) = do + Refl <- testEquality xh yh + Refl <- testEquality xl yl + pure Refl + testEquality _ _ = Nothing + +instance OrdF f => OrdF (List f) where + compareF Nil Nil = EQF + compareF Nil _ = LTF + compareF _ Nil = GTF + compareF (xh :< xl) (yh :< yl) = + lexCompareF xh yh $ + lexCompareF xl yl $ + EQF + +instance KnownRepr (List f) '[] where + knownRepr = Nil + +instance (KnownRepr f s, KnownRepr (List f) sh) => KnownRepr (List f) (s ': sh) where + knownRepr = knownRepr :< knownRepr + +-- | Apply function to list to yield a parameterized list. +fromListWith :: forall a f . (a -> Some f) -> [a] -> Some (List f) +fromListWith f = foldr g (Some Nil) + where g :: a -> Some (List f) -> Some (List f) + g x (Some r) = viewSome (\h -> Some (h :< r)) (f x) + +-- | Apply monadic action to list to yield a parameterized list. +fromListWithM :: forall a f m + . Monad m + => (a -> m (Some f)) + -> [a] + -> m (Some (List f)) +fromListWithM f = foldrM g (Some Nil) + where g :: a -> Some (List f) -> m (Some (List f)) + g x (Some r) = viewSome (\h -> Some (h :< r)) <$> f x + +-- | Map from list of Some to Some list +fromSomeList :: [Some f] -> Some (List f) +fromSomeList = fromListWith id + +{-# INLINABLE fromListWith #-} +{-# INLINABLE fromListWithM #-} + +-------------------------------------------------------------------------------- +-- * Indexed operations + +-- | Represents an index into a type-level list. Used in place of integers to +-- 1. ensure that the given index *does* exist in the list +-- 2. guarantee that it has the given kind +data Index :: [k] -> k -> Type where + IndexHere :: Index (x:r) x + IndexThere :: !(Index r y) -> Index (x:r) y + +deriving instance Eq (Index l x) +deriving instance Show (Index l x) + +instance ShowF (Index l) + +instance TestEquality (Index l) where + testEquality IndexHere IndexHere = Just Refl + testEquality (IndexThere x) (IndexThere y) = testEquality x y + testEquality _ _ = Nothing + +instance OrdF (Index l) where + compareF IndexHere IndexHere = EQF + compareF IndexHere IndexThere{} = LTF + compareF IndexThere{} IndexHere = GTF + compareF (IndexThere x) (IndexThere y) = compareF x y + +instance Ord (Index sh x) where + x `compare` y = toOrdering $ x `compareF` y + +-- | Return the index as an integer. +indexValue :: Index l tp -> Integer +indexValue = go 0 + where go :: Integer -> Index l tp -> Integer + go i IndexHere = i + go i (IndexThere x) = seq j $ go j x + where j = i+1 + +instance Hashable (Index l x) where + hashWithSalt s i = s `hashWithSalt` (indexValue i) + +-- | Index 0 +index0 :: Index (x:r) x +index0 = IndexHere + +-- | Index 1 +index1 :: Index (x0:x1:r) x1 +index1 = IndexThere index0 + +-- | Index 2 +index2 :: Index (x0:x1:x2:r) x2 +index2 = IndexThere index1 + +-- | Index 3 +index3 :: Index (x0:x1:x2:x3:r) x3 +index3 = IndexThere index2 + +-- | Return the value in a list at a given index +(!!) :: List f l -> Index l x -> f x +l !! (IndexThere i) = + case l of + _ :< r -> r !! i +l !! IndexHere = + case l of + (h :< _) -> h + +-- | Update the 'List' at an index +update :: List f l -> Index l s -> (f s -> f s) -> List f l +update vals IndexHere upd = + case vals of + x :< rest -> upd x :< rest +update vals (IndexThere th) upd = + case vals of + x :< rest -> x :< update rest th upd + +-- | Provides a lens for manipulating the element at the given index. +indexed :: Index l x -> Lens.Lens' (List f l) (f x) +indexed IndexHere f (x :< rest) = (:< rest) <$> f x +indexed (IndexThere i) f (x :< rest) = (x :<) <$> indexed i f rest + +-------------------------------------------------------------------------------- +-- Indexed operations + +-- | Map over the elements in the list, and provide the index into +-- each element along with the element itself. +-- +-- This is a specialization of 'imapFC'. +imap :: forall f g l + . (forall x . Index l x -> f x -> g x) + -> List f l + -> List g l +imap f = go id + where + go :: forall l' + . (forall tp . Index l' tp -> Index l tp) + -> List f l' + -> List g l' + go g l = + case l of + Nil -> Nil + e :< rest -> f (g IndexHere) e :< go (g . IndexThere) rest + +-- | Left fold with an additional index. +ifoldlM :: forall sh a b m + . Monad m + => (forall tp . b -> Index sh tp -> a tp -> m b) + -> b + -> List a sh + -> m b +ifoldlM _ b Nil = pure b +ifoldlM f b0 (a0 :< r0) = f b0 IndexHere a0 >>= go IndexHere r0 + where + go :: forall tps tp + . Index sh tp + -> List a tps + -> b + -> m b + go _ Nil b = pure b + go idx (a :< rest) b = + let idx' = unsafeCoerce (IndexThere idx) + in f b idx' a >>= go idx' rest + +-- | Right-fold with an additional index. +-- +-- This is a specialization of 'ifoldrFC'. +ifoldr :: forall sh a b . (forall tp . Index sh tp -> a tp -> b -> b) -> b -> List a sh -> b +ifoldr f seed0 l = go id l seed0 + where + go :: forall tps + . (forall tp . Index tps tp -> Index sh tp) + -> List a tps + -> b + -> b + go g ops b = + case ops of + Nil -> b + a :< rest -> f (g IndexHere) a (go (\ix -> g (IndexThere ix)) rest b) + +-- | Zip up two lists with a zipper function, which can use the index. +izipWith :: forall a b c sh . (forall tp. Index sh tp -> a tp -> b tp -> c tp) + -> List a sh + -> List b sh + -> List c sh +izipWith f = go id + where + go :: forall sh' . + (forall tp . Index sh' tp -> Index sh tp) + -> List a sh' + -> List b sh' + -> List c sh' + go g as bs = + case (as, bs) of + (Nil, Nil) -> Nil + (a :< as', b :< bs') -> + f (g IndexHere) a b :< go (g . IndexThere) as' bs' + +-- | Traverse with an additional index. +-- +-- This is a specialization of 'itraverseFC'. +itraverse :: forall a b sh t + . Applicative t + => (forall tp . Index sh tp -> a tp -> t (b tp)) + -> List a sh + -> t (List b sh) +itraverse f = go id + where + go :: forall tps . (forall tp . Index tps tp -> Index sh tp) + -> List a tps + -> t (List b tps) + go g l = + case l of + Nil -> pure Nil + e :< rest -> (:<) <$> f (g IndexHere) e <*> go (\ix -> g (IndexThere ix)) rest diff --git a/src/Data/Parameterized/Map.hs b/src/Data/Parameterized/Map.hs new file mode 100644 index 0000000..2f423b6 --- /dev/null +++ b/src/Data/Parameterized/Map.hs @@ -0,0 +1,718 @@ +{-| +Description : Finite maps with parameterized key and value types +Copyright : (c) Galois, Inc 2014-2019 + +This module defines finite maps where the key and value types are +parameterized by an arbitrary kind. + +Some code was adapted from containers. +-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +#if __GLASGOW_HASKELL__ < 806 +{-# LANGUAGE TypeInType #-} +#endif +module Data.Parameterized.Map + ( MapF + -- * Construction + , Data.Parameterized.Map.empty + , singleton + , insert + , insertWith + , delete + , union + , intersectWithKeyMaybe + -- * Query + , null + , lookup + , findWithDefault + , member + , notMember + , size + -- * Conversion + , keys + , elems + , fromList + , toList + , toAscList + , toDescList + , fromKeys + , fromKeysM + -- * Filter + , filter + , filterWithKey + , filterGt + , filterLt + -- * Folds + , foldlWithKey + , foldlWithKey' + , foldrWithKey + , foldrWithKey' + , foldMapWithKey + , foldlMWithKey + , foldrMWithKey + -- * Traversals + , map + , mapWithKey + , mapMaybe + , mapMaybeWithKey + , traverseWithKey + , traverseWithKey_ + , traverseMaybeWithKey + -- * Complex interface. + , UpdateRequest(..) + , Updated(..) + , updatedValue + , updateAtKey + , mergeWithKey + , mergeWithKeyM + , module Data.Parameterized.Classes + -- * Pair + , Pair(..) + ) where + +import Control.Applicative hiding (empty) +import Control.Lens (Traversal', Lens') +import Control.Monad.Identity (Identity(..)) +import Control.Monad (foldM) +import Data.Kind (Type) +import Data.List (intercalate, foldl') +import Data.Monoid +import Prelude hiding (filter, lookup, map, traverse, null) + +import Data.Parameterized.Classes +import Data.Parameterized.Some +import Data.Parameterized.Pair ( Pair(..) ) +import Data.Parameterized.TraversableF +import Data.Parameterized.Utils.BinTree + ( MaybeS(..) + , fromMaybeS + , Updated(..) + , updatedValue + , TreeApp(..) + , bin + , IsBinTree(..) + , balanceL + , balanceR + , glue + ) +import qualified Data.Parameterized.Utils.BinTree as Bin + +------------------------------------------------------------------------ +-- * Pair + +comparePairKeys :: OrdF k => Pair k a -> Pair k a -> Ordering +comparePairKeys (Pair x _) (Pair y _) = toOrdering (compareF x y) +{-# INLINABLE comparePairKeys #-} + +------------------------------------------------------------------------ +-- MapF + +-- | A map from parameterized keys to values with the same parameter type. +data MapF (k :: v -> Type) (a :: v -> Type) where + Bin :: {-# UNPACK #-} + !Size -- Number of elements in tree. + -> !(k x) + -> !(a x) + -> !(MapF k a) + -> !(MapF k a) + -> MapF k a + Tip :: MapF k a + +type Size = Int + +-- | Return empty map +empty :: MapF k a +empty = Tip + +-- | Return true if map is empty +null :: MapF k a -> Bool +null Tip = True +null Bin{} = False + +-- | Return map containing a single element +singleton :: k tp -> a tp -> MapF k a +singleton k x = Bin 1 k x Tip Tip + +instance Bin.IsBinTree (MapF k a) (Pair k a) where + asBin (Bin _ k v l r) = BinTree (Pair k v) l r + asBin Tip = TipTree + + tip = Tip + bin (Pair k v) l r = Bin (size l + size r + 1) k v l r + + size Tip = 0 + size (Bin sz _ _ _ _) = sz + +instance (TestEquality k, EqF a) => Eq (MapF k a) where + x == y = size x == size y && toList x == toList y + +------------------------------------------------------------------------ +-- * Traversals + +#ifdef __GLASGOW_HASKELL__ +{-# NOINLINE [1] map #-} +{-# NOINLINE [1] traverse #-} +{-# RULES +"map/map" forall (f :: (forall tp . f tp -> g tp)) (g :: (forall tp . g tp -> h tp)) xs + . map g (map f xs) = map (g . f) xs +"map/traverse" forall (f :: (forall tp . f tp -> m (g tp))) (g :: (forall tp . g tp -> h tp)) xs + . fmap (map g) (traverse f xs) = traverse (\v -> g <$> f v) xs +"traverse/map" + forall (f :: (forall tp . f tp -> g tp)) (g :: (forall tp . g tp -> m (h tp))) xs + . traverse g (map f xs) = traverse (\v -> g (f v)) xs +"traverse/traverse" + forall (f :: (forall tp . f tp -> m (g tp))) (g :: (forall tp . g tp -> m (h tp))) xs + . traverse f xs >>= traverse g = traverse (\v -> f v >>= g) xs + #-} +#endif + +-- | Apply function to all elements in map. +mapWithKey + :: (forall tp . ktp tp -> f tp -> g tp) + -> MapF ktp f + -> MapF ktp g +mapWithKey _ Tip = Tip +mapWithKey f (Bin sx kx x l r) = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f r) + +-- | Modify elements in a map +map :: (forall tp . f tp -> g tp) -> MapF ktp f -> MapF ktp g +map f = mapWithKey (\_ x -> f x) + +-- | Map keys and elements and collect `Just` results. +mapMaybeWithKey :: (forall tp . k tp -> f tp -> Maybe (g tp)) -> MapF k f -> MapF k g +mapMaybeWithKey _ Tip = Tip +mapMaybeWithKey f (Bin _ k x l r) = + case f k x of + Just y -> Bin.link (Pair k y) (mapMaybeWithKey f l) (mapMaybeWithKey f r) + Nothing -> Bin.merge (mapMaybeWithKey f l) (mapMaybeWithKey f r) + +-- | Map elements and collect `Just` results. +mapMaybe :: (forall tp . f tp -> Maybe (g tp)) -> MapF ktp f -> MapF ktp g +mapMaybe f = mapMaybeWithKey (\_ x -> f x) + +-- | Traverse elements in a map +traverse :: Applicative m => (forall tp . f tp -> m (g tp)) -> MapF ktp f -> m (MapF ktp g) +traverse _ Tip = pure Tip +traverse f (Bin sx kx x l r) = + (\l' x' r' -> Bin sx kx x' l' r') <$> traverse f l <*> f x <*> traverse f r + +-- | Traverse elements in a map +traverseWithKey + :: Applicative m + => (forall tp . ktp tp -> f tp -> m (g tp)) + -> MapF ktp f + -> m (MapF ktp g) +traverseWithKey _ Tip = pure Tip +traverseWithKey f (Bin sx kx x l r) = + (\l' x' r' -> Bin sx kx x' l' r') <$> traverseWithKey f l <*> f kx x <*> traverseWithKey f r + +-- | Traverse elements in a map without returning result. +traverseWithKey_ + :: Applicative m + => (forall tp . ktp tp -> f tp -> m ()) + -> MapF ktp f + -> m () +traverseWithKey_ = \f -> foldrWithKey (\k v r -> f k v *> r) (pure ()) +{-# INLINABLE traverseWithKey_ #-} + +-- | Traverse keys\/values and collect the 'Just' results. +traverseMaybeWithKey :: Applicative f + => (forall tp . k tp -> a tp -> f (Maybe (b tp))) + -> MapF k a -> f (MapF k b) +traverseMaybeWithKey _ Tip = pure Tip +traverseMaybeWithKey f (Bin _ kx x Tip Tip) = maybe Tip (\x' -> Bin 1 kx x' Tip Tip) <$> f kx x +traverseMaybeWithKey f (Bin _ kx x l r) = + liftA3 combine (traverseMaybeWithKey f l) (f kx x) (traverseMaybeWithKey f r) + where + combine l' mx r' = seq l' $ seq r' $ + case mx of + Just x' -> Bin.link (Pair kx x') l' r' + Nothing -> Bin.merge l' r' +{-# INLINABLE traverseMaybeWithKey #-} + +type instance IndexF (MapF k v) = k +type instance IxValueF (MapF k v) = v + +-- | Turn a map key into a traversal that visits the indicated element in the map, if it exists. +instance forall a (k:: a -> Type) v. OrdF k => IxedF a (MapF k v) where + ixF :: k x -> Traversal' (MapF k v) (v x) + ixF i f m = updatedValue <$> updateAtKey i (pure Nothing) (\x -> Set <$> f x) m + +-- | Turn a map key into a lens that points into the indicated position in the map. +instance forall a (k:: a -> Type) v. OrdF k => AtF a (MapF k v) where + atF :: k x -> Lens' (MapF k v) (Maybe (v x)) + atF i f m = updatedValue <$> updateAtKey i (f Nothing) (\x -> maybe Delete Set <$> f (Just x)) m + + +-- | Lookup value in map. +lookup :: OrdF k => k tp -> MapF k a -> Maybe (a tp) +lookup k0 = seq k0 (go k0) + where + go :: OrdF k => k tp -> MapF k a -> Maybe (a tp) + go _ Tip = Nothing + go k (Bin _ kx x l r) = + case compareF k kx of + LTF -> go k l + GTF -> go k r + EQF -> Just x +{-# INLINABLE lookup #-} + +-- | @findWithDefault d k m@ returns the value bound to @k@ in the map @m@, or @d@ +-- if @k@ is not bound in the map. +findWithDefault :: OrdF k => a tp -> k tp -> MapF k a -> a tp +findWithDefault = \def k -> seq k (go def k) + where + go :: OrdF k => a tp -> k tp -> MapF k a -> a tp + go d _ Tip = d + go d k (Bin _ kx x l r) = + case compareF k kx of + LTF -> go d k l + GTF -> go d k r + EQF -> x +{-# INLINABLE findWithDefault #-} + +-- | Return true if key is bound in map. +member :: OrdF k => k tp -> MapF k a -> Bool +member k0 = seq k0 (go k0) + where + go :: OrdF k => k tp -> MapF k a -> Bool + go _ Tip = False + go k (Bin _ kx _ l r) = + case compareF k kx of + LTF -> go k l + GTF -> go k r + EQF -> True +{-# INLINABLE member #-} + +-- | Return true if key is not bound in map. +notMember :: OrdF k => k tp -> MapF k a -> Bool +notMember k m = not $ member k m +{-# INLINABLE notMember #-} + +instance FunctorF (MapF ktp) where + fmapF = map + +instance FoldableF (MapF ktp) where + foldrF f z = go z + where go z' Tip = z' + go z' (Bin _ _ x l r) = go (f x (go z' r)) l + +instance TraversableF (MapF ktp) where + traverseF = traverse + +instance (ShowF ktp, ShowF rtp) => Show (MapF ktp rtp) where + show m = showMap showF showF m + +-- | Return all keys of the map in ascending order. +keys :: MapF k a -> [Some k] +keys = foldrWithKey (\k _ l -> Some k : l) [] + +-- | Return all elements of the map in the ascending order of their keys. +elems :: MapF k a -> [Some a] +elems = foldrF (\e l -> Some e : l) [] + +-- | Perform a left fold with the key also provided. +foldlWithKey :: (forall s . b -> k s -> a s -> b) -> b -> MapF k a -> b +foldlWithKey _ z Tip = z +foldlWithKey f z (Bin _ kx x l r) = + let lz = foldlWithKey f z l + kz = f lz kx x + in foldlWithKey f kz r + +-- | Perform a strict left fold with the key also provided. +foldlWithKey' :: (forall s . b -> k s -> a s -> b) -> b -> MapF k a -> b +foldlWithKey' _ z Tip = z +foldlWithKey' f z (Bin _ kx x l r) = + let lz = foldlWithKey f z l + kz = seq lz $ f lz kx x + in seq kz $ foldlWithKey f kz r + +-- | Perform a right fold with the key also provided. +foldrWithKey :: (forall s . k s -> a s -> b -> b) -> b -> MapF k a -> b +foldrWithKey _ z Tip = z +foldrWithKey f z (Bin _ kx x l r) = + foldrWithKey f (f kx x (foldrWithKey f z r)) l + +-- | Perform a strict right fold with the key also provided. +foldrWithKey' :: (forall s . k s -> a s -> b -> b) -> b -> MapF k a -> b +foldrWithKey' _ z Tip = z +foldrWithKey' f z (Bin _ kx x l r) = + let rz = foldrWithKey f z r + kz = seq rz $ f kx x rz + in seq kz $ foldrWithKey f kz l + +-- | Fold the keys and values using the given monoid. +foldMapWithKey :: Monoid m => (forall s . k s -> a s -> m) -> MapF k a -> m +foldMapWithKey _ Tip = mempty +foldMapWithKey f (Bin _ kx x l r) = foldMapWithKey f l <> f kx x <> foldMapWithKey f r + +-- | A monadic left-to-right fold over keys and values in the map. +foldlMWithKey :: Monad m => (forall s . b -> k s -> a s -> m b) -> b -> MapF k a -> m b +foldlMWithKey f z0 m = foldrWithKey (\k a r z -> f z k a >>= r) pure m z0 + +-- | A monadic right-to-left fold over keys and values in the map. +foldrMWithKey :: Monad m => (forall s . k s -> a s -> b -> m b) -> b -> MapF k a -> m b +foldrMWithKey f z0 m = foldlWithKey (\r k a z -> f k a z >>= r) pure m z0 + +-- | Pretty print keys and values in map. +showMap :: (forall tp . ktp tp -> String) + -> (forall tp . rtp tp -> String) + -> MapF ktp rtp + -> String +showMap ppk ppv m = "{ " ++ intercalate ", " l ++ " }" + where l = foldrWithKey (\k a l0 -> (ppk k ++ " -> " ++ ppv a) : l0) [] m + +------------------------------------------------------------------------ +-- filter + +-- | Return entries with values that satisfy a predicate. +filter :: (forall tp . f tp -> Bool) -> MapF k f -> MapF k f +filter f = filterWithKey (\_ v -> f v) + +-- | Return key-value pairs that satisfy a predicate. +filterWithKey :: (forall tp . k tp -> f tp -> Bool) -> MapF k f -> MapF k f +filterWithKey _ Tip = Tip +filterWithKey f (Bin _ k x l r) + | f k x = Bin.link (Pair k x) (filterWithKey f l) (filterWithKey f r) + | otherwise = Bin.merge (filterWithKey f l) (filterWithKey f r) + +compareKeyPair :: OrdF k => k tp -> Pair k a -> Ordering +compareKeyPair k = \(Pair x _) -> toOrdering (compareF k x) + +-- | @filterGt k m@ returns submap of @m@ that only contains entries +-- that are larger than @k@. +filterGt :: OrdF k => k tp -> MapF k v -> MapF k v +filterGt k m = fromMaybeS m (Bin.filterGt (compareKeyPair k) m) +{-# INLINABLE filterGt #-} + +-- | @filterLt k m@ returns submap of @m@ that only contains entries +-- that are smaller than @k@. +filterLt :: OrdF k => k tp -> MapF k v -> MapF k v +filterLt k m = fromMaybeS m (Bin.filterLt (compareKeyPair k) m) +{-# INLINABLE filterLt #-} + +------------------------------------------------------------------------ +-- User operations + +-- | Insert a binding into the map, replacing the existing binding if needed. +insert :: OrdF k => k tp -> a tp -> MapF k a -> MapF k a +insert = \k v m -> seq k $ updatedValue (Bin.insert comparePairKeys (Pair k v) m) +{-# INLINABLE insert #-} +-- {-# SPECIALIZE Bin.insert :: OrdF k => Pair k a -> MapF k a -> Updated (MapF k a) #-} + +-- | Insert a binding into the map, replacing the existing binding if needed. +insertWithImpl :: OrdF k => (a tp -> a tp -> a tp) -> k tp -> a tp -> MapF k a -> Updated (MapF k a) +insertWithImpl f k v t = seq k $ + case t of + Tip -> Bin.Updated (Bin 1 k v Tip Tip) + Bin sz yk yv l r -> + case compareF k yk of + LTF -> + case insertWithImpl f k v l of + Bin.Updated l' -> Bin.Updated (Bin.balanceL (Pair yk yv) l' r) + Bin.Unchanged l' -> Bin.Unchanged (Bin sz yk yv l' r) + GTF -> + case insertWithImpl f k v r of + Bin.Updated r' -> Bin.Updated (Bin.balanceR (Pair yk yv) l r') + Bin.Unchanged r' -> Bin.Unchanged (Bin sz yk yv l r') + EQF -> Bin.Unchanged (Bin sz yk (f v yv) l r) +{-# INLINABLE insertWithImpl #-} + +-- | @insertWith f new m@ inserts the binding into @m@. +-- +-- It inserts @f new old@ if @m@ already contains an equivalent value +-- @old@, and @new@ otherwise. It returns an 'Unchanged' value if the +-- map stays the same size and an 'Updated' value if a new entry was +-- inserted. +insertWith :: OrdF k => (a tp -> a tp -> a tp) -> k tp -> a tp -> MapF k a -> MapF k a +insertWith = \f k v t -> seq k $ updatedValue (insertWithImpl f k v t) +{-# INLINABLE insertWith #-} + +-- | Delete a value from the map if present. +delete :: OrdF k => k tp -> MapF k a -> MapF k a +delete = \k m -> seq k $ fromMaybeS m $ Bin.delete (p k) m + where p :: OrdF k => k tp -> Pair k a -> Ordering + p k (Pair kx _) = toOrdering (compareF k kx) +{-# INLINABLE delete #-} +{-# SPECIALIZE Bin.delete :: (Pair k a -> Ordering) -> MapF k a -> MaybeS (MapF k a) #-} + +-- | Left-biased union of two maps. The resulting map will contain the +-- union of the keys of the two arguments. When a key is contained in +-- both maps the value from the first map will be preserved. +union :: OrdF k => MapF k a -> MapF k a -> MapF k a +union t1 t2 = Bin.union comparePairKeys t1 t2 +{-# INLINABLE union #-} +-- {-# SPECIALIZE Bin.union compare :: OrdF k => MapF k a -> MapF k a -> MapF k a #-} + +------------------------------------------------------------------------ +-- updateAtKey + +-- | 'UpdateRequest' tells what to do with a found value +data UpdateRequest v + = -- | Keep the current value. + Keep + -- | Set the value to a new value. + | Set !v + -- | Delete a value. + | Delete + +data AtKeyResult k a where + AtKeyUnchanged :: AtKeyResult k a + AtKeyInserted :: MapF k a -> AtKeyResult k a + AtKeyModified :: MapF k a -> AtKeyResult k a + AtKeyDeleted :: MapF k a -> AtKeyResult k a + +atKey' :: (OrdF k, Functor f) + => k tp + -> f (Maybe (a tp)) -- ^ Function to call if no element is found. + -> (a tp -> f (UpdateRequest (a tp))) + -> MapF k a + -> f (AtKeyResult k a) +atKey' k onNotFound onFound t = + case asBin t of + TipTree -> ins <$> onNotFound + where ins Nothing = AtKeyUnchanged + ins (Just v) = AtKeyInserted (singleton k v) + BinTree yp@(Pair kx y) l r -> + case compareF k kx of + LTF -> ins <$> atKey' k onNotFound onFound l + where ins AtKeyUnchanged = AtKeyUnchanged + ins (AtKeyInserted l') = AtKeyInserted (balanceL yp l' r) + ins (AtKeyModified l') = AtKeyModified (bin yp l' r) + ins (AtKeyDeleted l') = AtKeyDeleted (balanceR yp l' r) + GTF -> ins <$> atKey' k onNotFound onFound r + where ins AtKeyUnchanged = AtKeyUnchanged + ins (AtKeyInserted r') = AtKeyInserted (balanceR yp l r') + ins (AtKeyModified r') = AtKeyModified (bin yp l r') + ins (AtKeyDeleted r') = AtKeyDeleted (balanceL yp l r') + EQF -> ins <$> onFound y + where ins Keep = AtKeyUnchanged + ins (Set x) = AtKeyModified (bin (Pair kx x) l r) + ins Delete = AtKeyDeleted (glue l r) +{-# INLINABLE atKey' #-} + +-- | Log-time algorithm that allows a value at a specific key to be added, replaced, +-- or deleted. +updateAtKey :: (OrdF k, Functor f) + => k tp -- ^ Key to update + -> f (Maybe (a tp)) + -- ^ Action to call if nothing is found + -> (a tp -> f (UpdateRequest (a tp))) + -- ^ Action to call if value is found. + -> MapF k a + -- ^ Map to update + -> f (Updated (MapF k a)) +updateAtKey k onNotFound onFound t = ins <$> atKey' k onNotFound onFound t + where ins AtKeyUnchanged = Unchanged t + ins (AtKeyInserted t') = Updated t' + ins (AtKeyModified t') = Updated t' + ins (AtKeyDeleted t') = Updated t' +{-# INLINABLE updateAtKey #-} + +-- | Create a Map from a list of pairs. +fromList :: OrdF k => [Pair k a] -> MapF k a +fromList = foldl' (\m (Pair k a) -> insert k a m) Data.Parameterized.Map.empty + +-- | Return list of key-values pairs in map in ascending order. +toAscList :: MapF k a -> [Pair k a] +toAscList = foldrWithKey (\k x l -> Pair k x : l) [] + +-- | Return list of key-values pairs in map in descending order. +toDescList :: MapF k a -> [Pair k a] +toDescList = foldlWithKey (\l k x -> Pair k x : l) [] + +-- | Return list of key-values pairs in map. +toList :: MapF k a -> [Pair k a] +toList = toAscList + +-- | Generate a map from a foldable collection of keys and a +-- function from keys to values. +fromKeys :: forall k m (t :: Type -> Type) (a :: k -> Type) (v :: k -> Type) + . (Monad m, Foldable t, OrdF a) + => (forall tp . a tp -> m (v tp)) + -- ^ Function for evaluating a register value. + -> t (Some a) + -- ^ Set of X86 registers + -> m (MapF a v) +fromKeys f = foldM go empty + where go :: MapF a v -> Some a -> m (MapF a v) + go m (Some k) = (\v -> insert k v m) <$> f k + +-- | Generate a map from a foldable collection of keys and a monadic +-- function from keys to values. +fromKeysM :: forall k m (t :: Type -> Type) (a :: k -> Type) (v :: k -> Type) + . (Monad m, Foldable t, OrdF a) + => (forall tp . a tp -> m (v tp)) + -- ^ Function for evaluating an input value to store the result in the map. + -> t (Some a) + -- ^ Set of input values (traversed via folding) + -> m (MapF a v) +fromKeysM f = foldM go empty + where go :: MapF a v -> Some a -> m (MapF a v) + go m (Some k) = (\v -> insert k v m) <$> f k + +filterGtMaybe :: OrdF k => MaybeS (k x) -> MapF k a -> MapF k a +filterGtMaybe NothingS m = m +filterGtMaybe (JustS k) m = filterGt k m + +filterLtMaybe :: OrdF k => MaybeS (k x) -> MapF k a -> MapF k a +filterLtMaybe NothingS m = m +filterLtMaybe (JustS k) m = filterLt k m + +-- | Returns only entries that are strictly between the two keys. +filterMiddle :: OrdF k => k x -> k y -> MapF k a -> MapF k a +filterMiddle lo hi (Bin _ k _ _ r) + | k `leqF` lo = filterMiddle lo hi r +filterMiddle lo hi (Bin _ k _ l _) + | k `geqF` hi = filterMiddle lo hi l +filterMiddle _ _ t = t +{-# INLINABLE filterMiddle #-} + +{-------------------------------------------------------------------- + [trim blo bhi t] trims away all subtrees that surely contain no + values between the range [blo] to [bhi]. The returned tree is either + empty or the key of the root is between @blo@ and @bhi@. +--------------------------------------------------------------------} +trim :: OrdF k => MaybeS (k x) -> MaybeS (k y) -> MapF k a -> MapF k a +trim NothingS NothingS t = t +trim (JustS lk) NothingS t = filterGt lk t +trim NothingS (JustS hk) t = filterLt hk t +trim (JustS lk) (JustS hk) t = filterMiddle lk hk t + +-- Helper function for 'mergeWithKeyM'. The @'trimLookupLo' lk hk t@ performs both +-- @'trim' (JustS lk) hk t@ and @'lookup' lk t@. + +-- See Note: Type of local 'go' function +trimLookupLo :: OrdF k => k tp -> MaybeS (k y) -> MapF k a -> Bin.PairS (Maybe (a tp)) (MapF k a) +trimLookupLo lk NothingS t = greater lk t + where greater :: OrdF k => k tp -> MapF k a -> Bin.PairS (Maybe (a tp)) (MapF k a) + greater lo t'@(Bin _ kx x l r) = + case compareF lo kx of + LTF -> Bin.PairS (lookup lo l) t' + EQF -> Bin.PairS (Just x) r + GTF -> greater lo r + greater _ Tip = Bin.PairS Nothing Tip +trimLookupLo lk (JustS hk) t = middle lk hk t + where middle :: OrdF k => k tp -> k y -> MapF k a -> Bin.PairS (Maybe (a tp)) (MapF k a) + middle lo hi t'@(Bin _ kx x l r) = + case compareF lo kx of + LTF | kx `ltF` hi -> Bin.PairS (lookup lo l) t' + | otherwise -> middle lo hi l + EQF -> Bin.PairS (Just x) (lesser hi r) + GTF -> middle lo hi r + middle _ _ Tip = Bin.PairS Nothing Tip + + lesser :: OrdF k => k y -> MapF k a -> MapF k a + lesser hi (Bin _ k _ l _) | k `geqF` hi = lesser hi l + lesser _ t' = t' + +-- | Merge bindings in two maps using monadic actions to get a third. +-- +-- The first function is used to merge elements that occur under the +-- same key in both maps. Return Just to add an entry into the +-- resulting map under this key or Nothing to remove this key from the +-- resulting map. +-- +-- The second function will be applied to submaps of the first map +-- argument where no keys overlap with the second map argument. The +-- result of this function must be a map with a subset of the keys of +-- its argument. This means the function can alter the values of its +-- argument and it can remove key-value pairs from it, but it can +-- break `MapF` ordering invariants if it introduces new keys. +-- +-- Third function is analogous to the second function except that it applies +-- to the second map argument of 'mergeWithKeyM' instead of the first. +-- +-- Common examples of the two functions include 'id' when constructing a union +-- or 'const' 'empty' when constructing an intersection. +mergeWithKeyM :: forall k a b c m + . (Applicative m, OrdF k) + => (forall tp . k tp -> a tp -> b tp -> m (Maybe (c tp))) + -> (MapF k a -> m (MapF k c)) + -> (MapF k b -> m (MapF k c)) + -> MapF k a + -> MapF k b + -> m (MapF k c) +mergeWithKeyM f g1 g2 = go + where + go Tip t2 = g2 t2 + go t1 Tip = g1 t1 + go t1 t2 = hedgeMerge NothingS NothingS t1 t2 + + hedgeMerge :: MaybeS (k x) -> MaybeS (k y) -> MapF k a -> MapF k b -> m (MapF k c) + hedgeMerge _ _ t1 Tip = g1 t1 + hedgeMerge blo bhi Tip (Bin _ kx x l r) = + g2 $ Bin.link (Pair kx x) (filterGtMaybe blo l) (filterLtMaybe bhi r) + hedgeMerge blo bhi (Bin _ kx x l r) t2 = + let Bin.PairS found trim_t2 = trimLookupLo kx bhi t2 + resolve_g1 :: MapF k c -> MapF k c -> MapF k c -> MapF k c + resolve_g1 Tip = Bin.merge + resolve_g1 (Bin _ k' x' Tip Tip) = Bin.link (Pair k' x') + resolve_g1 _ = error "mergeWithKey: Bad function g1" + resolve_f Nothing = Bin.merge + resolve_f (Just x') = Bin.link (Pair kx x') + in case found of + Nothing -> + resolve_g1 <$> g1 (singleton kx x) + <*> hedgeMerge blo bmi l (trim blo bmi t2) + <*> hedgeMerge bmi bhi r trim_t2 + Just x2 -> + resolve_f <$> f kx x x2 + <*> hedgeMerge blo bmi l (trim blo bmi t2) + <*> hedgeMerge bmi bhi r trim_t2 + where bmi = JustS kx + +{-# INLINABLE mergeWithKeyM #-} + +-- | Merge bindings in two maps to get a third. +-- +-- The first function is used to merge elements that occur under the +-- same key in both maps. Return Just to add an entry into the +-- resulting map under this key or Nothing to remove this key from the +-- resulting map. +-- +-- The second function will be applied to submaps of the first map +-- argument where no keys overlap with the second map argument. The +-- result of this function must be a map with a subset of the keys of +-- its argument. This means the function can alter the values of its +-- argument and it can remove key-value pairs from it, but it can +-- break `MapF` ordering invariants if it introduces new keys. +-- +-- Third function is analogous to the second function except that it applies +-- to the second map argument of 'mergeWithKeyM' instead of the first. +-- +-- Common examples of the two functions include 'id' when constructing a union +-- or 'const' 'empty' when constructing an intersection. +mergeWithKey :: forall k a b c + . OrdF k + => (forall tp . k tp -> a tp -> b tp -> Maybe (c tp)) + -> (MapF k a -> MapF k c) + -> (MapF k b -> MapF k c) + -> MapF k a + -> MapF k b + -> MapF k c +mergeWithKey f g1 g2 x y = runIdentity $ + mergeWithKeyM (\k a b -> pure $! f k a b) (pure . g1) (pure . g2) x y + +-- | Applies a function to the pairwise common elements of two maps. +-- +-- Formally, we have that @intersectWithKeyMaybe f x y@ contains a +-- binding from a key @k@ to a value @v@ if and only if @x@ and @y@ +-- bind @k@ to @x_k@ and @y_k@ and @f x_k y_k = Just v@. +intersectWithKeyMaybe :: OrdF k + => (forall tp . k tp -> a tp -> b tp -> Maybe (c tp)) + -> MapF k a + -> MapF k b + -> MapF k c +intersectWithKeyMaybe f = mergeWithKey f (const empty) (const empty) diff --git a/src/Data/Parameterized/NatRepr.hs b/src/Data/Parameterized/NatRepr.hs new file mode 100644 index 0000000..718126b --- /dev/null +++ b/src/Data/Parameterized/NatRepr.hs @@ -0,0 +1,650 @@ +{-| +Description : Type level natural number representation at runtime +Copyright : (c) Galois, Inc 2014-2019 +Maintainer : Joe Hendrix + +This defines a type 'NatRepr' for representing a type-level natural +at runtime. This can be used to branch on a type-level value. For +each @n@, @NatRepr n@ contains a single value containing the value +@n@. This can be used to help use type-level variables on code +with data dependendent types. + +The @TestEquality@ and @DecidableEq@ instances for 'NatRepr' +are implemented using 'unsafeCoerce', as is the `isZeroNat` function. This +should be typesafe because we maintain the invariant that the integer value +contained in a NatRepr value matches its static type. +-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +#if __GLASGOW_HASKELL__ >= 805 +{-# LANGUAGE NoStarIsType #-} +#endif +module Data.Parameterized.NatRepr + ( NatRepr + , natValue + , intValue + , knownNat + , withKnownNat + , IsZeroNat(..) + , isZeroNat + , isZeroOrGT1 + , NatComparison(..) + , compareNat + , decNat + , predNat + , incNat + , addNat + , subNat + , divNat + , halfNat + , withDivModNat + , natMultiply + , someNat + , mkNatRepr + , maxNat + , natRec + , natRecStrong + , natRecBounded + , natRecStrictlyBounded + , natForEach + , natFromZero + , NatCases(..) + , testNatCases + -- * Strict order + , lessThanIrreflexive + , lessThanAsymmetric + -- * Bitvector utilities + , widthVal + , minUnsigned + , maxUnsigned + , minSigned + , maxSigned + , toUnsigned + , toSigned + , unsignedClamp + , signedClamp + -- * LeqProof + , LeqProof(..) + , decideLeq + , testLeq + , testStrictLeq + , leqRefl + , leqSucc + , leqTrans + , leqZero + , leqAdd2 + , leqSub2 + , leqMulCongr + -- * LeqProof combinators + , leqProof + , withLeqProof + , isPosNat + , leqAdd + , leqSub + , leqMulPos + , leqAddPos + , addIsLeq + , withAddLeq + , addPrefixIsLeq + , withAddPrefixLeq + , addIsLeqLeft1 + , dblPosIsPos + , leqMulMono + -- * Arithmetic proof + , plusComm + , plusAssoc + , mulComm + , plusMinusCancel + , minusPlusCancel + , addMulDistribRight + , withAddMulDistribRight + , withSubMulDistribRight + , mulCancelR + , mul2Plus + , lemmaMul + -- * Re-exports typelists basics +-- , NatK + , type (+) + , type (-) + , type (*) + , type (<=) + , Equality.TestEquality(..) + , (Equality.:~:)(..) + , Data.Parameterized.Some.Some + ) where + +import Data.Bits ((.&.), bit) +import Data.Data +import Data.Type.Equality as Equality +import Data.Void as Void +import Numeric.Natural +import GHC.TypeNats ( KnownNat, Nat, SomeNat(..) + , type (+), type (-), type (*), type (<=) + , someNatVal ) +import Unsafe.Coerce + +import Data.Parameterized.Axiom +import Data.Parameterized.NatRepr.Internal +import Data.Parameterized.Some + +maxInt :: Natural +maxInt = fromIntegral (maxBound :: Int) + +intValue :: NatRepr n -> Integer +intValue n = toInteger (natValue n) +{-# INLINE intValue #-} + +-- | Return the value of the nat representation. +widthVal :: NatRepr n -> Int +widthVal (NatRepr i) | i <= maxInt = fromIntegral i + | otherwise = error ("Width is too large: " ++ show i) + +withKnownNat :: forall n r. NatRepr n -> (KnownNat n => r) -> r +withKnownNat (NatRepr nVal) v = + case someNatVal nVal of + SomeNat (Proxy :: Proxy n') -> + case unsafeAxiom :: n :~: n' of + Refl -> v + +data IsZeroNat n where + ZeroNat :: IsZeroNat 0 + NonZeroNat :: IsZeroNat (n+1) + +isZeroNat :: NatRepr n -> IsZeroNat n +isZeroNat (NatRepr 0) = unsafeCoerce ZeroNat +isZeroNat (NatRepr _) = unsafeCoerce NonZeroNat + +-- | Every nat is either zero or >= 1. +isZeroOrGT1 :: NatRepr n -> Either (n :~: 0) (LeqProof 1 n) +isZeroOrGT1 n = + case isZeroNat n of + ZeroNat -> Left Refl + NonZeroNat -> Right $ + -- We have n = m + 1 for some m. + let + -- | x <= x + 1 + leqPlus :: forall f x y. ((x + 1) ~ y) => f x -> LeqProof 1 y + leqPlus fx = + case (plusComm fx (knownNat @1) :: x + 1 :~: 1 + x) of { Refl -> + case (plusMinusCancel (knownNat @1) fx :: 1+x-x :~: 1) of { Refl -> + case (LeqProof :: LeqProof (x+1) y) of { LeqProof -> + case (LeqProof :: LeqProof (1+x-x) (y-x)) of { LeqProof -> + leqTrans (LeqProof :: LeqProof 1 (y-x)) + (leqSub (LeqProof :: LeqProof y y) + (leqTrans (leqSucc (Proxy :: Proxy x)) + (LeqProof) :: LeqProof x y) :: LeqProof (y - x) y) + }}}} + in leqPlus (predNat n) + +-- | Decrement a @NatRepr@ +decNat :: (1 <= n) => NatRepr n -> NatRepr (n-1) +decNat (NatRepr i) = NatRepr (i-1) + +-- | Get the predecessor of a nat +predNat :: NatRepr (n+1) -> NatRepr n +predNat (NatRepr i) = NatRepr (i-1) + +-- | Increment a @NatRepr@ +incNat :: NatRepr n -> NatRepr (n+1) +incNat (NatRepr x) = NatRepr (x+1) + +halfNat :: NatRepr (n+n) -> NatRepr n +halfNat (NatRepr x) = NatRepr (x `div` 2) + +addNat :: NatRepr m -> NatRepr n -> NatRepr (m+n) +addNat (NatRepr m) (NatRepr n) = NatRepr (m+n) + +subNat :: (n <= m) => NatRepr m -> NatRepr n -> NatRepr (m-n) +subNat (NatRepr m) (NatRepr n) = NatRepr (m-n) + +divNat :: (1 <= n) => NatRepr (m * n) -> NatRepr n -> NatRepr m +divNat (NatRepr x) (NatRepr y) = NatRepr (div x y) + +withDivModNat :: forall n m a. + NatRepr n + -> NatRepr m + -> (forall div mod. (n ~ ((div * m) + mod)) => + NatRepr div -> NatRepr mod -> a) + -> a +withDivModNat n m f = + case ( Some (NatRepr divPart), Some (NatRepr modPart)) of + ( Some (divn :: NatRepr div), Some (modn :: NatRepr mod) ) + -> case unsafeAxiom of + (Refl :: (n :~: ((div * m) + mod))) -> f divn modn + where + (divPart, modPart) = divMod (natValue n) (natValue m) + +natMultiply :: NatRepr n -> NatRepr m -> NatRepr (n * m) +natMultiply (NatRepr n) (NatRepr m) = NatRepr (n * m) + +------------------------------------------------------------------------ +-- Operations for using NatRepr as a bitwidth. + +-- | Return minimum unsigned value for bitvector with given width (always 0). +minUnsigned :: NatRepr w -> Integer +minUnsigned _ = 0 + +-- | Return maximum unsigned value for bitvector with given width. +maxUnsigned :: NatRepr w -> Integer +maxUnsigned w = bit (widthVal w) - 1 + +-- | Return minimum value for bitvector in two's complement with given width. +minSigned :: (1 <= w) => NatRepr w -> Integer +minSigned w = negate (bit (widthVal w - 1)) + +-- | Return maximum value for bitvector in two's complement with given width. +maxSigned :: (1 <= w) => NatRepr w -> Integer +maxSigned w = bit (widthVal w - 1) - 1 + +-- | @toUnsigned w i@ maps @i@ to a @i `mod` 2^w@. +toUnsigned :: NatRepr w -> Integer -> Integer +toUnsigned w i = maxUnsigned w .&. i + +-- | @toSigned w i@ interprets the least-significant @w@ bits in @i@ as a +-- signed number in two's complement notation and returns that value. +toSigned :: (1 <= w) => NatRepr w -> Integer -> Integer +toSigned w i0 + | i > maxSigned w = i - bit (widthVal w) + | otherwise = i + where i = i0 .&. maxUnsigned w + +-- | @unsignedClamp w i@ rounds @i@ to the nearest value between +-- @0@ and @2^w-1@ (inclusive). +unsignedClamp :: NatRepr w -> Integer -> Integer +unsignedClamp w i + | i < minUnsigned w = minUnsigned w + | i > maxUnsigned w = maxUnsigned w + | otherwise = i + +-- | @signedClamp w i@ rounds @i@ to the nearest value between +-- @-2^(w-1)@ and @2^(w-1)-1@ (inclusive). +signedClamp :: (1 <= w) => NatRepr w -> Integer -> Integer +signedClamp w i + | i < minSigned w = minSigned w + | i > maxSigned w = maxSigned w + | otherwise = i + +------------------------------------------------------------------------ +-- Some NatRepr + +-- | Turn an @Integral@ value into a @NatRepr@. Returns @Nothing@ +-- if the given value is negative. +someNat :: Integral a => a -> Maybe (Some NatRepr) +someNat x | x >= 0 = Just . Some . NatRepr $! fromIntegral x +someNat _ = Nothing + +-- | Turn a @Natural@ into the corresponding @NatRepr@ +mkNatRepr :: Natural -> Some NatRepr +mkNatRepr n = Some (NatRepr n) + +-- | Return the maximum of two nat representations. +maxNat :: NatRepr m -> NatRepr n -> Some NatRepr +maxNat x y + | natValue x >= natValue y = Some x + | otherwise = Some y + +------------------------------------------------------------------------ +-- Arithmetic + +-- | Produce evidence that @+@ is commutative. +plusComm :: forall f m g n . f m -> g n -> m+n :~: n+m +plusComm _ _ = unsafeAxiom + +-- | Produce evidence that @+@ is associative. +plusAssoc :: forall f m g n h o . f m -> g n -> h o -> m+(n+o) :~: (m+n)+o +plusAssoc _ _ _ = unsafeAxiom + +-- | Produce evidence that @*@ is commutative. +mulComm :: forall f m g n. f m -> g n -> (m * n) :~: (n * m) +mulComm _ _ = unsafeAxiom + +mul2Plus :: forall f n. f n -> (n + n) :~: (2 * n) +mul2Plus n = case addMulDistribRight (Proxy @1) (Proxy @1) n of + Refl -> Refl + +-- | Cancel an add followed by a subtract +plusMinusCancel :: forall f m g n . f m -> g n -> (m + n) - n :~: m +plusMinusCancel _ _ = unsafeAxiom + +minusPlusCancel :: forall f m g n . (n <= m) => f m -> g n -> (m - n) + n :~: m +minusPlusCancel _ _ = unsafeAxiom + +addMulDistribRight :: forall n m p f g h. f n -> g m -> h p + -> ((n * p) + (m * p)) :~: ((n + m) * p) +addMulDistribRight _n _m _p = unsafeAxiom + + + +withAddMulDistribRight :: forall n m p f g h a. f n -> g m -> h p + -> ( (((n * p) + (m * p)) ~ ((n + m) * p)) => a) -> a +withAddMulDistribRight n m p f = + case addMulDistribRight n m p of + Refl -> f + +withSubMulDistribRight :: forall n m p f g h a. (m <= n) => f n -> g m -> h p + -> ( (((n * p) - (m * p)) ~ ((n - m) * p)) => a) -> a +withSubMulDistribRight _n _m _p f = + case unsafeAxiom of + (Refl :: (((n * p) - (m * p)) :~: ((n - m) * p)) ) -> f + +------------------------------------------------------------------------ +-- LeqProof + +-- | @LeqProof m n@ is a type whose values are only inhabited when @m@ +-- is less than or equal to @n@. +data LeqProof (m :: Nat) (n :: Nat) where + LeqProof :: (m <= n) => LeqProof m n + +-- | (<=) is a decidable relation on nats. +decideLeq :: NatRepr a -> NatRepr b -> Either (LeqProof a b) ((LeqProof a b) -> Void) +decideLeq (NatRepr m) (NatRepr n) + | m <= n = Left $ unsafeCoerce (LeqProof :: LeqProof 0 0) + | otherwise = Right $ + \x -> seq x $ error "Impossible [decidable <= on NatRepr]" + +testStrictLeq :: forall m n + . (m <= n) + => NatRepr m + -> NatRepr n + -> Either (LeqProof (m+1) n) (m :~: n) +testStrictLeq (NatRepr m) (NatRepr n) + | m < n = Left (unsafeCoerce (LeqProof :: LeqProof 0 0)) + | otherwise = Right unsafeAxiom +{-# NOINLINE testStrictLeq #-} + +-- As for NatComparison above, but works with LeqProof +data NatCases m n where + -- First number is less than second. + NatCaseLT :: LeqProof (m+1) n -> NatCases m n + NatCaseEQ :: NatCases m m + -- First number is greater than second. + NatCaseGT :: LeqProof (n+1) m -> NatCases m n + +testNatCases :: forall m n + . NatRepr m + -> NatRepr n + -> NatCases m n +testNatCases m n = + case compare (natValue m) (natValue n) of + LT -> NatCaseLT (unsafeCoerce (LeqProof :: LeqProof 0 0)) + EQ -> unsafeCoerce $ (NatCaseEQ :: NatCases m m) + GT -> NatCaseGT (unsafeCoerce (LeqProof :: LeqProof 0 0)) +{-# NOINLINE testNatCases #-} + +-- | The strict order (\<), defined by n \< m \<-> n + 1 \<= m, is irreflexive. +lessThanIrreflexive :: forall f (a :: Nat). f a -> LeqProof (1 + a) a -> Void +lessThanIrreflexive a prf = + let prf1 :: LeqProof (1 + a - a) (a - a) + prf1 = leqSub2 prf (LeqProof :: LeqProof a a) + prf2 :: 1 + a - a :~: 1 + prf2 = plusMinusCancel (knownNat @1) a + prf3 :: a - a :~: 0 + prf3 = plusMinusCancel (knownNat @0) a + prf4 :: LeqProof 1 0 + prf4 = case prf2 of Refl -> case prf3 of { Refl -> prf1 } + in case prf4 of {} + +-- | The strict order on the naturals is asymmetric +lessThanAsymmetric :: forall m f n + . LeqProof (n+1) m + -> LeqProof (m+1) n + -> f n + -> Void +lessThanAsymmetric nLTm mLTn n = + case plusComm n (knownNat @1) :: n + 1 :~: 1 + n of { Refl -> + case leqAdd (LeqProof :: LeqProof m m) (knownNat @1) :: LeqProof m (m+1) of + LeqProof -> lessThanIrreflexive n $ leqTrans (leqTrans nLTm LeqProof) mLTn + } + +-- | @x `testLeq` y@ checks whether @x@ is less than or equal to @y@. +testLeq :: forall m n . NatRepr m -> NatRepr n -> Maybe (LeqProof m n) +testLeq (NatRepr m) (NatRepr n) + | m <= n = Just (unsafeCoerce (LeqProof :: LeqProof 0 0)) + | otherwise = Nothing +{-# NOINLINE testLeq #-} + +-- | Apply reflexivity to LeqProof +leqRefl :: forall f n . f n -> LeqProof n n +leqRefl _ = LeqProof + +leqSucc :: forall f z. f z -> LeqProof z (z + 1) +leqSucc fz = leqAdd (leqRefl fz :: LeqProof z z) (knownNat @1) + +-- | Apply transitivity to LeqProof +leqTrans :: LeqProof m n -> LeqProof n p -> LeqProof m p +leqTrans LeqProof LeqProof = unsafeCoerce (LeqProof :: LeqProof 0 0) +{-# NOINLINE leqTrans #-} + +-- | Zero is less than or equal to any 'Nat'. +leqZero :: LeqProof 0 n +leqZero = unsafeCoerce (LeqProof :: LeqProof 0 0) + +-- | Add both sides of two inequalities +leqAdd2 :: LeqProof x_l x_h -> LeqProof y_l y_h -> LeqProof (x_l + y_l) (x_h + y_h) +leqAdd2 x y = seq x $ seq y $ unsafeCoerce (LeqProof :: LeqProof 0 0) +{-# NOINLINE leqAdd2 #-} + +-- | Subtract sides of two inequalities. +leqSub2 :: LeqProof x_l x_h + -> LeqProof y_l y_h + -> LeqProof (x_l-y_h) (x_h-y_l) +leqSub2 LeqProof LeqProof = unsafeCoerce (LeqProof :: LeqProof 0 0) +{-# NOINLINE leqSub2 #-} + +------------------------------------------------------------------------ +-- LeqProof combinators + +-- | Create a leqProof using two proxies +leqProof :: (m <= n) => f m -> g n -> LeqProof m n +leqProof _ _ = LeqProof + +withLeqProof :: LeqProof m n -> ((m <= n) => a) -> a +withLeqProof p a = + case p of + LeqProof -> a + +-- | Test whether natural number is positive. +isPosNat :: NatRepr n -> Maybe (LeqProof 1 n) +isPosNat = testLeq (knownNat :: NatRepr 1) + +-- | Congruence rule for multiplication +leqMulCongr :: LeqProof a x + -> LeqProof b y + -> LeqProof (a*b) (x*y) +leqMulCongr LeqProof LeqProof = unsafeCoerce (LeqProof :: LeqProof 1 1) +{-# NOINLINE leqMulCongr #-} + +-- | Multiplying two positive numbers results in a positive number. +leqMulPos :: forall p q x y + . (1 <= x, 1 <= y) + => p x + -> q y + -> LeqProof 1 (x*y) +leqMulPos _ _ = leqMulCongr (LeqProof :: LeqProof 1 x) (LeqProof :: LeqProof 1 y) + +leqMulMono :: (1 <= x) => p x -> q y -> LeqProof y (x * y) +leqMulMono x y = leqMulCongr (leqProof (Proxy :: Proxy 1) x) (leqRefl y) + +-- | Produce proof that adding a value to the larger element in an LeqProof +-- is larger +leqAdd :: forall f m n p . LeqProof m n -> f p -> LeqProof m (n+p) +leqAdd x _ = leqAdd2 x (leqZero @p) + +leqAddPos :: (1 <= m, 1 <= n) => p m -> q n -> LeqProof 1 (m + n) +leqAddPos m n = leqAdd (leqProof (Proxy :: Proxy 1) m) n + +-- | Produce proof that subtracting a value from the smaller element is smaller. +leqSub :: forall m n p . LeqProof m n -> LeqProof p m -> LeqProof (m-p) n +leqSub x _ = leqSub2 x (leqZero @p) + +addIsLeq :: f n -> g m -> LeqProof n (n + m) +addIsLeq n m = leqAdd (leqRefl n) m + +addPrefixIsLeq :: f m -> g n -> LeqProof n (m + n) +addPrefixIsLeq m n = + case plusComm n m of + Refl -> addIsLeq n m + +dblPosIsPos :: forall n . LeqProof 1 n -> LeqProof 1 (n+n) +dblPosIsPos x = leqAdd x Proxy + +addIsLeqLeft1 :: forall n n' m . LeqProof (n + n') m -> LeqProof n m +addIsLeqLeft1 p = + case plusMinusCancel n n' of + Refl -> leqSub p le + where n :: Proxy n + n = Proxy + n' :: Proxy n' + n' = Proxy + le :: LeqProof n' (n + n') + le = addPrefixIsLeq n n' + +{-# INLINE withAddPrefixLeq #-} +withAddPrefixLeq :: NatRepr n -> NatRepr m -> ((m <= n + m) => a) -> a +withAddPrefixLeq n m = withLeqProof (addPrefixIsLeq n m) + +withAddLeq :: forall n m a. NatRepr n -> NatRepr m -> ((n <= n + m) => NatRepr (n + m) -> a) -> a +withAddLeq n m f = withLeqProof (addIsLeq n m) (f (addNat n m)) + +natForEach' :: forall l h a + . NatRepr l + -> NatRepr h + -> (forall n. LeqProof l n -> LeqProof n h -> NatRepr n -> a) + -> [a] +natForEach' l h f + | Just LeqProof <- testLeq l h = + let f' :: forall n. LeqProof (l + 1) n -> LeqProof n h -> NatRepr n -> a + f' = \lp hp -> f (addIsLeqLeft1 lp) hp + in f LeqProof LeqProof l : natForEach' (incNat l) h f' + | otherwise = [] + +-- | Apply a function to each element in a range; return the list of values +-- obtained. +natForEach :: forall l h a + . NatRepr l + -> NatRepr h + -> (forall n. (l <= n, n <= h) => NatRepr n -> a) + -> [a] +natForEach l h f = natForEach' l h (\LeqProof LeqProof -> f) + +-- | Apply a function to each element in a range starting at zero; +-- return the list of values obtained. +natFromZero :: forall h a + . NatRepr h + -> (forall n. (n <= h) => NatRepr n -> a) + -> [a] +natFromZero h f = natForEach (knownNat @0) h f + +-- | Recursor for natural numbeers. +natRec :: forall p f + . NatRepr p + -> f 0 {- ^ base case -} + -> (forall n. NatRepr n -> f n -> f (n + 1)) + -> f p +natRec n base ind = + case isZeroNat n of + ZeroNat -> base + NonZeroNat -> let n' = predNat n + in ind n' (natRec n' base ind) + +-- | Strong induction variant of the recursor. +natRecStrong :: forall p f + . NatRepr p + -> f 0 {- ^ base case -} + -> (forall n. + NatRepr n -> + (forall m. (m <= n) => NatRepr m -> f m) -> + f (n + 1)) {- ^ inductive step -} + -> f p +natRecStrong p base ind = natRecStrong' base ind p + where -- We can't use use "flip" or some other basic combinator + -- because type variables can't be instantiated to contain "forall"s. + natRecStrong' :: forall p' f' + . f' 0 {- ^ base case -} + -> (forall n. + NatRepr n -> + (forall m. (m <= n) => NatRepr m -> f' m) -> + f' (n + 1)) {- ^ inductive step -} + -> NatRepr p' + -> f' p' + natRecStrong' base' ind' n = + case isZeroNat n of + ZeroNat -> base' + NonZeroNat -> ind' (predNat n) (natRecStrong' base' ind') + +-- | Bounded recursor for natural numbers. +-- +-- If you can prove: +-- - Base case: f 0 +-- - Inductive step: if n <= h and (f n) then (f (n + 1)) +-- You can conclude: for all n <= h, (f (n + 1)). +natRecBounded :: forall m h f. (m <= h) + => NatRepr m + -> NatRepr h + -> f 0 + -> (forall n. (n <= h) => NatRepr n -> f n -> f (n + 1)) + -> f (m + 1) +natRecBounded m h base indH = + case isZeroOrGT1 m of + Left Refl -> indH (knownNat @0) base + Right LeqProof -> + case decideLeq m h of + Left LeqProof {- :: m <= h -} -> + let -- Since m is non-zero, it is n + 1 for some n. + lemma :: LeqProof (m-1) h + lemma = leqSub (LeqProof :: LeqProof m h) (LeqProof :: LeqProof 1 m) + in indH m $ + case lemma of { LeqProof -> + case minusPlusCancel m (knownNat @1) of { Refl -> + natRecBounded @(m - 1) @h @f (predNat m) h base indH + }} + Right f {- :: (m <= h) -> Void -} -> + absurd $ f (LeqProof :: LeqProof m h) + +-- | A version of 'natRecBounded' which doesn't require the type index of the +-- result to be greater than @0@ and provides a strict inequality constraint. +natRecStrictlyBounded :: + forall m f. + NatRepr m -> + f 0 -> + (forall n. (n + 1 <= m) => NatRepr n -> f n -> f (n + 1)) -> + f m +natRecStrictlyBounded m base indH = + case isZeroNat m of + ZeroNat -> base + NonZeroNat -> + case predNat m of + (p :: NatRepr p) -> + natRecBounded + p + p + base + (\(k :: NatRepr n) (v :: f n) -> + case leqAdd2 (LeqProof :: LeqProof n p) (LeqProof :: LeqProof 1 1) of + LeqProof -> indH k v) + +mulCancelR :: + (1 <= c, (n1 * c) ~ (n2 * c)) => f1 n1 -> f2 n2 -> f3 c -> (n1 :~: n2) +mulCancelR _ _ _ = unsafeAxiom + +-- | Used in @Vector@ +lemmaMul :: (1 <= n) => p w -> q n -> (w + (n-1) * w) :~: (n * w) +lemmaMul _ _ = unsafeAxiom diff --git a/src/Data/Parameterized/NatRepr/Internal.hs b/src/Data/Parameterized/NatRepr/Internal.hs new file mode 100644 index 0000000..fad97e1 --- /dev/null +++ b/src/Data/Parameterized/NatRepr/Internal.hs @@ -0,0 +1,100 @@ +{-| +Copyright : (c) Galois, Inc 2014-2018 +Maintainer : Joe Hendrix + +This internal module exports the 'NatRepr' type and its constructor. It is intended +for use only within parameterized-utils, and is excluded from the module export list. +-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Parameterized.NatRepr.Internal where + +import Data.Data +import Data.Hashable +import GHC.TypeNats +import qualified Numeric.Natural as Natural +import Unsafe.Coerce + +import Data.Parameterized.Axiom +import Data.Parameterized.Classes +import Data.Parameterized.DecidableEq + +------------------------------------------------------------------------ +-- Nat + +-- | A runtime presentation of a type-level 'Nat'. +-- +-- This can be used for performing dynamic checks on a type-level natural +-- numbers. +newtype NatRepr (n::Nat) = NatRepr { natValue :: Natural.Natural + -- ^ The underlying natural value of the number. + } + deriving (Hashable, Data) + +type role NatRepr nominal + +instance Eq (NatRepr m) where + _ == _ = True + +instance TestEquality NatRepr where + testEquality (NatRepr m) (NatRepr n) + | m == n = Just unsafeAxiom + | otherwise = Nothing + +instance DecidableEq NatRepr where + decEq (NatRepr m) (NatRepr n) + | m == n = Left unsafeAxiom + | otherwise = Right $ + \x -> seq x $ error "Impossible [DecidableEq on NatRepr]" + +compareNat :: NatRepr m -> NatRepr n -> NatComparison m n +compareNat m n = + case compare (natValue m) (natValue n) of + LT -> unsafeCoerce (NatLT @0 @0) (NatRepr (natValue n - natValue m - 1)) + EQ -> unsafeCoerce NatEQ + GT -> unsafeCoerce (NatGT @0 @0) (NatRepr (natValue m - natValue n - 1)) + +-- | Result of comparing two numbers. +data NatComparison m n where + -- First number is less than second. + NatLT :: x+1 <= x+(y+1) => !(NatRepr y) -> NatComparison x (x+(y+1)) + NatEQ :: NatComparison x x + -- First number is greater than second. + NatGT :: x+1 <= x+(y+1) => !(NatRepr y) -> NatComparison (x+(y+1)) x + +instance OrdF NatRepr where + compareF x y = + case compareNat x y of + NatLT _ -> LTF + NatEQ -> EQF + NatGT _ -> GTF + +instance PolyEq (NatRepr m) (NatRepr n) where + polyEqF x y = fmap (\Refl -> Refl) $ testEquality x y + +instance Show (NatRepr n) where + show (NatRepr n) = show n + +instance ShowF NatRepr + +instance HashableF NatRepr where + hashWithSaltF = hashWithSalt + +-- | This generates a NatRepr from a type-level context. +knownNat :: forall n . KnownNat n => NatRepr n +knownNat = NatRepr (natVal (Proxy :: Proxy n)) + +instance (KnownNat n) => KnownRepr NatRepr n where + knownRepr = knownNat diff --git a/src/Data/Parameterized/Nonce.hs b/src/Data/Parameterized/Nonce.hs new file mode 100644 index 0000000..895f370 --- /dev/null +++ b/src/Data/Parameterized/Nonce.hs @@ -0,0 +1,167 @@ +{-| +Description : Index generator in the ST monad. +Copyright : (c) Galois, Inc 2014-2019 +Maintainer : Joe Hendrix + +This module provides a simple generator of new indexes in the 'ST' monad. +It is predictable and not intended for cryptographic purposes. + +This module also provides a global nonce generator that will generate +2^64 nonces before repeating. + +NOTE: The 'TestEquality' and 'OrdF' instances for the 'Nonce' type simply +compare the generated nonce values and then assert to the compiler +(via 'unsafeCoerce') that the types ascribed to the nonces are equal +if their values are equal. +-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE Trustworthy #-} +#if __GLASGOW_HASKELL__ < 806 +{-# LANGUAGE TypeInType #-} +#endif +module Data.Parameterized.Nonce + ( -- * NonceGenerator + NonceGenerator + , freshNonce + , countNoncesGenerated + , Nonce + , indexValue + -- * Accessing a nonce generator + , newSTNonceGenerator + , newIONonceGenerator + , withIONonceGenerator + , withSTNonceGenerator + , runSTNonceGenerator + -- * Global nonce generator + , withGlobalSTNonceGenerator + , GlobalNonceGenerator + , globalNonceGenerator + ) where + +import Control.Monad.ST +import Data.Hashable +import Data.Kind +import Data.IORef +import Data.STRef +import Data.Word +import Unsafe.Coerce +import System.IO.Unsafe (unsafePerformIO) + +import Data.Parameterized.Axiom +import Data.Parameterized.Classes +import Data.Parameterized.Some + +-- | Provides a monadic action for getting fresh typed names. +-- +-- The first type parameter @m@ is the monad used for generating names, and +-- the second parameter @s@ is used for the counter. +data NonceGenerator (m :: Type -> Type) (s :: Type) where + STNG :: !(STRef t Word64) -> NonceGenerator (ST t) s + IONG :: !(IORef Word64) -> NonceGenerator IO s + +freshNonce :: forall m s k (tp :: k) . NonceGenerator m s -> m (Nonce s tp) +freshNonce (IONG r) = + atomicModifyIORef' r $ \n -> (n+1, Nonce n) +freshNonce (STNG r) = do + i <- readSTRef r + writeSTRef r $! i+1 + return $ Nonce i + -- (Weirdly, there's no atomicModifySTRef'. Yes, only the IO monad + -- does concurrency, but the ST monad is part of the IO monad via + -- stToIO, so there's no guarantee that ST code won't be run in + -- multiple threads.) + +{-# INLINE freshNonce #-} + -- Inlining is particularly necessary since there's no @Monad m@ + -- constraint on 'freshNonce', so SPECIALIZE doesn't work on it. In + -- this case, though, we get specialization for free from inlining. + -- For instance, a @NonceGenerator IO s@ must be an @IONG@, so the + -- simplifier eliminates the STNG branch. + +-- | The number of nonces generated so far by this generator. Only +-- really useful for profiling. +countNoncesGenerated :: NonceGenerator m s -> m Integer +countNoncesGenerated (IONG r) = toInteger <$> readIORef r +countNoncesGenerated (STNG r) = toInteger <$> readSTRef r + +-- | Create a new nonce generator in the 'ST' monad. +newSTNonceGenerator :: ST t (Some (NonceGenerator (ST t))) +newSTNonceGenerator = Some . STNG <$> newSTRef (toEnum 0) + +-- | This combines `runST` and `newSTNonceGenerator` to create a nonce +-- generator that shares the same phantom type parameter as the @ST@ monad. +-- +-- This can be used to reduce the number of type parameters when we know a +-- ST computation only needs a single `NonceGenerator`. +runSTNonceGenerator :: (forall s . NonceGenerator (ST s) s -> ST s a) + -> a +runSTNonceGenerator f = runST $ f . STNG =<< newSTRef 0 + +-- | Create a new nonce generator in the 'IO' monad. +newIONonceGenerator :: IO (Some (NonceGenerator IO)) +newIONonceGenerator = Some . IONG <$> newIORef (toEnum 0) + +-- | Run an 'ST' computation with a new nonce generator in the 'ST' monad. +withSTNonceGenerator :: (forall s . NonceGenerator (ST t) s -> ST t r) -> ST t r +withSTNonceGenerator f = do + Some r <- newSTNonceGenerator + f r + +-- | Run an 'IO' computation with a new nonce generator in the 'IO' monad. +withIONonceGenerator :: (forall s . NonceGenerator IO s -> IO r) -> IO r +withIONonceGenerator f = do + Some r <- newIONonceGenerator + f r + +-- | An index generated by the counter. +newtype Nonce (s :: Type) (tp :: k) = Nonce { indexValue :: Word64 } + deriving (Eq, Ord, Hashable, Show) + +-- Force the type role of Nonce to be nominal: this prevents Data.Coerce.coerce +-- from casting the types of nonces, which it would otherwise be able to do +-- because tp is a phantom type parameter. This partially helps to protect +-- the nonce abstraction. +type role Nonce nominal nominal + +instance TestEquality (Nonce s) where + testEquality x y | indexValue x == indexValue y = Just unsafeAxiom + | otherwise = Nothing + +instance OrdF (Nonce s) where + compareF x y = + case compare (indexValue x) (indexValue y) of + LT -> LTF + EQ -> unsafeCoerce EQF + GT -> GTF + +instance HashableF (Nonce s) where + hashWithSaltF s (Nonce x) = hashWithSalt s x + +instance ShowF (Nonce s) + +------------------------------------------------------------------------ +-- * GlobalNonceGenerator + +data GlobalNonceGenerator + +globalNonceIORef :: IORef Word64 +globalNonceIORef = unsafePerformIO (newIORef 0) +{-# NOINLINE globalNonceIORef #-} + +-- | A nonce generator that uses a globally-defined counter. +globalNonceGenerator :: NonceGenerator IO GlobalNonceGenerator +globalNonceGenerator = IONG globalNonceIORef + +-- | Create a new counter. +withGlobalSTNonceGenerator :: (forall t . NonceGenerator (ST t) t -> ST t r) -> r +withGlobalSTNonceGenerator f = runST $ do + r <- newSTRef (toEnum 0) + f $! STNG r diff --git a/src/Data/Parameterized/Nonce/Transformers.hs b/src/Data/Parameterized/Nonce/Transformers.hs new file mode 100644 index 0000000..8133a8a --- /dev/null +++ b/src/Data/Parameterized/Nonce/Transformers.hs @@ -0,0 +1,72 @@ +{-| +Description : A typeclass and monad transformers for generating nonces. +Copyright : (c) Galois, Inc 2014-2019 +Maintainer : Eddy Westbrook + +This module provides a typeclass and monad transformers for generating +nonces. +-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +module Data.Parameterized.Nonce.Transformers + ( MonadNonce(..) + , NonceT(..) + , NonceST + , NonceIO + , getNonceSTGen + , runNonceST + , runNonceIO + , module Data.Parameterized.Nonce + ) where + +import Control.Monad.Reader +import Control.Monad.ST +import Control.Monad.State +import Data.Kind + +import Data.Parameterized.Nonce + + +-- | A 'MonadNonce' is a monad that can generate fresh 'Nonce's in a given set +-- (where we view the phantom type parameter of 'Nonce' as a designator of the +-- set that the 'Nonce' came from). +class Monad m => MonadNonce m where + type NonceSet m :: Type + freshNonceM :: forall k (tp :: k) . m (Nonce (NonceSet m) tp) + +-- | This transformer adds a nonce generator to a given monad. +newtype NonceT s m a = + NonceT { runNonceT :: ReaderT (NonceGenerator m s) m a } + deriving (Functor, Applicative, Monad) + +instance MonadTrans (NonceT s) where + lift m = NonceT $ lift m + +instance Monad m => MonadNonce (NonceT s m) where + type NonceSet (NonceT s m) = s + freshNonceM = NonceT $ lift . freshNonce =<< ask + +instance MonadNonce m => MonadNonce (StateT s m) where + type NonceSet (StateT s m) = NonceSet m + freshNonceM = lift $ freshNonceM + +-- | Helper type to build a 'MonadNonce' from the 'ST' monad. +type NonceST t s = NonceT s (ST t) + +-- | Helper type to build a 'MonadNonce' from the 'IO' monad. +type NonceIO s = NonceT s IO + +-- | Return the actual 'NonceGenerator' used in an 'ST' computation. +getNonceSTGen :: NonceST t s (NonceGenerator (ST t) s) +getNonceSTGen = NonceT ask + +-- | Run a 'NonceST' computation with a fresh 'NonceGenerator'. +runNonceST :: (forall t s. NonceST t s a) -> a +runNonceST m = runST $ withSTNonceGenerator $ runReaderT $ runNonceT m + +-- | Run a 'NonceIO' computation with a fresh 'NonceGenerator' inside 'IO'. +runNonceIO :: (forall s. NonceIO s a) -> IO a +runNonceIO m = withIONonceGenerator $ runReaderT $ runNonceT m diff --git a/src/Data/Parameterized/Nonce/Unsafe.hs b/src/Data/Parameterized/Nonce/Unsafe.hs new file mode 100644 index 0000000..1ef11a3 --- /dev/null +++ b/src/Data/Parameterized/Nonce/Unsafe.hs @@ -0,0 +1,96 @@ +------------------------------------------------------------------------ +-- | +-- Module : Data.Parameterized.Nonce.Unsafe +-- Description : A counter in the ST monad. +-- Copyright : (c) Galois, Inc 2014 +-- Maintainer : Joe Hendrix +-- Stability : provisional +-- +-- This module provides a simple generator of new indexes in the ST monad. +-- It is predictable and not intended for cryptographic purposes. +-- +-- NOTE: the 'TestEquality' and 'OrdF' instances for the 'Nonce' type simply +-- compare the generated nonce values and then assert to the compiler +-- (via 'unsafeCoerce') that the types ascribed to the nonces are equal +-- if their values are equal. This is only OK because of the discipline +-- by which nonces should be used: they should only be generated from +-- a 'NonceGenerator' (i.e., should not be built directly), and nonces from +-- different generators must never be compared! Arranging to compare +-- Nonces from different origins would allow users to build 'unsafeCoerce' +-- via the 'testEquality' function. +-- +-- This module is deprecated, and should not be used in new code. +-- Clients of this module should migrate to use "Data.Parameterized.Nonce". +------------------------------------------------------------------------- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE Unsafe #-} +module Data.Parameterized.Nonce.Unsafe + {-# DEPRECATED "Migrate to use Data.Parameterized.Nonce instead, this module will be removed soon." #-} + ( NonceGenerator + , newNonceGenerator + , freshNonce + , atLimit + , Nonce + , indexValue + ) where + +import Control.Monad.ST +import Data.Hashable +import Data.STRef +import Data.Word +import Unsafe.Coerce + +import Data.Parameterized.Axiom +import Data.Parameterized.Classes + +-- | A simple type that for getting fresh indices in the 'ST' monad. +-- The type parameter @s@ is used for the 'ST' monad parameter. +newtype NonceGenerator s = NonceGenerator (STRef s Word64) + +-- | Create a new counter. +newNonceGenerator :: ST s (NonceGenerator s) +newNonceGenerator = NonceGenerator `fmap` newSTRef (toEnum 0) + +-- | An index generated by the counter. +newtype Nonce (tp :: k) = Nonce { indexValue :: Word64 } + deriving (Eq, Ord, Hashable, Show) + +-- Force the type role of Nonce to be nominal: this prevents Data.Coerce.coerce +-- from casting the types of nonces, which it would otherwise be able to do +-- because tp is a phantom type parameter. This partially helps to protect +-- the nonce abstraction. +type role Nonce nominal + +instance TestEquality Nonce where + testEquality x y | indexValue x == indexValue y = Just unsafeAxiom + | otherwise = Nothing + +instance OrdF Nonce where + compareF x y = + case compare (indexValue x) (indexValue y) of + LT -> LTF + EQ -> unsafeCoerce EQF + GT -> GTF + +instance HashableF Nonce where + hashWithSaltF s (Nonce x) = hashWithSalt s x + +instance ShowF Nonce + +{-# INLINE freshNonce #-} +-- | Get a fresh index and increment the counter. +freshNonce :: NonceGenerator s -> ST s (Nonce tp) +freshNonce (NonceGenerator r) = do + i <- readSTRef r + writeSTRef r $! succ i + return (Nonce i) + +-- | Return true if counter has reached the limit, and can't be +-- incremented without risk of error. +atLimit :: NonceGenerator s -> ST s Bool +atLimit (NonceGenerator r) = do + i <- readSTRef r + return (i == maxBound) diff --git a/src/Data/Parameterized/Pair.hs b/src/Data/Parameterized/Pair.hs new file mode 100644 index 0000000..2b8eb41 --- /dev/null +++ b/src/Data/Parameterized/Pair.hs @@ -0,0 +1,53 @@ +{-| +Description : A 2-tuple with identically parameterized elements +Copyright : (c) Galois, Inc 2017-2019 + +This module defines a 2-tuple where both elements are parameterized over the +same existentially quantified parameter. + +-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +module Data.Parameterized.Pair + ( Pair(..) + , fstPair + , sndPair + , viewPair + ) where + +import Data.Kind +import Data.Parameterized.Classes +import Data.Parameterized.Some +import Data.Parameterized.TraversableF + +-- | Like a 2-tuple, but with an existentially quantified parameter that both of +-- the elements share. +data Pair (a :: k -> Type) (b :: k -> Type) where + Pair :: !(a tp) -> !(b tp) -> Pair a b + +instance (TestEquality a, EqF b) => Eq (Pair a b) where + Pair xa xb == Pair ya yb = + case testEquality xa ya of + Just Refl -> eqF xb yb + Nothing -> False + +instance FunctorF (Pair a) where + fmapF f (Pair x y) = Pair x (f y) + +instance FoldableF (Pair a) where + foldMapF f (Pair _ y) = f y + foldrF f z (Pair _ y) = f y z + +-- | Extract the first element of a pair. +fstPair :: Pair a b -> Some a +fstPair (Pair x _) = Some x + +-- | Extract the second element of a pair. +sndPair :: Pair a b -> Some b +sndPair (Pair _ y) = Some y + +-- | Project out of Pair. +viewPair :: (forall tp. a tp -> b tp -> c) -> Pair a b -> c +viewPair f (Pair x y) = f x y diff --git a/src/Data/Parameterized/Peano.hs b/src/Data/Parameterized/Peano.hs new file mode 100644 index 0000000..942e1c3 --- /dev/null +++ b/src/Data/Parameterized/Peano.hs @@ -0,0 +1,498 @@ +{-| +Description: Representations of a type-level natural at runtime. +Copyright : (c) Galois, Inc 2019 + +This defines a type 'Peano' and 'PeanoRepr' for representing a +type-level natural at runtime. These type-level numbers are defined +inductively instead of using GHC.TypeLits. + +As a result, type-level computation defined recursively over these +numbers works more smoothly. (For example, see the type-level +function 'Repeat' below.) + +Note: as in "NatRepr", in UNSAFE mode, the runtime representation of +these type-level natural numbers is 'Word64'. + +-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +#if __GLASGOW_HASKELL__ >= 805 +{-# LANGUAGE NoStarIsType #-} +#endif +module Data.Parameterized.Peano + ( -- * Peano + Peano + , Z , S + + -- * Basic arithmetic + , Plus, Minus, Mul, Max, Min + , plusP, minusP, mulP, maxP, minP + , zeroP, succP, predP + + -- * Counting + , Repeat, CtxSizeP + , repeatP, ctxSizeP + -- * Comparisons + , Le, Lt, Gt, Ge + , leP, ltP, gtP, geP + + -- * Runtime representation + , KnownPeano + , PeanoRepr + , PeanoView(..), peanoView, viewRepr + + -- * 'Some Peano' + , mkPeanoRepr, peanoValue + , somePeano + , maxPeano + , minPeano + , peanoLength + + -- * Properties + , plusCtxSizeAxiom + , minusPlusAxiom + , ltMinusPlusAxiom + + -- * Re-exports + , TestEquality(..) + , (:~:)(..) + , Data.Parameterized.Some.Some + + ) where + +import Data.Parameterized.BoolRepr +import Data.Parameterized.Classes +import Data.Parameterized.DecidableEq +import Data.Parameterized.Some +import Data.Parameterized.Context + +import Data.Word + +#ifdef UNSAFE_OPS +import Data.Parameterized.Axiom +import Unsafe.Coerce(unsafeCoerce) +#endif + +------------------------------------------------------------------------ +-- * Peano arithmetic + +-- | Unary representation for natural numbers +data Peano = Z | S Peano +-- | Peano zero +type Z = 'Z +-- | Peano successor +type S = 'S + +-- Peano numbers are more about *counting* than arithmetic. +-- They are most useful as iteration arguments and list indices +-- However, for completeness, we define a few standard +-- operations. + + +-- | Addition +type family Plus (a :: Peano) (b :: Peano) :: Peano where + Plus Z b = b + Plus (S a) b = S (Plus a b) + +-- | Subtraction +type family Minus (a :: Peano) (b :: Peano) :: Peano where + Minus Z b = Z + Minus (S a) (S b) = Minus a b + Minus a Z = a + +-- | Multiplication +type family Mul (a :: Peano) (b :: Peano) :: Peano where + Mul Z b = Z + Mul (S a) b = Plus a (Mul a b) + +-- | Less-than-or-equal +type family Le (a :: Peano) (b :: Peano) :: Bool where + Le Z b = 'True + Le a Z = 'False + Le (S a) (S b) = Le a b + +-- | Less-than +type family Lt (a :: Peano) (b :: Peano) :: Bool where + Lt a b = Le (S a) b + +-- | Greater-than +type family Gt (a :: Peano) (b :: Peano) :: Bool where + Gt a b = Le b a + +-- | Greater-than-or-equal +type family Ge (a :: Peano) (b :: Peano) :: Bool where + Ge a b = Lt b a + +-- | Maximum +type family Max (a :: Peano) (b :: Peano) :: Peano where + Max Z b = b + Max a Z = a + Max (S a) (S b) = S (Max a b) + +-- | Minimum +type family Min (a :: Peano) (b :: Peano) :: Peano where + Min Z b = Z + Min a Z = Z + Min (S a) (S b) = S (Min a b) + +-- | Apply a constructor 'f' n-times to an argument 's' +type family Repeat (m :: Peano) (f :: k -> k) (s :: k) :: k where + Repeat Z f s = s + Repeat (S m) f s = f (Repeat m f s) + +-- | Calculate the size of a context +type family CtxSizeP (ctx :: Ctx k) :: Peano where + CtxSizeP 'EmptyCtx = Z + CtxSizeP (xs '::> x) = S (CtxSizeP xs) + +------------------------------------------------------------------------ +-- * Run time representation of Peano numbers + +#ifdef UNSAFE_OPS +-- | The run time value, stored as an Word64 +-- As these are unary numbers, we don't worry about overflow. +newtype PeanoRepr (n :: Peano) = + PeanoRepr { peanoValue :: Word64 } +-- n is Phantom in the definition, but we don't want to allow coerce +type role PeanoRepr nominal +#else +-- | Runtime value +type PeanoRepr = PeanoView +-- | Conversion +peanoValue :: PeanoRepr n -> Word64 +peanoValue ZRepr = 0 +peanoValue (SRepr m) = 1 + peanoValue m +#endif + +-- | When we have optimized the runtime representation, +-- we need to have a "view" that decomposes the representation +-- into the standard form. +data PeanoView (n :: Peano) where + ZRepr :: PeanoView Z + SRepr :: PeanoRepr n -> PeanoView (S n) + +-- | Test whether a number is Zero or Successor +peanoView :: PeanoRepr n -> PeanoView n +#ifdef UNSAFE_OPS +peanoView (PeanoRepr i) = + if i == 0 + then unsafeCoerce ZRepr + else unsafeCoerce (SRepr (PeanoRepr (i-1))) +#else +peanoView = id +#endif + +-- | convert the view back to the runtime representation +viewRepr :: PeanoView n -> PeanoRepr n +#ifdef UNSAFE_OPS +viewRepr ZRepr = PeanoRepr 0 +viewRepr (SRepr n) = PeanoRepr (peanoValue n + 1) +#else +viewRepr = id +#endif + +---------------------------------------------------------- +-- * Class instances + +instance Hashable (PeanoRepr n) where + hashWithSalt i x = hashWithSalt i (peanoValue x) + +instance Eq (PeanoRepr m) where + _ == _ = True + +instance TestEquality PeanoRepr where +#ifdef UNSAFE_OPS + testEquality (PeanoRepr m) (PeanoRepr n) + | m == n = Just unsafeAxiom + | otherwise = Nothing +#else + testEquality ZRepr ZRepr = Just Refl + testEquality (SRepr m1) (SRepr m2) + | Just Refl <- testEquality m1 m2 + = Just Refl + testEquality _ _ = Nothing + +#endif + +instance DecidableEq PeanoRepr where +#ifdef UNSAFE_OPS + decEq (PeanoRepr m) (PeanoRepr n) + | m == n = Left unsafeAxiom + | otherwise = Right $ + \x -> seq x $ error "Impossible [DecidableEq on PeanoRepr]" +#else + decEq ZRepr ZRepr = Left Refl + decEq (SRepr m1) (SRepr m2) = + case decEq m1 m2 of + Left Refl -> Left Refl + Right f -> Right $ \case Refl -> f Refl + decEq ZRepr (SRepr _) = + Right $ \case {} + decEq (SRepr _) ZRepr = + Right $ \case {} +#endif + +instance OrdF PeanoRepr where +#ifdef UNSAFE_OPS + compareF (PeanoRepr m) (PeanoRepr n) + | m < n = unsafeCoerce LTF + | m == n = unsafeCoerce EQF + | otherwise = unsafeCoerce GTF +#else + compareF ZRepr ZRepr = EQF + compareF ZRepr (SRepr _) = LTF + compareF (SRepr _) ZRepr = GTF + compareF (SRepr m1) (SRepr m2) = + case compareF m1 m2 of + EQF -> EQF + LTF -> LTF + GTF -> GTF +#endif + +instance PolyEq (PeanoRepr m) (PeanoRepr n) where + polyEqF x y = (\Refl -> Refl) <$> testEquality x y + +-- Display as digits, not in unary +instance Show (PeanoRepr p) where + show p = show (peanoValue p) + +instance ShowF PeanoRepr + +instance HashableF PeanoRepr where + hashWithSaltF = hashWithSalt + +---------------------------------------------------------- +-- * Implicit runtime Peano numbers + +-- | Implicit runtime representation +type KnownPeano = KnownRepr PeanoRepr + +instance KnownRepr PeanoRepr Z where + knownRepr = viewRepr ZRepr +instance (KnownRepr PeanoRepr n) => KnownRepr PeanoRepr (S n) where + knownRepr = viewRepr (SRepr knownRepr) + +---------------------------------------------------------- +-- * Operations on runtime numbers + + +-- | Zero +zeroP :: PeanoRepr Z +#ifdef UNSAFE_OPS +zeroP = PeanoRepr 0 +#else +zeroP = ZRepr +#endif + +-- | Successor, Increment +succP :: PeanoRepr n -> PeanoRepr (S n) +#ifdef UNSAFE_OPS +succP (PeanoRepr i) = PeanoRepr (i+1) +#else +succP = SRepr +#endif + +-- | Get the predecessor (decrement) +predP :: PeanoRepr (S n) -> PeanoRepr n +#ifdef UNSAFE_OPS +predP (PeanoRepr i) = PeanoRepr (i-1) +#else +predP (SRepr i) = i +#endif + +-- | Addition +plusP :: PeanoRepr a -> PeanoRepr b -> PeanoRepr (Plus a b) +#ifdef UNSAFE_OPS +plusP (PeanoRepr a) (PeanoRepr b) = PeanoRepr (a + b) +#else +plusP (SRepr a) b = SRepr (plusP a b) +#endif + +-- | Subtraction +minusP :: PeanoRepr a -> PeanoRepr b -> PeanoRepr (Minus a b) +#ifdef UNSAFE_OPS +minusP (PeanoRepr a) (PeanoRepr b) = PeanoRepr (a - b) +#else +minusP ZRepr _b = ZRepr +minusP (SRepr a) (SRepr b) = minusP a b +minusP a ZRepr = a +#endif + +-- | Multiplication +mulP :: PeanoRepr a -> PeanoRepr b -> PeanoRepr (Mul a b) +#ifdef UNSAFE_OPS +mulP (PeanoRepr a) (PeanoRepr b) = PeanoRepr (a * b) +#else +mulP ZRepr _b = ZRepr +mulP (SRepr a) b = plusP a (mulP a b) +#endif + +-- | Maximum +maxP :: PeanoRepr a -> PeanoRepr b -> PeanoRepr (Max a b) +#ifdef UNSAFE_OPS +maxP (PeanoRepr a) (PeanoRepr b) = PeanoRepr (max a b) +#else +maxP ZRepr b = b +maxP a ZRepr = a +maxP (SRepr a) (SRepr b) = SRepr (maxP a b) +#endif + +-- | Minimum +minP :: PeanoRepr a -> PeanoRepr b -> PeanoRepr (Min a b) +#ifdef UNSAFE_OPS +minP (PeanoRepr a) (PeanoRepr b) = PeanoRepr (min a b) +#else +minP ZRepr _b = ZRepr +minP _a ZRepr = ZRepr +minP (SRepr a) (SRepr b) = SRepr (minP a b) +#endif + +-- | Less-than-or-equal-to +leP :: PeanoRepr a -> PeanoRepr b -> BoolRepr (Le a b) +#ifdef UNSAFE_OPS +leP (PeanoRepr a) (PeanoRepr b) = + if a <= b then unsafeCoerce (TrueRepr) + else unsafeCoerce(FalseRepr) +#else +leP ZRepr ZRepr = TrueRepr +leP ZRepr (SRepr _) = TrueRepr +leP (SRepr _) ZRepr = FalseRepr +leP (SRepr a) (SRepr b) = leP a b +#endif + +-- | Less-than +ltP :: PeanoRepr a -> PeanoRepr b -> BoolRepr (Lt a b) +ltP a b = leP (succP a) b + +-- | Greater-than-or-equal-to +geP :: PeanoRepr a -> PeanoRepr b -> BoolRepr (Ge a b) +geP a b = ltP b a + +-- | Greater-than +gtP :: PeanoRepr a -> PeanoRepr b -> BoolRepr (Gt a b) +gtP a b = leP b a + + +-- | Apply a constructor 'f' n-times to an argument 's' +repeatP :: PeanoRepr m -> (forall a. repr a -> repr (f a)) -> repr s -> repr (Repeat m f s) +repeatP n f s = case peanoView n of + ZRepr -> s + SRepr m -> f (repeatP m f s) + +-- | Calculate the size of a context +ctxSizeP :: Assignment f ctx -> PeanoRepr (CtxSizeP ctx) +ctxSizeP r = case viewAssign r of + AssignEmpty -> zeroP + AssignExtend a _ -> succP (ctxSizeP a) + +------------------------------------------------------------------------ +-- * Some PeanoRepr + +-- | Convert a 'Word64' to a 'PeanoRepr' +mkPeanoRepr :: Word64 -> Some PeanoRepr +#ifdef UNSAFE_OPS +mkPeanoRepr n = Some (PeanoRepr n) +#else +mkPeanoRepr 0 = Some ZRepr +mkPeanoRepr n = case mkPeanoRepr (n - 1) of + Some mr -> Some (SRepr mr) +#endif + +-- | Turn an @Integral@ value into a 'PeanoRepr'. Returns @Nothing@ +-- if the given value is negative. +somePeano :: Integral a => a -> Maybe (Some PeanoRepr) +somePeano x | x >= 0 = Just . mkPeanoRepr $! fromIntegral x +somePeano _ = Nothing + +-- | Return the maximum of two representations. +maxPeano :: PeanoRepr m -> PeanoRepr n -> Some PeanoRepr +maxPeano x y = Some (maxP x y) + +-- | Return the minimum of two representations. +minPeano :: PeanoRepr m -> PeanoRepr n -> Some PeanoRepr +minPeano x y = Some (minP x y) + +-- | List length as a Peano number +peanoLength :: [a] -> Some PeanoRepr +peanoLength [] = Some zeroP +peanoLength (_:xs) = case peanoLength xs of + Some n -> Some (succP n) + + +------------------------------------------------------------------------ +-- * Properties about Peano numbers +-- +-- The safe version of these properties includes a runtime proof of +-- the equality. The unsafe version has no run-time +-- computation. Therefore, in the unsafe version, the "Repr" arguments +-- can be used as proxies (i.e. called using 'undefined') but must be +-- supplied to the safe versions. + + +-- | Context size commutes with context append +plusCtxSizeAxiom :: forall t1 t2 f. + Assignment f t1 -> Assignment f t2 -> + CtxSizeP (t1 <+> t2) :~: Plus (CtxSizeP t2) (CtxSizeP t1) +#ifdef UNSAFE_OPS +plusCtxSizeAxiom _t1 _t2 = unsafeAxiom +#else +plusCtxSizeAxiom t1 t2 = + case viewAssign t2 of + AssignEmpty -> Refl + AssignExtend t2' _ + | Refl <- plusCtxSizeAxiom t1 t2' -> Refl +#endif + +-- | Minus distributes over plus +-- +minusPlusAxiom :: forall n t t'. + PeanoRepr n -> PeanoRepr t -> PeanoRepr t' -> + Minus n (Plus t' t) :~: Minus (Minus n t') t +#ifdef UNSAFE_OPS +minusPlusAxiom _n _t _t' = unsafeAxiom +#else +minusPlusAxiom n t t' = case peanoView t' of + ZRepr -> Refl + SRepr t1' -> case peanoView n of + ZRepr -> Refl + SRepr n1 -> case minusPlusAxiom n1 t t1' of + Refl -> Refl +#endif + +-- | We can reshuffle minus with less than +-- +ltMinusPlusAxiom :: forall n t t'. + (Lt t (Minus n t') ~ 'True) => + PeanoRepr n -> PeanoRepr t -> PeanoRepr t' -> + Lt (Plus t' t) n :~: 'True +#ifdef UNSAFE_OPS +ltMinusPlusAxiom _n _t _t' = unsafeAxiom +#else +ltMinusPlusAxiom n t t' = case peanoView n of + SRepr m -> case peanoView t' of + ZRepr -> Refl + SRepr t1' -> case ltMinusPlusAxiom m t t1' of + Refl -> Refl +#endif + +------------------------------------------------------------------------ +-- LocalWords: PeanoRepr runtime Peano unary diff --git a/src/Data/Parameterized/Some.hs b/src/Data/Parameterized/Some.hs new file mode 100644 index 0000000..702d921 --- /dev/null +++ b/src/Data/Parameterized/Some.hs @@ -0,0 +1,73 @@ +------------------------------------------------------------------------ +-- | +-- Module : Data.Parameterized.Some +-- Copyright : (c) Galois, Inc 2014-2019 +-- Maintainer : Joe Hendrix +-- Description : a GADT that hides a type parameter +-- +-- This module provides 'Some', a GADT that hides a type parameter. +------------------------------------------------------------------------ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +module Data.Parameterized.Some + ( Some(..) + , viewSome + , mapSome + , traverseSome + , traverseSome_ + , someLens + ) where + +import Control.Lens (Lens', lens, (&), (^.), (.~)) +import Data.Hashable +import Data.Kind +import Data.Parameterized.Classes +import Data.Parameterized.TraversableF + + +data Some (f:: k -> Type) = forall x . Some (f x) + +instance TestEquality f => Eq (Some f) where + Some x == Some y = isJust (testEquality x y) + +instance OrdF f => Ord (Some f) where + compare (Some x) (Some y) = toOrdering (compareF x y) + +instance (HashableF f, TestEquality f) => Hashable (Some f) where + hashWithSalt s (Some x) = hashWithSaltF s x + hash (Some x) = hashF x + +instance ShowF f => Show (Some f) where + show (Some x) = showF x + +-- | Project out of Some. +viewSome :: (forall tp . f tp -> r) -> Some f -> r +viewSome f (Some x) = f x + +-- | Apply function to inner value. +mapSome :: (forall tp . f tp -> g tp) -> Some f -> Some g +mapSome f (Some x) = Some $! f x + +{-# INLINE traverseSome #-} +-- | Modify the inner value. +traverseSome :: Functor m + => (forall tp . f tp -> m (g tp)) + -> Some f + -> m (Some g) +traverseSome f (Some x) = Some `fmap` f x + +{-# INLINE traverseSome_ #-} +-- | Modify the inner value. +traverseSome_ :: Functor m => (forall tp . f tp -> m ()) -> Some f -> m () +traverseSome_ f (Some x) = (\_ -> ()) `fmap` f x + +instance FunctorF Some where fmapF = mapSome +instance FoldableF Some where foldMapF = foldMapFDefault +instance TraversableF Some where traverseF = traverseSome + +-- | A lens that is polymorphic in the index may be used on a value with an +-- existentially-quantified index. +someLens :: (forall tp. Lens' (f tp) a) -> Lens' (Some f) a +someLens l = lens (\(Some x) -> x ^. l) (\(Some x) v -> Some (x & l .~ v)) diff --git a/src/Data/Parameterized/SymbolRepr.hs b/src/Data/Parameterized/SymbolRepr.hs new file mode 100644 index 0000000..473e4ec --- /dev/null +++ b/src/Data/Parameterized/SymbolRepr.hs @@ -0,0 +1,125 @@ +{-| +Copyright : (c) Galois, Inc 2014-2019 +Maintainer : Joe Hendrix +Description : a type family for representing a type-level string (AKA symbol) at runtime + +This defines a type family 'SymbolRepr' for representing a type-level string +(AKA symbol) at runtime. This can be used to branch on a type-level value. + +The 'TestEquality' and 'OrdF' instances for 'SymbolRepr' are implemented using +'unsafeCoerce'. This should be typesafe because we maintain the invariant +that the string value contained in a SymbolRepr value matches its static type. + +At the type level, symbols have very few operations, so SymbolRepr +correspondingly has very few functions that manipulate them. +-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Trustworthy #-} +module Data.Parameterized.SymbolRepr + ( -- * SymbolRepr + SymbolRepr + , symbolRepr + , knownSymbol + , someSymbol + , SomeSym(SomeSym) + , viewSomeSym + -- * Re-exports + , type GHC.Symbol + , GHC.KnownSymbol + ) where + +import GHC.TypeLits as GHC +import Unsafe.Coerce (unsafeCoerce) + +import Data.Hashable +import Data.Kind ( Type ) +import Data.Proxy +import qualified Data.Text as Text + +import Data.Parameterized.Axiom +import Data.Parameterized.Classes +import Data.Parameterized.Some + +-- | A runtime representation of a GHC type-level symbol. +newtype SymbolRepr (nm::GHC.Symbol) + = SymbolRepr { symbolRepr :: Text.Text + -- ^ The underlying text representation of the symbol + } +-- INVARIANT: The contained runtime text value matches the value +-- of the type level symbol. The SymbolRepr constructor +-- is not exported so we can maintain this invariant in this +-- module. + +-- | Generate a symbol representative at runtime. The type-level +-- symbol will be abstract, as it is hidden by the 'Some' constructor. +someSymbol :: Text.Text -> Some SymbolRepr +someSymbol nm = Some (SymbolRepr nm) + +-- | Generate a value representative for the type level symbol. +knownSymbol :: GHC.KnownSymbol s => SymbolRepr s +knownSymbol = go Proxy + where go :: GHC.KnownSymbol s => Proxy s -> SymbolRepr s + go p = SymbolRepr $! packSymbol (GHC.symbolVal p) + + -- NOTE here we explicitly test that unpacking the packed text value + -- gives the desired string. This is to avoid pathological corner cases + -- involving string values that have no text representation. + packSymbol str + | Text.unpack txt == str = txt + | otherwise = error $ "Unrepresentable symbol! "++ str + where txt = Text.pack str + +instance (GHC.KnownSymbol s) => KnownRepr SymbolRepr s where + knownRepr = knownSymbol + +instance TestEquality SymbolRepr where + testEquality (SymbolRepr x :: SymbolRepr x) (SymbolRepr y) + | x == y = Just unsafeAxiom + | otherwise = Nothing +instance OrdF SymbolRepr where + compareF (SymbolRepr x :: SymbolRepr x) (SymbolRepr y) + | x < y = LTF + | x == y = unsafeCoerce (EQF :: OrderingF x x) + | otherwise = GTF + +-- These instances are trivial by the invariant +-- that the contained string matches the type-level +-- symbol +instance Eq (SymbolRepr x) where + _ == _ = True +instance Ord (SymbolRepr x) where + compare _ _ = EQ + +instance HashableF SymbolRepr where + hashWithSaltF = hashWithSalt +instance Hashable (SymbolRepr nm) where + hashWithSalt s (SymbolRepr nm) = hashWithSalt s nm + +instance Show (SymbolRepr nm) where + show (SymbolRepr nm) = Text.unpack nm + +instance ShowF SymbolRepr + + +-- | The SomeSym hides a Symbol parameter but preserves a +-- KnownSymbol constraint on the hidden parameter. + +data SomeSym (c :: GHC.Symbol -> Type) = + forall (s :: GHC.Symbol) . GHC.KnownSymbol s => SomeSym (c s) + + +-- | Projects a value out of a SomeSym into a function, re-ifying the +-- Symbol type parameter to the called function, along with the +-- KnownSymbol constraint on that Symbol value. + +viewSomeSym :: (forall (s :: GHC.Symbol) . GHC.KnownSymbol s => c s -> r) -> + SomeSym c -> r +viewSomeSym f (SomeSym x) = f x diff --git a/src/Data/Parameterized/TH/GADT.hs b/src/Data/Parameterized/TH/GADT.hs new file mode 100644 index 0000000..56573f6 --- /dev/null +++ b/src/Data/Parameterized/TH/GADT.hs @@ -0,0 +1,785 @@ +------------------------------------------------------------------------ +-- | +-- Module : Data.Parameterized.TH.GADT +-- Copyright : (c) Galois, Inc 2013-2019 +-- Maintainer : Joe Hendrix +-- Description : Template Haskell primitives for working with large GADTs +-- +-- This module declares template Haskell primitives so that it is easier +-- to work with GADTs that have many constructors. +------------------------------------------------------------------------ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE EmptyCase #-} +module Data.Parameterized.TH.GADT + ( -- * Instance generators + -- $typePatterns + structuralEquality + , structuralTypeEquality + , structuralTypeOrd + , structuralTraversal + , structuralShowsPrec + , structuralHash + , structuralHashWithSalt + , PolyEq(..) + -- * Repr generators (\"singletons\") + -- $reprs + , mkRepr + , mkKnownReprs + -- * Template haskell utilities that may be useful in other contexts. + , DataD + , lookupDataType' + , asTypeCon + , conPat + , TypePat(..) + , dataParamTypes + , assocTypePats + ) where + +import Control.Monad +import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as Set +import Language.Haskell.TH +import Language.Haskell.TH.Datatype + + +import Data.Parameterized.Classes + +------------------------------------------------------------------------ +-- Template Haskell utilities + +type DataD = DatatypeInfo + +lookupDataType' :: Name -> Q DatatypeInfo +lookupDataType' = reifyDatatype + +-- | Given a constructor and string, this generates a pattern for matching +-- the expression, and the names of variables bound by pattern in order +-- they appear in constructor. +conPat :: + ConstructorInfo {- ^ constructor information -} -> + String {- ^ generated name prefix -} -> + Q (Pat, [Name]) {- ^ pattern and bound names -} +conPat con pre = do + nms <- newNames pre (length (constructorFields con)) + return (conPCompat (constructorName con) (VarP <$> nms), nms) + + +-- | Return an expression corresponding to the constructor. +-- Note that this will have the type of a function expecting +-- the argumetns given. +conExpr :: ConstructorInfo -> Exp +conExpr = ConE . constructorName + +------------------------------------------------------------------------ +-- TypePat + +-- | A type used to describe (and match) types appearing in generated pattern +-- matches inside of the TH generators in this module ('structuralEquality', +-- 'structuralTypeEquality', 'structuralTypeOrd', and 'structuralTraversal') +data TypePat + = TypeApp TypePat TypePat -- ^ The application of a type. + | AnyType -- ^ Match any type. + | DataArg Int -- ^ Match the i'th argument of the data type we are traversing. + | ConType TypeQ -- ^ Match a ground type. + +matchTypePat :: [Type] -> TypePat -> Type -> Q Bool +matchTypePat d (TypeApp p q) (AppT x y) = do + r <- matchTypePat d p x + case r of + True -> matchTypePat d q y + False -> return False +matchTypePat _ AnyType _ = return True +matchTypePat tps (DataArg i) tp + | i < 0 || i >= length tps = error ("Type pattern index " ++ show i ++ " out of bounds") + | otherwise = return (stripSigT (tps !! i) == tp) + where + -- th-abstraction can annotate type parameters with their kinds, + -- we ignore these for matching + stripSigT (SigT t _) = t + stripSigT t = t +matchTypePat _ (ConType tpq) tp = do + tp' <- tpq + return (tp' == tp) +matchTypePat _ _ _ = return False + +-- | The dataParamTypes function returns the list of Type arguments +-- for the constructor. For example, if passed the DatatypeInfo for a +-- @newtype Id a = MkId a@ then this would return @['SigT' ('VarT' a) +-- 'StarT']@. Note that there may be type *variables* not referenced +-- in the returned array; this simply returns the type *arguments*. +dataParamTypes :: DatatypeInfo -> [Type] +dataParamTypes = datatypeInstTypes + -- see th-abstraction 'dataTypeVars' for the type variables if needed + +-- | Find value associated with first pattern that matches given pat if any. +assocTypePats :: [Type] -> [(TypePat, v)] -> Type -> Q (Maybe v) +assocTypePats _ [] _ = return Nothing +assocTypePats dTypes ((p,v):pats) tp = do + r <- matchTypePat dTypes p tp + case r of + True -> return (Just v) + False -> assocTypePats dTypes pats tp + +------------------------------------------------------------------------ +-- Contructor cases + +typeVars :: TypeSubstitution a => a -> Set Name +typeVars = Set.fromList . freeVariables + + +-- | @structuralEquality@ declares a structural equality predicate. +structuralEquality :: TypeQ -> [(TypePat,ExpQ)] -> ExpQ +structuralEquality tpq pats = + [| \x y -> isJust ($(structuralTypeEquality tpq pats) x y) |] + +joinEqMaybe :: Name -> Name -> ExpQ -> ExpQ +joinEqMaybe x y r = do + [| if $(varE x) == $(varE y) then $(r) else Nothing |] + +joinTestEquality :: ExpQ -> Name -> Name -> ExpQ -> ExpQ +joinTestEquality f x y r = + [| case $(f) $(varE x) $(varE y) of + Nothing -> Nothing + Just Refl -> $(r) + |] + +matchEqArguments :: [Type] + -- ^ Types bound by data arguments. + -> [(TypePat,ExpQ)] -- ^ Patterns for matching arguments + -> Name + -- ^ Name of constructor. + -> Set Name + -> [Type] + -> [Name] + -> [Name] + -> ExpQ +matchEqArguments dTypes pats cnm bnd (tp:tpl) (x:xl) (y:yl) = do + doesMatch <- assocTypePats dTypes pats tp + case doesMatch of + Just q -> do + let bnd' = + case tp of + AppT _ (VarT nm) -> Set.insert nm bnd + _ -> bnd + joinTestEquality q x y (matchEqArguments dTypes pats cnm bnd' tpl xl yl) + Nothing | typeVars tp `Set.isSubsetOf` bnd -> do + joinEqMaybe x y (matchEqArguments dTypes pats cnm bnd tpl xl yl) + Nothing -> do + fail $ "Unsupported argument type " ++ show tp + ++ " in " ++ show (ppr cnm) ++ "." +matchEqArguments _ _ _ _ [] [] [] = [| Just Refl |] +matchEqArguments _ _ _ _ [] _ _ = error "Unexpected end of types." +matchEqArguments _ _ _ _ _ [] _ = error "Unexpected end of names." +matchEqArguments _ _ _ _ _ _ [] = error "Unexpected end of names." + +mkSimpleEqF :: [Type] -- ^ Data declaration types + -> Set Name + -> [(TypePat,ExpQ)] -- ^ Patterns for matching arguments + -> ConstructorInfo + -> [Name] + -> ExpQ + -> Bool -- ^ wildcard case required + -> ExpQ +mkSimpleEqF dTypes bnd pats con xv yQ multipleCases = do + -- Get argument types for constructor. + let nm = constructorName con + (yp,yv) <- conPat con "y" + let rv = matchEqArguments dTypes pats nm bnd (constructorFields con) xv yv + caseE yQ $ match (pure yp) (normalB rv) [] + : [ match wildP (normalB [| Nothing |]) [] | multipleCases ] + +-- | Match equational form. +mkEqF :: DatatypeInfo -- ^ Data declaration. + -> [(TypePat,ExpQ)] + -> ConstructorInfo + -> [Name] + -> ExpQ + -> Bool -- ^ wildcard case required + -> ExpQ +mkEqF d pats con = + let dVars = dataParamTypes d -- the type arguments for the constructor + -- bnd is the list of type arguments for this datatype. Since + -- this is Functor equality, ignore the final type since this is + -- a higher-kinded equality. + bnd | null dVars = Set.empty + | otherwise = typeVars (init dVars) + in mkSimpleEqF dVars bnd pats con + +-- | @structuralTypeEquality f@ returns a function with the type: +-- @ +-- forall x y . f x -> f y -> Maybe (x :~: y) +-- @ +structuralTypeEquality :: TypeQ -> [(TypePat,ExpQ)] -> ExpQ +structuralTypeEquality tpq pats = do + d <- reifyDatatype =<< asTypeCon "structuralTypeEquality" =<< tpq + + let multipleCons = not (null (drop 1 (datatypeCons d))) + trueEqs yQ = [ do (xp,xv) <- conPat con "x" + match (pure xp) (normalB (mkEqF d pats con xv yQ multipleCons)) [] + | con <- datatypeCons d + ] + + if null (datatypeCons d) + then [| \x -> case x of {} |] + else [| \x y -> $(caseE [| x |] (trueEqs [| y |])) |] + +-- | @structuralTypeOrd f@ returns a function with the type: +-- @ +-- forall x y . f x -> f y -> OrderingF x y +-- @ +-- +-- This implementation avoids matching on both the first and second +-- parameters in a simple case expression in order to avoid stressing +-- GHC's coverage checker. In the case that the first and second parameters +-- have unique constructors, a simple numeric comparison is done to +-- compute the result. +structuralTypeOrd :: + TypeQ -> + [(TypePat,ExpQ)] {- ^ List of type patterns to match. -} -> + ExpQ +structuralTypeOrd tpq l = do + d <- reifyDatatype =<< asTypeCon "structuralTypeEquality" =<< tpq + + let withNumber :: ExpQ -> (Maybe ExpQ -> ExpQ) -> ExpQ + withNumber yQ k + | null (drop 1 (datatypeCons d)) = k Nothing + | otherwise = [| let yn :: Int + yn = $(caseE yQ (constructorNumberMatches (datatypeCons d))) + in $(k (Just [| yn |])) |] + + if null (datatypeCons d) + then [| \x -> case x of {} |] + else [| \x y -> $(withNumber [|y|] $ \mbYn -> caseE [| x |] (outerOrdMatches d [|y|] mbYn)) |] + where + constructorNumberMatches :: [ConstructorInfo] -> [MatchQ] + constructorNumberMatches cons = + [ match (recP (constructorName con) []) + (normalB (litE (integerL i))) + [] + | (i,con) <- zip [0..] cons ] + + outerOrdMatches :: DatatypeInfo -> ExpQ -> Maybe ExpQ -> [MatchQ] + outerOrdMatches d yExp mbYn = + [ do (pat,xv) <- conPat con "x" + match (pure pat) + (normalB (do xs <- mkOrdF d l con i mbYn xv + caseE yExp xs)) + [] + | (i,con) <- zip [0..] (datatypeCons d) ] + +-- | Generate a list of fresh names using the base name +-- and numbered 1 to @n@ to make them useful in conjunction with +-- @-dsuppress-uniques@. +newNames :: + String {- ^ base name -} -> + Int {- ^ quantity -} -> + Q [Name] {- ^ list of names: @base1@, @base2@, ... -} +newNames base n = traverse (\i -> newName (base ++ show i)) [1..n] + + +joinCompareF :: ExpQ -> Name -> Name -> ExpQ -> ExpQ +joinCompareF f x y r = do + [| case $(f) $(varE x) $(varE y) of + LTF -> LTF + GTF -> GTF + EQF -> $(r) + |] + +-- | Compare two variables, returning the third argument if they are equal. +-- +-- This returns an 'OrdF' instance. +joinCompareToOrdF :: Name -> Name -> ExpQ -> ExpQ +joinCompareToOrdF x y r = + [| case compare $(varE x) $(varE y) of + LT -> LTF + GT -> GTF + EQ -> $(r) + |] + +-- | Match expression with given type to variables +matchOrdArguments :: [Type] + -- ^ Types bound by data arguments + -> [(TypePat,ExpQ)] -- ^ Patterns for matching arguments + -> Name + -- ^ Name of constructor. + -> Set Name + -- ^ Names bound in data declaration + -> [Type] + -- ^ Types for constructors + -> [Name] + -- ^ Variables bound in first pattern + -> [Name] + -- ^ Variables bound in second pattern + -> ExpQ +matchOrdArguments dTypes pats cnm bnd (tp : tpl) (x:xl) (y:yl) = do + doesMatch <- assocTypePats dTypes pats tp + case doesMatch of + Just f -> do + let bnd' = case tp of + AppT _ (VarT nm) -> Set.insert nm bnd + _ -> bnd + joinCompareF f x y (matchOrdArguments dTypes pats cnm bnd' tpl xl yl) + Nothing | typeVars tp `Set.isSubsetOf` bnd -> do + joinCompareToOrdF x y (matchOrdArguments dTypes pats cnm bnd tpl xl yl) + Nothing -> + fail $ "Unsupported argument type " ++ show (ppr tp) + ++ " in " ++ show (ppr cnm) ++ "." +matchOrdArguments _ _ _ _ [] [] [] = [| EQF |] +matchOrdArguments _ _ _ _ [] _ _ = error "Unexpected end of types." +matchOrdArguments _ _ _ _ _ [] _ = error "Unexpected end of names." +matchOrdArguments _ _ _ _ _ _ [] = error "Unexpected end of names." + +mkSimpleOrdF :: [Type] -- ^ Data declaration types + -> [(TypePat,ExpQ)] -- ^ Patterns for matching arguments + -> ConstructorInfo -- ^ Information about the second constructor + -> Integer -- ^ First constructor's index + -> Maybe ExpQ -- ^ Optional second constructor's index + -> [Name] -- ^ Name from first pattern + -> Q [MatchQ] +mkSimpleOrdF dTypes pats con xnum mbYn xv = do + (yp,yv) <- conPat con "y" + let rv = matchOrdArguments dTypes pats (constructorName con) Set.empty (constructorFields con) xv yv + -- Return match expression + return $ match (pure yp) (normalB rv) [] + : case mbYn of + Nothing -> [] + Just yn -> [match wildP (normalB [| if xnum < $yn then LTF else GTF |]) []] + +-- | Match equational form. +mkOrdF :: DatatypeInfo -- ^ Data declaration. + -> [(TypePat,ExpQ)] -- ^ Patterns for matching arguments + -> ConstructorInfo + -> Integer + -> Maybe ExpQ -- ^ optional right constructr index + -> [Name] + -> Q [MatchQ] +mkOrdF d pats = mkSimpleOrdF (datatypeInstTypes d) pats + +-- | @genTraverseOfType f var tp@ applies @f@ to @var@ where @var@ has type @tp@. +genTraverseOfType :: [Type] + -- ^ Argument types for the data declaration. + -> [(TypePat, ExpQ)] + -- ^ Patterrns the user provided for overriding type lookup. + -> ExpQ -- ^ Function to apply + -> ExpQ -- ^ Expression denoting value of this constructor field. + -> Type -- ^ Type bound for this constructor field. + -> Q (Maybe Exp) +genTraverseOfType dataArgs pats f v tp = do + mr <- assocTypePats dataArgs pats tp + case mr of + Just g -> Just <$> [| $(g) $(f) $(v) |] + Nothing -> + case tp of + AppT (ConT _) (AppT (VarT _) _) -> Just <$> [| traverse $(f) $(v) |] + AppT (VarT _) _ -> Just <$> [| $(f) $(v) |] + _ -> return Nothing + +-- | @traverseAppMatch patMatch cexp @ builds a case statement that matches a term with +-- the constructor @c@ and applies @f@ to each argument. +traverseAppMatch :: [Type] + -- ^ Argument types for the data declaration. + -> [(TypePat, ExpQ)] + -- ^ Patterrns the user provided for overriding type lookup. + -> ExpQ -- ^ Function @f@ given to `traverse` + -> ConstructorInfo -- ^ Constructor to match. + -> MatchQ +traverseAppMatch dataArgs pats fv c0 = do + (pat,patArgs) <- conPat c0 "p" + exprs <- zipWithM (genTraverseOfType dataArgs pats fv) (varE <$> patArgs) (constructorFields c0) + let mkRes :: ExpQ -> [(Name, Maybe Exp)] -> ExpQ + mkRes e [] = e + mkRes e ((v,Nothing):r) = + mkRes (appE e (varE v)) r + mkRes e ((_,Just{}):r) = do + v <- newName "r" + lamE [varP v] (mkRes (appE e (varE v)) r) + + -- Apply the remaining argument to the expression in list. + let applyRest :: ExpQ -> [Exp] -> ExpQ + applyRest e [] = e + applyRest e (a:r) = applyRest [| $(e) <*> $(pure a) |] r + + -- Apply the first argument to the list + let applyFirst :: ExpQ -> [Exp] -> ExpQ + applyFirst e [] = [| pure $(e) |] + applyFirst e (a:r) = applyRest [| $(e) <$> $(pure a) |] r + + let pargs = patArgs `zip` exprs + let rhs = applyFirst (mkRes (pure (conExpr c0)) pargs) (catMaybes exprs) + match (pure pat) (normalB rhs) [] + +-- | @structuralTraversal tp@ generates a function that applies +-- a traversal @f@ to the subterms with free variables in @tp@. +structuralTraversal :: TypeQ -> [(TypePat, ExpQ)] -> ExpQ +structuralTraversal tpq pats0 = do + d <- reifyDatatype =<< asTypeCon "structuralTraversal" =<< tpq + f <- newName "f" + a <- newName "a" + lamE [varP f, varP a] $ + caseE (varE a) + (traverseAppMatch (datatypeInstTypes d) pats0 (varE f) <$> datatypeCons d) + +asTypeCon :: String -> Type -> Q Name +asTypeCon _ (ConT nm) = return nm +asTypeCon fn _ = fail (fn ++ " expected type constructor.") + +-- | @structuralHash tp@ generates a function with the type +-- @Int -> tp -> Int@ that hashes type. +-- +-- All arguments use `hashable`, and `structuralHashWithSalt` can be +-- used instead as it allows user-definable patterns to be used at +-- specific types. +structuralHash :: TypeQ -> ExpQ +structuralHash tpq = structuralHashWithSalt tpq [] +{-# DEPRECATED structuralHash "Use structuralHashWithSalt" #-} + +-- | @structuralHashWithSalt tp@ generates a function with the type +-- @Int -> tp -> Int@ that hashes type. +-- +-- The second arguments is for generating user-defined patterns to replace +-- `hashWithSalt` for specific types. +structuralHashWithSalt :: TypeQ -> [(TypePat, ExpQ)] -> ExpQ +structuralHashWithSalt tpq pats = do + d <- reifyDatatype =<< asTypeCon "structuralHash" =<< tpq + s <- newName "s" + a <- newName "a" + lamE [varP s, varP a] $ + caseE (varE a) (zipWith (matchHashCtor d pats (varE s)) [0..] (datatypeCons d)) + +-- | This matches one of the constructors in a datatype when generating +-- a `hashWithSalt` function. +matchHashCtor :: DatatypeInfo + -- ^ Data declaration of type we are hashing. + -> [(TypePat, ExpQ)] + -- ^ User provide type patterns + -> ExpQ -- ^ Initial salt expression + -> Integer -- ^ Index of constructor + -> ConstructorInfo -- ^ Constructor information + -> MatchQ +matchHashCtor d pats s0 i c = do + (pat,vars) <- conPat c "x" + let go s (e, tp) = do + mr <- assocTypePats (datatypeInstTypes d) pats tp + case mr of + Just f -> do + [| $(f) $(s) $(e) |] + Nothing -> + [| hashWithSalt $(s) $(e) |] + let s1 = [| hashWithSalt $(s0) ($(litE (IntegerL i)) :: Int) |] + let rhs = foldl go s1 (zip (varE <$> vars) (constructorFields c)) + match (pure pat) (normalB rhs) [] + +-- | @structuralShow tp@ generates a function with the type +-- @tp -> ShowS@ that shows the constructor. +structuralShowsPrec :: TypeQ -> ExpQ +structuralShowsPrec tpq = do + d <- reifyDatatype =<< asTypeCon "structuralShowPrec" =<< tpq + p <- newName "_p" + a <- newName "a" + lamE [varP p, varP a] $ + caseE (varE a) (matchShowCtor (varE p) <$> datatypeCons d) + +showCon :: ExpQ -> Name -> Int -> MatchQ +showCon p nm n = do + vars <- newNames "x" n + let pat = conPCompat nm (VarP <$> vars) + let go s e = [| $(s) . showChar ' ' . showsPrec 11 $(varE e) |] + let ctor = [| showString $(return (LitE (StringL (nameBase nm)))) |] + let rhs | null vars = ctor + | otherwise = [| showParen ($(p) >= 11) $(foldl go ctor vars) |] + match (pure pat) (normalB rhs) [] + +matchShowCtor :: ExpQ -> ConstructorInfo -> MatchQ +matchShowCtor p con = showCon p (constructorName con) (length (constructorFields con)) + +-- | Generate a \"repr\" or singleton type from a data kind. For nullary +-- constructors, this works as follows: +-- +-- @ +-- data T1 = A | B | C +-- \$(mkRepr ''T1) +-- ======> +-- data T1Repr (tp :: T1) +-- where +-- ARepr :: T1Repr 'A +-- BRepr :: T1Repr 'B +-- CRepr :: T1Repr 'C +-- @ +-- +-- For constructors with fields, we assume each field type @T@ already has a +-- corresponding repr type @TRepr :: T -> *@. +-- +-- @ +-- data T2 = T2_1 T1 | T2_2 T1 +-- \$(mkRepr ''T2) +-- ======> +-- data T2Repr (tp :: T2) +-- where +-- T2_1Repr :: T1Repr tp -> T2Repr ('T2_1 tp) +-- T2_2Repr :: T1Repr tp -> T2Repr ('T2_2 tp) +-- @ +-- +-- Constructors with multiple fields work fine as well: +-- +-- @ +-- data T3 = T3 T1 T2 +-- \$(mkRepr ''T3) +-- ======> +-- data T3Repr (tp :: T3) +-- where +-- T3Repr :: T1Repr tp1 -> T2Repr tp2 -> T3Repr ('T3 tp1 tp2) +-- @ +-- +-- This is generally compatible with other \"repr\" types provided by +-- @parameterized-utils@, such as @NatRepr@ and @PeanoRepr@: +-- +-- @ +-- data T4 = T4_1 Nat | T4_2 Peano +-- \$(mkRepr ''T4) +-- ======> +-- data T4Repr (tp :: T4) +-- where +-- T4Repr :: NatRepr tp1 -> PeanoRepr tp2 -> T4Repr ('T4 tp1 tp2) +-- @ +-- +-- The data kind must be \"simple\", i.e. it must be monomorphic and only +-- contain user-defined data constructors (no lists, tuples, etc.). For example, +-- the following will not work: +-- +-- @ +-- data T5 a = T5 a +-- \$(mkRepr ''T5) +-- ======> +-- Foo.hs:1:1: error: +-- Exception when trying to run compile-time code: +-- mkRepr cannot be used on polymorphic data kinds. +-- @ +-- +-- Similarly, this will not work: +-- +-- @ +-- data T5 = T5 [Nat] +-- \$(mkRepr ''T5) +-- ======> +-- Foo.hs:1:1: error: +-- Exception when trying to run compile-time code: +-- mkRepr cannot be used on this data kind. +-- @ +-- +-- Note that at a minimum, you will need the following extensions to use this macro: +-- +-- @ +-- {-\# LANGUAGE DataKinds \#-} +-- {-\# LANGUAGE GADTs \#-} +-- {-\# LANGUAGE KindSignatures \#-} +-- {-\# LANGUAGE TemplateHaskell \#-} +-- @ +mkRepr :: Name -> DecsQ +mkRepr typeName = do + let reprTypeName = mkReprName typeName + varName = mkName "tp" + info <- lookupDataType' typeName + let gc ci = do + let ctorName = constructorName ci + reprCtorName = mkReprName ctorName + ctorFieldTypeNames = getCtorName <$> constructorFields ci + ctorFieldReprNames = mkReprName <$> ctorFieldTypeNames + -- Generate a list of type variables to be supplied as type arguments + -- for each repr argument. + tvars <- replicateM (length (constructorFields ci)) (newName "tp") + let appliedType = + foldl AppT (PromotedT (constructorName ci)) (VarT <$> tvars) + ctorType = AppT (ConT reprTypeName) appliedType + ctorArgTypes = + zipWith (\n v -> (Bang NoSourceUnpackedness NoSourceStrictness, AppT (ConT n) (VarT v))) ctorFieldReprNames tvars + return $ GadtC + [reprCtorName] + ctorArgTypes + ctorType + ctors <- mapM gc (datatypeCons info) + return $ [ DataD [] reprTypeName + [kindedTV varName (ConT typeName)] + Nothing + ctors + [] + ] + where getCtorName :: Type -> Name + getCtorName c = case c of + ConT nm -> nm + VarT _ -> error $ "mkRepr cannot be used on polymorphic data kinds." + _ -> error $ "mkRepr cannot be used on this data kind." + +-- | Generate @KnownRepr@ instances for each constructor of a data kind. Given a +-- data kind @T@, we assume a repr type @TRepr (t :: T)@ is in scope with +-- structure that perfectly matches @T@ (using 'mkRepr' to generate the repr +-- type will guarantee this). +-- +-- Given data kinds @T1@, @T2@, and @T3@ from the documentation of 'mkRepr', and +-- the associated repr types @T1Repr@, @T2Repr@, and @T3Repr@, we can use +-- 'mkKnownReprs' to generate these instances like so: +-- +-- @ +-- \$(mkKnownReprs ''T1) +-- ======> +-- instance KnownRepr T1Repr 'A where +-- knownRepr = ARepr +-- instance KnownRepr T1Repr 'B where +-- knownRepr = BRepr +-- instance KnownRepr T1Repr 'C where +-- knownRepr = CRepr +-- @ +-- +-- @ +-- \$(mkKnownReprs ''T2) +-- ======> +-- instance KnownRepr T1Repr tp => +-- KnownRepr T2Repr ('T2_1 tp) where +-- knownRepr = T2_1Repr knownRepr +-- @ +-- +-- @ +-- \$(mkKnownReprs ''T3) +-- ======> +-- instance (KnownRepr T1Repr tp1, KnownRepr T2Repr tp2) => +-- KnownRepr T3Repr ('T3_1 tp1 tp2) where +-- knownRepr = T3_1Repr knownRepr knownRepr +-- @ +-- +-- The same restrictions that apply to 'mkRepr' also apply to 'mkKnownReprs'. +-- The data kind must be \"simple\", i.e. it must be monomorphic and only +-- contain user-defined data constructors (no lists, tuples, etc.). +-- +-- Note that at a minimum, you will need the following extensions to use this macro: +-- +-- @ +-- {-\# LANGUAGE DataKinds \#-} +-- {-\# LANGUAGE GADTs \#-} +-- {-\# LANGUAGE KindSignatures \#-} +-- {-\# LANGUAGE MultiParamTypeClasses \#-} +-- {-\# LANGUAGE TemplateHaskell \#-} +-- @ +-- +-- Also, 'mkKnownReprs' must be used in the same module as the definition of +-- the repr type (not necessarily for the data kind). +mkKnownReprs :: Name -> DecsQ +mkKnownReprs typeName = do + kr <- [t|KnownRepr|] + let krFName = mkName "knownRepr" + reprTypeName = mkReprName typeName + typeInfo <- lookupDataType' typeName + reprInfo <- lookupDataType' reprTypeName + forM (zip (datatypeCons typeInfo) (datatypeCons reprInfo)) $ \(tci, rci) -> do + vars <- replicateM (length (constructorFields tci)) (newName "tp") + krReqs <- forM (zip (constructorFields tci) vars) $ \(tfld, v) -> do + let fldReprName = mkReprName (getCtorName tfld) + return $ AppT (AppT kr (ConT fldReprName)) (VarT v) + let appliedType = + foldl AppT (PromotedT (constructorName tci)) (VarT <$> vars) + krConstraint = AppT (AppT kr (ConT reprTypeName)) appliedType + krExp = foldl AppE (ConE (constructorName rci)) $ + map (const (VarE krFName)) vars + krDec = FunD krFName [Clause [] (NormalB krExp) []] + + return $ InstanceD Nothing krReqs krConstraint [krDec] + where getCtorName :: Type -> Name + getCtorName c = case c of + ConT nm -> nm + VarT _ -> error $ "mkKnownReprs cannot be used on polymorphic data kinds." + _ -> error $ "mkKnownReprs cannot be used on this data kind." + +mkReprName :: Name -> Name +mkReprName nm = mkName (nameBase nm ++ "Repr") + +conPCompat :: Name -> [Pat] -> Pat +conPCompat n pats = ConP n +#if MIN_VERSION_template_haskell(2,18,0) + [] +#endif + pats + +-- $typePatterns +-- +-- The Template Haskell instance generators 'structuralEquality', +-- 'structuralTypeEquality', 'structuralTypeOrd', and 'structuralTraversal' +-- employ heuristics to generate valid instances in the majority of cases. Most +-- failures in the heuristics occur on sub-terms that are type indexed. To +-- handle cases where these functions fail to produce a valid instance, they +-- take a list of exceptions in the form of their second parameter, which has +-- type @[('TypePat', 'ExpQ')]@. Each 'TypePat' is a /matcher/ that tells the +-- TH generator to use the 'ExpQ' to process the matched sub-term. Consider the +-- following example: +-- +-- > data T a b where +-- > C1 :: NatRepr n -> T () n +-- > +-- > instance TestEquality (T a) where +-- > testEquality = $(structuralTypeEquality [t|T|] +-- > [ (ConType [t|NatRepr|] `TypeApp` AnyType, [|testEquality|]) +-- > ]) +-- +-- The exception list says that 'structuralTypeEquality' should use +-- 'testEquality' to compare any sub-terms of type @'NatRepr' n@ in a value of +-- type @T@. +-- +-- * 'AnyType' means that the type parameter in that position can be instantiated as any type +-- +-- * @'DataArg' n@ means that the type parameter in that position is the @n@-th +-- type parameter of the GADT being traversed (@T@ in the example) +-- +-- * 'TypeApp' is type application +-- +-- * 'ConType' specifies a base type +-- +-- The exception list could have equivalently (and more precisely) have been specified as: +-- +-- > [(ConType [t|NatRepr|] `TypeApp` DataArg 1, [|testEquality|])] +-- +-- The use of 'DataArg' says that the type parameter of the 'NatRepr' must +-- be the same as the second type parameter of @T@. + +-- $reprs +-- +-- When working with data kinds with run-time representatives, we encourage +-- users of @parameterized-utils@ to use the following convention. Given a data +-- kind defined by +-- +-- @ +-- data T = ... +-- @ +-- +-- users should also supply a GADT @TRepr@ parameterized by @T@, e.g. +-- +-- @ +-- data TRepr (t :: T) where ... +-- @ +-- +-- Each constructor of @TRepr@ should correspond to a constructor of @T@. If @T@ +-- is defined by +-- +-- @ +-- data T = A | B Nat +-- @ +-- +-- we have a corresponding +-- +-- @ +-- data TRepr (t :: T) where +-- ARepr :: TRepr 'A +-- BRepr :: NatRepr w -> TRepr ('B w) +-- @ +-- +-- Assuming the user of @parameterized-utils@ follows this convention, we +-- provide the Template Haskell construct 'mkRepr' to automate the creation of +-- the @TRepr@ GADT. We also provide 'mkKnownReprs', which generates 'KnownRepr' +-- instances for that GADT type. See the documentation for those two functions +-- for more detailed explanations. +-- +-- NB: These macros are inspired by the corresponding macros provided by +-- @singletons-th@, and the \"repr\" programming idiom is very similar to the one +-- used by @singletons@. diff --git a/src/Data/Parameterized/TraversableF.hs b/src/Data/Parameterized/TraversableF.hs new file mode 100644 index 0000000..d8d0f37 --- /dev/null +++ b/src/Data/Parameterized/TraversableF.hs @@ -0,0 +1,191 @@ +------------------------------------------------------------------------ +-- | +-- Module : Data.Parameterized.TraversableF +-- Copyright : (c) Galois, Inc 2014-2019 +-- Maintainer : Joe Hendrix +-- Description : Traversing structures having a single parametric type +-- +-- This module declares classes for working with structures that accept +-- a single parametric type parameter. +------------------------------------------------------------------------ +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +module Data.Parameterized.TraversableF + ( FunctorF(..) + , FoldableF(..) + , foldlMF + , foldlMF' + , foldrMF + , foldrMF' + , TraversableF(..) + , traverseF_ + , forF_ + , forF + , fmapFDefault + , foldMapFDefault + , allF + , anyF + , lengthF + ) where + +import Control.Applicative +import Control.Monad.Identity +import Data.Coerce +import Data.Functor.Compose (Compose(..)) +import Data.Kind +import Data.Monoid +import GHC.Exts (build) + +import Data.Parameterized.TraversableFC + +-- | A parameterized type that is a functor on all instances. +class FunctorF m where + fmapF :: (forall x . f x -> g x) -> m f -> m g + +instance FunctorF (Const x) where + fmapF _ = coerce + +------------------------------------------------------------------------ +-- FoldableF + +-- | This is a coercion used to avoid overhead associated +-- with function composition. +(#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c) +(#.) _f = coerce + +-- | This is a generalization of the 'Foldable' class to +-- structures over parameterized terms. +class FoldableF (t :: (k -> Type) -> Type) where + {-# MINIMAL foldMapF | foldrF #-} + + -- | Map each element of the structure to a monoid, + -- and combine the results. + foldMapF :: Monoid m => (forall s . e s -> m) -> t e -> m + foldMapF f = foldrF (mappend . f) mempty + + -- | Right-associative fold of a structure. + foldrF :: (forall s . e s -> b -> b) -> b -> t e -> b + foldrF f z t = appEndo (foldMapF (Endo #. f) t) z + + -- | Left-associative fold of a structure. + foldlF :: (forall s . b -> e s -> b) -> b -> t e -> b + foldlF f z t = appEndo (getDual (foldMapF (\e -> Dual (Endo (\r -> f r e))) t)) z + + -- | Right-associative fold of a structure, + -- but with strict application of the operator. + foldrF' :: (forall s . e s -> b -> b) -> b -> t e -> b + foldrF' f0 z0 xs = foldlF (f' f0) id xs z0 + where f' f k x z = k $! f x z + + -- | Left-associative fold of a parameterized structure + -- with a strict accumulator. + foldlF' :: (forall s . b -> e s -> b) -> b -> t e -> b + foldlF' f0 z0 xs = foldrF (f' f0) id xs z0 + where f' f x k z = k $! f z x + + -- | Convert structure to list. + toListF :: (forall tp . f tp -> a) -> t f -> [a] + toListF f t = build (\c n -> foldrF (\e v -> c (f e) v) n t) + +-- | Monadic fold over the elements of a structure from left to right. +foldlMF :: (FoldableF t, Monad m) => (forall x . b -> f x -> m b) -> b -> t f -> m b +foldlMF f z0 xs = foldrF f' return xs z0 + where f' x k z = f z x >>= k + +-- | Monadic strict fold over the elements of a structure from left to right. +foldlMF' :: (FoldableF t, Monad m) => (forall x . b -> f x -> m b) -> b -> t f -> m b +foldlMF' f z0 xs = seq z0 (foldrF f' return xs z0) + where f' x k z = f z x >>= \r -> seq r (k r) + +-- | Monadic fold over the elements of a structure from right to left. +foldrMF :: (FoldableF t, Monad m) => (forall x . f x -> b -> m b) -> b -> t f -> m b +foldrMF f z0 xs = foldlF f' return xs z0 + where f' k x z = f x z >>= k + +-- | Monadic strict fold over the elements of a structure from right to left. +foldrMF' :: (FoldableF t, Monad m) => (forall x . f x -> b -> m b) -> b -> t f -> m b +foldrMF' f z0 xs = seq z0 $ foldlF f' return xs z0 + where f' k x z = f x z >>= \r -> seq r (k r) + +-- | Return 'True' if all values satisfy the predicate. +allF :: FoldableF t => (forall tp . f tp -> Bool) -> t f -> Bool +allF p = getAll #. foldMapF (All #. p) + +-- | Return 'True' if any values satisfy the predicate. +anyF :: FoldableF t => (forall tp . f tp -> Bool) -> t f -> Bool +anyF p = getAny #. foldMapF (Any #. p) + +-- | Return number of elements that we fold over. +lengthF :: FoldableF t => t f -> Int +lengthF = foldrF (const (+1)) 0 + +instance FoldableF (Const x) where + foldMapF _ _ = mempty + +------------------------------------------------------------------------ +-- TraversableF + +class (FunctorF t, FoldableF t) => TraversableF t where + traverseF :: Applicative m + => (forall s . e s -> m (f s)) + -> t e + -> m (t f) + +instance TraversableF (Const x) where + traverseF _ (Const x) = pure (Const x) + +-- | Flipped 'traverseF' +forF :: (TraversableF t, Applicative m) => t e -> (forall s . e s -> m (f s)) -> m (t f) +forF f x = traverseF x f +{-# INLINE forF #-} + +-- | This function may be used as a value for `fmapF` in a `FunctorF` +-- instance. +fmapFDefault :: TraversableF t => (forall s . e s -> f s) -> t e -> t f +fmapFDefault f = runIdentity #. traverseF (Identity #. f) +{-# INLINE fmapFDefault #-} + +-- | This function may be used as a value for `Data.Foldable.foldMap` +-- in a `Foldable` instance. +foldMapFDefault :: (TraversableF t, Monoid m) => (forall s . e s -> m) -> t e -> m +foldMapFDefault f = getConst #. traverseF (Const #. f) + +-- | Map each element of a structure to an action, evaluate +-- these actions from left to right, and ignore the results. +traverseF_ :: (FoldableF t, Applicative f) => (forall s . e s -> f a) -> t e -> f () +traverseF_ f = foldrF (\e r -> f e *> r) (pure ()) + + +-- | Map each element of a structure to an action, evaluate +-- these actions from left to right, and ignore the results. +forF_ :: (FoldableF t, Applicative m) => t f -> (forall x. f x -> m a) -> m () +forF_ v f = traverseF_ f v +{-# INLINE forF_ #-} + +------------------------------------------------------------------------ +-- TraversableF (Compose s t) + +instance ( FunctorF (s :: (k -> Type) -> Type) + , FunctorFC (t :: (l -> Type) -> (k -> Type)) + ) => + FunctorF (Compose s t) where + fmapF f (Compose v) = Compose $ fmapF (fmapFC f) v + +instance ( TraversableF (s :: (k -> Type) -> Type) + , TraversableFC (t :: (l -> Type) -> (k -> Type)) + ) => + FoldableF (Compose s t) where + foldMapF = foldMapFDefault + +-- | Traverse twice over: go under the @t@, under the @s@ and lift @m@ out. +instance ( TraversableF (s :: (k -> Type) -> Type) + , TraversableFC (t :: (l -> Type) -> (k -> Type)) + ) => + TraversableF (Compose s t) where + traverseF :: forall (f :: l -> Type) (g :: l -> Type) m. (Applicative m) => + (forall (u :: l). f u -> m (g u)) + -> Compose s t f -> m (Compose s t g) + traverseF f (Compose v) = Compose <$> traverseF (traverseFC f) v diff --git a/src/Data/Parameterized/TraversableFC.hs b/src/Data/Parameterized/TraversableFC.hs new file mode 100644 index 0000000..e11361a --- /dev/null +++ b/src/Data/Parameterized/TraversableFC.hs @@ -0,0 +1,208 @@ +------------------------------------------------------------------------ +-- | +-- Module : Data.Parameterized.TraversableFC +-- Copyright : (c) Galois, Inc 2014-2015 +-- Maintainer : Joe Hendrix +-- Description : Traversing structures having a single parametric type followed by a fixed kind. +-- +-- This module declares classes for working with structures that accept +-- a parametric type parameter followed by some fixed kind. +------------------------------------------------------------------------ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} +module Data.Parameterized.TraversableFC + ( TestEqualityFC(..) + , OrdFC(..) + , ShowFC(..) + , HashableFC(..) + , FunctorFC(..) + , FoldableFC(..) + , foldlMFC + , foldlMFC' + , foldrMFC + , foldrMFC' + , TraversableFC(..) + , traverseFC_ + , forMFC_ + , forFC_ + , forFC + , fmapFCDefault + , foldMapFCDefault + , allFC + , anyFC + , lengthFC + ) where + +import Control.Applicative (Const(..) ) +import Control.Monad.Identity ( Identity (..) ) +import Data.Coerce +import Data.Kind +import Data.Monoid +import GHC.Exts (build) +import Data.Type.Equality + +import Data.Parameterized.Classes + +-- | A parameterized type that is a functor on all instances. +-- +-- Laws: +-- +-- [Identity] @'fmapFC' 'id' == 'id'@ +-- [Composition] @'fmapFC' (f . g) == 'fmapFC' f . 'fmapFC' g@ +class FunctorFC (t :: (k -> Type) -> l -> Type) where + fmapFC :: forall f g. (forall x. f x -> g x) -> + (forall x. t f x -> t g x) + +-- | A parameterized class for types which can be shown, when given +-- functions to show parameterized subterms. +class ShowFC (t :: (k -> Type) -> l -> Type) where + {-# MINIMAL showFC | showsPrecFC #-} + + showFC :: forall f. (forall x. f x -> String) + -> (forall x. t f x -> String) + showFC sh x = showsPrecFC (\_prec z rest -> sh z ++ rest) 0 x [] + + showsPrecFC :: forall f. (forall x. Int -> f x -> ShowS) -> + (forall x. Int -> t f x -> ShowS) + showsPrecFC sh _prec x rest = showFC (\z -> sh 0 z []) x ++ rest + + +-- | A parameterized class for types which can be hashed, when given +-- functions to hash parameterized subterms. +class HashableFC (t :: (k -> Type) -> l -> Type) where + hashWithSaltFC :: forall f. (forall x. Int -> f x -> Int) -> + (forall x. Int -> t f x -> Int) + +-- | A parameterized class for types which can be tested for parameterized equality, +-- when given an equality test for subterms. +class TestEqualityFC (t :: (k -> Type) -> l -> Type) where + testEqualityFC :: forall f. (forall x y. f x -> f y -> (Maybe (x :~: y))) -> + (forall x y. t f x -> t f y -> (Maybe (x :~: y))) + +-- | A parameterized class for types which can be tested for parameterized ordering, +-- when given an comparison test for subterms. +class TestEqualityFC t => OrdFC (t :: (k -> Type) -> l -> Type) where + compareFC :: forall f. (forall x y. f x -> f y -> OrderingF x y) -> + (forall x y. t f x -> t f y -> OrderingF x y) + +------------------------------------------------------------------------ +-- FoldableF + +-- | This is a coercion used to avoid overhead associated +-- with function composition. +(#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c) +(#.) _f = coerce + +-- | This is a generalization of the 'Foldable' class to +-- structures over parameterized terms. +class FoldableFC (t :: (k -> Type) -> l -> Type) where + {-# MINIMAL foldMapFC | foldrFC #-} + + -- | Map each element of the structure to a monoid, + -- and combine the results. + foldMapFC :: forall f m. Monoid m => (forall x. f x -> m) -> (forall x. t f x -> m) + foldMapFC f = foldrFC (mappend . f) mempty + + -- | Right-associative fold of a structure. + foldrFC :: forall f b. (forall x. f x -> b -> b) -> (forall x. b -> t f x -> b) + foldrFC f z t = appEndo (foldMapFC (Endo #. f) t) z + + -- | Left-associative fold of a structure. + foldlFC :: forall f b. (forall x. b -> f x -> b) -> (forall x. b -> t f x -> b) + foldlFC f z t = appEndo (getDual (foldMapFC (\e -> Dual (Endo (\r -> f r e))) t)) z + + -- | Right-associative fold of a structure, + -- but with strict application of the operator. + foldrFC' :: forall f b. (forall x. f x -> b -> b) -> (forall x. b -> t f x -> b) + foldrFC' f0 z0 xs = foldlFC (f' f0) id xs z0 + where f' f k x z = k $! f x z + + -- | Left-associative fold of a parameterized structure + -- with a strict accumulator. + foldlFC' :: forall f b. (forall x. b -> f x -> b) -> (forall x. b -> t f x -> b) + foldlFC' f0 z0 xs = foldrFC (f' f0) id xs z0 + where f' f x k z = k $! f z x + + -- | Convert structure to list. + toListFC :: forall f a. (forall x. f x -> a) -> (forall x. t f x -> [a]) + toListFC f t = build (\c n -> foldrFC (\e v -> c (f e) v) n t) + +-- | Monadic fold over the elements of a structure from left to right. +foldlMFC :: (FoldableFC t, Monad m) => (forall x . b -> f x -> m b) -> b -> t f c -> m b +foldlMFC f z0 xs = foldrFC f' return xs z0 + where f' x k z = f z x >>= k + +-- | Monadic strict fold over the elements of a structure from left to right. +foldlMFC' :: (FoldableFC t, Monad m) => (forall x . b -> f x -> m b) -> b -> t f c -> m b +foldlMFC' f z0 xs = seq z0 $ foldrFC f' return xs z0 + where f' x k z = f z x >>= \r -> seq r (k r) + +-- | Monadic fold over the elements of a structure from right to left. +foldrMFC :: (FoldableFC t, Monad m) => (forall x . f x -> b -> m b) -> b -> t f c -> m b +foldrMFC f z0 xs = foldlFC f' return xs z0 + where f' k x z = f x z >>= k + +-- | Monadic strict fold over the elements of a structure from right to left. +foldrMFC' :: (FoldableFC t, Monad m) => (forall x . f x -> b -> m b) -> b -> t f c -> m b +foldrMFC' f z0 xs = seq z0 (foldlFC f' return xs z0) + where f' k x z = f x z >>= \r -> seq r (k r) + +-- | Return 'True' if all values satisfy predicate. +allFC :: FoldableFC t => (forall x. f x -> Bool) -> (forall x. t f x -> Bool) +allFC p = getAll #. foldMapFC (All #. p) + +-- | Return 'True' if any values satisfy predicate. +anyFC :: FoldableFC t => (forall x. f x -> Bool) -> (forall x. t f x -> Bool) +anyFC p = getAny #. foldMapFC (Any #. p) + +-- | Return number of elements that we fold over. +lengthFC :: FoldableFC t => t f x -> Int +lengthFC = foldrFC (const (+1)) 0 + +------------------------------------------------------------------------ +-- TraversableF + +class (FunctorFC t, FoldableFC t) => TraversableFC (t :: (k -> Type) -> l -> Type) where + traverseFC :: forall f g m. Applicative m + => (forall x. f x -> m (g x)) + -> (forall x. t f x -> m (t g x)) + +-- | This function may be used as a value for `fmapF` in a `FunctorF` +-- instance. +fmapFCDefault :: TraversableFC t => forall f g. (forall x. f x -> g x) -> (forall x. t f x -> t g x) +fmapFCDefault = \f -> runIdentity . traverseFC (Identity . f) +{-# INLINE fmapFCDefault #-} + +-- | This function may be used as a value for `Data.Foldable.foldMap` +-- in a `Foldable` instance. +foldMapFCDefault :: (TraversableFC t, Monoid m) => (forall x. f x -> m) -> (forall x. t f x -> m) +foldMapFCDefault = \f -> getConst . traverseFC (Const . f) +{-# INLINE foldMapFCDefault #-} + +-- | Map each element of a structure to an action, evaluate +-- these actions from left to right, and ignore the results. +traverseFC_ :: (FoldableFC t, Applicative m) => (forall x. f x -> m a) -> (forall x. t f x -> m ()) +traverseFC_ f = foldrFC (\e r -> f e *> r) (pure ()) +{-# INLINE traverseFC_ #-} + +-- | Map each element of a structure to an action, evaluate +-- these actions from left to right, and ignore the results. +forMFC_ :: (FoldableFC t, Applicative m) => t f c -> (forall x. f x -> m a) -> m () +forMFC_ v f = traverseFC_ f v +{-# INLINE forMFC_ #-} +{-# DEPRECATED forMFC_ "Use forFC_" #-} + +-- | Map each element of a structure to an action, evaluate +-- these actions from left to right, and ignore the results. +forFC_ :: (FoldableFC t, Applicative m) => t f c -> (forall x. f x -> m a) -> m () +forFC_ v f = traverseFC_ f v +{-# INLINE forFC_ #-} + +-- | Flipped 'traverseFC' +forFC :: + (TraversableFC t, Applicative m) => + t f x -> (forall y. f y -> m (g y)) -> m (t g x) +forFC v f = traverseFC f v +{-# INLINE forFC #-} diff --git a/src/Data/Parameterized/TraversableFC/WithIndex.hs b/src/Data/Parameterized/TraversableFC/WithIndex.hs new file mode 100644 index 0000000..dcbe6e9 --- /dev/null +++ b/src/Data/Parameterized/TraversableFC/WithIndex.hs @@ -0,0 +1,175 @@ +------------------------------------------------------------------------ +-- | +-- Module : Data.Parameterized.TraversableFC.WithIndex +-- Copyright : (c) Galois, Inc 2021 +-- Maintainer : Langston Barrett +-- Description : 'TraversableFC' classes, but with indices. +-- +-- As in the package indexed-traversable. +------------------------------------------------------------------------ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Parameterized.TraversableFC.WithIndex + ( FunctorFCWithIndex(..) + , FoldableFCWithIndex(..) + , ifoldlMFC + , ifoldrMFC + , iallFC + , ianyFC + , TraversableFCWithIndex(..) + , imapFCDefault + , ifoldMapFCDefault + ) where + +import Data.Functor.Const (Const(Const, getConst)) +import Data.Functor.Identity (Identity(Identity, runIdentity)) +import Data.Kind +import Data.Monoid (All(..), Any(..), Endo(Endo), appEndo, Dual(Dual, getDual)) +import Data.Profunctor.Unsafe ((#.)) +import GHC.Exts (build) + +import Data.Parameterized.Classes +import Data.Parameterized.TraversableFC + +class FunctorFC t => FunctorFCWithIndex (t :: (k -> Type) -> l -> Type) where + -- | Like 'fmapFC', but with an index. + -- + -- @ + -- 'fmapFC' f ≡ 'imapFC' ('const' f) + -- @ + imapFC :: + forall f g z. + (forall x. IndexF (t f z) x -> f x -> g x) + -> t f z + -> t g z + +------------------------------------------------------------------------ + +class (FoldableFC t, FunctorFCWithIndex t) => FoldableFCWithIndex (t :: (k -> Type) -> l -> Type) where + + -- | Like 'foldMapFC', but with an index. + -- + -- @ + -- 'foldMapFC' f ≡ 'ifoldMapFC' ('const' f) + -- @ + ifoldMapFC :: + forall f m z. + Monoid m => + (forall x. IndexF (t f z) x -> f x -> m) -> + t f z -> + m + ifoldMapFC f = ifoldrFC (\i x -> mappend (f i x)) mempty + + -- | Like 'foldrFC', but with an index. + ifoldrFC :: + forall z f b. + (forall x. IndexF (t f z) x -> f x -> b -> b) -> + b -> + t f z -> + b + ifoldrFC f z t = appEndo (ifoldMapFC (\i x -> Endo (f i x)) t) z + + -- | Like 'foldlFC', but with an index. + ifoldlFC :: + forall f b z. + (forall x. IndexF (t f z) x -> b -> f x -> b) -> + b -> + t f z -> + b + ifoldlFC f z t = + appEndo (getDual (ifoldMapFC (\i e -> Dual (Endo (\r -> f i r e))) t)) z + + -- | Like 'ifoldrFC', but with an index. + ifoldrFC' :: + forall f b z. + (forall x. IndexF (t f z) x -> f x -> b -> b) -> + b -> + t f z -> + b + ifoldrFC' f0 z0 xs = ifoldlFC (f' f0) id xs z0 + where f' f i k x z = k $! f i x z + + -- | Like 'ifoldlFC', but with an index. + ifoldlFC' :: forall f b. (forall x. b -> f x -> b) -> (forall x. b -> t f x -> b) + ifoldlFC' f0 z0 xs = foldrFC (f' f0) id xs z0 + where f' f x k z = k $! f z x + + -- | Convert structure to list. + itoListFC :: + forall f a z. + (forall x. IndexF (t f z) x -> f x -> a) -> + t f z -> + [a] + itoListFC f t = build (\c n -> ifoldrFC (\i e v -> c (f i e) v) n t) + +-- | Like 'foldlMFC', but with an index. +ifoldlMFC :: + FoldableFCWithIndex t => + Monad m => + (forall x. IndexF (t f z) x -> b -> f x -> m b) -> + b -> + t f z -> + m b +ifoldlMFC f z0 xs = ifoldlFC (\i k x z -> f i z x >>= k) return xs z0 + +-- | Like 'foldrMFC', but with an index. +ifoldrMFC :: + FoldableFCWithIndex t => + Monad m => + (forall x. IndexF (t f z) x -> f x -> b -> m b) -> + b -> + t f z -> + m b +ifoldrMFC f z0 xs = ifoldlFC (\i k x z -> f i x z >>= k) return xs z0 + +-- | Like 'allFC', but with an index. +iallFC :: + FoldableFCWithIndex t => + (forall x. IndexF (t f z) x -> f x -> Bool) -> + t f z -> + Bool +iallFC p = getAll #. ifoldMapFC (\i x -> All (p i x)) + +-- | Like 'anyFC', but with an index. +ianyFC :: + FoldableFCWithIndex t => + (forall x. IndexF (t f z) x -> f x -> Bool) -> + t f z -> Bool +ianyFC p = getAny #. ifoldMapFC (\i x -> Any (p i x)) + +------------------------------------------------------------------------ + +class (TraversableFC t, FoldableFCWithIndex t) => TraversableFCWithIndex (t :: (k -> Type) -> l -> Type) where + -- | Like 'traverseFC', but with an index. + -- + -- @ + -- 'traverseFC' f ≡ 'itraverseFC' ('const' f) + -- @ + itraverseFC :: + forall m z f g. + Applicative m => + (forall x. IndexF (t f z) x -> f x -> m (g x)) -> + t f z -> + m (t g z) + +imapFCDefault :: + forall t f g z. + TraversableFCWithIndex t => + (forall x. IndexF (t f z) x -> f x -> g x) + -> t f z + -> t g z +imapFCDefault f = runIdentity #. itraverseFC (\i x -> Identity (f i x)) +{-# INLINEABLE imapFCDefault #-} + +ifoldMapFCDefault :: + forall t m z f. + TraversableFCWithIndex t => + Monoid m => + (forall x. IndexF (t f z) x -> f x -> m) -> + t f z -> + m +ifoldMapFCDefault f = getConst #. itraverseFC (\i x -> Const (f i x)) +{-# INLINEABLE ifoldMapFCDefault #-} diff --git a/src/Data/Parameterized/Utils/BinTree.hs b/src/Data/Parameterized/Utils/BinTree.hs new file mode 100644 index 0000000..ed99c43 --- /dev/null +++ b/src/Data/Parameterized/Utils/BinTree.hs @@ -0,0 +1,368 @@ +{-| +Description : Utilities for balanced binary trees. +Copyright : (c) Galois, Inc 2014-2019 +Maintainer : Joe Hendrix +-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE Safe #-} +module Data.Parameterized.Utils.BinTree + ( MaybeS(..) + , fromMaybeS + , Updated(..) + , updatedValue + , TreeApp(..) + , IsBinTree(..) + , balanceL + , balanceR + , glue + , merge + , filterGt + , filterLt + , insert + , delete + , union + , link + , PairS(..) + ) where + +import Control.Applicative + +------------------------------------------------------------------------ +-- MaybeS + +-- | A strict version of 'Maybe' +data MaybeS v + = JustS !v + | NothingS + +instance Functor MaybeS where + fmap _ NothingS = NothingS + fmap f (JustS v) = JustS (f v) + +instance Alternative MaybeS where + empty = NothingS + mv@JustS{} <|> _ = mv + NothingS <|> v = v + +instance Applicative MaybeS where + pure = JustS + + NothingS <*> _ = NothingS + JustS{} <*> NothingS = NothingS + JustS f <*> JustS x = JustS (f x) + +fromMaybeS :: a -> MaybeS a -> a +fromMaybeS r NothingS = r +fromMaybeS _ (JustS v) = v + +------------------------------------------------------------------------ +-- Updated + +-- | @Updated a@ contains a value that has been flagged on whether it was +-- modified by an operation. +data Updated a + = Updated !a + | Unchanged !a + +updatedValue :: Updated a -> a +updatedValue (Updated a) = a +updatedValue (Unchanged a) = a + +------------------------------------------------------------------------ +-- IsBinTree + +data TreeApp e t + = BinTree !e !t !t + | TipTree + +class IsBinTree t e | t -> e where + asBin :: t -> TreeApp e t + tip :: t + + bin :: e -> t -> t -> t + size :: t -> Int + +delta,ratio :: Int +delta = 3 +ratio = 2 + +-- | @balanceL p l r@ returns a balanced tree for the sequence @l ++ [p] ++ r@. +-- +-- It assumes that @l@ and @r@ are close to being balanced, and that only +-- @l@ may contain too many elements. +balanceL :: (IsBinTree c e) => e -> c -> c -> c +balanceL p l r = do + case asBin l of + BinTree l_pair ll lr | size l > max 1 (delta*size r) -> + case asBin lr of + BinTree lr_pair lrl lrr | size lr >= max 2 (ratio*size ll) -> + bin lr_pair (bin l_pair ll lrl) (bin p lrr r) + _ -> bin l_pair ll (bin p lr r) + + _ -> bin p l r +{-# INLINE balanceL #-} + +-- | @balanceR p l r@ returns a balanced tree for the sequence @l ++ [p] ++ r@. +-- +-- It assumes that @l@ and @r@ are close to being balanced, and that only +-- @r@ may contain too many elements. +balanceR :: (IsBinTree c e) => e -> c -> c -> c +balanceR p l r = do + case asBin r of + BinTree r_pair rl rr | size r > max 1 (delta*size l) -> + case asBin rl of + BinTree rl_pair rll rlr | size rl >= max 2 (ratio*size rr) -> + (bin rl_pair $! bin p l rll) $! bin r_pair rlr rr + _ -> bin r_pair (bin p l rl) rr + _ -> bin p l r +{-# INLINE balanceR #-} + +-- | Insert a new maximal element. +insertMax :: IsBinTree c e => e -> c -> c +insertMax p t = + case asBin t of + TipTree -> bin p tip tip + BinTree q l r -> balanceR q l (insertMax p r) + +-- | Insert a new minimal element. +insertMin :: IsBinTree c e => e -> c -> c +insertMin p t = + case asBin t of + TipTree -> bin p tip tip + BinTree q l r -> balanceL q (insertMin p l) r + +-- | @link@ is called to insert a key and value between two disjoint subtrees. +link :: IsBinTree c e => e -> c -> c -> c +link p l r = + case (asBin l, asBin r) of + (TipTree, _) -> insertMin p r + (_, TipTree) -> insertMax p l + (BinTree py ly ry, BinTree pz lz rz) + | delta*size l < size r -> balanceL pz (link p l lz) rz + | delta*size r < size l -> balanceR py ly (link p ry r) + | otherwise -> bin p l r +{-# INLINE link #-} + +-- | A Strict pair +data PairS f s = PairS !f !s + +deleteFindMin :: IsBinTree c e => e -> c -> c -> PairS e c +deleteFindMin p l r = + case asBin l of + TipTree -> PairS p r + BinTree lp ll lr -> + case deleteFindMin lp ll lr of + PairS q l' -> PairS q (balanceR p l' r) +{-# INLINABLE deleteFindMin #-} + +deleteFindMax :: IsBinTree c e => e -> c -> c -> PairS e c +deleteFindMax p l r = + case asBin r of + TipTree -> PairS p l + BinTree rp rl rr -> + case deleteFindMax rp rl rr of + PairS q r' -> PairS q (balanceL p l r') +{-# INLINABLE deleteFindMax #-} + +-- | Concatenate two trees that are ordered with respect to each other. +merge :: IsBinTree c e => c -> c -> c +merge l r = + case (asBin l, asBin r) of + (TipTree, _) -> r + (_, TipTree) -> l + (BinTree x lx rx, BinTree y ly ry) + | delta*size l < size r -> balanceL y (merge l ly) ry + | delta*size r < size l -> balanceR x lx (merge rx r) + | size l > size r -> + case deleteFindMax x lx rx of + PairS q l' -> balanceR q l' r + | otherwise -> + case deleteFindMin y ly ry of + PairS q r' -> balanceL q l r' +{-# INLINABLE merge #-} + +------------------------------------------------------------------------ +-- Ordered operations + +-- | @insert p m@ inserts the binding into @m@. It returns +-- an Unchanged value if the map stays the same size and an updated +-- value if a new entry was inserted. +insert :: (IsBinTree c e) => (e -> e -> Ordering) -> e -> c -> Updated c +insert comp x t = + case asBin t of + TipTree -> Updated (bin x tip tip) + BinTree y l r -> + case comp x y of + LT -> + case insert comp x l of + Updated l' -> Updated (balanceL y l' r) + Unchanged l' -> Unchanged (bin y l' r) + GT -> + case insert comp x r of + Updated r' -> Updated (balanceR y l r') + Unchanged r' -> Unchanged (bin y l r') + EQ -> Unchanged (bin x l r) +{-# INLINABLE insert #-} + +-- | @glue l r@ concatenates @l@ and @r@. +-- +-- It assumes that @l@ and @r@ are already balanced with respect to each other. +glue :: IsBinTree c e => c -> c -> c +glue l r = + case (asBin l, asBin r) of + (TipTree, _) -> r + (_, TipTree) -> l + (BinTree x lx rx, BinTree y ly ry) + | size l > size r -> + case deleteFindMax x lx rx of + PairS q l' -> balanceR q l' r + | otherwise -> + case deleteFindMin y ly ry of + PairS q r' -> balanceL q l r' +{-# INLINABLE glue #-} + +delete :: IsBinTree c e + => (e -> Ordering) + -- ^ Predicate that returns whether the entry is less than, greater than, or equal + -- to the key we are entry that we are looking for. + -> c + -> MaybeS c +delete k t = + case asBin t of + TipTree -> NothingS + BinTree p l r -> + case k p of + LT -> (\l' -> balanceR p l' r) <$> delete k l + GT -> (\r' -> balanceL p l r') <$> delete k r + EQ -> JustS (glue l r) +{-# INLINABLE delete #-} + +------------------------------------------------------------------------ +-- filter + +-- | Returns only entries that are less than predicate with respect to the ordering +-- and Nothing if no elements are discarded. +filterGt :: IsBinTree c e => (e -> Ordering) -> c -> MaybeS c +filterGt k t = + case asBin t of + TipTree -> NothingS + BinTree x l r -> + case k x of + LT -> (\l' -> link x l' r) <$> filterGt k l + GT -> filterGt k r <|> JustS r + EQ -> JustS r +{-# INLINABLE filterGt #-} + + +-- | @filterLt k m@ returns submap of @m@ that only contains entries +-- that are smaller than @k@. If no entries are deleted then return Nothing. +filterLt :: IsBinTree c e => (e -> Ordering) -> c -> MaybeS c +filterLt k t = + case asBin t of + TipTree -> NothingS + BinTree x l r -> + case k x of + LT -> filterLt k l <|> JustS l + GT -> (\r' -> link x l r') <$> filterLt k r + EQ -> JustS l +{-# INLINABLE filterLt #-} + +------------------------------------------------------------------------ +-- Union + +-- | Insert a new key and value in the map if it is not already present. +-- Used by 'union'. +insertR :: forall c e . (IsBinTree c e) => (e -> e -> Ordering) -> e -> c -> c +insertR comp e m = fromMaybeS m (go e m) + where + go :: e -> c -> MaybeS c + go x t = + case asBin t of + TipTree -> JustS (bin x tip tip) + BinTree y l r -> + case comp x y of + LT -> (\l' -> balanceL y l' r) <$> go x l + GT -> (\r' -> balanceR y l r') <$> go x r + EQ -> NothingS +{-# INLINABLE insertR #-} + +-- | Union two sets +union :: (IsBinTree c e) => (e -> e -> Ordering) -> c -> c -> c +union comp t1 t2 = + case (asBin t1, asBin t2) of + (TipTree, _) -> t2 + (_, TipTree) -> t1 + (_, BinTree p (asBin -> TipTree) (asBin -> TipTree)) -> insertR comp p t1 + (BinTree x l r, _) -> + link x + (hedgeUnion_UB comp x l t2) + (hedgeUnion_LB comp x r t2) +{-# INLINABLE union #-} + +-- | Hedge union where we only add elements in second map if key is +-- strictly above a lower bound. +hedgeUnion_LB :: (IsBinTree c e) => (e -> e -> Ordering) -> e -> c -> c -> c +hedgeUnion_LB comp lo t1 t2 = + case (asBin t1, asBin t2) of + (_, TipTree) -> t1 + (TipTree, _) -> fromMaybeS t2 (filterGt (comp lo) t2) + -- Prune left tree. + (_, BinTree k _ r) | comp k lo <= EQ -> hedgeUnion_LB comp lo t1 r + -- Special case when t2 is a single element. + (_, BinTree x (asBin -> TipTree) (asBin -> TipTree)) -> insertR comp x t1 + -- Split on left-and-right subtrees of t1. + (BinTree x l r, _) -> + link x + (hedgeUnion_LB_UB comp lo x l t2) + (hedgeUnion_LB comp x r t2) +{-# INLINABLE hedgeUnion_LB #-} + +-- | Hedge union where we only add elements in second map if key is +-- strictly below a upper bound. +hedgeUnion_UB :: (IsBinTree c e) => (e -> e -> Ordering) -> e -> c -> c -> c +hedgeUnion_UB comp hi t1 t2 = + case (asBin t1, asBin t2) of + (_, TipTree) -> t1 + (TipTree, _) -> fromMaybeS t2 (filterLt (comp hi) t2) + -- Prune right tree. + (_, BinTree x l _) | comp x hi >= EQ -> hedgeUnion_UB comp hi t1 l + -- Special case when t2 is a single element. + (_, BinTree x (asBin -> TipTree) (asBin -> TipTree)) -> insertR comp x t1 + -- Split on left-and-right subtrees of t1. + (BinTree x l r, _) -> + link x + (hedgeUnion_UB comp x l t2) + (hedgeUnion_LB_UB comp x hi r t2) +{-# INLINABLE hedgeUnion_UB #-} + +-- | Hedge union where we only add elements in second map if key is +-- strictly between a lower and upper bound. +hedgeUnion_LB_UB :: (IsBinTree c e) => (e -> e -> Ordering) -> e -> e -> c -> c -> c +hedgeUnion_LB_UB comp lo hi t1 t2 = + case (asBin t1, asBin t2) of + (_, TipTree) -> t1 + -- Prune left tree. + (_, BinTree k _ r) | comp k lo <= EQ -> hedgeUnion_LB_UB comp lo hi t1 r + -- Prune right tree. + (_, BinTree k l _) | comp k hi >= EQ -> hedgeUnion_LB_UB comp lo hi t1 l + -- When t1 becomes empty (assumes lo <= k <= hi) + (TipTree, BinTree x l r) -> + case (filterGt (comp lo) l, filterLt (comp hi) r) of + -- No variables in t2 were eliminated. + (NothingS, NothingS) -> t2 + -- Relink t2 with filtered elements removed. + (l',r') -> link x (fromMaybeS l l') (fromMaybeS r r') + -- Special case when t2 is a single element. + (_, BinTree x (asBin -> TipTree) (asBin -> TipTree)) -> insertR comp x t1 + -- Split on left-and-right subtrees of t1. + (BinTree x l r, _) -> + link x + (hedgeUnion_LB_UB comp lo x l t2) + (hedgeUnion_LB_UB comp x hi r t2) +{-# INLINABLE hedgeUnion_LB_UB #-} diff --git a/src/Data/Parameterized/Utils/Endian.hs b/src/Data/Parameterized/Utils/Endian.hs new file mode 100644 index 0000000..bc1f497 --- /dev/null +++ b/src/Data/Parameterized/Utils/Endian.hs @@ -0,0 +1,16 @@ +{-| +Description: A common location for defining multi-byte value ordering. +Copyright : (c) Galois, Inc 2019 +-} + +module Data.Parameterized.Utils.Endian where + +-- | Determines the composition of smaller numeric values into larger values. +-- +-- BigEndian = most significant values in the lowest index location / first +-- LittleEndian = least significant values in the lowest index location / first +-- +-- Value: 0x01020304 +-- BigEndian = [ 0x01, 0x02, 0x03, 0x04 ] +-- LittleEndian = [ 0x04, 0x03, 0x02, 0x01 ] +data Endian = LittleEndian | BigEndian deriving (Eq,Show,Ord) diff --git a/src/Data/Parameterized/Vector.hs b/src/Data/Parameterized/Vector.hs new file mode 100644 index 0000000..3484511 --- /dev/null +++ b/src/Data/Parameterized/Vector.hs @@ -0,0 +1,754 @@ +{-# Language GADTs, DataKinds, TypeOperators, BangPatterns #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# Language PatternGuards #-} +{-# Language PolyKinds #-} +{-# Language TypeApplications, ScopedTypeVariables #-} +{-# Language TupleSections #-} +{-# Language Rank2Types, RoleAnnotations #-} +{-# Language CPP #-} +#if __GLASGOW_HASKELL__ >= 805 +{-# Language NoStarIsType #-} +#endif +{-| +Copyright : (c) Galois, Inc 2014-2019 + +A fixed-size vector of typed elements. + +NB: This module contains an orphan instance. It will be included in GHC 8.10, +see https://gitlab.haskell.org/ghc/ghc/merge_requests/273. +-} +module Data.Parameterized.Vector + ( Vector + -- * Lists + , fromList + , toList + + -- * Assignments + , fromAssignment + , toAssignment + + -- * Length + , length + , nonEmpty + , lengthInt + + -- * Indexing + , elemAt + , elemAtMaybe + , elemAtUnsafe + + -- * Indexing with Fin + , indicesUpTo + , indicesOf + + -- * Update + , insertAt + , insertAtMaybe + + -- * Sub sequences + , uncons + , unsnoc + , slice + , Data.Parameterized.Vector.take + , replace + , mapAt + , mapAtM + + -- * Zipping + , zipWith + , zipWithM + , zipWithM_ + , interleave + + -- * Reorder + , shuffle + , reverse + , rotateL + , rotateR + , shiftL + , shiftR + + -- * Construction + , singleton + , cons + , snoc + , generate + , generateM + -- ** Unfolding + , unfoldr + , unfoldrM + , unfoldrWithIndex + , unfoldrWithIndexM + , iterateN + , iterateNM + + -- * Splitting and joining + -- ** General + , joinWithM + , joinWith + , splitWith + , splitWithA + + -- ** Vectors + , split + , join + , append + + ) where + +import qualified Data.Vector as Vector +import Data.Coerce +import Data.Foldable.WithIndex (FoldableWithIndex(ifoldMap)) +import Data.Functor.Compose +import Data.Functor.WithIndex (FunctorWithIndex(imap)) +import Data.Vector.Mutable (MVector) +import qualified Data.Vector.Mutable as MVector +import Control.Monad.ST +import Data.Functor.Identity +import Data.Parameterized.Fin +import Data.Parameterized.NatRepr +import Data.Parameterized.NatRepr.Internal +import Data.Proxy +import Data.Traversable.WithIndex (TraversableWithIndex(itraverse)) +import Prelude hiding (length,reverse,zipWith) +import Numeric.Natural + +import qualified Data.Parameterized.Context as Ctx +import Data.Parameterized.Utils.Endian + +-- | Fixed-size non-empty vectors. +data Vector n a where + Vector :: (1 <= n) => !(Vector.Vector a) -> Vector n a + +type role Vector nominal representational + +instance Eq a => Eq (Vector n a) where + (Vector x) == (Vector y) = x == y + +instance Show a => Show (Vector n a) where + show (Vector x) = show x + +-- | Get the elements of the vector as a list, lowest index first. +toList :: Vector n a -> [a] +toList (Vector v) = Vector.toList v +{-# Inline toList #-} + +-- NOTE: We are using the raw 'NatRepr' constructor here, which is unsafe. +-- | Length of the vector. +-- @O(1)@ +length :: Vector n a -> NatRepr n +length (Vector xs) = NatRepr (fromIntegral (Vector.length xs) :: Natural) +{-# INLINE length #-} + +-- | The length of the vector as an "Int". +lengthInt :: Vector n a -> Int +lengthInt (Vector xs) = Vector.length xs +{-# Inline lengthInt #-} + +elemAt :: ((i+1) <= n) => NatRepr i -> Vector n a -> a +elemAt n (Vector xs) = xs Vector.! widthVal n + +-- | Get the element at the given index. +-- @O(1)@ +elemAtMaybe :: Int -> Vector n a -> Maybe a +elemAtMaybe n (Vector xs) = xs Vector.!? n +{-# INLINE elemAt #-} + +-- | Get the element at the given index. +-- Raises an exception if the element is not in the vector's domain. +-- @O(1)@ +elemAtUnsafe :: Int -> Vector n a -> a +elemAtUnsafe n (Vector xs) = xs Vector.! n +{-# INLINE elemAtUnsafe #-} + +-------------------------------------------------------------------------------- + +indicesUpTo :: NatRepr n -> Vector (n + 1) (Fin (n + 1)) +indicesUpTo n = + iterateN + n + (viewFin + (\x -> + case testStrictLeq (incNat x) (incNat n) of + Left LeqProof -> mkFin (incNat x) + Right Refl -> mkFin n)) + (case addPrefixIsLeq n (knownNat @1) of + LeqProof -> mkFin (knownNat @0)) + +indicesOf :: Vector n a -> Vector n (Fin n) +indicesOf v@(Vector _) = -- Pattern match to bring 1 <= n into scope + case minusPlusCancel (length v) (knownNat @1) of + Refl -> indicesUpTo (decNat (length v)) + +instance FunctorWithIndex (Fin n) (Vector n) where + imap f v = zipWith f (indicesOf v) v + +instance FoldableWithIndex (Fin n) (Vector n) where + ifoldMap f v = foldMap (uncurry f) (imap (,) v) + +instance TraversableWithIndex (Fin n) (Vector n) where + itraverse f v = traverse (uncurry f) (imap (,) v) + +-------------------------------------------------------------------------------- + +-- | Insert an element at the given index. +-- @O(n)@. +insertAt :: ((i + 1) <= n) => NatRepr i -> a -> Vector n a -> Vector n a +insertAt n a (Vector xs) = Vector (Vector.unsafeUpd xs [(widthVal n,a)]) + +-- | Insert an element at the given index. +-- Return 'Nothing' if the element is outside the vector bounds. +-- @O(n)@. +insertAtMaybe :: Int -> a -> Vector n a -> Maybe (Vector n a) +insertAtMaybe n a (Vector xs) + | 0 <= n && n < Vector.length xs = Just (Vector (Vector.unsafeUpd xs [(n,a)])) + | otherwise = Nothing + + +-- | Proof that the length of this vector is not 0. +nonEmpty :: Vector n a -> LeqProof 1 n +nonEmpty (Vector _) = LeqProof +{-# Inline nonEmpty #-} + + +-- | Remove the first element of the vector, and return the rest, if any. +uncons :: forall n a. Vector n a -> (a, Either (n :~: 1) (Vector (n-1) a)) +uncons v@(Vector xs) = (Vector.head xs, mbTail) + where + mbTail :: Either (n :~: 1) (Vector (n - 1) a) + mbTail = case testStrictLeq (knownNat @1) (length v) of + Left n2_leq_n -> + do LeqProof <- return (leqSub2 n2_leq_n (leqRefl (knownNat @1))) + return (Vector (Vector.tail xs)) + Right Refl -> Left Refl +{-# Inline uncons #-} + +-- | Remove the last element of the vector, and return the rest, if any. +unsnoc :: forall n a. Vector n a -> (a, Either (n :~: 1) (Vector (n-1) a)) +unsnoc v@(Vector xs) = (Vector.last xs, mbTail) + where + mbTail :: Either (n :~: 1) (Vector (n - 1) a) + mbTail = case testStrictLeq (knownNat @1) (length v) of + Left n2_leq_n -> + do LeqProof <- return (leqSub2 n2_leq_n (leqRefl (knownNat @1))) + return (Vector (Vector.slice 0 (Vector.length xs - 1) xs)) + Right Refl -> Left Refl +{-# Inline unsnoc #-} + + +-------------------------------------------------------------------------------- + +-- | Make a vector of the given length and element type. +-- Returns "Nothing" if the input list does not have the right number of +-- elements. +-- @O(n)@. +fromList :: (1 <= n) => NatRepr n -> [a] -> Maybe (Vector n a) +fromList n xs + | widthVal n == Vector.length v = Just (Vector v) + | otherwise = Nothing + where + v = Vector.fromList xs +{-# INLINE fromList #-} + +-- | Convert a non-empty 'Ctx.Assignment' to a fixed-size 'Vector'. +-- +-- This function uses the same ordering convention as 'Ctx.toVector'. +fromAssignment :: + forall f ctx tp e. + (forall tp'. f tp' -> e) -> + Ctx.Assignment f (ctx Ctx.::> tp) -> + Vector (Ctx.CtxSize (ctx Ctx.::> tp)) e +fromAssignment f assign = + case Ctx.viewAssign assign of + Ctx.AssignExtend assign' _ -> + case leqAdd (leqRefl (knownNat @1)) (Ctx.sizeToNatRepr (Ctx.size assign')) of + LeqProof -> Vector (Ctx.toVector assign f) + +-- | Convert a 'Vector' into a 'Ctx.Assignment'. +-- +-- This function uses the same ordering convention as 'Ctx.toVector'. +toAssignment :: + Ctx.Size ctx -> + (forall tp. Ctx.Index ctx tp -> e -> f tp) -> + Vector (Ctx.CtxSize ctx) e -> + Ctx.Assignment f ctx +toAssignment sz g vec = + -- The unsafe indexing here relies on the safety of the rest of the Vector + -- API, specifically the inability to construct vectors that have an + -- underlying size that differs from the size in their type. + Ctx.generate sz (\idx -> g idx (elemAtUnsafe (Ctx.indexVal idx) vec)) + +-- | Extract a subvector of the given vector. +slice :: (i + w <= n, 1 <= w) => + NatRepr i {- ^ Start index -} -> + NatRepr w {- ^ Width of sub-vector -} -> + Vector n a -> Vector w a +slice i w (Vector xs) = Vector (Vector.slice (widthVal i) (widthVal w) xs) +{-# INLINE slice #-} + +-- | Take the front (lower-indexes) part of the vector. +take :: forall n x a. (1 <= n) => NatRepr n -> Vector (n + x) a -> Vector n a +take | LeqProof <- prf = slice (knownNat @0) + where + prf = leqAdd (leqRefl (Proxy @n)) (Proxy @x) + +-- | Scope a monadic function to a sub-section of the given vector. +mapAtM :: Monad m => (i + w <= n, 1 <= w) => + NatRepr i {- ^ Start index -} -> + NatRepr w {- ^ Section width -} -> + (Vector w a -> m (Vector w a)) {-^ map for the sub-vector -} -> + Vector n a -> m (Vector n a) +mapAtM i w f (Vector vn) = + let + (vhead, vtail) = Vector.splitAt (widthVal i) vn + (vsect, vend) = Vector.splitAt (widthVal w) vtail + in do + Vector vsect' <- f (Vector vsect) + return $ Vector $ vhead Vector.++ vsect' Vector.++ vend + +-- | Scope a function to a sub-section of the given vector. +mapAt :: (i + w <= n, 1 <= w) => + NatRepr i {- ^ Start index -} -> + NatRepr w {- ^ Section width -} -> + (Vector w a -> Vector w a) {-^ map for the sub-vector -} -> + Vector n a -> Vector n a +mapAt i w f vn = runIdentity $ mapAtM i w (pure . f) vn + +-- | Replace a sub-section of a vector with the given sub-vector. +replace :: (i + w <= n, 1 <= w) => + NatRepr i {- ^ Start index -} -> + Vector w a {- ^ sub-vector -} -> + Vector n a -> Vector n a +replace i vw vn = mapAt i (length vw) (const vw) vn + +-------------------------------------------------------------------------------- + +instance Functor (Vector n) where + fmap f (Vector xs) = Vector (Vector.map f xs) + {-# Inline fmap #-} + +instance Foldable (Vector n) where + foldMap f (Vector xs) = foldMap f xs + +instance Traversable (Vector n) where + traverse f (Vector xs) = Vector <$> traverse f xs + {-# Inline traverse #-} + +-- | Zip two vectors, potentially changing types. +-- @O(n)@ +zipWith :: (a -> b -> c) -> Vector n a -> Vector n b -> Vector n c +zipWith f (Vector xs) (Vector ys) = Vector (Vector.zipWith f xs ys) +{-# Inline zipWith #-} + +zipWithM :: Monad m => (a -> b -> m c) -> + Vector n a -> Vector n b -> m (Vector n c) +zipWithM f (Vector xs) (Vector ys) = Vector <$> Vector.zipWithM f xs ys +{-# Inline zipWithM #-} + +zipWithM_ :: Monad m => (a -> b -> m ()) -> Vector n a -> Vector n b -> m () +zipWithM_ f (Vector xs) (Vector ys) = Vector.zipWithM_ f xs ys +{-# Inline zipWithM_ #-} + +{- | Interleave two vectors. The elements of the first vector are +at even indexes in the result, the elements of the second are at odd indexes. -} +interleave :: + forall n a. (1 <= n) => Vector n a -> Vector n a -> Vector (2 * n) a +interleave (Vector xs) (Vector ys) + | LeqProof <- leqMulPos (Proxy @2) (Proxy @n) = Vector zs + where + len = Vector.length xs + Vector.length ys + zs = Vector.generate len (\i -> let v = if even i then xs else ys + in v Vector.! (i `div` 2)) + +-------------------------------------------------------------------------------- + +{- | Move the elements around, as specified by the given function. + * Note: the reindexing function says where each of the elements + in the new vector come from. + * Note: it is OK for the same input element to end up in mulitple places + in the result. +@O(n)@ +-} +shuffle :: (Int -> Int) -> Vector n a -> Vector n a +shuffle f (Vector xs) = Vector ys + where + ys = Vector.generate (Vector.length xs) (\i -> xs Vector.! f i) +{-# Inline shuffle #-} + +-- | Reverse the vector. +reverse :: forall a n. (1 <= n) => Vector n a -> Vector n a +reverse x = shuffle (\i -> lengthInt x - i - 1) x + +-- | Rotate "left". The first element of the vector is on the "left", so +-- rotate left moves all elemnts toward the corresponding smaller index. +-- Elements that fall off the beginning end up at the end. +rotateL :: Int -> Vector n a -> Vector n a +rotateL !n xs = shuffle rotL xs + where + !len = lengthInt xs + rotL i = (i + n) `mod` len -- `len` is known to be >= 1 +{-# Inline rotateL #-} + +-- | Rotate "right". The first element of the vector is on the "left", so +-- rotate right moves all elemnts toward the corresponding larger index. +-- Elements that fall off the end, end up at the beginning. +rotateR :: Int -> Vector n a -> Vector n a +rotateR !n xs = shuffle rotR xs + where + !len = lengthInt xs + rotR i = (i - n) `mod` len -- `len` is known to be >= 1 +{-# Inline rotateR #-} + +{- | Move all elements towards smaller indexes. +Elements that fall off the front are ignored. +Empty slots are filled in with the given element. +@O(n)@. -} +shiftL :: Int -> a -> Vector n a -> Vector n a +shiftL !x a (Vector xs) = Vector ys + where + !len = Vector.length xs + ys = Vector.generate len (\i -> let j = i + x + in if j >= len then a else xs Vector.! j) +{-# Inline shiftL #-} + +{- | Move all elements towards the larger indexes. +Elements that "fall" off the end are ignored. +Empty slots are filled in with the given element. +@O(n)@. -} +shiftR :: Int -> a -> Vector n a -> Vector n a +shiftR !x a (Vector xs) = Vector ys + where + !len = Vector.length xs + ys = Vector.generate len (\i -> let j = i - x + in if j < 0 then a else xs Vector.! j) +{-# Inline shiftR #-} + +-------------------------------------------------------------------------------i + +-- | Append two vectors. The first one is at lower indexes in the result. +append :: Vector m a -> Vector n a -> Vector (m + n) a +append v1@(Vector xs) v2@(Vector ys) = + case leqAddPos (length v1) (length v2) of { LeqProof -> + Vector (xs Vector.++ ys) + } +{-# Inline append #-} + +-------------------------------------------------------------------------------- +-- Constructing Vectors + +-- | Vector with exactly one element +singleton :: forall a. a -> Vector 1 a +singleton a = Vector (Vector.singleton a) + +leqLen :: forall n a. Vector n a -> LeqProof 1 (n + 1) +leqLen v = leqTrans (nonEmpty v :: LeqProof 1 n) (leqSucc (length v)) + +-- | Add an element to the head of a vector +cons :: forall n a. a -> Vector n a -> Vector (n+1) a +cons a v@(Vector x) = case leqLen v of LeqProof -> (Vector (Vector.cons a x)) + +-- | Add an element to the tail of a vector +snoc :: forall n a. Vector n a -> a -> Vector (n+1) a +snoc v@(Vector x) a = case leqLen v of LeqProof -> (Vector (Vector.snoc x a)) + +-- | This newtype wraps Vector so that we can curry it in the call to +-- @natRecBounded@. It adds 1 to the length so that the base case is +-- a @Vector@ of non-zero length. +newtype Vector' a n = MkVector' (Vector (n+1) a) + +unVector' :: Vector' a n -> Vector (n+1) a +unVector' (MkVector' v) = v + +generate' :: forall h a + . NatRepr h + -> (forall n. (n <= h) => NatRepr n -> a) + -> Vector' a h +generate' h gen = + runIdentity $ unfoldrWithIndexM' h (\n _last -> Identity (gen n, ())) () + +-- | Apply a function to each element in a range starting at zero; +-- return the a vector of values obtained. +-- cf. both @natFromZero@ and @Data.Vector.generate@ +generate :: forall h a + . NatRepr h + -> (forall n. (n <= h) => NatRepr n -> a) + -> Vector (h + 1) a +generate h gen = unVector' (generate' h gen) + +-- | Since @Vector@ is traversable, we can pretty trivially sequence +-- @natFromZeroVec@ inside a monad. +generateM :: forall m h a. (Monad m) + => NatRepr h + -> (forall n. (n <= h) => NatRepr n -> m a) + -> m (Vector (h + 1) a) +generateM h gen = sequence $ generate h gen + +newtype Compose3 m f g a = Compose3 { getCompose3 :: m (f (g a)) } + +unfoldrWithIndexM' :: forall m h a b. (Monad m) + => NatRepr h + -> (forall n. (n <= h) => NatRepr n -> b -> m (a, b)) + -> b + -> m (Vector' a h) +unfoldrWithIndexM' h gen start = + case isZeroOrGT1 h of + Left Refl -> snd <$> getCompose3 base + Right LeqProof -> + case (minusPlusCancel h (knownNat @1) :: h - 1 + 1 :~: h) of { Refl -> + snd <$> getCompose3 (natRecBounded (decNat h) (decNat h) base step) + } + where base :: Compose3 m ((,) b) (Vector' a) 0 + base = + case leqZero @h of { LeqProof -> + Compose3 $ (\(hd, b) -> (b, MkVector' (singleton hd))) <$> gen (knownNat @0) start + } + step :: forall p. (1 <= h, p <= h - 1) + => NatRepr p + -> Compose3 m ((,) b) (Vector' a) p + -> Compose3 m ((,) b) (Vector' a) (p + 1) + step p (Compose3 mv) = + case minusPlusCancel h (knownNat @1) :: h - 1 + 1 :~: h of { Refl -> + case (leqAdd2 (LeqProof :: LeqProof p (h-1)) + (LeqProof :: LeqProof 1 1) :: LeqProof (p+1) h) of { LeqProof -> + Compose3 $ + do (seed, MkVector' v) <- mv + (next, nextSeed) <- gen (incNat p) seed + pure $ (nextSeed, MkVector' $ snoc v next) + }} + +-- | Monadically unfold a vector, with access to the current index. +-- +-- c.f. @Data.Vector.unfoldrExactNM@ +unfoldrWithIndexM :: forall m h a b. (Monad m) + => NatRepr h + -> (forall n. (n <= h) => NatRepr n -> b -> m (a, b)) + -> b + -> m (Vector (h + 1) a) +unfoldrWithIndexM h gen start = unVector' <$> unfoldrWithIndexM' h gen start + +-- | Unfold a vector, with access to the current index. +-- +-- c.f. @Data.Vector.unfoldrExactN@ +unfoldrWithIndex :: forall h a b + . NatRepr h + -> (forall n. (n <= h) => NatRepr n -> b -> (a, b)) + -> b + -> Vector (h + 1) a +unfoldrWithIndex h gen start = + unVector' $ runIdentity $ unfoldrWithIndexM' h (\n v -> Identity (gen n v)) start + +-- | Monadically construct a vector with exactly @h + 1@ elements by repeatedly +-- applying a generator function to a seed value. +-- +-- c.f. @Data.Vector.unfoldrExactNM@ +unfoldrM :: forall m h a b. (Monad m) + => NatRepr h + -> (b -> m (a, b)) + -> b + -> m (Vector (h + 1) a) +unfoldrM h gen start = unfoldrWithIndexM h (\_ v -> gen v) start + +-- | Construct a vector with exactly @h + 1@ elements by repeatedly applying a +-- generator function to a seed value. +-- +-- c.f. @Data.Vector.unfoldrExactN@ +unfoldr :: forall h a b + . NatRepr h + -> (b -> (a, b)) + -> b + -> Vector (h + 1) a +unfoldr h gen start = unfoldrWithIndex h (\_ v -> gen v) start + +-- | Build a vector by repeatedly applying a monadic function to a seed value. +-- +-- Compare to 'Vector.iterateNM'. +iterateNM :: Monad m => NatRepr n -> (a -> m a) -> a -> m (Vector (n + 1) a) +iterateNM h f start = + case isZeroNat h of + ZeroNat -> pure (singleton start) + NonZeroNat -> cons start <$> unfoldrM (predNat h) (fmap dup . f) start + where dup x = (x, x) + +-- | Build a vector by repeatedly applying a function to a seed value. +-- +-- Compare to 'Vector.iterateN' +iterateN :: NatRepr n -> (a -> a) -> a -> Vector (n + 1) a +iterateN h f start = runIdentity (iterateNM h (Identity . f) start) + +-------------------------------------------------------------------------------- + +coerceVec :: Coercible a b => Vector n a -> Vector n b +coerceVec = coerce + +-- | Monadically join a vector of values, using the given function. +-- This functionality can sometimes be reproduced by creating a newtype +-- wrapper and using @joinWith@, this implementation is provided for +-- convenience. +joinWithM :: + forall m f n w. + (1 <= w, Monad m) => + (forall l. (1 <= l) => NatRepr l -> f w -> f l -> m (f (w + l))) + {- ^ A function for joining contained elements. The first argument is + the size of the accumulated third term, and the second argument + is the element to join to the accumulated term. The function + can use any join strategy desired (prepending/"BigEndian", + appending/"LittleEndian", etc.). -} + -> NatRepr w + -> Vector n (f w) + -> m (f (n * w)) + +joinWithM jn w = fmap fst . go + where + go :: forall l. Vector l (f w) -> m (f (l * w), NatRepr (l * w)) + go exprs = + case uncons exprs of + (a, Left Refl) -> return (a, w) + (a, Right rest) -> + case nonEmpty rest of { LeqProof -> + case leqMulPos (length rest) w of { LeqProof -> + case nonEmpty exprs of { LeqProof -> + case lemmaMul w (length exprs) of { Refl -> do + -- @siddharthist: This could probably be written applicatively? + (res, sz) <- go rest + joined <- jn sz a res + return (joined, addNat w sz) + }}}} + +-- | Join a vector of vectors, using the given function to combine the +-- sub-vectors. +joinWith :: + forall f n w. + (1 <= w) => + (forall l. (1 <= l) => NatRepr l -> f w -> f l -> f (w + l)) + {- ^ A function for joining contained elements. The first argument is + the size of the accumulated third term, and the second argument + is the element to join to the accumulated term. The function + can use any join strategy desired (prepending/"BigEndian", + appending/"LittleEndian", etc.). -} + -> NatRepr w + -> Vector n (f w) + -> f (n * w) +joinWith jn w v = runIdentity $ joinWithM (\n x -> pure . (jn n x)) w v +{-# Inline joinWith #-} + +-- | Split a vector into a vector of vectors. +-- +-- The "Endian" parameter determines the ordering of the inner +-- vectors. If "LittleEndian", then less significant bits go into +-- smaller indexes. If "BigEndian", then less significant bits go +-- into larger indexes. See the documentation for 'split' for more +-- details. +splitWith :: forall f w n. + (1 <= w, 1 <= n) => + Endian -> + (forall i. (i + w <= n * w) => + NatRepr (n * w) -> NatRepr i -> f (n * w) -> f w) + {- ^ A function for slicing out a chunk of length @w@, starting at @i@ -} -> + NatRepr n -> NatRepr w -> f (n * w) -> Vector n (f w) +splitWith endian select n w val = Vector (Vector.create initializer) + where + len = widthVal n + start :: Int + next :: Int -> Int + (start,next) = case endian of + LittleEndian -> (0, succ) + BigEndian -> (len - 1, pred) + + initializer :: forall s. ST s (MVector s (f w)) + initializer = + do LeqProof <- return (leqMulPos n w) + LeqProof <- return (leqMulMono n w) + + v <- MVector.new len + let fill :: Int -> NatRepr i -> ST s () + fill loc i = + let end = addNat i w in + case testLeq end inLen of + Just LeqProof -> + do MVector.write v loc (select inLen i val) + fill (next loc) end + Nothing -> return () + + + fill start (knownNat @0) + return v + + inLen :: NatRepr (n * w) + inLen = natMultiply n w +{-# Inline splitWith #-} + +-- We can sneakily put our functor in the parameter "f" of @splitWith@ using the +-- @Compose@ newtype. +-- | An applicative version of @splitWith@. +splitWithA :: forall f g w n. (Applicative f, 1 <= w, 1 <= n) => + Endian -> + (forall i. (i + w <= n * w) => + NatRepr (n * w) -> NatRepr i -> g (n * w) -> f (g w)) + {- ^ f function for slicing out f chunk of length @w@, starting at @i@ -} -> + NatRepr n -> NatRepr w -> g (n * w) -> f (Vector n (g w)) +splitWithA e select n w val = traverse getCompose $ + splitWith @(Compose f g) e select' n w $ Compose (pure val) + where -- Wrap everything in Compose + select' :: (forall i. (i + w <= n * w) + => NatRepr (n * w) -> NatRepr i -> Compose f g (n * w) -> Compose f g w) + -- Whatever we pass in as "val" is what's passed to select anyway, + -- so there's no need to examine the argument. Just use "val" directly here. + select' nw i _ = Compose $ select nw i val + +newtype Vec a n = Vec (Vector n a) + +vSlice :: (i + w <= l, 1 <= w) => + NatRepr w -> NatRepr l -> NatRepr i -> Vec a l -> Vec a w +vSlice w _ i (Vec xs) = Vec (slice i w xs) +{-# Inline vSlice #-} + +-- | Append the two bit vectors. The first argument is +-- at the lower indexes of the resulting vector. +vAppend :: NatRepr n -> Vec a m -> Vec a n -> Vec a (m + n) +vAppend _ (Vec xs) (Vec ys) = Vec (append xs ys) +{-# Inline vAppend #-} + +-- | Split a vector into a vector of vectors. The default ordering of +-- the outer result vector is "LittleEndian". +-- +-- For example: +-- @ +-- let wordsize = knownNat :: NatRepr 3 +-- vecsize = knownNat :: NatRepr 12 +-- numwords = knownNat :: NatRepr 4 (12 / 3) +-- Just inpvec = fromList vecsize [ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12 ] +-- in show (split numwords wordsize inpvec) == "[ [1,2,3], [4,5,6], [7,8,9], [10,11,12] ]" +-- @ +-- whereas a BigEndian result would have been +-- @ +-- [ [10,11,12], [7,8,9], [4,5,6], [1,2,3] ] +-- @ +split :: (1 <= w, 1 <= n) => + NatRepr n -- ^ Inner vector size + -> NatRepr w -- ^ Outer vector size + -> Vector (n * w) a -- ^ Input vector + -> Vector n (Vector w a) +split n w xs = coerceVec (splitWith LittleEndian (vSlice w) n w (Vec xs)) +{-# Inline split #-} + +-- | Join a vector of vectors into a single vector. Assumes an +-- append/"LittleEndian" join strategy: the order of the inner vectors +-- is preserved in the result vector. +-- +-- @ +-- let innersize = knownNat :: NatRepr 4 +-- Just inner1 = fromList innersize [ 1, 2, 3, 4 ] +-- Just inner2 = fromList innersize [ 5, 6, 7, 8 ] +-- Just inner3 = fromList innersize [ 9, 10, 11, 12 ] +-- outersize = knownNat :: NatRepr 3 +-- Just outer = fromList outersize [ inner1, inner2, inner3 ] +-- in show (join innersize outer) = [ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12 ] +-- @ +-- a prepend/"BigEndian" join strategy would have the result: +-- @ +-- [ 9, 10, 11, 12, 5, 6, 7, 8, 1, 2, 3, 4 ] +-- @ +join :: (1 <= w) => NatRepr w -> Vector n (Vector w a) -> Vector (n * w) a +join w xs = ys + where Vec ys = joinWith vAppend w (coerceVec xs) +{-# Inline join #-} diff --git a/src/Data/Parameterized/WithRepr.hs b/src/Data/Parameterized/WithRepr.hs new file mode 100644 index 0000000..9c7ff73 --- /dev/null +++ b/src/Data/Parameterized/WithRepr.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-| +Copyright : (c) Galois, Inc 2019 + +This module declares a class with a single method that can be used to +derive a 'KnownRepr' constraint from an explicit 'Repr' argument. +Clients of this method need only create an empty instance. The default +implementation suffices. + +For example, suppose we have defined a 'Repr' type for 'Peano' numbers: + +@ +data Peano = Z | S Peano + +data PeanoRepr p where + ZRepr :: PeanoRepr Z + SRepr :: PeanoRepr p -> PeanoRepr (S p) + +-- KnownRepr instances +@ + +Then the instance for this class +@ +instance IsRepr PeanoRepr +@ + +means that functions with 'KnownRepr' constraints can be used after +pattern matching. + +@ +f :: KnownRepr PeanoRepr a => ... + +example :: PeanoRepr n -> ... +example ZRepr = ... +example (SRepr (pm::PeanoRepr m)) = ... withRepr pm f ... +@ + + +NOTE: The type 'f' must be a *singleton* type--- i.e. for a given +type 'a' there should be only one value that inhabits 'f a'. If that +is not the case, this operation can be used to subvert coherence. + +Credit: the unsafe implementation of 'withRepr' is taken from the +'withSingI' function in the singletons library +. Packaging +this method in a class here makes it more flexible---we do not have to +define a dedicated 'Sing' type, but can use any convenient singleton +as a 'Repr'. + +NOTE: if this module is compiled without UNSAFE_OPS, the default +method will not be available. + +-} +module Data.Parameterized.WithRepr(IsRepr(..)) where + +import Data.Kind +import Data.Parameterized.Classes + +#ifdef UNSAFE_OPS +import Data.Constraint(Dict(..)) +import Unsafe.Coerce(unsafeCoerce) + +import Data.Parameterized.NatRepr (NatRepr) +import Data.Parameterized.SymbolRepr (SymbolRepr) +import Data.Parameterized.Peano (PeanoRepr) +import Data.Parameterized.Context(Assignment) +import Data.Parameterized.List(List) +#else +import Data.Parameterized.Peano (PeanoRepr,PeanoView(..)) +#endif +import Data.Parameterized.BoolRepr + +-- | Turn an explicit Repr value into an implict KnownRepr constraint +class IsRepr (f :: k -> Type) where + + withRepr :: f a -> (KnownRepr f a => r) -> r + +#ifdef UNSAFE_OPS + withRepr si r = case reprInstance si of + Dict -> r + +reprInstance :: forall f a . IsRepr f => f a -> Dict (KnownRepr f a) +reprInstance s = with_repr Dict + where + with_repr :: (KnownRepr f a => Dict (KnownRepr f a)) -> Dict (KnownRepr f a) + with_repr si = unsafeCoerce (Don'tInstantiate si) s + +newtype DI f a = Don'tInstantiate (KnownRepr f a => Dict (KnownRepr f a)) +#endif + + +------------------------------------ +-- Instances for types defined in parameterized-utils + +#ifdef UNSAFE_OPS +instance IsRepr NatRepr +instance IsRepr SymbolRepr +instance IsRepr PeanoRepr +instance IsRepr BoolRepr +instance IsRepr f => IsRepr (List f) +instance IsRepr f => IsRepr (Assignment f) +#else +-- awful, slow implementation for PeanoRepr +instance IsRepr PeanoRepr where + withRepr ZRepr f = f + withRepr (SRepr m) f = withRepr m f + +instance IsRepr BoolRepr where + withRepr TrueRepr f = f + withRepr FalseRepr f = f +#endif diff --git a/test/Test/Context.hs b/test/Test/Context.hs new file mode 100644 index 0000000..67571b4 --- /dev/null +++ b/test/Test/Context.hs @@ -0,0 +1,615 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Test.Context + ( contextTests + , genSomePayloadList + , mkUAsgn + , mkSAsgn + ) +where + +import Control.Lens +import Data.Functor.Product (Product(Pair)) +import Data.Kind +import Data.Parameterized.Classes +import qualified Data.Parameterized.Context as C +import qualified Data.Parameterized.Context.Safe as S +import qualified Data.Parameterized.Context.Unsafe as U +import Data.Parameterized.Ctx +import qualified Data.Parameterized.Ctx.Proofs as P +import Data.Parameterized.Some +import Data.Parameterized.TraversableFC +import Data.Parameterized.TraversableFC.WithIndex +import Hedgehog +import qualified Hedgehog.Gen as HG +import Hedgehog.Range +import Test.Tasty +import Test.Tasty.HUnit ( (@=?), (@?=), testCaseSteps ) +import Test.Tasty.Hedgehog + +---------------------------------------------------------------------- +-- Create a Payload GADT which is the parameterized type used for many +-- of the Context/Assignment tests in this module. + +data Payload (ty :: Type) where + IntPayload :: Int -> Payload Int + StringPayload :: String -> Payload String + BoolPayload :: Bool -> Payload Bool + +deriving instance Eq (Payload ty) + +instance TestEquality Payload where + testEquality (IntPayload x) (IntPayload y) = if x == y then Just Refl else Nothing + testEquality (StringPayload x) (StringPayload y) = if x == y then Just Refl else Nothing + testEquality (BoolPayload x) (BoolPayload y) = if x == y then Just Refl else Nothing + testEquality _ _ = Nothing + +instance Show (Payload tp) where + show (IntPayload x) = show x <> " :: Int" + show (StringPayload x) = show x <> " :: String" + show (BoolPayload x) = show x <> " :: Bool" + +instance ShowF Payload + +twiddle :: Payload a -> Payload a +twiddle (IntPayload n) = IntPayload (n+1) +twiddle (StringPayload str) = StringPayload (str++"asdf") +twiddle (BoolPayload b) = BoolPayload (not b) + +twaddle :: Payload a -> Payload a +twaddle (IntPayload n) = IntPayload (n-1) +twaddle (StringPayload str) = StringPayload (reverse str) +twaddle (BoolPayload b) = BoolPayload (not b) + +newtype Fun = Fun (forall a. Payload a -> Payload a) + +instance Show Fun where + show _ = "unshowable" + +-- | Functions for e.g. testing functor laws +funs :: [Fun] +funs = [Fun twiddle, Fun twaddle, Fun id] + +---------------------------------------------------------------------- +-- Create another parameterized type for testing. This one is not a +-- GADT, which will require some interesting implementation tricks. +-- +-- The common 'Maybe' type is potentially useable for this type, but +-- there are some restrictions on 'Maybe'. For example, it is not +-- possible to create a @ShowF Maybe@ because although 'Maybe' is of type +-- @(k -> type)@, @k@ is unconstrained and doesn't contain a 'Show' +-- constraint. + +data MyMaybe t = (Show t) => MyJust t | MyNothing +instance ShowF MyMaybe +instance Show (MyMaybe t) where + show (MyJust x) = "MyJust " <> show x + show MyNothing = "MyNothing" + +---------------------------------------------------------------------- +-- Some Hedgehog generators + +genSomePayload :: Monad m => GenT m (Some Payload) +genSomePayload = + HG.choice + [ Some . IntPayload <$> HG.integral (linearBounded :: Range Int) + , Some . StringPayload <$> HG.string (linear 1 32) HG.ascii + , Some . BoolPayload <$> HG.element [ True, False ] + ] + +-- generate a non-empty list of payload entries +genSomePayloadList :: Monad m => GenT m [Some Payload] +genSomePayloadList = HG.list (linear 1 10) genSomePayload + + +type UAsgn = U.Assignment Payload +type SAsgn = S.Assignment Payload + +mkUAsgn :: [Some Payload] -> Some UAsgn +mkUAsgn = go U.empty + where go :: UAsgn ctx -> [Some Payload] -> Some UAsgn + go a [] = Some a + go a (Some x : xs) = go (U.extend a x) xs + +mkSAsgn :: [Some Payload] -> Some SAsgn +mkSAsgn = go S.empty + where go :: SAsgn ctx -> [Some Payload] -> Some SAsgn + go a [] = Some a + go a (Some x : xs) = go (S.extend a x) xs + +---------------------------------------------------------------------- +-- A Ctx type that will be used for some of the Assignments tested here + +type TestCtx = U.EmptyCtx '::> Int '::> String '::> Int '::> Bool + +---------------------------------------------------------------------- +-- Hedgehog properties + +prop_sizeUnsafe :: Property +prop_sizeUnsafe = property $ + do vals <- forAll genSomePayloadList + Some a <- return $ mkUAsgn vals + length vals === U.sizeInt (U.size a) + +prop_sizeSafe :: Property +prop_sizeSafe = property $ + do vals <- forAll genSomePayloadList + Some a <- return $ mkSAsgn vals + length vals === S.sizeInt (S.size a) + +prop_safeIndexEq :: Property +prop_safeIndexEq = property $ + do vals <- forAll genSomePayloadList + i' <- forAll $ HG.int (linear 0 $ length vals - 1) + Some a <- return $ mkSAsgn vals + Just (Some idx) <- return $ S.intIndex i' (S.size a) + Some (a S.! idx) === vals !! i' + +prop_unsafeIndexEq :: Property +prop_unsafeIndexEq = property $ + do vals <- forAll genSomePayloadList + i' <- forAll $ HG.int (linear 0 $ length vals - 1) + Some a <- return $ mkUAsgn vals + Just (Some idx) <- return $ U.intIndex i' (U.size a) + Some (a U.! idx) === vals !! i' + +prop_safeToList :: Property +prop_safeToList = property $ + do vals <- forAll genSomePayloadList + Some a <- return $ mkSAsgn vals + let vals' = toListFC Some a + vals === vals' + +prop_unsafeToList :: Property +prop_unsafeToList = property $ + do vals <- forAll genSomePayloadList + Some a <- return $ mkUAsgn vals + let vals' = toListFC Some a + vals === vals' + +prop_adjustTestMonadic :: Property +prop_adjustTestMonadic = property $ + do vals <- forAll genSomePayloadList + i' <- forAll $ HG.int (linear 0 $ length vals - 1) + + Some x <- return $ mkUAsgn vals + Some y <- return $ mkSAsgn vals + + Just (Some idx_x) <- return $ U.intIndex i' (U.size x) + Just (Some idx_y) <- return $ S.intIndex i' (S.size y) + + x' <- U.adjustM (return . twiddle) idx_x x + y' <- S.adjustM (return . twiddle) idx_y y + + toListFC Some x' === toListFC Some y' + +prop_adjustTest :: Property +prop_adjustTest = property $ + do vals <- forAll genSomePayloadList + i' <- forAll $ HG.int (linear 0 $ length vals - 1) + + Some x <- return $ mkUAsgn vals + Some y <- return $ mkSAsgn vals + + Just (Some idx_x) <- return $ U.intIndex i' (U.size x) + Just (Some idx_y) <- return $ S.intIndex i' (S.size y) + + let x' = x & ixF idx_x %~ twiddle + y' = y & ixF idx_y %~ twiddle + + toListFC Some x' === toListFC Some y' + -- adjust actually modified the entry + toListFC Some x /== toListFC Some x' + toListFC Some y /== toListFC Some y' + +prop_updateTest :: Property +prop_updateTest = property $ + do vals <- forAll genSomePayloadList + i' <- forAll $ HG.int (linear 0 $ length vals - 1) + + Some x <- return $ mkUAsgn vals + Some y <- return $ mkSAsgn vals + + Just (Some idx_x) <- return $ U.intIndex i' (U.size x) + Just (Some idx_y) <- return $ S.intIndex i' (S.size y) + + let x' = over (ixF idx_x) twiddle x + y' = (ixF idx_y) %~ twiddle $ y + updX = x & ixF idx_x .~ x' U.! idx_x + updY = y & ixF idx_y .~ y' S.! idx_y + + toListFC Some updX === toListFC Some updY + -- update actually modified the entry + toListFC Some x /== toListFC Some updX + toListFC Some y /== toListFC Some updY + -- update modified the expected entry + toListFC Some x' === toListFC Some updX + toListFC Some y' === toListFC Some updY + +prop_safeEq :: Property +prop_safeEq = property $ + do vals1 <- forAll genSomePayloadList + vals2 <- forAll genSomePayloadList + Some x <- return $ mkSAsgn vals1 + Some y <- return $ mkSAsgn vals2 + case testEquality x y of + Just Refl -> vals1 === vals2 + Nothing -> vals1 /== vals2 + +prop_unsafeEq :: Property +prop_unsafeEq = property $ + do vals1 <- forAll genSomePayloadList + vals2 <- forAll genSomePayloadList + Some x <- return $ mkUAsgn vals1 + Some y <- return $ mkUAsgn vals2 + case testEquality x y of + Just Refl -> vals1 === vals2 + Nothing -> vals1 /== vals2 + +prop_takeNone :: Property +prop_takeNone = property $ + do vals1 <- forAll genSomePayloadList + vals2 <- forAll genSomePayloadList + vals3 <- forAll genSomePayloadList + Some w <- return $ mkUAsgn vals1 + Some x <- return $ mkUAsgn vals2 + Some y <- return $ mkUAsgn vals3 + let z = w U.<++> x U.<++> y + case P.leftId z of + Refl -> let r = C.take U.zeroSize (U.size z) z in + assert $ isJust $ testEquality U.empty r + +prop_dropNone :: Property +prop_dropNone = property $ + do vals1 <- forAll genSomePayloadList + vals2 <- forAll genSomePayloadList + vals3 <- forAll genSomePayloadList + Some w <- return $ mkUAsgn vals1 + Some x <- return $ mkUAsgn vals2 + Some y <- return $ mkUAsgn vals3 + let z = w U.<++> x U.<++> y + case P.leftId z of + Refl -> let r = C.drop U.zeroSize (U.size z) z in + assert $ isJust $ testEquality z r + +prop_takeAll :: Property +prop_takeAll = property $ + do vals1 <- forAll genSomePayloadList + vals2 <- forAll genSomePayloadList + vals3 <- forAll genSomePayloadList + Some w <- return $ mkUAsgn vals1 + Some x <- return $ mkUAsgn vals2 + Some y <- return $ mkUAsgn vals3 + let z = w U.<++> x U.<++> y + let r = C.take (U.size z) U.zeroSize z + assert $ isJust $ testEquality z r + +prop_dropAll :: Property +prop_dropAll = property $ + do vals1 <- forAll genSomePayloadList + vals2 <- forAll genSomePayloadList + vals3 <- forAll genSomePayloadList + Some w <- return $ mkUAsgn vals1 + Some x <- return $ mkUAsgn vals2 + Some y <- return $ mkUAsgn vals3 + let z = w U.<++> x U.<++> y + let r = C.drop (U.size z) U.zeroSize z + assert $ isJust $ testEquality U.empty r + +prop_appendTake :: Property +prop_appendTake = property $ + do vals1 <- forAll genSomePayloadList + vals2 <- forAll genSomePayloadList + Some x <- return $ mkUAsgn vals1 + Some y <- return $ mkUAsgn vals2 + let z = x U.<++> y + let x' = C.take (U.size x) (U.size y) z + assert $ isJust $ testEquality x x' + +prop_appendTakeDrop :: Property +prop_appendTakeDrop = property $ + do vals1 <- forAll genSomePayloadList + vals2 <- forAll genSomePayloadList + Some x <- return $ mkUAsgn vals1 + Some y <- return $ mkUAsgn vals2 + let z = x U.<++> y + let x' = C.take (U.size x) (U.size y) z + let y' = C.drop (U.size x) (U.size y) z + assert $ isJust $ testEquality x x' + assert $ isJust $ testEquality y y' + +prop_appendTakeDropMultiple :: Property +prop_appendTakeDropMultiple = property $ + do vals1 <- forAll genSomePayloadList + vals2 <- forAll genSomePayloadList + vals3 <- forAll genSomePayloadList + vals4 <- forAll genSomePayloadList + vals5 <- forAll genSomePayloadList + Some u <- return $ mkUAsgn vals1 + Some v <- return $ mkUAsgn vals2 + Some w <- return $ mkUAsgn vals3 + Some x <- return $ mkUAsgn vals4 + Some y <- return $ mkUAsgn vals5 + let uv = u U.<++> v + let wxy = w U.<++> x U.<++> y + -- let z = u C.<++> v C.<++> w C.<++> x C.<++> y + let z = uv U.<++> wxy + let uv' = C.take (U.size uv) (U.size wxy) z + let wxy' = C.drop (U.size uv) (U.size wxy) z + let withWXY = C.dropPrefix z uv (error "failed dropPrefix") + assert $ isJust $ testEquality (u U.<++> v) uv' + assert $ isJust $ testEquality (w U.<++> x U.<++> y) wxy' + assert $ isJust $ testEquality uv uv' + assert $ isJust $ testEquality wxy wxy' + withWXY $ \t -> assert $ isJust $ testEquality wxy' t + +prop_zipUnzip :: Property +prop_zipUnzip = property $ + do Some x <- mkUAsgn <$> forAll genSomePayloadList + let zipped = C.zipWith Pair x x + let (x', x'') = C.unzip zipped + assert $ isJust $ testEquality x x' + assert $ isJust $ testEquality x x'' + +prop_fmapFCIdentity :: Property +prop_fmapFCIdentity = property $ + do Some x <- mkUAsgn <$> forAll genSomePayloadList + assert $ isJust $ testEquality x (fmapFC id x) + +prop_fmapFCAssoc :: Property +prop_fmapFCAssoc = property $ + do Some x <- mkUAsgn <$> forAll genSomePayloadList + Fun f <- forAll $ HG.element funs + Fun g <- forAll $ HG.element funs + assert $ isJust $ testEquality + (fmapFC g (fmapFC f x)) + (fmapFC (g . f) x) + +prop_imapFCIndexNoop :: Property +prop_imapFCIndexNoop = property $ + do Some x <- mkUAsgn <$> forAll genSomePayloadList + assert $ + isJust $ + testEquality x (imapFC (\idx _ -> x U.! idx) x) + +prop_imapFCFmapFC :: Property +prop_imapFCFmapFC = property $ + do Some x <- mkUAsgn <$> forAll genSomePayloadList + Fun f <- forAll $ HG.element funs + assert $ isJust $ testEquality + (fmapFC f x) + (imapFC (const f) x) + +prop_ifoldMapFCFoldMapFC :: Property +prop_ifoldMapFCFoldMapFC = property $ + do Some x <- mkUAsgn <$> forAll genSomePayloadList + assert $ foldMapFC show x == ifoldMapFC (const show) x + +prop_itraverseFCTraverseFC :: Property +prop_itraverseFCTraverseFC = property $ + do Some x <- mkUAsgn <$> forAll genSomePayloadList + Fun f <- forAll $ HG.element funs + let f' :: forall a. Payload a -> Identity (Payload a) + f' = Identity . f + assert $ isJust $ testEquality + (runIdentity (traverseFC f' x)) + (runIdentity (itraverseFC (const f') x)) + +---------------------------------------------------------------------- + +contextTests :: IO TestTree +contextTests = testGroup "Context" <$> return + [ testPropertyNamed "size (unsafe)" "prop_sizeUnsafe" prop_sizeUnsafe + , testPropertyNamed "size (safe)" "prop_sizeSafe" prop_sizeSafe + + , testPropertyNamed "safe_index_eq" "prop_safeIndexEq" prop_safeIndexEq + + , testPropertyNamed "unsafe_index_eq" "prop_unsafeIndexEq" prop_unsafeIndexEq + + , testPropertyNamed "safe_tolist" "prop_safeToList" prop_safeToList + , testPropertyNamed "unsafe_tolist" "prop_unsafeToList" prop_unsafeToList + + , testPropertyNamed "adjust test monadic" "prop_adjustTestMonadic" prop_adjustTestMonadic + + , testPropertyNamed "adjust test" "prop_adjustTest" prop_adjustTest + + , testPropertyNamed "update test" "prop_updateTest" prop_updateTest + + , testPropertyNamed "safe_eq" "prop_safeEq" prop_safeEq + , testPropertyNamed "unsafe_eq" "prop_unsafeEq" prop_unsafeEq + + , testPropertyNamed "take none" "prop_takeNone" prop_takeNone + , testPropertyNamed "drop none" "prop_dropNone" prop_dropNone + + , testPropertyNamed "take all" "prop_takeAll" prop_takeAll + , testPropertyNamed "drop all" "prop_dropAll" prop_dropAll + + , testPropertyNamed "append_take" "prop_appendTake" prop_appendTake + + , testPropertyNamed "append_take_drop" "prop_appendTakeDrop" prop_appendTakeDrop + + , testPropertyNamed "append_take_drop_multiple" "prop_appendTakeDropMultiple" prop_appendTakeDropMultiple + + , testPropertyNamed "zip/unzip" "prop_zipUnzip" prop_zipUnzip + + , testPropertyNamed "fmapFC_identity" "prop_fmapFCIdentity" prop_fmapFCIdentity + + , testPropertyNamed "fmapFC_assoc" "prop_fmapFCAssoc" prop_fmapFCAssoc + + , testPropertyNamed "imapFC_index_noop" "prop_imapFCIndexNoop" prop_imapFCIndexNoop + + , testPropertyNamed "imapFC/fmapFC" "prop_imapFCFmapFC" prop_imapFCFmapFC + + , testPropertyNamed "ifoldMapFC/foldMapFC" "prop_ifoldMapFCFoldMapFC" prop_ifoldMapFCFoldMapFC + + , testPropertyNamed "itraverseFC/traverseFC" "prop_itraverseFCTraverseFC" prop_itraverseFCTraverseFC + + , testCaseSteps "explicit indexing (unsafe)" $ \step -> do + let mkUPayload :: U.Assignment Payload TestCtx + mkUPayload = U.empty + `U.extend` IntPayload 1 + `U.extend` StringPayload "two" + `U.extend` IntPayload 3 + `U.extend` BoolPayload True + + -- Alternative construction using the 'generate' and a + -- function consuming @Index ctx tp@ selectors to return + -- the corresponding value + mkUMyMaybe :: U.Assignment MyMaybe TestCtx + mkUMyMaybe = U.generate U.knownSize setMyValue + setMyValue :: U.Index TestCtx tp -> MyMaybe tp + setMyValue idx + | Just Refl <- testEquality (U.lastIndex U.knownSize) idx + = MyJust False + | Just Refl <- testEquality (U.skipIndex $ U.skipIndex $ U.skipIndex U.baseIndex) idx + = MyJust 10 + | Just Refl <- testEquality (U.skipIndex $ U.skipIndex $ U.nextIndex U.knownSize) idx + = MyJust "twenty" + | Just Refl <- testEquality (U.skipIndex $ U.nextIndex U.knownSize) idx + = MyNothing + | otherwise = error $ "setMyValue with unrecognized Index " <> show idx + + step "Verify size of Assignment" + U.sizeInt (U.size mkUPayload) @?= 4 + + step "Verify show of Assignment" + "[1 :: Int, \"two\" :: String, 3 :: Int, True :: Bool]" @=? show mkUPayload + "[MyJust 10, MyJust \"twenty\", MyNothing, MyJust False]" @=? show mkUMyMaybe + + step "Verify show explicit indexing" + Just "\"two\" :: String" @=? + do Some i <- U.intIndex 1 (U.size mkUPayload) + return $ show $ mkUPayload U.! i + Just "1 :: Int" @=? + do Some i <- U.intIndex 0 (U.size mkUPayload) + return $ show $ mkUPayload U.! i + "#<; @0=1 :: Int; @1=\"two\" :: String; @2=3 :: Int; @3=True :: Bool" @=? + U.forIndex U.knownSize + (\s idx -> s <> "; @" <> show idx <> "=" <> + show (mkUPayload U.! idx)) + "#<" + (Nothing @String) @=? + do Some i <- U.intIndex 8 (U.size mkUPayload) + return $ show $ mkUPayload U.! i + + step "Verify invalid type at index" + (Nothing :: Maybe Bool) @=? + do Some i <- U.intIndex 1 (U.size mkUPayload) + Refl <- testEquality (mkUPayload U.! i) (IntPayload 1) + return True + + , testCaseSteps "explicit indexing (safe)" $ \step -> do + let mkSPayload :: S.Assignment Payload TestCtx + mkSPayload = S.empty + `S.extend` IntPayload 1 + `S.extend` StringPayload "two" + `S.extend` IntPayload 3 + `S.extend` BoolPayload True + + -- Alternative construction using the 'generate' and a + -- function consuming @Index ctx tp@ selectors to return + -- the corresponding value + mkSMyMaybe :: S.Assignment MyMaybe TestCtx + mkSMyMaybe = S.generate S.knownSize setMyValue + setMyValue :: S.Index TestCtx tp -> MyMaybe tp + setMyValue idx + | Just Refl <- testEquality (S.lastIndex S.knownSize) idx + = MyJust False + | Just Refl <- testEquality (S.skipIndex $ S.skipIndex $ S.skipIndex S.baseIndex) idx + = MyJust 10 + | Just Refl <- testEquality (S.skipIndex $ S.skipIndex $ S.nextIndex S.knownSize) idx + = MyJust "twenty" + | Just Refl <- testEquality (S.skipIndex $ S.nextIndex S.knownSize) idx + = MyNothing + | otherwise = error $ "setMyValue with unrecognized Index " <> show idx + + step "Verify size of Assignment" + S.sizeInt (S.size mkSPayload) @?= 4 + + step "Verify show of Assignment" + "[1 :: Int, \"two\" :: String, 3 :: Int, True :: Bool]" @=? show mkSPayload + "[MyJust 10, MyJust \"twenty\", MyNothing, MyJust False]" @=? show mkSMyMaybe + + step "Verify show explicit indexing" + Just "\"two\" :: String" @=? + do Some i <- S.intIndex 1 (S.size mkSPayload) + return $ show $ mkSPayload S.! i + Just "1 :: Int" @=? + do Some i <- S.intIndex 0 (S.size mkSPayload) + return $ show $ mkSPayload S.! i + "#<; @3=True :: Bool; @2=3 :: Int; @1=\"two\" :: String; @0=1 :: Int" @=? + S.forIndex S.knownSize + (\s idx -> s <> "; @" <> show idx <> "=" <> + show (mkSPayload S.! idx)) + "#<" + (Nothing @String) @=? + do Some i <- S.intIndex 8 (S.size mkSPayload) + return $ show $ mkSPayload S.! i + + step "Verify invalid type at index" + (Nothing :: Maybe Bool) @=? + do Some i <- S.intIndex 1 (S.size mkSPayload) + Refl <- testEquality (mkSPayload S.! i) (IntPayload 1) + return True + + , testCaseSteps "joined Assigment operations (unsafe)" $ \step -> do + let mkU1 = U.empty + `U.extend` IntPayload 1 + mkU2 = U.empty + `U.extend` StringPayload "two" + `U.extend` IntPayload 3 + `U.extend` BoolPayload True + + step "Length" + U.sizeInt (U.size mkU1) + U.sizeInt (U.size mkU2) @?= + U.sizeInt (U.size (mkU1 U.<++> mkU2)) + + step "Index adjustments" + Just (Some i1) <- return $ U.intIndex 0 (U.size mkU1) + v1s <- return $ show $ mkU1 U.! i1 + "1 :: Int" @=? v1s + Just (Some i2) <- return $ U.intIndex 2 (U.size mkU2) + v2s <- return $ show $ mkU2 U.! i2 + "True :: Bool" @=? v2s + let mkUB = mkU1 U.<++> mkU2 + v1s' <- return $ show $ mkUB U.! (U.leftIndex (U.size mkU2) i1) + v1s' @?= v1s + v2s' <- return $ show $ mkUB U.! (U.rightIndex (U.size mkU1) (U.size mkU2) i2) + v2s' @?= v2s + + , testCaseSteps "joined Assigment operations (safe)" $ \step -> do + let mkS1 = S.empty + `S.extend` IntPayload 1 + mkS2 = S.empty + `S.extend` StringPayload "two" + `S.extend` IntPayload 3 + `S.extend` BoolPayload True + + step "Length" + S.sizeInt (S.size mkS1) + S.sizeInt (S.size mkS2) @?= + S.sizeInt (S.size (mkS1 S.<++> mkS2)) + + step "Index adjustments" + Just (Some i1) <- return $ S.intIndex 0 (S.size mkS1) + v1s <- return $ show $ mkS1 S.! i1 + "1 :: Int" @=? v1s + Just (Some i2) <- return $ S.intIndex 2 (S.size mkS2) + v2s <- return $ show $ mkS2 S.! i2 + "True :: Bool" @=? v2s + let mkSB = mkS1 S.<++> mkS2 + v1s' <- return $ show $ mkSB S.! (S.leftIndex (S.size mkS2) i1) + v1s' @?= v1s + v2s' <- return $ show $ mkSB S.! (S.rightIndex (S.size mkS1) (S.size mkS2) i2) + v2s' @?= v2s + + ] diff --git a/test/Test/Fin.hs b/test/Test/Fin.hs new file mode 100644 index 0000000..2ba59f1 --- /dev/null +++ b/test/Test/Fin.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# Language CPP #-} + +module Test.Fin + ( finTests + , genFin + ) +where + +import Numeric.Natural (Natural) + +import Hedgehog +import qualified Hedgehog.Gen as HG +import Hedgehog.Range (linear) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testPropertyNamed) +import Test.Tasty.HUnit (assertBool, testCase) + +import Data.Parameterized.NatRepr +import Data.Parameterized.Fin +import Data.Parameterized.Some (Some(Some)) + +#if __GLASGOW_HASKELL__ >= 806 +import qualified Hedgehog.Classes as HC +#endif + +genNatRepr :: (Monad m) => Natural -> GenT m (Some NatRepr) +genNatRepr bound = + do x0 <- HG.integral (linear 0 bound) + return (mkNatRepr x0) + +genFin :: (1 <= n, Monad m) => NatRepr n -> GenT m (Fin n) +genFin n = + do Some x <- genNatRepr (natValue n - 1 :: Natural) + return $ + case testLeq (incNat x) n of + Just LeqProof -> mkFin x + Nothing -> error "Impossible" + +prop_count_true :: Property +prop_count_true = property $ + do Some n <- forAll (genNatRepr 100) + finToNat (countFin n (\_ _ -> True)) === natValue n + +prop_count_false :: Property +prop_count_false = property $ + do Some n <- forAll (genNatRepr 100) + finToNat (countFin n (\_ _ -> False)) === 0 + +finTests :: IO TestTree +finTests = + testGroup "Fin" <$> + return + [ testCase "minBound <= maxBound (1)" $ + assertBool + "minBound <= maxBound (1)" + ((minBound :: Fin 1) <= (minBound :: Fin 1)) + , testCase "minBound <= maxBound (2)" $ + assertBool + "minBound <= maxBound (2)" + ((minBound :: Fin 2) <= (minBound :: Fin 2)) + + , testPropertyNamed "count-true" "prop_count_true" prop_count_true + , testPropertyNamed "count-false" "prop_count_false" prop_count_false + +#if __GLASGOW_HASKELL__ >= 806 + , testCase "Eq-Fin-laws-1" $ + assertBool "Eq-Fin-laws-1" =<< + HC.lawsCheck (HC.eqLaws (genFin (knownNat @1))) + + , testCase "Ord-Fin-laws-1" $ + assertBool "Ord-Fin-laws-1" =<< + HC.lawsCheck (HC.ordLaws (genFin (knownNat @1))) + + , testCase "Eq-Fin-laws-10" $ + assertBool "Eq-Fin-laws-10" =<< + HC.lawsCheck (HC.eqLaws (genFin (knownNat @10))) + + , testCase "Ord-Fin-laws-10" $ + assertBool "Ord-Fin-laws-10" =<< + HC.lawsCheck (HC.ordLaws (genFin (knownNat @10))) +#endif + ] diff --git a/test/Test/FinMap.hs b/test/Test/FinMap.hs new file mode 100644 index 0000000..94d2aec --- /dev/null +++ b/test/Test/FinMap.hs @@ -0,0 +1,393 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + + +module Test.FinMap (finMapTests) where + +import Control.Monad (foldM) +import Data.Foldable.WithIndex (itoList) +import Data.Functor.WithIndex (FunctorWithIndex(imap)) +import Data.Foldable.WithIndex (FoldableWithIndex(ifoldMap)) +import Data.Proxy (Proxy(Proxy)) +import Data.Type.Equality ((:~:)(Refl)) + +import Data.Parameterized.Fin (Fin) +import qualified Data.Parameterized.Fin as Fin +import Data.Parameterized.NatRepr (LeqProof, NatRepr, type (<=), type (+)) +import qualified Data.Parameterized.NatRepr as NatRepr + +import Hedgehog +import qualified Hedgehog.Gen as HG +import Hedgehog.Range (linear) +import Test.Tasty +import Test.Tasty.Hedgehog + +#if __GLASGOW_HASKELL__ >= 806 +import Test.Tasty.HUnit (assertBool, testCase) +import qualified Hedgehog.Classes as HC +#endif + +import qualified Data.Parameterized.FinMap.Safe as S +import qualified Data.Parameterized.FinMap.Unsafe as U +import qualified Data.Parameterized.Vector as Vec + +import Test.Fin (genFin) +import Test.Vector (SomeVector(..), genSomeVector, genVectorOfLength, genOrdering, orderingEndomorphisms, orderingToStringFuns) + +data SomeSafeFinMap a = forall n. SomeSafeFinMap (NatRepr n) (S.FinMap n a) +data SomeUnsafeFinMap a = forall n. SomeUnsafeFinMap (NatRepr n) (U.FinMap n a) + +instance Show a => Show (SomeSafeFinMap a) where + show (SomeSafeFinMap _ v) = show v +instance Show a => Show (SomeUnsafeFinMap a) where + show (SomeUnsafeFinMap _ v) = show v + +genSafeFinMap :: (Monad m) => NatRepr n -> GenT m a -> GenT m (S.FinMap (n + 1) a) +genSafeFinMap n genElem = S.fromVector <$> genVectorOfLength n (HG.maybe genElem) + +genUnsafeFinMap :: (Monad m) => NatRepr n -> GenT m a -> GenT m (U.FinMap (n + 1) a) +genUnsafeFinMap n genElem = U.fromVector <$> genVectorOfLength n (HG.maybe genElem) + +genSomeSafeFinMap :: (Monad m) => GenT m a -> GenT m (SomeSafeFinMap a) +genSomeSafeFinMap genElem = + do SomeVector v <- genSomeVector (HG.maybe genElem) + return (SomeSafeFinMap (Vec.length v) (S.fromVector v)) + +genSomeUnsafeFinMap :: (Monad m) => GenT m a -> GenT m (SomeUnsafeFinMap a) +genSomeUnsafeFinMap genElem = + do SomeVector v <- genSomeVector (HG.maybe genElem) + return (SomeUnsafeFinMap (Vec.length v) (U.fromVector v)) + +prop_incMax_size_safe :: Property +prop_incMax_size_safe = property $ + do SomeSafeFinMap _ fm <- forAll $ genSomeSafeFinMap genOrdering + Fin.finToNat (S.size (S.incMax fm)) === Fin.finToNat (S.size fm) + +prop_incMax_size_unsafe :: Property +prop_incMax_size_unsafe = property $ + do SomeUnsafeFinMap _ fm <- forAll $ genSomeUnsafeFinMap genOrdering + Fin.finToNat (U.size (U.incMax fm)) === Fin.finToNat (U.size fm) + +prop_imap_const_safe :: Property +prop_imap_const_safe = property $ + do f <- forAll (HG.element orderingEndomorphisms) + SomeSafeFinMap _ fm <- forAll (genSomeSafeFinMap genOrdering) + imap (const f) fm === fmap f fm + +prop_imap_const_unsafe :: Property +prop_imap_const_unsafe = property $ + do f <- forAll (HG.element orderingEndomorphisms) + SomeUnsafeFinMap _ fm <- forAll (genSomeUnsafeFinMap genOrdering) + imap (const f) fm === fmap f fm + +prop_ifoldMap_const_safe :: Property +prop_ifoldMap_const_safe = property $ + do f <- forAll (HG.element orderingToStringFuns) + SomeSafeFinMap _ fm <- forAll (genSomeSafeFinMap genOrdering) + ifoldMap (const f) fm === foldMap f fm + +prop_ifoldMap_const_unsafe :: Property +prop_ifoldMap_const_unsafe = property $ + do f <- forAll (HG.element orderingToStringFuns) + SomeUnsafeFinMap _ fm <- forAll (genSomeUnsafeFinMap genOrdering) + ifoldMap (const f) fm === foldMap f fm + +cancelPlusOne :: + forall f g i n. + f i -> + g n -> + LeqProof (i + 1) (n + 1) -> + LeqProof i n +cancelPlusOne i n NatRepr.LeqProof = + case NatRepr.plusMinusCancel n (NatRepr.knownNat :: NatRepr 1) of + Refl -> + case NatRepr.plusMinusCancel i (NatRepr.knownNat :: NatRepr 1) of + Refl -> + case NatRepr.leqSub2 + (NatRepr.LeqProof :: LeqProof (i + 1) (n + 1)) + (NatRepr.LeqProof :: LeqProof 1 1) of + NatRepr.LeqProof -> NatRepr.LeqProof + +withIndexSafe :: + SomeSafeFinMap a -> + (forall n. Fin n -> S.FinMap n a -> PropertyT IO ()) -> + PropertyT IO () +withIndexSafe (SomeSafeFinMap n fm) k = + case NatRepr.isZeroOrGT1 n of + Left Refl -> k Fin.minFin (S.incMax fm) + Right NatRepr.LeqProof -> + do idx <- forAll (genFin n) + k idx fm + +withIndexUnsafe :: + SomeUnsafeFinMap a -> + (forall n. Fin n -> U.FinMap n a -> PropertyT IO ()) -> + PropertyT IO () +withIndexUnsafe (SomeUnsafeFinMap n fm) k = + case NatRepr.isZeroOrGT1 n of + Left Refl -> k Fin.minFin (U.incMax fm) + Right NatRepr.LeqProof -> + do idx <- forAll (genFin n) + k idx fm + +withSizeUnsafe :: + U.FinMap n a -> + (forall i. (i + 1 <= n + 1, i <= n) => NatRepr i -> r) -> + r +withSizeUnsafe fm k = + case U.size fm of + (sz :: Fin (n + 1)) -> + Fin.viewFin + (\(i :: NatRepr i) -> + case cancelPlusOne i (Proxy :: Proxy n) NatRepr.LeqProof of + NatRepr.LeqProof -> k i) + sz + +prop_insert_size_safe :: Property +prop_insert_size_safe = property $ + do sfm <- forAll $ genSomeSafeFinMap genOrdering + withIndexSafe sfm $ \idx fm -> do + o <- forAll genOrdering + let size = Fin.finToNat (S.size fm) + let newSize = Fin.finToNat (S.size (S.insert (Fin.embed idx) o fm)) + assert (size == newSize || size + 1 == newSize) + +prop_insert_size_unsafe :: Property +prop_insert_size_unsafe = property $ + do sfm <- forAll $ genSomeUnsafeFinMap genOrdering + withIndexUnsafe sfm $ \idx fm -> do + o <- forAll genOrdering + let size = Fin.finToNat (U.size fm) + let newSize = Fin.finToNat (U.size (U.insert (Fin.embed idx) o fm)) + assert (size == newSize || size + 1 == newSize) + +prop_insert_delete_safe :: Property +prop_insert_delete_safe = property $ + do sfm <- forAll $ genSomeSafeFinMap genOrdering + withIndexSafe sfm $ \idx fm -> do + o <- forAll genOrdering + S.delete idx (S.insert idx o fm) === S.delete idx fm + +prop_insert_delete_unsafe :: Property +prop_insert_delete_unsafe = property $ + do sfm <- forAll $ genSomeUnsafeFinMap genOrdering + withIndexUnsafe sfm $ \idx fm -> do + o <- forAll genOrdering + U.delete idx (U.insert idx o fm) === U.delete idx fm + +prop_delete_insert_safe :: Property +prop_delete_insert_safe = property $ + do sfm <- forAll $ genSomeSafeFinMap genOrdering + withIndexSafe sfm $ \idx fm -> do + o <- forAll genOrdering + S.insert idx o (S.delete idx fm) === S.insert idx o fm + +prop_delete_insert_unsafe :: Property +prop_delete_insert_unsafe = property $ + do sfm <- forAll $ genSomeUnsafeFinMap genOrdering + withIndexUnsafe sfm $ \idx fm -> do + o <- forAll genOrdering + U.insert idx o (U.delete idx fm) === U.insert idx o fm + +prop_empty_insert_safe :: Property +prop_empty_insert_safe = property $ + do withIndexSafe (SomeSafeFinMap (NatRepr.knownNat @0) S.empty) $ \idx fm -> do + o <- forAll genOrdering + fm /== S.insert idx o fm + +prop_empty_insert_unsafe :: Property +prop_empty_insert_unsafe = property $ + do withIndexUnsafe (SomeUnsafeFinMap (NatRepr.knownNat @0) U.empty) $ \idx fm -> do + o <- forAll genOrdering + fm /== U.insert idx o fm + +prop_insert_insert_safe :: Property +prop_insert_insert_safe = property $ + do sfm <- forAll $ genSomeSafeFinMap genOrdering + withIndexSafe sfm $ \idx fm -> do + o <- forAll genOrdering + S.insert idx o (S.insert idx o fm) === S.insert idx o fm + +prop_insert_insert_unsafe :: Property +prop_insert_insert_unsafe = property $ + do sfm <- forAll $ genSomeUnsafeFinMap genOrdering + withIndexUnsafe sfm $ \idx fm -> do + o <- forAll genOrdering + U.insert idx o (U.insert idx o fm) === U.insert idx o fm + +prop_delete_delete_safe :: Property +prop_delete_delete_safe = property $ + do sfm <- forAll $ genSomeSafeFinMap genOrdering + withIndexSafe sfm $ \idx fm -> do + S.delete idx (S.delete idx fm) === S.delete idx fm + +prop_delete_delete_unsafe :: Property +prop_delete_delete_unsafe = property $ + do sfm <- forAll $ genSomeUnsafeFinMap genOrdering + withIndexUnsafe sfm $ \idx fm -> do + U.delete idx (U.delete idx fm) === U.delete idx fm + +-- | Type used for comparative API tests +data MatchedMaps a = + forall n. + MatchedMaps + { _unsafe :: U.FinMap n a + , _safe :: S.FinMap n a + } + +operations :: + Show a => + Gen a -> + -- | For testing 'fmap'. + [a -> a] -> + [MatchedMaps a -> PropertyT IO (MatchedMaps a)] +operations genValue valEndomorphisms = + [ \(MatchedMaps u s) -> + withSizeUnsafe u $ \sz -> do + case NatRepr.isZeroOrGT1 sz of + Left Refl -> + do v <- forAll genValue + return $ + MatchedMaps + (U.insert Fin.minFin v (U.incMax u)) + (S.insert Fin.minFin v (S.incMax s)) + Right NatRepr.LeqProof -> + do idx <- Fin.embed <$> forAll (genFin sz) + v <- forAll genValue + return (MatchedMaps (U.insert idx v u) (S.insert idx v s)) + , \(MatchedMaps u s) -> + withSizeUnsafe u $ \sz -> do + case NatRepr.isZeroOrGT1 sz of + Left Refl -> return (MatchedMaps u s) + Right NatRepr.LeqProof -> + do idx <- Fin.embed <$> forAll (genFin sz) + return (MatchedMaps (U.delete idx u) (S.delete idx s)) + , \(MatchedMaps u s) -> + return (MatchedMaps (U.incMax u) (S.incMax s)) + , \(MatchedMaps u s) -> + do f <- forAll (HG.element (id:valEndomorphisms)) + return (MatchedMaps (fmap f u) (fmap f s)) + , \(MatchedMaps u s) -> + do f <- forAll (HG.element (id:valEndomorphisms)) + return (MatchedMaps (imap (const f) u) (imap (const f) s)) + , \(MatchedMaps _ _) -> + do v <- forAll genValue + return (MatchedMaps (U.singleton v) (S.singleton v)) + , \(MatchedMaps _ _) -> + return (MatchedMaps (U.empty @0) S.empty) + , \(MatchedMaps _ _) -> + return (MatchedMaps (U.empty @8) S.empty) + ] + +-- | Possibly the most important and far-reaching test: The unsafe API should +-- yield the same results as the safe API, after some randomized sequence of +-- operations. +prop_safe_unsafe :: Property +prop_safe_unsafe = property $ + do numOps <- forAll (HG.integral (linear 0 (99 :: Int))) + let empty = MatchedMaps (U.empty @0) S.empty + MatchedMaps u s <- + doTimes (chooseAndApply orderingOps) numOps empty + itoList u === itoList s + where + orderingOps = operations genOrdering orderingEndomorphisms + + chooseAndApply :: [a -> PropertyT IO b] -> a -> PropertyT IO b + chooseAndApply funs arg = + do f <- forAll (HG.element funs) + f arg + + doTimes f n m = foldM (\accum () -> f accum) m (replicate n ()) + + +finMapTests :: IO TestTree +finMapTests = testGroup "FinMap" <$> return + [ testPropertyNamed "incSize-decSize-safe" "prop_incMax_size_safe" prop_incMax_size_safe + , testPropertyNamed "incSize-decSize-unsafe" "prop_incMax_size_unsafe" prop_incMax_size_unsafe + , testPropertyNamed "insert-size-safe" "prop_insert_size_safe" prop_insert_size_safe + , testPropertyNamed "insert-size-unsafe" "prop_insert_size_unsafe" prop_insert_size_unsafe + , testPropertyNamed "insert-delete-safe" "prop_insert_delete_safe" prop_insert_delete_safe + , testPropertyNamed "insert-delete-unsafe" "prop_insert_delete_unsafe" prop_insert_delete_unsafe + , testPropertyNamed "delete-insert-safe" "prop_delete_insert_safe" prop_delete_insert_safe + , testPropertyNamed "delete-insert-unsafe" "prop_delete_insert_unsafe" prop_delete_insert_unsafe + , testPropertyNamed "empty-insert-safe" "prop_empty_insert_safe" prop_empty_insert_safe + , testPropertyNamed "empty-insert-unsafe" "prop_empty_insert_unsafe" prop_empty_insert_unsafe + , testPropertyNamed "insert-insert-safe" "prop_insert_insert_safe" prop_insert_insert_safe + , testPropertyNamed "insert-insert-unsafe" "prop_insert_insert_unsafe" prop_insert_insert_unsafe + , testPropertyNamed "delete-delete-safe" "prop_delete_delete_safe" prop_delete_delete_safe + , testPropertyNamed "delete-delete-unsafe" "prop_delete_delete_unsafe" prop_delete_delete_unsafe + , testPropertyNamed "imap-const-safe" "prop_imap_const_safe" prop_imap_const_safe + , testPropertyNamed "imap-const-unsafe" "prop_imap_const_unsafe" prop_imap_const_unsafe + , testPropertyNamed "ifoldMap-const-safe" "prop_ifoldMap_const_safe" prop_ifoldMap_const_safe + , testPropertyNamed "ifoldMap-const-unsafe" "prop_ifoldMap_const_unsafe" prop_ifoldMap_const_unsafe + , testPropertyNamed "safe-unsafe" "prop_safe_unsafe" prop_safe_unsafe + +#if __GLASGOW_HASKELL__ >= 806 + , testCase "Eq-Safe-FinMap-laws-1" $ + assertBool "Eq-Safe-FinMap-laws-1" =<< + HC.lawsCheck (HC.eqLaws (genSafeFinMap (NatRepr.knownNat @1) genOrdering)) + , testCase "Eq-Unsafe-FinMap-laws-1" $ + assertBool "Eq-Unsafe-FinMap-laws-1" =<< + HC.lawsCheck (HC.eqLaws (genUnsafeFinMap (NatRepr.knownNat @1) genOrdering)) + , testCase "Eq-Safe-FinMap-laws-10" $ + assertBool "Eq-Safe-FinMap-laws-10" =<< + HC.lawsCheck (HC.eqLaws (genSafeFinMap (NatRepr.knownNat @10) genOrdering)) + , testCase "Eq-Unsafe-FinMap-laws-10" $ + assertBool "Eq-Unsafe-FinMap-laws-10" =<< + HC.lawsCheck (HC.eqLaws (genUnsafeFinMap (NatRepr.knownNat @10) genOrdering)) + , testCase "Semigroup-Safe-FinMap-laws-1" $ + assertBool "Semigroup-Safe-FinMap-laws-1" =<< + HC.lawsCheck (HC.semigroupLaws (genSafeFinMap (NatRepr.knownNat @1) genOrdering)) + , testCase "Semigroup-Unsafe-FinMap-laws-1" $ + assertBool "Semigroup-Unsafe-FinMap-laws-1" =<< + HC.lawsCheck (HC.semigroupLaws (genUnsafeFinMap (NatRepr.knownNat @1) genOrdering)) + , testCase "Semigroup-Safe-FinMap-laws-10" $ + assertBool "Semigroup-Safe-FinMap-laws-10" =<< + HC.lawsCheck (HC.semigroupLaws (genSafeFinMap (NatRepr.knownNat @10) genOrdering)) + , testCase "Semigroup-Unsafe-FinMap-laws-10" $ + assertBool "Semigroup-Unsafe-FinMap-laws-10" =<< + HC.lawsCheck (HC.semigroupLaws (genUnsafeFinMap (NatRepr.knownNat @10) genOrdering)) + , testCase "Monoid-Safe-FinMap-laws-1" $ + assertBool "Monoid-Safe-FinMap-laws-1" =<< + HC.lawsCheck (HC.monoidLaws (genSafeFinMap (NatRepr.knownNat @1) genOrdering)) + , testCase "Monoid-Unsafe-FinMap-laws-1" $ + assertBool "Monoid-Unsafe-FinMap-laws-1" =<< + HC.lawsCheck (HC.monoidLaws (genUnsafeFinMap (NatRepr.knownNat @1) genOrdering)) + , testCase "Monoid-Safe-FinMap-laws-10" $ + assertBool "Monoid-Safe-FinMap-laws-10" =<< + HC.lawsCheck (HC.monoidLaws (genSafeFinMap (NatRepr.knownNat @10) genOrdering)) + , testCase "Monoid-Unsafe-FinMap-laws-10" $ + assertBool "Monoid-Unsafe-FinMap-laws-10" =<< + HC.lawsCheck (HC.monoidLaws (genUnsafeFinMap (NatRepr.knownNat @10) genOrdering)) + , testCase "Foldable-Safe-FinMap-laws-1" $ + assertBool "Foldable-Safe-FinMap-laws-1" =<< + HC.lawsCheck (HC.foldableLaws (genSafeFinMap (NatRepr.knownNat @1))) + , testCase "Foldable-Unsafe-FinMap-laws-1" $ + assertBool "Foldable-Unsafe-FinMap-laws-1" =<< + HC.lawsCheck (HC.foldableLaws (genUnsafeFinMap (NatRepr.knownNat @1))) + , testCase "Foldable-Safe-FinMap-laws-10" $ + assertBool "Foldable-Safe-FinMap-laws-10" =<< + HC.lawsCheck (HC.foldableLaws (genSafeFinMap (NatRepr.knownNat @10))) + , testCase "Foldable-Unsafe-FinMap-laws-10" $ + assertBool "Foldable-Unsafe-FinMap-laws-10" =<< + HC.lawsCheck (HC.foldableLaws (genUnsafeFinMap (NatRepr.knownNat @10))) + , testCase "Traversable-Safe-FinMap-laws-1" $ + assertBool "Traversable-Safe-FinMap-laws-1" =<< + HC.lawsCheck (HC.traversableLaws (genSafeFinMap (NatRepr.knownNat @1))) + , testCase "Traversable-Unsafe-FinMap-laws-1" $ + assertBool "Traversable-Unsafe-FinMap-laws-1" =<< + HC.lawsCheck (HC.traversableLaws (genUnsafeFinMap (NatRepr.knownNat @1))) + , testCase "Traversable-Safe-FinMap-laws-10" $ + assertBool "Traversable-Safe-FinMap-laws-10" =<< + HC.lawsCheck (HC.traversableLaws (genSafeFinMap (NatRepr.knownNat @10))) + , testCase "Traversable-Unsafe-FinMap-laws-10" $ + assertBool "Traversable-Unsafe-FinMap-laws-10" =<< + HC.lawsCheck (HC.traversableLaws (genUnsafeFinMap (NatRepr.knownNat @10))) +#endif + ] diff --git a/test/Test/List.hs b/test/Test/List.hs new file mode 100644 index 0000000..fc42027 --- /dev/null +++ b/test/Test/List.hs @@ -0,0 +1,29 @@ +module Test.List + ( tests + ) where + +import Control.Monad.Identity +import Data.Functor.Const +import qualified Data.Parameterized.List as PL +import Data.Parameterized.Some +import Test.Tasty +import Test.Tasty.HUnit + +-- | Test ifoldlM indexing is correct by summing a list using it. +testIfoldlMSum :: [Integer] -> TestTree +testIfoldlMSum l = + testCase ("ifoldlMSum " ++ show l) $ + case PL.fromListWith (Some . Const) l of + Some pl -> + let expected = sum l + actual = PL.ifoldlM (\r i v -> Identity $ r + if pl PL.!! i == v then getConst v else 0) 0 pl + in expected @?= runIdentity actual + + +tests :: TestTree +tests = testGroup "List" + [ testIfoldlMSum [] + , testIfoldlMSum [1] + , testIfoldlMSum [1,2] + , testIfoldlMSum [1,2,3] + ] \ No newline at end of file diff --git a/test/Test/NatRepr.hs b/test/Test/NatRepr.hs new file mode 100644 index 0000000..01eb360 --- /dev/null +++ b/test/Test/NatRepr.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} +module Test.NatRepr + ( natTests + ) +where + +import Hedgehog +import qualified Hedgehog.Gen as HG +import Hedgehog.Range +import Test.Tasty +import Test.Tasty.Hedgehog + +import Data.Parameterized.NatRepr +import Data.Parameterized.Some +import GHC.TypeLits (natVal) + +prop_withKnownNat :: Property +prop_withKnownNat = property $ + do nInt <- forAll $ HG.int (linearBounded :: Range Int) + case someNat nInt of + Nothing -> diff nInt (<) 0 + Just (Some r) -> nInt === withKnownNat r (fromEnum $ natVal r) + +natTests :: IO TestTree +natTests = testGroup "Nat" <$> return + [ testPropertyNamed "withKnownNat" "prop_withKnownNat" prop_withKnownNat + ] diff --git a/test/Test/Some.hs b/test/Test/Some.hs new file mode 100644 index 0000000..8b92e46 --- /dev/null +++ b/test/Test/Some.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} + +module Test.Some + ( someTests + ) +where + +import Data.Type.Equality (TestEquality(testEquality), (:~:)(Refl)) +import Control.Lens (Lens', lens, view, set) + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertEqual, testCase) + +import Data.Parameterized.Classes (ShowF) +import Data.Parameterized.Some (Some(Some), someLens) + +data Item b where + BoolItem :: Item Bool + IntItem :: Item Int + +instance Show (Item b) where + show = + \case + BoolItem -> "BoolItem" + IntItem -> "IntItem" + +instance TestEquality Item where + testEquality x y = + case (x, y) of + (BoolItem, BoolItem) -> Just Refl + (IntItem, IntItem) -> Just Refl + _ -> Nothing + +data Pair a b = + Pair + { _fir :: a + , _sec :: Item b + } + +-- This instance isn't compatible with the intended use of TestEquality (which +-- is supposed to be just for singletons), but it seems fine for tests. +instance Eq a => TestEquality (Pair a) where + testEquality x y = + case testEquality (_sec x) (_sec y) of + Just Refl -> if _fir x == _fir y then Just Refl else Nothing + Nothing -> Nothing + +instance (Show a) => Show (Pair a b) where + show (Pair a b) = "Pair(" ++ show a ++ ", " ++ show b ++ ")" + +instance Show a => ShowF (Pair a) + +fir :: Lens' (Pair a b) a +fir = lens _fir (\s v -> s { _fir = v }) + +someFir :: Lens' (Some (Pair a)) a +someFir = someLens fir + +someTests :: IO TestTree +someTests = + testGroup "Some" <$> + return + [ testCase "someLens: view . set" $ + assertEqual + "view l . set l x == const x" + (view someFir (set someFir 5 (Some (Pair 1 BoolItem)))) + (5 :: Int) + , testCase "someLens: set . set" $ + assertEqual + "set l y . set l x == set l y" + (set someFir 4 (set someFir 5 (Some (Pair 1 IntItem)))) + (Some (Pair (4 :: Int) IntItem)) + ] diff --git a/test/Test/SymbolRepr.hs b/test/Test/SymbolRepr.hs new file mode 100644 index 0000000..11e4ea6 --- /dev/null +++ b/test/Test/SymbolRepr.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} + +module Test.SymbolRepr + ( + symbolTests + ) +where + +import Test.Tasty +import Test.Tasty.HUnit ( (@=?), testCase ) + +import Data.Parameterized.SymbolRepr +import GHC.TypeLits + + +data Bird (name :: Symbol) where + Jay :: String -> Bird "Jay" + Dove :: Bird "Dove" + Hawk :: Bird "Hawk" + +symbolTests :: IO TestTree +symbolTests = testGroup "Symbol" <$> return + [ + testCase "SomeSym" $ do + let syms = [ SomeSym (Jay "Blue") + , SomeSym Dove + , SomeSym Hawk + ] + "Dove" @=? viewSomeSym symbolVal (head (tail syms)) + + ] diff --git a/test/Test/TH.hs b/test/Test/TH.hs new file mode 100644 index 0000000..9f4f12a --- /dev/null +++ b/test/Test/TH.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +module Test.TH + ( thTests + ) +where + +import Test.Tasty +import Test.Tasty.HUnit + +import Control.Monad (when) +import Data.Parameterized.Classes +import Data.Parameterized.NatRepr +import Data.Parameterized.TH.GADT +import GHC.TypeNats + +data T1 = A | B | C +$(mkRepr ''T1) +$(mkKnownReprs ''T1) +$(return []) +instance TestEquality T1Repr where + testEquality = $(structuralTypeEquality [t|T1Repr|] []) +deriving instance Show (T1Repr t) + +data T2 = T2_1 T1 | T2_2 Nat +$(mkRepr ''T2) +$(mkKnownReprs ''T2) +$(return []) +instance TestEquality T2Repr where + testEquality = $(structuralTypeEquality [t|T2Repr|] + [ (AnyType, [|testEquality|]) ]) +deriving instance Show (T2Repr t) + +eqTest :: (TestEquality f, Show (f a), Show (f b)) => f a -> f b -> IO () +eqTest a b = + when (not (isJust (testEquality a b))) $ assertFailure $ show a ++ " /= " ++ show b + +neqTest :: (TestEquality f, Show (f a), Show (f b)) => f a -> f b -> IO () +neqTest a b = + when (isJust (testEquality a b)) $ assertFailure $ show a ++ " == " ++ show b + +thTests :: IO TestTree +thTests = testGroup "TH" <$> return + [ testCase "Repr equality test" $ do + -- T1 + ARepr `eqTest` ARepr + ARepr `neqTest` BRepr + BRepr `eqTest` BRepr + BRepr `neqTest` CRepr + -- T2 + T2_1Repr ARepr `eqTest` T2_1Repr ARepr + T2_2Repr (knownNat @5) `eqTest` T2_2Repr (knownNat @5) + T2_1Repr ARepr `neqTest` T2_1Repr CRepr + T2_2Repr (knownNat @5) `neqTest` T2_2Repr (knownNat @9) + T2_1Repr BRepr `neqTest` T2_2Repr (knownNat @4) + + , testCase "KnownRepr test" $ do + -- T1 + let aRepr = knownRepr :: T1Repr 'A + bRepr = knownRepr :: T1Repr 'B + cRepr = knownRepr :: T1Repr 'C + aRepr `eqTest` ARepr + bRepr `eqTest` BRepr + cRepr `eqTest` CRepr + --T2 + let t2ARepr = knownRepr :: T2Repr ('T2_1 'A) + t2BRepr = knownRepr :: T2Repr ('T2_1 'B) + t25Repr = knownRepr :: T2Repr ('T2_2 5) + t2ARepr `eqTest` T2_1Repr ARepr + t2BRepr `eqTest` T2_1Repr BRepr + t25Repr `eqTest` T2_2Repr (knownNat @5) + t2ARepr `neqTest` t2BRepr + t2ARepr `neqTest` t25Repr + t2BRepr `neqTest` t25Repr + ] diff --git a/test/Test/Vector.hs b/test/Test/Vector.hs new file mode 100644 index 0000000..f3e0ff2 --- /dev/null +++ b/test/Test/Vector.hs @@ -0,0 +1,338 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE TypeApplications #-} +{-# Language CPP #-} +{-# Language DataKinds #-} +{-# Language ExplicitForAll #-} +{-# Language FlexibleInstances #-} +{-# Language LambdaCase #-} +{-# Language OverloadedStrings #-} +{-# Language ScopedTypeVariables #-} +{-# Language StandaloneDeriving #-} +{-# Language TypeFamilies #-} +{-# Language TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +#if __GLASGOW_HASKELL__ >= 805 +{-# Language NoStarIsType #-} +#endif +module Test.Vector + ( vecTests + , SomeVector(..) + , genSomeVector + , genVectorOfLength + , genOrdering + , orderingEndomorphisms + , orderingToStringFuns + ) +where + +import Data.Functor.Const (Const(..)) +import Data.Functor.WithIndex (imap) +import Data.Foldable.WithIndex (ifoldMap) +import Data.Maybe (isJust) +import qualified Data.List as List +import qualified Data.Parameterized.Context as Ctx +import Data.Parameterized.Fin +import Data.Parameterized.NatRepr +import Data.Parameterized.Some +import Data.Parameterized.Vector +import Data.Semigroup +import GHC.TypeLits (KnownNat) +import Hedgehog +import qualified Hedgehog.Gen as HG +import Hedgehog.Range +import Numeric.Natural (Natural) +import Prelude hiding (take, reverse, length) +import qualified Prelude as P +import Test.Fin (genFin) +import Test.Tasty +import Test.Tasty.Hedgehog +import Test.Context (genSomePayloadList, mkUAsgn) + +#if __GLASGOW_HASKELL__ >= 806 +import qualified Hedgehog.Classes as HC +import Test.Tasty.HUnit (assertBool, testCase) +#endif + +data SomeVector a = forall n. SomeVector (Vector n a) + +instance Show a => Show (SomeVector a) where + show (SomeVector v) = show v + +genVectorOfLength :: (Monad m) => NatRepr n -> GenT m a -> GenT m (Vector (n + 1) a) +genVectorOfLength n genElem = + do let w = widthVal n + l <- HG.list (linear (w + 1) (w + 1)) genElem + case testLeq (knownNat @1) (incNat n) of + Nothing -> error "testLeq in genSomeVector" + Just LeqProof -> + case fromList (incNat n) l of + Just v -> return v + Nothing -> error ("fromList failure for size " <> show w) + +genSomeVector :: (Monad m) => GenT m a -> GenT m (SomeVector a) +genSomeVector genElem = + do Some len <- mkNatRepr <$> HG.integral (linear 0 (99 :: Natural)) + SomeVector <$> genVectorOfLength len genElem + +genVectorKnownLength :: (1 <= n, KnownNat n, Monad m) => GenT m a -> GenT m (Vector n a) +genVectorKnownLength genElem = + do let n = knownNat + w = widthVal n + l <- HG.list (constant w w) genElem + case fromList n l of + Just v -> return v + Nothing -> error ("fromList failure for size " <> show w) + +genOrdering :: Monad m => GenT m Ordering +genOrdering = HG.element [ LT, EQ, GT ] + +instance Show (a -> b) where + show _ = "unshowable" + +-- Used to test e.g., 'fmap (g . f) = fmap g . fmap f' and 'imap (const f) = +-- fmap f'. +orderingEndomorphisms :: [Ordering -> Ordering] +orderingEndomorphisms = + [ const EQ + , id + , \case + EQ -> EQ + LT -> GT + GT -> LT + , \case + LT -> EQ + EQ -> GT + GT -> LT + ] + +-- | Used to test ifoldMap. +orderingToStringFuns :: [ Ordering -> String ] +orderingToStringFuns = + [ const "s" + , show + ] + +prop_reverse100 :: Property +prop_reverse100 = property $ + do SomeVector v <- forAll $ genSomeVector genOrdering + case testLeq (knownNat @1) (length v) of + Nothing -> pure () + Just LeqProof -> v === (reverse $ reverse v) + +prop_reverseSingleton :: Property +prop_reverseSingleton = property $ + do l <- (:[]) <$> forAll genOrdering + Just v <- return $ fromList (knownNat @1) l + v === reverse v + +prop_splitJoin :: Property +prop_splitJoin = property $ + do let n = knownNat @5 + v <- forAll $ genVectorKnownLength @(5 * 5) genOrdering + v === (join n $ split n (knownNat @5) v) + +prop_cons :: Property +prop_cons = property $ + do let n = knownNat @20 + w = widthVal n + l <- forAll $ HG.list (constant w w) genOrdering + x <- forAll genOrdering + (cons x <$> fromList n l) === fromList (incNat n) (x:l) + +prop_snoc :: Property +prop_snoc = property $ + do let n = knownNat @20 + w = widthVal n + l <- forAll $ HG.list (constant w w) genOrdering + x <- forAll genOrdering + (flip snoc x <$> fromList n l) === fromList (incNat n) (l ++ [x]) + +prop_snocUnsnoc :: Property +prop_snocUnsnoc = property $ + do let n = knownNat @20 + w = widthVal n + l <- forAll $ HG.list (constant w w) genOrdering + x <- forAll genOrdering + (fst . unsnoc . flip snoc x <$> fromList n l) === Just x + +prop_generate :: Property +prop_generate = property $ + do let n = knownNat @55 + w = widthVal n + funs :: [ Int -> Ordering ] -- some miscellaneous functions to generate Vector values + funs = [ const EQ + , \i -> if i < 10 then LT else if i > 15 then GT else EQ + , \i -> if i == 0 then EQ else GT + ] + f <- forAll $ HG.element funs + Just (generate n (f . widthVal)) === fromList (incNat n) (map f [0..w]) + +prop_unfold :: Property +prop_unfold = property $ + do let n = knownNat @55 + w = widthVal n + funs :: [ Ordering -> (Ordering, Ordering) ] -- some miscellaneous functions to generate Vector values + funs = [ const (EQ, EQ) + , \case + LT -> (LT, GT) + GT -> (GT, LT) + EQ -> (EQ, EQ) + ] + f <- forAll $ HG.element funs + o <- forAll $ HG.element [EQ, LT, GT] + Just (unfoldr n f o) === fromList (incNat n) (P.take (w + 1) (List.unfoldr (Just . f) o)) + +prop_toFromAssignment :: Property +prop_toFromAssignment = property $ + do vals <- forAll genSomePayloadList + Some a <- return $ mkUAsgn vals + let sz = Ctx.size a + case Ctx.viewSize sz of + Ctx.ZeroSize -> pure () + Ctx.IncSize _ -> + let a' = + toAssignment + sz + (\_idx val -> Const val) + (fromAssignment Some a) + in do assert $ + isJust $ + testEquality + (Ctx.sizeToNatRepr sz) + (Ctx.sizeToNatRepr (Ctx.size a')) + viewSome + (\lastElem -> + assert $ + isJust $ + testEquality + (a Ctx.! Ctx.lastIndex sz) lastElem) + (getConst (a' Ctx.! Ctx.lastIndex sz)) + +prop_fmapId :: Property +prop_fmapId = property $ + do SomeVector v <- forAll $ genSomeVector genOrdering + fmap id v === v + +prop_fmapCompose :: Property +prop_fmapCompose = property $ + do SomeVector v <- forAll $ genSomeVector genOrdering + f <- forAll $ HG.element orderingEndomorphisms + g <- forAll $ HG.element orderingEndomorphisms + fmap (g . f) v === fmap g (fmap f v) + +prop_iterateNRange :: Property +prop_iterateNRange = property $ + do Some len <- mkNatRepr <$> forAll (HG.integral (linear 0 (99 :: Natural))) + toList (iterateN len (+1) 0) === [0..(natValue len)] + +prop_indicesOfRange :: Property +prop_indicesOfRange = property $ + do SomeVector v <- forAll $ genSomeVector genOrdering + toList (fmap (viewFin natValue) (indicesOf v)) === [0..(natValue (length v) - 1)] + +prop_imapConst :: Property +prop_imapConst = property $ + do f <- forAll $ HG.element orderingEndomorphisms + SomeVector v <- forAll $ genSomeVector genOrdering + imap (const f) v === fmap f v + +prop_ifoldMapConst :: Property +prop_ifoldMapConst = property $ + do f <- forAll $ HG.element orderingToStringFuns + SomeVector v <- forAll $ genSomeVector genOrdering + ifoldMap (const f) v === foldMap f v + +prop_imapConstIndicesOf :: Property +prop_imapConstIndicesOf = property $ + do SomeVector v <- forAll $ genSomeVector genOrdering + imap const v === indicesOf v + +prop_imapElemAt :: Property +prop_imapElemAt = property $ + do SomeVector v <- forAll $ genSomeVector genOrdering + imap (\i _ -> viewFin (\x -> elemAt x v) i) v === v + +prop_OrdEqVectorIndex :: Property +prop_OrdEqVectorIndex = property $ + do i <- forAll $ genFin (knownNat @10) + j <- forAll $ genFin (knownNat @10) + (i == j) === (compare i j == EQ) + +-- We use @Ordering@ just because it's simple +vecTests :: IO TestTree +vecTests = testGroup "Vector" <$> return + [ testPropertyNamed "reverse100" "prop_reverse100" prop_reverse100 + , testPropertyNamed "reverseSingleton" "prop_reverseSingleton" prop_reverseSingleton + + , testPropertyNamed "split-join" "prop_splitJoin" prop_splitJoin + + -- @cons@ is the same for vectors or lists + , testPropertyNamed "cons" "prop_cons" prop_cons + + -- @snoc@ is like appending to a list + , testPropertyNamed "snoc" "prop_snoc" prop_snoc + + -- @snoc@ and @unsnoc@ are inverses + , testPropertyNamed "snoc/unsnoc" "prop_snocUnsnoc" prop_snocUnsnoc + + -- @generate@ is like mapping a function over indices + , testPropertyNamed "generate" "prop_generate" prop_generate + + -- @unfold@ works like @unfold@ on lists + , testPropertyNamed "unfold" "prop_unfold" prop_unfold + + -- Converting to and from assignments preserves size and last element + , testPropertyNamed "to-from-assignment" "prop_toFromAssignment" prop_toFromAssignment + + -- NOTE: We don't use hedgehog-classes here, because the way the types work + -- would require this to only tests vectors of some fixed size. + -- + -- Also, for 'fmap-compose', hedgehog-classes only tests two fixed functions + -- over integers. + , testPropertyNamed "fmap-id" "prop_fmapId" prop_fmapId + + , testPropertyNamed "fmap-compose" "prop_fmapCompose" prop_fmapCompose + + , testPropertyNamed "iterateN-range" "prop_iterateNRange" prop_iterateNRange + + , testPropertyNamed "indicesOf-range" "prop_indicesOfRange" prop_indicesOfRange + + , testPropertyNamed "imap-const" "prop_imapConst" prop_imapConst + + , testPropertyNamed "ifoldMap-const" "prop_ifoldMapConst" prop_ifoldMapConst + + , testPropertyNamed "imap-const-indicesOf" "prop_imapConstIndicesOf" prop_imapConstIndicesOf + + , testPropertyNamed "imap-elemAt" "prop_imapElemAt" prop_imapElemAt + + , testPropertyNamed "Ord-Eq-VectorIndex" "prop_OrdEqVectorIndex" prop_OrdEqVectorIndex + +#if __GLASGOW_HASKELL__ >= 806 + -- Test a few different sizes since the types force each test to use a + -- specific size vector. + , testCase "Eq-Vector-laws-1" $ + assertBool "Eq-Vector-laws-1" =<< + HC.lawsCheck (HC.eqLaws (genVectorKnownLength @1 genOrdering)) + , testCase "Eq-Vector-laws-10" $ + assertBool "Eq-Vector-laws-10" =<< + HC.lawsCheck (HC.eqLaws (genVectorKnownLength @10 genOrdering)) + , testCase "Show-Vector-laws-1" $ + assertBool "Show-Vector-laws-1" =<< + HC.lawsCheck (HC.showLaws (genVectorKnownLength @1 genOrdering)) + , testCase "Show-Vector-laws-10" $ + assertBool "Show-Vector-laws-10" =<< + HC.lawsCheck (HC.showLaws (genVectorKnownLength @10 genOrdering)) + , testCase "Foldable-Vector-laws-1" $ + assertBool "Foldable-Vector-laws-1" =<< + HC.lawsCheck (HC.foldableLaws (genVectorKnownLength @1)) + , testCase "Foldable-Vector-laws-10" $ + assertBool "Foldable-Vector-laws-10" =<< + HC.lawsCheck (HC.foldableLaws (genVectorKnownLength @10)) + , testCase "Traversable-Vector-laws-1" $ + assertBool "Traversable-Vector-laws-1" =<< + HC.lawsCheck (HC.traversableLaws (genVectorKnownLength @1)) + , testCase "Traversable-Vector-laws-10" $ + assertBool "Traversable-Vector-laws-10" =<< + HC.lawsCheck (HC.traversableLaws (genVectorKnownLength @10)) +#endif + ] diff --git a/test/UnitTest.hs b/test/UnitTest.hs new file mode 100644 index 0000000..5909ecd --- /dev/null +++ b/test/UnitTest.hs @@ -0,0 +1,36 @@ +import Test.Tasty +import Test.Tasty.Ingredients +import Test.Tasty.Runners.AntXML + +import qualified Test.Context +import qualified Test.Fin +import qualified Test.FinMap +import qualified Test.List +import qualified Test.NatRepr +import qualified Test.Some +import qualified Test.SymbolRepr +import qualified Test.TH +import qualified Test.Vector + +main :: IO () +main = tests >>= defaultMainWithIngredients ingrs + +ingrs :: [Ingredient] +ingrs = + [ antXMLRunner + ] + ++ + defaultIngredients + +tests :: IO TestTree +tests = testGroup "ParameterizedUtils" <$> sequence + [ Test.Context.contextTests + , pure Test.List.tests + , Test.Fin.finTests + , Test.FinMap.finMapTests + , Test.NatRepr.natTests + , Test.Some.someTests + , Test.SymbolRepr.symbolTests + , Test.TH.thTests + , Test.Vector.vecTests + ] -- 2.30.2