constraints-0.10.1/0000755000000000000000000000000013316540016012325 5ustar0000000000000000constraints-0.10.1/CHANGELOG.markdown0000644000000000000000000001002613316540016015357 0ustar00000000000000000.10.1 [2018.07.02] ------------------- * Allow building with GHC 8.6. * Add three axioms about `(+)` and `(-)` to `Data.Constraint.Nat`. 0.10 ---- * Adapt to the `Semigroup`–`Monoid` Proposal (introduced in `base-4.11`): * Add a `Semigroup` instance for `Dict` * Add the appropriate `(:=>)` instances involving `Semigroup`, and change the `Class () (Monoid a)` instance to `Class (Semigroup a) (Monoid a)` when `base` is recent enough * Add the appropriate `Lifting(2)` instances involving `Semigroup` * `Data.Constraint.Nat` now reexports the `Div` and `Mod` type families from `GHC.TypeLits` on `base-4.11` or later * Fix the type signature of `maxCommutes` * Export the `no` method of `Bottom` * Add `NFData` instances for `Dict` and `(:-)` 0.9.1 ----- * Correct an improper use of `unsafeCoerce` in the internals of `Data.Constraint.Nat` and `Data.Constraint.Symbol` * Correctly identify the mismatched types when you defer an unsatisfiable equality constraint through `Data.Constraint.Deferrable` * Re-export the `(:~~:)` defined in `base` from `Data.Constraint.Deferred` with GHC 8.2 or later * Add several new `(:=>)` instances for `Bits`, `Identity`, `Const`, `Natural`, `IO`, and `Word`. * Modernize some existing `Class` and `(:=>)` instances to reflect the fact that `Applicative` is now a superclass of `Monad` on recent versions of `base`. 0.9 --- * Changes to `Data.Constraint`: * Add `strengthen1` and `strengthen2` * Changes to `Data.Constraint.Deferrable`: * Add a `Deferrable ()` instance * The `Deferrable (a ~ b)` instance now shows the `TypeRep`s of `a` and `b` when a type mismatch error is thrown * Add `defer_` and `deferEither_`, counterparts to `defer` and `deferEither` which do not require proxy arguments * Enable `PolyKinds`. This allows the `Deferrable (a ~ b` instance to be polykinded on all supported versions of GHC _except_ 7.10, where the kinds must be `*` due to an old GHC bug * Introduce a heterogeneous equality type `(:~~:)`, and use it to define a `Deferrable (a ~~ b)` instance on GHC 8.0 or later * Changes to `Data.Constraint.Forall`: * Implement `ForallF` and `ForallT` in terms of `Forall` * Add `ForallV` and `InstV` (supporting a variable number of parameters) * Add a `forall` combinator * Introduce `Data.Constraint.Nat` and `Data.Constraint.Symbol`, which contain utilities for working with `KnownNat` and `KnownSymbol` constraints, respectively. These modules are only available on GHC 8.0 or later. 0.8 ----- * GHC 8 compatibility * `transformers` 0.5 compatibility * `binary` 0.8 compatibility * Dropped support for GHC 7.6 in favor of a nicer Bottom representation. 0.7 --- * Found a nicer encoding of the initial object in the category of constraints using a [nullary constraint](https://ghc.haskell.org/trac/ghc/ticket/7642). 0.6.1 ----- * Remove the need for closed type families from the new `Forall`. 0.6 --- * Completely redesigned `Data.Constraint.Forall`. The old design is unsound and can be abused to define `unsafeCoerce`! The new design requires closed type families, so this module now requires GHC 7.8+ 0.5.1 ----- * Added `Data.Constraint.Deferrable`. 0.5 ----- * Added `Data.Constraint.Lifting`. 0.4.1.3 ------- * Acknowledge we actually need at least base 4.5 0.4.1.2 ------- * Restore support for building on older GHCs 0.4.1.1 ------- * Minor documentation fixes. 0.4.1 ----- * Added `mapDict` and `unmapDict`. * Added a lot of documentation. 0.4 --- * `Typeable` and `Data`. The `Data` instance for `(:-)` is a conservative approximation that avoids having to turn (:-) into a cartesian closed category. If it becomes a pain point for users, I know how to do that, and have done so in other libraries -- see [hask](http://github.com/ekmett/hask), but I'm hesitant to bring such heavy machinery to bear and it isn't clear how to do it in a way that is compatible with those other libraries. 0.3.5 ----- * Explicit role annotations 0.3.4.1 ------- * Fixed build failures. * Fixed an unused import warning on older GHCs. 0.3.4 ----- * Added `bottom` constraints-0.10.1/README.markdown0000644000000000000000000000107213316540016015026 0ustar0000000000000000constraints =========== [![Hackage](https://img.shields.io/hackage/v/constraints.svg)](https://hackage.haskell.org/package/constraints) [![Build Status](https://secure.travis-ci.org/ekmett/constraints.png?branch=master)](http://travis-ci.org/ekmett/constraints) This package provides data types and classes for manipulating the 'ConstraintKinds' exposed by GHC in 7.4. Contact Information ------------------- Contributions and bug reports are welcome! Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. -Edward Kmett constraints-0.10.1/constraints.cabal0000644000000000000000000000416013316540016015661 0ustar0000000000000000name: constraints category: Constraints version: 0.10.1 license: BSD2 cabal-version: >= 1.10 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett stability: experimental homepage: http://github.com/ekmett/constraints/ bug-reports: http://github.com/ekmett/constraints/issues copyright: Copyright (C) 2011-2015 Edward A. Kmett synopsis: Constraint manipulation description: GHC 7.4 gave us the ability to talk about @ConstraintKinds@. They stopped crashing the compiler in GHC 7.6. . This package provides a vocabulary for working with them. build-type: Simple tested-with: GHC == 7.8.4 , GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.3 , GHC == 8.6.1 extra-source-files: README.markdown , CHANGELOG.markdown source-repository head type: git location: git://github.com/ekmett/constraints.git library hs-source-dirs: src default-language: Haskell2010 other-extensions: FunctionalDependencies, ScopedTypeVariables, StandaloneDeriving, FlexibleInstances, FlexibleContexts, ConstraintKinds, KindSignatures, TypeOperators, Rank2Types, GADTs build-depends: base >= 4.7 && < 5, binary >= 0.7.1 && < 0.9, deepseq >= 1.3 && < 1.5, ghc-prim, hashable >= 1.2 && < 1.3, mtl >= 2.1.2 && < 2.3, semigroups >= 0.17 && < 0.19, transformers >= 0.3.0.0 && < 0.6, transformers-compat >= 0.5 && < 1 exposed-modules: Data.Constraint Data.Constraint.Deferrable Data.Constraint.Forall Data.Constraint.Lifting Data.Constraint.Unsafe if impl(ghc >= 8) exposed-modules: Data.Constraint.Nat Data.Constraint.Symbol ghc-options: -Wall test-suite spec type: exitcode-stdio-1.0 default-language: Haskell2010 hs-source-dirs: tests main-is: Spec.hs other-modules: GH55Spec ghc-options: -Wall -threaded -rtsopts build-tool-depends: hspec-discover:hspec-discover >= 2 build-depends: base >= 4.7 && < 5, constraints, hspec >= 2 constraints-0.10.1/LICENSE0000644000000000000000000000236413316540016013337 0ustar0000000000000000Copyright 2011-2015 Edward Kmett All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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. constraints-0.10.1/Setup.hs0000644000000000000000000000005613316540016013762 0ustar0000000000000000import Distribution.Simple main = defaultMain constraints-0.10.1/src/0000755000000000000000000000000013316540016013114 5ustar0000000000000000constraints-0.10.1/src/Data/0000755000000000000000000000000013316540016013765 5ustar0000000000000000constraints-0.10.1/src/Data/Constraint.hs0000644000000000000000000006230713316540016016455 0ustar0000000000000000{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE UndecidableSuperClasses #-} #endif #if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 {-# LANGUAGE NullaryTypeClasses #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Constraint -- Copyright : (C) 2011-2015 Edward Kmett, -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- -- @ConstraintKinds@ made type classes into types of a new kind, @Constraint@. -- -- @ -- 'Eq' :: * -> 'Constraint' -- 'Ord' :: * -> 'Constraint' -- 'Monad' :: (* -> *) -> 'Constraint' -- @ -- -- The need for this extension was first publicized in the paper -- -- -- -- by Ralf Lämmel and Simon Peyton Jones in 2005, which shoehorned all the -- things they needed into a custom 'Sat' typeclass. -- -- With @ConstraintKinds@ we can put into code a lot of tools for manipulating -- these new types without such awkward workarounds. ---------------------------------------------------------------------------- module Data.Constraint ( -- * The Kind of Constraints Constraint -- * Dictionary , Dict(Dict) , withDict -- * Entailment , (:-)(Sub) , (\\) , weaken1, weaken2, contract , strengthen1, strengthen2 , (&&&), (***) , trans, refl , Bottom(no) , top, bottom -- * Dict is fully faithful , mapDict , unmapDict -- * Reflection , Class(..) , (:=>)(..) ) where import Control.Applicative import Control.Category import Control.DeepSeq import Control.Monad import Data.Complex import Data.Ratio #if !MIN_VERSION_base(4,11,0) import Data.Semigroup #endif import Data.Data import qualified GHC.Exts as Exts (Any) import GHC.Exts (Constraint) import Data.Bits (Bits) import Data.Functor.Identity (Identity) #if MIN_VERSION_base(4,8,0) import Numeric.Natural (Natural) #endif #if !MIN_VERSION_base(4,8,0) import Data.Word (Word) #endif -- | Values of type @'Dict' p@ capture a dictionary for a constraint of type @p@. -- -- e.g. -- -- @ -- 'Dict' :: 'Dict' ('Eq' 'Int') -- @ -- -- captures a dictionary that proves we have an: -- -- @ -- instance 'Eq' 'Int -- @ -- -- Pattern matching on the 'Dict' constructor will bring this instance into scope. -- data Dict :: Constraint -> * where Dict :: a => Dict a deriving Typeable instance (Typeable p, p) => Data (Dict p) where gfoldl _ z Dict = z Dict toConstr _ = dictConstr gunfold _ z c = case constrIndex c of 1 -> z Dict _ -> error "gunfold" dataTypeOf _ = dictDataType dictConstr :: Constr dictConstr = mkConstr dictDataType "Dict" [] Prefix dictDataType :: DataType dictDataType = mkDataType "Data.Constraint.Dict" [dictConstr] deriving instance Eq (Dict a) deriving instance Ord (Dict a) deriving instance Show (Dict a) instance NFData (Dict c) where rnf Dict = () -- | From a 'Dict', takes a value in an environment where the instance -- witnessed by the 'Dict' is in scope, and evaluates it. -- -- Essentially a deconstruction of a 'Dict' into its continuation-style -- form. -- withDict :: Dict a -> (a => r) -> r withDict d r = case d of Dict -> r infixr 9 :- -- | This is the type of entailment. -- -- @a ':-' b@ is read as @a@ \"entails\" @b@. -- -- With this we can actually build a category for 'Constraint' resolution. -- -- e.g. -- -- Because @'Eq' a@ is a superclass of @'Ord' a@, we can show that @'Ord' a@ -- entails @'Eq' a@. -- -- Because @instance 'Ord' a => 'Ord' [a]@ exists, we can show that @'Ord' a@ -- entails @'Ord' [a]@ as well. -- -- This relationship is captured in the ':-' entailment type here. -- -- Since @p ':-' p@ and entailment composes, ':-' forms the arrows of a -- 'Category' of constraints. However, 'Category' only became sufficiently -- general to support this instance in GHC 7.8, so prior to 7.8 this instance -- is unavailable. -- -- But due to the coherence of instance resolution in Haskell, this 'Category' -- has some very interesting properties. Notably, in the absence of -- @IncoherentInstances@, this category is \"thin\", which is to say that -- between any two objects (constraints) there is at most one distinguishable -- arrow. -- -- This means that for instance, even though there are two ways to derive -- @'Ord' a ':-' 'Eq' [a]@, the answers from these two paths _must_ by -- construction be equal. This is a property that Haskell offers that is -- pretty much unique in the space of languages with things they call \"type -- classes\". -- -- What are the two ways? -- -- Well, we can go from @'Ord' a ':-' 'Eq' a@ via the -- superclass relationship, and then from @'Eq' a ':-' 'Eq' [a]@ via the -- instance, or we can go from @'Ord' a ':-' 'Ord' [a]@ via the instance -- then from @'Ord' [a] ':-' 'Eq' [a]@ through the superclass relationship -- and this diagram by definition must \"commute\". -- -- Diagrammatically, -- -- > Ord a -- > ins / \ cls -- > v v -- > Ord [a] Eq a -- > cls \ / ins -- > v v -- > Eq [a] -- -- This safety net ensures that pretty much anything you can write with this -- library is sensible and can't break any assumptions on the behalf of -- library authors. newtype a :- b = Sub (a => Dict b) deriving Typeable type role (:-) nominal nominal -- TODO: _proper_ Data for @(p ':-' q)@ requires @(:-)@ to be cartesian _closed_. -- -- This is admissable, but not present by default -- constraint should be instance (Typeable p, Typeable q, p |- q) => Data (p :- q) instance (Typeable p, Typeable q, p, q) => Data (p :- q) where gfoldl _ z (Sub Dict) = z (Sub Dict) toConstr _ = subConstr gunfold _ z c = case constrIndex c of 1 -> z (Sub Dict) _ -> error "gunfold" dataTypeOf _ = subDataType subConstr :: Constr subConstr = mkConstr dictDataType "Sub" [] Prefix subDataType :: DataType subDataType = mkDataType "Data.Constraint.:-" [subConstr] -- | Possible since GHC 7.8, when 'Category' was made polykinded. instance Category (:-) where id = refl (.) = trans -- | Assumes 'IncoherentInstances' doesn't exist. instance Eq (a :- b) where _ == _ = True -- | Assumes 'IncoherentInstances' doesn't exist. instance Ord (a :- b) where compare _ _ = EQ instance Show (a :- b) where showsPrec d _ = showParen (d > 10) $ showString "Sub Dict" instance a => NFData (a :- b) where rnf (Sub Dict) = () infixl 1 \\ -- required comment -- | Given that @a :- b@, derive something that needs a context @b@, using the context @a@ (\\) :: a => (b => r) -> (a :- b) -> r r \\ Sub Dict = r -------------------------------------------------------------------------------- -- Constraints form a Category -------------------------------------------------------------------------------- -- | Transitivity of entailment -- -- If we view @(':-')@ as a Constraint-indexed category, then this is @('.')@ trans :: (b :- c) -> (a :- b) -> a :- c trans f g = Sub $ Dict \\ f \\ g -- | Reflexivity of entailment -- -- If we view @(':-')@ as a Constraint-indexed category, then this is 'id' refl :: a :- a refl = Sub Dict -------------------------------------------------------------------------------- -- (,) is a Bifunctor -------------------------------------------------------------------------------- -- | due to the hack for the kind of @(,)@ in the current version of GHC we can't actually -- make instances for @(,) :: Constraint -> Constraint -> Constraint@, but @(,)@ is a -- bifunctor on the category of constraints. This lets us map over both sides. (***) :: (a :- b) -> (c :- d) -> (a, c) :- (b, d) f *** g = Sub $ Dict \\ f \\ g -------------------------------------------------------------------------------- -- Constraints are Cartesian -------------------------------------------------------------------------------- -- | Weakening a constraint product -- -- The category of constraints is Cartesian. We can forget information. weaken1 :: (a, b) :- a weaken1 = Sub Dict -- | Weakening a constraint product -- -- The category of constraints is Cartesian. We can forget information. weaken2 :: (a, b) :- b weaken2 = Sub Dict strengthen1 :: Dict b -> a :- c -> a :- (b,c) strengthen1 d e = unmapDict (const d) &&& e strengthen2 :: Dict b -> a :- c -> a :- (c,b) strengthen2 d e = e &&& unmapDict (const d) -- | Contracting a constraint / diagonal morphism -- -- The category of constraints is Cartesian. We can reuse information. contract :: a :- (a, a) contract = Sub Dict -- | Constraint product -- -- > trans weaken1 (f &&& g) = f -- > trans weaken2 (f &&& g) = g (&&&) :: (a :- b) -> (a :- c) -> a :- (b, c) f &&& g = Sub $ Dict \\ f \\ g -------------------------------------------------------------------------------- -- Initial and terminal morphisms -------------------------------------------------------------------------------- -- | Every constraint implies truth -- -- These are the terminal arrows of the category, and @()@ is the terminal object. -- -- Given any constraint there is a unique entailment of the @()@ constraint from that constraint. top :: a :- () top = Sub Dict -- | 'Any' inhabits every kind, including 'Constraint' but is uninhabited, making it impossible to define an instance. class Exts.Any => Bottom where no :: a -- | -- This demonstrates the law of classical logic bottom :: Bottom :- a bottom = Sub no -------------------------------------------------------------------------------- -- Dict is fully faithful -------------------------------------------------------------------------------- -- | Apply an entailment to a dictionary. -- -- From a category theoretic perspective 'Dict' is a functor that maps from the category -- of constraints (with arrows in ':-') to the category Hask of Haskell data types. mapDict :: (a :- b) -> Dict a -> Dict b mapDict p Dict = case p of Sub q -> q -- | -- This functor is fully faithful, which is to say that given any function you can write -- @Dict a -> Dict b@ there also exists an entailment @a :- b@ in the category of constraints -- that you can build. unmapDict :: (Dict a -> Dict b) -> a :- b unmapDict f = Sub (f Dict) type role Dict nominal -------------------------------------------------------------------------------- -- Reflection -------------------------------------------------------------------------------- -- | Reify the relationship between a class and its superclass constraints as a class -- -- Given a definition such as -- -- @ -- class Foo a => Bar a -- @ -- -- you can capture the relationship between 'Bar a' and its superclass 'Foo a' with -- -- @ -- instance 'Class' (Foo a) (Bar a) where 'cls' = 'Sub' 'Dict' -- @ -- -- Now the user can use 'cls :: Bar a :- Foo a' class Class b h | h -> b where cls :: h :- b infixr 9 :=> -- | Reify the relationship between an instance head and its body as a class -- -- Given a definition such as -- -- @ -- instance Foo a => Foo [a] -- @ -- -- you can capture the relationship between the instance head and its body with -- -- @ -- instance Foo a ':=>' Foo [a] where 'ins' = 'Sub' 'Dict' -- @ class b :=> h | h -> b where ins :: b :- h -- Bootstrapping instance Class () (Class b a) where cls = Sub Dict instance Class () (b :=> a) where cls = Sub Dict instance Class b a => () :=> Class b a where ins = Sub Dict instance (b :=> a) => () :=> (b :=> a) where ins = Sub Dict instance Class () () where cls = Sub Dict instance () :=> () where ins = Sub Dict -- Local, Prelude, Applicative, C.M.I and Data.Monoid instances -- Eq instance Class () (Eq a) where cls = Sub Dict instance () :=> Eq () where ins = Sub Dict instance () :=> Eq Int where ins = Sub Dict instance () :=> Eq Bool where ins = Sub Dict instance () :=> Eq Integer where ins = Sub Dict instance () :=> Eq Float where ins = Sub Dict instance () :=> Eq Double where ins = Sub Dict instance Eq a :=> Eq [a] where ins = Sub Dict instance Eq a :=> Eq (Maybe a) where ins = Sub Dict instance Eq a :=> Eq (Complex a) where ins = Sub Dict instance Eq a :=> Eq (Ratio a) where ins = Sub Dict instance (Eq a, Eq b) :=> Eq (a, b) where ins = Sub Dict instance (Eq a, Eq b) :=> Eq (Either a b) where ins = Sub Dict instance () :=> Eq (Dict a) where ins = Sub Dict instance () :=> Eq (a :- b) where ins = Sub Dict instance () :=> Eq Word where ins = Sub Dict instance Eq a :=> Eq (Identity a) where ins = Sub Dict #if MIN_VERSION_base(4,8,0) instance Eq a :=> Eq (Const a b) where ins = Sub Dict instance () :=> Eq Natural where ins = Sub Dict #endif -- Ord instance Class (Eq a) (Ord a) where cls = Sub Dict instance () :=> Ord () where ins = Sub Dict instance () :=> Ord Bool where ins = Sub Dict instance () :=> Ord Int where ins = Sub Dict instance ():=> Ord Integer where ins = Sub Dict instance () :=> Ord Float where ins = Sub Dict instance ():=> Ord Double where ins = Sub Dict instance () :=> Ord Char where ins = Sub Dict instance Ord a :=> Ord (Maybe a) where ins = Sub Dict instance Ord a :=> Ord [a] where ins = Sub Dict instance (Ord a, Ord b) :=> Ord (a, b) where ins = Sub Dict instance (Ord a, Ord b) :=> Ord (Either a b) where ins = Sub Dict instance Integral a :=> Ord (Ratio a) where ins = Sub Dict instance () :=> Ord (Dict a) where ins = Sub Dict instance () :=> Ord (a :- b) where ins = Sub Dict instance () :=> Ord Word where ins = Sub Dict instance Ord a :=> Ord (Identity a) where ins = Sub Dict #if MIN_VERSION_base(4,8,0) instance Ord a :=> Ord (Const a b) where ins = Sub Dict instance () :=> Ord Natural where ins = Sub Dict #endif -- Show instance Class () (Show a) where cls = Sub Dict instance () :=> Show () where ins = Sub Dict instance () :=> Show Bool where ins = Sub Dict instance () :=> Show Ordering where ins = Sub Dict instance () :=> Show Char where ins = Sub Dict instance () :=> Show Int where ins = Sub Dict instance Show a :=> Show (Complex a) where ins = Sub Dict instance Show a :=> Show [a] where ins = Sub Dict instance Show a :=> Show (Maybe a) where ins = Sub Dict instance (Show a, Show b) :=> Show (a, b) where ins = Sub Dict instance (Show a, Show b) :=> Show (Either a b) where ins = Sub Dict instance (Integral a, Show a) :=> Show (Ratio a) where ins = Sub Dict instance () :=> Show (Dict a) where ins = Sub Dict instance () :=> Show (a :- b) where ins = Sub Dict instance () :=> Show Word where ins = Sub Dict instance Show a :=> Show (Identity a) where ins = Sub Dict #if MIN_VERSION_base(4,8,0) instance Show a :=> Show (Const a b) where ins = Sub Dict instance () :=> Show Natural where ins = Sub Dict #endif -- Read instance Class () (Read a) where cls = Sub Dict instance () :=> Read () where ins = Sub Dict instance () :=> Read Bool where ins = Sub Dict instance () :=> Read Ordering where ins = Sub Dict instance () :=> Read Char where ins = Sub Dict instance () :=> Read Int where ins = Sub Dict instance Read a :=> Read (Complex a) where ins = Sub Dict instance Read a :=> Read [a] where ins = Sub Dict instance Read a :=> Read (Maybe a) where ins = Sub Dict instance (Read a, Read b) :=> Read (a, b) where ins = Sub Dict instance (Read a, Read b) :=> Read (Either a b) where ins = Sub Dict instance (Integral a, Read a) :=> Read (Ratio a) where ins = Sub Dict instance () :=> Read Word where ins = Sub Dict instance Read a :=> Read (Identity a) where ins = Sub Dict #if MIN_VERSION_base(4,8,0) instance Read a :=> Read (Const a b) where ins = Sub Dict instance () :=> Read Natural where ins = Sub Dict #endif -- Enum instance Class () (Enum a) where cls = Sub Dict instance () :=> Enum () where ins = Sub Dict instance () :=> Enum Bool where ins = Sub Dict instance () :=> Enum Ordering where ins = Sub Dict instance () :=> Enum Char where ins = Sub Dict instance () :=> Enum Int where ins = Sub Dict instance () :=> Enum Integer where ins = Sub Dict instance () :=> Enum Float where ins = Sub Dict instance () :=> Enum Double where ins = Sub Dict instance Integral a :=> Enum (Ratio a) where ins = Sub Dict instance () :=> Enum Word where ins = Sub Dict #if MIN_VERSION_base(4,9,0) instance Enum a :=> Enum (Identity a) where ins = Sub Dict instance Enum a :=> Enum (Const a b) where ins = Sub Dict #endif #if MIN_VERSION_base(4,8,0) instance () :=> Enum Natural where ins = Sub Dict #endif -- Bounded instance Class () (Bounded a) where cls = Sub Dict instance () :=> Bounded () where ins = Sub Dict instance () :=> Bounded Ordering where ins = Sub Dict instance () :=> Bounded Bool where ins = Sub Dict instance () :=> Bounded Int where ins = Sub Dict instance () :=> Bounded Char where ins = Sub Dict instance (Bounded a, Bounded b) :=> Bounded (a,b) where ins = Sub Dict instance () :=> Bounded Word where ins = Sub Dict #if MIN_VERSION_base(4,9,0) instance Bounded a :=> Bounded (Identity a) where ins = Sub Dict instance Bounded a :=> Bounded (Const a b) where ins = Sub Dict #endif -- Num instance Class () (Num a) where cls = Sub Dict instance () :=> Num Int where ins = Sub Dict instance () :=> Num Integer where ins = Sub Dict instance () :=> Num Float where ins = Sub Dict instance () :=> Num Double where ins = Sub Dict instance RealFloat a :=> Num (Complex a) where ins = Sub Dict instance Integral a :=> Num (Ratio a) where ins = Sub Dict instance () :=> Num Word where ins = Sub Dict #if MIN_VERSION_base(4,9,0) instance Num a :=> Num (Identity a) where ins = Sub Dict instance Num a :=> Num (Const a b) where ins = Sub Dict #endif #if MIN_VERSION_base(4,8,0) instance () :=> Num Natural where ins = Sub Dict #endif -- Real instance Class (Num a, Ord a) (Real a) where cls = Sub Dict instance () :=> Real Int where ins = Sub Dict instance () :=> Real Integer where ins = Sub Dict instance () :=> Real Float where ins = Sub Dict instance () :=> Real Double where ins = Sub Dict instance Integral a :=> Real (Ratio a) where ins = Sub Dict instance () :=> Real Word where ins = Sub Dict #if MIN_VERSION_base(4,9,0) instance Real a :=> Real (Identity a) where ins = Sub Dict instance Real a :=> Real (Const a b) where ins = Sub Dict #endif #if MIN_VERSION_base(4,8,0) instance () :=> Real Natural where ins = Sub Dict #endif -- Integral instance Class (Real a, Enum a) (Integral a) where cls = Sub Dict instance () :=> Integral Int where ins = Sub Dict instance () :=> Integral Integer where ins = Sub Dict instance () :=> Integral Word where ins = Sub Dict #if MIN_VERSION_base(4,9,0) instance Integral a :=> Integral (Identity a) where ins = Sub Dict instance Integral a :=> Integral (Const a b) where ins = Sub Dict #endif #if MIN_VERSION_base(4,8,0) instance () :=> Integral Natural where ins = Sub Dict #endif -- Bits instance Class (Eq a) (Bits a) where cls = Sub Dict instance () :=> Bits Bool where ins = Sub Dict instance () :=> Bits Int where ins = Sub Dict instance () :=> Bits Integer where ins = Sub Dict instance () :=> Bits Word where ins = Sub Dict #if MIN_VERSION_base(4,9,0) instance Bits a :=> Bits (Identity a) where ins = Sub Dict instance Bits a :=> Bits (Const a b) where ins = Sub Dict #endif #if MIN_VERSION_base(4,8,0) instance () :=> Bits Natural where ins = Sub Dict #endif -- Fractional instance Class (Num a) (Fractional a) where cls = Sub Dict instance () :=> Fractional Float where ins = Sub Dict instance () :=> Fractional Double where ins = Sub Dict instance RealFloat a :=> Fractional (Complex a) where ins = Sub Dict instance Integral a :=> Fractional (Ratio a) where ins = Sub Dict #if MIN_VERSION_base(4,9,0) instance Fractional a :=> Fractional (Identity a) where ins = Sub Dict instance Fractional a :=> Fractional (Const a b) where ins = Sub Dict #endif -- Floating instance Class (Fractional a) (Floating a) where cls = Sub Dict instance () :=> Floating Float where ins = Sub Dict instance () :=> Floating Double where ins = Sub Dict instance RealFloat a :=> Floating (Complex a) where ins = Sub Dict #if MIN_VERSION_base(4,9,0) instance Floating a :=> Floating (Identity a) where ins = Sub Dict instance Floating a :=> Floating (Const a b) where ins = Sub Dict #endif -- RealFrac instance Class (Real a, Fractional a) (RealFrac a) where cls = Sub Dict instance () :=> RealFrac Float where ins = Sub Dict instance () :=> RealFrac Double where ins = Sub Dict instance Integral a :=> RealFrac (Ratio a) where ins = Sub Dict #if MIN_VERSION_base(4,9,0) instance RealFrac a :=> RealFrac (Identity a) where ins = Sub Dict instance RealFrac a :=> RealFrac (Const a b) where ins = Sub Dict #endif -- RealFloat instance Class (RealFrac a, Floating a) (RealFloat a) where cls = Sub Dict instance () :=> RealFloat Float where ins = Sub Dict instance () :=> RealFloat Double where ins = Sub Dict #if MIN_VERSION_base(4,9,0) instance RealFloat a :=> RealFloat (Identity a) where ins = Sub Dict instance RealFloat a :=> RealFloat (Const a b) where ins = Sub Dict #endif -- Semigroup instance Class () (Semigroup a) where cls = Sub Dict instance () :=> Semigroup () where ins = Sub Dict instance () :=> Semigroup Ordering where ins = Sub Dict instance () :=> Semigroup [a] where ins = Sub Dict instance Semigroup a :=> Semigroup (Maybe a) where ins = Sub Dict instance (Semigroup a, Semigroup b) :=> Semigroup (a, b) where ins = Sub Dict instance Semigroup a :=> Semigroup (Const a b) where ins = Sub Dict #if MIN_VERSION_base(4,9,0) instance Semigroup a :=> Semigroup (Identity a) where ins = Sub Dict #endif #if MIN_VERSION_base(4,10,0) instance Semigroup a :=> Semigroup (IO a) where ins = Sub Dict #endif -- Monoid #if MIN_VERSION_base(4,11,0) instance Class (Semigroup a) (Monoid a) where cls = Sub Dict #else instance Class () (Monoid a) where cls = Sub Dict #endif instance () :=> Monoid () where ins = Sub Dict instance () :=> Monoid Ordering where ins = Sub Dict instance () :=> Monoid [a] where ins = Sub Dict instance Monoid a :=> Monoid (Maybe a) where ins = Sub Dict instance (Monoid a, Monoid b) :=> Monoid (a, b) where ins = Sub Dict instance Monoid a :=> Monoid (Const a b) where ins = Sub Dict #if MIN_VERSION_base(4,9,0) instance Monoid a :=> Monoid (Identity a) where ins = Sub Dict instance Monoid a :=> Monoid (IO a) where ins = Sub Dict #endif -- Functor instance Class () (Functor f) where cls = Sub Dict instance () :=> Functor [] where ins = Sub Dict instance () :=> Functor Maybe where ins = Sub Dict instance () :=> Functor (Either a) where ins = Sub Dict instance () :=> Functor ((->) a) where ins = Sub Dict instance () :=> Functor ((,) a) where ins = Sub Dict instance () :=> Functor IO where ins = Sub Dict instance Monad m :=> Functor (WrappedMonad m) where ins = Sub Dict instance () :=> Functor Identity where ins = Sub Dict instance () :=> Functor (Const a) where ins = Sub Dict -- Applicative instance Class (Functor f) (Applicative f) where cls = Sub Dict instance () :=> Applicative [] where ins = Sub Dict instance () :=> Applicative Maybe where ins = Sub Dict instance () :=> Applicative (Either a) where ins = Sub Dict instance () :=> Applicative ((->)a) where ins = Sub Dict instance () :=> Applicative IO where ins = Sub Dict instance Monoid a :=> Applicative ((,)a) where ins = Sub Dict instance Monoid a :=> Applicative (Const a) where ins = Sub Dict instance Monad m :=> Applicative (WrappedMonad m) where ins = Sub Dict -- Alternative instance Class (Applicative f) (Alternative f) where cls = Sub Dict instance () :=> Alternative [] where ins = Sub Dict instance () :=> Alternative Maybe where ins = Sub Dict instance MonadPlus m :=> Alternative (WrappedMonad m) where ins = Sub Dict -- Monad #if MIN_VERSION_base(4,8,0) instance Class (Applicative f) (Monad f) where cls = Sub Dict #else instance Class () (Monad f) where cls = Sub Dict #endif instance () :=> Monad [] where ins = Sub Dict instance () :=> Monad ((->) a) where ins = Sub Dict instance () :=> Monad (Either a) where ins = Sub Dict instance () :=> Monad IO where ins = Sub Dict instance () :=> Monad Identity where ins = Sub Dict -- MonadPlus #if MIN_VERSION_base(4,8,0) instance Class (Monad f, Alternative f) (MonadPlus f) where cls = Sub Dict #else instance Class (Monad f) (MonadPlus f) where cls = Sub Dict #endif instance () :=> MonadPlus [] where ins = Sub Dict instance () :=> MonadPlus Maybe where ins = Sub Dict -------------------------------------------------------------------------------- -- UndecidableInstances -------------------------------------------------------------------------------- instance a :=> Enum (Dict a) where ins = Sub Dict instance a => Enum (Dict a) where toEnum _ = Dict fromEnum Dict = 0 instance a :=> Bounded (Dict a) where ins = Sub Dict instance a => Bounded (Dict a) where minBound = Dict maxBound = Dict instance a :=> Read (Dict a) where ins = Sub Dict deriving instance a => Read (Dict a) instance () :=> Semigroup (Dict a) where ins = Sub Dict instance Semigroup (Dict a) where Dict <> Dict = Dict instance a :=> Monoid (Dict a) where ins = Sub Dict instance a => Monoid (Dict a) where #if !(MIN_VERSION_base(4,11,0)) mappend = (<>) #endif mempty = Dict constraints-0.10.1/src/Data/Constraint/0000755000000000000000000000000013316540016016111 5ustar0000000000000000constraints-0.10.1/src/Data/Constraint/Symbol.hs0000644000000000000000000000642413316540016017720 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} -- | Utilities for working with 'KnownSymbol' constraints. -- -- This module is only available on GHC 8.0 or later. module Data.Constraint.Symbol ( type (++) , type Take , type Drop , type Length , appendSymbol , appendUnit1 , appendUnit2 , appendAssociates , takeSymbol , dropSymbol , takeAppendDrop , lengthSymbol , takeLength , take0 , takeEmpty , dropLength , drop0 , dropEmpty , lengthTake , lengthDrop , dropDrop , takeTake ) where import Data.Constraint import Data.Constraint.Nat import Data.Proxy import GHC.TypeLits import Unsafe.Coerce type family (++) :: Symbol -> Symbol -> Symbol where type family Take :: Nat -> Symbol -> Symbol where type family Drop :: Nat -> Symbol -> Symbol where type family Length :: Symbol -> Nat where -- implementation details newtype Magic n = Magic (KnownSymbol n => Dict (KnownSymbol n)) magicNSS :: forall n m o. (Int -> String -> String) -> (KnownNat n, KnownSymbol m) :- KnownSymbol o magicNSS f = Sub $ unsafeCoerce (Magic Dict) (fromIntegral (natVal (Proxy :: Proxy n)) `f` symbolVal (Proxy :: Proxy m)) magicSSS :: forall n m o. (String -> String -> String) -> (KnownSymbol n, KnownSymbol m) :- KnownSymbol o magicSSS f = Sub $ unsafeCoerce (Magic Dict) (symbolVal (Proxy :: Proxy n) `f` symbolVal (Proxy :: Proxy m)) magicSN :: forall a n. (String -> Int) -> KnownSymbol a :- KnownNat n magicSN f = Sub $ unsafeCoerce (Magic Dict) (toInteger (f (symbolVal (Proxy :: Proxy a)))) axiom :: forall a b. Dict (a ~ b) axiom = unsafeCoerce (Dict :: Dict (a ~ a)) -- axioms and operations appendSymbol :: (KnownSymbol a, KnownSymbol b) :- KnownSymbol (a ++ b) appendSymbol = magicSSS (++) appendUnit1 :: forall a. Dict (("" ++ a) ~ a) appendUnit1 = axiom appendUnit2 :: forall a. Dict ((a ++ "") ~ a) appendUnit2 = axiom appendAssociates :: forall a b c. Dict (((a ++ b) ++ c) ~ (a ++ (b ++ c))) appendAssociates = axiom takeSymbol :: forall n a. (KnownNat n, KnownSymbol a) :- KnownSymbol (Take n a) takeSymbol = magicNSS take dropSymbol :: forall n a. (KnownNat n, KnownSymbol a) :- KnownSymbol (Drop n a) dropSymbol = magicNSS drop takeAppendDrop :: forall n a. Dict (Take n a ++ Drop n a ~ a) takeAppendDrop = axiom lengthSymbol :: forall a. KnownSymbol a :- KnownNat (Length a) lengthSymbol = magicSN length takeLength :: forall n a. (Length a <= n) :- (Take n a ~ a) takeLength = Sub axiom take0 :: forall a. Dict (Take 0 a ~ "") take0 = axiom takeEmpty :: forall n. Dict (Take n "" ~ "") takeEmpty = axiom dropLength :: forall n a. (Length a <= n) :- (Drop n a ~ "") dropLength = Sub axiom drop0 :: forall a. Dict (Drop 0 a ~ a) drop0 = axiom dropEmpty :: forall n. Dict (Drop n "" ~ "") dropEmpty = axiom lengthTake :: forall n a. Dict (Length (Take n a) <= n) lengthTake = axiom lengthDrop :: forall n a. Dict (Length a <= (Length (Drop n a) + n)) lengthDrop = axiom dropDrop :: forall n m a. Dict (Drop n (Drop m a) ~ Drop (n + m) a) dropDrop = axiom takeTake :: forall n m a. Dict (Take n (Take m a) ~ Take (Min n m) a) takeTake = axiom constraints-0.10.1/src/Data/Constraint/Unsafe.hs0000644000000000000000000000411613316540016017670 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Unsafe #-} #if __GLASGOW_HASKELL__ >= 800 {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Constraint.Unsafe -- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ---------------------------------------------------------------------------- module Data.Constraint.Unsafe ( Coercible , unsafeCoerceConstraint , unsafeDerive , unsafeUnderive -- * Sugar , unsafeApplicative , unsafeAlternative ) where import Control.Applicative import Control.Monad import Data.Coerce import Data.Constraint import Unsafe.Coerce -- | Coerce a dictionary unsafely from one type to another unsafeCoerceConstraint :: a :- b unsafeCoerceConstraint = unsafeCoerce refl -- | Coerce a dictionary unsafely from one type to a newtype of that type unsafeDerive :: Coercible n o => (o -> n) -> t o :- t n unsafeDerive _ = unsafeCoerceConstraint -- | Coerce a dictionary unsafely from a newtype of a type to the base type unsafeUnderive :: Coercible n o => (o -> n) -> t n :- t o unsafeUnderive _ = unsafeCoerceConstraint -- | Construct an Applicative instance from a Monad unsafeApplicative :: forall m a. Monad m => (Applicative m => m a) -> m a #if __GLASGOW_HASKELL__ < 710 unsafeApplicative m = m \\ trans (unsafeCoerceConstraint :: Applicative (WrappedMonad m) :- Applicative m) ins #else unsafeApplicative m = m #endif -- | Construct an Alternative instance from a MonadPlus unsafeAlternative :: forall m a. MonadPlus m => (Alternative m => m a) -> m a #if __GLASGOW_HASKELL__ < 710 unsafeAlternative m = m \\ trans (unsafeCoerceConstraint :: Alternative (WrappedMonad m) :- Alternative m) ins #else unsafeAlternative m = m #endif constraints-0.10.1/src/Data/Constraint/Deferrable.hs0000644000000000000000000001120113316540016020473 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PolyKinds #-} #if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE TypeApplications #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TypeInType #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Constraint.Deferrable -- Copyright : (C) 2015-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- -- The idea for this trick comes from Dimitrios Vytiniotis. ----------------------------------------------------------------------------- module Data.Constraint.Deferrable ( UnsatisfiedConstraint(..) , Deferrable(..) , defer , deferred #if __GLASGOW_HASKELL__ >= 800 , defer_ , deferEither_ , (:~~:)(HRefl) #endif , (:~:)(Refl) ) where import Control.Exception import Control.Monad import Data.Constraint import Data.Proxy import Data.Typeable (Typeable, cast, typeRep) import Data.Type.Equality ((:~:)(Refl)) #if __GLASGOW_HASKELL__ >= 800 import GHC.Types (type (~~)) #endif #if __GLASGOW_HASKELL__ >= 801 import Data.Type.Equality ((:~~:)(HRefl)) #endif data UnsatisfiedConstraint = UnsatisfiedConstraint String deriving (Typeable, Show) instance Exception UnsatisfiedConstraint -- | Allow an attempt at resolution of a constraint at a later time class Deferrable p where -- | Resolve a 'Deferrable' constraint with observable failure. deferEither :: proxy p -> (p => r) -> Either String r -- | Defer a constraint for later resolution in a context where we want to upgrade failure into an error defer :: forall p r proxy. Deferrable p => proxy p -> (p => r) -> r defer _ r = either (throw . UnsatisfiedConstraint) id $ deferEither (Proxy :: Proxy p) r deferred :: forall p. Deferrable p :- p deferred = Sub $ defer (Proxy :: Proxy p) Dict #if __GLASGOW_HASKELL__ >= 800 -- | A version of 'defer' that uses visible type application in place of a 'Proxy'. -- -- Only available on GHC 8.0 or later. defer_ :: forall p r. Deferrable p => (p => r) -> r defer_ r = defer @p Proxy r -- | A version of 'deferEither' that uses visible type application in place of a 'Proxy'. -- -- Only available on GHC 8.0 or later. deferEither_ :: forall p r. Deferrable p => (p => r) -> Either String r deferEither_ r = deferEither @p Proxy r #endif #if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 801 -- | Kind heterogeneous propositional equality. Like '(:~:)', @a :~~: b@ is -- inhabited by a terminating value if and only if @a@ is the same type as @b@. -- -- Only available on GHC 8.0 or later. data (a :: i) :~~: (b :: j) where HRefl :: a :~~: a deriving Typeable #endif showTypeRep :: Typeable t => Proxy t -> String showTypeRep = show . typeRep instance Deferrable () where deferEither _ r = Right r -- | Deferrable homogeneous equality constraints. -- -- Note that due to a GHC bug (https://ghc.haskell.org/trac/ghc/ticket/10343), -- using this instance on GHC 7.10 will only work with @*@-kinded types. #if __GLASGOW_HASKELL__ >= 800 instance (Typeable k, Typeable (a :: k), Typeable b) => Deferrable (a ~ b) where #elif __GLASGOW_HASKELL__ == 710 instance (Typeable a, Typeable b) => Deferrable ((a :: *) ~ (b :: *)) where #else instance (Typeable a, Typeable b) => Deferrable (a ~ b) where #endif deferEither _ r = case cast (Refl :: a :~: a) :: Maybe (a :~: b) of Just Refl -> Right r Nothing -> Left $ "deferred type equality: type mismatch between `" ++ showTypeRep (Proxy :: Proxy a) ++ "’ and `" ++ showTypeRep (Proxy :: Proxy b) ++ "'" #if __GLASGOW_HASKELL__ >= 800 -- | Deferrable heterogenous equality constraints. -- -- Only available on GHC 8.0 or later. instance (Typeable i, Typeable j, Typeable (a :: i), Typeable (b :: j)) => Deferrable (a ~~ b) where deferEither _ r = case cast (HRefl :: a :~~: a) :: Maybe (a :~~: b) of Just HRefl -> Right r Nothing -> Left $ "deferred type equality: type mismatch between `" ++ showTypeRep (Proxy :: Proxy a) ++ "’ and `" ++ showTypeRep (Proxy :: Proxy b) ++ "'" #endif instance (Deferrable a, Deferrable b) => Deferrable (a, b) where deferEither _ r = join $ deferEither (Proxy :: Proxy a) $ deferEither (Proxy :: Proxy b) r instance (Deferrable a, Deferrable b, Deferrable c) => Deferrable (a, b, c) where deferEither _ r = join $ deferEither (Proxy :: Proxy a) $ join $ deferEither (Proxy :: Proxy b) $ deferEither (Proxy :: Proxy c) r constraints-0.10.1/src/Data/Constraint/Nat.hs0000644000000000000000000002466413316540016017203 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE Trustworthy #-} #if __GLASGOW_HASKELL__ >= 805 {-# LANGUAGE NoStarIsType #-} #endif -- | Utilities for working with 'KnownNat' constraints. -- -- This module is only available on GHC 8.0 or later. module Data.Constraint.Nat ( Min, Max, Lcm, Gcd, Divides, Div, Mod , plusNat, timesNat, powNat, minNat, maxNat, gcdNat, lcmNat, divNat, modNat , plusZero, timesZero, timesOne, powZero, powOne, maxZero, minZero, gcdZero, gcdOne, lcmZero, lcmOne , plusAssociates, timesAssociates, minAssociates, maxAssociates, gcdAssociates, lcmAssociates , plusCommutes, timesCommutes, minCommutes, maxCommutes, gcdCommutes, lcmCommutes , plusDistributesOverTimes, timesDistributesOverPow, timesDistributesOverGcd, timesDistributesOverLcm , minDistributesOverPlus, minDistributesOverTimes, minDistributesOverPow1, minDistributesOverPow2, minDistributesOverMax , maxDistributesOverPlus, maxDistributesOverTimes, maxDistributesOverPow1, maxDistributesOverPow2, maxDistributesOverMin , gcdDistributesOverLcm, lcmDistributesOverGcd , minIsIdempotent, maxIsIdempotent, lcmIsIdempotent, gcdIsIdempotent , plusIsCancellative, timesIsCancellative , dividesPlus, dividesTimes, dividesMin, dividesMax, dividesPow, dividesGcd, dividesLcm , plusMonotone1, plusMonotone2 , timesMonotone1, timesMonotone2 , powMonotone1, powMonotone2 , minMonotone1, minMonotone2 , maxMonotone1, maxMonotone2 , divMonotone1, divMonotone2 , euclideanNat , plusMod, timesMod , modBound , dividesDef , timesDiv , eqLe, leEq, leId, leTrans , leZero, zeroLe , plusMinusInverse1, plusMinusInverse2, plusMinusInverse3 ) where import Data.Constraint import Data.Proxy import GHC.TypeLits import Unsafe.Coerce type family Min (m::Nat) (n::Nat) :: Nat where Min m m = m type family Max (m::Nat) (n::Nat) :: Nat where Max m m = m #if !(MIN_VERSION_base(4,11,0)) type family Div (m::Nat) (n::Nat) :: Nat where Div m 1 = m type family Mod (m::Nat) (n::Nat) :: Nat where Mod 0 m = 0 #endif type family Gcd (m::Nat) (n::Nat) :: Nat where Gcd m m = m type family Lcm (m::Nat) (n::Nat) :: Nat where Lcm m m = m type Divides n m = n ~ Gcd n m newtype Magic n = Magic (KnownNat n => Dict (KnownNat n)) magic :: forall n m o. (Integer -> Integer -> Integer) -> (KnownNat n, KnownNat m) :- KnownNat o magic f = Sub $ unsafeCoerce (Magic Dict) (natVal (Proxy :: Proxy n) `f` natVal (Proxy :: Proxy m)) axiom :: forall a b. Dict (a ~ b) axiom = unsafeCoerce (Dict :: Dict (a ~ a)) axiomLe :: forall a b. Dict (a <= b) axiomLe = axiom eqLe :: (a ~ b) :- (a <= b) eqLe = Sub Dict dividesGcd :: forall a b c. (Divides a b, Divides a c) :- Divides a (Gcd b c) dividesGcd = Sub axiom dividesLcm :: forall a b c. (Divides a c, Divides b c) :- Divides (Lcm a b) c dividesLcm = Sub axiom gcdCommutes :: forall a b. Dict (Gcd a b ~ Gcd b a) gcdCommutes = axiom lcmCommutes :: forall a b. Dict (Lcm a b ~ Lcm b a) lcmCommutes = axiom gcdZero :: forall a. Dict (Gcd 0 a ~ a) gcdZero = axiom gcdOne :: forall a. Dict (Gcd 1 a ~ 1) gcdOne = axiom lcmZero :: forall a. Dict (Lcm 0 a ~ 0) lcmZero = axiom lcmOne :: forall a. Dict (Lcm 1 a ~ a) lcmOne = axiom gcdNat :: forall n m. (KnownNat n, KnownNat m) :- KnownNat (Gcd n m) gcdNat = magic gcd lcmNat :: forall n m. (KnownNat n, KnownNat m) :- KnownNat (Lcm n m) lcmNat = magic lcm plusNat :: forall n m. (KnownNat n, KnownNat m) :- KnownNat (n + m) plusNat = magic (+) minNat :: forall n m. (KnownNat n, KnownNat m) :- KnownNat (Min n m) minNat = magic min maxNat :: forall n m. (KnownNat n, KnownNat m) :- KnownNat (Max n m) maxNat = magic max timesNat :: forall n m. (KnownNat n, KnownNat m) :- KnownNat (n * m) timesNat = magic (*) powNat :: forall n m. (KnownNat n, KnownNat m) :- KnownNat (n ^ m) powNat = magic (^) divNat :: forall n m. (KnownNat n, KnownNat m, 1 <= m) :- KnownNat (Div n m) divNat = Sub $ case magic @n @m div of Sub r -> r modNat :: forall n m. (KnownNat n, KnownNat m, 1 <= m) :- KnownNat (Mod n m) modNat = Sub $ case magic @n @m mod of Sub r -> r plusZero :: forall n. Dict ((n + 0) ~ n) plusZero = Dict timesZero :: forall n. Dict ((n * 0) ~ 0) timesZero = Dict timesOne :: forall n. Dict ((n * 1) ~ n) timesOne = Dict minZero :: forall n. Dict (Min n 0 ~ 0) minZero = axiom maxZero :: forall n. Dict (Max n 0 ~ n) maxZero = axiom powZero :: forall n. Dict ((n ^ 0) ~ 1) powZero = Dict leZero :: forall a. (a <= 0) :- (a ~ 0) leZero = Sub axiom zeroLe :: forall a. Dict (0 <= a) zeroLe = Dict plusMinusInverse1 :: forall n m. Dict (((m + n) - n) ~ m) plusMinusInverse1 = axiom plusMinusInverse2 :: forall n m. (m <= n) :- (((m + n) - m) ~ n) plusMinusInverse2 = Sub axiom plusMinusInverse3 :: forall n m. (n <= m) :- (((m - n) + n) ~ m) plusMinusInverse3 = Sub axiom plusMonotone1 :: forall a b c. (a <= b) :- (a + c <= b + c) plusMonotone1 = Sub axiom plusMonotone2 :: forall a b c. (b <= c) :- (a + b <= a + c) plusMonotone2 = Sub axiom powMonotone1 :: forall a b c. (a <= b) :- ((a^c) <= (b^c)) powMonotone1 = Sub axiom powMonotone2 :: forall a b c. (b <= c) :- ((a^b) <= (a^c)) powMonotone2 = Sub axiom divMonotone1 :: forall a b c. (a <= b) :- (Div a c <= Div b c) divMonotone1 = Sub axiom divMonotone2 :: forall a b c. (b <= c) :- (Div a c <= Div a b) divMonotone2 = Sub axiom timesMonotone1 :: forall a b c. (a <= b) :- (a * c <= b * c) timesMonotone1 = Sub axiom timesMonotone2 :: forall a b c. (b <= c) :- (a * b <= a * c) timesMonotone2 = Sub axiom minMonotone1 :: forall a b c. (a <= b) :- (Min a c <= Min b c) minMonotone1 = Sub axiom minMonotone2 :: forall a b c. (b <= c) :- (Min a b <= Min a c) minMonotone2 = Sub axiom maxMonotone1 :: forall a b c. (a <= b) :- (Max a c <= Max b c) maxMonotone1 = Sub axiom maxMonotone2 :: forall a b c. (b <= c) :- (Max a b <= Max a c) maxMonotone2 = Sub axiom powOne :: forall n. Dict ((n ^ 1) ~ n) powOne = axiom plusMod :: forall a b c. (1 <= c) :- (Mod (a + b) c ~ Mod (Mod a c + Mod b c) c) plusMod = Sub axiom timesMod :: forall a b c. (1 <= c) :- (Mod (a * b) c ~ Mod (Mod a c * Mod b c) c) timesMod = Sub axiom modBound :: forall m n. (1 <= n) :- (Mod m n <= n) modBound = Sub axiom euclideanNat :: (1 <= c) :- (a ~ (c * Div a c + Mod a c)) euclideanNat = Sub axiom plusCommutes :: forall n m. Dict ((m + n) ~ (n + m)) plusCommutes = axiom timesCommutes :: forall n m. Dict ((m * n) ~ (n * m)) timesCommutes = axiom minCommutes :: forall n m. Dict (Min m n ~ Min n m) minCommutes = axiom maxCommutes :: forall n m. Dict (Max m n ~ Max n m) maxCommutes = axiom plusAssociates :: forall m n o. Dict (((m + n) + o) ~ (m + (n + o))) plusAssociates = axiom timesAssociates :: forall m n o. Dict (((m * n) * o) ~ (m * (n * o))) timesAssociates = axiom minAssociates :: forall m n o. Dict (Min (Min m n) o ~ Min m (Min n o)) minAssociates = axiom maxAssociates :: forall m n o. Dict (Max (Max m n) o ~ Max m (Max n o)) maxAssociates = axiom gcdAssociates :: forall a b c. Dict (Gcd (Gcd a b) c ~ Gcd a (Gcd b c)) gcdAssociates = axiom lcmAssociates :: forall a b c. Dict (Lcm (Lcm a b) c ~ Lcm a (Lcm b c)) lcmAssociates = axiom minIsIdempotent :: forall n. Dict (Min n n ~ n) minIsIdempotent = Dict maxIsIdempotent :: forall n. Dict (Max n n ~ n) maxIsIdempotent = Dict gcdIsIdempotent :: forall n. Dict (Gcd n n ~ n) gcdIsIdempotent = Dict lcmIsIdempotent :: forall n. Dict (Lcm n n ~ n) lcmIsIdempotent = Dict minDistributesOverPlus :: forall n m o. Dict ((n + Min m o) ~ Min (n + m) (n + o)) minDistributesOverPlus = axiom minDistributesOverTimes :: forall n m o. Dict ((n * Min m o) ~ Min (n * m) (n * o)) minDistributesOverTimes = axiom minDistributesOverPow1 :: forall n m o. Dict ((Min n m ^ o) ~ Min (n ^ o) (m ^ o)) minDistributesOverPow1 = axiom minDistributesOverPow2 :: forall n m o. Dict ((n ^ Min m o) ~ Min (n ^ m) (n ^ o)) minDistributesOverPow2 = axiom minDistributesOverMax :: forall n m o. Dict (Max n (Min m o) ~ Min (Max n m) (Max n o)) minDistributesOverMax = axiom maxDistributesOverPlus :: forall n m o. Dict ((n + Max m o) ~ Max (n + m) (n + o)) maxDistributesOverPlus = axiom maxDistributesOverTimes :: forall n m o. Dict ((n * Max m o) ~ Max (n * m) (n * o)) maxDistributesOverTimes = axiom maxDistributesOverPow1 :: forall n m o. Dict ((Max n m ^ o) ~ Max (n ^ o) (m ^ o)) maxDistributesOverPow1 = axiom maxDistributesOverPow2 :: forall n m o. Dict ((n ^ Max m o) ~ Max (n ^ m) (n ^ o)) maxDistributesOverPow2 = axiom maxDistributesOverMin :: forall n m o. Dict (Min n (Max m o) ~ Max (Min n m) (Min n o)) maxDistributesOverMin = axiom plusDistributesOverTimes :: forall n m o. Dict ((n * (m + o)) ~ (n * m + n * o)) plusDistributesOverTimes = axiom timesDistributesOverPow :: forall n m o. Dict ((n ^ (m + o)) ~ (n ^ m * n ^ o)) timesDistributesOverPow = axiom timesDistributesOverGcd :: forall n m o. Dict ((n * Gcd m o) ~ Gcd (n * m) (n * o)) timesDistributesOverGcd = axiom timesDistributesOverLcm :: forall n m o. Dict ((n * Lcm m o) ~ Lcm (n * m) (n * o)) timesDistributesOverLcm = axiom plusIsCancellative :: forall n m o. ((n + m) ~ (n + o)) :- (m ~ o) plusIsCancellative = Sub axiom timesIsCancellative :: forall n m o. (1 <= n, (n * m) ~ (n * o)) :- (m ~ o) timesIsCancellative = Sub axiom gcdDistributesOverLcm :: forall a b c. Dict (Gcd (Lcm a b) c ~ Lcm (Gcd a c) (Gcd b c)) gcdDistributesOverLcm = axiom lcmDistributesOverGcd :: forall a b c. Dict (Lcm (Gcd a b) c ~ Gcd (Lcm a c) (Lcm b c)) lcmDistributesOverGcd = axiom dividesPlus :: (Divides a b, Divides a c) :- Divides a (b + c) dividesPlus = Sub axiom dividesTimes :: (Divides a b, Divides a c) :- Divides a (b * c) dividesTimes = Sub axiom dividesMin :: (Divides a b, Divides a c) :- Divides a (Min b c) dividesMin = Sub axiom dividesMax :: (Divides a b, Divides a c) :- Divides a (Max b c) dividesMax = Sub axiom dividesDef :: forall a b. Divides a b :- ((a * Div b a) ~ a) dividesDef = Sub axiom dividesPow :: (1 <= n, Divides a b) :- Divides a (b^n) dividesPow = Sub axiom timesDiv :: forall a b. Dict ((a * Div b a) <= a) timesDiv = axiom -- (<=) is an internal category in the category of constraints. leId :: forall a. Dict (a <= a) leId = Dict leEq :: forall a b. (a <= b, b <= a) :- (a ~ b) leEq = Sub axiom leTrans :: forall a b c. (b <= c, a <= b) :- (a <= c) leTrans = Sub (axiomLe @a @c) constraints-0.10.1/src/Data/Constraint/Lifting.hs0000644000000000000000000006455713316540016020062 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} module Data.Constraint.Lifting ( Lifting(..) , Lifting2(..) ) where import Control.Applicative import Control.Applicative.Backwards import Control.Applicative.Lift import Control.DeepSeq import Control.Monad import Control.Monad.Cont.Class import Control.Monad.Error.Class import Control.Monad.Fix import Control.Monad.IO.Class import Control.Monad.RWS.Class import Control.Monad.Trans.Cont import Control.Monad.Trans.Error import Control.Monad.Trans.Except import Control.Monad.Trans.Identity import Control.Monad.Trans.List import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader import Control.Monad.Trans.RWS.Lazy as Lazy import Control.Monad.Trans.RWS.Strict as Strict import Control.Monad.Trans.State.Lazy as Lazy import Control.Monad.Trans.State.Strict as Strict import Control.Monad.Trans.Writer.Lazy as Lazy import Control.Monad.Trans.Writer.Strict as Strict import Data.Binary import Data.Complex import Data.Constraint #if __GLASGOW_HASKELL__ < 710 import Data.Foldable #endif import Data.Functor.Classes import Data.Functor.Compose as Functor import Data.Functor.Identity import Data.Functor.Product as Functor import Data.Functor.Reverse as Functor import Data.Functor.Sum as Functor import Data.Hashable #if __GLASGOW_HASKELL__ < 710 import Data.Monoid #endif import Data.Ratio #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup #endif #if __GLASGOW_HASKELL__ < 710 import Data.Traversable #endif import GHC.Arr class Lifting p f where lifting :: p a :- p (f a) instance Lifting Eq [] where lifting = Sub Dict instance Lifting Ord [] where lifting = Sub Dict instance Lifting Show [] where lifting = Sub Dict instance Lifting Read [] where lifting = Sub Dict instance Lifting Hashable [] where lifting = Sub Dict instance Lifting Binary [] where lifting = Sub Dict instance Lifting NFData [] where lifting = Sub Dict instance Lifting Eq Maybe where lifting = Sub Dict instance Lifting Ord Maybe where lifting = Sub Dict instance Lifting Show Maybe where lifting = Sub Dict instance Lifting Read Maybe where lifting = Sub Dict instance Lifting Hashable Maybe where lifting = Sub Dict instance Lifting Binary Maybe where lifting = Sub Dict instance Lifting NFData Maybe where lifting = Sub Dict instance Lifting Semigroup Maybe where lifting = Sub Dict instance Lifting Monoid Maybe where lifting = Sub Dict instance Lifting Eq Ratio where lifting = Sub Dict -- instance Lifting Show Ratio where lifting = Sub Dict -- requires 7.10 instance Lifting Eq Complex where lifting = Sub Dict instance Lifting Read Complex where lifting = Sub Dict instance Lifting Show Complex where lifting = Sub Dict instance Lifting Semigroup ((->) a) where lifting = Sub Dict instance Lifting Monoid ((->) a) where lifting = Sub Dict instance Eq a => Lifting Eq (Either a) where lifting = Sub Dict instance Ord a => Lifting Ord (Either a) where lifting = Sub Dict instance Show a => Lifting Show (Either a) where lifting = Sub Dict instance Read a => Lifting Read (Either a) where lifting = Sub Dict instance Hashable a => Lifting Hashable (Either a) where lifting = Sub Dict instance Binary a => Lifting Binary (Either a) where lifting = Sub Dict instance NFData a => Lifting NFData (Either a) where lifting = Sub Dict instance Eq a => Lifting Eq ((,) a) where lifting = Sub Dict instance Ord a => Lifting Ord ((,) a) where lifting = Sub Dict instance Show a => Lifting Show ((,) a) where lifting = Sub Dict instance Read a => Lifting Read ((,) a) where lifting = Sub Dict instance Hashable a => Lifting Hashable ((,) a) where lifting = Sub Dict instance Binary a => Lifting Binary ((,) a) where lifting = Sub Dict instance NFData a => Lifting NFData ((,) a) where lifting = Sub Dict instance Semigroup a => Lifting Semigroup ((,) a) where lifting = Sub Dict instance Monoid a => Lifting Monoid ((,) a) where lifting = Sub Dict instance Bounded a => Lifting Bounded ((,) a) where lifting = Sub Dict instance Ix a => Lifting Ix ((,) a) where lifting = Sub Dict instance Functor f => Lifting Functor (Compose f) where lifting = Sub Dict instance Foldable f => Lifting Foldable (Compose f) where lifting = Sub Dict instance Traversable f => Lifting Traversable (Compose f) where lifting = Sub Dict instance Applicative f => Lifting Applicative (Compose f) where lifting = Sub Dict instance Alternative f => Lifting Alternative (Compose f) where lifting = Sub Dict -- overconstrained #if MIN_VERSION_transformers(0,5,0) instance Show1 f => Lifting Show1 (Compose f) where lifting = Sub Dict instance Eq1 f => Lifting Eq1 (Compose f) where lifting = Sub Dict instance Ord1 f => Lifting Ord1 (Compose f) where lifting = Sub Dict instance Read1 f => Lifting Read1 (Compose f) where lifting = Sub Dict instance (Eq1 f, Eq1 g) => Lifting Eq (Compose f g) where lifting = Sub Dict instance (Ord1 f, Ord1 g) => Lifting Ord (Compose f g) where lifting = Sub Dict instance (Read1 f, Read1 g) => Lifting Read (Compose f g) where lifting = Sub Dict instance (Show1 f, Show1 g) => Lifting Show (Compose f g) where lifting = Sub Dict #else instance (Functor f, Show1 f) => Lifting Show1 (Compose f) where lifting = Sub Dict instance (Functor f, Eq1 f) => Lifting Eq1 (Compose f) where lifting = Sub Dict instance (Functor f, Ord1 f) => Lifting Ord1 (Compose f) where lifting = Sub Dict instance (Functor f, Read1 f) => Lifting Read1 (Compose f) where lifting = Sub Dict instance (Functor f, Eq1 f, Eq1 g) => Lifting Eq (Compose f g) where lifting = Sub Dict instance (Functor f, Ord1 f, Ord1 g) => Lifting Ord (Compose f g) where lifting = Sub Dict instance (Functor f, Read1 f, Read1 g) => Lifting Read (Compose f g) where lifting = Sub Dict instance (Functor f, Show1 f, Show1 g) => Lifting Show (Compose f g) where lifting = Sub Dict #endif instance Functor f => Lifting Functor (Functor.Product f) where lifting = Sub Dict instance Foldable f => Lifting Foldable (Functor.Product f) where lifting = Sub Dict instance Traversable f => Lifting Traversable (Functor.Product f) where lifting = Sub Dict instance Applicative f => Lifting Applicative (Functor.Product f) where lifting = Sub Dict instance Alternative f => Lifting Alternative (Functor.Product f) where lifting = Sub Dict instance Monad f => Lifting Monad (Functor.Product f) where lifting = Sub Dict instance MonadFix f => Lifting MonadFix (Functor.Product f) where lifting = Sub Dict instance MonadPlus f => Lifting MonadPlus (Functor.Product f) where lifting = Sub Dict instance Show1 f => Lifting Show1 (Functor.Product f) where lifting = Sub Dict instance Eq1 f => Lifting Eq1 (Functor.Product f) where lifting = Sub Dict instance Ord1 f => Lifting Ord1 (Functor.Product f) where lifting = Sub Dict instance Read1 f => Lifting Read1 (Functor.Product f) where lifting = Sub Dict instance (Eq1 f, Eq1 g) => Lifting Eq (Functor.Product f g) where lifting = Sub Dict instance (Ord1 f, Ord1 g) => Lifting Ord (Functor.Product f g) where lifting = Sub Dict instance (Read1 f, Read1 g) => Lifting Read (Functor.Product f g) where lifting = Sub Dict instance (Show1 f, Show1 g) => Lifting Show (Functor.Product f g) where lifting = Sub Dict instance Functor f => Lifting Functor (Functor.Sum f) where lifting = Sub Dict instance Foldable f => Lifting Foldable (Functor.Sum f) where lifting = Sub Dict instance Traversable f => Lifting Traversable (Functor.Sum f) where lifting = Sub Dict instance Show1 f => Lifting Show1 (Functor.Sum f) where lifting = Sub Dict instance Eq1 f => Lifting Eq1 (Functor.Sum f) where lifting = Sub Dict instance Ord1 f => Lifting Ord1 (Functor.Sum f) where lifting = Sub Dict instance Read1 f => Lifting Read1 (Functor.Sum f) where lifting = Sub Dict instance (Eq1 f, Eq1 g) => Lifting Eq (Functor.Sum f g) where lifting = Sub Dict instance (Ord1 f, Ord1 g) => Lifting Ord (Functor.Sum f g) where lifting = Sub Dict instance (Read1 f, Read1 g) => Lifting Read (Functor.Sum f g) where lifting = Sub Dict instance (Show1 f, Show1 g) => Lifting Show (Functor.Sum f g) where lifting = Sub Dict instance Lifting Functor (Strict.StateT s) where lifting = Sub Dict instance Lifting Monad (Strict.StateT s) where lifting = Sub Dict instance Lifting MonadFix (Strict.StateT s) where lifting = Sub Dict instance Lifting MonadIO (Strict.StateT s) where lifting = Sub Dict instance Lifting MonadPlus (Strict.StateT s) where lifting = Sub Dict instance Lifting Functor (Lazy.StateT s) where lifting = Sub Dict instance Lifting Monad (Lazy.StateT s) where lifting = Sub Dict instance Lifting MonadFix (Lazy.StateT s) where lifting = Sub Dict instance Lifting MonadIO (Lazy.StateT s) where lifting = Sub Dict instance Lifting MonadPlus (Lazy.StateT s) where lifting = Sub Dict instance Lifting Functor (Lazy.RWST r w s) where lifting = Sub Dict instance Monoid w => Lifting Monad (Lazy.RWST r w s) where lifting = Sub Dict instance Monoid w => Lifting MonadFix (Lazy.RWST r w s) where lifting = Sub Dict instance Monoid w => Lifting MonadPlus (Lazy.RWST r w s) where lifting = Sub Dict instance Monoid w => Lifting MonadIO (Lazy.RWST r w s) where lifting = Sub Dict instance Lifting Functor (Strict.RWST r w s) where lifting = Sub Dict instance Monoid w => Lifting Monad (Strict.RWST r w s) where lifting = Sub Dict instance Monoid w => Lifting MonadFix (Strict.RWST r w s) where lifting = Sub Dict instance Monoid w => Lifting MonadPlus (Strict.RWST r w s) where lifting = Sub Dict instance Monoid w => Lifting MonadIO (Strict.RWST r w s) where lifting = Sub Dict instance Lifting Functor (ReaderT e) where lifting = Sub Dict instance Lifting Applicative (ReaderT e) where lifting = Sub Dict instance Lifting Alternative (ReaderT e) where lifting = Sub Dict instance Lifting Monad (ReaderT e) where lifting = Sub Dict instance Lifting MonadPlus (ReaderT e) where lifting = Sub Dict instance Lifting MonadFix (ReaderT e) where lifting = Sub Dict instance Lifting MonadIO (ReaderT e) where lifting = Sub Dict instance Lifting Functor (ErrorT e) where lifting = Sub Dict instance Lifting Foldable (ErrorT e) where lifting = Sub Dict instance Lifting Traversable (ErrorT e) where lifting = Sub Dict instance Error e => Lifting Monad (ErrorT e) where lifting = Sub Dict instance Error e => Lifting MonadFix (ErrorT e) where lifting = Sub Dict instance Error e => Lifting MonadPlus (ErrorT e) where lifting = Sub Dict -- overconstrained! instance Error e => Lifting MonadIO (ErrorT e) where lifting = Sub Dict instance Show e => Lifting Show1 (ErrorT e) where lifting = Sub Dict instance Eq e => Lifting Eq1 (ErrorT e) where lifting = Sub Dict instance Ord e => Lifting Ord1 (ErrorT e) where lifting = Sub Dict instance Read e => Lifting Read1 (ErrorT e) where lifting = Sub Dict instance (Show e, Show1 m) => Lifting Show (ErrorT e m) where lifting = Sub Dict instance (Eq e, Eq1 m) => Lifting Eq (ErrorT e m) where lifting = Sub Dict instance (Ord e, Ord1 m) => Lifting Ord (ErrorT e m) where lifting = Sub Dict instance (Read e, Read1 m) => Lifting Read (ErrorT e m) where lifting = Sub Dict instance Lifting Functor (ExceptT e) where lifting = Sub Dict instance Lifting Foldable (ExceptT e) where lifting = Sub Dict instance Lifting Traversable (ExceptT e) where lifting = Sub Dict instance Lifting Monad (ExceptT e) where lifting = Sub Dict instance Lifting MonadFix (ExceptT e) where lifting = Sub Dict instance Monoid e => Lifting MonadPlus (ExceptT e) where lifting = Sub Dict -- overconstrained! instance Lifting MonadIO (ExceptT e) where lifting = Sub Dict instance Show e => Lifting Show1 (ExceptT e) where lifting = Sub Dict instance Eq e => Lifting Eq1 (ExceptT e) where lifting = Sub Dict instance Ord e => Lifting Ord1 (ExceptT e) where lifting = Sub Dict instance Read e => Lifting Read1 (ExceptT e) where lifting = Sub Dict instance (Show e, Show1 m) => Lifting Show (ExceptT e m) where lifting = Sub Dict instance (Eq e, Eq1 m) => Lifting Eq (ExceptT e m) where lifting = Sub Dict instance (Ord e, Ord1 m) => Lifting Ord (ExceptT e m) where lifting = Sub Dict instance (Read e, Read1 m) => Lifting Read (ExceptT e m) where lifting = Sub Dict instance Lifting Functor (Strict.WriterT w) where lifting = Sub Dict instance Monoid w => Lifting Applicative (Strict.WriterT w) where lifting = Sub Dict instance Monoid w => Lifting Alternative (Strict.WriterT w) where lifting = Sub Dict instance Monoid w => Lifting Monad (Strict.WriterT w) where lifting = Sub Dict instance Monoid w => Lifting MonadFix (Strict.WriterT w) where lifting = Sub Dict instance Monoid w => Lifting MonadPlus (Strict.WriterT w) where lifting = Sub Dict instance Lifting Foldable (Strict.WriterT w) where lifting = Sub Dict instance Lifting Traversable (Strict.WriterT w) where lifting = Sub Dict instance Monoid w => Lifting MonadIO (Strict.WriterT w) where lifting = Sub Dict instance Show w => Lifting Show1 (Strict.WriterT w) where lifting = Sub Dict instance Eq w => Lifting Eq1 (Strict.WriterT w) where lifting = Sub Dict instance Ord w => Lifting Ord1 (Strict.WriterT w) where lifting = Sub Dict instance Read w => Lifting Read1 (Strict.WriterT w) where lifting = Sub Dict instance (Show w, Show1 m) => Lifting Show (Strict.WriterT w m) where lifting = Sub Dict instance (Eq w, Eq1 m) => Lifting Eq (Strict.WriterT w m) where lifting = Sub Dict instance (Ord w, Ord1 m) => Lifting Ord (Strict.WriterT w m) where lifting = Sub Dict instance (Read w, Read1 m) => Lifting Read (Strict.WriterT w m) where lifting = Sub Dict instance Lifting Functor (Lazy.WriterT w) where lifting = Sub Dict instance Monoid w => Lifting Applicative (Lazy.WriterT w) where lifting = Sub Dict instance Monoid w => Lifting Alternative (Lazy.WriterT w) where lifting = Sub Dict instance Monoid w => Lifting Monad (Lazy.WriterT w) where lifting = Sub Dict instance Monoid w => Lifting MonadFix (Lazy.WriterT w) where lifting = Sub Dict instance Monoid w => Lifting MonadPlus (Lazy.WriterT w) where lifting = Sub Dict instance Lifting Foldable (Lazy.WriterT w) where lifting = Sub Dict instance Lifting Traversable (Lazy.WriterT w) where lifting = Sub Dict instance Monoid w => Lifting MonadIO (Lazy.WriterT w) where lifting = Sub Dict instance Show w => Lifting Show1 (Lazy.WriterT w) where lifting = Sub Dict instance Eq w => Lifting Eq1 (Lazy.WriterT w) where lifting = Sub Dict instance Ord w => Lifting Ord1 (Lazy.WriterT w) where lifting = Sub Dict instance Read w => Lifting Read1 (Lazy.WriterT w) where lifting = Sub Dict instance (Show w, Show1 m) => Lifting Show (Lazy.WriterT w m) where lifting = Sub Dict instance (Eq w, Eq1 m) => Lifting Eq (Lazy.WriterT w m) where lifting = Sub Dict instance (Ord w, Ord1 m) => Lifting Ord (Lazy.WriterT w m) where lifting = Sub Dict instance (Read w, Read1 m) => Lifting Read (Lazy.WriterT w m) where lifting = Sub Dict instance Lifting Functor (ContT r) where lifting = Sub Dict -- overconstrained instance Lifting Applicative (ContT r) where lifting = Sub Dict -- overconstrained instance Lifting Monad (ContT r) where lifting = Sub Dict -- overconstrained instance Lifting MonadIO (ContT r) where lifting = Sub Dict instance Lifting Functor IdentityT where lifting = Sub Dict instance Lifting Applicative IdentityT where lifting = Sub Dict instance Lifting Alternative IdentityT where lifting = Sub Dict instance Lifting Monad IdentityT where lifting = Sub Dict instance Lifting MonadPlus IdentityT where lifting = Sub Dict instance Lifting MonadFix IdentityT where lifting = Sub Dict instance Lifting Foldable IdentityT where lifting = Sub Dict instance Lifting Traversable IdentityT where lifting = Sub Dict instance Lifting MonadIO IdentityT where lifting = Sub Dict instance Lifting Show1 IdentityT where lifting = Sub Dict instance Lifting Read1 IdentityT where lifting = Sub Dict instance Lifting Ord1 IdentityT where lifting = Sub Dict instance Lifting Eq1 IdentityT where lifting = Sub Dict instance Show1 m => Lifting Show (IdentityT m) where lifting = Sub Dict instance Read1 m => Lifting Read (IdentityT m) where lifting = Sub Dict instance Ord1 m => Lifting Ord (IdentityT m) where lifting = Sub Dict instance Eq1 m => Lifting Eq (IdentityT m) where lifting = Sub Dict instance Lifting Functor ListT where lifting = Sub Dict instance Lifting Applicative ListT where lifting = Sub Dict instance Lifting Alternative ListT where lifting = Sub Dict -- overconstrained instance Lifting Monad ListT where lifting = Sub Dict -- instance Lifting MonadFix ListT where lifting = Sub Dict instance Lifting MonadPlus ListT where lifting = Sub Dict -- overconstrained instance Lifting Foldable ListT where lifting = Sub Dict instance Lifting Traversable ListT where lifting = Sub Dict instance Lifting MonadIO ListT where lifting = Sub Dict instance Lifting Show1 ListT where lifting = Sub Dict instance Lifting Read1 ListT where lifting = Sub Dict instance Lifting Ord1 ListT where lifting = Sub Dict instance Lifting Eq1 ListT where lifting = Sub Dict instance Show1 m => Lifting Show (ListT m) where lifting = Sub Dict instance Read1 m => Lifting Read (ListT m) where lifting = Sub Dict instance Ord1 m => Lifting Ord (ListT m) where lifting = Sub Dict instance Eq1 m => Lifting Eq (ListT m) where lifting = Sub Dict instance Lifting Functor MaybeT where lifting = Sub Dict instance Lifting Monad MaybeT where lifting = Sub Dict -- instance Lifting MonadFix MaybeT where lifting = Sub Dict instance Lifting MonadPlus MaybeT where lifting = Sub Dict -- overconstrained instance Lifting Foldable MaybeT where lifting = Sub Dict instance Lifting Traversable MaybeT where lifting = Sub Dict instance Lifting MonadIO MaybeT where lifting = Sub Dict instance Lifting Show1 MaybeT where lifting = Sub Dict instance Lifting Read1 MaybeT where lifting = Sub Dict instance Lifting Ord1 MaybeT where lifting = Sub Dict instance Lifting Eq1 MaybeT where lifting = Sub Dict instance Show1 m => Lifting Show (MaybeT m) where lifting = Sub Dict instance Read1 m => Lifting Read (MaybeT m) where lifting = Sub Dict instance Ord1 m => Lifting Ord (MaybeT m) where lifting = Sub Dict instance Eq1 m => Lifting Eq (MaybeT m) where lifting = Sub Dict instance Lifting Functor Reverse where lifting = Sub Dict instance Lifting Applicative Reverse where lifting = Sub Dict instance Lifting Alternative Reverse where lifting = Sub Dict instance Lifting Foldable Reverse where lifting = Sub Dict instance Lifting Traversable Reverse where lifting = Sub Dict instance Lifting Show1 Reverse where lifting = Sub Dict instance Lifting Read1 Reverse where lifting = Sub Dict instance Lifting Ord1 Reverse where lifting = Sub Dict instance Lifting Eq1 Reverse where lifting = Sub Dict instance Show1 f => Lifting Show (Reverse f) where lifting = Sub Dict instance Read1 f => Lifting Read (Reverse f) where lifting = Sub Dict instance Ord1 f => Lifting Ord (Reverse f) where lifting = Sub Dict instance Eq1 f => Lifting Eq (Reverse f) where lifting = Sub Dict instance Lifting Functor Backwards where lifting = Sub Dict instance Lifting Foldable Backwards where lifting = Sub Dict instance Lifting Traversable Backwards where lifting = Sub Dict instance Lifting Applicative Backwards where lifting = Sub Dict instance Lifting Alternative Backwards where lifting = Sub Dict instance Lifting Show1 Backwards where lifting = Sub Dict instance Lifting Read1 Backwards where lifting = Sub Dict instance Lifting Ord1 Backwards where lifting = Sub Dict instance Lifting Eq1 Backwards where lifting = Sub Dict instance Show1 f => Lifting Show (Backwards f) where lifting = Sub Dict instance Read1 f => Lifting Read (Backwards f) where lifting = Sub Dict instance Ord1 f => Lifting Ord (Backwards f) where lifting = Sub Dict instance Eq1 f => Lifting Eq (Backwards f) where lifting = Sub Dict instance Lifting Functor Lift where lifting = Sub Dict instance Lifting Foldable Lift where lifting = Sub Dict instance Lifting Traversable Lift where lifting = Sub Dict instance Lifting Applicative Lift where lifting = Sub Dict instance Lifting Alternative Lift where lifting = Sub Dict instance Lifting Show1 Lift where lifting = Sub Dict instance Lifting Read1 Lift where lifting = Sub Dict instance Lifting Ord1 Lift where lifting = Sub Dict instance Lifting Eq1 Lift where lifting = Sub Dict instance Show1 f => Lifting Show (Lift f) where lifting = Sub Dict instance Read1 f => Lifting Read (Lift f) where lifting = Sub Dict instance Ord1 f => Lifting Ord (Lift f) where lifting = Sub Dict instance Eq1 f => Lifting Eq (Lift f) where lifting = Sub Dict instance Lifting Eq Identity where lifting = Sub Dict instance Lifting Ord Identity where lifting = Sub Dict instance Lifting Show Identity where lifting = Sub Dict instance Lifting Read Identity where lifting = Sub Dict instance Lifting MonadCont MaybeT where lifting = Sub Dict instance Lifting MonadCont ListT where lifting = Sub Dict instance Lifting MonadCont IdentityT where lifting = Sub Dict instance Monoid w => Lifting MonadCont (Strict.WriterT w) where lifting = Sub Dict instance Monoid w => Lifting MonadCont (Lazy.WriterT w) where lifting = Sub Dict instance Error e => Lifting MonadCont (ErrorT e) where lifting = Sub Dict instance Lifting MonadCont (ExceptT w) where lifting = Sub Dict instance Lifting MonadCont (Strict.StateT s) where lifting = Sub Dict instance Lifting MonadCont (Lazy.StateT s) where lifting = Sub Dict instance Lifting MonadCont (ReaderT e) where lifting = Sub Dict instance Monoid w => Lifting MonadCont (Strict.RWST r w s) where lifting = Sub Dict instance Monoid w => Lifting MonadCont (Lazy.RWST r w s) where lifting = Sub Dict instance Lifting (MonadError e) MaybeT where lifting = Sub Dict instance Lifting (MonadError e) ListT where lifting = Sub Dict instance Lifting (MonadError e) IdentityT where lifting = Sub Dict instance Monoid w => Lifting (MonadError e) (Strict.WriterT w) where lifting = Sub Dict instance Monoid w => Lifting (MonadError e) (Lazy.WriterT w) where lifting = Sub Dict instance Lifting (MonadError e) (Strict.StateT s) where lifting = Sub Dict instance Lifting (MonadError e) (Lazy.StateT s) where lifting = Sub Dict instance Lifting (MonadError e) (ReaderT r) where lifting = Sub Dict instance Monoid w => Lifting (MonadError e) (Strict.RWST r w s) where lifting = Sub Dict instance Monoid w => Lifting (MonadError e) (Lazy.RWST r w s) where lifting = Sub Dict instance Lifting (MonadRWS r w s) MaybeT where lifting = Sub Dict instance Lifting (MonadRWS r w s) IdentityT where lifting = Sub Dict instance Error e => Lifting (MonadRWS r w s) (ErrorT e) where lifting = Sub Dict instance Lifting (MonadRWS r w s) (ExceptT e) where lifting = Sub Dict instance Lifting (MonadReader r) MaybeT where lifting = Sub Dict instance Lifting (MonadReader r) ListT where lifting = Sub Dict instance Lifting (MonadReader r) IdentityT where lifting = Sub Dict instance Monoid w => Lifting (MonadReader r) (Strict.WriterT w) where lifting = Sub Dict instance Monoid w => Lifting (MonadReader r) (Lazy.WriterT w) where lifting = Sub Dict instance Lifting (MonadReader r) (Strict.StateT s) where lifting = Sub Dict instance Lifting (MonadReader r) (Lazy.StateT s) where lifting = Sub Dict instance Lifting (MonadReader r) (ExceptT e) where lifting = Sub Dict instance Error e => Lifting (MonadReader r) (ErrorT e) where lifting = Sub Dict instance Lifting (MonadReader r) (ContT r') where lifting = Sub Dict instance Lifting (MonadState s) MaybeT where lifting = Sub Dict instance Lifting (MonadState s) ListT where lifting = Sub Dict instance Lifting (MonadState s) IdentityT where lifting = Sub Dict instance Monoid w => Lifting (MonadState s) (Strict.WriterT w) where lifting = Sub Dict instance Monoid w => Lifting (MonadState s) (Lazy.WriterT w) where lifting = Sub Dict instance Lifting (MonadState s) (ReaderT r) where lifting = Sub Dict instance Lifting (MonadState s) (ExceptT e) where lifting = Sub Dict instance Error e => Lifting (MonadState s) (ErrorT e) where lifting = Sub Dict instance Lifting (MonadState s) (ContT r') where lifting = Sub Dict class Lifting2 p f where lifting2 :: p a :- Lifting p (f a) -- (p a, p b) :- p (f a b) instance Lifting2 Eq Either where lifting2 = Sub Dict instance Lifting2 Ord Either where lifting2 = Sub Dict instance Lifting2 Show Either where lifting2 = Sub Dict instance Lifting2 Read Either where lifting2 = Sub Dict instance Lifting2 Hashable Either where lifting2 = Sub Dict instance Lifting2 Binary Either where lifting2 = Sub Dict instance Lifting2 NFData Either where lifting2 = Sub Dict instance Lifting2 Eq (,) where lifting2 = Sub Dict instance Lifting2 Ord (,) where lifting2 = Sub Dict instance Lifting2 Show (,) where lifting2 = Sub Dict instance Lifting2 Read (,) where lifting2 = Sub Dict instance Lifting2 Hashable (,) where lifting2 = Sub Dict instance Lifting2 Binary (,) where lifting2 = Sub Dict instance Lifting2 NFData (,) where lifting2 = Sub Dict instance Lifting2 Semigroup (,) where lifting2 = Sub Dict instance Lifting2 Monoid (,) where lifting2 = Sub Dict instance Lifting2 Bounded (,) where lifting2 = Sub Dict instance Lifting2 Ix (,) where lifting2 = Sub Dict instance Lifting2 Functor Compose where lifting2 = Sub Dict instance Lifting2 Foldable Compose where lifting2 = Sub Dict instance Lifting2 Traversable Compose where lifting2 = Sub Dict instance Lifting2 Applicative Compose where lifting2 = Sub Dict instance Lifting2 Alternative Compose where lifting2 = Sub Dict -- overconstrained instance Lifting2 Functor Functor.Product where lifting2 = Sub Dict instance Lifting2 Foldable Functor.Product where lifting2 = Sub Dict instance Lifting2 Traversable Functor.Product where lifting2 = Sub Dict instance Lifting2 Applicative Functor.Product where lifting2 = Sub Dict instance Lifting2 Alternative Functor.Product where lifting2 = Sub Dict instance Lifting2 Monad Functor.Product where lifting2 = Sub Dict instance Lifting2 MonadPlus Functor.Product where lifting2 = Sub Dict instance Lifting2 MonadFix Functor.Product where lifting2 = Sub Dict instance Lifting2 Show1 Functor.Product where lifting2 = Sub Dict instance Lifting2 Eq1 Functor.Product where lifting2 = Sub Dict instance Lifting2 Ord1 Functor.Product where lifting2 = Sub Dict instance Lifting2 Read1 Functor.Product where lifting2 = Sub Dict instance Lifting2 Functor Functor.Sum where lifting2 = Sub Dict instance Lifting2 Foldable Functor.Sum where lifting2 = Sub Dict instance Lifting2 Traversable Functor.Sum where lifting2 = Sub Dict instance Lifting2 Show1 Functor.Sum where lifting2 = Sub Dict instance Lifting2 Eq1 Functor.Sum where lifting2 = Sub Dict instance Lifting2 Ord1 Functor.Sum where lifting2 = Sub Dict instance Lifting2 Read1 Functor.Sum where lifting2 = Sub Dict constraints-0.10.1/src/Data/Constraint/Forall.hs0000644000000000000000000001737513316540016017701 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE PolyKinds #-} #if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE UndecidableSuperClasses #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Constraint.Forall -- Copyright : (C) 2011-2015 Edward Kmett, -- (C) 2015 Ørjan Johansen, -- (C) 2016 David Feuer -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- -- This module uses a trick to provide quantification over constraints. ---------------------------------------------------------------------------- module Data.Constraint.Forall ( Forall, inst , ForallF, instF , Forall1, inst1 , ForallT, instT , ForallV, InstV (instV) , forall ) where import Data.Constraint import Unsafe.Coerce (unsafeCoerce) {- The basic trick of this module is to use "skolem" types as test candidates - for whether a class predicate holds, and if so assume that it holds for all - types, unsafely coercing the typeclass dictionary. - - The particular technique used to implement 'Forall' appears to have been - discovered first by Nicolas Frisby and is - - on his blog. - - However, his discovery did not directly affect the development of this - module. - - A previous version of this module used concrete, unexported types as the - skolems. This turned out to be unsound in the presence of type families. - There were 3 somewhat distinct issues: - - 1. Using closed type families, it is possible to test whether two concrete - types are equal, even if one of them is not directly importable. - - 2. Using just open type families, it is possible to test "at least 2 of - these n+1 types are equal", thus using the pigeonhole principle to thwart - any scheme based on having only a finite number of shared skolem types. - - 3. Using just pattern matching of types by unification, it is possible - to extract the skolem types from the application the `Forall p` expands - to. (Although type families are probably still needed to exploit this.) - - András Kovács and Ørjan Johansen independently realized that skolems - themselves made as type family applications can be used to solve the first - two problems (and discovered the third problem in the process). As a bonus, - the resulting code is easy to make polykinded. - - Problem 1 is solved by making the type family have no instances, forcing - GHC to make no assumption about what type a skolem is. - - Problem 2 is solved by parametrizing the skolem on the predicate tested - for. (This is a known trick in predicate logic.) - - Problem 3 is solved by making the `Forall p` application expand to a type - class, and have the *actual* test constraint be a superclass constraint on - that type class, thus preventing the user directly accessing it. - - An unfortunate side effect of the new method is that it tends to trigger - spurious errors from GHC test for cycles in superclass constraints. András - Kovács discovered that these can be silenced by yet another use of a type - family. - - David Feuer points out a remaining doubt about the soundness of this scheme: - GHC *does* know that the skolems created from a single predicate `p` are - equal. This could in theory apply even if the skolems come from two - *distinct* invocations of `Forall p`. - - However, we don't know any way of bringing two such skolems in contact with - each other to create an actual exploit. It would seem to require `p` to - already contain its own skolem, despite there being (hopefully) no way to - extract it from `Forall p` in order to tie the knot. -} -- The `Skolem` type family represents skolem variables; do not export! -- If GHC supports it, these might be made closed with no instances. type family Skolem (p :: k -> Constraint) :: k -- The outer `Forall` type family prevents GHC from giving a spurious -- superclass cycle error. -- The inner `Forall_` class prevents the skolem from leaking to the user, -- which would be disastrous. -- | A representation of the quantified constraint @forall a. p a@. type family Forall (p :: k -> Constraint) :: Constraint type instance Forall p = Forall_ p class p (Skolem p) => Forall_ (p :: k -> Constraint) instance p (Skolem p) => Forall_ (p :: k -> Constraint) -- | Instantiate a quantified @'Forall' p@ constraint at type @a@. inst :: forall p a. Forall p :- p a inst = unsafeCoerce (Sub Dict :: Forall p :- p (Skolem p)) -- | Composition for constraints. class p (f a) => ComposeC (p :: k2 -> Constraint) (f :: k1 -> k2) (a :: k1) instance p (f a) => ComposeC p f a -- | A representation of the quantified constraint @forall a. p (f a)@. class Forall (ComposeC p f) => ForallF (p :: k2 -> Constraint) (f :: k1 -> k2) instance Forall (ComposeC p f) => ForallF p f -- | Instantiate a quantified @'ForallF' p f@ constraint at type @a@. instF :: forall p f a . ForallF p f :- p (f a) instF = Sub $ case inst :: Forall (ComposeC p f) :- ComposeC p f a of Sub Dict -> Dict -- Classes building up to ForallT class p (t a b) => R (p :: k3 -> Constraint) (t :: k1 -> k2 -> k3) (a :: k1) (b :: k2) instance p (t a b) => R p t a b class Forall (R p t a) => Q (p :: k3 -> Constraint) (t :: k1 -> k2 -> k3) (a :: k1) instance Forall (R p t a) => Q p t a -- | A representation of the quantified constraint @forall f a. p (t f a)@. class Forall (Q p t) => ForallT (p :: k4 -> Constraint) (t :: (k1 -> k2) -> k3 -> k4) instance Forall (Q p t) => ForallT p t -- | Instantiate a quantified @'ForallT' p t@ constraint at types @f@ and @a@. instT :: forall (p :: k4 -> Constraint) (t :: (k1 -> k2) -> k3 -> k4) (f :: k1 -> k2) (a :: k3). ForallT p t :- p (t f a) instT = Sub $ case inst :: Forall (Q p t) :- Q p t f of { Sub Dict -> case inst :: Forall (R p t f) :- R p t f a of Sub Dict -> Dict } type Forall1 p = Forall p -- | Instantiate a quantified constraint on kind @* -> *@. -- This is now redundant since @'inst'@ became polykinded. inst1 :: forall (p :: (* -> *) -> Constraint) (f :: * -> *). Forall p :- p f inst1 = inst -- | A representation of the quantified constraint -- @forall a1 a2 ... an . p a1 a2 ... an@, supporting a variable number of -- parameters. type family ForallV :: k -> Constraint type instance ForallV = ForallV_ class ForallV' p => ForallV_ (p :: k) instance ForallV' p => ForallV_ p -- | Instantiate a quantified @'ForallV' p@ constraint as @c@, where -- @c ~ p a1 a2 ... an@. class InstV (p :: k) c | k c -> p where type ForallV' (p :: k) :: Constraint instV :: ForallV p :- c instance p ~ c => InstV (p :: Constraint) c where type ForallV' (p :: Constraint) = p instV = Sub Dict -- Treating 1 argument specially rather than recursing as a bit of (premature?) -- optimization instance p a ~ c => InstV (p :: k -> Constraint) c where type ForallV' (p :: k -> Constraint) = Forall p instV = Sub $ case inst :: Forall p :- c of Sub Dict -> Dict instance InstV (p a) c => InstV (p :: k1 -> k2 -> k3) c where type ForallV' (p :: k1 -> k2 -> k3) = ForallF ForallV p instV = Sub $ case instF :: ForallF ForallV p :- ForallV (p a) of Sub Dict -> case instV :: ForallV (p a) :- c of Sub Dict -> Dict forall :: forall p. (forall a. Dict (p a)) -> Dict (Forall p) forall d = case d :: Dict (p (Skolem p)) of Dict -> Dict constraints-0.10.1/tests/0000755000000000000000000000000013316540016013467 5ustar0000000000000000constraints-0.10.1/tests/GH55Spec.hs0000644000000000000000000000237313316540016015313 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE TypeApplications #-} #endif module GH55Spec (main, spec) where import Test.Hspec #if __GLASGOW_HASKELL__ >= 800 import Data.Constraint import Data.Constraint.Nat import GHC.TypeLits newtype GF (n :: Nat) = GF Integer deriving (Eq, Show) instance KnownNat n => Num (GF n) where xf@(GF a) + GF b = GF $ (a+b) `mod` (natVal xf) xf@(GF a) - GF b = GF $ (a-b) `mod` (natVal xf) xf@(GF a) * GF b = GF $ (a*b) `mod` (natVal xf) abs = id signum xf@(GF a) | a==0 = xf | otherwise = GF 1 fromInteger = GF x :: GF 5 x = GF 3 y :: GF 5 y = GF 4 foo :: (KnownNat m, KnownNat n) => GF m -> GF n -> GF (Lcm m n) foo m@(GF a) n@(GF b) = GF $ (a*b) `mod` (lcm (natVal m) (natVal n)) bar :: (KnownNat m) => GF m -> GF m -> GF m bar (a :: GF m) b = foo a b - foo b a \\ Sub @() (lcmIsIdempotent @m) \\ lcmNat @m @m z :: GF 5 z = bar x y spec :: Spec spec = describe "GH #53" $ it "should normalize Lcm m m" $ z `shouldBe` (GF 0 :: GF (Lcm 5 5)) #else spec :: Spec spec = return () #endif main :: IO () main = hspec spec constraints-0.10.1/tests/Spec.hs0000644000000000000000000000005413316540016014714 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-}