singletons-3.0.3/0000755000000000000000000000000007346545000012073 5ustar0000000000000000singletons-3.0.3/CHANGES.md0000644000000000000000000010313007346545000013463 0ustar0000000000000000Changelog for the `singletons` project ====================================== 3.0.3 [2024.05.12] ------------------ * Allow building with GHC 9.10. 3.0.2 [2022.08.23] ------------------ * Allow building with GHC 9.4. * When building with GHC 9.4 or later, use the new [`withDict`](https://hackage.haskell.org/package/ghc-prim-0.9.0/docs/GHC-Magic-Dict.html#v:withDict) primitive to implement `withSingI` instead of `unsafeCoerce`. This change should not have any consequences for user-facing code. 3.0.1 [2021.10.30] ------------------ * Add `SingI1` and `SingI2`, higher-order versions of `SingI`, to `Data.Singletons`, along with various derived functions: * `sing{1,2}` * `singByProxy{1,2}` and `singByProxy{1,2}#` * `usingSing{1,2}` * `withSing{1,2}` * `singThat{1,2}` 3.0 [2021.03.12] ---------------- * The `singletons` library has been split into three libraries: * The new `singletons` library is now a minimal library that only provides `Data.Singletons`, `Data.Singletons.Decide`, `Data.Singletons.Sigma`, and `Data.Singletons.ShowSing` (if compiled with GHC 8.6 or later). `singletons` now supports building GHCs back to GHC 8.0, as well as GHCJS. * The `singletons-th` library defines Template Haskell functionality for promoting and singling term-level definitions, but but nothing else. This library continues to require the latest stable release of GHC. * The `singletons-base` library defines promoted and singled versions of definitions from the `base` library, including the `Prelude`. This library continues to require the latest stable release of GHC. Consult the changelogs for `singletons-th` and `singletons-base` for changes specific to those libraries. For more information on this split, see the [relevant GitHub discussion](https://github.com/goldfirere/singletons/issues/420). * The internals of `ShowSing` have been tweaked to make it possible to derive `Show` instances for singleton types, e.g., ```hs deriving instance ShowSing a => Show (SList (z :: [a])) ``` For the most part, this is a backwards-compatible change, although there exists at least one corner case where the new internals of `ShowSing` require extra work to play nicely with GHC's constraint solver. For more details, refer to the Haddocks for `ShowSing'` in `Data.Singletons.ShowSing`. 2.7 --- * Require GHC 8.10. * Record selectors are now singled as top-level functions. For instance, `$(singletons [d| data T = MkT { unT :: Bool } |])` will now generate this: ```hs data ST :: T -> Type where SMkT :: Sing b -> Sing (MkT b) sUnT :: Sing (t :: T) -> Sing (UnT t :: Bool) sUnT (SMkT sb) = sb ... ``` Instead of this: ```hs data ST :: T -> Type where SMkT :: { sUnT :: Sing b } -> Sing (MkT b) ``` Note that the new type of `sUnT` is more general than the previous type (`Sing (MkT b) -> Sing b`). There are two primary reasons for this change: 1. Singling record selectors as top-level functions is consistent with how promoting records works (note that `MkT` is also a top-level function). As 2. Embedding record selectors directly into a singleton data constructor can result in surprising behavior. This can range from simple code using a record selector not typechecking to the inability to define multiple constructors that share the same record name. See [this GitHub issue](https://github.com/goldfirere/singletons/issues/364) for an extended discussion on the motivation behind this change. * The Template Haskell machinery now supports fine-grained configuration in the way of an `Options` data type, which lives in the new `Data.Singletons.TH.Options` module. Besides `Options`, this module also contains: * `Options`' record selectors. Currently, these include options to toggle generating quoted declarations, toggle generating `SingKind` instances, and configure how `singletons` generates the names of promoted or singled types. In the future, there may be additional options. * A `defaultOptions` value. * An `mtl`-like `OptionsMonad` class for monads that support carrying `Option`s. This includes `Q`, which uses `defaultOptions` if it is the top of the monad transformer stack. * An `OptionM` monad transformer that turns any `DsMonad` into an `OptionsMonad`. * A `withOptions` function which allows passing `Options` to TH functions (e.g., `promote` or `singletons`). See the `README` for a full example of how to use `withOptions`. Most TH functions are now polymorphic over `OptionsMonad` instead of `DsMonad`. * `singletons` now does a much better job of preserving the order of type variables in type signatures during promotion and singling. See the `Support for TypeApplications` section of the `README` for more details. When generating type-level declarations in particular (e.g., promoted type families or defunctionalization symbols), `singletons` will likely also generate standalone kind signatures to preserve type variable order. As a result, most `singletons` code that uses Template Haskell will require the use of the `StandaloneKindSignatures` extension (and, by extension, the `NoCUSKs` extension) to work. * `singletons` now does a more much thorough job of rejecting higher-rank types during promotion or singling, as `singletons` cannot support them. (Previously, `singletons` would sometimes accept them, often changing rank-2 types to rank-1 types incorrectly in the process.) * Add the `Data.Singletons.Prelude.Proxy` module. * Remove the promoted versions of `genericTake`, `genericDrop`, `genericSplitAt`, `genericIndex`, and `genericReplicate` from `Data.Singletons.Prelude.List`. These definitions were subtly wrong since (1) they claim to work over any `Integral` type `i`, but in practice would only work on `Nat`s, and (2) wouldn't even typecheck if they were singled. * Export `ApplyTyConAux1`, `ApplyTyConAux2`, as well as the record pattern synonyms selector `applySing2`, `applySing3`, etc. from `Data.Singletons`. These were unintentionally left out in previous releases. * Export promoted and singled versions of the `getDown` record selector in `Data.Singletons.Prelude.Ord`. * Fix a slew of bugs related to fixity declarations: * Fixity declarations for data types are no longer singled, as fixity declarations do not serve any purpose for singled data type constructors, which always have exactly one argument. * `singletons` now promotes fixity declarations for class names. `genPromotions`/`genSingletons` now also handle fixity declarations for classes, class methods, data types, and record selectors correctly. * `singletons` will no longer erroneously try to single fixity declarations for type synonym or type family names. * A bug that caused fixity declarations for certain defunctionalization symbols not to be generated has been fixed. * `promoteOnly` and `singletonsOnly` will now produce fixity declarations for values with infix names. 2.6 --- * Require GHC 8.8. * `Sing` has switched from a data family to a type family. This [GitHub issue comment](https://github.com/goldfirere/singletons/issues/318#issuecomment-467067257) provides a detailed explanation for the motivation behind this change. This has a number of consequences: * Names like `SBool`, `SMaybe`, etc. are no longer type synonyms for particular instantiations of `Sing` but are instead the names of the singleton data types themselves. In other words, previous versions of `singletons` would provide this: ```haskell data instance Sing :: Bool -> Type where SFalse :: Sing False STrue :: Sing True type SBool = (Sing :: Bool -> Type) ``` Whereas with `Sing`-as-a-type-family, `singletons` now provides this: ```haskell data SBool :: Bool -> Type where SFalse :: SBool False STrue :: SBool True type instance Sing @Bool = SBool ``` * The `Sing` instance for `TYPE rep` in `Data.Singletons.TypeRepTYPE` is now directly defined as `type instance Sing @(TYPE rep) = TypeRep`, without the use of an intermediate newtype as before. * Due to limitations in the ways that quantified constraints and type families can interact (see [this GHC issue](https://gitlab.haskell.org/ghc/ghc/issues/14860)), the internals of `ShowSing` has to be tweaked in order to continue to work with `Sing`-as-a-type-family. One notable consequence of this is that `Show` instances for singleton types can no longer be derived—they must be written by hand in order to work around [this GHC bug](https://gitlab.haskell.org/ghc/ghc/issues/16365). This is unlikely to affect you unless you define 'Show' instances for singleton types by hand. For more information, refer to the Haddocks for `ShowSing'` in `Data.Singletons.ShowSing`. * GHC does not permit type class instances to mention type families, which means that it is no longer possible to define instances that mention the `Sing` type constructor. For this reason, a `WrappedSing` data type (which is a newtype around `Sing`) was introduced so that one can hang instances off of it. This had one noticeable effect in `singletons` itself: there are no longer `TestEquality Sing` or `TestCoercion Sing` instances. Instead, `singletons` now generates a separate `TestEquality`/`TestCoercion` instance for every data type that singles a derived `Eq` instance. In addition, the `Data.Singletons.Decide` module now provides top-level `decideEquality`/`decideCoercion` functions which provide the behavior of `testEquality`/`testCoercion`, but monomorphized to `Sing`. Finally, `TestEquality`/`TestCoercion` instances are provided for `WrappedSing`. * GHC's behavior surrounding kind inference for local definitions has changed in 8.8, and certain code that `singletons` generates for local definitions may no longer typecheck as a result. While we have taken measures to mitigate the issue on `singletons`' end, there still exists code that must be patched on the users' end in order to continue compiling. For instance, here is an example of code that stopped compiling with the switch to GHC 8.8: ```haskell replicateM_ :: (Applicative m) => Nat -> m a -> m () replicateM_ cnt0 f = loop cnt0 where loop cnt | cnt <= 0 = pure () | otherwise = f *> loop (cnt - 1) ``` This produces errors to the effect of: ``` • Could not deduce (SNum k1) arising from a use of ‘sFromInteger’ from the context: SApplicative m ... • Could not deduce (SOrd k1) arising from a use of ‘%<=’ from the context: SApplicative m ... ``` The issue is that GHC 8.8 now kind-generalizes `sLoop` (whereas it did not previously), explaining why the error message mentions a mysterious kind variable `k1` that only appeared after kind generalization. The solution is to give `loop` an explicit type signature like so: ```diff -replicateM_ :: (Applicative m) => Nat -> m a -> m () +replicateM_ :: forall m a. (Applicative m) => Nat -> m a -> m () replicateM_ cnt0 f = loop cnt0 where + loop :: Nat -> m () loop cnt | cnt <= 0 = pure () | otherwise = f *> loop (cnt - 1) ``` This general approach should be sufficient to fix any type inference regressions that were introduced between GHC 8.6 and 8.8. If this isn't the case, please file an issue. * Due to [GHC Trac #16133](https://ghc.haskell.org/trac/ghc/ticket/16133) being fixed, `singletons`-generated code now requires explicitly enabling the `TypeApplications` extension. (The generated code was always using `TypeApplications` under the hood, but it's only now that GHC is detecting it.) * `Data.Singletons` now defines a family of `SingI` instances for `TyCon1` through `TyCon8`: ```haskell instance (forall a. SingI a => SingI (f a), ...) => SingI (TyCon1 f) instance (forall a b. (SingI a, SingI b) => SingI (f a b), ...) => SingI (TyCon2 f) ... ``` As a result, `singletons` no longer generates instances for `SingI` instances for applications of `TyCon{N}` to particular type constructors, as they have been superseded by the instances above. * Changes to `Data.Singletons.Sigma`: * `SSigma`, the singleton type for `Sigma`, is now defined. * New functions `fstSigma`, `sndSigma`, `FstSigma`, `SndSigma`, `currySigma`, and `uncurrySigma` have been added. A `Show` instance for `Sigma` has also been added. * `projSigma1` has been redefined to use continuation-passing style to more closely resemble its cousin `projSigma2`. The new type signature of `projSigma1` is: ```hs projSigma1 :: (forall (fst :: s). Sing fst -> r) -> Sigma s t -> r ``` The old type signature of `projSigma1` can be found in the `fstSigma` function. * `Σ` has been redefined such that it is now a partial application of `Sigma`, like so: ```haskell type Σ = Sigma ``` One benefit of this change is that one no longer needs defunctionalization symbols in order to partially apply `Σ`. As a result, `ΣSym0`, `ΣSym1`, and `ΣSym2` have been removed. * In line with corresponding changes in `base-4.13`, the `Fail`/`sFail` methods of `{P,S}Monad` have been removed in favor of new `{P,S}MonadFail` classes introduced in the `Data.Singletons.Prelude.Monad.Fail` module. These classes are also re-exported from `Data.Singletons.Prelude`. * Fix a bug where expressions with explicit signatures involving function types would fail to single. * The infix names `(.)` and `(!)` are no longer mapped to `(:.)` and `(:!)`, as GHC 8.8 learned to parse them at the type level. * The `Enum` instance for `SomeSing` now uses more efficient implementations of `enumFromTo` and `enumFromThenTo` that no longer require a `SingKind` constraint. 2.5.1 ----- * `ShowSing` is now a type class (with a single instance) instead of a type synonym. This was changed because defining `ShowSing` as a type synonym prevents it from working well with recursive types due to an unfortunate GHC bug. For more information, see [issue #371](https://github.com/goldfirere/singletons/issues/371). * Add an `IsString` instance for `SomeSing`. 2.5 --- * The `Data.Promotion.Prelude.*` namespace has been removed. Use the corresponding modules in the `Data.Singletons.Prelude.*` namespace instead. * Fix a regression in which certain infix type families, such as `(++)`, `($)`, `(+)`, and others, did not have the correct fixities. * The default implementation of the `(==)` type in `PEq` was changed from `(Data.Type.Equality.==)` to a custom type family, `DefaultEq`. The reason for this change is that `(Data.Type.Equality.==)` is unable to conclude that `a == a` reduces to `True` for any `a`. (As a result, the previous version of `singletons` regressed in terms of type inference for the `PEq` instances for `Nat` and `Symbol`, which used that default.) On the other hand, `DefaultEq a a` _does_ reduce to `True` for all `a`. * Add `Enum Nat`, `Show Nat`, and `Show Symbol` instances to `Data.Singletons.TypeLits`. * Template Haskell-generated code may require `DataKinds` and `PolyKinds` in scenarios which did not previously require it: * `singletons` now explicitly quantifies all kind variables used in explicit `forall`s. * `singletons` now generates `a ~> b` instead of `TyFun a b -> Type` whenever possible. * Since `th-desugar` now desugars all data types to GADT syntax, Template Haskell-generated code may require `GADTs` in situations that didn't require it before. * Overhaul the way derived `Show` instances for singleton types works. Before, there was an awkward `ShowSing` class (which was essentially a cargo-culted version of `Show` specialized for `Sing`) that one had to create instances for separately. Now that GHC has `QuantifiedConstraints`, we can scrap this whole class and turn `ShowSing` into a simple type synonym: ```haskell type ShowSing k = forall z. Show (Sing (z :: k)) ``` Now, instead of generating a hand-written `ShowSing` and `Show` instance for each singleton type, we only generate a single (derived!) `Show` instance. As a result of this change, you will likely need to enable `QuantifiedConstraints` and `StandaloneDeriving` if you single any derived `Show` instances in your code. * The kind of the type parameter to `SingI` is no longer specified. This only affects you if you were using the `sing` method with `TypeApplications`. For instance, if you were using `sing @Bool @True` before, then you will now need to now use `sing @Bool` instead. * `singletons` now generates `SingI` instances for defunctionalization symbols through Template Haskell. As a result, you may need to enable `FlexibleInstances` in more places. * `genDefunSymbols` is now more robust with respect to types that use dependent quantification, such as: ```haskell type family MyProxy k (a :: k) :: Type where MyProxy k (a :: k) = Proxy a ``` See the documentation for `genDefunSymbols` for limitations to this. * Rename `Data.Singletons.TypeRepStar` to `Data.Singletons.TypeRepTYPE`, and generalize the `Sing :: Type -> Type` instance to `Sing :: TYPE rep -> Type`, allowing it to work over more open kinds. Also rename `SomeTypeRepStar` to `SomeTypeRepTYPE`, and change its definition accordingly. * Promoting or singling a type synonym or type family declaration now produces defunctionalization symbols for it. (Previously, promoting or singling a type synonym did nothing whatsoever, and promoting or singling a type family produced an error.) * `singletons` now produces fixity declarations for defunctionalization symbols when appropriate. * Add `(%<=?)`, a singled version of `(<=?)` from `GHC.TypeNats`, as well as defunctionalization symbols for `(<=?)`, to `Data.Singletons.TypeLits`. * Add `Data.Singletons.Prelude.{Semigroup,Monoid}`, which define promoted and singled versions of the `Semigroup` and `Monoid` type classes, as well as various newtype modifiers. `Symbol` is now has promoted `Semigroup` and `Monoid` instances as well. As a consequence, `Data.Singletons.TypeLits` no longer exports `(<>)` or `(%<>)`, as they are superseded by the corresponding methods from `PSemigroup` and `SSemigroup`. * Add promoted and singled versions of the `Functor`, `Foldable`, `Traversable`, `Applicative`, `Alternative`, `Monad`, `MonadPlus`, and `MonadZip` classes. Among other things, this grants the ability to promote or single `do`-notation and list comprehensions. * `Data.Singletons.Prelude.List` now reexports more general `Foldable`/`Traversable` functions wherever possible, just as `Data.List` does. * Add `Data.Singletons.Prelude.{Const,Identity}`, which define promoted and singled version of the `Const` and `Identity` data types, respectively. * Promote and single the `Down` newtype in `Data.Singletons.Prelude.Ord`. * To match the `base` library, the promoted/singled versions of `comparing` and `thenCmp` are no longer exported from `Data.Singletons.Prelude`. (They continue to live in `Data.Singletons.Prelude.Ord`.) * Permit singling of expression and pattern signatures. * Permit promotion and singling of `InstanceSigs`. * `sError` and `sUndefined` now have `HasCallStack` constraints, like their counterparts `error` and `undefined`. The promoted and singled counterparts to `errorWithoutStackTrace` have also been added in case you do not want this behavior. * Add `Data.Singletons.TypeError`, which provides a drop-in replacement for `GHC.TypeLits.TypeError` which can be used at both the value- and type-level. 2.4.1 ----- * Restore the `TyCon1`, `TyCon2`, etc. types. It turns out that the new `TyCon` doesn't work with kind-polymorphic tycons. 2.4 --- * Require GHC 8.4. * `Demote Nat` is now `Natural` (from `Numeric.Natural`) instead of `Integer`. In accordance with this change, `Data.Singletons.TypeLits` now exposes `GHC.TypeNats.natVal` (which returns a `Natural`) instead of `GHC.TypeLits.natVal` (which returns an `Integer`). * The naming conventions for infix identifiers (e.g., `(&*)`) have been overhauled. * Infix functions (that are not constructors) are no longer prepended with a colon when promoted to type families. For instance, the promoted version of `(&*)` is now called `(&*)` as well, instead of `(:&*)` as before. There is one exception to this rule: the `(.)` function, which is promoted as `(:.)`. The reason is that one cannot write `(.)` at the type level. * Singletons for infix functions are now always prepended with `%` instead of `%:`. * Singletons for infix classes are now always prepended with `%` instead of `:%`. * Singletons for infix datatypes are now always prepended with a `%`. (Before, there was an unspoken requirement that singling an infix datatype required that name to begin with a colon, and the singleton type would begin with `:%`. But now that infix datatype names can be things like `(+)`, this requirement became obsolete.) The upshot is that most infix names can now be promoted using the same name, and singled by simply prepending the name with `%`. * The suffix for defunctionalized names of symbolic functions (e.g., `(+)`) has changed. Before, the promoted type name would be suffixed with some number of dollar signs (e.g., `(+$)` and `(+$$)`) to indicate defunctionalization symbols. Now, the promoted type name is first suffixed with `@#@` and _then_ followed by dollar signs (e.g., `(+@#@$)` and `(+@#@$$)`). Adopting this conventional eliminates naming conflicts that could arise for functions that consisted of solely `$` symbols. * The treatment of `undefined` is less magical. Before, all uses of `undefined` would be promoted to `GHC.Exts.Any` and singled to `undefined`. Now, there is a proper `Undefined` type family and `sUndefined` singleton function. * As a consequence of not promoting `undefined` to `Any`, there is no need to have a special `any_` function to distinguish the function on lists. The corresponding promoted type, singleton function, and defunctionalization symbols are now named `Any`, `sAny`, and `AnySym{0,1,2}`. * Rework the treatment of empty data types: * Generated `SingKind` instances for empty data types now use `EmptyCase` instead of simply `error`ing. * Derived `PEq` instances for empty data types now return `True` instead of `False`. Derived `SEq` instances now return `True` instead of `error`ing. * Derived `SDecide` instances for empty data types now return `Proved bottom`, where `bottom` is a divergent computation, instead of `error`ing. * Add `Data.Singletons.Prelude.IsString` and `Data.Promotion.Prelude.IsString` modules. `IsString.fromString` is now used when promoting or singling string literals when the `-XOverloadedStrings` extension is enabled (similarly to how `Num.fromInteger` is currently used when promoting or singling numeric literals). * Add `Data.Singletons.Prelude.Void`. * Add promoted and singled versions of `div`, `mod`, `divMod`, `quot`, `rem`, and `quotRem` to `Data.Singletons.TypeLits` that utilize the efficient `Div` and `Mod` type families from `GHC.TypeNats`. Also add `sLog2` and defunctionalization symbols for `Log2` from `GHC.TypeNats`. * Add `(<>)` and `(%<>)`, the promoted and singled versions of `AppendSymbol` from `GHC.TypeLits`. * Add `(%^)`, the singleton version of `GHC.TypeLits.^`. * Add `unlines` and `unwords` to `Data.Singletons.Prelude.List`. * Add promoted and singled versions of `Show`, including `deriving` support. * Add a `ShowSing` class, which facilitates the ability to write `Show` instances for `Sing` instances. * Permit derived `Ord` instances for empty datatypes. * Permit standalone `deriving` declarations. * Permit `DeriveAnyClass` (through the `anyclass` keyword of `DerivingStrategies`) * Add a value-level `(@@)`, which is a synonym for `applySing`. * Add `Eq`, `Ord`, `Num`, `Enum`, and `Bounded` instances for `SomeSing`, which leverage the `SEq`, `SOrd`, `SNum`, `SEnum`, and `SBounded` instances, respectively, for the underlying `Sing`. * Rework the `Sing (a :: *)` instance in `Data.Singletons.TypeRepStar` such that it now uses type-indexed `Typeable`. The new `Sing` instance is now: ```haskell newtype instance Sing :: Type -> Type where STypeRep :: TypeRep a -> Sing a ``` Accordingly, the `SingKind` instance has also been changed: ```haskell instance SingKind Type where type Demote Type = SomeTypeRepStar ... data SomeTypeRepStar where SomeTypeRepStar :: forall (a :: *). !(TypeRep a) -> SomeTypeRepStar ``` Aside from cleaning up some implementation details, this change assures that `toSing` can only be called on `TypeRep`s whose kind is of kind `*`. The previous implementation did not enforce this, which could lead to segfaults if used carelessly. * Instead of `error`ing, the `toSing` implementation in the `SingKind (k1 ~> k2)` instance now works as one would expect (provided the user adheres to some common-sense `SingKind` laws, which are now documented). * Add a `demote` function, which is a convenient shorthand for `fromSing sing`. * Add a `Data.Singletons.Sigma` module with a `Sigma` (dependent pair) data type. * Export defunctionalization symbols for `Demote`, `SameKind, `KindOf`, `(~>)`, `Apply`, and `(@@)` from `Data.Singletons`. * Add an explicitly bidirectional pattern synonym `Sing`. Pattern matching on `Sing` brings a `SingI ty` constraint into scope from a singleton `Sing ty`. * Add an explicitly bidirectional pattern synonym `FromSing`. Pattern matching on any demoted (base) type gives us the corresponding singleton. * Add explicitly bidirectional pattern synonyms `SLambda{2..8}`. Pattern matching on any defunctionalized singleton yields a term-level Haskell function on singletons. * Remove the family of `TyCon1`, `TyCon2`, ..., in favor of just `TyCon`. GHC 8.4's type system is powerful enough to allow this nice simplification. 2.3 --- * Documentation clarifiation in `Data.Singletons.TypeLits`, thanks to @ivan-m. * `Demote` was no longer a convenient way of calling `DemoteRep` and has been removed. `DemoteRep` has been renamed `Demote`. * `DemoteRep` is now injective. * Demoting a `Symbol` now gives `Text`. This is motivated by making `DemoteRep` injective. (If `Symbol` demoted to `String`, then there would be a conflict between demoting `[Char]` and `Symbol`.) * Generating singletons also now generates fixity declarations for the singletonized definitions, thanks to @int-index. * Though more an implementation detail: singletons no longer uses kind-level proxies anywhere, thanks again to @int-index. * Support for promoting higher-kinded type variables, thanks for @int-index. * `Data.Singletons.TypeLits` now exports defunctionalization symbols for `KnownNat` and `KnownSymbol`. * Better type inference support around constraints, as tracked in Issue #176. * Type synonym definitions are now ignored, as they should be. * `Show` instances for `SNat` and `SSymbol`, thanks to @cumber. * The `singFun` and `unSingFun` functions no longer use proxies, preferring `TypeApplications`. 2.2 --- * With `TypeInType`, we no longer kind `KProxy`. @int-index has very helpfully removed the use of `KProxy` from `singletons`. * Drop support for GHC 7.x. * Remove `bugInGHC`. That function was intended to work around GHC's difficulty in detecting exhaustiveness of GADT pattern matches. GHC 8 comes with a much better exhaustiveness checker, and so this function is no longer necessary. 2.1 --- * Require `th-desugar` >= 1.6 * Work with GHC 8. GHC 8 gives the opportunity to simplify some pieces of singletons, but these opportunities are not yet fully realized. For example, injective type families means that we no longer need `Sing` to be a data family; it could be a type family. This might drastically simplify the way functions are singletonized. But not yet! * `singletons` now outputs a few more type/kind annotations to help GHC do type inference. There may be a few more programs accepted than before. (This is the fix for #136.) 2.0.1 ----- * Lots more functions in `Data.Singletons.Prelude.List`: `filter`, `find`, `elemIndex`, `elemIndices`, `findIndex`, `findIndices`, `intersect`, `intersectBy`, `takeWhile`, `dropWhile`, `dropWhileEnd`, `span`, `break`, `take`, `drop`, `splitAt`, `group`, `maximum`, `minimum`, `insert`, `sort`, `groupBy`, `lookup`, `partition`, `sum`, `product`, `length`, `replicate`, `transpose`, `(!!)`, `nub`, `nubBy`, `unionBy`, `union`, `genericLength` 2.0.0.2 ------- * Fix fixity of `*`. 2.0.0.1 ------- * Make haddock work. 2.0 --- * Instance promotion now works properly -- it was quite buggy in 1.0. * Classes and instances can now be singletonized. * Limited support for functional dependencies. * We now have promoted and singletonized versions of `Enum`, as well as `Bounded`. * Deriving `Enum` is also now supported. * Ditto for `Num`, which includes an instance for `Nat`, naturally. * Promoting a literal number now uses overloaded literals at the type level, using a type-level `FromInteger` in the type-level `Num` class. * Better support for dealing with constraints. Some previously-unsingletonizable functions that have constrained parameters now work. * No more orphan `Quasi` instances! * Support for functions of arity 8 (instead of the old limit, 7). * Full support for fixity declarations. * A raft of bugfixes. * Drop support for GHC 7.8. You must have GHC 7.10.2. 1.1.2.1 ------- Fix bug #116, thus allowing locally-declared symbols to be used in GHC 7.10. 1.1.2 ----- * No more GHC 7.8.2 support -- you must have GHC 7.8.3. 1.1.1 ----- Update testsuite to work with th-desugar-1.5.2. No functional changes. 1.1 --- This is a maintenance release to support building (but *not* testing, due to GHC bug #10058) with 7.10. This release also targets th-desugar-1.5. Some types changed (using th-desugar's new `DsMonad` instead of `Quasi`), but clients generally won't need to make any changes, unless they, too, generalize over `Quasi`. 1.0 --- This is a complete rewrite of the package. * A much wider array of surface syntax is now accepted for promotion and singletonization, including `let`, `case`, partially-applied functions, and anonymous functions, `where`, sections, among others. * Classes and instances can be promoted (but not singletonized). * Derivation of promoted instances for `Ord` and `Bounded`. This release can be seen as a "technology preview". More features are coming soon. This version drops GHC 7.6 support. 0.10.0 ------ Template Haskell names are now more hygienic. In other words, `singletons` won't try to gobble up something happened to be named `Sing` in your project. (Note that the Template Haskell names are not *completely* hygienic; names generated during singleton generation can still cause conflicts.) If a function to be promoted or singletonized is missing a type signature, that is now an *error*, not a warning. Added a new external module Data.Singletons.TypeLits, which contain the singletons for GHC.TypeLits. Some convenience functions are also provided. The extension `EmptyCase` is no longer needed. This caused pain when trying to support both GHC 7.6.3 and 7.8. 0.9.3 ----- Fix export list of Data.Singletons.TH, again again. Add `SEq` instances for `Nat` and `Symbol`. 0.9.2 ----- Fix export list of Data.Singletons.TH, again. 0.9.1 ----- Fix export list of Data.Singletons.TH. 0.9.0 ----- Make compatible with GHC HEAD, but HEAD reports core lint errors sometimes. Change module structure significantly. If you want to derive your own singletons, you should import `Data.Singletons.TH`. The module `Data.Singletons` now exports functions only for the *use* of singletons. New modules `Data.Singletons.Bool`, `...Maybe`, `...Either`, and `...List` are just like their equivalents from `Data.`, except for `List`, which is quite lacking in features. For singleton equality, use `Data.Singletons.Eq`. For propositional singleton equality, use `Data.Singletons.Decide`. New module `Data.Singletons.Prelude` is meant to mirror the Haskell Prelude, but with singleton definitions. Streamline representation of singletons, resulting in *exponential* speedup at execution. (This has not been rigorously measured, but the data structures are now *exponentially* smaller.) Add internal support for TypeLits, because the TypeLits module no longer exports singleton definitions. Add support for existential singletons, through the `toSing` method of `SingKind`. Remove the `SingE` class, bundling its functionality into `SingKind`. Thus, the `SingRep` synonym has also been removed. Name change: `KindIs` becomes `KProxy`. Add support for singletonizing calls to `error`. Add support for singletonizing empty data definitions. 0.8.6 ----- Make compatible with GHC HEAD, but HEAD reports core lint errors sometimes. 0.8.5 ----- Bug fix to make singletons compatible with GHC 7.6.1. Added git info to cabal file. 0.8.4 ----- Update to work with latest version of GHC (7.7.20130114). Now use branched type family instances to allow for promotion of functions with overlapping patterns. Permit promotion of functions with constraints by omitting constraints. 0.8.3 ----- Update to work with latest version of GHC (7.7.20121031). Removed use of Any to simulate kind classes; now using KindOf and OfKind from GHC.TypeLits. Made compatible with GHC.TypeLits. 0.8.2 ----- Added this changelog Update to work with latest version of GHC (7.6.1). (There was a change to Template Haskell). Moved library into Data.Singletons. 0.8.1 ----- Update to work with latest version of GHC. (There was a change to Template Haskell). Updated dependencies in cabal to include the newer version of TH. 0.8 --- Initial public release singletons-3.0.3/LICENSE0000644000000000000000000000271307346545000013103 0ustar0000000000000000Copyright (c) 2012-2020, Richard Eisenberg 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. 3. Neither the name of the author 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 HOLDER 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. singletons-3.0.3/README.md0000644000000000000000000000224307346545000013353 0ustar0000000000000000`singletons` ============ [![Hackage](https://img.shields.io/hackage/v/singletons.svg)](http://hackage.haskell.org/package/singletons) `singletons` contains the basic types and definitions needed to support dependently typed programming techniques in Haskell. This library was originally presented in [_Dependently Typed Programming with Singletons_](https://richarde.dev/papers/2012/singletons/paper.pdf), published at the Haskell Symposium, 2012. `singletons` is intended to be a small, foundational library on which other projects can build. As such, `singletons` has a minimal dependency footprint and supports GHCs dating back to GHC 8.0. For more information, consult the `singletons` [`README`](https://github.com/goldfirere/singletons/blob/master/README.md). You may also be interested in the following related libraries: * The `singletons-th` library defines Template Haskell functionality that allows _promotion_ of term-level functions to type-level equivalents and _singling_ functions to dependently typed equivalents. * The `singletons-base` library uses `singletons-th` to define promoted and singled functions from the `base` library, including the `Prelude`. singletons-3.0.3/Setup.hs0000644000000000000000000000005607346545000013530 0ustar0000000000000000import Distribution.Simple main = defaultMain singletons-3.0.3/singletons.cabal0000644000000000000000000000571007346545000015247 0ustar0000000000000000name: singletons version: 3.0.3 cabal-version: 1.24 synopsis: Basic singleton types and definitions homepage: http://www.github.com/goldfirere/singletons category: Dependent Types author: Richard Eisenberg , Jan Stolarek maintainer: Ryan Scott bug-reports: https://github.com/goldfirere/singletons/issues stability: experimental tested-with: GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2 , GHC == 9.2.7 , GHC == 9.4.8 , GHC == 9.6.5 , GHC == 9.8.2 , GHC == 9.10.1 extra-source-files: README.md, CHANGES.md license: BSD3 license-file: LICENSE build-type: Simple description: @singletons@ contains the basic types and definitions needed to support dependently typed programming techniques in Haskell. This library was originally presented in /Dependently Typed Programming with Singletons/, published at the Haskell Symposium, 2012. () . @singletons@ is intended to be a small, foundational library on which other projects can build. As such, @singletons@ has a minimal dependency footprint and supports GHCs dating back to GHC 8.0. For more information, consult the @singletons@ @@. . You may also be interested in the following related libraries: . * The @singletons-th@ library defines Template Haskell functionality that allows /promotion/ of term-level functions to type-level equivalents and /singling/ functions to dependently typed equivalents. . * The @singletons-base@ library uses @singletons-th@ to define promoted and singled functions from the @base@ library, including the "Prelude". source-repository this type: git location: https://github.com/goldfirere/singletons.git subdir: singletons tag: v3.0.2 source-repository head type: git location: https://github.com/goldfirere/singletons.git subdir: singletons branch: master library hs-source-dirs: src build-depends: base >= 4.9 && < 4.21 default-language: Haskell2010 exposed-modules: Data.Singletons Data.Singletons.Decide Data.Singletons.ShowSing Data.Singletons.Sigma ghc-options: -Wall test-suite singletons-test-suite type: exitcode-stdio-1.0 hs-source-dirs: tests ghc-options: -Wall -threaded default-language: Haskell2010 main-is: SingletonsTestSuite.hs other-modules: ByHand ByHand2 build-depends: base >= 4.9 && < 4.21, singletons singletons-3.0.3/src/Data/0000755000000000000000000000000007346545000013533 5ustar0000000000000000singletons-3.0.3/src/Data/Singletons.hs0000644000000000000000000014613707346545000016230 0ustar0000000000000000{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} #if __GLASGOW_HASKELL__ >= 806 {-# LANGUAGE QuantifiedConstraints #-} #else {-# LANGUAGE TypeInType #-} #endif #if __GLASGOW_HASKELL__ >= 810 {-# LANGUAGE StandaloneKindSignatures #-} #endif #if __GLASGOW_HASKELL__ >= 910 {-# LANGUAGE TypeAbstractions #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Singletons -- Copyright : (C) 2013 Richard Eisenberg -- License : BSD-style (see LICENSE) -- Maintainer : Ryan Scott -- Stability : experimental -- Portability : non-portable -- -- This module exports the basic definitions to use singletons. See also -- @Prelude.Singletons@ from the @singletons-base@ -- library, which re-exports this module alongside many singled definitions -- based on the "Prelude". -- -- You may also want to read -- the original papers presenting this library, available at -- -- and . -- ---------------------------------------------------------------------------- module Data.Singletons ( -- * Main singleton definitions Sing, SLambda(..), (@@), SingI(..), SingI1(..), sing1, SingI2(..), sing2, SingKind(..), -- * Working with singletons KindOf, SameKind, SingInstance(..), SomeSing(..), singInstance, pattern Sing, withSingI, withSomeSing, pattern FromSing, usingSingI1, usingSingI2, singByProxy, singByProxy1, singByProxy2, demote, demote1, demote2, singByProxy#, singByProxy1#, singByProxy2#, withSing, withSing1, withSing2, singThat, singThat1, singThat2, -- ** @WrappedSing@ WrappedSing(..), SWrappedSing(..), UnwrapSing, -- $SingletonsOfSingletons -- ** Defunctionalization TyFun, type (~>), TyCon1, TyCon2, TyCon3, TyCon4, TyCon5, TyCon6, TyCon7, TyCon8, Apply, type (@@), #if __GLASGOW_HASKELL__ >= 806 TyCon, ApplyTyCon, ApplyTyConAux1, ApplyTyConAux2, #endif -- ** Defunctionalized singletons -- | When calling a higher-order singleton function, you need to use a -- @singFun...@ function to wrap it. See 'singFun1'. singFun1, singFun2, singFun3, singFun4, singFun5, singFun6, singFun7, singFun8, unSingFun1, unSingFun2, unSingFun3, unSingFun4, unSingFun5, unSingFun6, unSingFun7, unSingFun8, -- $SLambdaPatternSynonyms pattern SLambda2, applySing2, pattern SLambda3, applySing3, pattern SLambda4, applySing4, pattern SLambda5, applySing5, pattern SLambda6, applySing6, pattern SLambda7, applySing7, pattern SLambda8, applySing8, -- | These type synonyms are exported only to improve error messages; users -- should not have to mention them. SingFunction1, SingFunction2, SingFunction3, SingFunction4, SingFunction5, SingFunction6, SingFunction7, SingFunction8, -- * Auxiliary functions Proxy(..), -- * Defunctionalization symbols DemoteSym0, DemoteSym1, SameKindSym0, SameKindSym1, SameKindSym2, KindOfSym0, KindOfSym1, type (~>@#@$), type (~>@#@$$), type (~>@#@$$$), ApplySym0, ApplySym1, ApplySym2, type (@@@#@$), type (@@@#@$$), type (@@@#@$$$) ) where import Data.Kind (Constraint, Type) import Data.Proxy (Proxy(..)) import GHC.Exts (Proxy#) import Unsafe.Coerce (unsafeCoerce) #if MIN_VERSION_base(4,17,0) import GHC.Exts (withDict) #endif -- | Convenient synonym to refer to the kind of a type variable: -- @type KindOf (a :: k) = k@ #if __GLASGOW_HASKELL__ >= 810 type KindOf :: k -> Type #endif type KindOf (a :: k) = k -- | Force GHC to unify the kinds of @a@ and @b@. Note that @SameKind a b@ is -- different from @KindOf a ~ KindOf b@ in that the former makes the kinds -- unify immediately, whereas the latter is a proposition that GHC considers -- as possibly false. #if __GLASGOW_HASKELL__ >= 810 type SameKind :: k -> k -> Constraint #endif type SameKind (a :: k) (b :: k) = (() :: Constraint) ---------------------------------------------------------------------- ---- Sing & friends -------------------------------------------------- ---------------------------------------------------------------------- -- | The singleton kind-indexed type family. #if __GLASGOW_HASKELL__ >= 810 type Sing :: k -> Type #endif #if __GLASGOW_HASKELL__ >= 910 type family Sing @k :: k -> Type #else type family Sing :: k -> Type #endif {- Note [The kind of Sing] ~~~~~~~~~~~~~~~~~~~~~~~ It is important to define Sing like this: type Sing :: k -> Type type family Sing Or, equivalently, type family Sing :: k -> Type There are other conceivable ways to define Sing, but they all suffer from various drawbacks: * type family Sing :: forall k. k -> Type Surprisingly, this is /not/ equivalent to `type family Sing :: k -> Type`. The difference lies in their arity, i.e., the number of arguments that must be supplied in order to apply Sing. The former declaration has arity 0, while the latter has arity 1 (this is more obvious if you write the declaration as GHCi would display it with -fprint-explicit-kinds enabled: `type family Sing @k :: k -> Type`). The former declaration having arity 0 is actually what makes it useless. If we were to adopt an arity-0 definition of `Sing`, then in order to write `type instance Sing = SFoo`, GHC would require that `SFoo` must have the kind `forall k. k -> Type`, and moreover, the kind /must/ be polymorphic in `k`. This is undesirable, because in practice, every single `Sing` instance in the wild must monomorphize `k` (e.g., `SBool` monomorphizes it to `Bool`), so an arity-0 `Sing` simply won't work. In contrast, the current arity-1 definition of `Sing` /does/ let you monomorphize `k` in type family instances. * type family Sing (a :: k) = (r :: Type) | r -> a Again, this is not equivalent to `type family Sing :: k -> Type`. This version of `Sing` has arity 2, since one must supply both `k` and `a` in order to apply it. While an arity-2 `Sing` is not suffer from the same polymorphism issues as the arity-0 `Sing` in the previous bullet point, it does suffer from another issue in that it cannot be partially applied. This is because its `a` argument /must/ be supplied, whereas with the arity-1 `Sing`, it is perfectly admissible to write `Sing` without an explicit `a` argument. (Its invisible `k` argument is filled in automatically behind the scenes.) * type family Sing = (r :: k -> Type) | r -> k This is the same as `type family Sing :: k -> Type`, but with an injectivity annotation. Technically, this definition isn't /wrong/, but the injectivity annotation is actually unnecessary. Because the return kind of `Sing` is declared to be `k -> Type`, the `Sing` type constructor is automatically injective, so `Sing a1 ~ Sing a2` implies `a1 ~~ a2`. Another way of phrasing this, using the terminology of Dependent Haskell, is that the arrow in `Sing`'s return kind is /matchable/, which implies that `Sing` is an injective type constructor as a consequence. -} -- | A 'SingI' constraint is essentially an implicitly-passed singleton. -- -- In contrast to the 'SingKind' class, which is parameterized over data types -- promoted to the kind level, the 'SingI' class is parameterized over values -- promoted to the type level. To explain this distinction another way, consider -- this code: -- -- @ -- f = fromSing (sing @(T :: K)) -- @ -- -- Here, @f@ uses methods from both 'SingI' and 'SingKind'. However, the shape -- of each constraint is rather different: using 'sing' requires a 'SingI T' -- constraint, whereas using 'fromSing' requires a 'SingKind K' constraint. -- -- If you need to satisfy this constraint with an explicit singleton, please -- see 'withSingI' or the 'Sing' pattern synonym. #if __GLASGOW_HASKELL__ >= 900 type SingI :: forall {k}. k -> Constraint #endif class SingI a where -- | Produce the singleton explicitly. You will likely need the @ScopedTypeVariables@ -- extension to use this method the way you want. sing :: Sing a -- | A version of the 'SingI' class lifted to unary type constructors. #if __GLASGOW_HASKELL__ >= 900 type SingI1 :: forall {k1} {k2}. (k1 -> k2) -> Constraint #endif class #if __GLASGOW_HASKELL__ >= 806 (forall x. SingI x => SingI (f x)) => #endif SingI1 f where -- | Lift an explicit singleton through a unary type constructor. -- You will likely need the @ScopedTypeVariables@ extension to use this -- method the way you want. liftSing :: Sing x -> Sing (f x) -- | Produce a singleton explicitly using implicit 'SingI1' and 'SingI' -- constraints. You will likely need the @ScopedTypeVariables@ extension to use -- this method the way you want. sing1 :: (SingI1 f, SingI x) => Sing (f x) sing1 = liftSing sing -- | A version of the 'SingI' class lifted to binary type constructors. #if __GLASGOW_HASKELL__ >= 900 type SingI2 :: forall {k1} {k2} {k3}. (k1 -> k2 -> k3) -> Constraint #endif class #if __GLASGOW_HASKELL__ >= 806 (forall x y. (SingI x, SingI y) => SingI (f x y)) => #endif SingI2 f where -- | Lift explicit singletons through a binary type constructor. -- You will likely need the @ScopedTypeVariables@ extension to use this -- method the way you want. liftSing2 :: Sing x -> Sing y -> Sing (f x y) -- | Produce a singleton explicitly using implicit 'SingI2' and 'SingI' -- constraints. You will likely need the @ScopedTypeVariables@ extension to use -- this method the way you want. sing2 :: (SingI2 f, SingI x, SingI y) => Sing (f x y) sing2 = liftSing2 sing sing -- | An explicitly bidirectional pattern synonym for implicit singletons. -- -- As an __expression__: Constructs a singleton @Sing a@ given a -- implicit singleton constraint @SingI a@. -- -- As a __pattern__: Matches on an explicit @Sing a@ witness bringing -- an implicit @SingI a@ constraint into scope. #if __GLASGOW_HASKELL__ >= 802 {-# COMPLETE Sing #-} #endif pattern Sing :: forall k (a :: k). () => SingI a => Sing a pattern Sing <- (singInstance -> SingInstance) where Sing = sing -- | The 'SingKind' class is a /kind/ class. It classifies all kinds -- for which singletons are defined. The class supports converting between a singleton -- type and the base (unrefined) type which it is built from. -- -- For a 'SingKind' instance to be well behaved, it should obey the following laws: -- -- @ -- 'toSing' . 'fromSing' ≡ 'SomeSing' -- (\\x -> 'withSomeSing' x 'fromSing') ≡ 'id' -- @ -- -- The final law can also be expressed in terms of the 'FromSing' pattern -- synonym: -- -- @ -- (\\('FromSing' sing) -> 'FromSing' sing) ≡ 'id' -- @ #if __GLASGOW_HASKELL__ >= 810 type SingKind :: Type -> Constraint #endif class SingKind k where -- | Get a base type from the promoted kind. For example, -- @Demote Bool@ will be the type @Bool@. Rarely, the type and kind do not -- match. For example, @Demote Nat@ is @Natural@. type Demote k = (r :: Type) | r -> k -- | Convert a singleton to its unrefined version. fromSing :: Sing (a :: k) -> Demote k -- | Convert an unrefined type to an existentially-quantified singleton type. toSing :: Demote k -> SomeSing k -- | An /existentially-quantified/ singleton. This type is useful when you want a -- singleton type, but there is no way of knowing, at compile-time, what the type -- index will be. To make use of this type, you will generally have to use a -- pattern-match: -- -- > foo :: Bool -> ... -- > foo b = case toSing b of -- > SomeSing sb -> {- fancy dependently-typed code with sb -} -- -- An example like the one above may be easier to write using 'withSomeSing'. #if __GLASGOW_HASKELL__ >= 810 type SomeSing :: Type -> Type #endif data SomeSing k where SomeSing :: Sing (a :: k) -> SomeSing k -- | An explicitly bidirectional pattern synonym for going between a -- singleton and the corresponding demoted term. -- -- As an __expression__: this takes a singleton to its demoted (base) -- type. -- -- >>> :t FromSing \@Bool -- FromSing \@Bool :: Sing a -> Bool -- >>> FromSing SFalse -- False -- -- As a __pattern__: It extracts a singleton from its demoted (base) -- type. -- -- @ -- singAnd :: 'Bool' -> 'Bool' -> 'SomeSing' 'Bool' -- singAnd ('FromSing' singBool1) ('FromSing' singBool2) = -- 'SomeSing' (singBool1 %&& singBool2) -- @ -- -- instead of writing it with 'withSomeSing': -- -- @ -- singAnd bool1 bool2 = -- 'withSomeSing' bool1 $ \singBool1 -> -- 'withSomeSing' bool2 $ \singBool2 -> -- 'SomeSing' (singBool1 %&& singBool2) -- @ #if __GLASGOW_HASKELL__ >= 802 {-# COMPLETE FromSing #-} #endif pattern FromSing :: SingKind k => forall (a :: k). Sing a -> Demote k pattern FromSing sng <- ((\demotedVal -> withSomeSing demotedVal SomeSing) -> SomeSing sng) where FromSing sng = fromSing sng ---------------------------------------------------------------------- ---- WrappedSing ----------------------------------------------------- ---------------------------------------------------------------------- -- | A newtype around 'Sing'. -- -- Since 'Sing' is a type family, it cannot be used directly in type class -- instances. As one example, one cannot write a catch-all -- @instance 'SDecide' k => 'TestEquality' ('Sing' k)@. On the other hand, -- 'WrappedSing' is a perfectly ordinary data type, which means that it is -- quite possible to define an -- @instance 'SDecide' k => 'TestEquality' ('WrappedSing' k)@. #if __GLASGOW_HASKELL__ >= 810 type WrappedSing :: k -> Type #endif newtype WrappedSing :: forall k. k -> Type where WrapSing :: forall k (a :: k). { unwrapSing :: Sing a } -> WrappedSing a -- | The singleton for 'WrappedSing's. Informally, this is the singleton type -- for other singletons. #if __GLASGOW_HASKELL__ >= 810 type SWrappedSing :: forall k (a :: k). WrappedSing a -> Type #endif newtype SWrappedSing :: forall k (a :: k). WrappedSing a -> Type where SWrapSing :: forall k (a :: k) (ws :: WrappedSing a). { sUnwrapSing :: Sing a } -> SWrappedSing ws type instance Sing = SWrappedSing #if __GLASGOW_HASKELL__ >= 810 type UnwrapSing :: forall k (a :: k). WrappedSing a -> Sing a #endif type family UnwrapSing (ws :: WrappedSing (a :: k)) :: Sing a where UnwrapSing ('WrapSing s) = s instance SingKind (WrappedSing a) where type Demote (WrappedSing a) = WrappedSing a fromSing (SWrapSing s) = WrapSing s toSing (WrapSing s) = SomeSing $ SWrapSing s instance forall a (s :: Sing a). SingI a => SingI ('WrapSing s) where sing = SWrapSing sing ---------------------------------------------------------------------- ---- SingInstance ---------------------------------------------------- ---------------------------------------------------------------------- -- | A 'SingInstance' wraps up a 'SingI' instance for explicit handling. #if __GLASGOW_HASKELL__ >= 810 type SingInstance :: k -> Type #endif data SingInstance (a :: k) where SingInstance :: SingI a => SingInstance a -- | Get an implicit singleton (a 'SingI' instance) from an explicit one. singInstance :: forall k (a :: k). Sing a -> SingInstance a singInstance s = with_sing_i SingInstance where with_sing_i :: (SingI a => SingInstance a) -> SingInstance a #if MIN_VERSION_base(4,17,0) with_sing_i = withDict @(SingI a) @(Sing a) s #else with_sing_i si = unsafeCoerce (Don'tInstantiate si) s -- dirty implementation of explicit-to-implicit conversion #if __GLASGOW_HASKELL__ >= 810 type DI :: k -> Type #endif newtype DI a = Don'tInstantiate (SingI a => SingInstance a) #endif ---------------------------------------------------------------------- ---- Defunctionalization --------------------------------------------- ---------------------------------------------------------------------- -- | Representation of the kind of a type-level function. The difference -- between term-level arrows and this type-level arrow is that at the term -- level applications can be unsaturated, whereas at the type level all -- applications have to be fully saturated. #if __GLASGOW_HASKELL__ >= 810 type TyFun :: Type -> Type -> Type #endif data TyFun :: Type -> Type -> Type -- | Something of kind @a '~>' b@ is a defunctionalized type function that is -- not necessarily generative or injective. Defunctionalized type functions -- (also called \"defunctionalization symbols\") can be partially applied, even -- if the original type function cannot be. For more information on how this -- works, see the "Promotion and partial application" section of the -- @@. -- -- The singleton for things of kind @a '~>' b@ is 'SLambda'. 'SLambda' values -- can be constructed in one of two ways: -- -- 1. With the @singFun*@ family of combinators (e.g., 'singFun1'). For -- example, if you have: -- -- @ -- type Id :: a -> a -- sId :: Sing a -> Sing (Id a) -- @ -- -- Then you can construct a value of type @'Sing' \@(a '~>' a)@ (that is, -- @'SLambda' \@a \@a@ like so: -- -- @ -- sIdFun :: 'Sing' \@(a '~>' a) IdSym0 -- sIdFun = singFun1 @IdSym0 sId -- @ -- -- Where @IdSym0 :: a '~>' a@ is the defunctionlized version of @Id@. -- -- 2. Using the 'SingI' class. For example, @'sing' \@IdSym0@ is another way of -- defining @sIdFun@ above. The @singletons-th@ library automatically -- generates 'SingI' instances for defunctionalization symbols such as -- @IdSym0@. -- -- Normal type-level arrows @(->)@ can be converted into defunctionalization -- arrows @('~>')@ by the use of the 'TyCon' family of types. (Refer to the -- Haddocks for 'TyCon1' to see an example of this in practice.) For this -- reason, we do not make an effort to define defunctionalization symbols for -- most type constructors of kind @a -> b@, as they can be used in -- defunctionalized settings by simply applying @TyCon{N}@ with an appropriate -- @N@. -- -- This includes the @(->)@ type constructor itself, which is of kind -- @'Type' -> 'Type' -> 'Type'@. One can turn it into something of kind -- @'Type' '~>' 'Type' '~>' 'Type'@ by writing @'TyCon2' (->)@, or something of -- kind @'Type' -> 'Type' '~>' 'Type'@ by writing @'TyCon1' ((->) t)@ -- (where @t :: 'Type'@). #if __GLASGOW_HASKELL__ >= 810 type (~>) :: Type -> Type -> Type #endif type a ~> b = TyFun a b -> Type infixr 0 ~> -- | Type level function application #if __GLASGOW_HASKELL__ >= 810 type Apply :: (k1 ~> k2) -> k1 -> k2 #endif type family Apply (f :: k1 ~> k2) (x :: k1) :: k2 -- | An infix synonym for `Apply` #if __GLASGOW_HASKELL__ >= 810 type (@@) :: (k1 ~> k2) -> k1 -> k2 #endif type a @@ b = Apply a b infixl 9 @@ #if __GLASGOW_HASKELL__ >= 806 -- | Workhorse for the 'TyCon1', etc., types. This can be used directly -- in place of any of the @TyConN@ types, but it will work only with -- /monomorphic/ types. When GHC#14645 is fixed, this should fully supersede -- the @TyConN@ types. -- -- Note that this is only defined on GHC 8.6 or later. Prior to GHC 8.6, -- 'TyCon1' /et al./ were defined as separate data types. #if __GLASGOW_HASKELL__ >= 810 type TyCon :: (k1 -> k2) -> unmatchable_fun #endif data family TyCon :: (k1 -> k2) -> unmatchable_fun -- That unmatchable_fun should really be a function of k1 and k2, -- but GHC 8.4 doesn't support type family calls in the result kind -- of a data family. It should. See GHC#14645. -- The result kind of this is also a bit wrong; it should line -- up with unmatchable_fun above. However, we can't do that -- because GHC is too stupid to remember that f's kind can't -- have more than one argument when kind-checking the RHS of -- the second equation. Note that this infelicity is independent -- of the problem in the kind of TyCon. There is no GHC ticket -- here because dealing with inequality like this is hard, and -- I (Richard) wasn't sure what concrete value the ticket would -- have, given that we don't know how to begin fixing it. -- | An \"internal\" definition used primary in the 'Apply' instance for -- 'TyCon'. -- -- Note that this only defined on GHC 8.6 or later. #if __GLASGOW_HASKELL__ >= 810 type ApplyTyCon :: (k1 -> k2) -> (k1 ~> unmatchable_fun) #endif #if __GLASGOW_HASKELL__ >= 910 type family ApplyTyCon @k1 @k2 @unmatchable_fun :: (k1 -> k2) -> (k1 ~> unmatchable_fun) where #else type family ApplyTyCon :: (k1 -> k2) -> (k1 ~> unmatchable_fun) where #endif #if __GLASGOW_HASKELL__ >= 808 ApplyTyCon @k1 @(k2 -> k3) @unmatchable_fun = ApplyTyConAux2 ApplyTyCon @k1 @k2 @k2 = ApplyTyConAux1 #else ApplyTyCon = (ApplyTyConAux2 :: (k1 -> k2 -> k3) -> (k1 ~> unmatchable_fun)) ApplyTyCon = (ApplyTyConAux1 :: (k1 -> k2) -> (k1 ~> k2)) #endif -- Upon first glance, the definition of ApplyTyCon (as well as the -- corresponding Apply instance for TyCon) seems a little indirect. One might -- wonder why these aren't defined like so: -- -- type family ApplyTyCon (f :: k1 -> k2) (x :: k1) :: k3 where -- ApplyTyCon (f :: k1 -> k2 -> k3) x = TyCon (f x) -- ApplyTyCon f x = f x -- -- type instance Apply (TyCon f) x = ApplyTyCon f x -- -- This also works, but it requires that ApplyTyCon always be applied to a -- minimum of two arguments. In particular, this rules out a trick that we use -- elsewhere in the library to write SingI instances for different TyCons, -- which relies on partial applications of ApplyTyCon: -- -- instance forall k1 k2 (f :: k1 -> k2). -- ( forall a. SingI a => SingI (f a) -- , (ApplyTyCon :: (k1 -> k2) -> (k1 ~> k2)) ~ ApplyTyConAux1 -- ) => SingI (TyCon1 f) where type instance Apply (TyCon f) x = ApplyTyCon f @@ x -- | An \"internal\" defunctionalization symbol used primarily in the -- definition of 'ApplyTyCon', as well as the 'SingI' instances for 'TyCon1', -- 'TyCon2', etc. -- -- Note that this is only defined on GHC 8.6 or later. #if __GLASGOW_HASKELL__ >= 810 type ApplyTyConAux1 :: (k1 -> k2) -> (k1 ~> k2) #endif data ApplyTyConAux1 :: (k1 -> k2) -> (k1 ~> k2) -- | An \"internal\" defunctionalization symbol used primarily in the -- definition of 'ApplyTyCon'. -- -- Note that this is only defined on GHC 8.6 or later. #if __GLASGOW_HASKELL__ >= 810 type ApplyTyConAux2 :: (k1 -> k2 -> k3) -> (k1 ~> unmatchable_fun) #endif data ApplyTyConAux2 :: (k1 -> k2 -> k3) -> (k1 ~> unmatchable_fun) type instance Apply (ApplyTyConAux1 f) x = f x type instance Apply (ApplyTyConAux2 f) x = TyCon (f x) #if __GLASGOW_HASKELL__ >= 810 type TyCon1 :: (k1 -> k2) -> (k1 ~> k2) type TyCon2 :: (k1 -> k2 -> k3) -> (k1 ~> k2 ~> k3) type TyCon3 :: (k1 -> k2 -> k3 -> k4) -> (k1 ~> k2 ~> k3 ~> k4) type TyCon4 :: (k1 -> k2 -> k3 -> k4 -> k5) -> (k1 ~> k2 ~> k3 ~> k4 ~> k5) type TyCon5 :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6) -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6) type TyCon6 :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7) -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7) type TyCon7 :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7 -> k8) -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7 ~> k8) type TyCon8 :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7 -> k8 -> k9) -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7 ~> k8 ~> k9) #endif -- | Wrapper for converting the normal type-level arrow into a '~>'. -- For example, given: -- -- > data Nat = Zero | Succ Nat -- > type family Map (a :: a ~> b) (a :: [a]) :: [b] -- > Map f '[] = '[] -- > Map f (x ': xs) = Apply f x ': Map f xs -- -- We can write: -- -- > Map (TyCon1 Succ) [Zero, Succ Zero] #if __GLASGOW_HASKELL__ >= 910 type TyCon1 @k1 @k2 = (TyCon :: (k1 -> k2) -> (k1 ~> k2)) -- | Similar to 'TyCon1', but for two-parameter type constructors. type TyCon2 @k1 @k2 @k3 = (TyCon :: (k1 -> k2 -> k3) -> (k1 ~> k2 ~> k3)) type TyCon3 @k1 @k2 @k3 @k4 = (TyCon :: (k1 -> k2 -> k3 -> k4) -> (k1 ~> k2 ~> k3 ~> k4)) type TyCon4 @k1 @k2 @k3 @k4 @k5 = (TyCon :: (k1 -> k2 -> k3 -> k4 -> k5) -> (k1 ~> k2 ~> k3 ~> k4 ~> k5)) type TyCon5 @k1 @k2 @k3 @k4 @k5 @k6 = (TyCon :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6) -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6)) type TyCon6 @k1 @k2 @k3 @k4 @k5 @k6 @k7 = (TyCon :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7) -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7)) type TyCon7 @k1 @k2 @k3 @k4 @k5 @k6 @k7 @k8 = (TyCon :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7 -> k8) -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7 ~> k8)) type TyCon8 @k1 @k2 @k3 @k4 @k5 @k6 @k7 @k8 @k9 = (TyCon :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7 -> k8 -> k9) -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7 ~> k8 ~> k9)) #else type TyCon1 = (TyCon :: (k1 -> k2) -> (k1 ~> k2)) -- | Similar to 'TyCon1', but for two-parameter type constructors. type TyCon2 = (TyCon :: (k1 -> k2 -> k3) -> (k1 ~> k2 ~> k3)) type TyCon3 = (TyCon :: (k1 -> k2 -> k3 -> k4) -> (k1 ~> k2 ~> k3 ~> k4)) type TyCon4 = (TyCon :: (k1 -> k2 -> k3 -> k4 -> k5) -> (k1 ~> k2 ~> k3 ~> k4 ~> k5)) type TyCon5 = (TyCon :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6) -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6)) type TyCon6 = (TyCon :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7) -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7)) type TyCon7 = (TyCon :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7 -> k8) -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7 ~> k8)) type TyCon8 = (TyCon :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7 -> k8 -> k9) -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7 ~> k8 ~> k9)) #endif #else -- | Wrapper for converting the normal type-level arrow into a '~>'. -- For example, given: -- -- > data Nat = Zero | Succ Nat -- > type family Map (a :: a ~> b) (a :: [a]) :: [b] -- > Map f '[] = '[] -- > Map f (x ': xs) = Apply f x ': Map f xs -- -- We can write: -- -- > Map (TyCon1 Succ) [Zero, Succ Zero] data TyCon1 :: (k1 -> k2) -> (k1 ~> k2) -- | Similar to 'TyCon1', but for two-parameter type constructors. data TyCon2 :: (k1 -> k2 -> k3) -> (k1 ~> k2 ~> k3) data TyCon3 :: (k1 -> k2 -> k3 -> k4) -> (k1 ~> k2 ~> k3 ~> k4) data TyCon4 :: (k1 -> k2 -> k3 -> k4 -> k5) -> (k1 ~> k2 ~> k3 ~> k4 ~> k5) data TyCon5 :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6) -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6) data TyCon6 :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7) -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7) data TyCon7 :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7 -> k8) -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7 ~> k8) data TyCon8 :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7 -> k8 -> k9) -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7 ~> k8 ~> k9) type instance Apply (TyCon1 f) x = f x type instance Apply (TyCon2 f) x = TyCon1 (f x) type instance Apply (TyCon3 f) x = TyCon2 (f x) type instance Apply (TyCon4 f) x = TyCon3 (f x) type instance Apply (TyCon5 f) x = TyCon4 (f x) type instance Apply (TyCon6 f) x = TyCon5 (f x) type instance Apply (TyCon7 f) x = TyCon6 (f x) type instance Apply (TyCon8 f) x = TyCon7 (f x) #endif ---------------------------------------------------------------------- ---- Defunctionalized Sing instance and utilities -------------------- ---------------------------------------------------------------------- -- | The singleton type for functions. Functions have somewhat special -- treatment in @singletons@ (see the Haddocks for @('~>')@ for more information -- about this), and as a result, the 'Sing' instance for 'SLambda' is one of the -- only such instances defined in the @singletons@ library rather than, say, -- @singletons-base@. #if __GLASGOW_HASKELL__ >= 810 type SLambda :: (k1 ~> k2) -> Type #endif newtype SLambda (f :: k1 ~> k2) = SLambda { applySing :: forall t. Sing t -> Sing (f @@ t) } type instance Sing = SLambda -- | An infix synonym for `applySing` (@@) :: forall k1 k2 (f :: k1 ~> k2) (t :: k1). Sing f -> Sing t -> Sing (f @@ t) (@@) f = applySing f -- | Note that this instance's 'toSing' implementation crucially relies on the fact -- that the 'SingKind' instances for 'k1' and 'k2' both satisfy the 'SingKind' laws. -- If they don't, 'toSing' might produce strange results! instance (SingKind k1, SingKind k2) => SingKind (k1 ~> k2) where type Demote (k1 ~> k2) = Demote k1 -> Demote k2 fromSing sFun x = withSomeSing x (fromSing . applySing sFun) toSing f = SomeSing slam where -- Here, we are essentially "manufacturing" a type-level version of the -- function f. As long as k1 and k2 obey the SingKind laws, this is a -- perfectly fine thing to do, since the computational content of Sing f -- will be isomorphic to that of the function f. slam :: forall (f :: k1 ~> k2). Sing f slam = singFun1 @f lam where -- Here's the tricky part. We need to demote the argument Sing, apply the -- term-level function f to it, and promote it back to a Sing. However, -- we don't have a way to convince the typechecker that for all argument -- types t, f @@ t should be the same thing as res, which motivates the -- use of unsafeCoerce. lam :: forall (t :: k1). Sing t -> Sing (f @@ t) lam x = withSomeSing (f (fromSing x)) (\(r :: Sing res) -> unsafeCoerce r) #if __GLASGOW_HASKELL__ >= 810 type SingFunction1 :: (a1 ~> b) -> Type type SingFunction2 :: (a1 ~> a2 ~> b) -> Type type SingFunction3 :: (a1 ~> a2 ~> a3 ~> b) -> Type type SingFunction4 :: (a1 ~> a2 ~> a3 ~> a4 ~> b) -> Type type SingFunction5 :: (a1 ~> a2 ~> a3 ~> a4 ~> a5 ~> b) -> Type type SingFunction6 :: (a1 ~> a2 ~> a3 ~> a4 ~> a5 ~> a6 ~> b) -> Type type SingFunction7 :: (a1 ~> a2 ~> a3 ~> a4 ~> a5 ~> a6 ~> a7 ~> b) -> Type type SingFunction8 :: (a1 ~> a2 ~> a3 ~> a4 ~> a5 ~> a6 ~> a7 ~> a8 ~> b) -> Type #endif type SingFunction1 (f :: a1 ~> b) = forall t. Sing t -> Sing (f @@ t) -- | Use this function when passing a function on singletons as -- a higher-order function. You will need visible type application -- to get this to work. For example: -- -- > falses = sMap (singFun1 @NotSym0 sNot) -- > (STrue `SCons` STrue `SCons` SNil) -- -- There are a family of @singFun...@ functions, keyed by the number -- of parameters of the function. singFun1 :: forall f. SingFunction1 f -> Sing f singFun1 f = SLambda f type SingFunction2 (f :: a1 ~> a2 ~> b) = forall t1 t2. Sing t1 -> Sing t2 -> Sing (f @@ t1 @@ t2) singFun2 :: forall f. SingFunction2 f -> Sing f singFun2 f = SLambda (\x -> singFun1 (f x)) type SingFunction3 (f :: a1 ~> a2 ~> a3 ~> b) = forall t1 t2 t3. Sing t1 -> Sing t2 -> Sing t3 -> Sing (f @@ t1 @@ t2 @@ t3) singFun3 :: forall f. SingFunction3 f -> Sing f singFun3 f = SLambda (\x -> singFun2 (f x)) type SingFunction4 (f :: a1 ~> a2 ~> a3 ~> a4 ~> b) = forall t1 t2 t3 t4. Sing t1 -> Sing t2 -> Sing t3 -> Sing t4 -> Sing (f @@ t1 @@ t2 @@ t3 @@ t4) singFun4 :: forall f. SingFunction4 f -> Sing f singFun4 f = SLambda (\x -> singFun3 (f x)) type SingFunction5 (f :: a1 ~> a2 ~> a3 ~> a4 ~> a5 ~> b) = forall t1 t2 t3 t4 t5. Sing t1 -> Sing t2 -> Sing t3 -> Sing t4 -> Sing t5 -> Sing (f @@ t1 @@ t2 @@ t3 @@ t4 @@ t5) singFun5 :: forall f. SingFunction5 f -> Sing f singFun5 f = SLambda (\x -> singFun4 (f x)) type SingFunction6 (f :: a1 ~> a2 ~> a3 ~> a4 ~> a5 ~> a6 ~> b) = forall t1 t2 t3 t4 t5 t6. Sing t1 -> Sing t2 -> Sing t3 -> Sing t4 -> Sing t5 -> Sing t6 -> Sing (f @@ t1 @@ t2 @@ t3 @@ t4 @@ t5 @@ t6) singFun6 :: forall f. SingFunction6 f -> Sing f singFun6 f = SLambda (\x -> singFun5 (f x)) type SingFunction7 (f :: a1 ~> a2 ~> a3 ~> a4 ~> a5 ~> a6 ~> a7 ~> b) = forall t1 t2 t3 t4 t5 t6 t7. Sing t1 -> Sing t2 -> Sing t3 -> Sing t4 -> Sing t5 -> Sing t6 -> Sing t7 -> Sing (f @@ t1 @@ t2 @@ t3 @@ t4 @@ t5 @@ t6 @@ t7) singFun7 :: forall f. SingFunction7 f -> Sing f singFun7 f = SLambda (\x -> singFun6 (f x)) type SingFunction8 (f :: a1 ~> a2 ~> a3 ~> a4 ~> a5 ~> a6 ~> a7 ~> a8 ~> b) = forall t1 t2 t3 t4 t5 t6 t7 t8. Sing t1 -> Sing t2 -> Sing t3 -> Sing t4 -> Sing t5 -> Sing t6 -> Sing t7 -> Sing t8 -> Sing (f @@ t1 @@ t2 @@ t3 @@ t4 @@ t5 @@ t6 @@ t7 @@ t8) singFun8 :: forall f. SingFunction8 f -> Sing f singFun8 f = SLambda (\x -> singFun7 (f x)) -- | This is the inverse of 'singFun1', and likewise for the other -- @unSingFun...@ functions. unSingFun1 :: forall f. Sing f -> SingFunction1 f unSingFun1 sf = applySing sf unSingFun2 :: forall f. Sing f -> SingFunction2 f unSingFun2 sf x = unSingFun1 (sf @@ x) unSingFun3 :: forall f. Sing f -> SingFunction3 f unSingFun3 sf x = unSingFun2 (sf @@ x) unSingFun4 :: forall f. Sing f -> SingFunction4 f unSingFun4 sf x = unSingFun3 (sf @@ x) unSingFun5 :: forall f. Sing f -> SingFunction5 f unSingFun5 sf x = unSingFun4 (sf @@ x) unSingFun6 :: forall f. Sing f -> SingFunction6 f unSingFun6 sf x = unSingFun5 (sf @@ x) unSingFun7 :: forall f. Sing f -> SingFunction7 f unSingFun7 sf x = unSingFun6 (sf @@ x) unSingFun8 :: forall f. Sing f -> SingFunction8 f unSingFun8 sf x = unSingFun7 (sf @@ x) #if __GLASGOW_HASKELL__ >= 802 {-# COMPLETE SLambda2 #-} {-# COMPLETE SLambda3 #-} {-# COMPLETE SLambda4 #-} {-# COMPLETE SLambda5 #-} {-# COMPLETE SLambda6 #-} {-# COMPLETE SLambda7 #-} {-# COMPLETE SLambda8 #-} #endif pattern SLambda2 :: forall f. SingFunction2 f -> Sing f pattern SLambda2 {applySing2} <- (unSingFun2 -> applySing2) where SLambda2 lam2 = singFun2 lam2 pattern SLambda3 :: forall f. SingFunction3 f -> Sing f pattern SLambda3 {applySing3} <- (unSingFun3 -> applySing3) where SLambda3 lam3 = singFun3 lam3 pattern SLambda4 :: forall f. SingFunction4 f -> Sing f pattern SLambda4 {applySing4} <- (unSingFun4 -> applySing4) where SLambda4 lam4 = singFun4 lam4 pattern SLambda5 :: forall f. SingFunction5 f -> Sing f pattern SLambda5 {applySing5} <- (unSingFun5 -> applySing5) where SLambda5 lam5 = singFun5 lam5 pattern SLambda6 :: forall f. SingFunction6 f -> Sing f pattern SLambda6 {applySing6} <- (unSingFun6 -> applySing6) where SLambda6 lam6 = singFun6 lam6 pattern SLambda7 :: forall f. SingFunction7 f -> Sing f pattern SLambda7 {applySing7} <- (unSingFun7 -> applySing7) where SLambda7 lam7 = singFun7 lam7 pattern SLambda8 :: forall f. SingFunction8 f -> Sing f pattern SLambda8 {applySing8} <- (unSingFun8 -> applySing8) where SLambda8 lam8 = singFun8 lam8 ---------------------------------------------------------------------- ---- Convenience ----------------------------------------------------- ---------------------------------------------------------------------- -- | Convenience function for creating a context with an implicit singleton -- available. withSingI :: Sing n -> (SingI n => r) -> r withSingI sn r = case singInstance sn of SingInstance -> r -- | Convert a normal datatype (like 'Bool') to a singleton for that datatype, -- passing it into a continuation. withSomeSing :: forall k r . SingKind k => Demote k -- ^ The original datatype -> (forall (a :: k). Sing a -> r) -- ^ Function expecting a singleton -> r withSomeSing x f = case toSing x of SomeSing x' -> f x' -- | Convert a group of 'SingI1' and 'SingI' constraints (representing a -- function to apply and its argument, respectively) into a single 'SingI' -- constraint representing the application. You will likely need the -- @ScopedTypeVariables@ extension to use this method the way you want. usingSingI1 :: forall f x r. (SingI1 f, SingI x) => (SingI (f x) => r) -> r usingSingI1 k = withSingI (sing1 @f @x) k -- | Convert a group of 'SingI2' and 'SingI' constraints (representing a -- function to apply and its arguments, respectively) into a single 'SingI' -- constraint representing the application. You will likely need the -- @ScopedTypeVariables@ extension to use this method the way you want. usingSingI2 :: forall f x y r. (SingI2 f, SingI x, SingI y) => (SingI (f x y) => r) -> r usingSingI2 k = withSingI (sing2 @f @x @y) k -- | A convenience function useful when we need to name a singleton value -- multiple times. Without this function, each use of 'sing' could potentially -- refer to a different singleton, and one has to use type signatures (often -- with @ScopedTypeVariables@) to ensure that they are the same. withSing :: SingI a => (Sing a -> b) -> b withSing f = f sing -- | A convenience function useful when we need to name a singleton value for a -- unary type constructor multiple times. Without this function, each use of -- 'sing1' could potentially refer to a different singleton, and one has to use -- type signatures (often with @ScopedTypeVariables@) to ensure that they are -- the same. withSing1 :: (SingI1 f, SingI x) => (Sing (f x) -> b) -> b withSing1 f = f sing1 -- | A convenience function useful when we need to name a singleton value for a -- binary type constructor multiple times. Without this function, each use of -- 'sing1' could potentially refer to a different singleton, and one has to use -- type signatures (often with @ScopedTypeVariables@) to ensure that they are -- the same. withSing2 :: (SingI2 f, SingI x, SingI y) => (Sing (f x y) -> b) -> b withSing2 f = f sing2 -- | A convenience function that names a singleton satisfying a certain -- property. If the singleton does not satisfy the property, then the function -- returns 'Nothing'. The property is expressed in terms of the underlying -- representation of the singleton. singThat :: forall k (a :: k). (SingKind k, SingI a) => (Demote k -> Bool) -> Maybe (Sing a) singThat p = withSing $ \x -> if p (fromSing x) then Just x else Nothing -- | A convenience function that names a singleton for a unary type constructor -- satisfying a certain property. If the singleton does not satisfy the -- property, then the function returns 'Nothing'. The property is expressed in -- terms of the underlying representation of the singleton. singThat1 :: forall k1 k2 (f :: k1 -> k2) (x :: k1). (SingKind k2, SingI1 f, SingI x) => (Demote k2 -> Bool) -> Maybe (Sing (f x)) singThat1 p = withSing1 $ \x -> if p (fromSing x) then Just x else Nothing -- | A convenience function that names a singleton for a binary type constructor -- satisfying a certain property. If the singleton does not satisfy the -- property, then the function returns 'Nothing'. The property is expressed in -- terms of the underlying representation of the singleton. singThat2 :: forall k1 k2 k3 (f :: k1 -> k2 -> k3) (x :: k1) (y :: k2). (SingKind k3, SingI2 f, SingI x, SingI y) => (Demote k3 -> Bool) -> Maybe (Sing (f x y)) singThat2 p = withSing2 $ \x -> if p (fromSing x) then Just x else Nothing -- | Allows creation of a singleton when a proxy is at hand. singByProxy :: SingI a => proxy a -> Sing a singByProxy _ = sing -- | Allows creation of a singleton for a unary type constructor when a proxy -- is at hand. singByProxy1 :: (SingI1 f, SingI x) => proxy (f x) -> Sing (f x) singByProxy1 _ = sing1 -- | Allows creation of a singleton for a binary type constructor when a proxy -- is at hand. singByProxy2 :: (SingI2 f, SingI x, SingI y) => proxy (f x y) -> Sing (f x y) singByProxy2 _ = sing2 -- | Allows creation of a singleton when a @proxy#@ is at hand. singByProxy# :: SingI a => Proxy# a -> Sing a singByProxy# _ = sing -- | Allows creation of a singleton for a unary type constructor when a -- @proxy#@ is at hand. singByProxy1# :: (SingI1 f, SingI x) => Proxy# (f x) -> Sing (f x) singByProxy1# _ = sing1 -- | Allows creation of a singleton for a binary type constructor when a -- @proxy#@ is at hand. singByProxy2# :: (SingI2 f, SingI x, SingI y) => Proxy# (f x y) -> Sing (f x y) singByProxy2# _ = sing2 -- | A convenience function that takes a type as input and demotes it to its -- value-level counterpart as output. This uses 'SingKind' and 'SingI' behind -- the scenes, so @'demote' = 'fromSing' 'sing'@. -- -- This function is intended to be used with @TypeApplications@. For example: -- -- >>> demote @True -- True -- -- >>> demote @(Nothing :: Maybe Ordering) -- Nothing -- -- >>> demote @(Just EQ) -- Just EQ -- -- >>> demote @'(True,EQ) -- (True,EQ) demote :: #if __GLASGOW_HASKELL__ >= 900 forall {k} (a :: k). (SingKind k, SingI a) => Demote k #else forall a. (SingKind (KindOf a), SingI a) => Demote (KindOf a) #endif demote = fromSing (sing @a) -- | A convenience function that takes a unary type constructor and its -- argument as input, applies them, and demotes the result to its -- value-level counterpart as output. This uses 'SingKind', 'SingI1', and -- 'SingI' behind the scenes, so @'demote1' = 'fromSing' 'sing1'@. -- -- This function is intended to be used with @TypeApplications@. For example: -- -- >>> demote1 @Just @EQ -- Just EQ -- -- >>> demote1 @('(,) True) @EQ -- (True,EQ) demote1 :: #if __GLASGOW_HASKELL__ >= 900 forall {k1} {k2} (f :: k1 -> k2) (x :: k1). (SingKind k2, SingI1 f, SingI x) => Demote k2 #else forall f x. (SingKind (KindOf (f x)), SingI1 f, SingI x) => Demote (KindOf (f x)) #endif demote1 = fromSing (sing1 @f @x) -- | A convenience function that takes a binary type constructor and its -- arguments as input, applies them, and demotes the result to its -- value-level counterpart as output. This uses 'SingKind', 'SingI2', and -- 'SingI' behind the scenes, so @'demote2' = 'fromSing' 'sing2'@. -- -- This function is intended to be used with @TypeApplications@. For example: -- -- >>> demote2 @'(,) @True @EQ -- (True,EQ) demote2 :: #if __GLASGOW_HASKELL__ >= 900 forall {k1} {k2} {k3} (f :: k1 -> k2 -> k3) (x :: k1) (y :: k2). (SingKind k3, SingI2 f, SingI x, SingI y) => Demote k3 #else forall f x y. (SingKind (KindOf (f x y)), SingI2 f, SingI x, SingI y) => Demote (KindOf (f x y)) #endif demote2 = fromSing (sing2 @f @x @y) ---------------------------------------------------------------------- ---- SingI TyCon{N} instances ---------------------------------------- ---------------------------------------------------------------------- #if __GLASGOW_HASKELL__ >= 806 instance forall k1 kr (f :: k1 -> kr). ( forall a. SingI a => SingI (f a) , (ApplyTyCon :: (k1 -> kr) -> (k1 ~> kr)) ~ ApplyTyConAux1 ) => SingI (TyCon1 f) where sing = singFun1 (`withSingI` sing) instance forall k1 k2 kr (f :: k1 -> k2 -> kr). ( forall a b. (SingI a, SingI b) => SingI (f a b) , (ApplyTyCon :: (k2 -> kr) -> (k2 ~> kr)) ~ ApplyTyConAux1 ) => SingI (TyCon2 f) where sing = singFun1 (`withSingI` sing) instance forall k1 k2 k3 kr (f :: k1 -> k2 -> k3 -> kr). ( forall a b c. (SingI a, SingI b, SingI c) => SingI (f a b c) , (ApplyTyCon :: (k3 -> kr) -> (k3 ~> kr)) ~ ApplyTyConAux1 ) => SingI (TyCon3 f) where sing = singFun1 (`withSingI` sing) instance forall k1 k2 k3 k4 kr (f :: k1 -> k2 -> k3 -> k4 -> kr). ( forall a b c d. (SingI a, SingI b, SingI c, SingI d) => SingI (f a b c d) , (ApplyTyCon :: (k4 -> kr) -> (k4 ~> kr)) ~ ApplyTyConAux1 ) => SingI (TyCon4 f) where sing = singFun1 (`withSingI` sing) instance forall k1 k2 k3 k4 k5 kr (f :: k1 -> k2 -> k3 -> k4 -> k5 -> kr). ( forall a b c d e. (SingI a, SingI b, SingI c, SingI d, SingI e) => SingI (f a b c d e) , (ApplyTyCon :: (k5 -> kr) -> (k5 ~> kr)) ~ ApplyTyConAux1 ) => SingI (TyCon5 f) where sing = singFun1 (`withSingI` sing) instance forall k1 k2 k3 k4 k5 k6 kr (f :: k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> kr). ( forall a b c d e f'. (SingI a, SingI b, SingI c, SingI d, SingI e, SingI f') => SingI (f a b c d e f') , (ApplyTyCon :: (k6 -> kr) -> (k6 ~> kr)) ~ ApplyTyConAux1 ) => SingI (TyCon6 f) where sing = singFun1 (`withSingI` sing) instance forall k1 k2 k3 k4 k5 k6 k7 kr (f :: k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7 -> kr). ( forall a b c d e f' g. (SingI a, SingI b, SingI c, SingI d, SingI e, SingI f', SingI g) => SingI (f a b c d e f' g) , (ApplyTyCon :: (k7 -> kr) -> (k7 ~> kr)) ~ ApplyTyConAux1 ) => SingI (TyCon7 f) where sing = singFun1 (`withSingI` sing) instance forall k1 k2 k3 k4 k5 k6 k7 k8 kr (f :: k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7 -> k8 -> kr). ( forall a b c d e f' g h. (SingI a, SingI b, SingI c, SingI d, SingI e, SingI f', SingI g, SingI h) => SingI (f a b c d e f' g h) , (ApplyTyCon :: (k8 -> kr) -> (k8 ~> kr)) ~ ApplyTyConAux1 ) => SingI (TyCon8 f) where sing = singFun1 (`withSingI` sing) #endif ---------------------------------------------------------------------- ---- Defunctionalization symbols ------------------------------------- ---------------------------------------------------------------------- -- $(genDefunSymbols [''Demote, ''SameKind, ''KindOf, ''(~>), ''Apply, ''(@@)]) -- WrapSing, UnwrapSing, and SingFunction1 et al. are not defunctionalizable -- at the moment due to GHC#9269 #if __GLASGOW_HASKELL__ >= 810 type DemoteSym0 :: Type ~> Type type DemoteSym1 :: Type -> Type #endif data DemoteSym0 :: Type ~> Type type DemoteSym1 x = Demote x type instance Apply DemoteSym0 x = Demote x ----- #if __GLASGOW_HASKELL__ >= 810 type SameKindSym0 :: forall k. k ~> k ~> Constraint type SameKindSym1 :: forall k. k -> k ~> Constraint type SameKindSym2 :: forall k. k -> k -> Constraint #endif data SameKindSym0 :: forall k. k ~> k ~> Constraint data SameKindSym1 :: forall k. k -> k ~> Constraint type SameKindSym2 (x :: k) (y :: k) = SameKind x y type instance Apply SameKindSym0 x = SameKindSym1 x type instance Apply (SameKindSym1 x) y = SameKind x y ----- #if __GLASGOW_HASKELL__ >= 810 type KindOfSym0 :: forall k. k ~> Type type KindOfSym1 :: forall k. k -> Type #endif data KindOfSym0 :: forall k. k ~> Type type KindOfSym1 (x :: k) = KindOf x type instance Apply KindOfSym0 x = KindOf x ----- infixr 0 ~>@#@$, ~>@#@$$, ~>@#@$$$ #if __GLASGOW_HASKELL__ >= 810 type (~>@#@$) :: Type ~> Type ~> Type type (~>@#@$$) :: Type -> Type ~> Type type (~>@#@$$$) :: Type -> Type -> Type #endif data (~>@#@$) :: Type ~> Type ~> Type data (~>@#@$$) :: Type -> Type ~> Type type x ~>@#@$$$ y = x ~> y type instance Apply (~>@#@$) x = (~>@#@$$) x type instance Apply ((~>@#@$$) x) y = x ~> y ----- #if __GLASGOW_HASKELL__ >= 810 type ApplySym0 :: forall a b. (a ~> b) ~> a ~> b type ApplySym1 :: forall a b. (a ~> b) -> a ~> b type ApplySym2 :: forall a b. (a ~> b) -> a -> b #endif data ApplySym0 :: forall a b. (a ~> b) ~> a ~> b data ApplySym1 :: forall a b. (a ~> b) -> a ~> b type ApplySym2 (f :: a ~> b) (x :: a) = Apply f x type instance Apply ApplySym0 f = ApplySym1 f type instance Apply (ApplySym1 f) x = Apply f x ----- infixl 9 @@@#@$, @@@#@$$, @@@#@$$$ #if __GLASGOW_HASKELL__ >= 810 type (@@@#@$) :: forall a b. (a ~> b) ~> a ~> b type (@@@#@$$) :: forall a b. (a ~> b) -> a ~> b type (@@@#@$$$) :: forall a b. (a ~> b) -> a -> b #endif data (@@@#@$) :: forall a b. (a ~> b) ~> a ~> b data (@@@#@$$) :: forall a b. (a ~> b) -> a ~> b type (f :: a ~> b) @@@#@$$$ (x :: a) = f @@ x type instance Apply (@@@#@$) f = (@@@#@$$) f type instance Apply ((@@@#@$$) f) x = f @@ x {- $SingletonsOfSingletons Aside from being a data type to hang instances off of, 'WrappedSing' has another purpose as a general-purpose mechanism for allowing one to write code that uses singletons of other singletons. For instance, suppose you had the following data type: @ data T :: Type -> Type where MkT :: forall a (x :: a). 'Sing' x -> F a -> T a @ A naïve attempt at defining a singleton for @T@ would look something like this: @ data ST :: forall a. T a -> Type where SMkT :: forall a (x :: a) (sx :: 'Sing' x) (f :: F a). 'Sing' sx -> 'Sing' f -> ST (MkT sx f) @ But there is a problem here: what exactly /is/ @'Sing' sx@? If @x@ were 'True', for instance, then @sx@ would be 'STrue', but it's not clear what @'Sing' 'STrue'@ should be. One could define @SSBool@ to be the singleton of 'SBool's, but in order to be thorough, one would have to generate a singleton for /every/ singleton type out there. Plus, it's not clear when to stop. Should we also generate @SSSBool@, @SSSSBool@, etc.? Instead, 'WrappedSing' and its singleton 'SWrappedSing' provide a way to talk about singletons of other arbitrary singletons without the need to generate a bazillion instances. For reference, here is the definition of 'SWrappedSing': @ newtype 'SWrappedSing' :: forall k (a :: k). 'WrappedSing' a -> Type where 'SWrapSing' :: forall k (a :: k) (ws :: 'WrappedSing' a). { 'sUnwrapSing' :: 'Sing' a } -> 'SWrappedSing' ws type instance 'Sing' \@('WrappedSing' a) = 'SWrappedSing' @ 'SWrappedSing' is a bit of an unusual singleton in that its field is a singleton for @'Sing' \@k@, not @'WrappedSing' \@k@. But that's exactly the point—a singleton of a singleton contains as much type information as the underlying singleton itself, so we can get away with just @'Sing' \@k@. As an example of this in action, here is how you would define the singleton for the earlier @T@ type: @ data ST :: forall a. T a -> Type where SMkT :: forall a (x :: a) (sx :: 'Sing' x) (f :: F a). 'Sing' ('WrapSing' sx) -> 'Sing' f -> ST (MkT sx f) @ With this technique, we won't need anything like @SSBool@ in order to instantiate @x@ with 'True'. Instead, the field of type @'Sing' ('WrapSing' sx)@ will simply be a newtype around 'SBool'. In general, you'll need /n/ layers of 'WrapSing' if you wish to single a singleton /n/ times. Note that this is not the only possible way to define a singleton for @T@. An alternative approach that does not make use of singletons-of-singletons is discussed at some length . Due to the technical limitations of this approach, however, we do not use it in @singletons@ at the moment, instead favoring the slightly-clunkier-but-more-reliable 'WrappedSing' approach. -} {- $SLambdaPatternSynonyms @SLambda{2...8}@ are explicitly bidirectional pattern synonyms for defunctionalized singletons (@'Sing' (f :: k '~>' k' '~>' k'')@). As __constructors__: Same as @singFun{2..8}@. For example, one can turn a binary function on singletons @sTake :: 'SingFunction2' TakeSym0@ into a defunctionalized singleton @'Sing' (TakeSym :: Nat '~>' [a] '~>' [a])@: @ >>> import Data.List.Singletons >>> :set -XTypeApplications >>> >>> :t 'SLambda2' 'SLambda2' :: 'SingFunction2' f -> 'Sing' f >>> :t 'SLambda2' \@TakeSym0 'SLambda2' :: 'SingFunction2' TakeSym0 -> 'Sing' TakeSym0 >>> :t 'SLambda2' \@TakeSym0 sTake 'SLambda2' :: 'Sing' TakeSym0 @ This is useful for functions on singletons that expect a defunctionalized singleton as an argument, such as @sZipWith :: 'SingFunction3' ZipWithSym0@: @ sZipWith :: Sing (f :: a '~>' b '~>' c) -> Sing (xs :: [a]) -> Sing (ys :: [b]) -> Sing (ZipWith f xs ys :: [c]) sZipWith ('SLambda2' \@TakeSym0 sTake) :: Sing (xs :: [Nat]) -> Sing (ys :: [[a]]) -> Sing (ZipWith TakeSym0 xs ys :: [[a]]) @ As __patterns__: Same as @unSingFun{2..8}@. Gets a binary term-level Haskell function on singletons @'Sing' (x :: k) -> 'Sing' (y :: k') -> 'Sing' (f \@\@ x \@\@ y)@ from a defunctionalised @'Sing' f@. Alternatively, as a record field accessor: @ applySing2 :: 'Sing' (f :: k '~>' k' '~>' k'') -> 'SingFunction2' f @ -} singletons-3.0.3/src/Data/Singletons/0000755000000000000000000000000007346545000015660 5ustar0000000000000000singletons-3.0.3/src/Data/Singletons/Decide.hs0000644000000000000000000000624207346545000017375 0ustar0000000000000000{-# LANGUAGE CPP, RankNTypes, PolyKinds, DataKinds, TypeOperators, TypeFamilies, FlexibleContexts, UndecidableInstances, GADTs, TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} #if __GLASGOW_HASKELL__ < 806 {-# LANGUAGE TypeInType #-} #endif #if __GLASGOW_HASKELL__ >= 810 {-# LANGUAGE StandaloneKindSignatures #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Singletons.Decide -- Copyright : (C) 2013 Richard Eisenberg -- License : BSD-style (see LICENSE) -- Maintainer : Ryan Scott -- Stability : experimental -- Portability : non-portable -- -- Defines the class 'SDecide', allowing for decidable equality over singletons. -- ---------------------------------------------------------------------------- module Data.Singletons.Decide ( -- * The SDecide class SDecide(..), -- * Supporting definitions (:~:)(..), Void, Refuted, Decision(..), decideEquality, decideCoercion ) where import Data.Kind import Data.Singletons import Data.Type.Coercion import Data.Type.Equality import Data.Void ---------------------------------------------------------------------- ---- SDecide --------------------------------------------------------- ---------------------------------------------------------------------- -- | Because we can never create a value of type 'Void', a function that type-checks -- at @a -> Void@ shows that objects of type @a@ can never exist. Thus, we say that -- @a@ is 'Refuted' #if __GLASGOW_HASKELL__ >= 810 type Refuted :: Type -> Type #endif type Refuted a = (a -> Void) -- | A 'Decision' about a type @a@ is either a proof of existence or a proof that @a@ -- cannot exist. #if __GLASGOW_HASKELL__ >= 810 type Decision :: Type -> Type #endif data Decision a = Proved a -- ^ Witness for @a@ | Disproved (Refuted a) -- ^ Proof that no @a@ exists -- | Members of the 'SDecide' "kind" class support decidable equality. Instances -- of this class are generated alongside singleton definitions for datatypes that -- derive an 'Eq' instance. #if __GLASGOW_HASKELL__ >= 810 type SDecide :: Type -> Constraint #endif class SDecide k where -- | Compute a proof or disproof of equality, given two singletons. (%~) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Decision (a :~: b) infix 4 %~ -- | A suitable default implementation for 'testEquality' that leverages -- 'SDecide'. decideEquality :: forall k (a :: k) (b :: k). SDecide k => Sing a -> Sing b -> Maybe (a :~: b) decideEquality a b = case a %~ b of Proved Refl -> Just Refl Disproved _ -> Nothing instance SDecide k => TestEquality (WrappedSing :: k -> Type) where testEquality (WrapSing s1) (WrapSing s2) = decideEquality s1 s2 -- | A suitable default implementation for 'testCoercion' that leverages -- 'SDecide'. decideCoercion :: forall k (a :: k) (b :: k). SDecide k => Sing a -> Sing b -> Maybe (Coercion a b) decideCoercion a b = case a %~ b of Proved Refl -> Just Coercion Disproved _ -> Nothing instance SDecide k => TestCoercion (WrappedSing :: k -> Type) where testCoercion (WrapSing s1) (WrapSing s2) = decideCoercion s1 s2 singletons-3.0.3/src/Data/Singletons/ShowSing.hs0000644000000000000000000003202207346545000017754 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 806 {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} #if __GLASGOW_HASKELL__ >= 810 {-# LANGUAGE StandaloneKindSignatures #-} #endif #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Singletons.ShowSing -- Copyright : (C) 2017 Ryan Scott -- License : BSD-style (see LICENSE) -- Maintainer : Ryan Scott -- Stability : experimental -- Portability : non-portable -- -- Defines the class 'ShowSing' which is useful for defining 'Show' instances -- for singleton types. Because 'ShowSing' crucially relies on -- @QuantifiedConstraints@, it is only defined if this library is built with -- GHC 8.6 or later. -- ---------------------------------------------------------------------------- module Data.Singletons.ShowSing ( #if __GLASGOW_HASKELL__ >= 806 -- * The 'ShowSing' type ShowSing, -- * Internal utilities ShowSing' #endif ) where #if __GLASGOW_HASKELL__ >= 806 import Data.Kind import Data.Singletons import Text.Show -- | In addition to the promoted and singled versions of the 'Show' class that -- @singletons-base@ provides, it is also useful to be able to directly define -- 'Show' instances for singleton types themselves. Doing so is almost entirely -- straightforward, as a derived 'Show' instance does 90 percent of the work. -- The last 10 percent—getting the right instance context—is a bit tricky, and -- that's where 'ShowSing' comes into play. -- -- As an example, let's consider the singleton type for lists. We want to write -- an instance with the following shape: -- -- @ -- instance ??? => 'Show' ('SList' (z :: [k])) where -- showsPrec p 'SNil' = showString \"SNil\" -- showsPrec p ('SCons' sx sxs) = -- showParen (p > 10) $ showString \"SCons \" . showsPrec 11 sx -- . showSpace . showsPrec 11 sxs -- @ -- -- To figure out what should go in place of @???@, observe that we require the -- type of each field to also be 'Show' instances. In other words, we need -- something like @('Show' ('Sing' (a :: k)))@. But this isn't quite right, as the -- type variable @a@ doesn't appear in the instance head. In fact, this @a@ -- type is really referring to an existentially quantified type variable in the -- 'SCons' constructor, so it doesn't make sense to try and use it like this. -- -- Luckily, the @QuantifiedConstraints@ language extension provides a solution -- to this problem. This lets you write a context of the form -- @(forall a. 'Show' ('Sing' (a :: k)))@, which demands that there be an instance -- for @'Show' ('Sing' (a :: k))@ that is parametric in the use of @a@. -- This lets us write something closer to this: -- -- @ -- instance (forall a. 'Show' ('Sing' (a :: k))) => 'SList' ('Sing' (z :: [k])) where ... -- @ -- -- The 'ShowSing' class is a thin wrapper around -- @(forall a. 'Show' ('Sing' (a :: k)))@. With 'ShowSing', our final instance -- declaration becomes this: -- -- @ -- instance 'ShowSing' k => 'Show' ('SList' (z :: [k])) where ... -- @ -- -- In fact, this instance can be derived: -- -- @ -- deriving instance 'ShowSing' k => 'Show' ('SList' (z :: [k])) -- @ -- -- (Note that the actual definition of 'ShowSing' is slightly more complicated -- than what this documentation might suggest. For the full story, -- refer to the documentation for `ShowSing'`.) -- -- When singling a derived 'Show' instance, @singletons-th@ will also generate -- a 'Show' instance for the corresponding singleton type using 'ShowSing'. -- In other words, if you give @singletons-th@ a derived 'Show' instance, then -- you'll receive the following in return: -- -- * A promoted (@PShow@) instance -- * A singled (@SShow@) instance -- * A 'Show' instance for the singleton type -- -- What a bargain! -- One might wonder we we simply don't define ShowSing as -- @type ShowSing k = (forall (z :: k). ShowSing' z)@ instead of going the -- extra mile to define it as a class. -- See Note [Define ShowSing as a class, not a type synonym] for an explanation. #if __GLASGOW_HASKELL__ >= 810 type ShowSing :: Type -> Constraint #endif class (forall (z :: k). ShowSing' z) => ShowSing (k :: Type) instance (forall (z :: k). ShowSing' z) => ShowSing (k :: Type) -- | The workhorse that powers 'ShowSing'. The only reason that `ShowSing'` -- exists is to work around GHC's inability to put type families in the head -- of a quantified constraint (see -- for more -- details on this point). In other words, GHC will not let you define -- 'ShowSing' like so: -- -- @ -- class (forall (z :: k). 'Show' ('Sing' z)) => 'ShowSing' k -- @ -- -- By replacing @'Show' ('Sing' z)@ with @ShowSing' z@, we are able to avoid -- this restriction for the most part. -- -- The superclass of `ShowSing'` is a bit peculiar: -- -- @ -- class (forall (sing :: k -> Type). sing ~ 'Sing' => 'Show' (sing z)) => `ShowSing'` (z :: k) -- @ -- -- One might wonder why this superclass is used instead of this seemingly more -- direct equivalent: -- -- @ -- class 'Show' ('Sing' z) => `ShowSing'` (z :: k) -- @ -- -- Actually, these aren't equivalent! The latter's superclass mentions a type -- family in its head, and this gives GHC's constraint solver trouble when -- trying to match this superclass against other constraints. (See the -- discussion beginning at -- https://gitlab.haskell.org/ghc/ghc/-/issues/16365#note_189057 for more on -- this point). The former's superclass, on the other hand, does /not/ mention -- a type family in its head, which allows it to match other constraints more -- easily. It may sound like a small difference, but it's the only reason that -- 'ShowSing' is able to work at all without a significant amount of additional -- workarounds. -- -- The quantified superclass has one major downside. Although the head of the -- quantified superclass is more eager to match, which is usually a good thing, -- it can bite under certain circumstances. Because @'Show' (sing z)@ will -- match a 'Show' instance for /any/ types @sing :: k -> Type@ and @z :: k@, -- (where @k@ is a kind variable), it is possible for GHC's constraint solver -- to get into a situation where multiple instances match @'Show' (sing z)@, -- and GHC will get confused as a result. Consider this example: -- -- @ -- -- As in "Data.Singletons" -- newtype 'WrappedSing' :: forall k. k -> Type where -- 'WrapSing' :: forall k (a :: k). { 'unwrapSing' :: 'Sing' a } -> 'WrappedSing' a -- -- instance 'ShowSing' k => 'Show' ('WrappedSing' (a :: k)) where -- 'showsPrec' _ s = 'showString' "WrapSing {unwrapSing = " . showsPrec 0 s . showChar '}' -- @ -- -- When typechecking the 'Show' instance for 'WrappedSing', GHC must fill in a -- default definition @'show' = defaultShow@, where -- @defaultShow :: 'Show' ('WrappedSing' a) => 'WrappedSing' a -> 'String'@. -- GHC's constraint solver has two possible ways to satisfy the -- @'Show' ('WrappedSing' a)@ constraint for @defaultShow@: -- -- 1. The top-level instance declaration for @'Show' ('WrappedSing' (a :: k))@ -- itself, and -- -- 2. @'Show' (sing (z :: k))@ from the head of the quantified constraint arising -- from @'ShowSing' k@. -- -- In practice, GHC will choose (2), as local quantified constraints shadow -- global constraints. This confuses GHC greatly, causing it to error out with -- an error akin to @Couldn't match type Sing with WrappedSing@. See -- https://gitlab.haskell.org/ghc/ghc/-/issues/17934 for a full diagnosis of -- the issue. -- -- The bad news is that because of GHC#17934, we have to manually define 'show' -- (and 'showList') in the 'Show' instance for 'WrappedSing' in order to avoid -- confusing GHC's constraint solver. In other words, @deriving 'Show'@ is a -- no-go for 'WrappedSing'. The good news is that situations like 'WrappedSing' -- are quite rare in the world of @singletons@—most of the time, 'Show' -- instances for singleton types do /not/ have the shape -- @'Show' (sing (z :: k))@, where @k@ is a polymorphic kind variable. Rather, -- most such instances instantiate @k@ to a specific kind (e.g., @Bool@, or -- @[a]@), which means that they will not overlap the head of the quantified -- superclass in `ShowSing'` as observed above. -- -- Note that we define the single instance for `ShowSing'` without the use of a -- quantified constraint in the instance context: -- -- @ -- instance 'Show' ('Sing' z) => `ShowSing'` (z :: k) -- @ -- -- We /could/ define this instance with a quantified constraint in the instance -- context, and it would be equally as expressive. But it doesn't provide any -- additional functionality that the non-quantified version gives, so we opt -- for the non-quantified version, which is easier to read. #if __GLASGOW_HASKELL__ >= 810 type ShowSing' :: k -> Constraint #endif class (forall (sing :: k -> Type). sing ~ Sing => Show (sing z)) => ShowSing' (z :: k) instance Show (Sing z) => ShowSing' (z :: k) {- Note [Define ShowSing as a class, not a type synonym] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In an ideal world, we would simply define ShowSing like this: type ShowSing k = (forall (z :: k). ShowSing' z) :: Constraint) In fact, I used to define ShowSing in a manner similar to this in version 2.5 of singletons. However, I realized some time after 2.5's release that the this encoding is unfeasible at the time being due to GHC Trac #15888. To be more precise, the exact issue involves an infelicity in the way QuantifiedConstraints interacts with recursive type class instances. Consider the following example (from #371): $(singletons [d| data X a = X1 | X2 (Y a) deriving Show data Y a = Y1 | Y2 (X a) deriving Show |]) This will generate the following instances: deriving instance ShowSing (Y a) => Show (Sing (z :: X a)) deriving instance ShowSing (X a) => Show (Sing (z :: Y a)) So far, so good. Now, suppose you try to actually `show` a singleton for X. For example: show (sing @(X1 :: X Bool)) Somewhat surprisingly, this will be rejected by the typechecker with the following error: • Reduction stack overflow; size = 201 When simplifying the following type: Show (Sing z) To see why this happens, observe what goes on if we expand the occurrences of the ShowSing type synonym in the generated instances: deriving instance (forall z. ShowSing' (z :: Y a)) => Show (Sing (z :: X a)) deriving instance (forall z. ShowSing' (z :: X a)) => Show (Sing (z :: Y a)) Due to the way QuantifiedConstraints currently works (as surmised in Trac #15888), when GHC has a Wanted `ShowSing' (X1 :: X Bool)` constraint, it chooses the appropriate instance and emits a Wanted `forall z. ShowSing' (z :: Y Bool)` constraint (from the instance context). GHC skolemizes the `z` to `z1` and tries to solve a Wanted `ShowSing' (z1 :: Y Bool)` constraint. GHC chooses the appropriate instance and emits a Wanted `forall z. ShowSing' (z :: X Bool)` constraint. GHC skolemizes the `z` to `z2` and tries to solve a Wanted `ShowSing' (z2 :: X Bool)` constraint... we repeat the process and find ourselves in an infinite loop that eventually overflows the reduction stack. Eep. Until Trac #15888 is fixed, there are two possible ways to work around this problem: 1. Make derived instances' type inference more clever. If you look closely, you'll notice that the `ShowSing (X a)`/`ShowSing (Y a)` constraints in the generated instances are entirely redundant and could safely be left off. But determining this would require significantly improving singletons-th' Template Haskell capabilities for type inference, which is a path that we usually spurn in favor of keeping the generated code dumb but predictable. 2. Define `ShowSing` as a class (with a single instance) instead of a type synonym. `ShowSing`-as-a-class ties the recursive knot during instance resolution and thus avoids the problems that the type synonym version currently suffers from. Given the two options, (2) is by far the easier option, so that is what we ultimately went with. -} ------------------------------------------------------------ -- (S)WrappedSing instances ------------------------------------------------------------ -- Note that we cannot derive this Show instance due to -- https://gitlab.haskell.org/ghc/ghc/-/issues/17934. The Haddocks for -- ShowSing' contain a lengthier explanation of how GHC#17934 relates to -- ShowSing. instance ShowSing k => Show (WrappedSing (a :: k)) where showsPrec = showsWrappedSingPrec show x = showsWrappedSingPrec 0 x "" showList = showListWith (showsWrappedSingPrec 0) showsWrappedSingPrec :: ShowSing k => Int -> WrappedSing (a :: k) -> ShowS showsWrappedSingPrec p (WrapSing s) = showParen (p >= 11) $ showString "WrapSing {unwrapSing = " . showsPrec 0 s . showChar '}' deriving instance ShowSing k => Show (SWrappedSing (ws :: WrappedSing (a :: k))) #endif singletons-3.0.3/src/Data/Singletons/Sigma.hs0000644000000000000000000002071007346545000017254 0ustar0000000000000000{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} #if __GLASGOW_HASKELL__ >= 806 {-# LANGUAGE QuantifiedConstraints #-} #else {-# LANGUAGE TypeInType #-} #endif #if __GLASGOW_HASKELL__ >= 810 {-# LANGUAGE StandaloneKindSignatures #-} #else {-# LANGUAGE ImpredicativeTypes #-} -- See Note [Impredicative Σ?] #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Singletons.Sigma -- Copyright : (C) 2017 Ryan Scott -- License : BSD-style (see LICENSE) -- Maintainer : Ryan Scott -- Stability : experimental -- Portability : non-portable -- -- Defines 'Sigma', a dependent pair data type, and related functions. -- ---------------------------------------------------------------------------- module Data.Singletons.Sigma ( -- * The 'Sigma' type Sigma(..), Σ , Sing, SSigma(..), SΣ -- * Operations over 'Sigma' , fstSigma, FstSigma, sndSigma, SndSigma , projSigma1, projSigma2 , mapSigma, zipSigma , currySigma, uncurrySigma #if __GLASGOW_HASKELL__ >= 806 -- * Internal utilities -- $internalutilities , ShowApply, ShowSingApply , ShowApply', ShowSingApply' #endif ) where import Data.Kind import Data.Singletons #if __GLASGOW_HASKELL__ >= 806 import Data.Singletons.ShowSing #endif -- | A dependent pair. #if __GLASGOW_HASKELL__ >= 810 type Sigma :: forall s -> (s ~> Type) -> Type #endif data Sigma (s :: Type) :: (s ~> Type) -> Type where (:&:) :: forall s t fst. Sing (fst :: s) -> t @@ fst -> Sigma s t infixr 4 :&: -- | Unicode shorthand for 'Sigma'. #if __GLASGOW_HASKELL__ >= 810 type Σ :: forall s -> (s ~> Type) -> Type #endif type Σ = Sigma {- Note [Impredicative Σ?] ~~~~~~~~~~~~~~~~~~~~~~~ The following definition alone: type Σ = Sigma will not typecheck without the use of ImpredicativeTypes. There isn't a fundamental reason that this should be the case, and the only reason that GHC currently requires this is due to GHC#13408. Thankfully, giving Σ a standalone kind signature works around GHC#13408, so we only have to enable ImpredicativeTypes on pre-8.10 versions of GHC. -} -- | The singleton type for 'Sigma'. #if __GLASGOW_HASKELL__ >= 810 type SSigma :: Sigma s t -> Type #endif data SSigma :: forall s t. Sigma s t -> Type where (:%&:) :: forall s t (fst :: s) (sfst :: Sing fst) (snd :: t @@ fst). Sing ('WrapSing sfst) -> Sing snd -> SSigma (sfst ':&: snd :: Sigma s t) infixr 4 :%&: type instance Sing = SSigma instance forall s t (fst :: s) (a :: Sing fst) (b :: t @@ fst). (SingI fst, SingI b) => SingI (a ':&: b :: Sigma s t) where sing = sing :%&: sing -- | Unicode shorthand for 'SSigma'. #if __GLASGOW_HASKELL__ >= 810 type SΣ :: Sigma s t -> Type #endif type SΣ = SSigma -- | Project the first element out of a dependent pair. fstSigma :: forall s t. SingKind s => Sigma s t -> Demote s fstSigma (a :&: _) = fromSing a -- | Project the first element out of a dependent pair. #if __GLASGOW_HASKELL__ >= 810 type FstSigma :: Sigma s t -> s #endif type family FstSigma (sig :: Sigma s t) :: s where FstSigma ((_ :: Sing fst) ':&: _) = fst -- | Project the second element out of a dependent pair. sndSigma :: forall s t (sig :: Sigma s t). SingKind (t @@ FstSigma sig) => SSigma sig -> Demote (t @@ FstSigma sig) sndSigma (_ :%&: b) = fromSing b -- | Project the second element out of a dependent pair. #if __GLASGOW_HASKELL__ >= 810 type SndSigma :: forall s t. forall (sig :: Sigma s t) -> t @@ FstSigma sig #endif type family SndSigma (sig :: Sigma s t) :: t @@ FstSigma sig where SndSigma (_ ':&: b) = b -- | Project the first element out of a dependent pair using -- continuation-passing style. projSigma1 :: (forall (fst :: s). Sing fst -> r) -> Sigma s t -> r projSigma1 f (a :&: _) = f a -- | Project the second element out of a dependent pair using -- continuation-passing style. projSigma2 :: forall s t r. (forall (fst :: s). t @@ fst -> r) -> Sigma s t -> r projSigma2 f ((_ :: Sing (fst :: s)) :&: b) = f @fst b -- | Map across a 'Sigma' value in a dependent fashion. mapSigma :: Sing (f :: a ~> b) -> (forall (x :: a). p @@ x -> q @@ (f @@ x)) -> Sigma a p -> Sigma b q mapSigma f g ((x :: Sing (fst :: a)) :&: y) = (f @@ x) :&: (g @fst y) -- | Zip two 'Sigma' values together in a dependent fashion. zipSigma :: Sing (f :: a ~> b ~> c) -> (forall (x :: a) (y :: b). p @@ x -> q @@ y -> r @@ (f @@ x @@ y)) -> Sigma a p -> Sigma b q -> Sigma c r zipSigma f g ((a :: Sing (fstA :: a)) :&: p) ((b :: Sing (fstB :: b)) :&: q) = (f @@ a @@ b) :&: (g @fstA @fstB p q) -- | Convert an uncurried function on 'Sigma' to a curried one. -- -- Together, 'currySigma' and 'uncurrySigma' witness an isomorphism such that -- the following identities hold: -- -- @ -- id1 :: forall a (b :: a ~> Type) (c :: 'Sigma' a b ~> Type). -- (forall (p :: Sigma a b). 'SSigma' p -> c @@ p) -- -> (forall (p :: Sigma a b). 'SSigma' p -> c @@ p) -- id1 f = 'uncurrySigma' @a @b @c ('currySigma' @a @b @c f) -- -- id2 :: forall a (b :: a ~> Type) (c :: 'Sigma' a b ~> Type). -- (forall (x :: a) (sx :: Sing x) (y :: b @@ x). Sing ('WrapSing' sx) -> Sing y -> c @@ (sx :&: y)) -- -> (forall (x :: a) (sx :: Sing x) (y :: b @@ x). Sing ('WrapSing' sx) -> Sing y -> c @@ (sx :&: y)) -- id2 f = 'currySigma' @a @b @c ('uncurrySigma' @a @b @c f) -- @ currySigma :: forall a (b :: a ~> Type) (c :: Sigma a b ~> Type). (forall (p :: Sigma a b). SSigma p -> c @@ p) -> (forall (x :: a) (sx :: Sing x) (y :: b @@ x). Sing ('WrapSing sx) -> Sing y -> c @@ (sx ':&: y)) currySigma f x y = f (x :%&: y) -- | Convert a curried function on 'Sigma' to an uncurried one. -- -- Together, 'currySigma' and 'uncurrySigma' witness an isomorphism. -- (Refer to the documentation for 'currySigma' for more details.) uncurrySigma :: forall a (b :: a ~> Type) (c :: Sigma a b ~> Type). (forall (x :: a) (sx :: Sing x) (y :: b @@ x). Sing ('WrapSing sx) -> Sing y -> c @@ (sx ':&: y)) -> (forall (p :: Sigma a b). SSigma p -> c @@ p) uncurrySigma f (x :%&: y) = f x y #if __GLASGOW_HASKELL__ >= 806 instance (ShowSing s, ShowApply t) => Show (Sigma s t) where showsPrec p ((a :: Sing (fst :: s)) :&: b) = showParen (p >= 5) $ showsPrec 5 a . showString " :&: " . showsPrec 5 b :: ShowApply' t fst => ShowS instance forall s (t :: s ~> Type) (sig :: Sigma s t). (ShowSing s, ShowSingApply t) => Show (SSigma sig) where showsPrec p ((sa :: Sing ('WrapSing (sfst :: Sing fst))) :%&: (sb :: Sing snd)) = showParen (p >= 5) $ showsPrec 5 sa . showString " :&: " . showsPrec 5 sb :: ShowSingApply' t fst snd => ShowS ------------------------------------------------------------ -- Internal utilities ------------------------------------------------------------ {- $internal-utilities See the documentation in "Data.Singletons.ShowSing"—in particular, the Haddocks for 'ShowSing' and `ShowSing'`—for an explanation for why these classes exist. Note that these classes are only defined on GHC 8.6 or later. -} #if __GLASGOW_HASKELL__ >= 810 type ShowApply :: (a ~> Type) -> Constraint #endif class (forall (x :: a). ShowApply' f x) => ShowApply (f :: a ~> Type) instance (forall (x :: a). ShowApply' f x) => ShowApply (f :: a ~> Type) #if __GLASGOW_HASKELL__ >= 810 type ShowApply' :: (a ~> Type) -> a -> Constraint #endif class Show (Apply f x) => ShowApply' (f :: a ~> Type) (x :: a) instance Show (Apply f x) => ShowApply' (f :: a ~> Type) (x :: a) #if __GLASGOW_HASKELL__ >= 810 type ShowSingApply :: (a ~> Type) -> Constraint #endif class (forall (x :: a) (z :: Apply f x). ShowSingApply' f x z) => ShowSingApply (f :: a ~> Type) instance (forall (x :: a) (z :: Apply f x). ShowSingApply' f x z) => ShowSingApply (f :: a ~> Type) #if __GLASGOW_HASKELL__ >= 810 type ShowSingApply' :: forall a. forall (f :: a ~> Type) (x :: a) -> Apply f x -> Constraint #endif class Show (Sing z) => ShowSingApply' (f :: a ~> Type) (x :: a) (z :: Apply f x) instance Show (Sing z) => ShowSingApply' (f :: a ~> Type) (x :: a) (z :: Apply f x) #endif singletons-3.0.3/tests/0000755000000000000000000000000007346545000013235 5ustar0000000000000000singletons-3.0.3/tests/ByHand.hs0000644000000000000000000007746207346545000014756 0ustar0000000000000000{- ByHand.hs (c) Richard Eisenberg 2012 rae@cs.brynmawr.edu Shows the derivations for the singleton definitions done by hand. This file is a great way to understand the singleton encoding better. -} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors -Wno-orphans #-} {-# LANGUAGE PolyKinds, DataKinds, TypeFamilies, KindSignatures, GADTs, FlexibleInstances, FlexibleContexts, UndecidableInstances, RankNTypes, TypeOperators, MultiParamTypeClasses, FunctionalDependencies, ScopedTypeVariables, LambdaCase, EmptyCase, TypeApplications, EmptyCase, CPP #-} #if __GLASGOW_HASKELL__ < 806 {-# LANGUAGE TypeInType #-} #endif #if __GLASGOW_HASKELL__ >= 810 {-# LANGUAGE StandaloneKindSignatures #-} #endif module ByHand where import Data.Kind import Data.Type.Equality hiding (type (==), apply) import Data.Proxy import Data.Singletons import Data.Singletons.Decide import Prelude hiding ((+), (-), map, zipWith) import Unsafe.Coerce ----------------------------------- -- Original ADTs ------------------ ----------------------------------- #if __GLASGOW_HASKELL__ >= 810 type Nat :: Type #endif data Nat where Zero :: Nat Succ :: Nat -> Nat deriving Eq -- Defined using names to avoid fighting with concrete syntax #if __GLASGOW_HASKELL__ >= 810 type List :: Type -> Type #endif data List :: Type -> Type where Nil :: List a Cons :: a -> List a -> List a deriving Eq ----------------------------------- -- One-time definitions ----------- ----------------------------------- -- Promoted equality type class #if __GLASGOW_HASKELL__ >= 810 type PEq :: Type -> Constraint #endif class PEq k where type (==) (a :: k) (b :: k) :: Bool -- omitting definition of /= -- Singleton type equality type class #if __GLASGOW_HASKELL__ >= 810 type SEq :: Type -> Constraint #endif class SEq k where (%==) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Sing (a == b) -- omitting definition of %/= #if __GLASGOW_HASKELL__ >= 810 type If :: Bool -> a -> a -> a #endif type family If (cond :: Bool) (tru :: a) (fls :: a) :: a where If True tru fls = tru If False tru fls = fls sIf :: Sing a -> Sing b -> Sing c -> Sing (If a b c) sIf STrue b _ = b sIf SFalse _ c = c ----------------------------------- -- Auto-generated code ------------ ----------------------------------- -- Nat #if __GLASGOW_HASKELL__ >= 810 type SNat :: Nat -> Type #endif data SNat :: Nat -> Type where SZero :: SNat Zero SSucc :: SNat n -> SNat (Succ n) type instance Sing = SNat #if __GLASGOW_HASKELL__ >= 810 type SuccSym0 :: Nat ~> Nat #endif data SuccSym0 :: Nat ~> Nat type instance Apply SuccSym0 x = Succ x #if __GLASGOW_HASKELL__ >= 810 type EqualsNat :: Nat -> Nat -> Bool #endif type family EqualsNat (a :: Nat) (b :: Nat) :: Bool where EqualsNat Zero Zero = True EqualsNat (Succ a) (Succ b) = a == b EqualsNat (n1 :: Nat) (n2 :: Nat) = False instance PEq Nat where type a == b = EqualsNat a b instance SEq Nat where SZero %== SZero = STrue SZero %== (SSucc _) = SFalse (SSucc _) %== SZero = SFalse (SSucc n) %== (SSucc n') = n %== n' instance SDecide Nat where SZero %~ SZero = Proved Refl (SSucc m) %~ (SSucc n) = case m %~ n of Proved Refl -> Proved Refl Disproved contra -> Disproved (\Refl -> contra Refl) SZero %~ (SSucc _) = Disproved (\case) (SSucc _) %~ SZero = Disproved (\case) instance SingI Zero where sing = SZero instance SingI n => SingI (Succ n) where sing = SSucc sing instance SingI1 Succ where liftSing = SSucc instance SingKind Nat where type Demote Nat = Nat fromSing SZero = Zero fromSing (SSucc n) = Succ (fromSing n) toSing Zero = SomeSing SZero toSing (Succ n) = withSomeSing n (\n' -> SomeSing $ SSucc n') -- Bool #if __GLASGOW_HASKELL__ >= 810 type SBool :: Bool -> Type #endif data SBool :: Bool -> Type where SFalse :: SBool False STrue :: SBool True type instance Sing = SBool {- (&&) :: Bool -> Bool -> Bool False && _ = False True && x = x -} #if __GLASGOW_HASKELL__ >= 810 type (&&) :: Bool -> Bool -> Bool #endif type family (a :: Bool) && (b :: Bool) :: Bool where False && _ = False True && x = x (%&&) :: forall (a :: Bool) (b :: Bool). Sing a -> Sing b -> Sing (a && b) SFalse %&& SFalse = SFalse SFalse %&& STrue = SFalse STrue %&& SFalse = SFalse STrue %&& STrue = STrue instance SingI False where sing = SFalse instance SingI True where sing = STrue instance SingKind Bool where type Demote Bool = Bool fromSing SFalse = False fromSing STrue = True toSing False = SomeSing SFalse toSing True = SomeSing STrue -- Maybe #if __GLASGOW_HASKELL__ >= 810 type SMaybe :: forall k. Maybe k -> Type #endif data SMaybe :: forall k. Maybe k -> Type where SNothing :: SMaybe Nothing SJust :: forall k (a :: k). Sing a -> SMaybe (Just a) type instance Sing = SMaybe #if __GLASGOW_HASKELL__ >= 810 type EqualsMaybe :: Maybe k -> Maybe k -> Bool #endif type family EqualsMaybe (a :: Maybe k) (b :: Maybe k) :: Bool where EqualsMaybe Nothing Nothing = True EqualsMaybe (Just a) (Just a') = a == a' EqualsMaybe (x :: Maybe k) (y :: Maybe k) = False instance PEq a => PEq (Maybe a) where type m1 == m2 = EqualsMaybe m1 m2 instance SDecide k => SDecide (Maybe k) where SNothing %~ SNothing = Proved Refl (SJust x) %~ (SJust y) = case x %~ y of Proved Refl -> Proved Refl Disproved contra -> Disproved (\Refl -> contra Refl) SNothing %~ (SJust _) = Disproved (\case) (SJust _) %~ SNothing = Disproved (\case) instance SEq k => SEq (Maybe k) where SNothing %== SNothing = STrue SNothing %== (SJust _) = SFalse (SJust _) %== SNothing = SFalse (SJust a) %== (SJust a') = a %== a' instance SingI (Nothing :: Maybe k) where sing = SNothing instance SingI a => SingI (Just (a :: k)) where sing = SJust sing instance SingI1 Just where liftSing = SJust instance SingKind k => SingKind (Maybe k) where type Demote (Maybe k) = Maybe (Demote k) fromSing SNothing = Nothing fromSing (SJust a) = Just (fromSing a) toSing Nothing = SomeSing SNothing toSing (Just x) = case toSing x :: SomeSing k of SomeSing x' -> SomeSing $ SJust x' -- List #if __GLASGOW_HASKELL__ >= 810 type SList :: forall k. List k -> Type #endif data SList :: forall k. List k -> Type where SNil :: SList Nil SCons :: forall k (h :: k) (t :: List k). Sing h -> SList t -> SList (Cons h t) type instance Sing = SList #if __GLASGOW_HASKELL__ >= 810 type NilSym0 :: List a #endif type family NilSym0 :: List a where NilSym0 = Nil #if __GLASGOW_HASKELL__ >= 810 type ConsSym0 :: forall a. a ~> List a ~> List a type ConsSym1 :: forall a. a -> List a ~> List a type ConsSym2 :: forall a. a -> List a -> List a #endif data ConsSym0 :: forall a. a ~> List a ~> List a data ConsSym1 :: forall a. a -> List a ~> List a type family ConsSym2 (x :: a) (y :: List a) :: List a where ConsSym2 x y = Cons x y type instance Apply ConsSym0 a = ConsSym1 a type instance Apply (ConsSym1 a) b = Cons a b #if __GLASGOW_HASKELL__ >= 810 type EqualsList :: List k -> List k -> Bool #endif type family EqualsList (a :: List k) (b :: List k) :: Bool where EqualsList Nil Nil = True EqualsList (Cons a b) (Cons a' b') = (a == a') && (b == b') EqualsList (x :: List k) (y :: List k) = False instance PEq a => PEq (List a) where type l1 == l2 = EqualsList l1 l2 instance SEq k => SEq (List k) where SNil %== SNil = STrue SNil %== (SCons _ _) = SFalse (SCons _ _) %== SNil = SFalse (SCons a b) %== (SCons a' b') = (a %== a') %&& (b %== b') instance SDecide k => SDecide (List k) where SNil %~ SNil = Proved Refl (SCons h1 t1) %~ (SCons h2 t2) = case (h1 %~ h2, t1 %~ t2) of (Proved Refl, Proved Refl) -> Proved Refl (Disproved contra, _) -> Disproved (\Refl -> contra Refl) (_, Disproved contra) -> Disproved (\Refl -> contra Refl) SNil %~ (SCons _ _) = Disproved (\case) (SCons _ _) %~ SNil = Disproved (\case) instance SingI Nil where sing = SNil instance (SingI h, SingI t) => SingI (Cons (h :: k) (t :: List k)) where sing = SCons sing sing instance SingI h => SingI1 (Cons (h :: k)) where liftSing = SCons sing instance SingI2 Cons where liftSing2 = SCons instance SingKind k => SingKind (List k) where type Demote (List k) = List (Demote k) fromSing SNil = Nil fromSing (SCons h t) = Cons (fromSing h) (fromSing t) toSing Nil = SomeSing SNil toSing (Cons h t) = case ( toSing h :: SomeSing k , toSing t :: SomeSing (List k) ) of (SomeSing h', SomeSing t') -> SomeSing $ SCons h' t' -- Either #if __GLASGOW_HASKELL__ >= 810 type SEither :: forall k1 k2. Either k1 k2 -> Type #endif data SEither :: forall k1 k2. Either k1 k2 -> Type where SLeft :: forall k1 (a :: k1). Sing a -> SEither (Left a) SRight :: forall k2 (b :: k2). Sing b -> SEither (Right b) type instance Sing = SEither instance (SingI a) => SingI (Left (a :: k)) where sing = SLeft sing instance SingI1 Left where liftSing = SLeft instance (SingI b) => SingI (Right (b :: k)) where sing = SRight sing instance SingI1 Right where liftSing = SRight instance (SingKind k1, SingKind k2) => SingKind (Either k1 k2) where type Demote (Either k1 k2) = Either (Demote k1) (Demote k2) fromSing (SLeft x) = Left (fromSing x) fromSing (SRight x) = Right (fromSing x) toSing (Left x) = case toSing x :: SomeSing k1 of SomeSing x' -> SomeSing $ SLeft x' toSing (Right x) = case toSing x :: SomeSing k2 of SomeSing x' -> SomeSing $ SRight x' instance (SDecide k1, SDecide k2) => SDecide (Either k1 k2) where (SLeft x) %~ (SLeft y) = case x %~ y of Proved Refl -> Proved Refl Disproved contra -> Disproved (\Refl -> contra Refl) (SRight x) %~ (SRight y) = case x %~ y of Proved Refl -> Proved Refl Disproved contra -> Disproved (\Refl -> contra Refl) (SLeft _) %~ (SRight _) = Disproved (\case) (SRight _) %~ (SLeft _) = Disproved (\case) -- Composite #if __GLASGOW_HASKELL__ >= 810 type Composite :: Type -> Type -> Type #endif data Composite :: Type -> Type -> Type where MkComp :: Either (Maybe a) b -> Composite a b #if __GLASGOW_HASKELL__ >= 810 type SComposite :: forall k1 k2. Composite k1 k2 -> Type #endif data SComposite :: forall k1 k2. Composite k1 k2 -> Type where SMkComp :: forall k1 k2 (a :: Either (Maybe k1) k2). SEither a -> SComposite (MkComp a) type instance Sing = SComposite instance SingI a => SingI (MkComp (a :: Either (Maybe k1) k2)) where sing = SMkComp sing instance SingI1 MkComp where liftSing = SMkComp instance (SingKind k1, SingKind k2) => SingKind (Composite k1 k2) where type Demote (Composite k1 k2) = Composite (Demote k1) (Demote k2) fromSing (SMkComp x) = MkComp (fromSing x) toSing (MkComp x) = case toSing x :: SomeSing (Either (Maybe k1) k2) of SomeSing x' -> SomeSing $ SMkComp x' instance (SDecide k1, SDecide k2) => SDecide (Composite k1 k2) where (SMkComp x) %~ (SMkComp y) = case x %~ y of Proved Refl -> Proved Refl Disproved contra -> Disproved (\Refl -> contra Refl) -- Empty #if __GLASGOW_HASKELL__ >= 810 type Empty :: Type #endif data Empty #if __GLASGOW_HASKELL__ >= 810 type SEmpty :: Empty -> Type #endif data SEmpty :: Empty -> Type type instance Sing = SEmpty instance SingKind Empty where type Demote Empty = Empty fromSing = \case toSing x = SomeSing (case x of) -- Type #if __GLASGOW_HASKELL__ >= 810 type Vec :: Type -> Nat -> Type #endif data Vec :: Type -> Nat -> Type where VNil :: Vec a Zero VCons :: a -> Vec a n -> Vec a (Succ n) #if __GLASGOW_HASKELL__ >= 810 type Rep :: Type #endif data Rep = Nat | Maybe Rep | Vec Rep Nat #if __GLASGOW_HASKELL__ >= 810 type SRep :: Type -> Type #endif data SRep :: Type -> Type where SNat :: SRep Nat SMaybe :: SRep a -> SRep (Maybe a) SVec :: SRep a -> SNat n -> SRep (Vec a n) type instance Sing = SRep instance SingI Nat where sing = SNat instance SingI a => SingI (Maybe a) where sing = SMaybe sing instance SingI1 Maybe where liftSing = SMaybe instance (SingI a, SingI n) => SingI (Vec a n) where sing = SVec sing sing instance SingI a => SingI1 (Vec a) where liftSing = SVec sing instance SingI2 Vec where liftSing2 = SVec instance SingKind Type where type Demote Type = Rep fromSing SNat = Nat fromSing (SMaybe a) = Maybe (fromSing a) fromSing (SVec a n) = Vec (fromSing a) (fromSing n) toSing Nat = SomeSing SNat toSing (Maybe a) = case toSing a :: SomeSing Type of SomeSing a' -> SomeSing $ SMaybe a' toSing (Vec a n) = case ( toSing a :: SomeSing Type , toSing n :: SomeSing Nat) of (SomeSing a', SomeSing n') -> SomeSing $ SVec a' n' instance SDecide Type where SNat %~ SNat = Proved Refl SNat %~ (SMaybe {}) = Disproved (\case) SNat %~ (SVec {}) = Disproved (\case) (SMaybe {}) %~ SNat = Disproved (\case) (SMaybe a) %~ (SMaybe b) = case a %~ b of Proved Refl -> Proved Refl Disproved contra -> Disproved (\Refl -> contra Refl) (SMaybe {}) %~ (SVec {}) = Disproved (\case) (SVec {}) %~ SNat = Disproved (\case) (SVec {}) %~ (SMaybe {}) = Disproved (\case) (SVec a1 n1) %~ (SVec a2 n2) = case (a1 %~ a2, n1 %~ n2) of (Proved Refl, Proved Refl) -> Proved Refl (Disproved contra, _) -> Disproved (\Refl -> contra Refl) (_, Disproved contra) -> Disproved (\Refl -> contra Refl) #if __GLASGOW_HASKELL__ >= 810 type EqualsType :: Type -> Type -> Bool #endif type family EqualsType (a :: Type) (b :: Type) :: Bool where EqualsType a a = True EqualsType _ _ = False instance PEq Type where type a == b = EqualsType a b instance SEq Type where a %== b = case a %~ b of Proved Refl -> STrue Disproved _ -> unsafeCoerce SFalse ----------------------------------- -- Some example functions --------- ----------------------------------- isJust :: Maybe a -> Bool isJust Nothing = False isJust (Just _) = True #if __GLASGOW_HASKELL__ >= 810 type IsJust :: Maybe k -> Bool #endif type family IsJust (a :: Maybe k) :: Bool where IsJust Nothing = False IsJust (Just a) = True -- defunctionalization symbols #if __GLASGOW_HASKELL__ >= 810 type IsJustSym0 :: forall a. Maybe a ~> Bool #endif data IsJustSym0 :: forall a. Maybe a ~> Bool type instance Apply IsJustSym0 a = IsJust a sIsJust :: Sing a -> Sing (IsJust a) sIsJust SNothing = SFalse sIsJust (SJust _) = STrue pred :: Nat -> Nat pred Zero = Zero pred (Succ n) = n #if __GLASGOW_HASKELL__ >= 810 type Pred :: Nat -> Nat #endif type family Pred (a :: Nat) :: Nat where Pred Zero = Zero Pred (Succ n) = n #if __GLASGOW_HASKELL__ >= 810 type PredSym0 :: Nat ~> Nat #endif data PredSym0 :: Nat ~> Nat type instance Apply PredSym0 a = Pred a sPred :: forall (t :: Nat). Sing t -> Sing (Pred t) sPred SZero = SZero sPred (SSucc n) = n map :: (a -> b) -> List a -> List b map _ Nil = Nil map f (Cons h t) = Cons (f h) (map f t) #if __GLASGOW_HASKELL__ >= 810 type Map :: (k1 ~> k2) -> List k1 -> List k2 #endif type family Map (f :: k1 ~> k2) (l :: List k1) :: List k2 where Map f Nil = Nil Map f (Cons h t) = Cons (Apply f h) (Map f t) -- defunctionalization symbols #if __GLASGOW_HASKELL__ >= 810 type MapSym0 :: forall a b. (a ~> b) ~> List a ~> List b type MapSym1 :: forall a b. (a ~> b) -> List a ~> List b #endif data MapSym0 :: forall a b. (a ~> b) ~> List a ~> List b data MapSym1 :: forall a b. (a ~> b) -> List a ~> List b type instance Apply MapSym0 f = MapSym1 f type instance Apply (MapSym1 f) xs = Map f xs sMap :: forall k1 k2 (a :: List k1) (f :: k1 ~> k2). (forall b. Proxy f -> Sing b -> Sing (Apply f b)) -> Sing a -> Sing (Map f a) sMap _ SNil = SNil sMap f (SCons h t) = SCons (f Proxy h) (sMap f t) -- Alternative implementation of sMap with Proxy outside of callback. -- Not generated by the library. sMap2 :: forall k1 k2 (a :: List k1) (f :: k1 ~> k2). Proxy f -> (forall b. Sing b -> Sing (Apply f b)) -> Sing a -> Sing (Map f a) sMap2 _ _ SNil = SNil sMap2 p f (SCons h t) = SCons (f h) (sMap2 p f t) -- test sMap foo :: Sing (Cons (Succ (Succ Zero)) (Cons (Succ Zero) Nil)) foo = sMap (\(_ :: Proxy (TyCon1 Succ)) -> SSucc) (SCons (SSucc SZero) (SCons SZero SNil)) -- test sMap2 bar :: Sing (Cons (Succ (Succ Zero)) (Cons (Succ Zero) Nil)) bar = sMap2 (Proxy :: Proxy SuccSym0) (SSucc) (SCons (SSucc SZero) (SCons SZero SNil)) baz :: Sing (Cons Zero (Cons Zero Nil)) baz = sMap2 (Proxy :: Proxy PredSym0) (sPred) (SCons (SSucc SZero) (SCons SZero SNil)) zipWith :: (a -> b -> c) -> List a -> List b -> List c zipWith f (Cons x xs) (Cons y ys) = Cons (f x y) (zipWith f xs ys) zipWith _ Nil (Cons _ _) = Nil zipWith _ (Cons _ _) Nil = Nil zipWith _ Nil Nil = Nil #if __GLASGOW_HASKELL__ >= 810 type ZipWith :: (a ~> b ~> c) -> List a -> List b -> List c #endif type family ZipWith (k1 :: a ~> b ~> c) (k2 :: List a) (k3 :: List b) :: List c where ZipWith f (Cons x xs) (Cons y ys) = Cons (Apply (Apply f x) y) (ZipWith f xs ys) ZipWith f Nil (Cons z1 z2) = Nil ZipWith f (Cons z1 z2) Nil = Nil ZipWith f Nil Nil = Nil #if __GLASGOW_HASKELL__ >= 810 type ZipWithSym0 :: forall a b c. (a ~> b ~> c) ~> List a ~> List b ~> List c type ZipWithSym1 :: forall a b c. (a ~> b ~> c) -> List a ~> List b ~> List c type ZipWithSym2 :: forall a b c. (a ~> b ~> c) -> List a -> List b ~> List c #endif data ZipWithSym0 :: forall a b c. (a ~> b ~> c) ~> List a ~> List b ~> List c data ZipWithSym1 :: forall a b c. (a ~> b ~> c) -> List a ~> List b ~> List c data ZipWithSym2 :: forall a b c. (a ~> b ~> c) -> List a -> List b ~> List c type instance Apply ZipWithSym0 f = ZipWithSym1 f type instance Apply (ZipWithSym1 f) xs = ZipWithSym2 f xs type instance Apply (ZipWithSym2 f xs) ys = ZipWith f xs ys sZipWith :: forall a b c (k1 :: a ~> b ~> c) (k2 :: List a) (k3 :: List b). (forall (t1 :: a). Proxy k1 -> Sing t1 -> forall (t2 :: b). Sing t2 -> Sing (Apply (Apply k1 t1) t2)) -> Sing k2 -> Sing k3 -> Sing (ZipWith k1 k2 k3) sZipWith f (SCons x xs) (SCons y ys) = SCons (f Proxy x y) (sZipWith f xs ys) sZipWith _ SNil (SCons _ _) = SNil sZipWith _ (SCons _ _) SNil = SNil sZipWith _ SNil SNil = SNil either :: (a -> c) -> (b -> c) -> Either a b -> c either l _ (Left x) = l x either _ r (Right x) = r x #if __GLASGOW_HASKELL__ >= 810 type Either_ :: (a ~> c) -> (b ~> c) -> Either a b -> c #endif type family Either_ (l :: a ~> c) (r :: b ~> c) (e :: Either a b) :: c where Either_ l r (Left x) = Apply l x Either_ l r (Right x) = Apply r x -- defunctionalization symbols #if __GLASGOW_HASKELL__ >= 810 type Either_Sym0 :: forall a c b. (a ~> c) ~> (b ~> c) ~> Either a b ~> c type Either_Sym1 :: forall a c b. (a ~> c) -> (b ~> c) ~> Either a b ~> c type Either_Sym2 :: forall a c b. (a ~> c) -> (b ~> c) -> Either a b ~> c #endif data Either_Sym0 :: forall a c b. (a ~> c) ~> (b ~> c) ~> Either a b ~> c data Either_Sym1 :: forall a c b. (a ~> c) -> (b ~> c) ~> Either a b ~> c data Either_Sym2 :: forall a c b. (a ~> c) -> (b ~> c) -> Either a b ~> c type instance Apply Either_Sym0 k1 = Either_Sym1 k1 type instance Apply (Either_Sym1 k1) k2 = Either_Sym2 k1 k2 type instance Apply (Either_Sym2 k1 k2) k3 = Either_ k1 k2 k3 sEither :: forall a b c (l :: a ~> c) (r :: b ~> c) (e :: Either a b). (forall n. Proxy l -> Sing n -> Sing (Apply l n)) -> (forall n. Proxy r -> Sing n -> Sing (Apply r n)) -> Sing e -> Sing (Either_ l r e) sEither l _ (SLeft x) = l Proxy x sEither _ r (SRight x) = r Proxy x -- Alternative implementation of sEither with Proxy outside of callbacks. -- Not generated by the library. sEither2 :: forall a b c (l :: a ~> c) (r :: b ~> c) (e :: Either a b). Proxy l -> Proxy r -> (forall n. Sing n -> Sing (Apply l n)) -> (forall n. Sing n -> Sing (Apply r n)) -> Sing e -> Sing (Either_ l r e) sEither2 _ _ l _ (SLeft x) = l x sEither2 _ _ _ r (SRight x) = r x eitherFoo :: Sing (Succ (Succ Zero)) eitherFoo = sEither (\(_ :: Proxy SuccSym0) -> SSucc) (\(_ :: Proxy PredSym0) -> sPred) (SLeft (SSucc SZero)) eitherBar :: Sing Zero eitherBar = sEither2 (Proxy :: Proxy SuccSym0) (Proxy :: Proxy PredSym0) SSucc sPred (SRight (SSucc SZero)) eitherToNat :: Either Nat Nat -> Nat eitherToNat (Left x) = x eitherToNat (Right x) = x #if __GLASGOW_HASKELL__ >= 810 type EitherToNat :: Either Nat Nat -> Nat #endif type family EitherToNat (e :: Either Nat Nat) :: Nat where EitherToNat (Left x) = x EitherToNat (Right x) = x sEitherToNat :: Sing a -> Sing (EitherToNat a) sEitherToNat (SLeft x) = x sEitherToNat (SRight x) = x liftMaybe :: (a -> b) -> Maybe a -> Maybe b liftMaybe _ Nothing = Nothing liftMaybe f (Just a) = Just (f a) #if __GLASGOW_HASKELL__ >= 810 type LiftMaybe :: (a ~> b) -> Maybe a -> Maybe b #endif type family LiftMaybe (f :: a ~> b) (x :: Maybe a) :: Maybe b where LiftMaybe f Nothing = Nothing LiftMaybe f (Just a) = Just (Apply f a) #if __GLASGOW_HASKELL__ >= 810 type LiftMaybeSym0 :: forall a b. (a ~> b) ~> Maybe a ~> Maybe b type LiftMaybeSym1 :: forall a b. (a ~> b) -> Maybe a ~> Maybe b #endif data LiftMaybeSym0 :: forall a b. (a ~> b) ~> Maybe a ~> Maybe b data LiftMaybeSym1 :: forall a b. (a ~> b) -> Maybe a ~> Maybe b type instance Apply LiftMaybeSym0 k1 = LiftMaybeSym1 k1 type instance Apply (LiftMaybeSym1 k1) k2 = LiftMaybe k1 k2 sLiftMaybe :: forall a b (f :: a ~> b) (x :: Maybe a). (forall (y :: a). Proxy f -> Sing y -> Sing (Apply f y)) -> Sing x -> Sing (LiftMaybe f x) sLiftMaybe _ SNothing = SNothing sLiftMaybe f (SJust a) = SJust (f Proxy a) (+) :: Nat -> Nat -> Nat Zero + x = x (Succ x) + y = Succ (x + y) #if __GLASGOW_HASKELL__ >= 810 type (+) :: Nat -> Nat -> Nat #endif type family (+) (m :: Nat) (n :: Nat) :: Nat where Zero + x = x (Succ x) + y = Succ (x + y) -- defunctionalization symbols #if __GLASGOW_HASKELL__ >= 810 type (+@#@$) :: Nat ~> Nat ~> Nat type (+@#@$$) :: Nat -> Nat ~> Nat #endif data (+@#@$) :: Nat ~> Nat ~> Nat data (+@#@$$) :: Nat -> Nat ~> Nat type instance Apply (+@#@$) k1 = (+@#@$$) k1 type instance Apply ((+@#@$$) k1) k2 = (+) k1 k2 (%+) :: Sing m -> Sing n -> Sing (m + n) SZero %+ x = x (SSucc x) %+ y = SSucc (x %+ y) (-) :: Nat -> Nat -> Nat Zero - _ = Zero (Succ x) - Zero = Succ x (Succ x) - (Succ y) = x - y #if __GLASGOW_HASKELL__ >= 810 type (-) :: Nat -> Nat -> Nat #endif type family (-) (m :: Nat) (n :: Nat) :: Nat where Zero - x = Zero (Succ x) - Zero = Succ x (Succ x) - (Succ y) = x - y #if __GLASGOW_HASKELL__ >= 810 type (-@#@$) :: Nat ~> Nat ~> Nat type (-@#@$$) :: Nat -> Nat ~> Nat #endif data (-@#@$) :: Nat ~> Nat ~> Nat data (-@#@$$) :: Nat -> Nat ~> Nat type instance Apply (-@#@$) k1 = (-@#@$$) k1 type instance Apply ((-@#@$$) k1) k2 = (-) k1 k2 (%-) :: Sing m -> Sing n -> Sing (m - n) SZero %- _ = SZero (SSucc x) %- SZero = SSucc x (SSucc x) %- (SSucc y) = x %- y isZero :: Nat -> Bool isZero n = if n == Zero then True else False #if __GLASGOW_HASKELL__ >= 810 type IsZero :: Nat -> Bool #endif type family IsZero (n :: Nat) :: Bool where IsZero n = If (n == Zero) True False #if __GLASGOW_HASKELL__ >= 810 type IsZeroSym0 :: Nat ~> Bool #endif data IsZeroSym0 :: Nat ~> Bool type instance Apply IsZeroSym0 a = IsZero a sIsZero :: Sing n -> Sing (IsZero n) sIsZero n = sIf (n %== SZero) STrue SFalse {- (||) :: Bool -> Bool -> Bool False || x = x True || _ = True -} #if __GLASGOW_HASKELL__ >= 810 type (||) :: Bool -> Bool -> Bool #endif type family (a :: Bool) || (b :: Bool) :: Bool where False || x = x True || x = True #if __GLASGOW_HASKELL__ >= 810 type (||@#@$) :: Bool ~> Bool ~> Bool type (||@#@$$) :: Bool -> Bool ~> Bool #endif data (||@#@$) :: Bool ~> Bool ~> Bool data (||@#@$$) :: Bool -> Bool ~> Bool type instance Apply (||@#@$) a = (||@#@$$) a type instance Apply ((||@#@$$) a) b = (||) a b (%||) :: Sing a -> Sing b -> Sing (a || b) SFalse %|| x = x STrue %|| _ = STrue contains :: Eq a => a -> List a -> Bool contains _ Nil = False contains elt (Cons h t) = (elt == h) || contains elt t #if __GLASGOW_HASKELL__ >= 810 type Contains :: k -> List k -> Bool #endif type family Contains (a :: k) (b :: List k) :: Bool where Contains elt Nil = False Contains elt (Cons h t) = (elt == h) || (Contains elt t) #if __GLASGOW_HASKELL__ >= 810 type ContainsSym0 :: forall a. a ~> List a ~> Bool type ContainsSym1 :: forall a. a -> List a ~> Bool #endif data ContainsSym0 :: forall a. a ~> List a ~> Bool data ContainsSym1 :: forall a. a -> List a ~> Bool type instance Apply ContainsSym0 a = ContainsSym1 a type instance Apply (ContainsSym1 a) b = Contains a b {- sContains :: forall k. SEq k => forall (a :: k). Sing a -> forall (list :: List k). Sing list -> Sing (Contains a list) sContains _ SNil = SFalse sContains elt (SCons h t) = (elt %== h) %|| (sContains elt t) -} sContains :: forall a (t1 :: a) (t2 :: List a). SEq a => Sing t1 -> Sing t2 -> Sing (Contains t1 t2) sContains _ SNil = let lambda :: forall wild. Sing (Contains wild Nil) lambda = SFalse in lambda sContains elt (SCons h t) = let lambda :: forall elt h t. (elt ~ t1, (Cons h t) ~ t2) => Sing elt -> Sing h -> Sing t -> Sing (Contains elt (Cons h t)) lambda elt' h' t' = (elt' %== h') %|| sContains elt' t' in lambda elt h t cont :: Eq a => a -> List a -> Bool cont = \elt list -> case list of Nil -> False Cons h t -> (elt == h) || cont elt t #if __GLASGOW_HASKELL__ >= 810 type Cont :: a ~> List a ~> Bool #endif type family Cont :: a ~> List a ~> Bool where Cont = Lambda10Sym0 data Lambda10Sym0 f where KindInferenceLambda10Sym0 :: (Lambda10Sym0 @@ arg) ~ Lambda10Sym1 arg => Proxy arg -> Lambda10Sym0 f type instance Lambda10Sym0 `Apply` x = Lambda10Sym1 x data Lambda10Sym1 a f where KindInferenceLambda10Sym1 :: (Lambda10Sym1 a @@ arg) ~ Lambda10Sym2 a arg => Proxy arg -> Lambda10Sym1 a f type instance (Lambda10Sym1 a) `Apply` b = Lambda10Sym2 a b type Lambda10Sym2 a b = Lambda10 a b type family Lambda10 a b where Lambda10 elt list = Case10 elt list list type family Case10 a b scrut where Case10 elt list Nil = False Case10 elt list (Cons h t) = (||@#@$) @@ ((==@#@$) @@ elt @@ h) @@ (Cont @@ elt @@ t) data (==@#@$) f where (:###==@#@$) :: ((==@#@$) @@ arg) ~ (==@#@$$) arg => Proxy arg -> (==@#@$) f type instance (==@#@$) `Apply` x = (==@#@$$) x data (==@#@$$) a f where (:###==@#@$$) :: ((==@#@$$) x @@ arg) ~ (==@#@$$$) x arg => Proxy arg -> (==@#@$$) x y type instance (==@#@$$) a `Apply` b = (==) a b type family (==@#@$$$) a b where (==@#@$$$) a b = (==) a b impNat :: forall m n. SingI n => Proxy n -> Sing m -> Sing (n + m) impNat _ sm = (sing :: Sing n) %+ sm callImpNat :: forall n m. Sing n -> Sing m -> Sing (n + m) callImpNat sn sm = withSingI sn (impNat (Proxy :: Proxy n) sm) instance Show (SNat n) where show SZero = "SZero" show (SSucc n) = "SSucc (" ++ (show n) ++ ")" findIndices :: (a -> Bool) -> [a] -> [Nat] findIndices p ls = loop Zero ls where loop _ [] = [] loop n (x:xs) | p x = n : loop (Succ n) xs | otherwise = loop (Succ n) xs #if __GLASGOW_HASKELL__ >= 810 type FindIndices :: (a ~> Bool) -> List a -> List Nat #endif type family FindIndices (f :: a ~> Bool) (ls :: List a) :: List Nat where FindIndices p ls = (Let123LoopSym2 p ls) @@ Zero @@ ls type family Let123Loop p ls (arg1 :: Nat) (arg2 :: List a) :: List Nat where Let123Loop p ls z Nil = Nil Let123Loop p ls n (x `Cons` xs) = Case123 p ls n x xs (p @@ x) type family Case123 p ls n x xs scrut where Case123 p ls n x xs True = n `Cons` ((Let123LoopSym2 p ls) @@ (Succ n) @@ xs) Case123 p ls n x xs False = (Let123LoopSym2 p ls) @@ (Succ n) @@ xs data Let123LoopSym2 a b c where Let123LoopSym2KindInfernece :: ((Let123LoopSym2 a b @@ z) ~ Let123LoopSym3 a b z) => Proxy z -> Let123LoopSym2 a b c type instance Apply (Let123LoopSym2 a b) c = Let123LoopSym3 a b c data Let123LoopSym3 a b c d where KindInferenceLet123LoopSym3 :: ((Let123LoopSym3 a b c @@ z) ~ Let123LoopSym4 a b c z) => Proxy z -> Let123LoopSym3 a b c d type instance Apply (Let123LoopSym3 a b c) d = Let123Loop a b c d type family Let123LoopSym4 a b c d where Let123LoopSym4 a b c d = Let123Loop a b c d data FindIndicesSym0 a where KindInferenceFindIndicesSym0 :: (FindIndicesSym0 @@ z) ~ FindIndicesSym1 z => Proxy z -> FindIndicesSym0 a type instance Apply FindIndicesSym0 a = FindIndicesSym1 a data FindIndicesSym1 a b where KindInferenceFindIndicesSym1 :: (FindIndicesSym1 a @@ z) ~ FindIndicesSym2 a z => Proxy z -> FindIndicesSym1 a b type instance Apply (FindIndicesSym1 a) b = FindIndices a b type family FindIndicesSym2 a b where FindIndicesSym2 a b = FindIndices a b sFindIndices :: forall a (t1 :: a ~> Bool) (t2 :: (List a)). Sing t1 -> Sing t2 -> Sing (FindIndicesSym0 @@ t1 @@ t2) sFindIndices sP sLs = let sLoop :: forall (u1 :: Nat) (u2 :: List a). Sing u1 -> Sing u2 -> Sing ((Let123LoopSym2 t1 t2) @@ u1 @@ u2) sLoop _ SNil = SNil sLoop sN (sX `SCons` sXs) = case sP @@ sX of STrue -> (singFun2 @ConsSym0 SCons) @@ sN @@ ((singFun2 @(Let123LoopSym2 t1 t2) sLoop) @@ ((singFun1 @SuccSym0 SSucc) @@ sN) @@ sXs) SFalse -> (singFun2 @(Let123LoopSym2 t1 t2) sLoop) @@ ((singFun1 @SuccSym0 SSucc) @@ sN) @@ sXs in (singFun2 @(Let123LoopSym2 t1 t2) sLoop) @@ SZero @@ sLs fI :: forall a. (a -> Bool) -> [a] -> [Nat] fI = \p ls -> let loop :: Nat -> [a] -> [Nat] loop _ [] = [] loop n (x:xs) = case p x of True -> n : loop (Succ n) xs False -> loop (Succ n) xs in loop Zero ls type FI = Lambda22Sym0 type FISym0 = FI type family Lambda22 p ls where Lambda22 p ls = (Let123LoopSym2 p ls) @@ Zero @@ ls data Lambda22Sym0 a where KindInferenceLambda22Sym0 :: (Lambda22Sym0 @@ z) ~ Lambda22Sym1 z => Proxy z -> Lambda22Sym0 a type instance Apply Lambda22Sym0 a = Lambda22Sym1 a data Lambda22Sym1 a b where KindInferenceLambda22Sym1 :: (Lambda22Sym1 a @@ z) ~ Lambda22Sym2 a z => Proxy z -> Lambda22Sym1 a b type instance Apply (Lambda22Sym1 a) b = Lambda22 a b type family Lambda22Sym2 a b where Lambda22Sym2 a b = Lambda22 a b {- sFI :: forall a (t1 :: a ~> Bool) (t2 :: List a). Sing t1 -> Sing t2 -> Sing (FISym0 @@ t1 @@ t2) sFI = unSingFun2 (singFun2 @FI (\p ls -> let lambda :: forall {-(t1 :: a ~> Bool)-} t1 t2. Sing t1 -> Sing t2 -> Sing (Lambda22Sym0 @@ t1 @@ t2) lambda sP sLs = let sLoop :: (Lambda22Sym0 @@ t1 @@ t2) ~ (Let123LoopSym2 t1 t2 @@ Zero @@ t2) => forall (u1 :: Nat). Sing u1 -> forall {-(u2 :: List a)-} u2. Sing u2 -> Sing ((Let123LoopSym2 t1 t2) @@ u1 @@ u2) sLoop _ SNil = SNil sLoop sN (sX `SCons` sXs) = case sP @@ sX of STrue -> (singFun2 @ConsSym0 SCons) @@ sN @@ ((singFun2 @(Let123LoopSym2 t1 t2) sLoop) @@ ((singFun1 @SuccSym0 SSucc) @@ sN) @@ sXs) SFalse -> (singFun2 @(Let123LoopSym2 t1 t2) sLoop) @@ ((singFun1 @SuccSym0 SSucc) @@ sN) @@ sXs in (singFun2 @(Let123LoopSym2 t1 t2) sLoop) @@ SZero @@ sLs in lambda p ls )) -} ------------------------------------------------------------ #if __GLASGOW_HASKELL__ >= 810 type G :: Type -> Type #endif data G :: Type -> Type where MkG :: G Bool #if __GLASGOW_HASKELL__ >= 810 type SG :: forall a. G a -> Type #endif data SG :: forall a. G a -> Type where SMkG :: SG MkG type instance Sing = SG singletons-3.0.3/tests/ByHand2.hs0000644000000000000000000001434507346545000015027 0ustar0000000000000000{-# LANGUAGE DataKinds, PolyKinds, TypeFamilies, GADTs, TypeOperators, DefaultSignatures, ScopedTypeVariables, InstanceSigs, MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances, CPP #-} {-# OPTIONS_GHC -Wno-missing-signatures -Wno-orphans #-} #if __GLASGOW_HASKELL__ < 806 {-# LANGUAGE TypeInType #-} #endif #if __GLASGOW_HASKELL__ >= 810 {-# LANGUAGE StandaloneKindSignatures #-} #endif module ByHand2 where import Data.Kind import Data.Singletons (Sing) #if __GLASGOW_HASKELL__ >= 810 type Nat :: Type #endif data Nat = Zero | Succ Nat #if __GLASGOW_HASKELL__ >= 810 type SNat :: Nat -> Type #endif data SNat :: Nat -> Type where SZero :: SNat 'Zero SSucc :: SNat n -> SNat ('Succ n) type instance Sing = SNat {- type Bool :: Type data Bool = False | True -} #if __GLASGOW_HASKELL__ >= 810 type SBool :: Bool -> Type #endif data SBool :: Bool -> Type where SFalse :: SBool 'False STrue :: SBool 'True type instance Sing = SBool {- type Ordering :: Type data Ordering = LT | EQ | GT -} #if __GLASGOW_HASKELL__ >= 810 type SOrdering :: Ordering -> Type #endif data SOrdering :: Ordering -> Type where SLT :: SOrdering 'LT SEQ :: SOrdering 'EQ SGT :: SOrdering 'GT type instance Sing = SOrdering {- not :: Bool -> Bool not True = False not False = True -} #if __GLASGOW_HASKELL__ >= 810 type Not :: Bool -> Bool #endif type family Not (x :: Bool) :: Bool where Not 'True = 'False Not 'False = 'True sNot :: Sing b -> Sing (Not b) sNot STrue = SFalse sNot SFalse = STrue {- type Eq :: Type -> Constraint class Eq a where (==) :: a -> a -> Bool (/=) :: a -> a -> Bool infix 4 ==, /= x == y = not (x /= y) x /= y = not (x == y) -} #if __GLASGOW_HASKELL__ >= 810 type PEq :: Type -> Constraint #endif class PEq a where type (==) (x :: a) (y :: a) :: Bool type (/=) (x :: a) (y :: a) :: Bool type x == y = Not (x /= y) type x /= y = Not (x == y) #if __GLASGOW_HASKELL__ >= 810 type SEq :: Type -> Constraint #endif class SEq a where (%==) :: Sing (x :: a) -> Sing (y :: a) -> Sing (x == y) (%/=) :: Sing (x :: a) -> Sing (y :: a) -> Sing (x /= y) default (%==) :: ((x == y) ~ (Not (x /= y))) => Sing (x :: a) -> Sing (y :: a) -> Sing (x == y) x %== y = sNot (x %/= y) default (%/=) :: ((x /= y) ~ (Not (x == y))) => Sing (x :: a) -> Sing (y :: a) -> Sing (x /= y) x %/= y = sNot (x %== y) instance Eq Nat where Zero == Zero = True Zero == Succ _ = False Succ _ == Zero = False Succ x == Succ y = x == y instance PEq Nat where type 'Zero == 'Zero = 'True type 'Succ x == 'Zero = 'False type 'Zero == 'Succ x = 'False type 'Succ x == 'Succ y = x == y instance SEq Nat where (%==) :: forall (x :: Nat) (y :: Nat). Sing x -> Sing y -> Sing (x == y) SZero %== SZero = STrue SSucc _ %== SZero = SFalse SZero %== SSucc _ = SFalse SSucc x %== SSucc y = x %== y {- instance Eq Ordering where LT == LT = True LT == EQ = False LT == GT = False EQ == LT = False EQ == EQ = True EQ == GT = False GT == LT = False GT == EQ = False GT == GT = True -} instance PEq Ordering where type 'LT == 'LT = 'True type 'LT == 'EQ = 'False type 'LT == 'GT = 'False type 'EQ == 'LT = 'False type 'EQ == 'EQ = 'True type 'EQ == 'GT = 'False type 'GT == 'LT = 'False type 'GT == 'EQ = 'False type 'GT == 'GT = 'True instance SEq Ordering where SLT %== SLT = STrue SLT %== SEQ = SFalse SLT %== SGT = SFalse SEQ %== SLT = SFalse SEQ %== SEQ = STrue SEQ %== SGT = SFalse SGT %== SLT = SFalse SGT %== SEQ = SFalse SGT %== SGT = STrue {- type Ord :: Type -> Constraint class Eq a => Ord a where compare :: a -> a -> Ordering (<) :: a -> a -> Bool x < y = compare x y == LT -} #if __GLASGOW_HASKELL__ >= 810 type POrd :: Type -> Constraint #endif class PEq a => POrd a where type Compare (x :: a) (y :: a) :: Ordering type (<) (x :: a) (y :: a) :: Bool type x < y = Compare x y == 'LT #if __GLASGOW_HASKELL__ >= 810 type SOrd :: Type -> Constraint #endif class SEq a => SOrd a where sCompare :: Sing (x :: a) -> Sing (y :: a) -> Sing (Compare x y) (%<) :: Sing (x :: a) -> Sing (y :: a) -> Sing (x < y) default (%<) :: ((x < y) ~ (Compare x y == 'LT)) => Sing (x :: a) -> Sing (y :: a) -> Sing (x < y) x %< y = sCompare x y %== SLT instance Ord Nat where compare Zero Zero = EQ compare Zero (Succ _) = LT compare (Succ _) Zero = GT compare (Succ a) (Succ b) = compare a b instance POrd Nat where type Compare 'Zero 'Zero = 'EQ type Compare 'Zero ('Succ x) = 'LT type Compare ('Succ x) 'Zero = 'GT type Compare ('Succ x) ('Succ y) = Compare x y instance SOrd Nat where sCompare SZero SZero = SEQ sCompare SZero (SSucc _) = SLT sCompare (SSucc _) SZero = SGT sCompare (SSucc x) (SSucc y) = sCompare x y #if __GLASGOW_HASKELL__ >= 810 type Pointed :: Type -> Constraint #endif class Pointed a where point :: a #if __GLASGOW_HASKELL__ >= 810 type PPointed :: Type -> Constraint #endif class PPointed a where type Point :: a #if __GLASGOW_HASKELL__ >= 810 type SPointed :: Type -> Constraint #endif class SPointed a where sPoint :: Sing (Point :: a) instance Pointed Nat where point = Zero instance PPointed Nat where type Point = 'Zero instance SPointed Nat where sPoint = SZero -------------------------------- #if __GLASGOW_HASKELL__ >= 810 type FD :: Type -> Type -> Constraint #endif class FD a b | a -> b where meth :: a -> a l2r :: a -> b instance FD Bool Nat where meth = not l2r False = Zero l2r True = Succ Zero t1 = meth True t2 = l2r False #if __GLASGOW_HASKELL__ >= 810 type PFD :: Type -> Type -> Constraint #endif class PFD a b | a -> b where type Meth (x :: a) :: a type L2r (x :: a) :: b instance PFD Bool Nat where type Meth a = Not a type L2r 'False = 'Zero type L2r 'True = 'Succ 'Zero type T1 = Meth 'True #if __GLASGOW_HASKELL__ >= 810 type T2 :: Nat #endif type T2 = (L2r 'False :: Nat) #if __GLASGOW_HASKELL__ >= 810 type SFD :: Type -> Type -> Constraint #endif class SFD a b | a -> b where sMeth :: forall (x :: a). Sing x -> Sing (Meth x :: a) sL2r :: forall (x :: a). Sing x -> Sing (L2r x :: b) instance SFD Bool Nat where sMeth x = sNot x sL2r SFalse = SZero sL2r STrue = SSucc SZero sT1 = sMeth STrue sT2 :: Sing T2 sT2 = sL2r SFalse singletons-3.0.3/tests/SingletonsTestSuite.hs0000644000000000000000000000032207346545000017565 0ustar0000000000000000-- | Currently, there is code to execute at runtime as a part of this test -- suite, as the only interesting part is making sure that the code typechecks. module Main (main) where main :: IO () main = pure ()