--- /dev/null
+# Changelog for the `parameterized-utils` package
+
+## 2.1.8.0 -- *2023 Jan 15*
+
+ * Add support for GHC 9.8.
+ * Allow building with `constraints-0.14.*`, `tasty-1.5.*`, and
+ `th-abstraction-0.6.*`.
+
+## 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.
--- /dev/null
+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
--- /dev/null
+Cabal-version: 2.2
+Name: parameterized-utils
+Version: 2.1.8.0
+Author: Galois Inc.
+Maintainer: kquick@galois.com, rscott@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.7
+ , constraints >=0.10 && <0.15
+ , 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.6
+ , tasty-ant-xml == 1.1.*
+ , tasty-hunit >= 0.9 && < 0.11
+ , tasty-hedgehog >= 1.2
+
+ if impl(ghc >= 8.6)
+ build-depends:
+ hedgehog-classes
--- /dev/null
+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
--- /dev/null
+------------------------------------------------------------------------
+-- |
+-- Module : Data.Parameterized.All
+-- Copyright : (c) Galois, Inc 2019
+-- Maintainer : Langston Barrett <langston@galois.com>
+-- 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)
--- /dev/null
+{-# 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.
+-}
--- /dev/null
+{-# 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
--- /dev/null
+{-|
+Description : Classes for working with type of kind @k -> *@
+Copyright : (c) Galois, Inc 2014-2019
+Maintainer : Joe Hendrix <jhendrix@galois.com>
+
+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
--- /dev/null
+{-|
+Description : Classes for working with type of kind @(k -> *) -> *@
+Copyright : (c) Galois, Inc 2014-2019
+Maintainer : Langston Barrett <langston@galois.com>
+
+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
+<https://github.com/GaloisInc/parameterized-utils/issues/23 issue 23>.
+-}
+
+{-# 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)
--- /dev/null
+{-|
+Description : utilities for working with "Data.Functor.Compose"
+Copyright : (c) Galois, Inc 2014-2019
+Maintainer : Langston Barrett <langston@galois.com>
+
+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
--- /dev/null
+{-|
+Module : Data.Parameterized.Context
+Copyright : (c) Galois, Inc 2014-2019
+Maintainer : Joe Hendrix <jhendrix@galois.com>
+
+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
--- /dev/null
+------------------------------------------------------------------------
+-- |
+-- Module : Data.Parameterized.Context.Safe
+-- Copyright : (c) Galois, Inc 2014-2015
+-- Maintainer : Joe Hendrix <jhendrix@galois.com>
+--
+-- 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
--- /dev/null
+{-# 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
--- /dev/null
+{-|
+Description : Type-level lists.
+Copyright : (c) Galois, Inc 2015-2019
+Maintainer : Joe Hendrix <jhendrix@galois.com>
+
+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
--- /dev/null
+{-|
+Description : type-level proofs involving contexts
+Copyright : (c) Galois, Inc 2015-2019
+Maintainer : Joe Hendrix <jhendrix@galois.com>
+
+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
--- /dev/null
+{-# 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|] )
+ ])
--- /dev/null
+{-|
+Description : Decideable equality (i.e. evidence of non-equality) on type families
+Copyright : (c) Galois, Inc 2014-2019
+Maintainer : Langston Barrett <langston@galois.com>
+
+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
--- /dev/null
+{-# 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)
--- /dev/null
+{-|
+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
--- /dev/null
+{-|
+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
--- /dev/null
+{-|
+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
--- /dev/null
+------------------------------------------------------------------------
+-- |
+-- Module : Data.Parameterized.HashTable
+-- Description : a hash table for parameterized keys and values
+-- Copyright : (c) Galois, Inc 2014-2019
+-- Maintainer : Joe Hendrix <jhendrix@galois.com>
+--
+-- 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
--- /dev/null
+{-|
+Description : A type-indexed parameterized list
+Copyright : (c) Galois, Inc 2017-2019
+Maintainer : Joe Hendrix <jhendrix@galois.com>
+
+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:
+
+@
+\<interactive\>: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
--- /dev/null
+{-|
+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)
--- /dev/null
+{-|
+Description : Type level natural number representation at runtime
+Copyright : (c) Galois, Inc 2014-2019
+Maintainer : Joe Hendrix <jhendrix@galois.com>
+
+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
--- /dev/null
+{-|
+Copyright : (c) Galois, Inc 2014-2018
+Maintainer : Joe Hendrix <jhendrix@galois.com>
+
+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
--- /dev/null
+{-|
+Description : Index generator in the ST monad.
+Copyright : (c) Galois, Inc 2014-2019
+Maintainer : Joe Hendrix <jhendrix@galois.com>
+
+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
--- /dev/null
+{-|
+Description : A typeclass and monad transformers for generating nonces.
+Copyright : (c) Galois, Inc 2014-2019
+Maintainer : Eddy Westbrook <westbrook@galois.com>
+
+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
--- /dev/null
+------------------------------------------------------------------------
+-- |
+-- Module : Data.Parameterized.Nonce.Unsafe
+-- Description : A counter in the ST monad.
+-- Copyright : (c) Galois, Inc 2014
+-- Maintainer : Joe Hendrix <jhendrix@galois.com>
+-- 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)
--- /dev/null
+{-|
+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
--- /dev/null
+{-|
+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
--- /dev/null
+------------------------------------------------------------------------
+-- |
+-- Module : Data.Parameterized.Some
+-- Copyright : (c) Galois, Inc 2014-2019
+-- Maintainer : Joe Hendrix <jhendrix@galois.com>
+-- 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))
--- /dev/null
+{-|
+Copyright : (c) Galois, Inc 2014-2019
+Maintainer : Joe Hendrix <jhendrix@galois.com>
+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
--- /dev/null
+------------------------------------------------------------------------
+-- |
+-- Module : Data.Parameterized.TH.GADT
+-- Copyright : (c) Galois, Inc 2013-2019
+-- Maintainer : Joe Hendrix <jhendrix@galois.com>
+-- 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@.
--- /dev/null
+------------------------------------------------------------------------
+-- |
+-- Module : Data.Parameterized.TraversableF
+-- Copyright : (c) Galois, Inc 2014-2019
+-- Maintainer : Joe Hendrix <jhendrix@galois.com>
+-- 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
--- /dev/null
+------------------------------------------------------------------------
+-- |
+-- Module : Data.Parameterized.TraversableFC
+-- Copyright : (c) Galois, Inc 2014-2015
+-- Maintainer : Joe Hendrix <jhendrix@galois.com>
+-- 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 #-}
--- /dev/null
+------------------------------------------------------------------------
+-- |
+-- 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 #-}
--- /dev/null
+{-|
+Description : Utilities for balanced binary trees.
+Copyright : (c) Galois, Inc 2014-2019
+Maintainer : Joe Hendrix <jhendrix@galois.com>
+-}
+{-# 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 #-}
--- /dev/null
+{-|
+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)
--- /dev/null
+{-# 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 #-}
--- /dev/null
+{-# 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
+<http://hackage.haskell.org/package/singletons-2.5.1/>. 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
--- /dev/null
+{-# 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
+
+ ]
--- /dev/null
+{-# 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
+ ]
--- /dev/null
+{-# 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
+ ]
--- /dev/null
+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
--- /dev/null
+{-# 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
+ ]
--- /dev/null
+{-# 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))
+ ]
--- /dev/null
+{-# 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
+ "Jay" @=? viewSomeSym symbolVal (SomeSym (Jay "Blue"))
+ "Dove" @=? viewSomeSym symbolVal (SomeSym Dove)
+ "Hawk" @=? viewSomeSym symbolVal (SomeSym Hawk)
+
+ ]
--- /dev/null
+{-# 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
+ ]
--- /dev/null
+{-# 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
+ ]
--- /dev/null
+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
+ ]
projects / haskell-parameterized-utils.git / commitdiff