parameterized-utils-2.1.7.0/0000755000000000000000000000000007346545000014042 5ustar0000000000000000parameterized-utils-2.1.7.0/Changelog.md0000644000000000000000000003070307346545000016256 0ustar0000000000000000# Changelog for the `parameterized-utils` package ## 2.1.7.0 -- *2023 Jul 28* * Add support for GHC 9.6. * Allow building with `base-orphans-0.9.*`, `mtl-2.3.*`, and `th-abstraction-0.5.*`. * Mark `Data.Parameterized.ClassesC` as `Trustworthy` to restore the ability to build `parameterized-utils` with versions of `lens` older than `lens-5`. ## 2.1.6.0 -- *2022 Dec 18* * Added `FinMap`: an integer map with a statically-known maximum size. * Added `someLens` to `Some` to create a parameterized lens. * Allow building with `hashable-1.4.*`. Because `hashable-1.4.0.0` adds an `Eq` superclass to `Hashable`, some instances of `Hashable` in `parameterized-utils` now require additional `TestEquality` constraints, as the corresponding `Eq` instances for these data types also require `TestEquality` constraints. * Bump constraints to allow: vector-0.13, lens-5.2, tasty-hedgehog-1.3.0.0--1.4.0.0, GHC-9.4 ## 2.1.5.0 -- *2022 Mar 08* * Add support for GHC 9.2. Drop support for GHC 8.4 (or earlier). * Add a `Data.Parameterized.NatRepr.leqZero :: LeqProof 0 n` function. Starting with GHC 9.2, GHC is no longer able to conclude that `forall (n :: Nat). 0 <= n` due to changes in how the `(<=)` type family works. As a result, this fact must be asserted as an axiom, which the `leqZero` function accomplishes. ## 2.1.4.0 -- *2021 Oct 1* * Added the `ifoldLM` and `fromSomeList`, `fromListWith`, and `fromListWithM` functions to the `List` module. * Fix the description of the laws of the `OrdF` class. * Fix a bug in which `Data.Parameterized.Vector.{join,joinWith,joinWithM}` and `Data.Parameterized.NatRepr.plusAssoc` could crash at runtime if compiled without optimizations. * Add a `Data.Parameterized.Axiom` module providing `unsafeAxiom` and `unsafeHeteroAxiom`, which can construct proofs of equality between types that GHC isn't able to prove on its own. These functions are unsafe if used improperly, so the responsibility is on the programmer to ensure that these functions are used appropriately. * Various `Proxy` enhancements: adds `KnownRepr`, `EqF`, and `ShowF` instances. * Adds `mkRepr` and `mkKnownReprs` Template Haskell functions. * Added `TraversableFC.WithIndex` module which provides the `FunctorFCWithIndex`, `FoldableFCWithIndex`, and `TraversableFCWithIndex` classes, with instances defined for `Assignment` and `List`. * Added `indicesUpTo`, and `indicesOf` as well as `iterateN` and `iterateNM` for the `Vector` module. * Added `Data.Parameterized.Fin` for finite types which can be used to index into a `Vector n` or other size-indexed datatypes. ## 2.1.3.0 -- *2021 Mar 23* * Add support for GHC 9. * In the `Context` module: * Added `sizeToNatRepr` function for converting a `Context` `Size`. * Added `unzip` to unzip an `Assignment` of `Product(Pair)` into a separate `Assignment` for each element of the `Pair` (the inverse of the `zipWith Pair` operation). * Added `flattenAssignment` to convert an `Assignment` of `Assignment` into an `Assignment` of `CtxFlatten`. Also adds `flattenSize` to combine the sizes of each context into the size of the corresponding `CtxFlatten`. * In the `Vector` module: * Added `fromAssignment` and `toAssignment` to allow conversions between `Assignment` and `Vector`. * Added `unsnoc`, `unfoldr`, `unfoldrM`, `unfoldrWithIndex`, and `unfoldrWithIndexM` functions. * Various haddock documentation updates and corrections. * Updated the Cabal specification to Cabal-version 2.2. ## 2.1.2 -- *2021 Jan 25* * Added `SomeSym` and `viewSomeSym` for existentially hidden Symbol values which retain the `KnownSymbol` constraint. * Added `leftIndex` and `rightIndex` for re-casting indexes of the individual parts of an Assignment into the concatenated Assignment. * Additional tests and updated documentation. ## 2.1.1 -- *2020 Jul 30* * Added `drop` and `appendEmbeddingLeft` functions to the `Context` module. * Fixes/updates to haddock documentation (fixing Issue #74). * Allow tasty v1.3 for testing (thanks to felixonmars) ## 2.1.0 -- *2020 May 08* * Added `plusAssoc` to the `NatRepr` module to produce `+` associativity evidence. * Changed the `HashTable` module to use the Basic instead of the Cuckoo implementation strategy. * Added explicit kind parameters to various definitions to support GHC 8.10's adoption of [proposal 103](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0103-no-kind-vars.rst). This is a modification to the type signatures which _may impact_ backward-compatibility and require updates, especially for any uses of [`TypeApplications`](https://gitlab.haskell.org/ghc/ghc/-/wikis/type-application). * No longer verifying support for GHC 8.2 or earlier. * Updated the minimum cabal version to 1.10 and specify the default-language as Haskell2010. ## 2.0.2 -- *2020 Feb 10* * Add the `dropPrefix` operation to `Context` which splits an `Assignment`. * Add `intersectWithKeyMaybe` and `mergeWithKey` to `Map`. * Add `mapAt`, `mapAtM`, and `replace` to `Vector`. * Add dependency on `base-orphans` to handle the `TestEquality` instance for `Compose`; needed for GHC 8.10. * Bump upper limit of `lens` dependency to allow 4.19. ## 2.0.1 -- *2019 Nov 06* * Documentation updates * Dependency constraint updates: constraints, lens, th-abstraction, hashable, hashtables, and vector. * Now supports building under GHC 8.8.1. * Added monadic folds and more traversals: * lazy folds: `foldlMF`, `foldrMF`, `foldlMFC`, `foldrMFC` * strict folds: `foldlMF'`, `foldrMF'`, `foldlMFC'`, `foldrMFC'` * `forF`, `forF_` * `forFC`, `forFC_` * `lengthF` * Added monadic folds, ascending or descending list conversions to `Parameterized.Map`: * Added monadic folds: `foldlMWithKey`, `foldrMWithKey` * Added ascending or descending list conversions: `toAscList` (equivalent to existing `toList`) and `toDescList`. * Added `findWithDefault` to lookup a key or return a default value. * Added `traverseMaybeWithKey`. * Fixes traverse to do an in-order rather than a pre-order traversal. * Added the `Data.Parameterized.All` module for universal quantification/parametricity over a type variable. * Additions to `Data.Parameterized.Context`: * Added `IndexView` type and `viewIndex` functions. * Added `addDiff` function to explicitly describe the (flipped) binary operator for the `Diff` instance of the `Category` class from `Control.Category`. * Added `traverseWithIndex_` * Added `Data.Parameterized.DataKind` providing the `PairRepr` type with associated `fst` and `snd` functions. * Added `TypeAp` to `Data.Parameterized.Classes` * Added `runSTNonceGenerator` to `Data.Parameterized.Nonce` for a *global* ST generator. * Added a `Hashable` instance for list `Index l x` types. * Changes in GADT TH code generator: * Added `structuralHashWithSalt` to * Fixed off by one bug in output * Fixed generation and constructor generation to use constructor type arguments, not type parameters. * The `Some` type is now an instance of `FunctorF`, `FoldableF`, and `TraversableF`. * Adjusted `structuralShowsPrec` precedence to match GHC derived `Show` instances. * The `Data.Parameterized.Nonce.Unsafe` module is now deprecated: clients should switch to `Data.Parameterized.Nonce`. ## 2.0 -- *2019 Apr 03* * Drop support for GHC versions prior to GHC 8.2 * Various Haddock and module updates. * Data.Parameterized.Classes - Added function: `ordFCompose` - Added `OrdF` instance for `Compose` * Data.Parameterized.ClassesC - Marked as `Safe` haskell via pragma - Added `OrdC` instance for `Some` * Data.Parameterized.Compose - Update `testEqualityComposeBare` to be more kind-polymorphic. - Marked as `Safe` haskell via pragma * Data.Parameterized.Context - Added `diffIsAppend` function to extract the contextual difference between two `Context`s (as a `Diff`) as an `IsAppend` (new) data value if the left is a sub-context of the right. * Data.Parameterized.NatRepr - Change runtime representation from `Int` to `Natural` - Add function `intValue` to recover an `Int` from a `NatRepr`. - Add constructor function `mkNatRepr` to construct a `NatRepr` from a `Natural`. - Removed awkward backdoor for directly creating `NatRepr` values; the single needed internal usage is now handled internally. * Data.Parameterized.Peano - Newly added module. - Defines a type `Peano` and `PeanoRepr` for representing a type-level natural at runtime. - The runtime representation of `PeanoRepr` is `Word64` - Has both safe and unsafe implementations. * Data.Parameterized.WithRepr - Newly added module. - This module declares a class `IsRepr` with a single method `withRepr` that can be used to derive a 'KnownRepr' constraint from an explicit 'Repr' argument. Clients of this method need only create an empty instance. The default implementation suffices. ## 1.0.8 -- *2019 Feb 01* * Data.Parameterized.Map - Fixed `MapF` functions `filter` and `filterWithKey` - Added `MapF` function: `mapWithKey` * Data.Parameterized.NatRepr - Un-deprecate `withKnownNat` * Data.Parameterized.Context - Updated some haddock documentation (esp. `CtxEmbedding` data structure). * Data.Parameterized.Nonce - Fixed `newIONonceGenerator` haddock documentation (IO monad, not ST monad). - Added `countNoncesGenerated` for profiling Nonce usage. * Data.Parameterized.TraversableF - Added `FunctorF`, `FoldableF`, and `TraversableF` instances for `Compose` from Data.Functor.Compose * Data.Parameterized.ClassesC - Newly added module. - Declares `TestEqualityC` and `OrdC` classes for working with types that have kind `(k -> *) -> *` for any `k`. * Data.Parameterized.Compose - Newly added module. - Orphan instance and `testEqualityComposeBare` function for working with Data.Functor.Compose. * Data.Parameterized.TestEquality - Newly added module. - Utilities for working with Data.Type.TestEquality. ## 1.0.7 -- *2018 Nov 17* * Data.Parameterized.Map - Added `MapF` functions: - `filter` - `filterWithKey` ## 1.0.6 -- *2018 Nov 19* * Add support for GHC 8.6. * Data.Parameterized.Map - Added functions: - `foldlWithKey` and `foldlWithKey'` (strict) - `foldrWithKey` and `foldrWithKey'` (strict) - `mapMaybeWithKey` ## 1.0.5 -- *2018 Sep 04* * Data.Parameterized.Context - Add function: `take`, `appendEmbedding`, `appendDiff` - Diff is type role nominal in both parameters. ## 1.0.4 -- *2018 Aug 29* * Data.Parameterized.Context - Add `traverseAndCollect`. Allows traversal of an Assignment in order from left to right, collecting the results of a visitor function monoidically. * Data.Parameterized.DecidableEq - Newly added module. The `DecidableEq` class represents decideable equality on a type family as a superclass of `TestEquality`, where the latter cannot provide evidence of non-equality. * Data.Parameterized.NatRepr - Add `DecidableEq` instance for NatRepr. - Add functions: - `decideLeq` - `isZeroOrGT1` - `lessThanIrreflexive` - `lessThanAsymmetric` - `natRecStrong` -- recursor with strong induction - `natRecBounded` -- bounded recursor - `natFromZero` * Data.Parameterized.Vector - Add construction functions: `singleton`, `cons`, `snoc`, `generate`, and `generateM` - Add functions: `splitWithA` (applicative `splitWith`). ## 1.0.3 -- *2018 Aug 24* * Move `lemmaMul` from Vector to NatRepr. * Add stricter role annotations: - `NatRepr` is nominal. - `Vector` is nominal in the first parameter and representational in the second. * Data.Parameterized.NatRepr - Provide a backdoor for directly creating `NatRepr` values. Use carefully. * Data.Parameterized.Vector - Add Show and Eq instances - Add functions: `joinWithM`, `reverse` ## 1.0.2 -- *2018 Aug 23* * Allow function passed to `traverseF_`, `traverseFC_`, and `forMFC_` to return a value instead of null (`()`). * Data.Parameterized.Vector - Newly added module. A fixed-size vector of typed elements. * Data.Parameterized.Utils.Endian - Newly added module. Used in Vector. ## 1.0.1 -- *2018 Aug 13* Baseline for changelog tracking. parameterized-utils-2.1.7.0/LICENSE0000644000000000000000000000273707346545000015060 0ustar0000000000000000Copyright (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.parameterized-utils-2.1.7.0/parameterized-utils.cabal0000644000000000000000000001100307346545000021013 0ustar0000000000000000Cabal-version: 2.2 Name: parameterized-utils Version: 2.1.7.0 Author: Galois Inc. Maintainer: kquick@galois.com stability: stable Build-type: Simple Copyright: ©2016-2022 Galois, Inc. License: BSD-3-Clause License-file: LICENSE category: Data Structures, Dependent Types Synopsis: Classes and data structures for working with data-kind indexed types Description: This package contains collection classes and type representations used for working with values that have a single parameter. It's intended for things like expression libraries where one wishes to leverage the Haskell type-checker to improve type-safety by encoding the object language type system into data kinds. extra-source-files: Changelog.md homepage: https://github.com/GaloisInc/parameterized-utils bug-reports: https://github.com/GaloisInc/parameterized-utils/issues tested-with: GHC==8.6.5, GHC==8.8.4, GHC==8.10.7, GHC==9.0.2, GHC==9.2.1, GHC==9.4.3 -- Many (but not all, sadly) uses of unsafe operations are -- controlled by this compile flag. When this flag is set -- to False, alternate implementations are used to avoid -- Unsafe.Coerce and Data.Coerce. These alternate implementations -- impose a significant performance hit. flag unsafe-operations Description: Use unsafe operations (e.g. coercions) to improve performance Default: True source-repository head type: git location: https://github.com/GaloisInc/parameterized-utils common bldflags ghc-options: -Wall -Wcompat -Wpartial-fields -Wincomplete-uni-patterns -Werror=incomplete-patterns -Werror=missing-methods -Werror=overlapping-patterns -Wno-trustworthy-safe -fhide-source-paths default-language: Haskell2010 library import: bldflags build-depends: base >= 4.10 && < 5 , base-orphans >=0.8.2 && <0.10 , th-abstraction >=0.4.2 && <0.6 , constraints >=0.10 && <0.14 , containers , deepseq , ghc-prim , hashable >=1.2 && <1.5 , hashtables >=1.2 && <1.4 , indexed-traversable , lens >=4.16 && <5.3 , mtl , profunctors >=5.6 && < 5.7 , template-haskell , text , vector >=0.12 && < 0.14 hs-source-dirs: src exposed-modules: Data.Parameterized Data.Parameterized.All Data.Parameterized.Axiom Data.Parameterized.BoolRepr Data.Parameterized.Classes Data.Parameterized.ClassesC Data.Parameterized.Compose Data.Parameterized.Context Data.Parameterized.Context.Safe Data.Parameterized.Context.Unsafe Data.Parameterized.Ctx Data.Parameterized.Ctx.Proofs Data.Parameterized.DataKind Data.Parameterized.DecidableEq Data.Parameterized.Fin Data.Parameterized.FinMap Data.Parameterized.FinMap.Safe Data.Parameterized.FinMap.Unsafe Data.Parameterized.HashTable Data.Parameterized.List Data.Parameterized.Map Data.Parameterized.NatRepr Data.Parameterized.Nonce Data.Parameterized.Nonce.Transformers Data.Parameterized.Nonce.Unsafe Data.Parameterized.Pair Data.Parameterized.Peano Data.Parameterized.Some Data.Parameterized.SymbolRepr Data.Parameterized.TH.GADT Data.Parameterized.TraversableF Data.Parameterized.TraversableFC Data.Parameterized.TraversableFC.WithIndex Data.Parameterized.Utils.BinTree Data.Parameterized.Utils.Endian Data.Parameterized.Vector Data.Parameterized.WithRepr other-modules: Data.Parameterized.NatRepr.Internal if flag(unsafe-operations) cpp-options: -DUNSAFE_OPS test-suite parameterizedTests import: bldflags type: exitcode-stdio-1.0 hs-source-dirs: test main-is: UnitTest.hs other-modules: Test.Context Test.Fin Test.FinMap Test.List Test.NatRepr Test.Some Test.SymbolRepr Test.TH Test.Vector build-depends: base , hashable , hashtables , hedgehog , indexed-traversable , ghc-prim , lens , mtl , parameterized-utils , tasty >= 1.2 && < 1.5 , tasty-ant-xml == 1.1.* , tasty-hunit >= 0.9 && < 0.11 , tasty-hedgehog >= 1.2 if impl(ghc >= 8.6) build-depends: hedgehog-classes parameterized-utils-2.1.7.0/src/Data/0000755000000000000000000000000007346545000015502 5ustar0000000000000000parameterized-utils-2.1.7.0/src/Data/Parameterized.hs0000644000000000000000000000122307346545000020630 0ustar0000000000000000module 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 parameterized-utils-2.1.7.0/src/Data/Parameterized/0000755000000000000000000000000007346545000020276 5ustar0000000000000000parameterized-utils-2.1.7.0/src/Data/Parameterized/All.hs0000644000000000000000000000340507346545000021344 0ustar0000000000000000------------------------------------------------------------------------ -- | -- Module : Data.Parameterized.All -- Copyright : (c) Galois, Inc 2019 -- Maintainer : Langston Barrett -- Description : Universal quantification, in a datatype -- -- This module provides 'All', a GADT that encodes universal -- quantification/parametricity over a type variable. -- -- The following is an example of a situation in which it might be necessary -- to use 'All' (though it is a bit contrived): -- -- @ -- {-# LANGUAGE FlexibleInstances #-} -- {-# LANGUAGE GADTs #-} -- -- data F (x :: Bool) where -- FTrue :: F 'True -- FFalse :: F 'False -- FIndeterminate :: F b -- -- data Value = -- VAllF (All F) -- -- class Valuable a where -- valuation :: a -> Value -- -- instance Valuable (All F) where -- valuation = VAllF -- -- val1 :: Value -- val1 = valuation (All FIndeterminate) -- @ -- -- For a less contrived but more complex example, see this blog -- post: http://comonad.com/reader/2008/rotten-bananas/ ------------------------------------------------------------------------ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} module Data.Parameterized.All ( All(..) , allConst ) where import Data.Functor.Const (Const(..)) import Data.Kind import Data.Parameterized.Classes import Data.Parameterized.TraversableF newtype All (f :: k -> Type) = All { getAll :: forall x. f x } instance FunctorF All where fmapF f (All a) = All (f a) instance FoldableF All where foldMapF toMonoid (All x) = toMonoid x instance ShowF f => Show (All f) where show (All fa) = showF fa instance EqF f => Eq (All f) where (All x) == (All y) = eqF x y allConst :: a -> All (Const a) allConst a = All (Const a) parameterized-utils-2.1.7.0/src/Data/Parameterized/Axiom.hs0000644000000000000000000000352207346545000021711 0ustar0000000000000000{-# 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. -} parameterized-utils-2.1.7.0/src/Data/Parameterized/BoolRepr.hs0000644000000000000000000000570107346545000022361 0ustar0000000000000000{-# 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 parameterized-utils-2.1.7.0/src/Data/Parameterized/Classes.hs0000644000000000000000000002700707346545000022235 0ustar0000000000000000{-| Description : Classes for working with type of kind @k -> *@ Copyright : (c) Galois, Inc 2014-2019 Maintainer : Joe Hendrix This module declares classes for working with types with the kind @k -> *@ for any kind @k@. These are generalizations of the "Data.Functor.Classes" types as they work with any kind @k@, and are not restricted to '*'. -} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE Safe #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} module Data.Parameterized.Classes ( -- * Equality exports Equality.TestEquality(..) , (Equality.:~:)(..) , EqF(..) , PolyEq(..) -- * Ordering generalization , OrdF(..) , lexCompareF , OrderingF(..) , joinOrderingF , orderingF_refl , toOrdering , fromOrdering , ordFCompose -- * Typeclass generalizations , ShowF(..) , showsF , HashableF(..) , CoercibleF(..) -- * Type function application constructor , TypeAp(..) -- * Optics generalizations , IndexF , IxValueF , IxedF(..) , IxedF'(..) , AtF(..) -- * KnownRepr , KnownRepr(..) -- * Re-exports , Data.Hashable.Hashable(..) , Data.Maybe.isJust ) where import Data.Functor.Const import Data.Functor.Compose (Compose(..)) import Data.Kind import Data.Hashable import Data.Maybe (isJust) import Data.Proxy import Data.Type.Equality as Equality import Data.Parameterized.Compose () -- We define these type alias here to avoid importing Control.Lens -- modules, as this apparently causes problems with the safe Hasekll -- checking. type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s type Traversal' s a = forall f. Applicative f => (a -> f a) -> s -> f s ------------------------------------------------------------------------ -- CoercibleF -- | An instance of 'CoercibleF' gives a way to coerce between -- all the types of a family. We generally use this to witness -- the fact that the type parameter to @rtp@ is a phantom type -- by giving an implementation in terms of Data.Coerce.coerce. class CoercibleF (rtp :: k -> Type) where coerceF :: rtp a -> rtp b instance CoercibleF (Const x) where coerceF (Const x) = Const x ------------------------------------------------------------------------ -- EqF -- | @EqF@ provides a method @eqF@ for testing whether two parameterized -- types are equal. -- -- Unlike 'TestEquality', this only works when the type arguments are -- the same, and does not provide a proof that the types have the same -- type when they are equal. Thus this can be implemented over -- parameterized types that are unable to provide evidence that their -- type arguments are equal. class EqF (f :: k -> Type) where eqF :: f a -> f a -> Bool instance Eq a => EqF (Const a) where eqF (Const x) (Const y) = x == y instance EqF Proxy where eqF _ _ = True ------------------------------------------------------------------------ -- PolyEq -- | A polymorphic equality operator that generalizes 'TestEquality'. class PolyEq u v where polyEqF :: u -> v -> Maybe (u :~: v) polyEq :: u -> v -> Bool polyEq x y = isJust (polyEqF x y) ------------------------------------------------------------------------ -- Ordering -- | Ordering over two distinct types with a proof they are equal. data OrderingF x y where LTF :: OrderingF x y EQF :: OrderingF x x GTF :: OrderingF x y orderingF_refl :: OrderingF x y -> Maybe (x :~: y) orderingF_refl o = case o of LTF -> Nothing EQF -> Just Refl GTF -> Nothing -- | Convert 'OrderingF' to standard ordering. toOrdering :: OrderingF x y -> Ordering toOrdering LTF = LT toOrdering EQF = EQ toOrdering GTF = GT -- | Convert standard ordering to 'OrderingF'. fromOrdering :: Ordering -> OrderingF x x fromOrdering LT = LTF fromOrdering EQ = EQF fromOrdering GT = GTF -- | @joinOrderingF x y@ first compares on @x@, returning an -- equivalent value if it is not `EQF`. If it is `EQF`, it returns @y@. joinOrderingF :: forall j k (a :: j) (b :: j) (c :: k) (d :: k) . OrderingF a b -> (a ~ b => OrderingF c d) -> OrderingF c d joinOrderingF EQF y = y joinOrderingF LTF _ = LTF joinOrderingF GTF _ = GTF ------------------------------------------------------------------------ -- OrdF -- | The `OrdF` class is a total ordering over parameterized types so -- that types with different parameters can be compared. -- -- Instances of `OrdF` are expected to satisfy the following laws: -- -- [__Transitivity__]: if @leqF x y && leqF y z@ = 'True', then @leqF x = z@ = @True@ -- [__Reflexivity__]: @leqF x x@ = @True@ -- [__Antisymmetry__]: if @leqF x y && leqF y x@ = 'True', then @testEquality x y@ = @Just Refl@ -- -- Note that the following operator interactions are expected to hold: -- -- * @geqF x y@ iff @leqF y x@ -- * @ltF x y@ iff @leqF x y && testEquality x y = Nothing@ -- * @gtF x y@ iff @ltF y x@ -- * @ltF x y@ iff @compareF x y == LTF@ -- * @gtF x y@ iff @compareF x y == GTF@ -- * @isJust (testEquality x y)@ iff @compareF x y == EQF@ -- -- Furthermore, when @x@ and @y@ both have type @(k tp)@, we expect: -- -- * @toOrdering (compareF x y)@ equals @compare x y@ when @Ord (k tp)@ has an instance. -- * @isJust (testEquality x y)@ equals @x == y@ when @Eq (k tp)@ has an instance. -- -- Minimal complete definition: either 'compareF' or 'leqF'. -- Using 'compareF' can be more efficient for complex types. class TestEquality ktp => OrdF (ktp :: k -> Type) where {-# MINIMAL compareF | leqF #-} compareF :: ktp x -> ktp y -> OrderingF x y compareF x y = case testEquality x y of Just Refl -> EQF Nothing | leqF x y -> LTF | otherwise -> GTF leqF :: ktp x -> ktp y -> Bool leqF x y = case compareF x y of LTF -> True EQF -> True GTF -> False ltF :: ktp x -> ktp y -> Bool ltF x y = case compareF x y of LTF -> True EQF -> False GTF -> False geqF :: ktp x -> ktp y -> Bool geqF x y = case compareF x y of LTF -> False EQF -> True GTF -> True gtF :: ktp x -> ktp y -> Bool gtF x y = case compareF x y of LTF -> False EQF -> False GTF -> True -- | Compare two values, and if they are equal compare the next values, -- otherwise return LTF or GTF lexCompareF :: forall j k (f :: j -> Type) (a :: j) (b :: j) (c :: k) (d :: k) . OrdF f => f a -> f b -> (a ~ b => OrderingF c d) -> OrderingF c d lexCompareF x y = joinOrderingF (compareF x y) -- | If the \"outer\" functor has an 'OrdF' instance, then one can be generated -- for the \"inner\" functor. The type-level evidence of equality is deduced -- via generativity of @g@, e.g. the inference @g x ~ g y@ implies @x ~ y@. ordFCompose :: forall k l (f :: k -> Type) (g :: l -> k) x y. (forall w z. f w -> f z -> OrderingF w z) -> Compose f g x -> Compose f g y -> OrderingF x y ordFCompose ordF_ (Compose x) (Compose y) = case ordF_ x y of LTF -> LTF GTF -> GTF EQF -> EQF instance OrdF f => OrdF (Compose f g) where compareF x y = ordFCompose compareF x y ------------------------------------------------------------------------ -- ShowF -- | A parameterized type that can be shown on all instances. -- -- To implement @'ShowF' g@, one should implement an instance @'Show' -- (g tp)@ for all argument types @tp@, then write an empty instance -- @instance 'ShowF' g@. class ShowF (f :: k -> Type) where -- | Provides a show instance for each type. withShow :: p f -> q tp -> (Show (f tp) => a) -> a default withShow :: Show (f tp) => p f -> q tp -> (Show (f tp) => a) -> a withShow _ _ x = x showF :: forall tp . f tp -> String showF x = withShow (Proxy :: Proxy f) (Proxy :: Proxy tp) (show x) -- | Like 'showsPrec', the precedence argument is /one more/ than the -- precedence of the enclosing context. showsPrecF :: forall tp. Int -> f tp -> String -> String showsPrecF p x = withShow (Proxy :: Proxy f) (Proxy :: Proxy tp) (showsPrec p x) showsF :: ShowF f => f tp -> String -> String showsF x = showsPrecF 0 x instance Show x => ShowF (Const x) instance ShowF Proxy ------------------------------------------------------------------------ -- IxedF type family IndexF (m :: Type) :: k -> Type type family IxValueF (m :: Type) :: k -> Type -- | Parameterized generalization of the lens @Ixed@ class. class IxedF k m where -- | Given an index into a container, build a traversal that visits -- the given element in the container, if it exists. ixF :: forall (x :: k). IndexF m x -> Traversal' m (IxValueF m x) -- | Parameterized generalization of the lens @Ixed@ class, -- but with the guarantee that indexes exist in the container. class IxedF k m => IxedF' k m where -- | Given an index into a container, build a lens that -- points into the given element in the container. ixF' :: forall (x :: k). IndexF m x -> Lens' m (IxValueF m x) ------------------------------------------------------------------------ -- AtF -- | Parameterized generalization of the lens @At@ class. class IxedF k m => AtF k m where -- | Given an index into a container, build a lens that points into -- the given position in the container, whether or not it currently -- exists. Setting values of @atF@ to a @Just@ value will insert -- the value if it does not already exist. atF :: forall (x :: k). IndexF m x -> Lens' m (Maybe (IxValueF m x)) ------------------------------------------------------------------------ -- HashableF -- | A default salt used in the implementation of 'hash'. defaultSalt :: Int #if WORD_SIZE_IN_BITS == 64 defaultSalt = 0xdc36d1615b7400a4 #else defaultSalt = 0x087fc72c #endif {-# INLINE defaultSalt #-} -- | A parameterized type that is hashable on all instances. class HashableF (f :: k -> Type) where hashWithSaltF :: Int -> f tp -> Int -- | Hash with default salt. hashF :: f tp -> Int hashF = hashWithSaltF defaultSalt instance Hashable a => HashableF (Const a) where hashWithSaltF s (Const x) = hashWithSalt s x ------------------------------------------------------------------------ -- TypeAp -- | Captures the value obtained from applying a type to a function so -- that we can use parameterized class instance to provide unparameterized -- instances for specific types. -- -- This is the same as `Ap` from @Control.Applicative@, but we introduce -- our own new type to avoid orphan instances. newtype TypeAp (f :: k -> Type) (tp :: k) = TypeAp (f tp) instance TestEquality f => Eq (TypeAp f tp) where TypeAp x == TypeAp y = isJust $ testEquality x y instance OrdF f => Ord (TypeAp f tp) where compare (TypeAp x) (TypeAp y) = toOrdering (compareF x y) instance ShowF f => Show (TypeAp f tp) where showsPrec p (TypeAp x) = showsPrecF p x instance (HashableF f, TestEquality f) => Hashable (TypeAp f tp) where hashWithSalt s (TypeAp x) = hashWithSaltF s x ------------------------------------------------------------------------ -- KnownRepr -- | This class is parameterized by a kind @k@ (typically a data -- kind), a type constructor @f@ of kind @k -> *@ (typically a GADT of -- singleton types indexed by @k@), and an index parameter @ctx@ of -- kind @k@. class KnownRepr (f :: k -> Type) (ctx :: k) where knownRepr :: f ctx instance KnownRepr Proxy ctx where knownRepr = Proxy parameterized-utils-2.1.7.0/src/Data/Parameterized/ClassesC.hs0000644000000000000000000000335207346545000022335 0ustar0000000000000000{-| Description : Classes for working with type of kind @(k -> *) -> *@ Copyright : (c) Galois, Inc 2014-2019 Maintainer : Langston Barrett This module declares classes for working with types with the kind @(k -> *) -> *@ for any kind @k@. These classes generally require type-level evidence for operations on their subterms, but don't actually provide it themselves (because their types are not themselves parameterized, unlike those in "Data.Parameterized.TraversableFC"). Note that there is still some ambiguity around naming conventions, see . -} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeOperators #-} module Data.Parameterized.ClassesC ( TestEqualityC(..) , OrdC(..) ) where import Data.Type.Equality ((:~:)(..)) import Data.Kind import Data.Maybe (isJust) import Data.Parameterized.Classes (OrderingF, toOrdering) import Data.Parameterized.Some (Some(..)) class TestEqualityC (t :: (k -> Type) -> Type) where testEqualityC :: (forall x y. f x -> f y -> Maybe (x :~: y)) -> t f -> t f -> Bool class TestEqualityC t => OrdC (t :: (k -> Type) -> Type) where compareC :: (forall x y. f x -> g y -> OrderingF x y) -> t f -> t g -> Ordering -- | This instance demonstrates where the above class is useful: namely, in -- types with existential quantification. instance TestEqualityC Some where testEqualityC subterms (Some someone) (Some something) = isJust (subterms someone something) instance OrdC Some where compareC subterms (Some someone) (Some something) = toOrdering (subterms someone something) parameterized-utils-2.1.7.0/src/Data/Parameterized/Compose.hs0000644000000000000000000000256507346545000022247 0ustar0000000000000000{-| Description : utilities for working with "Data.Functor.Compose" Copyright : (c) Galois, Inc 2014-2019 Maintainer : Langston Barrett Utilities for working with "Data.Functor.Compose". NB: This module contains an orphan instance. It will be included in GHC 8.10, see https://gitlab.haskell.org/ghc/ghc/merge_requests/273 and also https://github.com/haskell-compat/base-orphans/issues/49. -} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE Safe #-} module Data.Parameterized.Compose ( testEqualityComposeBare ) where import Data.Functor.Compose import Data.Kind import Data.Orphans () -- For the TestEquality (Compose f g) instance import Data.Type.Equality -- | The deduction (via generativity) that if @g x :~: g y@ then @x :~: y@. -- -- See https://gitlab.haskell.org/ghc/ghc/merge_requests/273. testEqualityComposeBare :: forall k l (f :: k -> Type) (g :: l -> k) x y. (forall w z. f w -> f z -> Maybe (w :~: z)) -> Compose f g x -> Compose f g y -> Maybe (x :~: y) testEqualityComposeBare testEquality_ (Compose x) (Compose y) = case (testEquality_ x y :: Maybe (g x :~: g y)) of Just Refl -> Just (Refl :: x :~: y) Nothing -> Nothing parameterized-utils-2.1.7.0/src/Data/Parameterized/Context.hs0000644000000000000000000004552407346545000022270 0ustar0000000000000000{-| Module : Data.Parameterized.Context Copyright : (c) Galois, Inc 2014-2019 Maintainer : Joe Hendrix This module reexports either "Data.Parameterized.Context.Safe" or "Data.Parameterized.Context.Unsafe" depending on the the unsafe-operations compile-time flag. It also defines some utility typeclasses for transforming between curried and uncurried versions of functions over contexts. The 'Assignment' type is isomorphic to the 'Data.Parameterized.List' type, except 'Assignment's construct lists from the right-hand side, and instead of using type-level @'[]@-style lists, an 'Assignment' is indexed by a type-level 'Data.Parameterized.Context.Ctx'. The implementation of 'Assignment's is also more efficent than 'Data.Parameterized.List' for lists of many elements, as it uses a balanced binary tree representation rather than a linear-time list. For a motivating example, see 'Data.Parameterized.List'. -} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE ViewPatterns #-} module Data.Parameterized.Context ( #ifdef UNSAFE_OPS module Data.Parameterized.Context.Unsafe #else module Data.Parameterized.Context.Safe #endif , singleton , toVector , pattern (:>) , pattern Empty , decompose , Data.Parameterized.Context.null , Data.Parameterized.Context.init , Data.Parameterized.Context.last , Data.Parameterized.Context.view , Data.Parameterized.Context.take , Data.Parameterized.Context.drop , forIndexM , generateSome , generateSomeM , fromList , traverseAndCollect , traverseWithIndex_ , dropPrefix , unzip , flattenAssignment , flattenSize -- * Context extension and embedding utilities , CtxEmbedding(..) , ExtendContext(..) , ExtendContext'(..) , ApplyEmbedding(..) , ApplyEmbedding'(..) , identityEmbedding , extendEmbeddingRightDiff , extendEmbeddingRight , extendEmbeddingBoth , appendEmbedding , appendEmbeddingLeft , ctxeSize , ctxeAssignment -- * Static indexing and lenses for assignments , Idx , field , natIndex , natIndexProxy -- * Currying and uncurrying for assignments , CurryAssignment , CurryAssignmentClass(..) -- * Size and Index values , size1, size2, size3, size4, size5, size6 , i1of2, i2of2 , i1of3, i2of3, i3of3 , i1of4, i2of4, i3of4, i4of4 , i1of5, i2of5, i3of5, i4of5, i5of5 , i1of6, i2of6, i3of6, i4of6, i5of6, i6of6 ) where import Prelude hiding (unzip) import qualified Control.Applicative as App (liftA2) import Control.Lens hiding (Index, (:>), Empty) import Data.Functor (void) import Data.Functor.Product (Product(Pair)) import Data.Kind import qualified Data.Vector as V import qualified Data.Vector.Mutable as MV import GHC.TypeLits (Nat, type (-)) import Data.Parameterized.Classes import Data.Parameterized.Some import Data.Parameterized.TraversableFC #ifdef UNSAFE_OPS import Data.Parameterized.Context.Unsafe #else import Data.Parameterized.Context.Safe #endif -- | Create a single element context. singleton :: f tp -> Assignment f (EmptyCtx ::> tp) singleton = (empty :>) -- |'forIndexM sz f' calls 'f' on indices '[0..sz-1]'. forIndexM :: forall ctx m . Applicative m => Size ctx -> (forall tp . Index ctx tp -> m ()) -> m () forIndexM sz f = forIndexRange 0 sz (\i r -> f i *> r) (pure ()) -- | Generate an assignment with some context type that is not known. generateSome :: forall f . Int -> (Int -> Some f) -> Some (Assignment f) generateSome n f = go n where go :: Int -> Some (Assignment f) go 0 = Some empty go i = (\(Some a) (Some e) -> Some (a `extend` e)) (go (i-1)) (f (i-1)) -- | Generate an assignment with some context type that is not known. generateSomeM :: forall m f . Applicative m => Int -> (Int -> m (Some f)) -> m (Some (Assignment f)) generateSomeM n f = go n where go :: Int -> m (Some (Assignment f)) go 0 = pure (Some empty) go i = (\(Some a) (Some e) -> Some (a `extend` e)) <$> go (i-1) <*> f (i-1) -- | Convert the assignment to a vector. toVector :: Assignment f tps -> (forall tp . f tp -> e) -> V.Vector e toVector a f = V.create $ do vm <- MV.new (sizeInt (size a)) forIndexM (size a) $ \i -> do MV.write vm (indexVal i) (f (a ! i)) return vm {-# INLINABLE toVector #-} -- | Utility function for testing if @xs@ is an assignment with -- `prefix` as a prefix, and computing the tail of xs -- not in the prefix, if so. dropPrefix :: forall f xs prefix a. TestEquality f => Assignment f xs {- ^ Assignment to split -} -> Assignment f prefix {- ^ Expected prefix -} -> a {- ^ error continuation -} -> (forall addl. (xs ~ (prefix <+> addl)) => Assignment f addl -> a) {- ^ success continuation -} -> a dropPrefix xs0 prefix err = go xs0 (sizeInt (size xs0)) where sz_prefix = sizeInt (size prefix) go :: forall ys. Assignment f ys -> Int -> (forall addl. (ys ~ (prefix <+> addl)) => Assignment f addl -> a) -> a go (xs' :> z) sz_x success | sz_x > sz_prefix = go xs' (sz_x-1) (\zs -> success (zs :> z)) go xs _ success = case testEquality xs prefix of Just Refl -> success Empty Nothing -> err -- | Unzip an assignment of pairs into a pair of assignments. -- -- This is the inverse of @'zipWith' 'Pair'@. unzip :: Assignment (Product f g) ctx -> (Assignment f ctx, Assignment g ctx) unzip fgs = case viewAssign fgs of AssignEmpty -> (empty, empty) AssignExtend rest (Pair f g) -> let (fs, gs) = unzip rest in (extend fs f, extend gs g) -- | Flattens a nested assignment over a context of contexts @ctxs :: Ctx (Ctx -- a)@ into a flat assignment over the flattened context @CtxFlatten ctxs@. flattenAssignment :: Assignment (Assignment f) ctxs -> Assignment f (CtxFlatten ctxs) flattenAssignment ctxs = case viewAssign ctxs of AssignEmpty -> empty AssignExtend ctxs' ctx -> flattenAssignment ctxs' <++> ctx -- | Given the size of each context in @ctxs@, returns the size of @CtxFlatten -- ctxs@. You can obtain the former from any nested assignment @Assignment -- (Assignment f) ctxs@, by calling @fmapFC size@. flattenSize :: Assignment Size ctxs -> Size (CtxFlatten ctxs) flattenSize a = case viewAssign a of AssignEmpty -> zeroSize AssignExtend b s -> addSize (flattenSize b) s -------------------------------------------------------------------------------- -- Patterns -- | Pattern synonym for the empty assignment pattern Empty :: () => ctx ~ EmptyCtx => Assignment f ctx pattern Empty <- (viewAssign -> AssignEmpty) where Empty = empty infixl :> -- | Pattern synonym for extending an assignment on the right pattern (:>) :: () => ctx' ~ (ctx ::> tp) => Assignment f ctx -> f tp -> Assignment f ctx' pattern (:>) a v <- (viewAssign -> AssignExtend a v) where a :> v = extend a v {-# COMPLETE (:>), Empty :: Assignment #-} -------------------------------------------------------------------------------- -- Views -- | Return true if assignment is empty. null :: Assignment f ctx -> Bool null a = case viewAssign a of AssignEmpty -> True AssignExtend{} -> False decompose :: Assignment f (ctx ::> tp) -> (Assignment f ctx, f tp) decompose x = (Data.Parameterized.Context.init x, Data.Parameterized.Context.last x) -- | Return assignment with all but the last block. init :: Assignment f (ctx '::> tp) -> Assignment f ctx init x = case viewAssign x of AssignExtend t _ -> t -- | Return the last element in the assignment. last :: Assignment f (ctx '::> tp) -> f tp last x = case viewAssign x of AssignExtend _ e -> e {-# DEPRECATED view "Use viewAssign or the Empty and :> patterns instead." #-} -- | View an assignment as either empty or an assignment with one appended. view :: forall f ctx . Assignment f ctx -> AssignView f ctx view = viewAssign -- | Return the prefix of an appended 'Assignment' take :: forall f ctx ctx'. Size ctx -> Size ctx' -> Assignment f (ctx <+> ctx') -> Assignment f ctx take sz sz' asgn = let diff = appendDiff sz' in generate sz (\i -> asgn ! extendIndex' diff i) -- | Return the suffix of an appended 'Assignment' drop :: forall f ctx ctx'. Size ctx -> Size ctx' -> Assignment f (ctx <+> ctx') -> Assignment f ctx' drop sz sz' asgn = generate sz' (\i -> asgn ! extendIndexAppendLeft sz sz' i) -------------------------------------------------------------------------------- -- Context embedding. -- | This datastructure contains a proof that the first context is -- embeddable in the second. This is useful if we want to add extend -- an existing term under a larger context. data CtxEmbedding (ctx :: Ctx k) (ctx' :: Ctx k) = CtxEmbedding { _ctxeSize :: Size ctx' , _ctxeAssignment :: Assignment (Index ctx') ctx } -- Alternate encoding? -- data CtxEmbedding ctx ctx' where -- EIdentity :: CtxEmbedding ctx ctx -- ExtendBoth :: CtxEmbedding ctx ctx' -> CtxEmbedding (ctx ::> tp) (ctx' ::> tp) -- ExtendOne :: CtxEmbedding ctx ctx' -> CtxEmbedding ctx (ctx' ::> tp) ctxeSize :: Simple Lens (CtxEmbedding ctx ctx') (Size ctx') ctxeSize = lens _ctxeSize (\s v -> s { _ctxeSize = v }) ctxeAssignment :: Lens (CtxEmbedding ctx1 ctx') (CtxEmbedding ctx2 ctx') (Assignment (Index ctx') ctx1) (Assignment (Index ctx') ctx2) ctxeAssignment = lens _ctxeAssignment (\s v -> s { _ctxeAssignment = v }) class ApplyEmbedding (f :: Ctx k -> Type) where applyEmbedding :: CtxEmbedding ctx ctx' -> f ctx -> f ctx' class ApplyEmbedding' (f :: Ctx k -> k' -> Type) where applyEmbedding' :: CtxEmbedding ctx ctx' -> f ctx v -> f ctx' v class ExtendContext (f :: Ctx k -> Type) where extendContext :: Diff ctx ctx' -> f ctx -> f ctx' class ExtendContext' (f :: Ctx k -> k' -> Type) where extendContext' :: Diff ctx ctx' -> f ctx v -> f ctx' v instance ApplyEmbedding' Index where applyEmbedding' ctxe idx = (ctxe ^. ctxeAssignment) ! idx instance ExtendContext' Index where extendContext' = extendIndex' -- -- This is the inefficient way of doing things. A better way is to -- -- just have a map between indices. -- applyEmbedding :: CtxEmbedding ctx ctx' -- -> Index ctx tp -> Index ctx' tp -- applyEmbedding ctxe idx = (ctxe ^. ctxeAssignment) ! idx identityEmbedding :: Size ctx -> CtxEmbedding ctx ctx identityEmbedding sz = CtxEmbedding sz (generate sz id) -- emptyEmbedding :: CtxEmbedding EmptyCtx EmptyCtx -- emptyEmbedding = identityEmbedding knownSize extendEmbeddingRightDiff :: forall ctx ctx' ctx''. Diff ctx' ctx'' -> CtxEmbedding ctx ctx' -> CtxEmbedding ctx ctx'' extendEmbeddingRightDiff diff (CtxEmbedding sz' assgn) = CtxEmbedding (extSize sz' diff) updated where updated :: Assignment (Index ctx'') ctx updated = fmapFC (extendIndex' diff) assgn extendEmbeddingRight :: CtxEmbedding ctx ctx' -> CtxEmbedding ctx (ctx' ::> tp) extendEmbeddingRight = extendEmbeddingRightDiff knownDiff -- | Prove that the prefix of an appended context is embeddable in it appendEmbedding :: Size ctx -> Size ctx' -> CtxEmbedding ctx (ctx <+> ctx') appendEmbedding sz sz' = CtxEmbedding (addSize sz sz') (generate sz (extendIndex' diff)) where diff = appendDiff sz' -- | Prove that the suffix of an appended context is embeddable in it appendEmbeddingLeft :: Size ctx -> Size ctx' -> CtxEmbedding ctx' (ctx <+> ctx') appendEmbeddingLeft sz sz' = CtxEmbedding (addSize sz sz') (generate sz' (extendIndexAppendLeft sz sz')) extendEmbeddingBoth :: forall ctx ctx' tp. CtxEmbedding ctx ctx' -> CtxEmbedding (ctx ::> tp) (ctx' ::> tp) extendEmbeddingBoth ctxe = updated & ctxeAssignment %~ flip extend (nextIndex (ctxe ^. ctxeSize)) where updated :: CtxEmbedding ctx (ctx' ::> tp) updated = extendEmbeddingRight ctxe -------------------------------------------------------------------------------- -- Static indexing based on type-level naturals -- | Get a lens for an position in an 'Assignment' by zero-based, left-to-right position. -- The position must be specified using @TypeApplications@ for the @n@ parameter. field :: forall n ctx f r. Idx n ctx r => Lens' (Assignment f ctx) (f r) field = ixF' (natIndex @n) -- | Constraint synonym used for getting an 'Index' into a 'Ctx'. -- @n@ is the zero-based, left-counted index into the list of types -- @ctx@ which has the type @r@. type Idx n ctx r = (ValidIx n ctx, Idx' (FromLeft ctx n) ctx r) -- | Compute an 'Index' value for a particular position in a 'Ctx'. The -- @TypeApplications@ extension will be needed to disambiguate the choice -- of the type @n@. natIndex :: forall n ctx r. Idx n ctx r => Index ctx r natIndex = natIndex' @_ @(FromLeft ctx n) -- | This version of 'natIndex' is suitable for use without the @TypeApplications@ -- extension. natIndexProxy :: forall n ctx r proxy. Idx n ctx r => proxy n -> Index ctx r natIndexProxy _ = natIndex @n ------------------------------------------------------------------------ -- Implementation ------------------------------------------------------------------------ -- | Class for computing 'Index' values for positions in a 'Ctx'. class KnownContext ctx => Idx' (n :: Nat) (ctx :: Ctx k) (r :: k) | n ctx -> r where natIndex' :: Index ctx r -- | Base-case instance KnownContext xs => Idx' 0 (xs '::> x) x where natIndex' = lastIndex knownSize -- | Inductive-step instance {-# Overlaps #-} (KnownContext xs, Idx' (n-1) xs r) => Idx' n (xs '::> x) r where natIndex' = skipIndex (natIndex' @_ @(n-1)) -------------------------------------------------------------------------------- -- * CurryAssignment -- | This type family is used to define currying\/uncurrying operations -- on assignments. It is best understood by seeing its evaluation on -- several examples: -- -- > CurryAssignment EmptyCtx f x = x -- > CurryAssignment (EmptyCtx ::> a) f x = f a -> x -- > CurryAssignment (EmptyCtx ::> a ::> b) f x = f a -> f b -> x -- > CurryAssignment (EmptyCtx ::> a ::> b ::> c) f x = f a -> f b -> f c -> x type family CurryAssignment (ctx :: Ctx k) (f :: k -> Type) (x :: Type) :: Type where CurryAssignment EmptyCtx f x = x CurryAssignment (ctx ::> a) f x = CurryAssignment ctx f (f a -> x) -- | This class implements two methods that witness the isomorphism between -- curried and uncurried functions. class CurryAssignmentClass (ctx :: Ctx k) where -- | Transform a function that accepts an assignment into one with a separate -- variable for each element of the assignment. curryAssignment :: (Assignment f ctx -> x) -> CurryAssignment ctx f x -- | Transform a curried function into one that accepts an assignment value. uncurryAssignment :: CurryAssignment ctx f x -> (Assignment f ctx -> x) instance CurryAssignmentClass EmptyCtx where curryAssignment k = k empty uncurryAssignment k _ = k instance CurryAssignmentClass ctx => CurryAssignmentClass (ctx ::> a) where curryAssignment k = curryAssignment (\asgn a -> k (asgn :> a)) uncurryAssignment k asgn = case viewAssign asgn of AssignExtend asgn' x -> uncurryAssignment k asgn' x -- | Create an assignment from a list of values. fromList :: [Some f] -> Some (Assignment f) fromList = go empty where go :: Assignment f ctx -> [Some f] -> Some (Assignment f) go prev [] = Some prev go prev (Some g:next) = (go $! prev `extend` g) next newtype Collector m w a = Collector { runCollector :: m w } instance Functor (Collector m w) where fmap _ (Collector x) = Collector x instance (Applicative m, Monoid w) => Applicative (Collector m w) where pure _ = Collector (pure mempty) Collector x <*> Collector y = Collector (App.liftA2 (<>) x y) -- | Visit each of the elements in an @Assignment@ in order -- from left to right and collect the results using the provided @Monoid@. traverseAndCollect :: (Monoid w, Applicative m) => (forall tp. Index ctx tp -> f tp -> m w) -> Assignment f ctx -> m w traverseAndCollect f = runCollector . traverseWithIndex (\i x -> Collector (f i x)) -- | Visit each of the elements in an @Assignment@ in order -- from left to right, executing an action with each. traverseWithIndex_ :: Applicative m => (forall tp . Index ctx tp -> f tp -> m ()) -> Assignment f ctx -> m () traverseWithIndex_ f = void . traverseAndCollect f -------------------------------------------------------------------------------- -- Size and Index values size1 :: Size (EmptyCtx ::> a) size1 = incSize zeroSize size2 :: Size (EmptyCtx ::> a ::> b) size2 = incSize size1 size3 :: Size (EmptyCtx ::> a ::> b ::> c) size3 = incSize size2 size4 :: Size (EmptyCtx ::> a ::> b ::> c ::> d) size4 = incSize size3 size5 :: Size (EmptyCtx ::> a ::> b ::> c ::> d ::> e) size5 = incSize size4 size6 :: Size (EmptyCtx ::> a ::> b ::> c ::> d ::> e ::> f) size6 = incSize size5 i1of2 :: Index (EmptyCtx ::> a ::> b) a i1of2 = skipIndex baseIndex i2of2 :: Index (EmptyCtx ::> a ::> b) b i2of2 = nextIndex size1 i1of3 :: Index (EmptyCtx ::> a ::> b ::> c) a i1of3 = skipIndex i1of2 i2of3 :: Index (EmptyCtx ::> a ::> b ::> c) b i2of3 = skipIndex i2of2 i3of3 :: Index (EmptyCtx ::> a ::> b ::> c) c i3of3 = nextIndex size2 i1of4 :: Index (EmptyCtx ::> a ::> b ::> c ::> d) a i1of4 = skipIndex i1of3 i2of4 :: Index (EmptyCtx ::> a ::> b ::> c ::> d) b i2of4 = skipIndex i2of3 i3of4 :: Index (EmptyCtx ::> a ::> b ::> c ::> d) c i3of4 = skipIndex i3of3 i4of4 :: Index (EmptyCtx ::> a ::> b ::> c ::> d) d i4of4 = nextIndex size3 i1of5 :: Index (EmptyCtx ::> a ::> b ::> c ::> d ::> e) a i1of5 = skipIndex i1of4 i2of5 :: Index (EmptyCtx ::> a ::> b ::> c ::> d ::> e) b i2of5 = skipIndex i2of4 i3of5 :: Index (EmptyCtx ::> a ::> b ::> c ::> d ::> e) c i3of5 = skipIndex i3of4 i4of5 :: Index (EmptyCtx ::> a ::> b ::> c ::> d ::> e) d i4of5 = skipIndex i4of4 i5of5 :: Index (EmptyCtx ::> a ::> b ::> c ::> d ::> e) e i5of5 = nextIndex size4 i1of6 :: Index (EmptyCtx ::> a ::> b ::> c ::> d ::> e ::> f) a i1of6 = skipIndex i1of5 i2of6 :: Index (EmptyCtx ::> a ::> b ::> c ::> d ::> e ::> f) b i2of6 = skipIndex i2of5 i3of6 :: Index (EmptyCtx ::> a ::> b ::> c ::> d ::> e ::> f) c i3of6 = skipIndex i3of5 i4of6 :: Index (EmptyCtx ::> a ::> b ::> c ::> d ::> e ::> f) d i4of6 = skipIndex i4of5 i5of6 :: Index (EmptyCtx ::> a ::> b ::> c ::> d ::> e ::> f) e i5of6 = skipIndex i5of5 i6of6 :: Index (EmptyCtx ::> a ::> b ::> c ::> d ::> e ::> f) f i6of6 = nextIndex size5 parameterized-utils-2.1.7.0/src/Data/Parameterized/Context/0000755000000000000000000000000007346545000021722 5ustar0000000000000000parameterized-utils-2.1.7.0/src/Data/Parameterized/Context/Safe.hs0000644000000000000000000011265007346545000023141 0ustar0000000000000000------------------------------------------------------------------------ -- | -- Module : Data.Parameterized.Context.Safe -- Copyright : (c) Galois, Inc 2014-2015 -- Maintainer : Joe Hendrix -- -- This module defines type contexts as a data-kind that consists of -- a list of types. Indexes are defined with respect to these contexts. -- In addition, finite dependent products (Assignments) are defined over -- type contexts. The elements of an assignment can be accessed using -- appropriately-typed indexes. -- -- This module is intended to export exactly the same API as module -- "Data.Parameterized.Context.Unsafe", so that they can be used -- interchangeably. -- -- This implementation is entirely typesafe, and provides a proof that -- the signature implemented by this module is consistent. Contexts, -- indexes, and assignments are represented naively by linear sequences. -- -- Compared to the implementation in "Data.Parameterized.Context.Unsafe", -- this one suffers from the fact that the operation of extending an -- the context of an index is /not/ a no-op. We therefore cannot use -- 'Data.Coerce.coerce' to understand indexes in a new context without -- actually breaking things. -------------------------------------------------------------------------- {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE IncoherentInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE StandaloneDeriving #-} #if __GLASGOW_HASKELL__ < 806 {-# LANGUAGE TypeInType #-} #endif {-# OPTIONS_HADDOCK hide #-} module Data.Parameterized.Context.Safe ( module Data.Parameterized.Ctx -- * Size , Size , sizeInt , zeroSize , incSize , decSize , extSize , addSize , SizeView(..) , viewSize , sizeToNatRepr , KnownContext(..) -- * Diff , Diff , noDiff , addDiff , extendRight , appendDiff , DiffView(..) , viewDiff , KnownDiff(..) , IsAppend(..) , diffIsAppend -- * Indexing , Index , indexVal , baseIndex , skipIndex , lastIndex , nextIndex , leftIndex , rightIndex , extendIndex , extendIndex' , extendIndexAppendLeft , forIndex , forIndexRange , intIndex , IndexView(..) , viewIndex -- * Assignments , Assignment , size , Data.Parameterized.Context.Safe.replicate , generate , generateM , empty , extend , adjust , update , adjustM , AssignView(..) , viewAssign , (!) , (!^) , zipWith , zipWithM , (<++>) , traverseWithIndex ) where import qualified Control.Category as Cat import Control.DeepSeq import qualified Control.Lens as Lens import Control.Monad.Identity (Identity(..)) import Data.Hashable import Data.List (intercalate) import Data.Maybe (listToMaybe) import Data.Type.Equality import Prelude hiding (init, map, null, replicate, succ, zipWith) import Data.Kind(Type) import Data.Parameterized.Classes import Data.Parameterized.Ctx import Data.Parameterized.NatRepr import Data.Parameterized.Some import Data.Parameterized.TraversableFC import Data.Parameterized.TraversableFC.WithIndex ------------------------------------------------------------------------ -- Size -- | An indexed singleton type representing the size of a context. data Size (ctx :: Ctx k) where SizeZero :: Size 'EmptyCtx SizeSucc :: !(Size ctx) -> Size (ctx '::> tp) -- | Renders as integer literal instance Show (Size ctx) where show = show . sizeInt instance ShowF Size -- | Convert a context size to an 'Int'. sizeInt :: Size ctx -> Int sizeInt SizeZero = 0 sizeInt (SizeSucc sz) = (+1) $! sizeInt sz -- | The size of an empty context. zeroSize :: Size 'EmptyCtx zeroSize = SizeZero -- | Increment the size to the next value. incSize :: Size ctx -> Size (ctx '::> tp) incSize sz = SizeSucc sz decSize :: Size (ctx '::> tp) -> Size ctx decSize (SizeSucc sz) = sz -- | The total size of two concatenated contexts. addSize :: Size x -> Size y -> Size (x <+> y) addSize sx SizeZero = sx addSize sx (SizeSucc sy) = SizeSucc (addSize sx sy) -- | Allows interpreting a size. data SizeView (ctx :: Ctx k) where ZeroSize :: SizeView 'EmptyCtx IncSize :: !(Size ctx) -> SizeView (ctx '::> tp) -- | View a size as either zero or a smaller size plus one. viewSize :: Size ctx -> SizeView ctx viewSize SizeZero = ZeroSize viewSize (SizeSucc s) = IncSize s -- | Convert a 'Size' into a 'NatRepr'. sizeToNatRepr :: Size items -> NatRepr (CtxSize items) sizeToNatRepr sz = case viewSize sz of ZeroSize -> knownRepr IncSize sz' -> let oldRep = sizeToNatRepr sz' in case plusComm (knownRepr :: NatRepr 1) oldRep of Refl -> incNat oldRep ------------------------------------------------------------------------ -- Size -- | A context that can be determined statically at compiler time. class KnownContext (ctx :: Ctx k) where knownSize :: Size ctx instance KnownContext 'EmptyCtx where knownSize = zeroSize instance KnownContext ctx => KnownContext (ctx '::> tp) where knownSize = incSize knownSize ------------------------------------------------------------------------ -- Diff -- | Difference in number of elements between two contexts. -- The first context must be a sub-context of the other. data Diff (l :: Ctx k) (r :: Ctx k) where DiffHere :: Diff ctx ctx DiffThere :: Diff ctx1 ctx2 -> Diff ctx1 (ctx2 '::> tp) -- | The identity difference. Identity element of 'Category' instance. noDiff :: Diff l l noDiff = DiffHere -- | The addition of differences. Flipped binary operation -- of 'Category' instance. addDiff :: Diff a b -> Diff b c -> Diff a c addDiff x DiffHere = x addDiff x (DiffThere y) = DiffThere (addDiff x y) -- | Extend the difference to a sub-context of the right side. extendRight :: Diff l r -> Diff l (r '::> tp) extendRight diff = DiffThere diff appendDiff :: Size r -> Diff l (l <+> r) appendDiff SizeZero = DiffHere appendDiff (SizeSucc sz) = DiffThere (appendDiff sz) -- | Implemented with 'noDiff' and 'addDiff' instance Cat.Category Diff where id = DiffHere d1 . d2 = addDiff d2 d1 -- | Extend the size by a given difference. extSize :: Size l -> Diff l r -> Size r extSize sz DiffHere = sz extSize sz (DiffThere diff) = incSize (extSize sz diff) -- | Proof that @r = l <+> app@ for some @app@ data IsAppend l r where IsAppend :: Size app -> IsAppend l (l <+> app) -- | If @l@ is a sub-context of @r@ then extract out their "contextual -- difference", i.e., the @app@ such that @r = l <+> app@ diffIsAppend :: Diff l r -> IsAppend l r diffIsAppend DiffHere = IsAppend zeroSize diffIsAppend (DiffThere diff) = case diffIsAppend diff of IsAppend sz -> IsAppend (incSize sz) data DiffView a b where NoDiff :: DiffView a a ExtendRightDiff :: Diff a b -> DiffView a (b ::> r) viewDiff :: Diff a b -> DiffView a b viewDiff DiffHere = NoDiff viewDiff (DiffThere diff) = ExtendRightDiff diff ------------------------------------------------------------------------ -- KnownDiff -- | A difference that can be automatically inferred at compile time. class KnownDiff (l :: Ctx k) (r :: Ctx k) where knownDiff :: Diff l r instance KnownDiff l l where knownDiff = noDiff instance KnownDiff l r => KnownDiff l (r '::> tp) where knownDiff = extendRight knownDiff ------------------------------------------------------------------------ -- Index -- | An index is a reference to a position with a particular type in a -- context. data Index (ctx :: Ctx k) (tp :: k) where IndexHere :: Size ctx -> Index (ctx '::> tp) tp IndexThere :: !(Index ctx tp) -> Index (ctx '::> tp') tp -- | Convert an index to an 'Int', where the index of the left-most type in the context is 0. indexVal :: Index ctx tp -> Int indexVal (IndexHere sz) = sizeInt sz indexVal (IndexThere idx) = indexVal idx instance Eq (Index ctx tp) where idx1 == idx2 = isJust (testEquality idx1 idx2) instance TestEquality (Index ctx) where testEquality (IndexHere _) (IndexHere _) = Just Refl testEquality (IndexHere _) (IndexThere _) = Nothing testEquality (IndexThere _) (IndexHere _) = Nothing testEquality (IndexThere idx1) (IndexThere idx2) = case testEquality idx1 idx2 of Just Refl -> Just Refl Nothing -> Nothing instance Ord (Index ctx tp) where compare i j = toOrdering (compareF i j) instance OrdF (Index ctx) where compareF (IndexHere _) (IndexHere _) = EQF compareF (IndexThere _) (IndexHere _) = LTF compareF (IndexHere _) (IndexThere _) = GTF compareF (IndexThere idx1) (IndexThere idx2) = lexCompareF idx1 idx2 $ EQF -- | Index for first element in context. baseIndex :: Index ('EmptyCtx '::> tp) tp baseIndex = IndexHere SizeZero -- | Increase context while staying at same index. skipIndex :: Index ctx x -> Index (ctx '::> y) x skipIndex idx = IndexThere idx -- | Return the index of an element one past the size. nextIndex :: Size ctx -> Index (ctx '::> tp) tp nextIndex sz = IndexHere sz -- | Return the last index of a element. lastIndex :: Size (ctx ::> tp) -> Index (ctx ::> tp) tp lastIndex (SizeSucc s) = IndexHere s -- | Adapts an index in the left hand context of an append operation. leftIndex :: Size r -> Index l tp -> Index (l <+> r) tp leftIndex sr il = extendIndex' (appendDiff sr) il -- | Adapts an index in the right hand context of an append operation. rightIndex :: Size l -> Size r -> Index r tp -> Index (l <+> r) tp rightIndex sl sr ir = case viewIndex sr ir of IndexViewInit i -> skipIndex (rightIndex sl (decSize sr) i) IndexViewLast s -> lastIndex (incSize (addSize sl s)) {-# INLINE extendIndex #-} extendIndex :: KnownDiff l r => Index l tp -> Index r tp extendIndex = extendIndex' knownDiff {-# INLINE extendIndex' #-} -- | Compute an 'Index' into a context @r@ from an 'Index' into -- a sub-context @l@ of @r@. extendIndex' :: Diff l r -> Index l tp -> Index r tp extendIndex' DiffHere idx = idx extendIndex' (DiffThere diff) idx = IndexThere (extendIndex' diff idx) {-# INLINE extendIndexAppendLeft #-} -- | Compute an 'Index' into an appended context from an 'Index' into -- its suffix. extendIndexAppendLeft :: Size l -> Size r -> Index r tp -> Index (l <+> r) tp extendIndexAppendLeft sz sz' idx = case viewIndex sz' idx of IndexViewLast _ -> lastIndex (addSize sz sz') IndexViewInit idx' -> skipIndex (extendIndexAppendLeft sz (decSize sz') idx') -- | Given a size @n@, a function @f@, and an initial value @v0@, the -- expression @forIndex n f v0@ calls @f@ on each index less than @n@ -- starting from @0@ and @v0@, with the value @v@ obtained from the -- last call. forIndex :: forall ctx r . Size ctx -> (forall tp . r -> Index ctx tp -> r) -> r -> r forIndex sz_top f = go id sz_top where go :: forall ctx'. (forall tp. Index ctx' tp -> Index ctx tp) -> Size ctx' -> r -> r go _ SizeZero = id go g (SizeSucc sz) = \r -> go (\i -> g (IndexThere i)) sz $ f r (g (IndexHere sz)) data LDiff (l :: Ctx k) (r :: Ctx k) where LDiffHere :: LDiff a a LDiffThere :: !(LDiff (a::>x) b) -> LDiff a b ldiffIndex :: Index a tp -> LDiff a b -> Index b tp ldiffIndex i LDiffHere = i ldiffIndex i (LDiffThere d) = ldiffIndex (IndexThere i) d forIndexLDiff :: Size a -> LDiff a b -> (forall tp . Index b tp -> r -> r) -> r -> r forIndexLDiff _ LDiffHere _ r = r forIndexLDiff sz (LDiffThere d) f r = forIndexLDiff (SizeSucc sz) d f (f (ldiffIndex (IndexHere sz) d) r) forIndexRangeImpl :: Int -> Size a -> LDiff a b -> (forall tp . Index b tp -> r -> r) -> r -> r forIndexRangeImpl 0 sz d f r = forIndexLDiff sz d f r forIndexRangeImpl _ SizeZero _ _ r = r forIndexRangeImpl i (SizeSucc sz) d f r = forIndexRangeImpl (i-1) sz (LDiffThere d) f r -- | Given an index @i@, size @n@, a function @f@, and a value @v@, -- the expression @forIndexRange i n f v@ is equivalent -- to @v@ when @i >= sizeInt n@, and @f i (forIndexRange (i+1) n f v)@ -- otherwise. forIndexRange :: Int -> Size ctx -> (forall tp . Index ctx tp -> r -> r) -> r -> r forIndexRange i sz f r = forIndexRangeImpl i sz LDiffHere f r indexList :: forall ctx. Size ctx -> [Some (Index ctx)] indexList sz_top = go id [] sz_top where go :: (forall tp. Index ctx' tp -> Index ctx tp) -> [Some (Index ctx)] -> Size ctx' -> [Some (Index ctx)] go _ ls SizeZero = ls go g ls (SizeSucc sz) = go (\i -> g (IndexThere i)) (Some (g (IndexHere sz)) : ls) sz -- | Return index at given integer or nothing if integer is out of bounds. intIndex :: Int -> Size ctx -> Maybe (Some (Index ctx)) intIndex n sz = listToMaybe $ drop n $ indexList sz -- | Renders as integer literal instance Show (Index ctx tp) where show = show . indexVal instance ShowF (Index ctx) -- | View of indexes as pointing to the last element in the -- index range or pointing to an earlier element in a smaller -- range. data IndexView ctx tp where IndexViewLast :: Size ctx -> IndexView (ctx '::> t) t IndexViewInit :: Index ctx t -> IndexView (ctx '::> u) t instance ShowF (IndexView ctx) deriving instance Show (IndexView ctx tp) -- | Project an index viewIndex :: Size ctx -> Index ctx tp -> IndexView ctx tp viewIndex _ (IndexHere sz) = IndexViewLast sz viewIndex _ (IndexThere i) = IndexViewInit i -- NB: the unused size parameter is needed in the Unsafe module ------------------------------------------------------------------------ -- Assignment -- | An assignment is a sequence that maps each index with type 'tp' to -- a value of type 'f tp'. data Assignment (f :: k -> Type) (ctx :: Ctx k) where AssignmentEmpty :: Assignment f EmptyCtx AssignmentExtend :: Assignment f ctx -> f tp -> Assignment f (ctx ::> tp) -- | View an assignment as either empty or an assignment with one appended. data AssignView (f :: k -> Type) (ctx :: Ctx k) where AssignEmpty :: AssignView f EmptyCtx AssignExtend :: Assignment f ctx -> f tp -> AssignView f (ctx::>tp) viewAssign :: forall f ctx . Assignment f ctx -> AssignView f ctx viewAssign AssignmentEmpty = AssignEmpty viewAssign (AssignmentExtend asgn x) = AssignExtend asgn x instance NFData (Assignment f ctx) where rnf AssignmentEmpty = () rnf (AssignmentExtend asgn x) = rnf asgn `seq` x `seq` () -- | Return number of elements in assignment. size :: Assignment f ctx -> Size ctx size AssignmentEmpty = SizeZero size (AssignmentExtend asgn _) = SizeSucc (size asgn) -- | Generate an assignment generate :: forall ctx f . Size ctx -> (forall tp . Index ctx tp -> f tp) -> Assignment f ctx generate sz_top f = go id sz_top where go :: forall ctx' . (forall tp. Index ctx' tp -> Index ctx tp) -> Size ctx' -> Assignment f ctx' go _ SizeZero = AssignmentEmpty go g (SizeSucc sz) = let ctx = go (\i -> g (IndexThere i)) sz x = f (g (IndexHere sz)) in AssignmentExtend ctx x -- | Generate an assignment generateM :: forall ctx m f . Applicative m => Size ctx -> (forall tp . Index ctx tp -> m (f tp)) -> m (Assignment f ctx) generateM sz_top f = go id sz_top where go :: forall ctx'. (forall tp. Index ctx' tp -> Index ctx tp) -> Size ctx' -> m (Assignment f ctx') go _ SizeZero = pure AssignmentEmpty go g (SizeSucc sz) = AssignmentExtend <$> (go (\i -> g (IndexThere i)) sz) <*> f (g (IndexHere sz)) -- | @replicate n@ make a context with different copies of the same -- polymorphic value. replicate :: Size ctx -> (forall tp . f tp) -> Assignment f ctx replicate n c = generate n (\_ -> c) -- | Create empty indexed vector. empty :: Assignment f 'EmptyCtx empty = AssignmentEmpty -- n.b. see 'singleton' in Data/Parameterized/Context.hs -- | Extend an indexed vector with a new entry. extend :: Assignment f ctx -> f tp -> Assignment f (ctx '::> tp) extend asgn e = AssignmentExtend asgn e {-# DEPRECATED adjust "Replace 'adjust f i asgn' with 'Lens.over (ixF i) f asgn' instead." #-} adjust :: forall f ctx tp. (f tp -> f tp) -> Index ctx tp -> Assignment f ctx -> Assignment f ctx adjust f idx asgn = runIdentity (adjustM (Identity . f) idx asgn) {-# DEPRECATED update "Replace 'update idx val asgn' with 'Lens.set (ixF idx) val asgn' instead." #-} update :: forall f ctx tp. Index ctx tp -> f tp -> Assignment f ctx -> Assignment f ctx update i v a = adjust (\_ -> v) i a adjustM :: forall m f ctx tp. Functor m => (f tp -> m (f tp)) -> Index ctx tp -> Assignment f ctx -> m (Assignment f ctx) adjustM f = go (\x -> x) where go :: (forall tp'. g tp' -> f tp') -> Index ctx' tp -> Assignment g ctx' -> m (Assignment f ctx') go g (IndexHere _) (AssignmentExtend asgn x) = AssignmentExtend (map g asgn) <$> f (g x) go g (IndexThere idx) (AssignmentExtend asgn x) = flip AssignmentExtend (g x) <$> go g idx asgn type instance IndexF (Assignment (f :: k -> Type) ctx) = Index ctx type instance IxValueF (Assignment (f :: k -> Type) ctx) = f instance forall k (f :: k -> Type) ctx. IxedF k (Assignment f ctx) where ixF :: Index ctx x -> Lens.Traversal' (Assignment f ctx) (f x) ixF idx f = adjustM f idx instance forall k (f :: k -> Type) ctx. IxedF' k (Assignment f ctx) where ixF' :: Index ctx x -> Lens.Lens' (Assignment f ctx) (f x) ixF' idx f = adjustM f idx idxlookup :: (forall tp. a tp -> b tp) -> Assignment a ctx -> forall tp. Index ctx tp -> b tp idxlookup f (AssignmentExtend _ x) (IndexHere _) = f x idxlookup f (AssignmentExtend ctx _) (IndexThere idx) = idxlookup f ctx idx idxlookup _ AssignmentEmpty idx = case idx of {} -- | Return value of assignment. (!) :: Assignment f ctx -> Index ctx tp -> f tp (!) asgn idx = idxlookup id asgn idx -- | Return value of assignment, where the index is into an -- initial sequence of the assignment. (!^) :: KnownDiff l r => Assignment f r -> Index l tp -> f tp a !^ i = a ! extendIndex i instance TestEquality f => Eq (Assignment f ctx) where x == y = isJust (testEquality x y) testEq :: (forall x y. f x -> f y -> Maybe (x :~: y)) -> Assignment f cxt1 -> Assignment f cxt2 -> Maybe (cxt1 :~: cxt2) testEq _ AssignmentEmpty AssignmentEmpty = Just Refl testEq test (AssignmentExtend ctx1 x1) (AssignmentExtend ctx2 x2) = case testEq test ctx1 ctx2 of Nothing -> Nothing Just Refl -> case test x1 x2 of Nothing -> Nothing Just Refl -> Just Refl testEq _ AssignmentEmpty AssignmentExtend{} = Nothing testEq _ AssignmentExtend{} AssignmentEmpty = Nothing instance TestEqualityFC Assignment where testEqualityFC f = testEq f instance TestEquality f => TestEquality (Assignment f) where testEquality x y = testEq testEquality x y instance TestEquality f => PolyEq (Assignment f x) (Assignment f y) where polyEqF x y = fmap (\Refl -> Refl) $ testEquality x y compareAsgn :: (forall x y. f x -> f y -> OrderingF x y) -> Assignment f ctx1 -> Assignment f ctx2 -> OrderingF ctx1 ctx2 compareAsgn _ AssignmentEmpty AssignmentEmpty = EQF compareAsgn _ AssignmentEmpty _ = GTF compareAsgn _ _ AssignmentEmpty = LTF compareAsgn test (AssignmentExtend ctx1 x) (AssignmentExtend ctx2 y) = case compareAsgn test ctx1 ctx2 of LTF -> LTF GTF -> GTF EQF -> case test x y of LTF -> LTF GTF -> GTF EQF -> EQF instance OrdFC Assignment where compareFC f = compareAsgn f instance OrdF f => OrdF (Assignment f) where compareF = compareAsgn compareF instance OrdF f => Ord (Assignment f ctx) where compare x y = toOrdering (compareF x y) instance Hashable (Index ctx tp) where hashWithSalt = hashWithSaltF instance HashableF (Index ctx) where hashWithSaltF s i = hashWithSalt s (indexVal i) instance (HashableF f, TestEquality f) => HashableF (Assignment f) where hashWithSaltF = hashWithSalt instance (HashableF f, TestEquality f) => Hashable (Assignment f ctx) where hashWithSalt s AssignmentEmpty = s hashWithSalt s (AssignmentExtend asgn x) = (s `hashWithSalt` asgn) `hashWithSaltF` x instance ShowF f => Show (Assignment f ctx) where show a = "[" ++ intercalate ", " (toList showF a) ++ "]" instance ShowF f => ShowF (Assignment f) instance FunctorFC Assignment where fmapFC = fmapFCDefault instance FoldableFC Assignment where foldMapFC = foldMapFCDefault instance TraversableFC Assignment where traverseFC f = traverseF f instance FunctorFCWithIndex Assignment where imapFC = imapFCDefault instance FoldableFCWithIndex Assignment where ifoldMapFC = ifoldMapFCDefault instance TraversableFCWithIndex Assignment where itraverseFC = traverseWithIndex -- | Map assignment map :: (forall tp . f tp -> g tp) -> Assignment f c -> Assignment g c map f = fmapFC f traverseF :: forall k (f:: k -> Type) (g::k -> Type) (m:: Type -> Type) (c::Ctx k) . Applicative m => (forall tp . f tp -> m (g tp)) -> Assignment f c -> m (Assignment g c) traverseF _ AssignmentEmpty = pure AssignmentEmpty traverseF f (AssignmentExtend asgn x) = pure AssignmentExtend <*> traverseF f asgn <*> f x -- | Convert assignment to list. toList :: (forall tp . f tp -> a) -> Assignment f c -> [a] toList f = toListFC f zipWithM :: Applicative m => (forall tp . f tp -> g tp -> m (h tp)) -> Assignment f c -> Assignment g c -> m (Assignment h c) zipWithM f x y = go x y where go AssignmentEmpty AssignmentEmpty = pure AssignmentEmpty go (AssignmentExtend asgn1 x1) (AssignmentExtend asgn2 x2) = AssignmentExtend <$> (zipWithM f asgn1 asgn2) <*> (f x1 x2) zipWith :: (forall x . f x -> g x -> h x) -> Assignment f a -> Assignment g a -> Assignment h a zipWith f = \x y -> runIdentity $ zipWithM (\u v -> pure (f u v)) x y {-# INLINE zipWith #-} -- | This is a specialization of 'itraverseFC'. traverseWithIndex :: Applicative m => (forall tp . Index ctx tp -> f tp -> m (g tp)) -> Assignment f ctx -> m (Assignment g ctx) traverseWithIndex f a = generateM (size a) $ \i -> f i (a ! i) (<++>) :: Assignment f x -> Assignment f y -> Assignment f (x <+> y) x <++> AssignmentEmpty = x x <++> AssignmentExtend y t = AssignmentExtend (x <++> y) t ------------------------------------------------------------------------ -- KnownRepr instances instance (KnownRepr (Assignment f) ctx, KnownRepr f bt) => KnownRepr (Assignment f) (ctx ::> bt) where knownRepr = knownRepr `extend` knownRepr instance KnownRepr (Assignment f) EmptyCtx where knownRepr = empty -------------------------------------------------------------------------------------- -- lookups and update for lenses data MyNat where MyZ :: MyNat MyS :: MyNat -> MyNat type MyZ = 'MyZ type MyS = 'MyS data MyNatRepr :: MyNat -> Type where MyZR :: MyNatRepr MyZ MySR :: MyNatRepr n -> MyNatRepr (MyS n) type family StrongCtxUpdate (n::MyNat) (ctx::Ctx k) (z::k) :: Ctx k where StrongCtxUpdate n EmptyCtx z = EmptyCtx StrongCtxUpdate MyZ (ctx::>x) z = ctx ::> z StrongCtxUpdate (MyS n) (ctx::>x) z = (StrongCtxUpdate n ctx z) ::> x type family MyNatLookup (n::MyNat) (ctx::Ctx k) (f::k -> Type) :: Type where MyNatLookup n EmptyCtx f = () MyNatLookup MyZ (ctx::>x) f = f x MyNatLookup (MyS n) (ctx::>x) f = MyNatLookup n ctx f mynat_lookup :: MyNatRepr n -> Assignment f ctx -> MyNatLookup n ctx f mynat_lookup _ AssignmentEmpty = () mynat_lookup MyZR (AssignmentExtend _ x) = x mynat_lookup (MySR n) (AssignmentExtend asgn _) = mynat_lookup n asgn strong_ctx_update :: MyNatRepr n -> Assignment f ctx -> f tp -> Assignment f (StrongCtxUpdate n ctx tp) strong_ctx_update _ AssignmentEmpty _ = AssignmentEmpty strong_ctx_update MyZR (AssignmentExtend asgn _) z = AssignmentExtend asgn z strong_ctx_update (MySR n) (AssignmentExtend asgn x) z = AssignmentExtend (strong_ctx_update n asgn z) x ------------------------------------------------------------------------ -- 1 field lens combinators type Assignment1 f x1 = Assignment f ('EmptyCtx '::> x1) instance Lens.Field1 (Assignment1 f t) (Assignment1 f u) (f t) (f u) where _1 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MyZR ------------------------------------------------------------------------ -- 2 field lens combinators type Assignment2 f x1 x2 = Assignment f ('EmptyCtx '::> x1 '::> x2) instance Lens.Field1 (Assignment2 f t x2) (Assignment2 f u x2) (f t) (f u) where _1 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MyZR instance Lens.Field2 (Assignment2 f x1 t) (Assignment2 f x1 u) (f t) (f u) where _2 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MyZR ------------------------------------------------------------------------ -- 3 field lens combinators type Assignment3 f x1 x2 x3 = Assignment f ('EmptyCtx '::> x1 '::> x2 '::> x3) instance Lens.Field1 (Assignment3 f t x2 x3) (Assignment3 f u x2 x3) (f t) (f u) where _1 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MySR $ MyZR instance Lens.Field2 (Assignment3 f x1 t x3) (Assignment3 f x1 u x3) (f t) (f u) where _2 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MyZR instance Lens.Field3 (Assignment3 f x1 x2 t) (Assignment3 f x1 x2 u) (f t) (f u) where _3 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MyZR ------------------------------------------------------------------------ -- 4 field lens combinators type Assignment4 f x1 x2 x3 x4 = Assignment f ('EmptyCtx '::> x1 '::> x2 '::> x3 '::> x4) instance Lens.Field1 (Assignment4 f t x2 x3 x4) (Assignment4 f u x2 x3 x4) (f t) (f u) where _1 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MySR $ MySR $ MyZR instance Lens.Field2 (Assignment4 f x1 t x3 x4) (Assignment4 f x1 u x3 x4) (f t) (f u) where _2 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MySR $ MyZR instance Lens.Field3 (Assignment4 f x1 x2 t x4) (Assignment4 f x1 x2 u x4) (f t) (f u) where _3 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MyZR instance Lens.Field4 (Assignment4 f x1 x2 x3 t) (Assignment4 f x1 x2 x3 u) (f t) (f u) where _4 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MyZR ------------------------------------------------------------------------ -- 5 field lens combinators type Assignment5 f x1 x2 x3 x4 x5 = Assignment f ('EmptyCtx '::> x1 '::> x2 '::> x3 '::> x4 '::> x5) instance Lens.Field1 (Assignment5 f t x2 x3 x4 x5) (Assignment5 f u x2 x3 x4 x5) (f t) (f u) where _1 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MySR $ MySR $ MySR $ MyZR instance Lens.Field2 (Assignment5 f x1 t x3 x4 x5) (Assignment5 f x1 u x3 x4 x5) (f t) (f u) where _2 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MySR $ MySR $ MyZR instance Lens.Field3 (Assignment5 f x1 x2 t x4 x5) (Assignment5 f x1 x2 u x4 x5) (f t) (f u) where _3 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MySR $ MyZR instance Lens.Field4 (Assignment5 f x1 x2 x3 t x5) (Assignment5 f x1 x2 x3 u x5) (f t) (f u) where _4 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MyZR instance Lens.Field5 (Assignment5 f x1 x2 x3 x4 t) (Assignment5 f x1 x2 x3 x4 u) (f t) (f u) where _5 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MyZR ------------------------------------------------------------------------ -- 6 field lens combinators type Assignment6 f x1 x2 x3 x4 x5 x6 = Assignment f ('EmptyCtx '::> x1 '::> x2 '::> x3 '::> x4 '::> x5 '::> x6) instance Lens.Field1 (Assignment6 f t x2 x3 x4 x5 x6) (Assignment6 f u x2 x3 x4 x5 x6) (f t) (f u) where _1 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MySR $ MySR $ MySR $ MySR $ MyZR instance Lens.Field2 (Assignment6 f x1 t x3 x4 x5 x6) (Assignment6 f x1 u x3 x4 x5 x6) (f t) (f u) where _2 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MySR $ MySR $ MySR $ MyZR instance Lens.Field3 (Assignment6 f x1 x2 t x4 x5 x6) (Assignment6 f x1 x2 u x4 x5 x6) (f t) (f u) where _3 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MySR $ MySR $ MyZR instance Lens.Field4 (Assignment6 f x1 x2 x3 t x5 x6) (Assignment6 f x1 x2 x3 u x5 x6) (f t) (f u) where _4 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MySR $ MyZR instance Lens.Field5 (Assignment6 f x1 x2 x3 x4 t x6) (Assignment6 f x1 x2 x3 x4 u x6) (f t) (f u) where _5 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MyZR instance Lens.Field6 (Assignment6 f x1 x2 x3 x4 x5 t) (Assignment6 f x1 x2 x3 x4 x5 u) (f t) (f u) where _6 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MyZR ------------------------------------------------------------------------ -- 7 field lens combinators type Assignment7 f x1 x2 x3 x4 x5 x6 x7 = Assignment f ('EmptyCtx '::> x1 '::> x2 '::> x3 '::> x4 '::> x5 '::> x6 '::> x7) instance Lens.Field1 (Assignment7 f t x2 x3 x4 x5 x6 x7) (Assignment7 f u x2 x3 x4 x5 x6 x7) (f t) (f u) where _1 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MySR $ MySR $ MySR $ MySR $ MySR $ MyZR instance Lens.Field2 (Assignment7 f x1 t x3 x4 x5 x6 x7) (Assignment7 f x1 u x3 x4 x5 x6 x7) (f t) (f u) where _2 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MySR $ MySR $ MySR $ MySR $ MyZR instance Lens.Field3 (Assignment7 f x1 x2 t x4 x5 x6 x7) (Assignment7 f x1 x2 u x4 x5 x6 x7) (f t) (f u) where _3 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MySR $ MySR $ MySR $ MyZR instance Lens.Field4 (Assignment7 f x1 x2 x3 t x5 x6 x7) (Assignment7 f x1 x2 x3 u x5 x6 x7) (f t) (f u) where _4 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MySR $ MySR $ MyZR instance Lens.Field5 (Assignment7 f x1 x2 x3 x4 t x6 x7) (Assignment7 f x1 x2 x3 x4 u x6 x7) (f t) (f u) where _5 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MySR $ MyZR instance Lens.Field6 (Assignment7 f x1 x2 x3 x4 x5 t x7) (Assignment7 f x1 x2 x3 x4 x5 u x7) (f t) (f u) where _6 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MyZR instance Lens.Field7 (Assignment7 f x1 x2 x3 x4 x5 x6 t) (Assignment7 f x1 x2 x3 x4 x5 x6 u) (f t) (f u) where _7 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MyZR ------------------------------------------------------------------------ -- 8 field lens combinators type Assignment8 f x1 x2 x3 x4 x5 x6 x7 x8 = Assignment f ('EmptyCtx '::> x1 '::> x2 '::> x3 '::> x4 '::> x5 '::> x6 '::> x7 '::> x8) instance Lens.Field1 (Assignment8 f t x2 x3 x4 x5 x6 x7 x8) (Assignment8 f u x2 x3 x4 x5 x6 x7 x8) (f t) (f u) where _1 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MySR $ MySR $ MySR $ MySR $ MySR $ MySR $ MyZR instance Lens.Field2 (Assignment8 f x1 t x3 x4 x5 x6 x7 x8) (Assignment8 f x1 u x3 x4 x5 x6 x7 x8) (f t) (f u) where _2 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MySR $ MySR $ MySR $ MySR $ MySR $ MyZR instance Lens.Field3 (Assignment8 f x1 x2 t x4 x5 x6 x7 x8) (Assignment8 f x1 x2 u x4 x5 x6 x7 x8) (f t) (f u) where _3 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MySR $ MySR $ MySR $ MySR $ MyZR instance Lens.Field4 (Assignment8 f x1 x2 x3 t x5 x6 x7 x8) (Assignment8 f x1 x2 x3 u x5 x6 x7 x8) (f t) (f u) where _4 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MySR $ MySR $ MySR $ MyZR instance Lens.Field5 (Assignment8 f x1 x2 x3 x4 t x6 x7 x8) (Assignment8 f x1 x2 x3 x4 u x6 x7 x8) (f t) (f u) where _5 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MySR $ MySR $ MyZR instance Lens.Field6 (Assignment8 f x1 x2 x3 x4 x5 t x7 x8) (Assignment8 f x1 x2 x3 x4 x5 u x7 x8) (f t) (f u) where _6 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MySR $ MyZR instance Lens.Field7 (Assignment8 f x1 x2 x3 x4 x5 x6 t x8) (Assignment8 f x1 x2 x3 x4 x5 x6 u x8) (f t) (f u) where _7 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MyZR instance Lens.Field8 (Assignment8 f x1 x2 x3 x4 x5 x6 x7 t) (Assignment8 f x1 x2 x3 x4 x5 x6 x7 u) (f t) (f u) where _8 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MyZR ------------------------------------------------------------------------ -- 9 field lens combinators type Assignment9 f x1 x2 x3 x4 x5 x6 x7 x8 x9 = Assignment f ('EmptyCtx '::> x1 '::> x2 '::> x3 '::> x4 '::> x5 '::> x6 '::> x7 '::> x8 '::> x9) instance Lens.Field1 (Assignment9 f t x2 x3 x4 x5 x6 x7 x8 x9) (Assignment9 f u x2 x3 x4 x5 x6 x7 x8 x9) (f t) (f u) where _1 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MySR $ MySR $ MySR $ MySR $ MySR $ MySR $ MySR $ MyZR instance Lens.Field2 (Assignment9 f x1 t x3 x4 x5 x6 x7 x8 x9) (Assignment9 f x1 u x3 x4 x5 x6 x7 x8 x9) (f t) (f u) where _2 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MySR $ MySR $ MySR $ MySR $ MySR $ MySR $ MyZR instance Lens.Field3 (Assignment9 f x1 x2 t x4 x5 x6 x7 x8 x9) (Assignment9 f x1 x2 u x4 x5 x6 x7 x8 x9) (f t) (f u) where _3 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MySR $ MySR $ MySR $ MySR $ MySR $ MyZR instance Lens.Field4 (Assignment9 f x1 x2 x3 t x5 x6 x7 x8 x9) (Assignment9 f x1 x2 x3 u x5 x6 x7 x8 x9) (f t) (f u) where _4 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MySR $ MySR $ MySR $ MySR $ MyZR instance Lens.Field5 (Assignment9 f x1 x2 x3 x4 t x6 x7 x8 x9) (Assignment9 f x1 x2 x3 x4 u x6 x7 x8 x9) (f t) (f u) where _5 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MySR $ MySR $ MySR $ MyZR instance Lens.Field6 (Assignment9 f x1 x2 x3 x4 x5 t x7 x8 x9) (Assignment9 f x1 x2 x3 x4 x5 u x7 x8 x9) (f t) (f u) where _6 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MySR $ MySR $ MyZR instance Lens.Field7 (Assignment9 f x1 x2 x3 x4 x5 x6 t x8 x9) (Assignment9 f x1 x2 x3 x4 x5 x6 u x8 x9) (f t) (f u) where _7 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MySR $ MyZR instance Lens.Field8 (Assignment9 f x1 x2 x3 x4 x5 x6 x7 t x9) (Assignment9 f x1 x2 x3 x4 x5 x6 x7 u x9) (f t) (f u) where _8 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MySR $ MyZR instance Lens.Field9 (Assignment9 f x1 x2 x3 x4 x5 x6 x7 x8 t) (Assignment9 f x1 x2 x3 x4 x5 x6 x7 x8 u) (f t) (f u) where _9 = Lens.lens (mynat_lookup n) (strong_ctx_update n) where n = MyZR parameterized-utils-2.1.7.0/src/Data/Parameterized/Context/Unsafe.hs0000644000000000000000000012324707346545000023510 0ustar0000000000000000{-# 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 parameterized-utils-2.1.7.0/src/Data/Parameterized/Ctx.hs0000644000000000000000000000715607346545000021401 0ustar0000000000000000{-| Description : Type-level lists. Copyright : (c) Galois, Inc 2015-2019 Maintainer : Joe Hendrix This module defines type-level lists used for representing the type of variables in a context. A 'Ctx' is never intended to be manipulated at the value level; it is used purely as a type-level list, just like @'[]@. To see how it is used, see the module header for "Data.Parameterized.Context". -} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE Safe #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Data.Parameterized.Ctx ( type Ctx(..) , EmptyCtx , SingleCtx , (::>) , type (<+>) -- * Type context manipulation , CtxSize , CtxLookup , CtxUpdate , CtxLookupRight , CtxUpdateRight , CtxFlatten , CheckIx , ValidIx , FromLeft ) where import Data.Kind (Constraint) import GHC.TypeLits (Nat, type (+), type (-), type (<=?), TypeError, ErrorMessage(..)) ------------------------------------------------------------------------ -- Ctx type EmptyCtx = 'EmptyCtx type (c :: Ctx k) ::> (a::k) = c '::> a type SingleCtx x = EmptyCtx ::> x -- | Kind @'Ctx' k@ comprises lists of types of kind @k@. data Ctx k = EmptyCtx | Ctx k ::> k -- | Append two type-level contexts. type family (<+>) (x :: Ctx k) (y :: Ctx k) :: Ctx k where x <+> EmptyCtx = x x <+> (y ::> e) = (x <+> y) ::> e -- | This type family computes the number of elements in a 'Ctx' type family CtxSize (a :: Ctx k) :: Nat where CtxSize 'EmptyCtx = 0 CtxSize (xs '::> x) = 1 + CtxSize xs -- | Helper type family used to generate descriptive error messages when -- an index is larger than the length of the 'Ctx' being indexed. type family CheckIx (ctx :: Ctx k) (n :: Nat) (b :: Bool) :: Constraint where CheckIx ctx n 'True = () CheckIx ctx n 'False = TypeError ('Text "Index " ':<>: 'ShowType n ':<>: 'Text " out of range in " ':<>: 'ShowType ctx) -- | A constraint that checks that the nat @n@ is a valid index into the -- context @ctx@, and raises a type error if not. type ValidIx (n :: Nat) (ctx :: Ctx k) = CheckIx ctx n (n+1 <=? CtxSize ctx) -- | 'Ctx' is a snoc-list. In order to use the more intuitive left-to-right -- ordering of elements the desired index is subtracted from the total -- number of elements. type FromLeft ctx n = CtxSize ctx - 1 - n -- | Lookup the value in a context by number, from the right type family CtxLookupRight (n :: Nat) (ctx :: Ctx k) :: k where CtxLookupRight 0 (ctx '::> r) = r CtxLookupRight n (ctx '::> r) = CtxLookupRight (n-1) ctx -- | Update the value in a context by number, from the right. If the index -- is out of range, the context is unchanged. type family CtxUpdateRight (n :: Nat) (x::k) (ctx :: Ctx k) :: Ctx k where CtxUpdateRight n x 'EmptyCtx = 'EmptyCtx CtxUpdateRight 0 x (ctx '::> old) = ctx '::> x CtxUpdateRight n x (ctx '::> y) = CtxUpdateRight (n-1) x ctx '::> y -- | Lookup the value in a context by number, from the left. -- Produce a type error if the index is out of range. type CtxLookup (n :: Nat) (ctx :: Ctx k) = CtxLookupRight (FromLeft ctx n) ctx -- | Update the value in a context by number, from the left. If the index -- is out of range, the context is unchanged. type CtxUpdate (n :: Nat) (x :: k) (ctx :: Ctx k) = CtxUpdateRight (FromLeft ctx n) x ctx -- | Flatten a nested context type family CtxFlatten (ctx :: Ctx (Ctx a)) :: Ctx a where CtxFlatten EmptyCtx = EmptyCtx CtxFlatten (ctxs ::> ctx) = CtxFlatten ctxs <+> ctx parameterized-utils-2.1.7.0/src/Data/Parameterized/Ctx/0000755000000000000000000000000007346545000021034 5ustar0000000000000000parameterized-utils-2.1.7.0/src/Data/Parameterized/Ctx/Proofs.hs0000644000000000000000000000107407346545000022642 0ustar0000000000000000{-| Description : type-level proofs involving contexts Copyright : (c) Galois, Inc 2015-2019 Maintainer : Joe Hendrix This reflects type level proofs involving contexts. -} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeOperators #-} module Data.Parameterized.Ctx.Proofs ( leftId , assoc ) where import Data.Type.Equality import Data.Parameterized.Axiom import Data.Parameterized.Ctx leftId :: p x -> (EmptyCtx <+> x) :~: x leftId _ = unsafeAxiom assoc :: p x -> q y -> r z -> x <+> (y <+> z) :~: (x <+> y) <+> z assoc _ _ _ = unsafeAxiom parameterized-utils-2.1.7.0/src/Data/Parameterized/DataKind.hs0000644000000000000000000000326507346545000022317 0ustar0000000000000000{-# 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|] ) ]) parameterized-utils-2.1.7.0/src/Data/Parameterized/DecidableEq.hs0000644000000000000000000000233507346545000022757 0ustar0000000000000000{-| Description : Decideable equality (i.e. evidence of non-equality) on type families Copyright : (c) Galois, Inc 2014-2019 Maintainer : Langston Barrett This defines a class @DecidableEq@, which represents decidable equality on a type family. This is different from GHC's @TestEquality@ in that it provides evidence of non-equality. In fact, it is a superclass of @TestEquality@. -} {-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE Safe #-} #if __GLASGOW_HASKELL__ < 806 {-# LANGUAGE TypeInType #-} #endif module Data.Parameterized.DecidableEq ( DecidableEq(..) ) where import Data.Void (Void) import Data.Type.Equality ((:~:)) -- | Decidable equality. class DecidableEq f where decEq :: f a -> f b -> Either (a :~: b) ((a :~: b) -> Void) -- TODO: instances for sums, products of types with decidable equality -- import Data.Type.Equality ((:~:), TestEquality(..)) -- instance (DecidableEq f) => TestEquality f where -- testEquality a b = -- case decEq a b of -- Left prf -> Just prf -- Right _ -> Nothing parameterized-utils-2.1.7.0/src/Data/Parameterized/Fin.hs0000644000000000000000000000757507346545000021364 0ustar0000000000000000{-# 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) parameterized-utils-2.1.7.0/src/Data/Parameterized/FinMap.hs0000644000000000000000000000616007346545000022007 0ustar0000000000000000{-| 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 parameterized-utils-2.1.7.0/src/Data/Parameterized/FinMap/0000755000000000000000000000000007346545000021450 5ustar0000000000000000parameterized-utils-2.1.7.0/src/Data/Parameterized/FinMap/Safe.hs0000644000000000000000000001627207346545000022672 0ustar0000000000000000{-| 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 parameterized-utils-2.1.7.0/src/Data/Parameterized/FinMap/Unsafe.hs0000644000000000000000000001704207346545000023231 0ustar0000000000000000{-| 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 parameterized-utils-2.1.7.0/src/Data/Parameterized/HashTable.hs0000644000000000000000000000611307346545000022466 0ustar0000000000000000------------------------------------------------------------------------ -- | -- Module : Data.Parameterized.HashTable -- Description : a hash table for parameterized keys and values -- Copyright : (c) Galois, Inc 2014-2019 -- Maintainer : Joe Hendrix -- -- This module provides a 'ST'-based hashtable for parameterized keys and values. -- -- NOTE: This API makes use of 'unsafeCoerce' to implement the parameterized -- hashtable abstraction. This should be type-safe provided that the -- 'TestEquality' instance on the key type is implemented soundly. ------------------------------------------------------------------------ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE Trustworthy #-} module Data.Parameterized.HashTable ( HashTable , new , newSized , clone , lookup , insert , member , delete , clear , Data.Parameterized.Classes.HashableF(..) , Control.Monad.ST.RealWorld ) where import Control.Applicative import Control.Monad.ST import qualified Data.HashTable.ST.Basic as H import Data.Kind import GHC.Exts (Any) import Unsafe.Coerce import Prelude hiding (lookup) import Data.Parameterized.Classes import Data.Parameterized.Some -- | A hash table mapping nonces to values. newtype HashTable s (key :: k -> Type) (val :: k -> Type) = HashTable (H.HashTable s (Some key) Any) -- | Create a new empty table. new :: ST s (HashTable s key val) new = HashTable <$> H.new -- | Create a new empty table to hold 'n' elements. newSized :: Int -> ST s (HashTable s k v) newSized n = HashTable <$> H.newSized n -- | Create a hash table that is a copy of the current one. clone :: (HashableF key, TestEquality key) => HashTable s key val -> ST s (HashTable s key val) clone (HashTable tbl) = do -- Create a new table r <- H.new -- Insert existing elements in H.mapM_ (uncurry (H.insert r)) tbl -- Return table return $! HashTable r -- | Lookup value of key in table. lookup :: (HashableF key, TestEquality key) => HashTable s key val -> key tp -> ST s (Maybe (val tp)) lookup (HashTable h) k = fmap unsafeCoerce <$> H.lookup h (Some k) {-# INLINE lookup #-} -- | Insert new key and value mapping into table. insert :: (HashableF key, TestEquality key) => HashTable s (key :: k -> Type) (val :: k -> Type) -> key tp -> val tp -> ST s () insert (HashTable h) k v = H.insert h (Some k) (unsafeCoerce v) -- | Return true if the key is in the hash table. member :: (HashableF key, TestEquality key) => HashTable s (key :: k -> Type) (val :: k -> Type) -> key (tp :: k) -> ST s Bool member (HashTable h) k = isJust <$> H.lookup h (Some k) -- | Delete an element from the hash table. delete :: (HashableF key, TestEquality key) => HashTable s (key :: k -> Type) (val :: k -> Type) -> key (tp :: k) -> ST s () delete (HashTable h) k = H.delete h (Some k) clear :: (HashableF key, TestEquality key) => HashTable s (key :: k -> Type) (val :: k -> Type) -> ST s () clear (HashTable h) = H.mapM_ (\(k,_) -> H.delete h k) h parameterized-utils-2.1.7.0/src/Data/Parameterized/List.hs0000644000000000000000000002766207346545000021562 0ustar0000000000000000{-| Description : A type-indexed parameterized list Copyright : (c) Galois, Inc 2017-2019 Maintainer : Joe Hendrix This module defines a list over two parameters. The first is a fixed type-level function @k -> *@ for some kind @k@, and the second is a list of types with kind @k@ that provide the indices for the values in the list. This type is closely related to the 'Data.Parameterized.Context.Assignment' type in "Data.Parameterized.Context". = Motivating example - the 'Data.Parameterized.List.List' type For this example, we need the following extensions: @ \{\-\# LANGUAGE DataKinds \#\-\} \{\-\# LANGUAGE GADTs \#\-\} \{\-\# LANGUAGE KindSignatures \#\-\} \{\-\# LANGUAGE TypeOperators \#\-\} @ We also require the following imports: @ import Data.Parameterized import Data.Parameterized.List import GHC.TypeLits @ Suppose we have a bitvector type: @ data BitVector (w :: Nat) :: * where BV :: NatRepr w -> Integer -> BitVector w @ This type contains a 'Data.Parameterized.NatRepr.NatRepr', a value-level representative of the vector width, and an 'Integer', containing the actual value of the bitvector. We can create values of this type as follows: @ BV (knownNat @8) 0xAB @ We can also create a smart constructor to handle the 'Data.Parameterized.NatRepr.NatRepr' automatically, when the width is known from the type context: @ bitVector :: KnownNat w => Integer -> BitVector w bitVector x = BV knownNat x @ Note that this does not check that the value can be represented in the given number of bits; that is not important for this example. If we wish to construct a list of @BitVector@s of a particular length, we can do: @ [bitVector 0xAB, bitVector 0xFF, bitVector 0] :: BitVector 8 @ However, what if we wish to construct a list of 'BitVector's of different lengths? We could try: @ [bitVector 0xAB :: BitVector 8, bitVector 0x1234 :: BitVector 16] @ However, this gives us an error: @ \:3:33: error: • Couldn't match type ‘16’ with ‘8’ Expected type: BitVector 8 Actual type: BitVector 16 • In the expression: bitVector 0x1234 :: BitVector 16 In the expression: [bitVector 0xAB :: BitVector 8, bitVector 0x1234 :: BitVector 16] In an equation for ‘it’: it = [bitVector 0xAB :: BitVector 8, bitVector 0x1234 :: BitVector 16] @ A vanilla Haskell list cannot contain two elements of different types, and even though the two elements here are both @BitVector@s, they do not have the same type! One solution is to use the 'Data.Parameterized.Some.Some' type: @ [Some (bitVector 0xAB :: BitVector 8), Some (bitVector 0x1234 :: BitVector 16)] @ The type of the above expression is @[Some BitVector]@, which may be perfectly acceptable. However, there is nothing in this type that tells us what the widths of the bitvectors are, or what the length of the overall list is. If we want to actually track that information on the type level, we can use the 'List' type from this module. @ (bitVector 0xAB :: BitVector 8) :< (bitVector 0x1234 :: BitVector 16) :< Nil @ The type of the above expression is @List BitVector '[8, 16]@ -- That is, a two-element list of @BitVector@s, where the first element has width 8 and the second has width 16. == Summary In general, if we have a type constructor @Foo@ of kind @k -> *@ (in our example, @Foo@ is just @BitVector@, and we want to create a list of @Foo@s where the parameter @k@ varies, /and/ we wish to keep track of what each value of @k@ is inside the list at compile time, we can use the 'Data.Parameterized.List.List' type for this purpose. -} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} module Data.Parameterized.List ( List(..) , fromSomeList , fromListWith , fromListWithM , Index(..) , indexValue , (!!) , update , indexed , imap , ifoldlM , ifoldr , izipWith , itraverse -- * Constants , index0 , index1 , index2 , index3 ) where import qualified Control.Lens as Lens import Data.Foldable import Data.Kind import Prelude hiding ((!!)) import Unsafe.Coerce (unsafeCoerce) import Data.Parameterized.Classes import Data.Parameterized.Some import Data.Parameterized.TraversableFC import Data.Parameterized.TraversableFC.WithIndex -- | Parameterized list of elements. data List :: (k -> Type) -> [k] -> Type where Nil :: List f '[] (:<) :: f tp -> List f tps -> List f (tp : tps) infixr 5 :< instance ShowF f => Show (List f sh) where showsPrec _ Nil = showString "Nil" showsPrec p (elt :< rest) = showParen (p > precCons) $ -- Unlike a derived 'Show' instance, we don't print parens implied -- by right associativity. showsPrecF (precCons+1) elt . showString " :< " . showsPrec 0 rest where precCons = 5 instance ShowF f => ShowF (List f) instance FunctorFC List where fmapFC _ Nil = Nil fmapFC f (x :< xs) = f x :< fmapFC f xs instance FoldableFC List where foldrFC _ z Nil = z foldrFC f z (x :< xs) = f x (foldrFC f z xs) instance TraversableFC List where traverseFC _ Nil = pure Nil traverseFC f (h :< r) = (:<) <$> f h <*> traverseFC f r type instance IndexF (List (f :: k -> Type) sh) = Index sh type instance IxValueF (List (f :: k -> Type) sh) = f instance FunctorFCWithIndex List where imapFC = imap instance FoldableFCWithIndex List where ifoldrFC = ifoldr instance TraversableFCWithIndex List where itraverseFC = itraverse instance TestEquality f => TestEquality (List f) where testEquality Nil Nil = Just Refl testEquality (xh :< xl) (yh :< yl) = do Refl <- testEquality xh yh Refl <- testEquality xl yl pure Refl testEquality _ _ = Nothing instance OrdF f => OrdF (List f) where compareF Nil Nil = EQF compareF Nil _ = LTF compareF _ Nil = GTF compareF (xh :< xl) (yh :< yl) = lexCompareF xh yh $ lexCompareF xl yl $ EQF instance KnownRepr (List f) '[] where knownRepr = Nil instance (KnownRepr f s, KnownRepr (List f) sh) => KnownRepr (List f) (s ': sh) where knownRepr = knownRepr :< knownRepr -- | Apply function to list to yield a parameterized list. fromListWith :: forall a f . (a -> Some f) -> [a] -> Some (List f) fromListWith f = foldr g (Some Nil) where g :: a -> Some (List f) -> Some (List f) g x (Some r) = viewSome (\h -> Some (h :< r)) (f x) -- | Apply monadic action to list to yield a parameterized list. fromListWithM :: forall a f m . Monad m => (a -> m (Some f)) -> [a] -> m (Some (List f)) fromListWithM f = foldrM g (Some Nil) where g :: a -> Some (List f) -> m (Some (List f)) g x (Some r) = viewSome (\h -> Some (h :< r)) <$> f x -- | Map from list of Some to Some list fromSomeList :: [Some f] -> Some (List f) fromSomeList = fromListWith id {-# INLINABLE fromListWith #-} {-# INLINABLE fromListWithM #-} -------------------------------------------------------------------------------- -- * Indexed operations -- | Represents an index into a type-level list. Used in place of integers to -- 1. ensure that the given index *does* exist in the list -- 2. guarantee that it has the given kind data Index :: [k] -> k -> Type where IndexHere :: Index (x:r) x IndexThere :: !(Index r y) -> Index (x:r) y deriving instance Eq (Index l x) deriving instance Show (Index l x) instance ShowF (Index l) instance TestEquality (Index l) where testEquality IndexHere IndexHere = Just Refl testEquality (IndexThere x) (IndexThere y) = testEquality x y testEquality _ _ = Nothing instance OrdF (Index l) where compareF IndexHere IndexHere = EQF compareF IndexHere IndexThere{} = LTF compareF IndexThere{} IndexHere = GTF compareF (IndexThere x) (IndexThere y) = compareF x y instance Ord (Index sh x) where x `compare` y = toOrdering $ x `compareF` y -- | Return the index as an integer. indexValue :: Index l tp -> Integer indexValue = go 0 where go :: Integer -> Index l tp -> Integer go i IndexHere = i go i (IndexThere x) = seq j $ go j x where j = i+1 instance Hashable (Index l x) where hashWithSalt s i = s `hashWithSalt` (indexValue i) -- | Index 0 index0 :: Index (x:r) x index0 = IndexHere -- | Index 1 index1 :: Index (x0:x1:r) x1 index1 = IndexThere index0 -- | Index 2 index2 :: Index (x0:x1:x2:r) x2 index2 = IndexThere index1 -- | Index 3 index3 :: Index (x0:x1:x2:x3:r) x3 index3 = IndexThere index2 -- | Return the value in a list at a given index (!!) :: List f l -> Index l x -> f x l !! (IndexThere i) = case l of _ :< r -> r !! i l !! IndexHere = case l of (h :< _) -> h -- | Update the 'List' at an index update :: List f l -> Index l s -> (f s -> f s) -> List f l update vals IndexHere upd = case vals of x :< rest -> upd x :< rest update vals (IndexThere th) upd = case vals of x :< rest -> x :< update rest th upd -- | Provides a lens for manipulating the element at the given index. indexed :: Index l x -> Lens.Lens' (List f l) (f x) indexed IndexHere f (x :< rest) = (:< rest) <$> f x indexed (IndexThere i) f (x :< rest) = (x :<) <$> indexed i f rest -------------------------------------------------------------------------------- -- Indexed operations -- | Map over the elements in the list, and provide the index into -- each element along with the element itself. -- -- This is a specialization of 'imapFC'. imap :: forall f g l . (forall x . Index l x -> f x -> g x) -> List f l -> List g l imap f = go id where go :: forall l' . (forall tp . Index l' tp -> Index l tp) -> List f l' -> List g l' go g l = case l of Nil -> Nil e :< rest -> f (g IndexHere) e :< go (g . IndexThere) rest -- | Left fold with an additional index. ifoldlM :: forall sh a b m . Monad m => (forall tp . b -> Index sh tp -> a tp -> m b) -> b -> List a sh -> m b ifoldlM _ b Nil = pure b ifoldlM f b0 (a0 :< r0) = f b0 IndexHere a0 >>= go IndexHere r0 where go :: forall tps tp . Index sh tp -> List a tps -> b -> m b go _ Nil b = pure b go idx (a :< rest) b = let idx' = unsafeCoerce (IndexThere idx) in f b idx' a >>= go idx' rest -- | Right-fold with an additional index. -- -- This is a specialization of 'ifoldrFC'. ifoldr :: forall sh a b . (forall tp . Index sh tp -> a tp -> b -> b) -> b -> List a sh -> b ifoldr f seed0 l = go id l seed0 where go :: forall tps . (forall tp . Index tps tp -> Index sh tp) -> List a tps -> b -> b go g ops b = case ops of Nil -> b a :< rest -> f (g IndexHere) a (go (\ix -> g (IndexThere ix)) rest b) -- | Zip up two lists with a zipper function, which can use the index. izipWith :: forall a b c sh . (forall tp. Index sh tp -> a tp -> b tp -> c tp) -> List a sh -> List b sh -> List c sh izipWith f = go id where go :: forall sh' . (forall tp . Index sh' tp -> Index sh tp) -> List a sh' -> List b sh' -> List c sh' go g as bs = case (as, bs) of (Nil, Nil) -> Nil (a :< as', b :< bs') -> f (g IndexHere) a b :< go (g . IndexThere) as' bs' -- | Traverse with an additional index. -- -- This is a specialization of 'itraverseFC'. itraverse :: forall a b sh t . Applicative t => (forall tp . Index sh tp -> a tp -> t (b tp)) -> List a sh -> t (List b sh) itraverse f = go id where go :: forall tps . (forall tp . Index tps tp -> Index sh tp) -> List a tps -> t (List b tps) go g l = case l of Nil -> pure Nil e :< rest -> (:<) <$> f (g IndexHere) e <*> go (\ix -> g (IndexThere ix)) rest parameterized-utils-2.1.7.0/src/Data/Parameterized/Map.hs0000644000000000000000000006373007346545000021360 0ustar0000000000000000{-| 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) parameterized-utils-2.1.7.0/src/Data/Parameterized/NatRepr.hs0000644000000000000000000005135507346545000022216 0ustar0000000000000000{-| Description : Type level natural number representation at runtime Copyright : (c) Galois, Inc 2014-2019 Maintainer : Joe Hendrix This defines a type 'NatRepr' for representing a type-level natural at runtime. This can be used to branch on a type-level value. For each @n@, @NatRepr n@ contains a single value containing the value @n@. This can be used to help use type-level variables on code with data dependendent types. The @TestEquality@ and @DecidableEq@ instances for 'NatRepr' are implemented using 'unsafeCoerce', as is the `isZeroNat` function. This should be typesafe because we maintain the invariant that the integer value contained in a NatRepr value matches its static type. -} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} #if __GLASGOW_HASKELL__ >= 805 {-# LANGUAGE NoStarIsType #-} #endif module Data.Parameterized.NatRepr ( NatRepr , natValue , intValue , knownNat , withKnownNat , IsZeroNat(..) , isZeroNat , isZeroOrGT1 , NatComparison(..) , compareNat , decNat , predNat , incNat , addNat , subNat , divNat , halfNat , withDivModNat , natMultiply , someNat , mkNatRepr , maxNat , natRec , natRecStrong , natRecBounded , natRecStrictlyBounded , natForEach , natFromZero , NatCases(..) , testNatCases -- * Strict order , lessThanIrreflexive , lessThanAsymmetric -- * Bitvector utilities , widthVal , minUnsigned , maxUnsigned , minSigned , maxSigned , toUnsigned , toSigned , unsignedClamp , signedClamp -- * LeqProof , LeqProof(..) , decideLeq , testLeq , testStrictLeq , leqRefl , leqSucc , leqTrans , leqZero , leqAdd2 , leqSub2 , leqMulCongr -- * LeqProof combinators , leqProof , withLeqProof , isPosNat , leqAdd , leqSub , leqMulPos , leqAddPos , addIsLeq , withAddLeq , addPrefixIsLeq , withAddPrefixLeq , addIsLeqLeft1 , dblPosIsPos , leqMulMono -- * Arithmetic proof , plusComm , plusAssoc , mulComm , plusMinusCancel , minusPlusCancel , addMulDistribRight , withAddMulDistribRight , withSubMulDistribRight , mulCancelR , mul2Plus , lemmaMul -- * Re-exports typelists basics -- , NatK , type (+) , type (-) , type (*) , type (<=) , Equality.TestEquality(..) , (Equality.:~:)(..) , Data.Parameterized.Some.Some ) where import Data.Bits ((.&.), bit) import Data.Data import Data.Type.Equality as Equality import Data.Void as Void import Numeric.Natural import GHC.TypeNats ( KnownNat, Nat, SomeNat(..) , type (+), type (-), type (*), type (<=) , someNatVal ) import Unsafe.Coerce import Data.Parameterized.Axiom import Data.Parameterized.NatRepr.Internal import Data.Parameterized.Some maxInt :: Natural maxInt = fromIntegral (maxBound :: Int) intValue :: NatRepr n -> Integer intValue n = toInteger (natValue n) {-# INLINE intValue #-} -- | Return the value of the nat representation. widthVal :: NatRepr n -> Int widthVal (NatRepr i) | i <= maxInt = fromIntegral i | otherwise = error ("Width is too large: " ++ show i) withKnownNat :: forall n r. NatRepr n -> (KnownNat n => r) -> r withKnownNat (NatRepr nVal) v = case someNatVal nVal of SomeNat (Proxy :: Proxy n') -> case unsafeAxiom :: n :~: n' of Refl -> v data IsZeroNat n where ZeroNat :: IsZeroNat 0 NonZeroNat :: IsZeroNat (n+1) isZeroNat :: NatRepr n -> IsZeroNat n isZeroNat (NatRepr 0) = unsafeCoerce ZeroNat isZeroNat (NatRepr _) = unsafeCoerce NonZeroNat -- | Every nat is either zero or >= 1. isZeroOrGT1 :: NatRepr n -> Either (n :~: 0) (LeqProof 1 n) isZeroOrGT1 n = case isZeroNat n of ZeroNat -> Left Refl NonZeroNat -> Right $ -- We have n = m + 1 for some m. let -- | x <= x + 1 leqPlus :: forall f x y. ((x + 1) ~ y) => f x -> LeqProof 1 y leqPlus fx = case (plusComm fx (knownNat @1) :: x + 1 :~: 1 + x) of { Refl -> case (plusMinusCancel (knownNat @1) fx :: 1+x-x :~: 1) of { Refl -> case (LeqProof :: LeqProof (x+1) y) of { LeqProof -> case (LeqProof :: LeqProof (1+x-x) (y-x)) of { LeqProof -> leqTrans (LeqProof :: LeqProof 1 (y-x)) (leqSub (LeqProof :: LeqProof y y) (leqTrans (leqSucc (Proxy :: Proxy x)) (LeqProof) :: LeqProof x y) :: LeqProof (y - x) y) }}}} in leqPlus (predNat n) -- | Decrement a @NatRepr@ decNat :: (1 <= n) => NatRepr n -> NatRepr (n-1) decNat (NatRepr i) = NatRepr (i-1) -- | Get the predecessor of a nat predNat :: NatRepr (n+1) -> NatRepr n predNat (NatRepr i) = NatRepr (i-1) -- | Increment a @NatRepr@ incNat :: NatRepr n -> NatRepr (n+1) incNat (NatRepr x) = NatRepr (x+1) halfNat :: NatRepr (n+n) -> NatRepr n halfNat (NatRepr x) = NatRepr (x `div` 2) addNat :: NatRepr m -> NatRepr n -> NatRepr (m+n) addNat (NatRepr m) (NatRepr n) = NatRepr (m+n) subNat :: (n <= m) => NatRepr m -> NatRepr n -> NatRepr (m-n) subNat (NatRepr m) (NatRepr n) = NatRepr (m-n) divNat :: (1 <= n) => NatRepr (m * n) -> NatRepr n -> NatRepr m divNat (NatRepr x) (NatRepr y) = NatRepr (div x y) withDivModNat :: forall n m a. NatRepr n -> NatRepr m -> (forall div mod. (n ~ ((div * m) + mod)) => NatRepr div -> NatRepr mod -> a) -> a withDivModNat n m f = case ( Some (NatRepr divPart), Some (NatRepr modPart)) of ( Some (divn :: NatRepr div), Some (modn :: NatRepr mod) ) -> case unsafeAxiom of (Refl :: (n :~: ((div * m) + mod))) -> f divn modn where (divPart, modPart) = divMod (natValue n) (natValue m) natMultiply :: NatRepr n -> NatRepr m -> NatRepr (n * m) natMultiply (NatRepr n) (NatRepr m) = NatRepr (n * m) ------------------------------------------------------------------------ -- Operations for using NatRepr as a bitwidth. -- | Return minimum unsigned value for bitvector with given width (always 0). minUnsigned :: NatRepr w -> Integer minUnsigned _ = 0 -- | Return maximum unsigned value for bitvector with given width. maxUnsigned :: NatRepr w -> Integer maxUnsigned w = bit (widthVal w) - 1 -- | Return minimum value for bitvector in two's complement with given width. minSigned :: (1 <= w) => NatRepr w -> Integer minSigned w = negate (bit (widthVal w - 1)) -- | Return maximum value for bitvector in two's complement with given width. maxSigned :: (1 <= w) => NatRepr w -> Integer maxSigned w = bit (widthVal w - 1) - 1 -- | @toUnsigned w i@ maps @i@ to a @i `mod` 2^w@. toUnsigned :: NatRepr w -> Integer -> Integer toUnsigned w i = maxUnsigned w .&. i -- | @toSigned w i@ interprets the least-significant @w@ bits in @i@ as a -- signed number in two's complement notation and returns that value. toSigned :: (1 <= w) => NatRepr w -> Integer -> Integer toSigned w i0 | i > maxSigned w = i - bit (widthVal w) | otherwise = i where i = i0 .&. maxUnsigned w -- | @unsignedClamp w i@ rounds @i@ to the nearest value between -- @0@ and @2^w-1@ (inclusive). unsignedClamp :: NatRepr w -> Integer -> Integer unsignedClamp w i | i < minUnsigned w = minUnsigned w | i > maxUnsigned w = maxUnsigned w | otherwise = i -- | @signedClamp w i@ rounds @i@ to the nearest value between -- @-2^(w-1)@ and @2^(w-1)-1@ (inclusive). signedClamp :: (1 <= w) => NatRepr w -> Integer -> Integer signedClamp w i | i < minSigned w = minSigned w | i > maxSigned w = maxSigned w | otherwise = i ------------------------------------------------------------------------ -- Some NatRepr -- | Turn an @Integral@ value into a @NatRepr@. Returns @Nothing@ -- if the given value is negative. someNat :: Integral a => a -> Maybe (Some NatRepr) someNat x | x >= 0 = Just . Some . NatRepr $! fromIntegral x someNat _ = Nothing -- | Turn a @Natural@ into the corresponding @NatRepr@ mkNatRepr :: Natural -> Some NatRepr mkNatRepr n = Some (NatRepr n) -- | Return the maximum of two nat representations. maxNat :: NatRepr m -> NatRepr n -> Some NatRepr maxNat x y | natValue x >= natValue y = Some x | otherwise = Some y ------------------------------------------------------------------------ -- Arithmetic -- | Produce evidence that @+@ is commutative. plusComm :: forall f m g n . f m -> g n -> m+n :~: n+m plusComm _ _ = unsafeAxiom -- | Produce evidence that @+@ is associative. plusAssoc :: forall f m g n h o . f m -> g n -> h o -> m+(n+o) :~: (m+n)+o plusAssoc _ _ _ = unsafeAxiom -- | Produce evidence that @*@ is commutative. mulComm :: forall f m g n. f m -> g n -> (m * n) :~: (n * m) mulComm _ _ = unsafeAxiom mul2Plus :: forall f n. f n -> (n + n) :~: (2 * n) mul2Plus n = case addMulDistribRight (Proxy @1) (Proxy @1) n of Refl -> Refl -- | Cancel an add followed by a subtract plusMinusCancel :: forall f m g n . f m -> g n -> (m + n) - n :~: m plusMinusCancel _ _ = unsafeAxiom minusPlusCancel :: forall f m g n . (n <= m) => f m -> g n -> (m - n) + n :~: m minusPlusCancel _ _ = unsafeAxiom addMulDistribRight :: forall n m p f g h. f n -> g m -> h p -> ((n * p) + (m * p)) :~: ((n + m) * p) addMulDistribRight _n _m _p = unsafeAxiom withAddMulDistribRight :: forall n m p f g h a. f n -> g m -> h p -> ( (((n * p) + (m * p)) ~ ((n + m) * p)) => a) -> a withAddMulDistribRight n m p f = case addMulDistribRight n m p of Refl -> f withSubMulDistribRight :: forall n m p f g h a. (m <= n) => f n -> g m -> h p -> ( (((n * p) - (m * p)) ~ ((n - m) * p)) => a) -> a withSubMulDistribRight _n _m _p f = case unsafeAxiom of (Refl :: (((n * p) - (m * p)) :~: ((n - m) * p)) ) -> f ------------------------------------------------------------------------ -- LeqProof -- | @LeqProof m n@ is a type whose values are only inhabited when @m@ -- is less than or equal to @n@. data LeqProof (m :: Nat) (n :: Nat) where LeqProof :: (m <= n) => LeqProof m n -- | (<=) is a decidable relation on nats. decideLeq :: NatRepr a -> NatRepr b -> Either (LeqProof a b) ((LeqProof a b) -> Void) decideLeq (NatRepr m) (NatRepr n) | m <= n = Left $ unsafeCoerce (LeqProof :: LeqProof 0 0) | otherwise = Right $ \x -> seq x $ error "Impossible [decidable <= on NatRepr]" testStrictLeq :: forall m n . (m <= n) => NatRepr m -> NatRepr n -> Either (LeqProof (m+1) n) (m :~: n) testStrictLeq (NatRepr m) (NatRepr n) | m < n = Left (unsafeCoerce (LeqProof :: LeqProof 0 0)) | otherwise = Right unsafeAxiom {-# NOINLINE testStrictLeq #-} -- As for NatComparison above, but works with LeqProof data NatCases m n where -- First number is less than second. NatCaseLT :: LeqProof (m+1) n -> NatCases m n NatCaseEQ :: NatCases m m -- First number is greater than second. NatCaseGT :: LeqProof (n+1) m -> NatCases m n testNatCases :: forall m n . NatRepr m -> NatRepr n -> NatCases m n testNatCases m n = case compare (natValue m) (natValue n) of LT -> NatCaseLT (unsafeCoerce (LeqProof :: LeqProof 0 0)) EQ -> unsafeCoerce $ (NatCaseEQ :: NatCases m m) GT -> NatCaseGT (unsafeCoerce (LeqProof :: LeqProof 0 0)) {-# NOINLINE testNatCases #-} -- | The strict order (\<), defined by n \< m \<-> n + 1 \<= m, is irreflexive. lessThanIrreflexive :: forall f (a :: Nat). f a -> LeqProof (1 + a) a -> Void lessThanIrreflexive a prf = let prf1 :: LeqProof (1 + a - a) (a - a) prf1 = leqSub2 prf (LeqProof :: LeqProof a a) prf2 :: 1 + a - a :~: 1 prf2 = plusMinusCancel (knownNat @1) a prf3 :: a - a :~: 0 prf3 = plusMinusCancel (knownNat @0) a prf4 :: LeqProof 1 0 prf4 = case prf2 of Refl -> case prf3 of { Refl -> prf1 } in case prf4 of {} -- | The strict order on the naturals is asymmetric lessThanAsymmetric :: forall m f n . LeqProof (n+1) m -> LeqProof (m+1) n -> f n -> Void lessThanAsymmetric nLTm mLTn n = case plusComm n (knownNat @1) :: n + 1 :~: 1 + n of { Refl -> case leqAdd (LeqProof :: LeqProof m m) (knownNat @1) :: LeqProof m (m+1) of LeqProof -> lessThanIrreflexive n $ leqTrans (leqTrans nLTm LeqProof) mLTn } -- | @x `testLeq` y@ checks whether @x@ is less than or equal to @y@. testLeq :: forall m n . NatRepr m -> NatRepr n -> Maybe (LeqProof m n) testLeq (NatRepr m) (NatRepr n) | m <= n = Just (unsafeCoerce (LeqProof :: LeqProof 0 0)) | otherwise = Nothing {-# NOINLINE testLeq #-} -- | Apply reflexivity to LeqProof leqRefl :: forall f n . f n -> LeqProof n n leqRefl _ = LeqProof leqSucc :: forall f z. f z -> LeqProof z (z + 1) leqSucc fz = leqAdd (leqRefl fz :: LeqProof z z) (knownNat @1) -- | Apply transitivity to LeqProof leqTrans :: LeqProof m n -> LeqProof n p -> LeqProof m p leqTrans LeqProof LeqProof = unsafeCoerce (LeqProof :: LeqProof 0 0) {-# NOINLINE leqTrans #-} -- | Zero is less than or equal to any 'Nat'. leqZero :: LeqProof 0 n leqZero = unsafeCoerce (LeqProof :: LeqProof 0 0) -- | Add both sides of two inequalities leqAdd2 :: LeqProof x_l x_h -> LeqProof y_l y_h -> LeqProof (x_l + y_l) (x_h + y_h) leqAdd2 x y = seq x $ seq y $ unsafeCoerce (LeqProof :: LeqProof 0 0) {-# NOINLINE leqAdd2 #-} -- | Subtract sides of two inequalities. leqSub2 :: LeqProof x_l x_h -> LeqProof y_l y_h -> LeqProof (x_l-y_h) (x_h-y_l) leqSub2 LeqProof LeqProof = unsafeCoerce (LeqProof :: LeqProof 0 0) {-# NOINLINE leqSub2 #-} ------------------------------------------------------------------------ -- LeqProof combinators -- | Create a leqProof using two proxies leqProof :: (m <= n) => f m -> g n -> LeqProof m n leqProof _ _ = LeqProof withLeqProof :: LeqProof m n -> ((m <= n) => a) -> a withLeqProof p a = case p of LeqProof -> a -- | Test whether natural number is positive. isPosNat :: NatRepr n -> Maybe (LeqProof 1 n) isPosNat = testLeq (knownNat :: NatRepr 1) -- | Congruence rule for multiplication leqMulCongr :: LeqProof a x -> LeqProof b y -> LeqProof (a*b) (x*y) leqMulCongr LeqProof LeqProof = unsafeCoerce (LeqProof :: LeqProof 1 1) {-# NOINLINE leqMulCongr #-} -- | Multiplying two positive numbers results in a positive number. leqMulPos :: forall p q x y . (1 <= x, 1 <= y) => p x -> q y -> LeqProof 1 (x*y) leqMulPos _ _ = leqMulCongr (LeqProof :: LeqProof 1 x) (LeqProof :: LeqProof 1 y) leqMulMono :: (1 <= x) => p x -> q y -> LeqProof y (x * y) leqMulMono x y = leqMulCongr (leqProof (Proxy :: Proxy 1) x) (leqRefl y) -- | Produce proof that adding a value to the larger element in an LeqProof -- is larger leqAdd :: forall f m n p . LeqProof m n -> f p -> LeqProof m (n+p) leqAdd x _ = leqAdd2 x (leqZero @p) leqAddPos :: (1 <= m, 1 <= n) => p m -> q n -> LeqProof 1 (m + n) leqAddPos m n = leqAdd (leqProof (Proxy :: Proxy 1) m) n -- | Produce proof that subtracting a value from the smaller element is smaller. leqSub :: forall m n p . LeqProof m n -> LeqProof p m -> LeqProof (m-p) n leqSub x _ = leqSub2 x (leqZero @p) addIsLeq :: f n -> g m -> LeqProof n (n + m) addIsLeq n m = leqAdd (leqRefl n) m addPrefixIsLeq :: f m -> g n -> LeqProof n (m + n) addPrefixIsLeq m n = case plusComm n m of Refl -> addIsLeq n m dblPosIsPos :: forall n . LeqProof 1 n -> LeqProof 1 (n+n) dblPosIsPos x = leqAdd x Proxy addIsLeqLeft1 :: forall n n' m . LeqProof (n + n') m -> LeqProof n m addIsLeqLeft1 p = case plusMinusCancel n n' of Refl -> leqSub p le where n :: Proxy n n = Proxy n' :: Proxy n' n' = Proxy le :: LeqProof n' (n + n') le = addPrefixIsLeq n n' {-# INLINE withAddPrefixLeq #-} withAddPrefixLeq :: NatRepr n -> NatRepr m -> ((m <= n + m) => a) -> a withAddPrefixLeq n m = withLeqProof (addPrefixIsLeq n m) withAddLeq :: forall n m a. NatRepr n -> NatRepr m -> ((n <= n + m) => NatRepr (n + m) -> a) -> a withAddLeq n m f = withLeqProof (addIsLeq n m) (f (addNat n m)) natForEach' :: forall l h a . NatRepr l -> NatRepr h -> (forall n. LeqProof l n -> LeqProof n h -> NatRepr n -> a) -> [a] natForEach' l h f | Just LeqProof <- testLeq l h = let f' :: forall n. LeqProof (l + 1) n -> LeqProof n h -> NatRepr n -> a f' = \lp hp -> f (addIsLeqLeft1 lp) hp in f LeqProof LeqProof l : natForEach' (incNat l) h f' | otherwise = [] -- | Apply a function to each element in a range; return the list of values -- obtained. natForEach :: forall l h a . NatRepr l -> NatRepr h -> (forall n. (l <= n, n <= h) => NatRepr n -> a) -> [a] natForEach l h f = natForEach' l h (\LeqProof LeqProof -> f) -- | Apply a function to each element in a range starting at zero; -- return the list of values obtained. natFromZero :: forall h a . NatRepr h -> (forall n. (n <= h) => NatRepr n -> a) -> [a] natFromZero h f = natForEach (knownNat @0) h f -- | Recursor for natural numbeers. natRec :: forall p f . NatRepr p -> f 0 {- ^ base case -} -> (forall n. NatRepr n -> f n -> f (n + 1)) -> f p natRec n base ind = case isZeroNat n of ZeroNat -> base NonZeroNat -> let n' = predNat n in ind n' (natRec n' base ind) -- | Strong induction variant of the recursor. natRecStrong :: forall p f . NatRepr p -> f 0 {- ^ base case -} -> (forall n. NatRepr n -> (forall m. (m <= n) => NatRepr m -> f m) -> f (n + 1)) {- ^ inductive step -} -> f p natRecStrong p base ind = natRecStrong' base ind p where -- We can't use use "flip" or some other basic combinator -- because type variables can't be instantiated to contain "forall"s. natRecStrong' :: forall p' f' . f' 0 {- ^ base case -} -> (forall n. NatRepr n -> (forall m. (m <= n) => NatRepr m -> f' m) -> f' (n + 1)) {- ^ inductive step -} -> NatRepr p' -> f' p' natRecStrong' base' ind' n = case isZeroNat n of ZeroNat -> base' NonZeroNat -> ind' (predNat n) (natRecStrong' base' ind') -- | Bounded recursor for natural numbers. -- -- If you can prove: -- - Base case: f 0 -- - Inductive step: if n <= h and (f n) then (f (n + 1)) -- You can conclude: for all n <= h, (f (n + 1)). natRecBounded :: forall m h f. (m <= h) => NatRepr m -> NatRepr h -> f 0 -> (forall n. (n <= h) => NatRepr n -> f n -> f (n + 1)) -> f (m + 1) natRecBounded m h base indH = case isZeroOrGT1 m of Left Refl -> indH (knownNat @0) base Right LeqProof -> case decideLeq m h of Left LeqProof {- :: m <= h -} -> let -- Since m is non-zero, it is n + 1 for some n. lemma :: LeqProof (m-1) h lemma = leqSub (LeqProof :: LeqProof m h) (LeqProof :: LeqProof 1 m) in indH m $ case lemma of { LeqProof -> case minusPlusCancel m (knownNat @1) of { Refl -> natRecBounded @(m - 1) @h @f (predNat m) h base indH }} Right f {- :: (m <= h) -> Void -} -> absurd $ f (LeqProof :: LeqProof m h) -- | A version of 'natRecBounded' which doesn't require the type index of the -- result to be greater than @0@ and provides a strict inequality constraint. natRecStrictlyBounded :: forall m f. NatRepr m -> f 0 -> (forall n. (n + 1 <= m) => NatRepr n -> f n -> f (n + 1)) -> f m natRecStrictlyBounded m base indH = case isZeroNat m of ZeroNat -> base NonZeroNat -> case predNat m of (p :: NatRepr p) -> natRecBounded p p base (\(k :: NatRepr n) (v :: f n) -> case leqAdd2 (LeqProof :: LeqProof n p) (LeqProof :: LeqProof 1 1) of LeqProof -> indH k v) mulCancelR :: (1 <= c, (n1 * c) ~ (n2 * c)) => f1 n1 -> f2 n2 -> f3 c -> (n1 :~: n2) mulCancelR _ _ _ = unsafeAxiom -- | Used in @Vector@ lemmaMul :: (1 <= n) => p w -> q n -> (w + (n-1) * w) :~: (n * w) lemmaMul _ _ = unsafeAxiom parameterized-utils-2.1.7.0/src/Data/Parameterized/NatRepr/0000755000000000000000000000000007346545000021651 5ustar0000000000000000parameterized-utils-2.1.7.0/src/Data/Parameterized/NatRepr/Internal.hs0000644000000000000000000000576407346545000023775 0ustar0000000000000000{-| Copyright : (c) Galois, Inc 2014-2018 Maintainer : Joe Hendrix This internal module exports the 'NatRepr' type and its constructor. It is intended for use only within parameterized-utils, and is excluded from the module export list. -} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} module Data.Parameterized.NatRepr.Internal where import Data.Data import Data.Hashable import GHC.TypeNats import qualified Numeric.Natural as Natural import Unsafe.Coerce import Data.Parameterized.Axiom import Data.Parameterized.Classes import Data.Parameterized.DecidableEq ------------------------------------------------------------------------ -- Nat -- | A runtime presentation of a type-level 'Nat'. -- -- This can be used for performing dynamic checks on a type-level natural -- numbers. newtype NatRepr (n::Nat) = NatRepr { natValue :: Natural.Natural -- ^ The underlying natural value of the number. } deriving (Hashable, Data) type role NatRepr nominal instance Eq (NatRepr m) where _ == _ = True instance TestEquality NatRepr where testEquality (NatRepr m) (NatRepr n) | m == n = Just unsafeAxiom | otherwise = Nothing instance DecidableEq NatRepr where decEq (NatRepr m) (NatRepr n) | m == n = Left unsafeAxiom | otherwise = Right $ \x -> seq x $ error "Impossible [DecidableEq on NatRepr]" compareNat :: NatRepr m -> NatRepr n -> NatComparison m n compareNat m n = case compare (natValue m) (natValue n) of LT -> unsafeCoerce (NatLT @0 @0) (NatRepr (natValue n - natValue m - 1)) EQ -> unsafeCoerce NatEQ GT -> unsafeCoerce (NatGT @0 @0) (NatRepr (natValue m - natValue n - 1)) -- | Result of comparing two numbers. data NatComparison m n where -- First number is less than second. NatLT :: x+1 <= x+(y+1) => !(NatRepr y) -> NatComparison x (x+(y+1)) NatEQ :: NatComparison x x -- First number is greater than second. NatGT :: x+1 <= x+(y+1) => !(NatRepr y) -> NatComparison (x+(y+1)) x instance OrdF NatRepr where compareF x y = case compareNat x y of NatLT _ -> LTF NatEQ -> EQF NatGT _ -> GTF instance PolyEq (NatRepr m) (NatRepr n) where polyEqF x y = fmap (\Refl -> Refl) $ testEquality x y instance Show (NatRepr n) where show (NatRepr n) = show n instance ShowF NatRepr instance HashableF NatRepr where hashWithSaltF = hashWithSalt -- | This generates a NatRepr from a type-level context. knownNat :: forall n . KnownNat n => NatRepr n knownNat = NatRepr (natVal (Proxy :: Proxy n)) instance (KnownNat n) => KnownRepr NatRepr n where knownRepr = knownNat parameterized-utils-2.1.7.0/src/Data/Parameterized/Nonce.hs0000644000000000000000000001325307346545000021700 0ustar0000000000000000{-| Description : Index generator in the ST monad. Copyright : (c) Galois, Inc 2014-2019 Maintainer : Joe Hendrix This module provides a simple generator of new indexes in the 'ST' monad. It is predictable and not intended for cryptographic purposes. This module also provides a global nonce generator that will generate 2^64 nonces before repeating. NOTE: The 'TestEquality' and 'OrdF' instances for the 'Nonce' type simply compare the generated nonce values and then assert to the compiler (via 'unsafeCoerce') that the types ascribed to the nonces are equal if their values are equal. -} {-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE Trustworthy #-} #if __GLASGOW_HASKELL__ < 806 {-# LANGUAGE TypeInType #-} #endif module Data.Parameterized.Nonce ( -- * NonceGenerator NonceGenerator , freshNonce , countNoncesGenerated , Nonce , indexValue -- * Accessing a nonce generator , newSTNonceGenerator , newIONonceGenerator , withIONonceGenerator , withSTNonceGenerator , runSTNonceGenerator -- * Global nonce generator , withGlobalSTNonceGenerator , GlobalNonceGenerator , globalNonceGenerator ) where import Control.Monad.ST import Data.Hashable import Data.Kind import Data.IORef import Data.STRef import Data.Word import Unsafe.Coerce import System.IO.Unsafe (unsafePerformIO) import Data.Parameterized.Axiom import Data.Parameterized.Classes import Data.Parameterized.Some -- | Provides a monadic action for getting fresh typed names. -- -- The first type parameter @m@ is the monad used for generating names, and -- the second parameter @s@ is used for the counter. data NonceGenerator (m :: Type -> Type) (s :: Type) where STNG :: !(STRef t Word64) -> NonceGenerator (ST t) s IONG :: !(IORef Word64) -> NonceGenerator IO s freshNonce :: forall m s k (tp :: k) . NonceGenerator m s -> m (Nonce s tp) freshNonce (IONG r) = atomicModifyIORef' r $ \n -> (n+1, Nonce n) freshNonce (STNG r) = do i <- readSTRef r writeSTRef r $! i+1 return $ Nonce i -- (Weirdly, there's no atomicModifySTRef'. Yes, only the IO monad -- does concurrency, but the ST monad is part of the IO monad via -- stToIO, so there's no guarantee that ST code won't be run in -- multiple threads.) {-# INLINE freshNonce #-} -- Inlining is particularly necessary since there's no @Monad m@ -- constraint on 'freshNonce', so SPECIALIZE doesn't work on it. In -- this case, though, we get specialization for free from inlining. -- For instance, a @NonceGenerator IO s@ must be an @IONG@, so the -- simplifier eliminates the STNG branch. -- | The number of nonces generated so far by this generator. Only -- really useful for profiling. countNoncesGenerated :: NonceGenerator m s -> m Integer countNoncesGenerated (IONG r) = toInteger <$> readIORef r countNoncesGenerated (STNG r) = toInteger <$> readSTRef r -- | Create a new nonce generator in the 'ST' monad. newSTNonceGenerator :: ST t (Some (NonceGenerator (ST t))) newSTNonceGenerator = Some . STNG <$> newSTRef (toEnum 0) -- | This combines `runST` and `newSTNonceGenerator` to create a nonce -- generator that shares the same phantom type parameter as the @ST@ monad. -- -- This can be used to reduce the number of type parameters when we know a -- ST computation only needs a single `NonceGenerator`. runSTNonceGenerator :: (forall s . NonceGenerator (ST s) s -> ST s a) -> a runSTNonceGenerator f = runST $ f . STNG =<< newSTRef 0 -- | Create a new nonce generator in the 'IO' monad. newIONonceGenerator :: IO (Some (NonceGenerator IO)) newIONonceGenerator = Some . IONG <$> newIORef (toEnum 0) -- | Run an 'ST' computation with a new nonce generator in the 'ST' monad. withSTNonceGenerator :: (forall s . NonceGenerator (ST t) s -> ST t r) -> ST t r withSTNonceGenerator f = do Some r <- newSTNonceGenerator f r -- | Run an 'IO' computation with a new nonce generator in the 'IO' monad. withIONonceGenerator :: (forall s . NonceGenerator IO s -> IO r) -> IO r withIONonceGenerator f = do Some r <- newIONonceGenerator f r -- | An index generated by the counter. newtype Nonce (s :: Type) (tp :: k) = Nonce { indexValue :: Word64 } deriving (Eq, Ord, Hashable, Show) -- Force the type role of Nonce to be nominal: this prevents Data.Coerce.coerce -- from casting the types of nonces, which it would otherwise be able to do -- because tp is a phantom type parameter. This partially helps to protect -- the nonce abstraction. type role Nonce nominal nominal instance TestEquality (Nonce s) where testEquality x y | indexValue x == indexValue y = Just unsafeAxiom | otherwise = Nothing instance OrdF (Nonce s) where compareF x y = case compare (indexValue x) (indexValue y) of LT -> LTF EQ -> unsafeCoerce EQF GT -> GTF instance HashableF (Nonce s) where hashWithSaltF s (Nonce x) = hashWithSalt s x instance ShowF (Nonce s) ------------------------------------------------------------------------ -- * GlobalNonceGenerator data GlobalNonceGenerator globalNonceIORef :: IORef Word64 globalNonceIORef = unsafePerformIO (newIORef 0) {-# NOINLINE globalNonceIORef #-} -- | A nonce generator that uses a globally-defined counter. globalNonceGenerator :: NonceGenerator IO GlobalNonceGenerator globalNonceGenerator = IONG globalNonceIORef -- | Create a new counter. withGlobalSTNonceGenerator :: (forall t . NonceGenerator (ST t) t -> ST t r) -> r withGlobalSTNonceGenerator f = runST $ do r <- newSTRef (toEnum 0) f $! STNG r parameterized-utils-2.1.7.0/src/Data/Parameterized/Nonce/0000755000000000000000000000000007346545000021340 5ustar0000000000000000parameterized-utils-2.1.7.0/src/Data/Parameterized/Nonce/Transformers.hs0000644000000000000000000000436407346545000024370 0ustar0000000000000000{-| Description : A typeclass and monad transformers for generating nonces. Copyright : (c) Galois, Inc 2014-2019 Maintainer : Eddy Westbrook This module provides a typeclass and monad transformers for generating nonces. -} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} module Data.Parameterized.Nonce.Transformers ( MonadNonce(..) , NonceT(..) , NonceST , NonceIO , getNonceSTGen , runNonceST , runNonceIO , module Data.Parameterized.Nonce ) where import Control.Monad.Reader import Control.Monad.ST import Control.Monad.State import Data.Kind import Data.Parameterized.Nonce -- | A 'MonadNonce' is a monad that can generate fresh 'Nonce's in a given set -- (where we view the phantom type parameter of 'Nonce' as a designator of the -- set that the 'Nonce' came from). class Monad m => MonadNonce m where type NonceSet m :: Type freshNonceM :: forall k (tp :: k) . m (Nonce (NonceSet m) tp) -- | This transformer adds a nonce generator to a given monad. newtype NonceT s m a = NonceT { runNonceT :: ReaderT (NonceGenerator m s) m a } deriving (Functor, Applicative, Monad) instance MonadTrans (NonceT s) where lift m = NonceT $ lift m instance Monad m => MonadNonce (NonceT s m) where type NonceSet (NonceT s m) = s freshNonceM = NonceT $ lift . freshNonce =<< ask instance MonadNonce m => MonadNonce (StateT s m) where type NonceSet (StateT s m) = NonceSet m freshNonceM = lift $ freshNonceM -- | Helper type to build a 'MonadNonce' from the 'ST' monad. type NonceST t s = NonceT s (ST t) -- | Helper type to build a 'MonadNonce' from the 'IO' monad. type NonceIO s = NonceT s IO -- | Return the actual 'NonceGenerator' used in an 'ST' computation. getNonceSTGen :: NonceST t s (NonceGenerator (ST t) s) getNonceSTGen = NonceT ask -- | Run a 'NonceST' computation with a fresh 'NonceGenerator'. runNonceST :: (forall t s. NonceST t s a) -> a runNonceST m = runST $ withSTNonceGenerator $ runReaderT $ runNonceT m -- | Run a 'NonceIO' computation with a fresh 'NonceGenerator' inside 'IO'. runNonceIO :: (forall s. NonceIO s a) -> IO a runNonceIO m = withIONonceGenerator $ runReaderT $ runNonceT m parameterized-utils-2.1.7.0/src/Data/Parameterized/Nonce/Unsafe.hs0000644000000000000000000000662007346545000023121 0ustar0000000000000000------------------------------------------------------------------------ -- | -- Module : Data.Parameterized.Nonce.Unsafe -- Description : A counter in the ST monad. -- Copyright : (c) Galois, Inc 2014 -- Maintainer : Joe Hendrix -- Stability : provisional -- -- This module provides a simple generator of new indexes in the ST monad. -- It is predictable and not intended for cryptographic purposes. -- -- NOTE: the 'TestEquality' and 'OrdF' instances for the 'Nonce' type simply -- compare the generated nonce values and then assert to the compiler -- (via 'unsafeCoerce') that the types ascribed to the nonces are equal -- if their values are equal. This is only OK because of the discipline -- by which nonces should be used: they should only be generated from -- a 'NonceGenerator' (i.e., should not be built directly), and nonces from -- different generators must never be compared! Arranging to compare -- Nonces from different origins would allow users to build 'unsafeCoerce' -- via the 'testEquality' function. -- -- This module is deprecated, and should not be used in new code. -- Clients of this module should migrate to use "Data.Parameterized.Nonce". ------------------------------------------------------------------------- {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE Unsafe #-} module Data.Parameterized.Nonce.Unsafe {-# DEPRECATED "Migrate to use Data.Parameterized.Nonce instead, this module will be removed soon." #-} ( NonceGenerator , newNonceGenerator , freshNonce , atLimit , Nonce , indexValue ) where import Control.Monad.ST import Data.Hashable import Data.STRef import Data.Word import Unsafe.Coerce import Data.Parameterized.Axiom import Data.Parameterized.Classes -- | A simple type that for getting fresh indices in the 'ST' monad. -- The type parameter @s@ is used for the 'ST' monad parameter. newtype NonceGenerator s = NonceGenerator (STRef s Word64) -- | Create a new counter. newNonceGenerator :: ST s (NonceGenerator s) newNonceGenerator = NonceGenerator `fmap` newSTRef (toEnum 0) -- | An index generated by the counter. newtype Nonce (tp :: k) = Nonce { indexValue :: Word64 } deriving (Eq, Ord, Hashable, Show) -- Force the type role of Nonce to be nominal: this prevents Data.Coerce.coerce -- from casting the types of nonces, which it would otherwise be able to do -- because tp is a phantom type parameter. This partially helps to protect -- the nonce abstraction. type role Nonce nominal instance TestEquality Nonce where testEquality x y | indexValue x == indexValue y = Just unsafeAxiom | otherwise = Nothing instance OrdF Nonce where compareF x y = case compare (indexValue x) (indexValue y) of LT -> LTF EQ -> unsafeCoerce EQF GT -> GTF instance HashableF Nonce where hashWithSaltF s (Nonce x) = hashWithSalt s x instance ShowF Nonce {-# INLINE freshNonce #-} -- | Get a fresh index and increment the counter. freshNonce :: NonceGenerator s -> ST s (Nonce tp) freshNonce (NonceGenerator r) = do i <- readSTRef r writeSTRef r $! succ i return (Nonce i) -- | Return true if counter has reached the limit, and can't be -- incremented without risk of error. atLimit :: NonceGenerator s -> ST s Bool atLimit (NonceGenerator r) = do i <- readSTRef r return (i == maxBound) parameterized-utils-2.1.7.0/src/Data/Parameterized/Pair.hs0000644000000000000000000000257607346545000021537 0ustar0000000000000000{-| 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 parameterized-utils-2.1.7.0/src/Data/Parameterized/Peano.hs0000644000000000000000000003212407346545000021676 0ustar0000000000000000{-| 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 parameterized-utils-2.1.7.0/src/Data/Parameterized/Some.hs0000644000000000000000000000443007346545000021536 0ustar0000000000000000------------------------------------------------------------------------ -- | -- Module : Data.Parameterized.Some -- Copyright : (c) Galois, Inc 2014-2019 -- Maintainer : Joe Hendrix -- Description : a GADT that hides a type parameter -- -- This module provides 'Some', a GADT that hides a type parameter. ------------------------------------------------------------------------ {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} module Data.Parameterized.Some ( Some(..) , viewSome , mapSome , traverseSome , traverseSome_ , someLens ) where import Control.Lens (Lens', lens, (&), (^.), (.~)) import Data.Hashable import Data.Kind import Data.Parameterized.Classes import Data.Parameterized.TraversableF data Some (f:: k -> Type) = forall x . Some (f x) instance TestEquality f => Eq (Some f) where Some x == Some y = isJust (testEquality x y) instance OrdF f => Ord (Some f) where compare (Some x) (Some y) = toOrdering (compareF x y) instance (HashableF f, TestEquality f) => Hashable (Some f) where hashWithSalt s (Some x) = hashWithSaltF s x hash (Some x) = hashF x instance ShowF f => Show (Some f) where show (Some x) = showF x -- | Project out of Some. viewSome :: (forall tp . f tp -> r) -> Some f -> r viewSome f (Some x) = f x -- | Apply function to inner value. mapSome :: (forall tp . f tp -> g tp) -> Some f -> Some g mapSome f (Some x) = Some $! f x {-# INLINE traverseSome #-} -- | Modify the inner value. traverseSome :: Functor m => (forall tp . f tp -> m (g tp)) -> Some f -> m (Some g) traverseSome f (Some x) = Some `fmap` f x {-# INLINE traverseSome_ #-} -- | Modify the inner value. traverseSome_ :: Functor m => (forall tp . f tp -> m ()) -> Some f -> m () traverseSome_ f (Some x) = (\_ -> ()) `fmap` f x instance FunctorF Some where fmapF = mapSome instance FoldableF Some where foldMapF = foldMapFDefault instance TraversableF Some where traverseF = traverseSome -- | A lens that is polymorphic in the index may be used on a value with an -- existentially-quantified index. someLens :: (forall tp. Lens' (f tp) a) -> Lens' (Some f) a someLens l = lens (\(Some x) -> x ^. l) (\(Some x) v -> Some (x & l .~ v)) parameterized-utils-2.1.7.0/src/Data/Parameterized/SymbolRepr.hs0000644000000000000000000001037707346545000022740 0ustar0000000000000000{-| Copyright : (c) Galois, Inc 2014-2019 Maintainer : Joe Hendrix Description : a type family for representing a type-level string (AKA symbol) at runtime This defines a type family 'SymbolRepr' for representing a type-level string (AKA symbol) at runtime. This can be used to branch on a type-level value. The 'TestEquality' and 'OrdF' instances for 'SymbolRepr' are implemented using 'unsafeCoerce'. This should be typesafe because we maintain the invariant that the string value contained in a SymbolRepr value matches its static type. At the type level, symbols have very few operations, so SymbolRepr correspondingly has very few functions that manipulate them. -} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE Trustworthy #-} module Data.Parameterized.SymbolRepr ( -- * SymbolRepr SymbolRepr , symbolRepr , knownSymbol , someSymbol , SomeSym(SomeSym) , viewSomeSym -- * Re-exports , type GHC.Symbol , GHC.KnownSymbol ) where import GHC.TypeLits as GHC import Unsafe.Coerce (unsafeCoerce) import Data.Hashable import Data.Kind ( Type ) import Data.Proxy import qualified Data.Text as Text import Data.Parameterized.Axiom import Data.Parameterized.Classes import Data.Parameterized.Some -- | A runtime representation of a GHC type-level symbol. newtype SymbolRepr (nm::GHC.Symbol) = SymbolRepr { symbolRepr :: Text.Text -- ^ The underlying text representation of the symbol } -- INVARIANT: The contained runtime text value matches the value -- of the type level symbol. The SymbolRepr constructor -- is not exported so we can maintain this invariant in this -- module. -- | Generate a symbol representative at runtime. The type-level -- symbol will be abstract, as it is hidden by the 'Some' constructor. someSymbol :: Text.Text -> Some SymbolRepr someSymbol nm = Some (SymbolRepr nm) -- | Generate a value representative for the type level symbol. knownSymbol :: GHC.KnownSymbol s => SymbolRepr s knownSymbol = go Proxy where go :: GHC.KnownSymbol s => Proxy s -> SymbolRepr s go p = SymbolRepr $! packSymbol (GHC.symbolVal p) -- NOTE here we explicitly test that unpacking the packed text value -- gives the desired string. This is to avoid pathological corner cases -- involving string values that have no text representation. packSymbol str | Text.unpack txt == str = txt | otherwise = error $ "Unrepresentable symbol! "++ str where txt = Text.pack str instance (GHC.KnownSymbol s) => KnownRepr SymbolRepr s where knownRepr = knownSymbol instance TestEquality SymbolRepr where testEquality (SymbolRepr x :: SymbolRepr x) (SymbolRepr y) | x == y = Just unsafeAxiom | otherwise = Nothing instance OrdF SymbolRepr where compareF (SymbolRepr x :: SymbolRepr x) (SymbolRepr y) | x < y = LTF | x == y = unsafeCoerce (EQF :: OrderingF x x) | otherwise = GTF -- These instances are trivial by the invariant -- that the contained string matches the type-level -- symbol instance Eq (SymbolRepr x) where _ == _ = True instance Ord (SymbolRepr x) where compare _ _ = EQ instance HashableF SymbolRepr where hashWithSaltF = hashWithSalt instance Hashable (SymbolRepr nm) where hashWithSalt s (SymbolRepr nm) = hashWithSalt s nm instance Show (SymbolRepr nm) where show (SymbolRepr nm) = Text.unpack nm instance ShowF SymbolRepr -- | The SomeSym hides a Symbol parameter but preserves a -- KnownSymbol constraint on the hidden parameter. data SomeSym (c :: GHC.Symbol -> Type) = forall (s :: GHC.Symbol) . GHC.KnownSymbol s => SomeSym (c s) -- | Projects a value out of a SomeSym into a function, re-ifying the -- Symbol type parameter to the called function, along with the -- KnownSymbol constraint on that Symbol value. viewSomeSym :: (forall (s :: GHC.Symbol) . GHC.KnownSymbol s => c s -> r) -> SomeSym c -> r viewSomeSym f (SomeSym x) = f x parameterized-utils-2.1.7.0/src/Data/Parameterized/TH/0000755000000000000000000000000007346545000020611 5ustar0000000000000000parameterized-utils-2.1.7.0/src/Data/Parameterized/TH/GADT.hs0000644000000000000000000006765207346545000021704 0ustar0000000000000000------------------------------------------------------------------------ -- | -- Module : Data.Parameterized.TH.GADT -- Copyright : (c) Galois, Inc 2013-2019 -- Maintainer : Joe Hendrix -- Description : Template Haskell primitives for working with large GADTs -- -- This module declares template Haskell primitives so that it is easier -- to work with GADTs that have many constructors. ------------------------------------------------------------------------ {-# LANGUAGE CPP #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE EmptyCase #-} module Data.Parameterized.TH.GADT ( -- * Instance generators -- $typePatterns structuralEquality , structuralTypeEquality , structuralTypeOrd , structuralTraversal , structuralShowsPrec , structuralHash , structuralHashWithSalt , PolyEq(..) -- * Repr generators (\"singletons\") -- $reprs , mkRepr , mkKnownReprs -- * Template haskell utilities that may be useful in other contexts. , DataD , lookupDataType' , asTypeCon , conPat , TypePat(..) , dataParamTypes , assocTypePats ) where import Control.Monad import Data.Maybe import Data.Set (Set) import qualified Data.Set as Set import Language.Haskell.TH import Language.Haskell.TH.Datatype import Data.Parameterized.Classes ------------------------------------------------------------------------ -- Template Haskell utilities type DataD = DatatypeInfo lookupDataType' :: Name -> Q DatatypeInfo lookupDataType' = reifyDatatype -- | Given a constructor and string, this generates a pattern for matching -- the expression, and the names of variables bound by pattern in order -- they appear in constructor. conPat :: ConstructorInfo {- ^ constructor information -} -> String {- ^ generated name prefix -} -> Q (Pat, [Name]) {- ^ pattern and bound names -} conPat con pre = do nms <- newNames pre (length (constructorFields con)) return (conPCompat (constructorName con) (VarP <$> nms), nms) -- | Return an expression corresponding to the constructor. -- Note that this will have the type of a function expecting -- the argumetns given. conExpr :: ConstructorInfo -> Exp conExpr = ConE . constructorName ------------------------------------------------------------------------ -- TypePat -- | A type used to describe (and match) types appearing in generated pattern -- matches inside of the TH generators in this module ('structuralEquality', -- 'structuralTypeEquality', 'structuralTypeOrd', and 'structuralTraversal') data TypePat = TypeApp TypePat TypePat -- ^ The application of a type. | AnyType -- ^ Match any type. | DataArg Int -- ^ Match the i'th argument of the data type we are traversing. | ConType TypeQ -- ^ Match a ground type. matchTypePat :: [Type] -> TypePat -> Type -> Q Bool matchTypePat d (TypeApp p q) (AppT x y) = do r <- matchTypePat d p x case r of True -> matchTypePat d q y False -> return False matchTypePat _ AnyType _ = return True matchTypePat tps (DataArg i) tp | i < 0 || i >= length tps = error ("Type pattern index " ++ show i ++ " out of bounds") | otherwise = return (stripSigT (tps !! i) == tp) where -- th-abstraction can annotate type parameters with their kinds, -- we ignore these for matching stripSigT (SigT t _) = t stripSigT t = t matchTypePat _ (ConType tpq) tp = do tp' <- tpq return (tp' == tp) matchTypePat _ _ _ = return False -- | The dataParamTypes function returns the list of Type arguments -- for the constructor. For example, if passed the DatatypeInfo for a -- @newtype Id a = MkId a@ then this would return @['SigT' ('VarT' a) -- 'StarT']@. Note that there may be type *variables* not referenced -- in the returned array; this simply returns the type *arguments*. dataParamTypes :: DatatypeInfo -> [Type] dataParamTypes = datatypeInstTypes -- see th-abstraction 'dataTypeVars' for the type variables if needed -- | Find value associated with first pattern that matches given pat if any. assocTypePats :: [Type] -> [(TypePat, v)] -> Type -> Q (Maybe v) assocTypePats _ [] _ = return Nothing assocTypePats dTypes ((p,v):pats) tp = do r <- matchTypePat dTypes p tp case r of True -> return (Just v) False -> assocTypePats dTypes pats tp ------------------------------------------------------------------------ -- Contructor cases typeVars :: TypeSubstitution a => a -> Set Name typeVars = Set.fromList . freeVariables -- | @structuralEquality@ declares a structural equality predicate. structuralEquality :: TypeQ -> [(TypePat,ExpQ)] -> ExpQ structuralEquality tpq pats = [| \x y -> isJust ($(structuralTypeEquality tpq pats) x y) |] joinEqMaybe :: Name -> Name -> ExpQ -> ExpQ joinEqMaybe x y r = do [| if $(varE x) == $(varE y) then $(r) else Nothing |] joinTestEquality :: ExpQ -> Name -> Name -> ExpQ -> ExpQ joinTestEquality f x y r = [| case $(f) $(varE x) $(varE y) of Nothing -> Nothing Just Refl -> $(r) |] matchEqArguments :: [Type] -- ^ Types bound by data arguments. -> [(TypePat,ExpQ)] -- ^ Patterns for matching arguments -> Name -- ^ Name of constructor. -> Set Name -> [Type] -> [Name] -> [Name] -> ExpQ matchEqArguments dTypes pats cnm bnd (tp:tpl) (x:xl) (y:yl) = do doesMatch <- assocTypePats dTypes pats tp case doesMatch of Just q -> do let bnd' = case tp of AppT _ (VarT nm) -> Set.insert nm bnd _ -> bnd joinTestEquality q x y (matchEqArguments dTypes pats cnm bnd' tpl xl yl) Nothing | typeVars tp `Set.isSubsetOf` bnd -> do joinEqMaybe x y (matchEqArguments dTypes pats cnm bnd tpl xl yl) Nothing -> do fail $ "Unsupported argument type " ++ show tp ++ " in " ++ show (ppr cnm) ++ "." matchEqArguments _ _ _ _ [] [] [] = [| Just Refl |] matchEqArguments _ _ _ _ [] _ _ = error "Unexpected end of types." matchEqArguments _ _ _ _ _ [] _ = error "Unexpected end of names." matchEqArguments _ _ _ _ _ _ [] = error "Unexpected end of names." mkSimpleEqF :: [Type] -- ^ Data declaration types -> Set Name -> [(TypePat,ExpQ)] -- ^ Patterns for matching arguments -> ConstructorInfo -> [Name] -> ExpQ -> Bool -- ^ wildcard case required -> ExpQ mkSimpleEqF dTypes bnd pats con xv yQ multipleCases = do -- Get argument types for constructor. let nm = constructorName con (yp,yv) <- conPat con "y" let rv = matchEqArguments dTypes pats nm bnd (constructorFields con) xv yv caseE yQ $ match (pure yp) (normalB rv) [] : [ match wildP (normalB [| Nothing |]) [] | multipleCases ] -- | Match equational form. mkEqF :: DatatypeInfo -- ^ Data declaration. -> [(TypePat,ExpQ)] -> ConstructorInfo -> [Name] -> ExpQ -> Bool -- ^ wildcard case required -> ExpQ mkEqF d pats con = let dVars = dataParamTypes d -- the type arguments for the constructor -- bnd is the list of type arguments for this datatype. Since -- this is Functor equality, ignore the final type since this is -- a higher-kinded equality. bnd | null dVars = Set.empty | otherwise = typeVars (init dVars) in mkSimpleEqF dVars bnd pats con -- | @structuralTypeEquality f@ returns a function with the type: -- @ -- forall x y . f x -> f y -> Maybe (x :~: y) -- @ structuralTypeEquality :: TypeQ -> [(TypePat,ExpQ)] -> ExpQ structuralTypeEquality tpq pats = do d <- reifyDatatype =<< asTypeCon "structuralTypeEquality" =<< tpq let multipleCons = not (null (drop 1 (datatypeCons d))) trueEqs yQ = [ do (xp,xv) <- conPat con "x" match (pure xp) (normalB (mkEqF d pats con xv yQ multipleCons)) [] | con <- datatypeCons d ] if null (datatypeCons d) then [| \x -> case x of {} |] else [| \x y -> $(caseE [| x |] (trueEqs [| y |])) |] -- | @structuralTypeOrd f@ returns a function with the type: -- @ -- forall x y . f x -> f y -> OrderingF x y -- @ -- -- This implementation avoids matching on both the first and second -- parameters in a simple case expression in order to avoid stressing -- GHC's coverage checker. In the case that the first and second parameters -- have unique constructors, a simple numeric comparison is done to -- compute the result. structuralTypeOrd :: TypeQ -> [(TypePat,ExpQ)] {- ^ List of type patterns to match. -} -> ExpQ structuralTypeOrd tpq l = do d <- reifyDatatype =<< asTypeCon "structuralTypeEquality" =<< tpq let withNumber :: ExpQ -> (Maybe ExpQ -> ExpQ) -> ExpQ withNumber yQ k | null (drop 1 (datatypeCons d)) = k Nothing | otherwise = [| let yn :: Int yn = $(caseE yQ (constructorNumberMatches (datatypeCons d))) in $(k (Just [| yn |])) |] if null (datatypeCons d) then [| \x -> case x of {} |] else [| \x y -> $(withNumber [|y|] $ \mbYn -> caseE [| x |] (outerOrdMatches d [|y|] mbYn)) |] where constructorNumberMatches :: [ConstructorInfo] -> [MatchQ] constructorNumberMatches cons = [ match (recP (constructorName con) []) (normalB (litE (integerL i))) [] | (i,con) <- zip [0..] cons ] outerOrdMatches :: DatatypeInfo -> ExpQ -> Maybe ExpQ -> [MatchQ] outerOrdMatches d yExp mbYn = [ do (pat,xv) <- conPat con "x" match (pure pat) (normalB (do xs <- mkOrdF d l con i mbYn xv caseE yExp xs)) [] | (i,con) <- zip [0..] (datatypeCons d) ] -- | Generate a list of fresh names using the base name -- and numbered 1 to @n@ to make them useful in conjunction with -- @-dsuppress-uniques@. newNames :: String {- ^ base name -} -> Int {- ^ quantity -} -> Q [Name] {- ^ list of names: @base1@, @base2@, ... -} newNames base n = traverse (\i -> newName (base ++ show i)) [1..n] joinCompareF :: ExpQ -> Name -> Name -> ExpQ -> ExpQ joinCompareF f x y r = do [| case $(f) $(varE x) $(varE y) of LTF -> LTF GTF -> GTF EQF -> $(r) |] -- | Compare two variables, returning the third argument if they are equal. -- -- This returns an 'OrdF' instance. joinCompareToOrdF :: Name -> Name -> ExpQ -> ExpQ joinCompareToOrdF x y r = [| case compare $(varE x) $(varE y) of LT -> LTF GT -> GTF EQ -> $(r) |] -- | Match expression with given type to variables matchOrdArguments :: [Type] -- ^ Types bound by data arguments -> [(TypePat,ExpQ)] -- ^ Patterns for matching arguments -> Name -- ^ Name of constructor. -> Set Name -- ^ Names bound in data declaration -> [Type] -- ^ Types for constructors -> [Name] -- ^ Variables bound in first pattern -> [Name] -- ^ Variables bound in second pattern -> ExpQ matchOrdArguments dTypes pats cnm bnd (tp : tpl) (x:xl) (y:yl) = do doesMatch <- assocTypePats dTypes pats tp case doesMatch of Just f -> do let bnd' = case tp of AppT _ (VarT nm) -> Set.insert nm bnd _ -> bnd joinCompareF f x y (matchOrdArguments dTypes pats cnm bnd' tpl xl yl) Nothing | typeVars tp `Set.isSubsetOf` bnd -> do joinCompareToOrdF x y (matchOrdArguments dTypes pats cnm bnd tpl xl yl) Nothing -> fail $ "Unsupported argument type " ++ show (ppr tp) ++ " in " ++ show (ppr cnm) ++ "." matchOrdArguments _ _ _ _ [] [] [] = [| EQF |] matchOrdArguments _ _ _ _ [] _ _ = error "Unexpected end of types." matchOrdArguments _ _ _ _ _ [] _ = error "Unexpected end of names." matchOrdArguments _ _ _ _ _ _ [] = error "Unexpected end of names." mkSimpleOrdF :: [Type] -- ^ Data declaration types -> [(TypePat,ExpQ)] -- ^ Patterns for matching arguments -> ConstructorInfo -- ^ Information about the second constructor -> Integer -- ^ First constructor's index -> Maybe ExpQ -- ^ Optional second constructor's index -> [Name] -- ^ Name from first pattern -> Q [MatchQ] mkSimpleOrdF dTypes pats con xnum mbYn xv = do (yp,yv) <- conPat con "y" let rv = matchOrdArguments dTypes pats (constructorName con) Set.empty (constructorFields con) xv yv -- Return match expression return $ match (pure yp) (normalB rv) [] : case mbYn of Nothing -> [] Just yn -> [match wildP (normalB [| if xnum < $yn then LTF else GTF |]) []] -- | Match equational form. mkOrdF :: DatatypeInfo -- ^ Data declaration. -> [(TypePat,ExpQ)] -- ^ Patterns for matching arguments -> ConstructorInfo -> Integer -> Maybe ExpQ -- ^ optional right constructr index -> [Name] -> Q [MatchQ] mkOrdF d pats = mkSimpleOrdF (datatypeInstTypes d) pats -- | @genTraverseOfType f var tp@ applies @f@ to @var@ where @var@ has type @tp@. genTraverseOfType :: [Type] -- ^ Argument types for the data declaration. -> [(TypePat, ExpQ)] -- ^ Patterrns the user provided for overriding type lookup. -> ExpQ -- ^ Function to apply -> ExpQ -- ^ Expression denoting value of this constructor field. -> Type -- ^ Type bound for this constructor field. -> Q (Maybe Exp) genTraverseOfType dataArgs pats f v tp = do mr <- assocTypePats dataArgs pats tp case mr of Just g -> Just <$> [| $(g) $(f) $(v) |] Nothing -> case tp of AppT (ConT _) (AppT (VarT _) _) -> Just <$> [| traverse $(f) $(v) |] AppT (VarT _) _ -> Just <$> [| $(f) $(v) |] _ -> return Nothing -- | @traverseAppMatch patMatch cexp @ builds a case statement that matches a term with -- the constructor @c@ and applies @f@ to each argument. traverseAppMatch :: [Type] -- ^ Argument types for the data declaration. -> [(TypePat, ExpQ)] -- ^ Patterrns the user provided for overriding type lookup. -> ExpQ -- ^ Function @f@ given to `traverse` -> ConstructorInfo -- ^ Constructor to match. -> MatchQ traverseAppMatch dataArgs pats fv c0 = do (pat,patArgs) <- conPat c0 "p" exprs <- zipWithM (genTraverseOfType dataArgs pats fv) (varE <$> patArgs) (constructorFields c0) let mkRes :: ExpQ -> [(Name, Maybe Exp)] -> ExpQ mkRes e [] = e mkRes e ((v,Nothing):r) = mkRes (appE e (varE v)) r mkRes e ((_,Just{}):r) = do v <- newName "r" lamE [varP v] (mkRes (appE e (varE v)) r) -- Apply the remaining argument to the expression in list. let applyRest :: ExpQ -> [Exp] -> ExpQ applyRest e [] = e applyRest e (a:r) = applyRest [| $(e) <*> $(pure a) |] r -- Apply the first argument to the list let applyFirst :: ExpQ -> [Exp] -> ExpQ applyFirst e [] = [| pure $(e) |] applyFirst e (a:r) = applyRest [| $(e) <$> $(pure a) |] r let pargs = patArgs `zip` exprs let rhs = applyFirst (mkRes (pure (conExpr c0)) pargs) (catMaybes exprs) match (pure pat) (normalB rhs) [] -- | @structuralTraversal tp@ generates a function that applies -- a traversal @f@ to the subterms with free variables in @tp@. structuralTraversal :: TypeQ -> [(TypePat, ExpQ)] -> ExpQ structuralTraversal tpq pats0 = do d <- reifyDatatype =<< asTypeCon "structuralTraversal" =<< tpq f <- newName "f" a <- newName "a" lamE [varP f, varP a] $ caseE (varE a) (traverseAppMatch (datatypeInstTypes d) pats0 (varE f) <$> datatypeCons d) asTypeCon :: String -> Type -> Q Name asTypeCon _ (ConT nm) = return nm asTypeCon fn _ = fail (fn ++ " expected type constructor.") -- | @structuralHash tp@ generates a function with the type -- @Int -> tp -> Int@ that hashes type. -- -- All arguments use `hashable`, and `structuralHashWithSalt` can be -- used instead as it allows user-definable patterns to be used at -- specific types. structuralHash :: TypeQ -> ExpQ structuralHash tpq = structuralHashWithSalt tpq [] {-# DEPRECATED structuralHash "Use structuralHashWithSalt" #-} -- | @structuralHashWithSalt tp@ generates a function with the type -- @Int -> tp -> Int@ that hashes type. -- -- The second arguments is for generating user-defined patterns to replace -- `hashWithSalt` for specific types. structuralHashWithSalt :: TypeQ -> [(TypePat, ExpQ)] -> ExpQ structuralHashWithSalt tpq pats = do d <- reifyDatatype =<< asTypeCon "structuralHash" =<< tpq s <- newName "s" a <- newName "a" lamE [varP s, varP a] $ caseE (varE a) (zipWith (matchHashCtor d pats (varE s)) [0..] (datatypeCons d)) -- | This matches one of the constructors in a datatype when generating -- a `hashWithSalt` function. matchHashCtor :: DatatypeInfo -- ^ Data declaration of type we are hashing. -> [(TypePat, ExpQ)] -- ^ User provide type patterns -> ExpQ -- ^ Initial salt expression -> Integer -- ^ Index of constructor -> ConstructorInfo -- ^ Constructor information -> MatchQ matchHashCtor d pats s0 i c = do (pat,vars) <- conPat c "x" let go s (e, tp) = do mr <- assocTypePats (datatypeInstTypes d) pats tp case mr of Just f -> do [| $(f) $(s) $(e) |] Nothing -> [| hashWithSalt $(s) $(e) |] let s1 = [| hashWithSalt $(s0) ($(litE (IntegerL i)) :: Int) |] let rhs = foldl go s1 (zip (varE <$> vars) (constructorFields c)) match (pure pat) (normalB rhs) [] -- | @structuralShow tp@ generates a function with the type -- @tp -> ShowS@ that shows the constructor. structuralShowsPrec :: TypeQ -> ExpQ structuralShowsPrec tpq = do d <- reifyDatatype =<< asTypeCon "structuralShowPrec" =<< tpq p <- newName "_p" a <- newName "a" lamE [varP p, varP a] $ caseE (varE a) (matchShowCtor (varE p) <$> datatypeCons d) showCon :: ExpQ -> Name -> Int -> MatchQ showCon p nm n = do vars <- newNames "x" n let pat = conPCompat nm (VarP <$> vars) let go s e = [| $(s) . showChar ' ' . showsPrec 11 $(varE e) |] let ctor = [| showString $(return (LitE (StringL (nameBase nm)))) |] let rhs | null vars = ctor | otherwise = [| showParen ($(p) >= 11) $(foldl go ctor vars) |] match (pure pat) (normalB rhs) [] matchShowCtor :: ExpQ -> ConstructorInfo -> MatchQ matchShowCtor p con = showCon p (constructorName con) (length (constructorFields con)) -- | Generate a \"repr\" or singleton type from a data kind. For nullary -- constructors, this works as follows: -- -- @ -- data T1 = A | B | C -- \$(mkRepr ''T1) -- ======> -- data T1Repr (tp :: T1) -- where -- ARepr :: T1Repr 'A -- BRepr :: T1Repr 'B -- CRepr :: T1Repr 'C -- @ -- -- For constructors with fields, we assume each field type @T@ already has a -- corresponding repr type @TRepr :: T -> *@. -- -- @ -- data T2 = T2_1 T1 | T2_2 T1 -- \$(mkRepr ''T2) -- ======> -- data T2Repr (tp :: T2) -- where -- T2_1Repr :: T1Repr tp -> T2Repr ('T2_1 tp) -- T2_2Repr :: T1Repr tp -> T2Repr ('T2_2 tp) -- @ -- -- Constructors with multiple fields work fine as well: -- -- @ -- data T3 = T3 T1 T2 -- \$(mkRepr ''T3) -- ======> -- data T3Repr (tp :: T3) -- where -- T3Repr :: T1Repr tp1 -> T2Repr tp2 -> T3Repr ('T3 tp1 tp2) -- @ -- -- This is generally compatible with other \"repr\" types provided by -- @parameterized-utils@, such as @NatRepr@ and @PeanoRepr@: -- -- @ -- data T4 = T4_1 Nat | T4_2 Peano -- \$(mkRepr ''T4) -- ======> -- data T4Repr (tp :: T4) -- where -- T4Repr :: NatRepr tp1 -> PeanoRepr tp2 -> T4Repr ('T4 tp1 tp2) -- @ -- -- The data kind must be \"simple\", i.e. it must be monomorphic and only -- contain user-defined data constructors (no lists, tuples, etc.). For example, -- the following will not work: -- -- @ -- data T5 a = T5 a -- \$(mkRepr ''T5) -- ======> -- Foo.hs:1:1: error: -- Exception when trying to run compile-time code: -- mkRepr cannot be used on polymorphic data kinds. -- @ -- -- Similarly, this will not work: -- -- @ -- data T5 = T5 [Nat] -- \$(mkRepr ''T5) -- ======> -- Foo.hs:1:1: error: -- Exception when trying to run compile-time code: -- mkRepr cannot be used on this data kind. -- @ -- -- Note that at a minimum, you will need the following extensions to use this macro: -- -- @ -- {-\# LANGUAGE DataKinds \#-} -- {-\# LANGUAGE GADTs \#-} -- {-\# LANGUAGE KindSignatures \#-} -- {-\# LANGUAGE TemplateHaskell \#-} -- @ mkRepr :: Name -> DecsQ mkRepr typeName = do let reprTypeName = mkReprName typeName varName = mkName "tp" info <- lookupDataType' typeName let gc ci = do let ctorName = constructorName ci reprCtorName = mkReprName ctorName ctorFieldTypeNames = getCtorName <$> constructorFields ci ctorFieldReprNames = mkReprName <$> ctorFieldTypeNames -- Generate a list of type variables to be supplied as type arguments -- for each repr argument. tvars <- replicateM (length (constructorFields ci)) (newName "tp") let appliedType = foldl AppT (PromotedT (constructorName ci)) (VarT <$> tvars) ctorType = AppT (ConT reprTypeName) appliedType ctorArgTypes = zipWith (\n v -> (Bang NoSourceUnpackedness NoSourceStrictness, AppT (ConT n) (VarT v))) ctorFieldReprNames tvars return $ GadtC [reprCtorName] ctorArgTypes ctorType ctors <- mapM gc (datatypeCons info) return $ [ DataD [] reprTypeName [kindedTV varName (ConT typeName)] Nothing ctors [] ] where getCtorName :: Type -> Name getCtorName c = case c of ConT nm -> nm VarT _ -> error $ "mkRepr cannot be used on polymorphic data kinds." _ -> error $ "mkRepr cannot be used on this data kind." -- | Generate @KnownRepr@ instances for each constructor of a data kind. Given a -- data kind @T@, we assume a repr type @TRepr (t :: T)@ is in scope with -- structure that perfectly matches @T@ (using 'mkRepr' to generate the repr -- type will guarantee this). -- -- Given data kinds @T1@, @T2@, and @T3@ from the documentation of 'mkRepr', and -- the associated repr types @T1Repr@, @T2Repr@, and @T3Repr@, we can use -- 'mkKnownReprs' to generate these instances like so: -- -- @ -- \$(mkKnownReprs ''T1) -- ======> -- instance KnownRepr T1Repr 'A where -- knownRepr = ARepr -- instance KnownRepr T1Repr 'B where -- knownRepr = BRepr -- instance KnownRepr T1Repr 'C where -- knownRepr = CRepr -- @ -- -- @ -- \$(mkKnownReprs ''T2) -- ======> -- instance KnownRepr T1Repr tp => -- KnownRepr T2Repr ('T2_1 tp) where -- knownRepr = T2_1Repr knownRepr -- @ -- -- @ -- \$(mkKnownReprs ''T3) -- ======> -- instance (KnownRepr T1Repr tp1, KnownRepr T2Repr tp2) => -- KnownRepr T3Repr ('T3_1 tp1 tp2) where -- knownRepr = T3_1Repr knownRepr knownRepr -- @ -- -- The same restrictions that apply to 'mkRepr' also apply to 'mkKnownReprs'. -- The data kind must be \"simple\", i.e. it must be monomorphic and only -- contain user-defined data constructors (no lists, tuples, etc.). -- -- Note that at a minimum, you will need the following extensions to use this macro: -- -- @ -- {-\# LANGUAGE DataKinds \#-} -- {-\# LANGUAGE GADTs \#-} -- {-\# LANGUAGE KindSignatures \#-} -- {-\# LANGUAGE MultiParamTypeClasses \#-} -- {-\# LANGUAGE TemplateHaskell \#-} -- @ -- -- Also, 'mkKnownReprs' must be used in the same module as the definition of -- the repr type (not necessarily for the data kind). mkKnownReprs :: Name -> DecsQ mkKnownReprs typeName = do kr <- [t|KnownRepr|] let krFName = mkName "knownRepr" reprTypeName = mkReprName typeName typeInfo <- lookupDataType' typeName reprInfo <- lookupDataType' reprTypeName forM (zip (datatypeCons typeInfo) (datatypeCons reprInfo)) $ \(tci, rci) -> do vars <- replicateM (length (constructorFields tci)) (newName "tp") krReqs <- forM (zip (constructorFields tci) vars) $ \(tfld, v) -> do let fldReprName = mkReprName (getCtorName tfld) return $ AppT (AppT kr (ConT fldReprName)) (VarT v) let appliedType = foldl AppT (PromotedT (constructorName tci)) (VarT <$> vars) krConstraint = AppT (AppT kr (ConT reprTypeName)) appliedType krExp = foldl AppE (ConE (constructorName rci)) $ map (const (VarE krFName)) vars krDec = FunD krFName [Clause [] (NormalB krExp) []] return $ InstanceD Nothing krReqs krConstraint [krDec] where getCtorName :: Type -> Name getCtorName c = case c of ConT nm -> nm VarT _ -> error $ "mkKnownReprs cannot be used on polymorphic data kinds." _ -> error $ "mkKnownReprs cannot be used on this data kind." mkReprName :: Name -> Name mkReprName nm = mkName (nameBase nm ++ "Repr") conPCompat :: Name -> [Pat] -> Pat conPCompat n pats = ConP n #if MIN_VERSION_template_haskell(2,18,0) [] #endif pats -- $typePatterns -- -- The Template Haskell instance generators 'structuralEquality', -- 'structuralTypeEquality', 'structuralTypeOrd', and 'structuralTraversal' -- employ heuristics to generate valid instances in the majority of cases. Most -- failures in the heuristics occur on sub-terms that are type indexed. To -- handle cases where these functions fail to produce a valid instance, they -- take a list of exceptions in the form of their second parameter, which has -- type @[('TypePat', 'ExpQ')]@. Each 'TypePat' is a /matcher/ that tells the -- TH generator to use the 'ExpQ' to process the matched sub-term. Consider the -- following example: -- -- > data T a b where -- > C1 :: NatRepr n -> T () n -- > -- > instance TestEquality (T a) where -- > testEquality = $(structuralTypeEquality [t|T|] -- > [ (ConType [t|NatRepr|] `TypeApp` AnyType, [|testEquality|]) -- > ]) -- -- The exception list says that 'structuralTypeEquality' should use -- 'testEquality' to compare any sub-terms of type @'NatRepr' n@ in a value of -- type @T@. -- -- * 'AnyType' means that the type parameter in that position can be instantiated as any type -- -- * @'DataArg' n@ means that the type parameter in that position is the @n@-th -- type parameter of the GADT being traversed (@T@ in the example) -- -- * 'TypeApp' is type application -- -- * 'ConType' specifies a base type -- -- The exception list could have equivalently (and more precisely) have been specified as: -- -- > [(ConType [t|NatRepr|] `TypeApp` DataArg 1, [|testEquality|])] -- -- The use of 'DataArg' says that the type parameter of the 'NatRepr' must -- be the same as the second type parameter of @T@. -- $reprs -- -- When working with data kinds with run-time representatives, we encourage -- users of @parameterized-utils@ to use the following convention. Given a data -- kind defined by -- -- @ -- data T = ... -- @ -- -- users should also supply a GADT @TRepr@ parameterized by @T@, e.g. -- -- @ -- data TRepr (t :: T) where ... -- @ -- -- Each constructor of @TRepr@ should correspond to a constructor of @T@. If @T@ -- is defined by -- -- @ -- data T = A | B Nat -- @ -- -- we have a corresponding -- -- @ -- data TRepr (t :: T) where -- ARepr :: TRepr 'A -- BRepr :: NatRepr w -> TRepr ('B w) -- @ -- -- Assuming the user of @parameterized-utils@ follows this convention, we -- provide the Template Haskell construct 'mkRepr' to automate the creation of -- the @TRepr@ GADT. We also provide 'mkKnownReprs', which generates 'KnownRepr' -- instances for that GADT type. See the documentation for those two functions -- for more detailed explanations. -- -- NB: These macros are inspired by the corresponding macros provided by -- @singletons-th@, and the \"repr\" programming idiom is very similar to the one -- used by @singletons@. parameterized-utils-2.1.7.0/src/Data/Parameterized/TraversableF.hs0000644000000000000000000001530707346545000023220 0ustar0000000000000000------------------------------------------------------------------------ -- | -- Module : Data.Parameterized.TraversableF -- Copyright : (c) Galois, Inc 2014-2019 -- Maintainer : Joe Hendrix -- Description : Traversing structures having a single parametric type -- -- This module declares classes for working with structures that accept -- a single parametric type parameter. ------------------------------------------------------------------------ {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-} module Data.Parameterized.TraversableF ( FunctorF(..) , FoldableF(..) , foldlMF , foldlMF' , foldrMF , foldrMF' , TraversableF(..) , traverseF_ , forF_ , forF , fmapFDefault , foldMapFDefault , allF , anyF , lengthF ) where import Control.Applicative import Control.Monad.Identity import Data.Coerce import Data.Functor.Compose (Compose(..)) import Data.Kind import Data.Monoid import GHC.Exts (build) import Data.Parameterized.TraversableFC -- | A parameterized type that is a functor on all instances. class FunctorF m where fmapF :: (forall x . f x -> g x) -> m f -> m g instance FunctorF (Const x) where fmapF _ = coerce ------------------------------------------------------------------------ -- FoldableF -- | This is a coercion used to avoid overhead associated -- with function composition. (#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c) (#.) _f = coerce -- | This is a generalization of the 'Foldable' class to -- structures over parameterized terms. class FoldableF (t :: (k -> Type) -> Type) where {-# MINIMAL foldMapF | foldrF #-} -- | Map each element of the structure to a monoid, -- and combine the results. foldMapF :: Monoid m => (forall s . e s -> m) -> t e -> m foldMapF f = foldrF (mappend . f) mempty -- | Right-associative fold of a structure. foldrF :: (forall s . e s -> b -> b) -> b -> t e -> b foldrF f z t = appEndo (foldMapF (Endo #. f) t) z -- | Left-associative fold of a structure. foldlF :: (forall s . b -> e s -> b) -> b -> t e -> b foldlF f z t = appEndo (getDual (foldMapF (\e -> Dual (Endo (\r -> f r e))) t)) z -- | Right-associative fold of a structure, -- but with strict application of the operator. foldrF' :: (forall s . e s -> b -> b) -> b -> t e -> b foldrF' f0 z0 xs = foldlF (f' f0) id xs z0 where f' f k x z = k $! f x z -- | Left-associative fold of a parameterized structure -- with a strict accumulator. foldlF' :: (forall s . b -> e s -> b) -> b -> t e -> b foldlF' f0 z0 xs = foldrF (f' f0) id xs z0 where f' f x k z = k $! f z x -- | Convert structure to list. toListF :: (forall tp . f tp -> a) -> t f -> [a] toListF f t = build (\c n -> foldrF (\e v -> c (f e) v) n t) -- | Monadic fold over the elements of a structure from left to right. foldlMF :: (FoldableF t, Monad m) => (forall x . b -> f x -> m b) -> b -> t f -> m b foldlMF f z0 xs = foldrF f' return xs z0 where f' x k z = f z x >>= k -- | Monadic strict fold over the elements of a structure from left to right. foldlMF' :: (FoldableF t, Monad m) => (forall x . b -> f x -> m b) -> b -> t f -> m b foldlMF' f z0 xs = seq z0 (foldrF f' return xs z0) where f' x k z = f z x >>= \r -> seq r (k r) -- | Monadic fold over the elements of a structure from right to left. foldrMF :: (FoldableF t, Monad m) => (forall x . f x -> b -> m b) -> b -> t f -> m b foldrMF f z0 xs = foldlF f' return xs z0 where f' k x z = f x z >>= k -- | Monadic strict fold over the elements of a structure from right to left. foldrMF' :: (FoldableF t, Monad m) => (forall x . f x -> b -> m b) -> b -> t f -> m b foldrMF' f z0 xs = seq z0 $ foldlF f' return xs z0 where f' k x z = f x z >>= \r -> seq r (k r) -- | Return 'True' if all values satisfy the predicate. allF :: FoldableF t => (forall tp . f tp -> Bool) -> t f -> Bool allF p = getAll #. foldMapF (All #. p) -- | Return 'True' if any values satisfy the predicate. anyF :: FoldableF t => (forall tp . f tp -> Bool) -> t f -> Bool anyF p = getAny #. foldMapF (Any #. p) -- | Return number of elements that we fold over. lengthF :: FoldableF t => t f -> Int lengthF = foldrF (const (+1)) 0 instance FoldableF (Const x) where foldMapF _ _ = mempty ------------------------------------------------------------------------ -- TraversableF class (FunctorF t, FoldableF t) => TraversableF t where traverseF :: Applicative m => (forall s . e s -> m (f s)) -> t e -> m (t f) instance TraversableF (Const x) where traverseF _ (Const x) = pure (Const x) -- | Flipped 'traverseF' forF :: (TraversableF t, Applicative m) => t e -> (forall s . e s -> m (f s)) -> m (t f) forF f x = traverseF x f {-# INLINE forF #-} -- | This function may be used as a value for `fmapF` in a `FunctorF` -- instance. fmapFDefault :: TraversableF t => (forall s . e s -> f s) -> t e -> t f fmapFDefault f = runIdentity #. traverseF (Identity #. f) {-# INLINE fmapFDefault #-} -- | This function may be used as a value for `Data.Foldable.foldMap` -- in a `Foldable` instance. foldMapFDefault :: (TraversableF t, Monoid m) => (forall s . e s -> m) -> t e -> m foldMapFDefault f = getConst #. traverseF (Const #. f) -- | Map each element of a structure to an action, evaluate -- these actions from left to right, and ignore the results. traverseF_ :: (FoldableF t, Applicative f) => (forall s . e s -> f a) -> t e -> f () traverseF_ f = foldrF (\e r -> f e *> r) (pure ()) -- | Map each element of a structure to an action, evaluate -- these actions from left to right, and ignore the results. forF_ :: (FoldableF t, Applicative m) => t f -> (forall x. f x -> m a) -> m () forF_ v f = traverseF_ f v {-# INLINE forF_ #-} ------------------------------------------------------------------------ -- TraversableF (Compose s t) instance ( FunctorF (s :: (k -> Type) -> Type) , FunctorFC (t :: (l -> Type) -> (k -> Type)) ) => FunctorF (Compose s t) where fmapF f (Compose v) = Compose $ fmapF (fmapFC f) v instance ( TraversableF (s :: (k -> Type) -> Type) , TraversableFC (t :: (l -> Type) -> (k -> Type)) ) => FoldableF (Compose s t) where foldMapF = foldMapFDefault -- | Traverse twice over: go under the @t@, under the @s@ and lift @m@ out. instance ( TraversableF (s :: (k -> Type) -> Type) , TraversableFC (t :: (l -> Type) -> (k -> Type)) ) => TraversableF (Compose s t) where traverseF :: forall (f :: l -> Type) (g :: l -> Type) m. (Applicative m) => (forall (u :: l). f u -> m (g u)) -> Compose s t f -> m (Compose s t g) traverseF f (Compose v) = Compose <$> traverseF (traverseFC f) v parameterized-utils-2.1.7.0/src/Data/Parameterized/TraversableFC.hs0000644000000000000000000002011007346545000023307 0ustar0000000000000000------------------------------------------------------------------------ -- | -- Module : Data.Parameterized.TraversableFC -- Copyright : (c) Galois, Inc 2014-2015 -- Maintainer : Joe Hendrix -- Description : Traversing structures having a single parametric type followed by a fixed kind. -- -- This module declares classes for working with structures that accept -- a parametric type parameter followed by some fixed kind. ------------------------------------------------------------------------ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeOperators #-} module Data.Parameterized.TraversableFC ( TestEqualityFC(..) , OrdFC(..) , ShowFC(..) , HashableFC(..) , FunctorFC(..) , FoldableFC(..) , foldlMFC , foldlMFC' , foldrMFC , foldrMFC' , TraversableFC(..) , traverseFC_ , forMFC_ , forFC_ , forFC , fmapFCDefault , foldMapFCDefault , allFC , anyFC , lengthFC ) where import Control.Applicative (Const(..) ) import Control.Monad.Identity ( Identity (..) ) import Data.Coerce import Data.Kind import Data.Monoid import GHC.Exts (build) import Data.Type.Equality import Data.Parameterized.Classes -- | A parameterized type that is a functor on all instances. -- -- Laws: -- -- [Identity] @'fmapFC' 'id' == 'id'@ -- [Composition] @'fmapFC' (f . g) == 'fmapFC' f . 'fmapFC' g@ class FunctorFC (t :: (k -> Type) -> l -> Type) where fmapFC :: forall f g. (forall x. f x -> g x) -> (forall x. t f x -> t g x) -- | A parameterized class for types which can be shown, when given -- functions to show parameterized subterms. class ShowFC (t :: (k -> Type) -> l -> Type) where {-# MINIMAL showFC | showsPrecFC #-} showFC :: forall f. (forall x. f x -> String) -> (forall x. t f x -> String) showFC sh x = showsPrecFC (\_prec z rest -> sh z ++ rest) 0 x [] showsPrecFC :: forall f. (forall x. Int -> f x -> ShowS) -> (forall x. Int -> t f x -> ShowS) showsPrecFC sh _prec x rest = showFC (\z -> sh 0 z []) x ++ rest -- | A parameterized class for types which can be hashed, when given -- functions to hash parameterized subterms. class HashableFC (t :: (k -> Type) -> l -> Type) where hashWithSaltFC :: forall f. (forall x. Int -> f x -> Int) -> (forall x. Int -> t f x -> Int) -- | A parameterized class for types which can be tested for parameterized equality, -- when given an equality test for subterms. class TestEqualityFC (t :: (k -> Type) -> l -> Type) where testEqualityFC :: forall f. (forall x y. f x -> f y -> (Maybe (x :~: y))) -> (forall x y. t f x -> t f y -> (Maybe (x :~: y))) -- | A parameterized class for types which can be tested for parameterized ordering, -- when given an comparison test for subterms. class TestEqualityFC t => OrdFC (t :: (k -> Type) -> l -> Type) where compareFC :: forall f. (forall x y. f x -> f y -> OrderingF x y) -> (forall x y. t f x -> t f y -> OrderingF x y) ------------------------------------------------------------------------ -- FoldableF -- | This is a coercion used to avoid overhead associated -- with function composition. (#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c) (#.) _f = coerce -- | This is a generalization of the 'Foldable' class to -- structures over parameterized terms. class FoldableFC (t :: (k -> Type) -> l -> Type) where {-# MINIMAL foldMapFC | foldrFC #-} -- | Map each element of the structure to a monoid, -- and combine the results. foldMapFC :: forall f m. Monoid m => (forall x. f x -> m) -> (forall x. t f x -> m) foldMapFC f = foldrFC (mappend . f) mempty -- | Right-associative fold of a structure. foldrFC :: forall f b. (forall x. f x -> b -> b) -> (forall x. b -> t f x -> b) foldrFC f z t = appEndo (foldMapFC (Endo #. f) t) z -- | Left-associative fold of a structure. foldlFC :: forall f b. (forall x. b -> f x -> b) -> (forall x. b -> t f x -> b) foldlFC f z t = appEndo (getDual (foldMapFC (\e -> Dual (Endo (\r -> f r e))) t)) z -- | Right-associative fold of a structure, -- but with strict application of the operator. foldrFC' :: forall f b. (forall x. f x -> b -> b) -> (forall x. b -> t f x -> b) foldrFC' f0 z0 xs = foldlFC (f' f0) id xs z0 where f' f k x z = k $! f x z -- | Left-associative fold of a parameterized structure -- with a strict accumulator. foldlFC' :: forall f b. (forall x. b -> f x -> b) -> (forall x. b -> t f x -> b) foldlFC' f0 z0 xs = foldrFC (f' f0) id xs z0 where f' f x k z = k $! f z x -- | Convert structure to list. toListFC :: forall f a. (forall x. f x -> a) -> (forall x. t f x -> [a]) toListFC f t = build (\c n -> foldrFC (\e v -> c (f e) v) n t) -- | Monadic fold over the elements of a structure from left to right. foldlMFC :: (FoldableFC t, Monad m) => (forall x . b -> f x -> m b) -> b -> t f c -> m b foldlMFC f z0 xs = foldrFC f' return xs z0 where f' x k z = f z x >>= k -- | Monadic strict fold over the elements of a structure from left to right. foldlMFC' :: (FoldableFC t, Monad m) => (forall x . b -> f x -> m b) -> b -> t f c -> m b foldlMFC' f z0 xs = seq z0 $ foldrFC f' return xs z0 where f' x k z = f z x >>= \r -> seq r (k r) -- | Monadic fold over the elements of a structure from right to left. foldrMFC :: (FoldableFC t, Monad m) => (forall x . f x -> b -> m b) -> b -> t f c -> m b foldrMFC f z0 xs = foldlFC f' return xs z0 where f' k x z = f x z >>= k -- | Monadic strict fold over the elements of a structure from right to left. foldrMFC' :: (FoldableFC t, Monad m) => (forall x . f x -> b -> m b) -> b -> t f c -> m b foldrMFC' f z0 xs = seq z0 (foldlFC f' return xs z0) where f' k x z = f x z >>= \r -> seq r (k r) -- | Return 'True' if all values satisfy predicate. allFC :: FoldableFC t => (forall x. f x -> Bool) -> (forall x. t f x -> Bool) allFC p = getAll #. foldMapFC (All #. p) -- | Return 'True' if any values satisfy predicate. anyFC :: FoldableFC t => (forall x. f x -> Bool) -> (forall x. t f x -> Bool) anyFC p = getAny #. foldMapFC (Any #. p) -- | Return number of elements that we fold over. lengthFC :: FoldableFC t => t f x -> Int lengthFC = foldrFC (const (+1)) 0 ------------------------------------------------------------------------ -- TraversableF class (FunctorFC t, FoldableFC t) => TraversableFC (t :: (k -> Type) -> l -> Type) where traverseFC :: forall f g m. Applicative m => (forall x. f x -> m (g x)) -> (forall x. t f x -> m (t g x)) -- | This function may be used as a value for `fmapF` in a `FunctorF` -- instance. fmapFCDefault :: TraversableFC t => forall f g. (forall x. f x -> g x) -> (forall x. t f x -> t g x) fmapFCDefault = \f -> runIdentity . traverseFC (Identity . f) {-# INLINE fmapFCDefault #-} -- | This function may be used as a value for `Data.Foldable.foldMap` -- in a `Foldable` instance. foldMapFCDefault :: (TraversableFC t, Monoid m) => (forall x. f x -> m) -> (forall x. t f x -> m) foldMapFCDefault = \f -> getConst . traverseFC (Const . f) {-# INLINE foldMapFCDefault #-} -- | Map each element of a structure to an action, evaluate -- these actions from left to right, and ignore the results. traverseFC_ :: (FoldableFC t, Applicative m) => (forall x. f x -> m a) -> (forall x. t f x -> m ()) traverseFC_ f = foldrFC (\e r -> f e *> r) (pure ()) {-# INLINE traverseFC_ #-} -- | Map each element of a structure to an action, evaluate -- these actions from left to right, and ignore the results. forMFC_ :: (FoldableFC t, Applicative m) => t f c -> (forall x. f x -> m a) -> m () forMFC_ v f = traverseFC_ f v {-# INLINE forMFC_ #-} {-# DEPRECATED forMFC_ "Use forFC_" #-} -- | Map each element of a structure to an action, evaluate -- these actions from left to right, and ignore the results. forFC_ :: (FoldableFC t, Applicative m) => t f c -> (forall x. f x -> m a) -> m () forFC_ v f = traverseFC_ f v {-# INLINE forFC_ #-} -- | Flipped 'traverseFC' forFC :: (TraversableFC t, Applicative m) => t f x -> (forall y. f y -> m (g y)) -> m (t g x) forFC v f = traverseFC f v {-# INLINE forFC #-} parameterized-utils-2.1.7.0/src/Data/Parameterized/TraversableFC/0000755000000000000000000000000007346545000022761 5ustar0000000000000000parameterized-utils-2.1.7.0/src/Data/Parameterized/TraversableFC/WithIndex.hs0000644000000000000000000001130207346545000025215 0ustar0000000000000000------------------------------------------------------------------------ -- | -- 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 #-} parameterized-utils-2.1.7.0/src/Data/Parameterized/Utils/0000755000000000000000000000000007346545000021376 5ustar0000000000000000parameterized-utils-2.1.7.0/src/Data/Parameterized/Utils/BinTree.hs0000644000000000000000000002653207346545000023272 0ustar0000000000000000{-| Description : Utilities for balanced binary trees. Copyright : (c) Galois, Inc 2014-2019 Maintainer : Joe Hendrix -} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE Safe #-} module Data.Parameterized.Utils.BinTree ( MaybeS(..) , fromMaybeS , Updated(..) , updatedValue , TreeApp(..) , IsBinTree(..) , balanceL , balanceR , glue , merge , filterGt , filterLt , insert , delete , union , link , PairS(..) ) where import Control.Applicative ------------------------------------------------------------------------ -- MaybeS -- | A strict version of 'Maybe' data MaybeS v = JustS !v | NothingS instance Functor MaybeS where fmap _ NothingS = NothingS fmap f (JustS v) = JustS (f v) instance Alternative MaybeS where empty = NothingS mv@JustS{} <|> _ = mv NothingS <|> v = v instance Applicative MaybeS where pure = JustS NothingS <*> _ = NothingS JustS{} <*> NothingS = NothingS JustS f <*> JustS x = JustS (f x) fromMaybeS :: a -> MaybeS a -> a fromMaybeS r NothingS = r fromMaybeS _ (JustS v) = v ------------------------------------------------------------------------ -- Updated -- | @Updated a@ contains a value that has been flagged on whether it was -- modified by an operation. data Updated a = Updated !a | Unchanged !a updatedValue :: Updated a -> a updatedValue (Updated a) = a updatedValue (Unchanged a) = a ------------------------------------------------------------------------ -- IsBinTree data TreeApp e t = BinTree !e !t !t | TipTree class IsBinTree t e | t -> e where asBin :: t -> TreeApp e t tip :: t bin :: e -> t -> t -> t size :: t -> Int delta,ratio :: Int delta = 3 ratio = 2 -- | @balanceL p l r@ returns a balanced tree for the sequence @l ++ [p] ++ r@. -- -- It assumes that @l@ and @r@ are close to being balanced, and that only -- @l@ may contain too many elements. balanceL :: (IsBinTree c e) => e -> c -> c -> c balanceL p l r = do case asBin l of BinTree l_pair ll lr | size l > max 1 (delta*size r) -> case asBin lr of BinTree lr_pair lrl lrr | size lr >= max 2 (ratio*size ll) -> bin lr_pair (bin l_pair ll lrl) (bin p lrr r) _ -> bin l_pair ll (bin p lr r) _ -> bin p l r {-# INLINE balanceL #-} -- | @balanceR p l r@ returns a balanced tree for the sequence @l ++ [p] ++ r@. -- -- It assumes that @l@ and @r@ are close to being balanced, and that only -- @r@ may contain too many elements. balanceR :: (IsBinTree c e) => e -> c -> c -> c balanceR p l r = do case asBin r of BinTree r_pair rl rr | size r > max 1 (delta*size l) -> case asBin rl of BinTree rl_pair rll rlr | size rl >= max 2 (ratio*size rr) -> (bin rl_pair $! bin p l rll) $! bin r_pair rlr rr _ -> bin r_pair (bin p l rl) rr _ -> bin p l r {-# INLINE balanceR #-} -- | Insert a new maximal element. insertMax :: IsBinTree c e => e -> c -> c insertMax p t = case asBin t of TipTree -> bin p tip tip BinTree q l r -> balanceR q l (insertMax p r) -- | Insert a new minimal element. insertMin :: IsBinTree c e => e -> c -> c insertMin p t = case asBin t of TipTree -> bin p tip tip BinTree q l r -> balanceL q (insertMin p l) r -- | @link@ is called to insert a key and value between two disjoint subtrees. link :: IsBinTree c e => e -> c -> c -> c link p l r = case (asBin l, asBin r) of (TipTree, _) -> insertMin p r (_, TipTree) -> insertMax p l (BinTree py ly ry, BinTree pz lz rz) | delta*size l < size r -> balanceL pz (link p l lz) rz | delta*size r < size l -> balanceR py ly (link p ry r) | otherwise -> bin p l r {-# INLINE link #-} -- | A Strict pair data PairS f s = PairS !f !s deleteFindMin :: IsBinTree c e => e -> c -> c -> PairS e c deleteFindMin p l r = case asBin l of TipTree -> PairS p r BinTree lp ll lr -> case deleteFindMin lp ll lr of PairS q l' -> PairS q (balanceR p l' r) {-# INLINABLE deleteFindMin #-} deleteFindMax :: IsBinTree c e => e -> c -> c -> PairS e c deleteFindMax p l r = case asBin r of TipTree -> PairS p l BinTree rp rl rr -> case deleteFindMax rp rl rr of PairS q r' -> PairS q (balanceL p l r') {-# INLINABLE deleteFindMax #-} -- | Concatenate two trees that are ordered with respect to each other. merge :: IsBinTree c e => c -> c -> c merge l r = case (asBin l, asBin r) of (TipTree, _) -> r (_, TipTree) -> l (BinTree x lx rx, BinTree y ly ry) | delta*size l < size r -> balanceL y (merge l ly) ry | delta*size r < size l -> balanceR x lx (merge rx r) | size l > size r -> case deleteFindMax x lx rx of PairS q l' -> balanceR q l' r | otherwise -> case deleteFindMin y ly ry of PairS q r' -> balanceL q l r' {-# INLINABLE merge #-} ------------------------------------------------------------------------ -- Ordered operations -- | @insert p m@ inserts the binding into @m@. It returns -- an Unchanged value if the map stays the same size and an updated -- value if a new entry was inserted. insert :: (IsBinTree c e) => (e -> e -> Ordering) -> e -> c -> Updated c insert comp x t = case asBin t of TipTree -> Updated (bin x tip tip) BinTree y l r -> case comp x y of LT -> case insert comp x l of Updated l' -> Updated (balanceL y l' r) Unchanged l' -> Unchanged (bin y l' r) GT -> case insert comp x r of Updated r' -> Updated (balanceR y l r') Unchanged r' -> Unchanged (bin y l r') EQ -> Unchanged (bin x l r) {-# INLINABLE insert #-} -- | @glue l r@ concatenates @l@ and @r@. -- -- It assumes that @l@ and @r@ are already balanced with respect to each other. glue :: IsBinTree c e => c -> c -> c glue l r = case (asBin l, asBin r) of (TipTree, _) -> r (_, TipTree) -> l (BinTree x lx rx, BinTree y ly ry) | size l > size r -> case deleteFindMax x lx rx of PairS q l' -> balanceR q l' r | otherwise -> case deleteFindMin y ly ry of PairS q r' -> balanceL q l r' {-# INLINABLE glue #-} delete :: IsBinTree c e => (e -> Ordering) -- ^ Predicate that returns whether the entry is less than, greater than, or equal -- to the key we are entry that we are looking for. -> c -> MaybeS c delete k t = case asBin t of TipTree -> NothingS BinTree p l r -> case k p of LT -> (\l' -> balanceR p l' r) <$> delete k l GT -> (\r' -> balanceL p l r') <$> delete k r EQ -> JustS (glue l r) {-# INLINABLE delete #-} ------------------------------------------------------------------------ -- filter -- | Returns only entries that are less than predicate with respect to the ordering -- and Nothing if no elements are discarded. filterGt :: IsBinTree c e => (e -> Ordering) -> c -> MaybeS c filterGt k t = case asBin t of TipTree -> NothingS BinTree x l r -> case k x of LT -> (\l' -> link x l' r) <$> filterGt k l GT -> filterGt k r <|> JustS r EQ -> JustS r {-# INLINABLE filterGt #-} -- | @filterLt k m@ returns submap of @m@ that only contains entries -- that are smaller than @k@. If no entries are deleted then return Nothing. filterLt :: IsBinTree c e => (e -> Ordering) -> c -> MaybeS c filterLt k t = case asBin t of TipTree -> NothingS BinTree x l r -> case k x of LT -> filterLt k l <|> JustS l GT -> (\r' -> link x l r') <$> filterLt k r EQ -> JustS l {-# INLINABLE filterLt #-} ------------------------------------------------------------------------ -- Union -- | Insert a new key and value in the map if it is not already present. -- Used by 'union'. insertR :: forall c e . (IsBinTree c e) => (e -> e -> Ordering) -> e -> c -> c insertR comp e m = fromMaybeS m (go e m) where go :: e -> c -> MaybeS c go x t = case asBin t of TipTree -> JustS (bin x tip tip) BinTree y l r -> case comp x y of LT -> (\l' -> balanceL y l' r) <$> go x l GT -> (\r' -> balanceR y l r') <$> go x r EQ -> NothingS {-# INLINABLE insertR #-} -- | Union two sets union :: (IsBinTree c e) => (e -> e -> Ordering) -> c -> c -> c union comp t1 t2 = case (asBin t1, asBin t2) of (TipTree, _) -> t2 (_, TipTree) -> t1 (_, BinTree p (asBin -> TipTree) (asBin -> TipTree)) -> insertR comp p t1 (BinTree x l r, _) -> link x (hedgeUnion_UB comp x l t2) (hedgeUnion_LB comp x r t2) {-# INLINABLE union #-} -- | Hedge union where we only add elements in second map if key is -- strictly above a lower bound. hedgeUnion_LB :: (IsBinTree c e) => (e -> e -> Ordering) -> e -> c -> c -> c hedgeUnion_LB comp lo t1 t2 = case (asBin t1, asBin t2) of (_, TipTree) -> t1 (TipTree, _) -> fromMaybeS t2 (filterGt (comp lo) t2) -- Prune left tree. (_, BinTree k _ r) | comp k lo <= EQ -> hedgeUnion_LB comp lo t1 r -- Special case when t2 is a single element. (_, BinTree x (asBin -> TipTree) (asBin -> TipTree)) -> insertR comp x t1 -- Split on left-and-right subtrees of t1. (BinTree x l r, _) -> link x (hedgeUnion_LB_UB comp lo x l t2) (hedgeUnion_LB comp x r t2) {-# INLINABLE hedgeUnion_LB #-} -- | Hedge union where we only add elements in second map if key is -- strictly below a upper bound. hedgeUnion_UB :: (IsBinTree c e) => (e -> e -> Ordering) -> e -> c -> c -> c hedgeUnion_UB comp hi t1 t2 = case (asBin t1, asBin t2) of (_, TipTree) -> t1 (TipTree, _) -> fromMaybeS t2 (filterLt (comp hi) t2) -- Prune right tree. (_, BinTree x l _) | comp x hi >= EQ -> hedgeUnion_UB comp hi t1 l -- Special case when t2 is a single element. (_, BinTree x (asBin -> TipTree) (asBin -> TipTree)) -> insertR comp x t1 -- Split on left-and-right subtrees of t1. (BinTree x l r, _) -> link x (hedgeUnion_UB comp x l t2) (hedgeUnion_LB_UB comp x hi r t2) {-# INLINABLE hedgeUnion_UB #-} -- | Hedge union where we only add elements in second map if key is -- strictly between a lower and upper bound. hedgeUnion_LB_UB :: (IsBinTree c e) => (e -> e -> Ordering) -> e -> e -> c -> c -> c hedgeUnion_LB_UB comp lo hi t1 t2 = case (asBin t1, asBin t2) of (_, TipTree) -> t1 -- Prune left tree. (_, BinTree k _ r) | comp k lo <= EQ -> hedgeUnion_LB_UB comp lo hi t1 r -- Prune right tree. (_, BinTree k l _) | comp k hi >= EQ -> hedgeUnion_LB_UB comp lo hi t1 l -- When t1 becomes empty (assumes lo <= k <= hi) (TipTree, BinTree x l r) -> case (filterGt (comp lo) l, filterLt (comp hi) r) of -- No variables in t2 were eliminated. (NothingS, NothingS) -> t2 -- Relink t2 with filtered elements removed. (l',r') -> link x (fromMaybeS l l') (fromMaybeS r r') -- Special case when t2 is a single element. (_, BinTree x (asBin -> TipTree) (asBin -> TipTree)) -> insertR comp x t1 -- Split on left-and-right subtrees of t1. (BinTree x l r, _) -> link x (hedgeUnion_LB_UB comp lo x l t2) (hedgeUnion_LB_UB comp x hi r t2) {-# INLINABLE hedgeUnion_LB_UB #-} parameterized-utils-2.1.7.0/src/Data/Parameterized/Utils/Endian.hs0000644000000000000000000000110707346545000023127 0ustar0000000000000000{-| 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) parameterized-utils-2.1.7.0/src/Data/Parameterized/Vector.hs0000644000000000000000000006272107346545000022104 0ustar0000000000000000{-# 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 #-} parameterized-utils-2.1.7.0/src/Data/Parameterized/WithRepr.hs0000644000000000000000000000625007346545000022401 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} {-| Copyright : (c) Galois, Inc 2019 This module declares a class with a single method that can be used to derive a 'KnownRepr' constraint from an explicit 'Repr' argument. Clients of this method need only create an empty instance. The default implementation suffices. For example, suppose we have defined a 'Repr' type for 'Peano' numbers: @ data Peano = Z | S Peano data PeanoRepr p where ZRepr :: PeanoRepr Z SRepr :: PeanoRepr p -> PeanoRepr (S p) -- KnownRepr instances @ Then the instance for this class @ instance IsRepr PeanoRepr @ means that functions with 'KnownRepr' constraints can be used after pattern matching. @ f :: KnownRepr PeanoRepr a => ... example :: PeanoRepr n -> ... example ZRepr = ... example (SRepr (pm::PeanoRepr m)) = ... withRepr pm f ... @ NOTE: The type 'f' must be a *singleton* type--- i.e. for a given type 'a' there should be only one value that inhabits 'f a'. If that is not the case, this operation can be used to subvert coherence. Credit: the unsafe implementation of 'withRepr' is taken from the 'withSingI' function in the singletons library . Packaging this method in a class here makes it more flexible---we do not have to define a dedicated 'Sing' type, but can use any convenient singleton as a 'Repr'. NOTE: if this module is compiled without UNSAFE_OPS, the default method will not be available. -} module Data.Parameterized.WithRepr(IsRepr(..)) where import Data.Kind import Data.Parameterized.Classes #ifdef UNSAFE_OPS import Data.Constraint(Dict(..)) import Unsafe.Coerce(unsafeCoerce) import Data.Parameterized.NatRepr (NatRepr) import Data.Parameterized.SymbolRepr (SymbolRepr) import Data.Parameterized.Peano (PeanoRepr) import Data.Parameterized.Context(Assignment) import Data.Parameterized.List(List) #else import Data.Parameterized.Peano (PeanoRepr,PeanoView(..)) #endif import Data.Parameterized.BoolRepr -- | Turn an explicit Repr value into an implict KnownRepr constraint class IsRepr (f :: k -> Type) where withRepr :: f a -> (KnownRepr f a => r) -> r #ifdef UNSAFE_OPS withRepr si r = case reprInstance si of Dict -> r reprInstance :: forall f a . IsRepr f => f a -> Dict (KnownRepr f a) reprInstance s = with_repr Dict where with_repr :: (KnownRepr f a => Dict (KnownRepr f a)) -> Dict (KnownRepr f a) with_repr si = unsafeCoerce (Don'tInstantiate si) s newtype DI f a = Don'tInstantiate (KnownRepr f a => Dict (KnownRepr f a)) #endif ------------------------------------ -- Instances for types defined in parameterized-utils #ifdef UNSAFE_OPS instance IsRepr NatRepr instance IsRepr SymbolRepr instance IsRepr PeanoRepr instance IsRepr BoolRepr instance IsRepr f => IsRepr (List f) instance IsRepr f => IsRepr (Assignment f) #else -- awful, slow implementation for PeanoRepr instance IsRepr PeanoRepr where withRepr ZRepr f = f withRepr (SRepr m) f = withRepr m f instance IsRepr BoolRepr where withRepr TrueRepr f = f withRepr FalseRepr f = f #endif parameterized-utils-2.1.7.0/test/Test/0000755000000000000000000000000007346545000015740 5ustar0000000000000000parameterized-utils-2.1.7.0/test/Test/Context.hs0000644000000000000000000005441307346545000017727 0ustar0000000000000000{-# 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 ] parameterized-utils-2.1.7.0/test/Test/Fin.hs0000644000000000000000000000505007346545000017010 0ustar0000000000000000{-# 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 ] parameterized-utils-2.1.7.0/test/Test/FinMap.hs0000644000000000000000000004040707346545000017453 0ustar0000000000000000{-# 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 ] parameterized-utils-2.1.7.0/test/Test/List.hs0000644000000000000000000000145607346545000017215 0ustar0000000000000000module 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] ]parameterized-utils-2.1.7.0/test/Test/NatRepr.hs0000644000000000000000000000137107346545000017651 0ustar0000000000000000{-# 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 ] parameterized-utils-2.1.7.0/test/Test/Some.hs0000644000000000000000000000367307346545000017210 0ustar0000000000000000{-# 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)) ] parameterized-utils-2.1.7.0/test/Test/SymbolRepr.hs0000644000000000000000000000127007346545000020372 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} module Test.SymbolRepr ( symbolTests ) where import Test.Tasty import Test.Tasty.HUnit ( (@=?), testCase ) import Data.Parameterized.SymbolRepr import GHC.TypeLits data Bird (name :: Symbol) where Jay :: String -> Bird "Jay" Dove :: Bird "Dove" Hawk :: Bird "Hawk" symbolTests :: IO TestTree symbolTests = testGroup "Symbol" <$> return [ testCase "SomeSym" $ do let syms = [ SomeSym (Jay "Blue") , SomeSym Dove , SomeSym Hawk ] "Dove" @=? viewSomeSym symbolVal (head (tail syms)) ] parameterized-utils-2.1.7.0/test/Test/TH.hs0000644000000000000000000000473107346545000016614 0ustar0000000000000000{-# 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 ] parameterized-utils-2.1.7.0/test/Test/Vector.hs0000644000000000000000000002666707346545000017557 0ustar0000000000000000{-# 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 ] parameterized-utils-2.1.7.0/test/0000755000000000000000000000000007346545000015021 5ustar0000000000000000parameterized-utils-2.1.7.0/test/UnitTest.hs0000644000000000000000000000143307346545000017135 0ustar0000000000000000import 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 ]