diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,744 @@ -Changelog for singletons project -================================ +Changelog for the `singletons` project +====================================== + +3.0.4 [2024.12.11] +------------------ +* Define `Sing` instances such that they explicitly match on their types on the + left-hand sides (e.g., define `type instance Sing @(k1 ~> k2) = SLambda` + instead of `type instance Sing = SLambda`. Doing so will make `singletons` + future-proof once + [GHC#23515](https://gitlab.haskell.org/ghc/ghc/-/issues/23515) is fixed. + +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 ------ diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2012, Richard Eisenberg +Copyright (c) 2012-2020, Richard Eisenberg All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,337 +1,24 @@ -singletons 0.10 -=============== - -[![Build Status](https://travis-ci.org/goldfirere/singletons.svg?branch=master)](https://travis-ci.org/goldfirere/singletons) - -This is the README file for the singletons library. This file contains all the -documentation for the definitions and functions in the library. - -The singletons library was written by Richard Eisenberg, eir@cis.upenn.edu. -See also _Dependently typed programming with singletons_, available -[here](http://www.cis.upenn.edu/~eir/papers/2012/singletons/paper.pdf). - -Purpose of the singletons library ---------------------------------- - -The library contains a definition of _singleton types_, which allow -programmers to use dependently typed techniques to enforce rich constraints -among the types in their programs. See the paper cited above for a -more thorough introduction. - -Compatibility -------------- - -The singletons library requires GHC version 7.6.3 or greater. -Any code that uses the singleton generation primitives will also need -to enable a long list of GHC extensions. This list includes, but -is not necessarily limited to, the following: - -* `ScopedTypeVariables` (absolutely required) -* `TemplateHaskell` -* `TypeFamilies` -* `GADTs` -* `KindSignatures` -* `DataKinds` -* `PolyKinds` -* `TypeOperators` -* `FlexibleContexts` -* `RankNTypes` -* `UndecidableInstances` -* `FlexibleInstances` - -Modules -------- - -`Data.Singletons` exports all the basic singletons definitions. Import this -module if you are not using Template Haskell and wish only to define your -own singletons. - -`Data.Singletons.TH` exports all the definitions needed to use the Template -Haskell code to generate new singletons. - -`Data.Singletons.Prelude` re-exports `Data.Singletons` along with singleton -definitions for various Prelude types. This module is intended to export -those definitions that are exported by the real `Prelude`. - -There are several modules that echo standard modules. For example, -`Data.Singletons.Maybe` exports singleton definitions for `Data.Maybe`. -These modules are: `List` (many definitions are missing), `Bool`, -`Maybe`, `Either`, `Tuple`. - -`Data.Singletons.Eq` and `Data.Singletons.Decide` export type classes for -Boolean and propositional equality, respectively. - -`Data.Singletons.TypeLits` exports definitions for working with `GHC.TypeLits`. -In GHC 7.6.3, `Data.Singletons.TypeLits` defines and exports `KnownNat` and -`KnownSymbol`, which are part of `GHC.TypeLits` in GHC 7.8. This makes cross-version -support a little easier. - -`Data.Singletons.Void` exports a `Void` type, shamelessly copied from -Edward Kmett's `void` package, but without the great many package dependencies -in `void`. - -`Data.Singletons.Types` exports a few type-level definitions that are in -`base` for GHC 7.8, but not in GHC 7.6.3. By importing this package, users -of both GHC versions can access these definitions. - -Functions to generate singletons --------------------------------- - -The top-level functions used to generate singletons are documented in the -`Data.Singletons.TH` module. The most common case is just calling `singletons`, -which I'll describe here: - - singletons :: Q [Dec] -> Q [Dec] - -Generates singletons from the definitions given. Because singleton generation -requires promotion, this also promotes all of the definitions given to the -type level. - -To use: - $(singletons [d| - data Nat = Zero | Succ Nat - pred :: Nat -> Nat - pred Zero = Zero - pred (Succ n) = n - |]) - -Definitions used to support singletons --------------------------------------- - -Please refer to the paper cited above for a more in-depth explanation of these -definitions. Many of the definitions were developed in tandem with Iavor Diatchki. - - data family Sing (a :: k) - -The data family of singleton types. A new instance of this data family is -generated for every new singleton type. - - class SingI (a :: k) where - sing :: Sing a - -A class used to pass singleton values implicitly. The `sing` method produces -an explicit singleton value. - - data SomeSing (kproxy :: KProxy k) where - SomeSing :: Sing (a :: k) -> SomeSing ('KProxy :: KProxy k) - -The `SomeSing` type wraps up an _existentially-quantified_ singleton. Note that -the type parameter `a` does not appear in the `SomeSing` type. Thus, this type -can be used when you have a singleton, but you don't know at compile time what -it will be. `SomeSing ('KProxy :: KProxy Thing)` is isomorphic to `Thing`. - - class (kparam ~ 'KProxy) => SingKind (kparam :: KProxy k) where - type DemoteRep kparam :: * - fromSing :: Sing (a :: k) -> DemoteRep kparam - toSing :: DemoteRep kparam -> SomeSing kparam - -This class is used to convert a singleton value back to a value in the -original, unrefined ADT. The `fromSing` method converts, say, a -singleton `Nat` back to an ordinary `Nat`. The `toSing` method produces -an existentially-quantified singleton, wrapped up in a `SomeSing`. -The `DemoteRep` associated -kind-indexed type family maps a proxy of the kind `Nat` -back to the type `Nat`. - - data SingInstance (a :: k) where - SingInstance :: SingI a => SingInstance a - singInstance :: Sing a -> SingInstance a - -Sometimes you have an explicit singleton (a `Sing`) where you need an implicit -one (a dictionary for `SingI`). The `SingInstance` type simply wraps a `SingI` -dictionary, and the `singInstance` function produces this dictionary from an -explicit singleton. The `singInstance` function runs in constant time, using -a little magic. - - -Equality classes ----------------- - -There are two different notions of equality applicable to singletons: Boolean -equality and propositional equality. - -* Boolean equality is implemented in the type family `(:==)` (which is actually -a synonym for the type family `(==)` from `Data.Type.Equality`) and the class -`SEq`. See the `Data.Singletons.Eq` module for more information. - -* Propositional equality is implemented through the constraint `(~)`, the type -`(:~:)`, and the class `SDecide`. See modules `Data.Type.Equality` and -`Data.Singletons.Decide` for more information. - -Which one do you need? That depends on your application. Boolean equality has -the advantage that your program can take action when two types do _not_ equal, -while propositional equality has the advantage that GHC can use the equality -of types during type inference. - -Instances of both `SEq` and `SDecide` are generated when `singletons` is called -on a datatype that has `deriving Eq`. You can also generate these instances -directly through functions exported from `Data.Singletons.TH`. - - -Pre-defined singletons ----------------------- - -The singletons library defines a number of singleton types and functions -by default: - -* `Bool` -* `Maybe` -* `Either` -* `Ordering` -* `()` -* tuples up to length 7 -* lists - -These are all available through `Data.Singletons.Prelude`. Functions that -operate on these singletons are available from modules such as `Data.Singletons.Bool` -and `Data.Singletons.Maybe`. - - -On names --------- - -The singletons library has to produce new names for the new constructs it -generates. Here are some examples showing how this is done: - -original datatype: `Nat` -promoted kind: `Nat` -singleton type: `SNat` (which is really a synonym for `Sing`) - -original datatype: `:/\:` -promoted kind: `:/\:` -singleton type: `:%/\:` - -original constructor: `Zero` -promoted type: `'Zero` (you can use `Zero` when unambiguous) -singleton constructor: `SZero` - -original constructor: `:+:` -promoted type: `':+:` -singleton constructor: `:%+:` - -original value: `pred` -promoted type: `Pred` -singleton value: `sPred` - -original value: `+` -promoted type: `:+` -singleton value: `%:+` - - -Special names -------------- - -There are some special cases: - -original datatype: `[]` -singleton type: `SList` - -original constructor: `[]` -singleton constructor: `SNil` - -original constructor: `:` -singleton constructor: `SCons` - -original datatype: `(,)` -singleton type: `STuple2` - -original constructor: `(,)` -singleton constructor: `STuple2` - -All tuples (including the 0-tuple, unit) are treated similarly. - -original value: `undefined` -promoted type: `Any` -singleton value: `undefined` - - -Supported Haskell constructs ----------------------------- - -The following constructs are fully supported: - -* variables -* tuples -* constructors -* if statements -* infix expressions -* !, ~, and _ patterns -* aliased patterns (except at top-level) -* lists -* (+) sections -* (x +) sections -* undefined -* error -* deriving Eq -* class constraints -* literals (for `Nat` and `Symbol`) - -The following constructs will be coming soon: - -* unboxed tuples -* records -* scoped type variables -* overlapping patterns -* pattern guards -* (+ x) sections -* case -* let -* list comprehensions -* lambda expressions -* do -* arithmetic sequences - -As described briefly in the paper, the singletons generation mechanism does not -currently work for higher-order datatypes (though higher-order functions are -just peachy). So, if you have a declaration such as - - data Foo = Bar (Bool -> Maybe Bool) - -its singleton will not work correctly. It turns out that getting this to work -requires fairly thorough changes to the whole singleton generation scheme. -Please shout (to eir@cis.upenn.edu) if you have a compelling use case for this -and I can take a look at it. No promises, though. - -Support for `*` ---------------- - -The built-in Haskell promotion mechanism does not yet have a full story around -the kind `*` (the kind of types that have values). Ideally, promoting some form -of `TypeRep` would yield `*`, but the implementation of TypeRep would have to be -updated for this to really work out. In the meantime, users who wish to -experiment with this feature have two options: - -1) The module `Data.Singletons.TypeRepStar` has all the definitions possible for -making `*` the promoted version of `TypeRep`, as `TypeRep` is currently implemented. -The singleton associated with `TypeRep` has one constructor: - - data instance Sing (a :: *) where - STypeRep :: Typeable a => Sing a - -Thus, an implicit `TypeRep` is stored in the singleton constructor. However, -any datatypes that store `TypeRep`s will not generally work as expected; the -built-in promotion mechanism will not promote `TypeRep` to `*`. - -2) The module `Data.Singletons.CustomStar` allows the programmer to define a subset -of types with which to work. See the Haddock documentation for the function -`singletonStar` for more info. - -Changes from earlier versions ------------------------------ +`singletons` +============ -singletons 0.9 contains a bit of an API change from previous versions. Here is -a summary: +[![Hackage](https://img.shields.io/hackage/v/singletons.svg)](http://hackage.haskell.org/package/singletons) -* There are no more "smart" constructors. Those were necessary because each -singleton used to carry both explicit and implicit versions of any children -nodes. However, this leads to exponential overhead! Now, the magic (i.e., a -use of `unsafeCoerce`) in `singInstance` gets rid of the need for storing -implicit singletons. The smart constructors did some of the work of managing -the stored implicits, so they are no longer needed. +`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. -* `SingE` and `SingRep` are gone. If you need to carry an implicit singleton, -use `SingI`. Otherwise, you probably want `SingKind`. +`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). -* The Template Haskell functions are now exported from `Data.Singletons.TH`. +You may also be interested in the following related libraries: -* The Prelude singletons are now exported from `Data.Singletons.Prelude`. +* 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`. diff --git a/singletons.cabal b/singletons.cabal --- a/singletons.cabal +++ b/singletons.cabal @@ -1,92 +1,82 @@ name: singletons -version: 0.10.0 - -- Remember to bump version in the Makefile as well -cabal-version: >= 1.10 -synopsis: A framework for generating singleton types -homepage: http://www.cis.upenn.edu/~eir/packages/singletons +version: 3.0.4 +cabal-version: 1.24 +synopsis: Basic singleton types and definitions +homepage: http://www.github.com/goldfirere/singletons category: Dependent Types -author: Richard Eisenberg -maintainer: Richard Eisenberg +author: Richard Eisenberg , Jan Stolarek +maintainer: Ryan Scott bug-reports: https://github.com/goldfirere/singletons/issues stability: experimental -tested-with: GHC ==7.6.3, GHC ==7.8.* -extra-source-files: README.md, CHANGES.md, - tests/compile-and-dump/buildGoldenFiles.awk, - tests/compile-and-dump/GradingClient/*.hs, - tests/compile-and-dump/InsertionSort/*.hs, - tests/compile-and-dump/Promote/*.hs, - tests/compile-and-dump/Singletons/*.hs - tests/compile-and-dump/GradingClient/*.ghc76.template, - tests/compile-and-dump/InsertionSort/*.ghc76.template, - tests/compile-and-dump/Promote/*.ghc76.template, - tests/compile-and-dump/Singletons/*.ghc76.template, - tests/compile-and-dump/GradingClient/*.ghc78.template, - tests/compile-and-dump/InsertionSort/*.ghc78.template, - tests/compile-and-dump/Promote/*.ghc78.template, - tests/compile-and-dump/Singletons/*.ghc78.template +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.6 + , GHC == 9.8.2 + , GHC == 9.10.1 + , GHC == 9.12.1 +extra-source-files: README.md, CHANGES.md license: BSD3 license-file: LICENSE build-type: Simple description: - This library generates singleton types, promoted functions, and singleton - functions using Template Haskell. It is useful for programmers who wish - to use dependently typed programming techniques. The library was originally - presented in /Dependently Typed Programming with Singletons/, published - at the Haskell Symposium, 2012. - () - - The Haddock documentation does not build with the Haddock distributed with - GHC 7.6.x, but it does build with 7.8.1. Please see links from the project - homepage to find the built documentation. + @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 - tag: v0.10.0 + 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.6 && < 5, - mtl >= 2.1.1, - template-haskell, - containers >= 0.5, - th-desugar >= 1.2 + build-depends: base >= 4.9 && < 4.22 default-language: Haskell2010 - exposed-modules: Data.Singletons, - Data.Singletons.CustomStar, - Data.Singletons.TypeRepStar, - Data.Singletons.List, - Data.Singletons.Bool, - Data.Singletons.Maybe, - Data.Singletons.Either, - Data.Singletons.Tuple - Data.Singletons.TH, - Data.Singletons.Eq, - Data.Singletons.Prelude, - Data.Singletons.Types, - Data.Singletons.TypeLits, - Data.Singletons.Decide, - Data.Singletons.Void - - other-modules: Data.Singletons.Promote, - Data.Singletons.Singletons, - Data.Singletons.Util, - Data.Singletons.Instances - + 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: src, tests - ghc-options: -Wall + hs-source-dirs: tests + ghc-options: -Wall -threaded default-language: Haskell2010 main-is: SingletonsTestSuite.hs - other-modules: SingletonsTestSuiteUtils + other-modules: ByHand + ByHand2 - build-depends: base >= 4.6 && < 5, - constraints, - filepath >= 1.3, - process >= 1.1, - tasty >= 0.6, - tasty-golden >= 2.2, - Cabal >= 1.16 + build-depends: base >= 4.9 && < 4.22, + singletons diff --git a/src/Data/Singletons.hs b/src/Data/Singletons.hs --- a/src/Data/Singletons.hs +++ b/src/Data/Singletons.hs @@ -1,182 +1,1363 @@ -{-# LANGUAGE MagicHash, RankNTypes, PolyKinds, GADTs, DataKinds, - FlexibleContexts, CPP, TypeFamilies #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- This module exports the basic definitions to use singletons. For routine --- use, consider importing 'Data.Singletons.Prelude', which exports constructors --- for singletons based on types in the @Prelude@. --- --- You may also want to read --- and the --- original paper presenting this library, available at --- . --- ----------------------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ < 707 - -- optimizing instances of SDecide cause GHC to die (#8467) -{-# OPTIONS_GHC -O0 #-} -#endif - -module Data.Singletons ( - -- * Main singleton definitions - - Sing, - -- | See also 'Data.Singletons.Prelude.Sing' for exported constructors - - SingI(..), SingKind(..), - - -- * Working with singletons - KindOf, Demote, - SingInstance(..), SomeSing(..), - singInstance, withSingI, withSomeSing, singByProxy, - -#if __GLASGOW_HASKELL__ >= 707 - singByProxy#, -#endif - withSing, singThat, - - -- * Auxiliary functions - bugInGHC, - KProxy(..), Proxy(..) - ) where - -import Unsafe.Coerce - -#if __GLASGOW_HASKELL__ >= 707 -import GHC.Exts ( Proxy# ) -import Data.Proxy -#else -import Data.Singletons.Types -#endif - --- | Convenient synonym to refer to the kind of a type variable: --- @type KindOf (a :: k) = ('KProxy :: KProxy k)@ -type KindOf (a :: k) = ('KProxy :: KProxy k) - ----------------------------------------------------------------------- ----- Sing & friends -------------------------------------------------- ----------------------------------------------------------------------- - --- | The singleton kind-indexed data family. -data family Sing (a :: k) - --- | A 'SingI' constraint is essentially an implicitly-passed singleton. --- If you need to satisfy this constraint with an explicit singleton, please --- see 'withSingI'. -class SingI (a :: k) where - -- | Produce the singleton explicitly. You will likely need the @ScopedTypeVariables@ - -- extension to use this method the way you want. - sing :: Sing a - --- | The 'SingKind' class is essentially 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. -class (kparam ~ 'KProxy) => SingKind (kparam :: KProxy k) where - -- | Get a base type from a proxy for the promoted kind. For example, - -- @DemoteRep ('KProxy :: KProxy Bool)@ will be the type @Bool@. - type DemoteRep kparam :: * - - -- | Convert a singleton to its unrefined version. - fromSing :: Sing (a :: k) -> DemoteRep kparam - - -- | Convert an unrefined type to an existentially-quantified singleton type. - toSing :: DemoteRep kparam -> SomeSing kparam - --- | Convenient abbreviation for 'DemoteRep': --- @type Demote (a :: k) = DemoteRep ('KProxy :: KProxy k)@ -type Demote (a :: k) = DemoteRep ('KProxy :: KProxy 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'. -data SomeSing (kproxy :: KProxy k) where - SomeSing :: Sing (a :: k) -> SomeSing ('KProxy :: KProxy k) - ----------------------------------------------------------------------- ----- SingInstance ---------------------------------------------------- ----------------------------------------------------------------------- - --- | A 'SingInstance' wraps up a 'SingI' instance for explicit handling. -data SingInstance (a :: k) where - SingInstance :: SingI a => SingInstance a - --- dirty implementation of explicit-to-implicit conversion -newtype DI a = Don'tInstantiate (SingI a => SingInstance a) - --- | Get an implicit singleton (a 'SingI' instance) from an explicit one. -singInstance :: forall (a :: k). Sing a -> SingInstance a -singInstance s = with_sing_i SingInstance - where - with_sing_i :: (SingI a => SingInstance a) -> SingInstance a - with_sing_i si = unsafeCoerce (Don'tInstantiate si) s - ----------------------------------------------------------------------- ----- 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 :: SingKind ('KProxy :: KProxy k) - => DemoteRep ('KProxy :: KProxy 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' - --- | 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 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 (a :: k). (SingKind ('KProxy :: KProxy k), SingI a) - => (Demote a -> Bool) -> Maybe (Sing a) -singThat p = withSing $ \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 - -#if __GLASGOW_HASKELL__ >= 707 --- | Allows creation of a singleton when a @proxy#@ is at hand. -singByProxy# :: SingI a => Proxy# a -> Sing a -singByProxy# _ = sing -#endif - --- | GHC 7.8 sometimes warns about incomplete pattern matches when no such --- patterns are possible, due to GADT constraints. --- See the bug report at . --- In such cases, it's useful to have a catch-all pattern that then has --- 'bugInGHC' as its right-hand side. -bugInGHC :: forall a. a -bugInGHC = error "Bug encountered in GHC -- this should never happen" - +{-# 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 v'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 +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @(WrappedSing a) = +#else +type instance Sing = +#endif + 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 +#if __GLASGOW_HASKELL__ >= 808 +type instance Apply @k1 @k3 (TyCon @k1 @k2 @(k1 ~> k3) f) x = +#else +type instance Apply (TyCon f) x = +#endif + 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) } +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @(k1 ~> k2) = +#else +type instance Sing = +#endif + 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 +@ +-} diff --git a/src/Data/Singletons/Bool.hs b/src/Data/Singletons/Bool.hs deleted file mode 100644 --- a/src/Data/Singletons/Bool.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE TemplateHaskell, DataKinds, PolyKinds, TypeFamilies, TypeOperators, - GADTs, CPP #-} - -#if __GLASGOW_HASKELL__ < 707 -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -#endif - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Bool --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines functions and datatypes relating to the singleton for 'Bool', --- including a singletons version of all the definitions in @Data.Bool@. --- --- Because many of these definitions are produced by Template Haskell, --- it is not possible to create proper Haddock documentation. Please look --- up the corresponding operation in @Data.Bool@. Also, please excuse --- the apparent repeated variable names. This is due to an interaction --- between Template Haskell and Haddock. --- ----------------------------------------------------------------------------- - -module Data.Singletons.Bool ( - -- * The 'Bool' singleton - - Sing(SFalse, STrue), - -- | Though Haddock doesn't show it, the 'Sing' instance above declares - -- constructors - -- - -- > SFalse :: Sing False - -- > STrue :: Sing True - - SBool, - -- | 'SBool' is a kind-restricted synonym for 'Sing': @type SBool (a :: Bool) = Sing a@ - - -- * Conditionals - If, sIf, - - -- * Singletons from @Data.Bool@ - Not, sNot, (:&&), (:||), (%:&&), (%:||), - - -- | The following are derived from the function 'bool' in @Data.Bool@. The extra - -- underscore is to avoid name clashes with the type 'Bool'. - Bool_, sBool_, Otherwise, sOtherwise - ) where - -import Data.Singletons -import Data.Singletons.Instances -import Data.Singletons.Singletons -import Data.Singletons.Types - -#if __GLASGOW_HASKELL__ >= 707 -import Data.Type.Bool - -type a :&& b = a && b -type a :|| b = a || b - -(%:&&) :: SBool a -> SBool b -> SBool (a :&& b) -SFalse %:&& _ = SFalse -STrue %:&& a = a - -(%:||) :: SBool a -> SBool b -> SBool (a :|| b) -SFalse %:|| a = a -STrue %:|| _ = STrue - -#else - -$(singletonsOnly [d| - (&&) :: Bool -> Bool -> Bool - False && _ = False - True && x = x - - (||) :: Bool -> Bool -> Bool - False || x = x - True || _ = True - |]) - -#endif - -sNot :: SBool a -> SBool (Not a) -sNot SFalse = STrue -sNot STrue = SFalse - --- | Conditional over singletons -sIf :: Sing a -> Sing b -> Sing c -> Sing (If a b c) -sIf STrue b _ = b -sIf SFalse _ c = c - --- ... with some functions over Booleans -$(singletonsOnly [d| - bool_ :: a -> a -> Bool -> a - bool_ fls _tru False = fls - bool_ _fls tru True = tru - - otherwise :: Bool - otherwise = True - |]) diff --git a/src/Data/Singletons/CustomStar.hs b/src/Data/Singletons/CustomStar.hs deleted file mode 100644 --- a/src/Data/Singletons/CustomStar.hs +++ /dev/null @@ -1,181 +0,0 @@ -{-# LANGUAGE DataKinds, TypeFamilies, KindSignatures, CPP, TemplateHaskell #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.CustomStar --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- This file implements 'singletonStar', which generates a datatype @Rep@ and associated --- singleton from a list of types. The promoted version of @Rep@ is kind @*@ and the --- Haskell types themselves. This is still very experimental, so expect unusual --- results! --- ----------------------------------------------------------------------------- - -module Data.Singletons.CustomStar ( singletonStar ) where - -import Language.Haskell.TH -import Language.Haskell.TH.Syntax ( Quasi(..) ) -import Data.Singletons.Util -import Data.Singletons.Promote -import Data.Singletons.Singletons -import Control.Monad - -#if __GLASGOW_HASKELL__ >= 707 -import Data.Singletons.Decide -import Data.Singletons.Instances -import Data.Singletons.Eq -import Unsafe.Coerce -#endif - -{- -The SEq instance here is tricky. -The problem is that, in GHC 7.8+, the instance of type-level (==) for * -is not recursive. Thus, it's impossible, say, to get (Maybe a == Maybe b) ~ False -from (a == b) ~ False. - -There are a few ways forward: - 1) Define SEq to use our own Boolean (==) operator, instead of the built-in one. - This would work, but feels wrong. - 2) Use unsafeCoerce. -We do #2. - -Also to note: because these problems don't exist in GHC 7.6, the generation of -Eq and Decide for 7.6 is entirely normal. - -Note that mkCustomEqInstances makes the SDecide and SEq instances in GHC 7.8+, -but the type-level (==) instance in GHC 7.6. This is perhaps poor design, but -it reduces the amount of CPP noise. --} - --- | Produce a representation and singleton for the collection of types given. --- --- A datatype @Rep@ is created, with one constructor per type in the declared --- universe. When this type is promoted by the singletons library, the --- constructors become full types in @*@, not just promoted data constructors. --- --- For example, --- --- > $(singletonStar [''Nat, ''Bool, ''Maybe]) --- --- generates the following: --- --- > data Rep = Nat | Bool | Maybe Rep deriving (Eq, Show, Read) --- --- and its singleton. However, because @Rep@ is promoted to @*@, the singleton --- is perhaps slightly unexpected: --- --- > data instance Sing (a :: *) where --- > SNat :: Sing Nat --- > SBool :: Sing Bool --- > SMaybe :: SingRep a => Sing a -> Sing (Maybe a) --- --- The unexpected part is that @Nat@, @Bool@, and @Maybe@ above are the real @Nat@, --- @Bool@, and @Maybe@, not just promoted data constructors. --- --- Please note that this function is /very/ experimental. Use at your own risk. -singletonStar :: Quasi q - => [Name] -- ^ A list of Template Haskell @Name@s for types - -> q [Dec] -singletonStar names = do - kinds <- mapM getKind names - ctors <- zipWithM (mkCtor True) names kinds - let repDecl = DataD [] repName [] ctors - [''Eq, ''Show, ''Read] - fakeCtors <- zipWithM (mkCtor False) names kinds - eqInstances <- mkCustomEqInstances fakeCtors - singletonDecls <- singDataD True [] repName [] fakeCtors - [''Show, ''Read -#if __GLASGOW_HASKELL__ < 707 - , ''Eq -#endif - ] - return $ repDecl : - eqInstances ++ - singletonDecls - where -- get the kinds of the arguments to the tycon with the given name - getKind :: Quasi q => Name -> q [Kind] - getKind name = do - info <- reifyWithWarning name - case info of - TyConI (DataD (_:_) _ _ _ _) -> - fail "Cannot make a representation of a constrainted data type" - TyConI (DataD [] _ tvbs _ _) -> - return $ map extractTvbKind tvbs - TyConI (NewtypeD (_:_) _ _ _ _) -> - fail "Cannot make a representation of a constrainted newtype" - TyConI (NewtypeD [] _ tvbs _ _) -> - return $ map extractTvbKind tvbs - TyConI (TySynD _ tvbs _) -> - return $ map extractTvbKind tvbs - PrimTyConI _ n _ -> - return $ replicate n StarT - _ -> fail $ "Invalid thing for representation: " ++ (show name) - - -- first parameter is whether this is a real ctor (with a fresh name) - -- or a fake ctor (when the name is actually a Haskell type) - mkCtor :: Quasi q => Bool -> Name -> [Kind] -> q Con - mkCtor real name args = do - (types, vars) <- evalForPair $ mapM kindToType args - let ctor = NormalC ((if real then reinterpret else id) name) - (map (\ty -> (NotStrict, ty)) types) - if length vars > 0 - then return $ ForallC (map PlainTV vars) [] ctor - else return ctor - - -- demote a kind back to a type, accumulating any unbound parameters - kindToType :: Quasi q => Kind -> QWithAux [Name] q Type - kindToType (ForallT _ _ _) = fail "Explicit forall encountered in kind" - kindToType (AppT k1 k2) = do - t1 <- kindToType k1 - t2 <- kindToType k2 - return $ AppT t1 t2 - kindToType (SigT _ _) = fail "Sort signature encountered in kind" - kindToType (VarT n) = do - addElement n - return $ VarT n - kindToType (ConT n) = return $ ConT n - kindToType (PromotedT _) = fail "Promoted type used as a kind" - kindToType (TupleT n) = return $ TupleT n - kindToType (UnboxedTupleT _) = fail "Unboxed tuple kind encountered" - kindToType ArrowT = return ArrowT - kindToType ListT = return ListT - kindToType (PromotedTupleT _) = fail "Promoted tuple kind encountered" - kindToType PromotedNilT = fail "Promoted nil kind encountered" - kindToType PromotedConsT = fail "Promoted cons kind encountered" - kindToType StarT = return $ ConT repName - kindToType ConstraintT = - fail $ "Cannot make a representation of a type that has " ++ - "an argument of kind Constraint" - kindToType (LitT _) = fail "Literal encountered at the kind level" - -mkCustomEqInstances :: Quasi q => [Con] -> q [Dec] -mkCustomEqInstances ctors = do -#if __GLASGOW_HASKELL__ >= 707 - let ctorVar = error "Internal error: Equality instance inspected ctor var" - sCtors <- evalWithoutAux $ mapM (singCtor ctorVar) ctors - decideInst <- mkEqualityInstance StarT sCtors sDecideClassDesc - - a <- qNewName "a" - b <- qNewName "b" - let eqInst = InstanceD - [] - (AppT (ConT ''SEq) (kindParam StarT)) - [FunD '(%:==) - [Clause [VarP a, VarP b] - (NormalB $ - CaseE (foldExp (VarE '(%~)) [VarE a, VarE b]) - [ Match (ConP 'Proved [ConP 'Refl []]) - (NormalB $ ConE 'STrue) [] - , Match (ConP 'Disproved [WildP]) - (NormalB $ AppE (VarE 'unsafeCoerce) - (ConE 'SFalse)) [] - ]) []]] - return [decideInst, eqInst] -#else - mapM mkEqTypeInstance [(c1, c2) | c1 <- ctors, c2 <- ctors] -#endif diff --git a/src/Data/Singletons/Decide.hs b/src/Data/Singletons/Decide.hs --- a/src/Data/Singletons/Decide.hs +++ b/src/Data/Singletons/Decide.hs @@ -1,13 +1,22 @@ {-# LANGUAGE CPP, RankNTypes, PolyKinds, DataKinds, TypeOperators, - TypeFamilies, FlexibleContexts, UndecidableInstances, GADTs #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} + 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 : Richard Eisenberg (eir@cis.upenn.edu) +-- Maintainer : Ryan Scott -- Stability : experimental -- Portability : non-portable -- @@ -20,12 +29,15 @@ SDecide(..), -- * Supporting definitions - (:~:)(..), Void, Refuted, Decision(..) + (:~:)(..), Void, Refuted, Decision(..), + decideEquality, decideCoercion ) where +import Data.Kind import Data.Singletons -import Data.Singletons.Types -import Data.Singletons.Void +import Data.Type.Coercion +import Data.Type.Equality +import Data.Void ---------------------------------------------------------------------- ---- SDecide --------------------------------------------------------- @@ -34,22 +46,50 @@ -- | 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. -class (kparam ~ 'KProxy) => SDecide (kparam :: KProxy k) where +#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 %~ -instance SDecide ('KProxy :: KProxy k) => TestEquality (Sing :: k -> *) where - testEquality a b = - case a %~ b of - Proved Refl -> Just Refl - Disproved _ -> Nothing +-- | 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 diff --git a/src/Data/Singletons/Either.hs b/src/Data/Singletons/Either.hs deleted file mode 100644 --- a/src/Data/Singletons/Either.hs +++ /dev/null @@ -1,107 +0,0 @@ -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TypeFamilies, GADTs, - DataKinds, PolyKinds, RankNTypes, UndecidableInstances, CPP #-} - -#if __GLASGOW_HASKELL__ < 707 -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -#endif - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Either --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines functions and datatypes relating to the singleton for 'Either', --- including a singletons version of all the definitions in @Data.Either@. --- --- Because many of these definitions are produced by Template Haskell, --- it is not possible to create proper Haddock documentation. Please look --- up the corresponding operation in @Data.Either@. Also, please excuse --- the apparent repeated variable names. This is due to an interaction --- between Template Haskell and Haddock. --- ----------------------------------------------------------------------------- - -module Data.Singletons.Either ( - -- * The 'Either' singleton - Sing(SLeft, SRight), - -- | Though Haddock doesn't show it, the 'Sing' instance above declares - -- constructors - -- - -- > SLeft :: Sing a -> Sing (Left a) - -- > SRight :: Sing b -> Sing (Right b) - - SEither, - -- | 'SEither' is a kind-restricted synonym for 'Sing': - -- @type SEither (a :: Either x y) = Sing a@ - - -- * Singletons from @Data.Either@ - Either_, sEither_, - -- | The preceding two definitions are derived from the function 'either' in - -- @Data.Either@. The extra underscore is to avoid name clashes with the type - -- 'Either'. - - Lefts, sLefts, Rights, sRights, - PartitionEithers, sPartitionEithers, IsLeft, sIsLeft, IsRight, sIsRight - ) where - -import Data.Singletons.Instances -import Data.Singletons.TH -import Data.Singletons.List - -$(singletonsOnly [d| - -- | Case analysis for the 'Either' type. - -- If the value is @'Left' a@, apply the first function to @a@; - -- if it is @'Right' b@, apply the second function to @b@. - either_ :: (a -> c) -> (b -> c) -> Either a b -> c - either_ f _ (Left x) = f x - either_ _ g (Right y) = g y - - -- | Extracts from a list of 'Either' all the 'Left' elements - -- All the 'Left' elements are extracted in order. - - lefts :: [Either a b] -> [a] - lefts [] = [] - lefts (Left x : xs) = x : lefts xs - lefts (Right _ : xs) = lefts xs - - -- | Extracts from a list of 'Either' all the 'Right' elements - -- All the 'Right' elements are extracted in order. - - rights :: [Either a b] -> [b] - rights [] = [] - rights (Left _ : xs) = rights xs - rights (Right x : xs) = x : rights xs - - -- | Partitions a list of 'Either' into two lists - -- All the 'Left' elements are extracted, in order, to the first - -- component of the output. Similarly the 'Right' elements are extracted - -- to the second component of the output. - - partitionEithers :: [Either a b] -> ([a],[b]) - partitionEithers es = partitionEithers_aux ([], []) es - - partitionEithers_aux :: ([a],[b]) -> [Either a b] -> ([a],[b]) - partitionEithers_aux (as,bs) [] = (reverse as,reverse bs) - partitionEithers_aux (as,bs) (Left a : es) = - partitionEithers_aux (a : as, bs) es - partitionEithers_aux (as,bs) (Right b : es) = - partitionEithers_aux (as, b : bs) es - - -- | Return `True` if the given value is a `Left`-value, `False` otherwise. - -- - -- /Since: 4.7.0.0/ - isLeft :: Either a b -> Bool - isLeft (Left _) = True - isLeft (Right _) = False - - -- | Return `True` if the given value is a `Right`-value, `False` otherwise. - -- - -- /Since: 4.7.0.0/ - isRight :: Either a b -> Bool - isRight (Left _) = False - isRight (Right _) = True - |]) diff --git a/src/Data/Singletons/Eq.hs b/src/Data/Singletons/Eq.hs deleted file mode 100644 --- a/src/Data/Singletons/Eq.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE TypeOperators, DataKinds, PolyKinds, TypeFamilies, - RankNTypes, FlexibleContexts, TemplateHaskell, - UndecidableInstances, GADTs, CPP #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Eq --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines the SEq singleton version of the Eq type class. --- ------------------------------------------------------------------------------ - -module Data.Singletons.Eq ( - SEq(..), - type (==), (:==), (:/=) - ) where - -import Data.Singletons.Util -import Data.Singletons.Bool -import Data.Singletons -import Data.Singletons.Singletons -import Data.Singletons.Instances -import Data.Singletons.Types -#if __GLASGOW_HASKELL__ < 707 -import Data.Singletons.Promote ( promoteEqInstances ) -#endif - --- | A type synonym conforming to singletons naming conventions -type a :/= b = Not (a :== b) - --- | The singleton analogue of 'Eq'. Unlike the definition for 'Eq', it is required --- that instances define a body for '(%:==)'. You may also supply a body for '(%:/=)'. -class (kparam ~ 'KProxy) => SEq (kparam :: KProxy k) where - -- | Boolean equality on singletons - (%:==) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Sing (a :== b) - - -- | Boolean disequality on singletons - (%:/=) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Sing (a :/= b) - a %:/= b = sNot (a %:== b) - - -#if __GLASGOW_HASKELL__ < 707 -$(promoteEqInstances basicTypes) -- these instances are in Data.Type.Equality -#endif - -$(singEqInstancesOnly basicTypes) diff --git a/src/Data/Singletons/Instances.hs b/src/Data/Singletons/Instances.hs deleted file mode 100644 --- a/src/Data/Singletons/Instances.hs +++ /dev/null @@ -1,29 +0,0 @@ -{- Data/Singletons/Instances.hs - -(c) Richard Eisenberg 2013 -eir@cis.upenn.edu - -This (internal) module contains the main class definitions for singletons, -re-exported from various places. - --} - -{-# LANGUAGE CPP, RankNTypes, DataKinds, PolyKinds, GADTs, TypeFamilies, - FlexibleContexts, TemplateHaskell, ScopedTypeVariables, - UndecidableInstances, TypeOperators, FlexibleInstances #-} -#if __GLASGOW_HASKELL__ < 707 - -- optimizing instances of SDecide cause GHC to die (#8467) -{-# OPTIONS_GHC -O0 #-} -#endif - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Data.Singletons.Instances where - -import Data.Singletons.Singletons -import Data.Singletons.Util - --- some useful singletons -$(genSingletons basicTypes) -$(singDecideInstances basicTypes) - diff --git a/src/Data/Singletons/List.hs b/src/Data/Singletons/List.hs deleted file mode 100644 --- a/src/Data/Singletons/List.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE CPP, TypeOperators, DataKinds, PolyKinds, TypeFamilies, - TemplateHaskell, GADTs, UndecidableInstances #-} - -#if __GLASGOW_HASKELL__ < 707 -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -#endif - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.List --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines functions and datatypes relating to the singleton for '[]', --- including a singletons version of a few of the definitions in @Data.List@. --- --- Because many of these definitions are produced by Template Haskell, --- it is not possible to create proper Haddock documentation. Please look --- up the corresponding operation in @Data.List@. Also, please excuse --- the apparent repeated variable names. This is due to an interaction --- between Template Haskell and Haddock. --- ----------------------------------------------------------------------------- - -module Data.Singletons.List ( - -- * The singleton for lists - Sing(SNil, SCons), - -- | Though Haddock doesn't show it, the 'Sing' instance above declares - -- constructors - -- - -- > SNil :: Sing '[] - -- > SCons :: Sing (h :: k) -> Sing (t :: [k]) -> Sing (h ': t) - - SList, - -- | 'SList' is a kind-restricted synonym for 'Sing': @type SList (a :: [k]) = Sing a@ - - Head, Tail, sHead, sTail, - (:++), (%:++), - Reverse, sReverse - ) where - -import Data.Singletons.Instances -import Data.Singletons -import Data.Singletons.Singletons -import Data.Singletons.TypeLits - -$(singletonsOnly [d| - (++) :: [a] -> [a] -> [a] - [] ++ a = a - (h:t) ++ a = h:(t ++ a) - - head :: [a] -> a - head (a : _) = a - head [] = error "Data.Singletons.List.head: empty list" - - tail :: [a] -> [a] - tail (_ : t) = t - tail [] = error "Data.Singletons.List.tail: empty list" - - reverse :: [a] -> [a] - reverse list = reverse_aux [] list - - reverse_aux :: [a] -> [a] -> [a] - reverse_aux acc [] = acc - reverse_aux acc (h : t) = reverse_aux (h : acc) t - |]) diff --git a/src/Data/Singletons/Maybe.hs b/src/Data/Singletons/Maybe.hs deleted file mode 100644 --- a/src/Data/Singletons/Maybe.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TypeFamilies, - DataKinds, PolyKinds, UndecidableInstances, GADTs, - RankNTypes, CPP #-} - -#if __GLASGOW_HASKELL__ < 707 -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -#endif - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Maybe --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines functions and datatypes relating to the singleton for 'Maybe', --- including a singletons version of all the definitions in @Data.Maybe@. --- --- Because many of these definitions are produced by Template Haskell, --- it is not possible to create proper Haddock documentation. Please look --- up the corresponding operation in @Data.Maybe@. Also, please excuse --- the apparent repeated variable names. This is due to an interaction --- between Template Haskell and Haddock. --- ----------------------------------------------------------------------------- - - -module Data.Singletons.Maybe ( - -- The 'Maybe' singleton - - Sing(SNothing, SJust), - -- | Though Haddock doesn't show it, the 'Sing' instance above declares - -- constructors - -- - -- > SNothing :: Sing Nothing - -- > SJust :: Sing a -> Sing (Just a) - - SMaybe, - -- | 'SBool' is a kind-restricted synonym for 'Sing': @type SMaybe (a :: Maybe k) = Sing a@ - - -- * Singletons from @Data.Maybe@ - - Maybe_, sMaybe_, - -- | The preceding two definitions are derived from the function 'maybe' in - -- @Data.Maybe@. The extra underscore is to avoid name clashes with the type - -- 'Maybe'. - - IsJust, sIsJust, IsNothing, sIsNothing, - FromJust, sFromJust, FromMaybe, sFromMaybe, MaybeToList, sMaybeToList, - ListToMaybe, sListToMaybe, CatMaybes, sCatMaybes, MapMaybe, sMapMaybe - ) where - -import Data.Singletons.Instances -import Data.Singletons -import Data.Singletons.TH -import Data.Singletons.List -import Data.Singletons.TypeLits - -$(singletonsOnly [d| - -- | The 'maybe' function takes a default value, a function, and a 'Maybe' - -- value. If the 'Maybe' value is 'Nothing', the function returns the - -- default value. Otherwise, it applies the function to the value inside - -- the 'Just' and returns the result. - maybe_ :: b -> (a -> b) -> Maybe a -> b - maybe_ n _ Nothing = n - maybe_ _ f (Just x) = f x - - -- | The 'isJust' function returns 'True' iff its argument is of the - -- form @Just _@. - isJust :: Maybe a -> Bool - isJust Nothing = False - isJust (Just _) = True - - -- | The 'isNothing' function returns 'True' iff its argument is 'Nothing'. - isNothing :: Maybe a -> Bool - isNothing Nothing = True - isNothing (Just _) = False - - -- | The 'fromJust' function extracts the element out of a 'Just' and - -- throws an error if its argument is 'Nothing'. - fromJust :: Maybe a -> a - fromJust Nothing = error "Maybe.fromJust: Nothing" -- yuck - fromJust (Just x) = x - - -- | The 'fromMaybe' function takes a default value and and 'Maybe' - -- value. If the 'Maybe' is 'Nothing', it returns the default values; - -- otherwise, it returns the value contained in the 'Maybe'. - fromMaybe :: a -> Maybe a -> a - fromMaybe d Nothing = d - fromMaybe _ (Just v) = v - - -- | The 'maybeToList' function returns an empty list when given - -- 'Nothing' or a singleton list when not given 'Nothing'. - maybeToList :: Maybe a -> [a] - maybeToList Nothing = [] - maybeToList (Just x) = [x] - - -- | The 'listToMaybe' function returns 'Nothing' on an empty list - -- or @'Just' a@ where @a@ is the first element of the list. - listToMaybe :: [a] -> Maybe a - listToMaybe [] = Nothing - listToMaybe (a:_) = Just a - - -- | The 'catMaybes' function takes a list of 'Maybe's and returns - -- a list of all the 'Just' values. - catMaybes :: [Maybe a] -> [a] - catMaybes [] = [] - catMaybes (Just x : xs) = x : catMaybes xs - catMaybes (Nothing : xs) = catMaybes xs - - -- | The 'mapMaybe' function is a version of 'map' which can throw - -- out elements. In particular, the functional argument returns - -- something of type @'Maybe' b@. If this is 'Nothing', no element - -- is added on to the result list. If it just @'Just' b@, then @b@ is - -- included in the result list. - mapMaybe :: (a -> Maybe b) -> [a] -> [b] - mapMaybe _ [] = [] - mapMaybe f (x:xs) = maybeToList (f x) ++ (mapMaybe f xs) - |]) diff --git a/src/Data/Singletons/Prelude.hs b/src/Data/Singletons/Prelude.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude.hs +++ /dev/null @@ -1,106 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- Mimics the Haskell Prelude, but with singleton types. Includes the basic --- singleton definitions. Note: This is currently very incomplete! --- --- Because many of these definitions are produced by Template Haskell, it is --- not possible to create proper Haddock documentation. Also, please excuse --- the apparent repeated variable names. This is due to an interaction between --- Template Haskell and Haddock. --- ----------------------------------------------------------------------------- - -module Data.Singletons.Prelude ( - -- * Basic singleton definitions - module Data.Singletons, - - Sing(SFalse, STrue, SNil, SCons, SJust, SNothing, SLeft, SRight, SLT, SEQ, SGT, - STuple0, STuple2, STuple3, STuple4, STuple5, STuple6, STuple7), - -- | Though Haddock doesn't show it, the 'Sing' instance above includes - -- the following instances - -- - -- > data instance Sing (a :: Bool) where - -- > SFalse :: Sing False - -- > STrue :: Sing True - -- > - -- > data instance Sing (a :: [k]) where - -- > SNil :: Sing '[] - -- > SCons :: Sing (h :: k) -> Sing (t :: [k]) -> Sing (h ': t) - -- > - -- > data instance Sing (a :: Maybe k) where - -- > SNothing :: Sing Nothing - -- > SJust :: Sing (a :: k) -> Sing (Just a) - -- > - -- > data instance Sing (a :: Either x y) where - -- > SLeft :: Sing (a :: x) -> Sing (Left a) - -- > SRight :: Sing (b :: y) -> Sing (Right b) - -- > - -- > data instance Sing (a :: Ordering) where - -- > SLT :: Sing LT - -- > SEQ :: Sing EQ - -- > SGT :: Sing GT - -- > - -- > data instance Sing (a :: ()) where - -- > STuple0 :: Sing '() - -- > - -- > data instance Sing (z :: (a, b)) where - -- > STuple2 :: Sing a -> Sing b -> Sing '(a, b) - -- > - -- > data instance Sing (z :: (a, b, c)) where - -- > STuple3 :: Sing a -> Sing b -> Sing c -> Sing '(a, b, c) - -- > - -- > data instance Sing (z :: (a, b, c, d)) where - -- > STuple4 :: Sing a -> Sing b -> Sing c -> Sing d -> Sing '(a, b, c, d) - -- > - -- > data instance Sing (z :: (a, b, c, d, e)) where - -- > STuple5 :: Sing a -> Sing b -> Sing c -> Sing d -> Sing e -> Sing '(a, b, c, d, e) - -- > - -- > data instance Sing (z :: (a, b, c, d, e, f)) where - -- > STuple6 :: Sing a -> Sing b -> Sing c -> Sing d -> Sing e -> Sing f - -- > -> Sing '(a, b, c, d, e, f) - -- > - -- > data instance Sing (z :: (a, b, c, d, e, f, g)) where - -- > STuple7 :: Sing a -> Sing b -> Sing c -> Sing d -> Sing e -> Sing f - -- > -> Sing g -> Sing '(a, b, c, d, e, f, g) - - -- * Singleton type synonyms - - -- | These synonyms are all kind-restricted synonyms of 'Sing'. - -- For example 'SBool' requires an argument of kind 'Bool'. - SBool, SList, SMaybe, SEither, SOrdering, - STuple0, STuple2, STuple3, STuple4, STuple5, STuple6, STuple7, - - -- * Functions working with 'Bool' - If, sIf, Not, sNot, (:&&), (:||), (%:&&), (%:||), - - -- * Functions working with lists - Head, Tail, (:++), (%:++), - - -- * Error reporting - Error, sError, - - -- * Singleton equality - module Data.Singletons.Eq, - - -- * Other datatypes - Maybe_, sMaybe_, - Either_, sEither_, - Fst, sFst, Snd, sSnd, Curry, sCurry, Uncurry, sUncurry - ) where - -import Data.Singletons -import Data.Singletons.Bool -import Data.Singletons.List -import Data.Singletons.Maybe -import Data.Singletons.Either -import Data.Singletons.Tuple -import Data.Singletons.Eq -import Data.Singletons.Instances -import Data.Singletons.TypeLits diff --git a/src/Data/Singletons/Promote.hs b/src/Data/Singletons/Promote.hs deleted file mode 100644 --- a/src/Data/Singletons/Promote.hs +++ /dev/null @@ -1,699 +0,0 @@ -{- Data/Singletons/Promote.hs - -(c) Richard Eisenberg 2013 -eir@cis.upenn.edu - -This file contains functions to promote term-level constructs to the -type level. It is an internal module to the singletons package. --} - -{-# LANGUAGE TemplateHaskell, CPP #-} - -module Data.Singletons.Promote where - -import Language.Haskell.TH hiding ( Q, cxt ) -import Language.Haskell.TH.Syntax ( falseName, trueName, Quasi(..) ) -import Data.Singletons.Util -import Data.Singletons.Types -import GHC.Exts (Any) -import GHC.TypeLits (Symbol) -import Prelude hiding (exp) -import qualified Data.Map as Map -import qualified Data.Set as Set -import Control.Monad -import Data.List - -anyTypeName, boolName, andName, tyEqName, repName, ifName, - headName, tailName, symbolName :: Name -anyTypeName = ''Any -boolName = ''Bool -andName = '(&&) -#if __GLASGOW_HASKELL__ >= 707 -tyEqName = ''(==) -#else -tyEqName = ''(:==) -#endif -repName = mkName "Rep" -ifName = ''If -headName = mkName "Head" -- these will go away with the th-desugar change -tailName = mkName "Tail" -symbolName = ''Symbol - -falseTy :: Type -falseTy = PromotedT falseName - -trueTy :: Type -trueTy = PromotedT trueName - -boolTy :: Type -boolTy = ConT boolName - -andTy :: Type -andTy = promoteVal andName - -ifTyFam :: Type -ifTyFam = ConT ifName - -headTyFam :: Type -headTyFam = ConT headName - -tailTyFam :: Type -tailTyFam = ConT tailName - -promoteInfo :: Quasi q => Info -> q [Dec] -promoteInfo (ClassI _dec _instances) = - fail "Promotion of class info not supported" -promoteInfo (ClassOpI _name _ty _className _fixity) = - fail "Promotion of class members info not supported" -promoteInfo (TyConI dec) = evalWithoutAux $ promoteDec Map.empty dec -promoteInfo (FamilyI _dec _instances) = - fail "Promotion of type family info not yet supported" -- KindFams -promoteInfo (PrimTyConI _name _numArgs _unlifted) = - fail "Promotion of primitive type constructors not supported" -promoteInfo (DataConI _name _ty _tyname _fixity) = - fail $ "Promotion of individual constructors not supported; " ++ - "promote the type instead" -promoteInfo (VarI _name _ty _mdec _fixity) = - fail "Promotion of value info not supported" -promoteInfo (TyVarI _name _ty) = - fail "Promotion of type variable info not supported" - -promoteValName :: Name -> Name -promoteValName n - | nameBase n == "undefined" = anyTypeName - | otherwise = upcase n - -promoteVal :: Name -> Type -promoteVal = ConT . promoteValName - -promoteType :: Quasi q => Type -> q Kind --- We don't need to worry about constraints: they are used to express --- static guarantees at runtime. But, because we don't need to do --- anything special to keep static guarantees at compile time, we don't --- need to promote them. -promoteType (ForallT _tvbs _ ty) = promoteType ty -- ForallKinds -promoteType (VarT name) = return $ VarT name -promoteType (ConT name) = return $ - case nameBase name of - "TypeRep" -> StarT - "String" -> ConT symbolName - x | x == nameBase repName -> StarT - | otherwise -> ConT name -promoteType (TupleT n) = return $ TupleT n -promoteType (UnboxedTupleT _n) = fail "Promotion of unboxed tuples not supported" -promoteType ArrowT = return ArrowT -promoteType ListT = return ListT -promoteType (AppT (AppT ArrowT (ForallT (_:_) _ _)) _) = - fail "Cannot promote types of rank above 1." -promoteType (AppT ty1 ty2) = do - k1 <- promoteType ty1 - k2 <- promoteType ty2 - return $ AppT k1 k2 -promoteType (SigT _ty _) = fail "Cannot promote type of kind other than *" -promoteType (LitT _) = fail "Cannot promote a type-level literal" -promoteType (PromotedT _) = fail "Cannot promote a promoted data constructor" -promoteType (PromotedTupleT _) = fail "Cannot promote tuples that are already promoted" -promoteType PromotedNilT = fail "Cannot promote a nil that is already promoted" -promoteType PromotedConsT = fail "Cannot promote a cons that is already promoted" -promoteType StarT = fail "* used as a type" -promoteType ConstraintT = fail "Constraint used as a type" - --- a table to keep track of variable->type mappings -type TypeTable = Map.Map Name Type - --- | Promote every declaration given to the type level, retaining the originals. -promote :: Quasi q => q [Dec] -> q [Dec] -promote qdec = do - decls <- qdec - promDecls <- promoteDecs decls - return $ decls ++ promDecls - --- | Promote each declaration, discarding the originals. -promoteOnly :: Quasi q => q [Dec] -> q [Dec] -promoteOnly qdec = do - decls <- qdec - promDecls <- promoteDecs decls - return promDecls - -checkForRep :: Quasi q => [Name] -> q () -checkForRep names = - when (any ((== nameBase repName) . nameBase) names) - (fail $ "A data type named <> is a special case.\n" ++ - "Promoting it will not work as expected.\n" ++ - "Please choose another name for your data type.") - -checkForRepInDecls :: Quasi q => [Dec] -> q () -checkForRepInDecls decls = - checkForRep (map extractNameFromDec decls) - where extractNameFromDec :: Dec -> Name - extractNameFromDec (DataD _ name _ _ _) = name - extractNameFromDec (NewtypeD _ name _ _ _) = name - extractNameFromDec (TySynD name _ _) = name - extractNameFromDec (FamilyD _ name _ _) = name - extractNameFromDec _ = mkName "NotRep" - --- Note [Promoting declarations in two stages] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- Promoting declarations proceeds in two stages: --- 1) Promote everything except type signatures --- 2) Promote type signatures. This must be done in a second pass --- because a function type signature gets promoted to a type family --- declaration. Although function signatures do not differentiate --- between uniform parameters and non-uniform parameters, type --- family declarations do. We need to process a function's --- definition to get the count of non-uniform parameters before --- producing the type family declaration. At this point, any --- function written without a type signature is rejected and --- removed. --- --- Consider this example: --- --- foo :: Int -> Bool -> Bool --- foo 0 = id --- foo _ = not --- --- Here the first parameter to foo is non-uniform, because it is --- inspected in a pattern and can be different in each defining --- equation of foo. The second parameter to foo, specified in the type --- signature as Bool, is a uniform parameter - it is not inspected and --- each defining equation of foo uses it the same way. The foo --- function will be promoted to a type familty Foo like this: --- --- type family Foo (n :: Int) :: Bool -> Bool where --- Foo 0 = Id --- Foo a = Not --- --- To generate type signature for Foo type family we must first learn --- what is the actual number of patterns used in defining cequations --- of foo. In this case there is only one so we declare Foo to take --- one argument and have return type of Bool -> Bool. - --- Promote a list of declarations. -promoteDecs :: Quasi q => [Dec] -> q [Dec] -promoteDecs decls = do - checkForRepInDecls decls - let vartbl = Map.empty - -- See Note [Promoting declarations in two stages] - (newDecls, table) <- evalForPair $ mapM (promoteDec vartbl) decls - (declss, namess) <- mapAndUnzipM (promoteDec' table) decls - let moreNewDecls = concat declss - names = concat namess - noTypeSigs = Set.toList $ Set.difference (Map.keysSet $ -#if __GLASGOW_HASKELL__ >= 707 - Map.filter ((>= 0) . fst) table) -#else - Map.filter (>= 0) table) -#endif - (Set.fromList names) - when (not . null $ noTypeSigs) $ fail ("No type signature for functions: " - ++ intercalate ", " (map (show . nameBase) noTypeSigs) - ++ "; cannot promote or make singletons.") - return (concat newDecls ++ moreNewDecls) - --- | Produce instances for '(:==)' (type-level equality) from the given types -promoteEqInstances :: Quasi q => [Name] -> q [Dec] -promoteEqInstances = concatMapM promoteEqInstance - --- | Produce an instance for '(:==)' (type-level equality) from the given type -promoteEqInstance :: Quasi q => Name -> q [Dec] -promoteEqInstance name = do - (_tvbs, cons) <- getDataD "I cannot make an instance of (:==:) for it." name -#if __GLASGOW_HASKELL__ >= 707 - vars <- replicateM (length _tvbs) (qNewName "k") - let tyvars = map VarT vars - kind = foldType (ConT name) tyvars - inst_decs <- mkEqTypeInstance kind cons - return inst_decs -#else - let pairs = [(c1, c2) | c1 <- cons, c2 <- cons] - mapM mkEqTypeInstance pairs -#endif - -#if __GLASGOW_HASKELL__ >= 707 - --- produce a closed type family helper and the instance --- for (:==) over the given list of ctors -mkEqTypeInstance :: Quasi q => Kind -> [Con] -> q [Dec] -mkEqTypeInstance kind cons = do - helperName <- newUniqueName "Equals" - aName <- qNewName "a" - bName <- qNewName "b" - true_branches <- mapM mk_branch cons - false_branch <- false_case - let closedFam = ClosedTypeFamilyD helperName - [ KindedTV aName kind - , KindedTV bName kind ] - (Just boolTy) - (true_branches ++ [false_branch]) - eqInst = TySynInstD tyEqName (TySynEqn [ SigT (VarT aName) kind - , SigT (VarT bName) kind ] - (foldType (ConT helperName) - [VarT aName, VarT bName])) - return [closedFam, eqInst] - - where mk_branch :: Quasi q => Con -> q TySynEqn - mk_branch con = do - let (name, numArgs) = extractNameArgs con - lnames <- replicateM numArgs (qNewName "a") - rnames <- replicateM numArgs (qNewName "b") - let lvars = map VarT lnames - rvars = map VarT rnames - ltype = foldType (PromotedT name) lvars - rtype = foldType (PromotedT name) rvars - results = zipWith (\l r -> foldType (ConT tyEqName) [l, r]) lvars rvars - result = tyAll results - return $ TySynEqn [ltype, rtype] result - - false_case :: Quasi q => q TySynEqn - false_case = do - lvar <- qNewName "a" - rvar <- qNewName "b" - return $ TySynEqn [SigT (VarT lvar) kind, SigT (VarT rvar) kind] falseTy - - tyAll :: [Type] -> Type -- "all" at the type level - tyAll [] = trueTy - tyAll [one] = one - tyAll (h:t) = foldType andTy [h, (tyAll t)] - -#else - --- produce the type instance for (:==) for the given pair of constructors -mkEqTypeInstance :: Quasi q => (Con, Con) -> q Dec -mkEqTypeInstance (c1, c2) = - if c1 == c2 - then do - let (name, numArgs) = extractNameArgs c1 - lnames <- replicateM numArgs (qNewName "a") - rnames <- replicateM numArgs (qNewName "b") - let lvars = map VarT lnames - rvars = map VarT rnames - return $ TySynInstD - tyEqName - [foldType (PromotedT name) lvars, - foldType (PromotedT name) rvars] - (tyAll (zipWith (\l r -> foldType (ConT tyEqName) [l, r]) - lvars rvars)) - else do - let (lname, lNumArgs) = extractNameArgs c1 - (rname, rNumArgs) = extractNameArgs c2 - lnames <- replicateM lNumArgs (qNewName "a") - rnames <- replicateM rNumArgs (qNewName "b") - return $ TySynInstD - tyEqName - [foldType (PromotedT lname) (map VarT lnames), - foldType (PromotedT rname) (map VarT rnames)] - falseTy - where tyAll :: [Type] -> Type -- "all" at the type level - tyAll [] = trueTy - tyAll [one] = one - tyAll (h:t) = foldType andTy [h, (tyAll t)] - -#endif - --- keeps track of the number of non-uniform parameters to promoted values --- and all of the instance equations for those values -#if __GLASGOW_HASKELL__ >= 707 -type PromoteTable = Map.Map Name (Int, [TySynEqn]) -#else -type PromoteTable = Map.Map Name Int -#endif -type PromoteQ q = QWithAux PromoteTable q - --- used when a type is declared as a type synonym, not a type family --- no need to declare "type family ..." for these -typeSynonymFlag :: Int -typeSynonymFlag = -1 - -promoteDec :: Quasi q => TypeTable -> Dec -> PromoteQ q [Dec] -promoteDec vars (FunD name clauses) = do - let proName = promoteValName name - vars' = Map.insert name (promoteVal name) vars - numArgs = getNumPats (head clauses) -- count the parameters - -- Haskell requires all clauses to have the same number of parameters - (eqns, instDecls) <- evalForPair $ - mapM (promoteClause vars' proName) clauses -#if __GLASGOW_HASKELL__ >= 707 - addBinding name (numArgs, eqns) -- remember the number of parameters and the eqns - return instDecls -#else - addBinding name numArgs -- remember the number of parameters - return $ eqns ++ instDecls -#endif - where getNumPats :: Clause -> Int - getNumPats (Clause pats _ _) = length pats -promoteDec vars (ValD pat body decs) = do - -- see also the comment for promoteTopLevelPat - when (length decs > 0) - (fail $ "Promotion of global variable with <> clause " ++ - "not yet supported") - (rhs, decls) <- evalForPair $ promoteBody vars body - (lhss, decls') <- evalForPair $ promoteTopLevelPat pat - -- just use "type" decls -#if __GLASGOW_HASKELL__ >= 707 - mapM_ (flip addBinding (typeSynonymFlag, [])) (map lhsRawName lhss) -#else - mapM_ (flip addBinding typeSynonymFlag) (map lhsRawName lhss) -#endif - return $ (map (\(LHS _ nm hole) -> TySynD nm [] (hole rhs)) lhss) ++ - decls ++ decls' -promoteDec vars (DataD cxt name tvbs ctors derivings) = - promoteDataD vars cxt name tvbs ctors derivings -promoteDec vars (NewtypeD cxt name tvbs ctor derivings) = - promoteDataD vars cxt name tvbs [ctor] derivings -promoteDec _vars (TySynD _name _tvbs _ty) = - fail "Promotion of type synonym declaration not yet supported" -promoteDec _vars (ClassD _cxt _name _tvbs _fundeps _decs) = - fail "Promotion of class declaration not yet supported" -promoteDec _vars (InstanceD _cxt _ty _decs) = - fail "Promotion of instance declaration not yet supported" -promoteDec _vars (SigD _name _ty) = return [] -- handle in promoteDec' -promoteDec _vars (ForeignD _fgn) = - fail "Promotion of foreign function declaration not yet supported" -promoteDec _vars (InfixD fixity name) - | isUpcase name = return [] -- automatic: promoting a type or data ctor - | otherwise = return [InfixD fixity (promoteValName name)] -- value -promoteDec _vars (PragmaD _prag) = - fail "Promotion of pragmas not yet supported" -promoteDec _vars (FamilyD _flavour _name _tvbs _mkind) = - fail "Promotion of type and data families not yet supported" -promoteDec _vars (DataInstD _cxt _name _tys _ctors _derivings) = - fail "Promotion of data instances not yet supported" -promoteDec _vars (NewtypeInstD _cxt _name _tys _ctors _derivings) = - fail "Promotion of newtype instances not yet supported" -#if __GLASGOW_HASKELL__ >= 707 -promoteDec _vars (RoleAnnotD _name _roles) = - return [] -- silently ignore role annotations, as they're harmless here -promoteDec _vars (ClosedTypeFamilyD _name _tvs _mkind _eqns) = - fail "Promotion of closed type families not yet supported" -promoteDec _vars (TySynInstD _name _eqn) = -#else -promoteDec _vars (TySynInstD _name _lhs _rhs) = -#endif - fail "Promotion of type synonym instances not yet supported" - --- only need to check if the datatype derives Eq. The rest is automatic. -promoteDataD :: Quasi q => TypeTable -> Cxt -> Name -> [TyVarBndr] -> [Con] -> - [Name] -> PromoteQ q [Dec] -promoteDataD _vars _cxt _name _tvbs ctors derivings = - if any (\n -> (nameBase n) == "Eq") derivings - then do -#if __GLASGOW_HASKELL__ >= 707 - kvs <- replicateM (length _tvbs) (qNewName "k") - inst_decs <- mkEqTypeInstance (foldType (ConT _name) (map VarT kvs)) ctors - return inst_decs -#else - let pairs = [ (c1, c2) | c1 <- ctors, c2 <- ctors ] - mapM mkEqTypeInstance pairs -#endif - else return [] -- the actual promotion is automatic - --- second pass through declarations to deal with type signatures --- returns the new declarations and the list of names that have been --- processed -promoteDec' :: Quasi q => PromoteTable -> Dec -> q ([Dec], [Name]) -promoteDec' tab (SigD name ty) = case Map.lookup name tab of - Nothing -> fail $ "Type declaration is missing its binding: " ++ (show name) -#if __GLASGOW_HASKELL__ >= 707 - Just (numArgs, eqns) -> -#else - Just numArgs -> -#endif - -- if there are no args, then use a type synonym, not a type family - -- in the type synonym case, we ignore the type signature - if numArgs == typeSynonymFlag then return $ ([], [name]) else do - k <- promoteType ty - let ks = unravel k - (argKs, resultKs) = splitAt numArgs ks -- divide by uniformity - resultK <- ravel resultKs -- rebuild the arrow kind - tyvarNames <- mapM qNewName (replicate (length argKs) "a") -#if __GLASGOW_HASKELL__ >= 707 - return ([ClosedTypeFamilyD (promoteValName name) - (zipWith KindedTV tyvarNames argKs) - (Just resultK) - eqns], [name]) -#else - return ([FamilyD TypeFam - (promoteValName name) - (zipWith KindedTV tyvarNames argKs) - (Just resultK)], [name]) -#endif - where unravel :: Kind -> [Kind] -- get argument kinds from an arrow kind - unravel (AppT (AppT ArrowT k1) k2) = - let ks = unravel k2 in k1 : ks - unravel k = [k] - - ravel :: Quasi q => [Kind] -> q Kind - ravel [] = fail "Internal error: raveling nil" - ravel [k] = return k - ravel (h:t) = do - k <- ravel t - return $ (AppT (AppT ArrowT h) k) -promoteDec' _ _ = return ([], []) - -#if __GLASGOW_HASKELL__ >= 707 -promoteClause :: Quasi q => TypeTable -> Name -> Clause -> QWithDecs q TySynEqn -#else -promoteClause :: Quasi q => TypeTable -> Name -> Clause -> QWithDecs q Dec -#endif -promoteClause vars _name (Clause pats body []) = do - -- promoting the patterns creates variable bindings. These are passed - -- to the function promoted the RHS - (types, vartbl) <- evalForPair $ mapM promotePat pats - let vars' = Map.union vars vartbl - ty <- promoteBody vars' body -#if __GLASGOW_HASKELL__ >= 707 - return $ TySynEqn types ty -#else - return $ TySynInstD _name types ty -#endif -promoteClause _ _ (Clause _ _ (_:_)) = - fail "A <> clause in a function definition is not yet supported" - --- the LHS of a top-level expression is a name and "type with hole" --- the hole is filled in by the RHS -data TopLevelLHS = LHS { lhsRawName :: Name -- the unpromoted name - , lhsName :: Name - , lhsHole :: Type -> Type - } - --- Treatment of top-level patterns is different from other patterns --- because type families have type patterns as their LHS. However, --- it is not possible to use type patterns at the top level, so we --- have to use other techniques. -promoteTopLevelPat :: Quasi q => Pat -> QWithDecs q [TopLevelLHS] -promoteTopLevelPat (LitP _) = fail "Cannot declare a global literal." -promoteTopLevelPat (VarP name) = return [LHS name (promoteValName name) id] -promoteTopLevelPat (TupP pats) = case length pats of - 0 -> return [] -- unit as LHS of pattern... ignore - 1 -> fail "1-tuple encountered during top-level pattern promotion" - n -> promoteTopLevelPat (ConP (tupleDataName n) pats) -promoteTopLevelPat (UnboxedTupP _) = - fail "Promotion of unboxed tuples not supported" - --- to promote a constructor pattern, we need to create extraction type --- families to pull out the individual arguments of the constructor -promoteTopLevelPat (ConP name pats) = do - ctorInfo <- reifyWithWarning name - (ctorType, argTypes) <- extractTypes ctorInfo - when (length argTypes /= length pats) $ - fail $ "Inconsistent data constructor pattern: " ++ (show name) ++ " " ++ - (show pats) - kind <- promoteType ctorType - argKinds <- mapM promoteType argTypes - extractorNames <- replicateM (length pats) (newUniqueName "Extract") - - varName <- qNewName "a" - zipWithM_ (\nm arg -> addElement $ FamilyD TypeFam - nm - [KindedTV varName kind] - (Just arg)) - extractorNames argKinds - componentNames <- replicateM (length pats) (qNewName "a") - zipWithM_ (\extractorName componentName -> - addElement $ mkTyFamInst extractorName - [foldType (PromotedT name) - (map VarT componentNames)] - (VarT componentName)) - extractorNames componentNames - - -- now we have the extractor families. Use the appropriate families - -- in the "holes" - promotedPats <- mapM promoteTopLevelPat pats - return $ concat $ - zipWith (\lhslist extractor -> - map (\(LHS raw nm hole) -> LHS raw nm - (hole . (AppT (ConT extractor)))) - lhslist) - promotedPats extractorNames - where extractTypes :: Quasi q => Info -> q (Type, [Type]) - extractTypes (DataConI datacon _dataconTy tyname _fixity) = do - tyinfo <- reifyWithWarning tyname - extractTypesHelper datacon tyinfo - extractTypes _ = fail "Internal error: unexpected Info in extractTypes" - - extractTypesHelper :: Quasi q => Name -> Info -> q (Type, [Type]) - extractTypesHelper datacon - (TyConI (DataD _cxt tyname tvbs cons _derivs)) = - let mcon = find ((== datacon) . fst . extractNameArgs) cons in - case mcon of - Nothing -> fail $ "Internal error reifying " ++ (show datacon) - Just con -> return (foldType (ConT tyname) - (map (VarT . extractTvbName) tvbs), - extractConArgs con) - extractTypesHelper datacon - (TyConI (NewtypeD cxt tyname tvbs con derivs)) = - extractTypesHelper datacon (TyConI (DataD cxt tyname tvbs [con] derivs)) - extractTypesHelper datacon _ = - fail $ "Cannot promote data constructor " ++ (show datacon) - - extractConArgs :: Con -> [Type] - extractConArgs = ctor1Case (\_ tys -> tys) -promoteTopLevelPat (InfixP l name r) = promoteTopLevelPat (ConP name [l, r]) -promoteTopLevelPat (UInfixP _ _ _) = - fail "Unresolved infix constructors not supported" -promoteTopLevelPat (ParensP _) = - fail "Unresolved infix constructors not supported" -promoteTopLevelPat (TildeP pat) = do - qReportWarning "Lazy pattern converted into regular pattern in promotion" - promoteTopLevelPat pat -promoteTopLevelPat (BangP pat) = do - qReportWarning "Strict pattern converted into regular pattern in promotion" - promoteTopLevelPat pat -promoteTopLevelPat (AsP _name _pat) = - fail "Promotion of aliased patterns at top level not yet supported" -promoteTopLevelPat WildP = return [] -promoteTopLevelPat (RecP _ _) = - fail "Promotion of record patterns at top level not yet supported" - --- must do a similar trick as what is in the ConP case, but this is easier --- because Lib defined Head and Tail -promoteTopLevelPat (ListP pats) = do - promotedPats <- mapM promoteTopLevelPat pats - return $ concat $ snd $ - mapAccumL (\extractFn lhss -> - ((AppT tailTyFam) . extractFn, - map (\(LHS raw nm hole) -> - LHS raw nm (hole . (AppT headTyFam) . extractFn)) lhss)) - id promotedPats -promoteTopLevelPat (SigP pat _) = do - qReportWarning $ "Promotion of explicit type annotation in pattern " ++ - "not yet supported." - promoteTopLevelPat pat -promoteTopLevelPat (ViewP _ _) = - fail "Promotion of view patterns not yet supported" - -type TypesQ q = QWithAux TypeTable q - --- promotes a term pattern into a type pattern, accumulating variable --- binding in the auxiliary TypeTable -promotePat :: Quasi q => Pat -> TypesQ q Type -promotePat (LitP lit) = promoteLit lit -promotePat (VarP name) = do - tyVar <- qNewName (nameBase name) - addBinding name (VarT tyVar) - return $ VarT tyVar -promotePat (TupP pats) = do - types <- mapM promotePat pats - let baseTup = PromotedTupleT (length types) - tup = foldType baseTup types - return tup -promotePat (UnboxedTupP _) = fail "Unboxed tuples not supported" -promotePat (ConP name pats) = do - types <- mapM promotePat pats - let tyCon = foldType (PromotedT name) types - return tyCon -promotePat (InfixP pat1 name pat2) = promotePat (ConP name [pat1, pat2]) -promotePat (UInfixP _ _ _) = fail "Unresolved infix constructions not supported" -promotePat (ParensP _) = fail "Unresolved infix constructions not supported" -promotePat (TildeP pat) = do - qReportWarning "Lazy pattern converted into regular pattern in promotion" - promotePat pat -promotePat (BangP pat) = do - qReportWarning "Strict pattern converted into regular pattern in promotion" - promotePat pat -promotePat (AsP name pat) = do - ty <- promotePat pat - addBinding name ty - return ty -promotePat WildP = do - name <- qNewName "z" - return $ VarT name -promotePat (RecP _ _) = fail "Promotion of record patterns not yet supported" -promotePat (ListP pats) = do - types <- mapM promotePat pats - return $ foldr (\h t -> AppT (AppT PromotedConsT h) t) PromotedNilT types -promotePat (SigP pat _) = do - qReportWarning $ "Promotion of explicit type annotation in pattern " ++ - "not yet supported" - promotePat pat -promotePat (ViewP _ _) = fail "View patterns not yet supported" - --- promoting a body may produce auxiliary declarations. Accumulate these. -type QWithDecs q = QWithAux [Dec] q - -promoteBody :: Quasi q => TypeTable -> Body -> QWithDecs q Type -promoteBody vars (NormalB exp) = promoteExp vars exp -promoteBody _vars (GuardedB _) = - fail "Promoting guards in patterns not yet supported" - -promoteExp :: Quasi q => TypeTable -> Exp -> QWithDecs q Type -promoteExp vars (VarE name) = case Map.lookup name vars of - Just ty -> return ty - Nothing -> return $ promoteVal name -promoteExp _vars (ConE name) = return $ PromotedT name -promoteExp _vars (LitE lit) = promoteLit lit -promoteExp vars (AppE exp1 exp2) = do - ty1 <- promoteExp vars exp1 - ty2 <- promoteExp vars exp2 - return $ AppT ty1 ty2 -promoteExp vars (InfixE mexp1 exp mexp2) = - case (mexp1, mexp2) of - (Nothing, Nothing) -> promoteExp vars exp - (Just exp1, Nothing) -> promoteExp vars (AppE exp exp1) - (Nothing, Just _exp2) -> - fail "Promotion of right-only sections not yet supported" - (Just exp1, Just exp2) -> promoteExp vars (AppE (AppE exp exp1) exp2) -promoteExp _vars (UInfixE _ _ _) = - fail "Promotion of unresolved infix operators not supported" -promoteExp _vars (ParensE _) = fail "Promotion of unresolved parens not supported" -promoteExp _vars (LamE _pats _exp) = - fail "Promotion of lambda expressions not yet supported" -promoteExp _vars (LamCaseE _alts) = - fail "Promotion of lambda-case expressions not yet supported" -promoteExp vars (TupE exps) = do - tys <- mapM (promoteExp vars) exps - let tuple = PromotedTupleT (length tys) - tup = foldType tuple tys - return tup -promoteExp _vars (UnboxedTupE _) = fail "Promotion of unboxed tuples not supported" -promoteExp vars (CondE bexp texp fexp) = do - tys <- mapM (promoteExp vars) [bexp, texp, fexp] - return $ foldType ifTyFam tys -promoteExp _vars (MultiIfE _alts) = - fail "Promotion of multi-way if not yet supported" -promoteExp _vars (LetE _decs _exp) = - fail "Promotion of let statements not yet supported" -promoteExp _vars (CaseE _exp _matches) = - fail "Promotion of case statements not yet supported" -promoteExp _vars (DoE _stmts) = fail "Promotion of do statements not supported" -promoteExp _vars (CompE _stmts) = - fail "Promotion of list comprehensions not yet supported" -promoteExp _vars (ArithSeqE _) = fail "Promotion of ranges not supported" -promoteExp vars (ListE exps) = do - tys <- mapM (promoteExp vars) exps - return $ foldr (\ty lst -> AppT (AppT PromotedConsT ty) lst) PromotedNilT tys -promoteExp _vars (SigE _exp _ty) = - fail "Promotion of explicit type annotations not yet supported" -promoteExp _vars (RecConE _name _fields) = - fail "Promotion of record construction not yet supported" -promoteExp _vars (RecUpdE _exp _fields) = - fail "Promotion of record updates not yet supported" - -promoteLit :: Monad m => Lit -> m Type -promoteLit (IntegerL n) - | n >= 0 = return $ LitT (NumTyLit n) - | otherwise = fail ("Promoting negative integers not supported: " ++ (show n)) -promoteLit (StringL str) = return $ LitT (StrTyLit str) -promoteLit lit = - fail ("Only string and natural number literals can be promoted: " ++ show lit) diff --git a/src/Data/Singletons/ShowSing.hs b/src/Data/Singletons/ShowSing.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/ShowSing.hs @@ -0,0 +1,319 @@ +{-# 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 diff --git a/src/Data/Singletons/Sigma.hs b/src/Data/Singletons/Sigma.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Sigma.hs @@ -0,0 +1,248 @@ +{-# 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 :%&: +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @(Sigma s t) = +#else +type instance Sing = +#endif + 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 diff --git a/src/Data/Singletons/Singletons.hs b/src/Data/Singletons/Singletons.hs deleted file mode 100644 --- a/src/Data/Singletons/Singletons.hs +++ /dev/null @@ -1,738 +0,0 @@ -{- Data/Singletons/Singletons.hs - -(c) Richard Eisenberg 2013 -eir@cis.upenn.edu - -This file contains functions to refine constructs to work with singleton -types. It is an internal module to the singletons package. --} -{-# LANGUAGE TemplateHaskell, CPP, TupleSections #-} - -module Data.Singletons.Singletons where - -import Prelude hiding ( exp ) -import Language.Haskell.TH hiding ( cxt ) -import Language.Haskell.TH.Syntax (falseName, trueName, Quasi(..)) -import Data.Singletons.Util -import Data.Singletons.Promote -import Data.Singletons -import Data.Singletons.Decide -import qualified Data.Map as Map -import Control.Monad -import Control.Applicative - --- map to track bound variables -type ExpTable = Map.Map Name Exp - --- translating a type gives a type with a hole in it, --- represented here as a function -type TypeFn = Type -> Type - --- a list of argument types extracted from a type application -type TypeContext = [Type] - -singFamilyName, singIName, singMethName, demoteRepName, singKindClassName, - sEqClassName, sEqMethName, sconsName, snilName, sIfName, undefinedName, - kProxyDataName, kProxyTypeName, someSingTypeName, someSingDataName, - nilName, consName, sListName, eqName, sDecideClassName, sDecideMethName, - provedName, disprovedName, reflName, toSingName, fromSingName, listName :: Name -singFamilyName = ''Sing -singIName = ''SingI -singMethName = 'sing -toSingName = 'toSing -fromSingName = 'fromSing -demoteRepName = ''DemoteRep -singKindClassName = ''SingKind -sEqClassName = mkName "SEq" -sEqMethName = mkName "%:==" -sIfName = mkName "sIf" -undefinedName = 'undefined -sconsName = mkName "SCons" -snilName = mkName "SNil" -kProxyDataName = 'KProxy -kProxyTypeName = ''KProxy -someSingTypeName = ''SomeSing -someSingDataName = 'SomeSing -nilName = '[] -consName = '(:) -listName = ''[] -sListName = mkName "SList" -eqName = ''Eq -sDecideClassName = ''SDecide -sDecideMethName = '(%~) -provedName = 'Proved -disprovedName = 'Disproved -reflName = 'Refl - -mkTupleName :: Int -> Name -mkTupleName n = mkName $ "STuple" ++ (show n) - -singFamily :: Type -singFamily = ConT singFamilyName - -singKindConstraint :: Kind -> Pred -singKindConstraint k = ClassP singKindClassName [kindParam k] - -demote :: Type -demote = ConT demoteRepName - -singDataConName :: Name -> Name -singDataConName nm - | nm == nilName = snilName - | nm == consName = sconsName - | Just degree <- tupleNameDegree_maybe nm = mkTupleName degree - | otherwise = prefixUCName "S" ":%" nm - -singTyConName :: Name -> Name -singTyConName name - | name == listName = sListName - | Just degree <- tupleNameDegree_maybe name = mkTupleName degree - | otherwise = prefixUCName "S" ":%" name - -singClassName :: Name -> Name -singClassName = singTyConName - -singDataCon :: Name -> Exp -singDataCon = ConE . singDataConName - -singValName :: Name -> Name -singValName n - | nameBase n == "undefined" = undefinedName - | otherwise = (prefixLCName "s" "%") $ upcase n - -singVal :: Name -> Exp -singVal = VarE . singValName - -kindParam :: Kind -> Type -kindParam k = SigT (ConT kProxyDataName) (AppT (ConT kProxyTypeName) k) - --- | Generate singleton definitions from a type that is already defined. --- For example, the singletons package itself uses --- --- > $(genSingletons [''Bool, ''Maybe, ''Either, ''[]]) --- --- to generate singletons for Prelude types. -genSingletons :: Quasi q => [Name] -> q [Dec] -genSingletons names = do - checkForRep names - concatMapM (singInfo <=< reifyWithWarning) names - -singInfo :: Quasi q => Info -> q [Dec] -singInfo (ClassI _dec _instances) = - fail "Singling of class info not supported" -singInfo (ClassOpI _name _ty _className _fixity) = - fail "Singling of class members info not supported" -singInfo (TyConI dec) = singDec dec -singInfo (FamilyI _dec _instances) = - fail "Singling of type family info not yet supported" -- KindFams -singInfo (PrimTyConI _name _numArgs _unlifted) = - fail "Singling of primitive type constructors not supported" -singInfo (DataConI _name _ty _tyname _fixity) = - fail $ "Singling of individual constructors not supported; " ++ - "single the type instead" -singInfo (VarI _name _ty _mdec _fixity) = - fail "Singling of value info not supported" -singInfo (TyVarI _name _ty) = - fail "Singling of type variable info not supported" - --- refine a constructor. the first parameter is the type variable that --- the singleton GADT is parameterized by --- runs in the QWithDecs monad because auxiliary declarations are produced -singCtor :: Quasi q => Type -> Con -> QWithDecs q Con -singCtor a = ctorCases - -- monomorphic case - (\name types -> do - let sName = singDataConName name - sCon = singDataCon name - pCon = PromotedT name - indexNames <- replicateM (length types) (qNewName "n") - let indices = map VarT indexNames - kinds <- mapM promoteType types - args <- buildArgTypes types indices - let tvbs = zipWith KindedTV indexNames kinds - kindedIndices = zipWith SigT indices kinds - - -- SingI instance - addElement $ InstanceD (map (ClassP singIName . listify) indices) - (AppT (ConT singIName) - (foldType pCon kindedIndices)) - [ValD (VarP singMethName) - (NormalB $ foldExp sCon (replicate (length types) - (VarE singMethName))) - []] - - return $ ForallC tvbs - [EqualP a (foldType pCon indices)] - (NormalC sName $ map (NotStrict,) args)) - - -- polymorphic case - (\_tvbs cxt ctor -> case cxt of - _:_ -> fail "Singling of constrained constructors not yet supported" - [] -> singCtor a ctor) -- polymorphic constructors are handled just - -- like monomorphic ones -- the polymorphism in - -- the kind is automatic - where buildArgTypes :: Quasi q => [Type] -> [Type] -> q [Type] - buildArgTypes types indices = do - typeFns <- mapM singType types - return $ zipWith id typeFns indices - --- | Make promoted and singleton versions of all declarations given, retaining --- the original declarations. --- See for --- further explanation. -singletons :: Quasi q => q [Dec] -> q [Dec] -singletons = (>>= singDecs True) - --- | Make promoted and singleton versions of all declarations given, discarding --- the original declarations. -singletonsOnly :: Quasi q => q [Dec] -> q [Dec] -singletonsOnly = (>>= singDecs False) - --- first parameter says whether or not to include original decls -singDecs :: Quasi q => Bool -> [Dec] -> q [Dec] -singDecs originals decls = do - promDecls <- promoteDecs decls - newDecls <- mapM singDec decls - return $ (if originals then (decls ++) else id) $ promDecls ++ (concat newDecls) - -singDec :: Quasi q => Dec -> q [Dec] -singDec (FunD name clauses) = do - let sName = singValName name - vars = Map.singleton name (VarE sName) - listify <$> FunD sName <$> (mapM (singClause vars) clauses) -singDec (ValD _ (GuardedB _) _) = - fail "Singling of definitions of values with a pattern guard not yet supported" -singDec (ValD _ _ (_:_)) = - fail "Singling of definitions of values with a <> clause not yet supported" -singDec (ValD pat (NormalB exp) []) = do - (sPat, vartbl) <- evalForPair $ singPat TopLevel pat - sExp <- singExp vartbl exp - return [ValD sPat (NormalB sExp) []] -singDec (DataD cxt name tvbs ctors derivings) = - singDataD False cxt name tvbs ctors derivings -singDec (NewtypeD cxt name tvbs ctor derivings) = - singDataD False cxt name tvbs [ctor] derivings -singDec (TySynD _name _tvbs _ty) = - fail "Singling of type synonyms not yet supported" -singDec (ClassD _cxt _name _tvbs _fundeps _decs) = - fail "Singling of class declaration not yet supported" -singDec (InstanceD _cxt _ty _decs) = - fail "Singling of class instance not yet supported" -singDec (SigD name ty) = do - tyTrans <- singType ty - return [SigD (singValName name) (tyTrans (promoteVal name))] -singDec (ForeignD fgn) = - let name = extractName fgn in do - qReportWarning $ "Singling of foreign functions not supported -- " ++ - (show name) ++ " ignored" - return [] - where extractName :: Foreign -> Name - extractName (ImportF _ _ _ n _) = n - extractName (ExportF _ _ n _) = n -singDec (InfixD fixity name) - | isUpcase name = return [InfixD fixity (singDataConName name)] - | otherwise = return [InfixD fixity (singValName name)] -singDec (PragmaD _prag) = do - qReportWarning "Singling of pragmas not supported" - return [] -singDec (FamilyD _flavour _name _tvbs _mkind) = - fail "Singling of type and data families not yet supported" -singDec (DataInstD _cxt _name _tys _ctors _derivings) = - fail "Singling of data instances not yet supported" -singDec (NewtypeInstD _cxt _name _tys _ctor _derivings) = - fail "Singling of newtype instances not yet supported" -#if __GLASGOW_HASKELL__ >= 707 -singDec (RoleAnnotD _name _roles) = - return [] -- silently ignore role annotations, as they're harmless -singDec (ClosedTypeFamilyD _name _tvs _mkind _eqns) = - fail "Singling of closed type families not yet supported" -singDec (TySynInstD _name _eqns) = -#else -singDec (TySynInstD _name _lhs _rhs) = -#endif - fail "Singling of type family instances not yet supported" - --- | Create instances of 'SEq' and type-level '(:==)' for each type in the list -singEqInstances :: Quasi q => [Name] -> q [Dec] -singEqInstances = concatMapM singEqInstance - --- | Create instance of 'SEq' and type-level '(:==)' for the given type -singEqInstance :: Quasi q => Name -> q [Dec] -singEqInstance name = do - promotion <- promoteEqInstance name - dec <- singEqualityInstance sEqClassDesc name - return $ dec : promotion - --- | Create instances of 'SEq' (only -- no instance for '(:==)', which 'SEq' generally --- relies on) for each type in the list -singEqInstancesOnly :: Quasi q => [Name] -> q [Dec] -singEqInstancesOnly = concatMapM singEqInstanceOnly - --- | Create instances of 'SEq' (only -- no instance for '(:==)', which 'SEq' generally --- relies on) for the given type -singEqInstanceOnly :: Quasi q => Name -> q [Dec] -singEqInstanceOnly name = listify <$> singEqualityInstance sEqClassDesc name - --- | Create instances of 'SDecide' for each type in the list. --- --- Note that, due to a bug in GHC 7.6.3 (and lower) optimizing instances --- for SDecide can make GHC hang. You may want to put --- @{-# OPTIONS_GHC -O0 #-}@ in your file. -singDecideInstances :: Quasi q => [Name] -> q [Dec] -singDecideInstances = concatMapM singDecideInstance - --- | Create instance of 'SDecide' for the given type. --- --- Note that, due to a bug in GHC 7.6.3 (and lower) optimizing instances --- for SDecide can make GHC hang. You may want to put --- @{-# OPTIONS_GHC -O0 #-}@ in your file. -singDecideInstance :: Quasi q => Name -> q [Dec] -singDecideInstance name = listify <$> singEqualityInstance sDecideClassDesc name - --- generalized function for creating equality instances -singEqualityInstance :: Quasi q => EqualityClassDesc q -> Name -> q Dec -singEqualityInstance desc@(_, className, _) name = do - (tvbs, cons) <- getDataD ("I cannot make an instance of " ++ - show className ++ " for it.") name - let tyvars = map (VarT . extractTvbName) tvbs - kind = foldType (ConT name) tyvars - aName <- qNewName "a" - let aVar = VarT aName - scons <- mapM (evalWithoutAux . singCtor aVar) cons - mkEqualityInstance kind scons desc - --- making the SEq instance and the SDecide instance are rather similar, --- so we generalize -type EqualityClassDesc q = ((Con, Con) -> q Clause, Name, Name) -sEqClassDesc, sDecideClassDesc :: Quasi q => EqualityClassDesc q -sEqClassDesc = (mkEqMethClause, sEqClassName, sEqMethName) -sDecideClassDesc = (mkDecideMethClause, sDecideClassName, sDecideMethName) - --- pass the *singleton* constructors, not the originals -mkEqualityInstance :: Quasi q => Kind -> [Con] - -> EqualityClassDesc q -> q Dec -mkEqualityInstance k ctors (mkMeth, className, methName) = do - let ctorPairs = [ (c1, c2) | c1 <- ctors, c2 <- ctors ] - methClauses <- if null ctors - then mkEmptyMethClauses - else mapM mkMeth ctorPairs - return $ InstanceD (map (\kvar -> ClassP className [kindParam kvar]) - (getKindVars k)) - (AppT (ConT className) - (kindParam k)) - [FunD methName methClauses] - where getKindVars :: Kind -> [Kind] - getKindVars (AppT l r) = getKindVars l ++ getKindVars r - getKindVars (VarT x) = [VarT x] - getKindVars (ConT _) = [] - getKindVars StarT = [] - getKindVars other = - error ("getKindVars sees an unusual kind: " ++ show other) - - mkEmptyMethClauses :: Quasi q => q [Clause] - mkEmptyMethClauses = do - a <- qNewName "a" - return [Clause [VarP a, WildP] (NormalB (CaseE (VarE a) emptyMatches)) []] - -mkEqMethClause :: Quasi q => (Con, Con) -> q Clause -mkEqMethClause (c1, c2) - | lname == rname = do - lnames <- replicateM lNumArgs (qNewName "a") - rnames <- replicateM lNumArgs (qNewName "b") - let lpats = map VarP lnames - rpats = map VarP rnames - lvars = map VarE lnames - rvars = map VarE rnames - return $ Clause - [ConP lname lpats, ConP rname rpats] - (NormalB $ - allExp (zipWith (\l r -> foldExp (VarE sEqMethName) [l, r]) - lvars rvars)) - [] - | otherwise = - return $ Clause - [ConP lname (replicate lNumArgs WildP), - ConP rname (replicate rNumArgs WildP)] - (NormalB (singDataCon falseName)) - [] - where allExp :: [Exp] -> Exp - allExp [] = singDataCon trueName - allExp [one] = one - allExp (h:t) = AppE (AppE (singVal andName) h) (allExp t) - - (lname, lNumArgs) = extractNameArgs c1 - (rname, rNumArgs) = extractNameArgs c2 - -mkDecideMethClause :: Quasi q => (Con, Con) -> q Clause -mkDecideMethClause (c1, c2) - | lname == rname = - if lNumArgs == 0 - then return $ Clause [ConP lname [], ConP rname []] - (NormalB (AppE (ConE provedName) (ConE reflName))) [] - else do - lnames <- replicateM lNumArgs (qNewName "a") - rnames <- replicateM lNumArgs (qNewName "b") - contra <- qNewName "contra" - let lpats = map VarP lnames - rpats = map VarP rnames - lvars = map VarE lnames - rvars = map VarE rnames - return $ Clause - [ConP lname lpats, ConP rname rpats] - (NormalB $ - CaseE (mkTupleExp $ - zipWith (\l r -> foldExp (VarE sDecideMethName) [l, r]) - lvars rvars) - ((Match (mkTuplePat (replicate lNumArgs - (ConP provedName [ConP reflName []]))) - (NormalB $ AppE (ConE provedName) (ConE reflName)) - []) : - [Match (mkTuplePat (replicate i WildP ++ - ConP disprovedName [VarP contra] : - replicate (lNumArgs - i - 1) WildP)) - (NormalB $ AppE (ConE disprovedName) - (LamE [ConP reflName []] - (AppE (VarE contra) - (ConE reflName)))) - [] | i <- [0..lNumArgs-1] ])) - [] - - | otherwise = - return $ Clause - [ConP lname (replicate lNumArgs WildP), - ConP rname (replicate rNumArgs WildP)] - (NormalB (AppE (ConE disprovedName) (LamCaseE emptyMatches))) - [] - - where - (lname, lNumArgs) = extractNameArgs c1 - (rname, rNumArgs) = extractNameArgs c2 - --- the first parameter is True when we're refining the special case "Rep" --- and false otherwise. We wish to consider the promotion of "Rep" to be * --- not a promoted data constructor. -singDataD :: Quasi q => Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> [Name] -> q [Dec] -singDataD rep cxt name tvbs ctors derivings - | (_:_) <- cxt = fail "Singling of constrained datatypes is not supported" - | otherwise = do - aName <- qNewName "z" - let a = VarT aName - let tvbNames = map extractTvbName tvbs - k <- promoteType (foldType (ConT name) (map VarT tvbNames)) - (ctors', ctorInstDecls) <- evalForPair $ mapM (singCtor a) ctors - - -- instance for SingKind - fromSingClauses <- mapM mkFromSingClause ctors - toSingClauses <- mapM mkToSingClause ctors - let singKindInst = - InstanceD (map (singKindConstraint . VarT) tvbNames) - (AppT (ConT singKindClassName) - (kindParam k)) - [ mkTyFamInst demoteRepName - [kindParam k] - (foldType (ConT name) - (map (AppT demote . kindParam . VarT) tvbNames)) - , FunD fromSingName (fromSingClauses `orIfEmpty` emptyMethod aName) - , FunD toSingName (toSingClauses `orIfEmpty` emptyMethod aName) ] - - -- SEq instance - sEqInsts <- if elem eqName derivings - then mapM (mkEqualityInstance k ctors') [sEqClassDesc, sDecideClassDesc] - else return [] - - -- e.g. type SNat (a :: Nat) = Sing a - let kindedSynInst = - TySynD (singTyConName name) - [KindedTV aName k] - (AppT singFamily a) - - return $ (DataInstD [] singFamilyName [SigT a k] ctors' []) : - kindedSynInst : - singKindInst : - sEqInsts ++ - ctorInstDecls - where -- in the Rep case, the names of the constructors are in the wrong scope - -- (they're types, not datacons), so we have to reinterpret them. - mkConName :: Name -> Name - mkConName = if rep then reinterpret else id - - mkFromSingClause :: Quasi q => Con -> q Clause - mkFromSingClause c = do - let (cname, numArgs) = extractNameArgs c - varNames <- replicateM numArgs (qNewName "b") - return $ Clause [ConP (singDataConName cname) (map VarP varNames)] - (NormalB $ foldExp - (ConE $ mkConName cname) - (map (AppE (VarE fromSingName) . VarE) varNames)) - [] - - mkToSingClause :: Quasi q => Con -> q Clause - mkToSingClause = ctor1Case $ \cname types -> do - varNames <- mapM (const $ qNewName "b") types - svarNames <- mapM (const $ qNewName "c") types - promoted <- mapM promoteType types - let recursiveCalls = zipWith mkRecursiveCall varNames promoted - return $ - Clause [ConP (mkConName cname) (map VarP varNames)] - (NormalB $ - multiCase recursiveCalls - (map (ConP someSingDataName . listify . VarP) - svarNames) - (AppE (ConE someSingDataName) - (foldExp (ConE (singDataConName cname)) - (map VarE svarNames)))) - [] - - mkRecursiveCall :: Name -> Kind -> Exp - mkRecursiveCall var_name ki = - SigE (AppE (VarE toSingName) (VarE var_name)) - (AppT (ConT someSingTypeName) (kindParam ki)) - - emptyMethod :: Name -> [Clause] - emptyMethod n = [Clause [VarP n] (NormalB $ CaseE (VarE n) emptyMatches) []] - -singKind :: Quasi q => Kind -> q (Kind -> Kind) -singKind (ForallT _ _ _) = - fail "Singling of explicitly quantified kinds not yet supported" -singKind (VarT _) = fail "Singling of kind variables not yet supported" -singKind (ConT _) = fail "Singling of named kinds not yet supported" -singKind (TupleT _) = fail "Singling of tuple kinds not yet supported" -singKind (UnboxedTupleT _) = fail "Unboxed tuple used as kind" -singKind ArrowT = fail "Singling of unsaturated arrow kinds not yet supported" -singKind ListT = fail "Singling of list kinds not yet supported" -singKind (AppT (AppT ArrowT k1) k2) = do - k1fn <- singKind k1 - k2fn <- singKind k2 - k <- qNewName "k" - return $ \f -> AppT (AppT ArrowT (k1fn (VarT k))) (k2fn (AppT f (VarT k))) -singKind (AppT _ _) = fail "Singling of kind applications not yet supported" -singKind (SigT _ _) = - fail "Singling of explicitly annotated kinds not yet supported" -singKind (LitT _) = fail "Type literal used as kind" -singKind (PromotedT _) = fail "Promoted data constructor used as kind" -singKind (PromotedTupleT _) = fail "Promoted tuple used as kind" -singKind PromotedNilT = fail "Promoted nil used as kind" -singKind PromotedConsT = fail "Promoted cons used as kind" -singKind StarT = return $ \k -> AppT (AppT ArrowT k) StarT -singKind ConstraintT = fail "Singling of constraint kinds not yet supported" - -singType :: Quasi q => Type -> q TypeFn -singType ty = do -- replace with singTypeRec [] ty after GHC bug #??? is fixed - sTypeFn <- singTypeRec [] ty - return $ \inner_ty -> liftOutForalls $ sTypeFn inner_ty - --- Lifts all foralls to the top-level. This is a workaround for bug #8031 on GHC --- Trac -liftOutForalls :: Type -> Type -liftOutForalls = - go [] [] [] - where - go tyvars cxt args (ForallT tyvars1 cxt1 t1) - = go (reverse tyvars1 ++ tyvars) (reverse cxt1 ++ cxt) args t1 - go tyvars cxt args (SigT t1 _kind) -- ignore these kind annotations, which have to be * - = go tyvars cxt args t1 - go tyvars cxt args (AppT (AppT ArrowT arg1) res1) - = go tyvars cxt (arg1 : args) res1 - go [] [] args t1 - = mk_fun_ty (reverse args) t1 - go tyvars cxt args t1 - = ForallT (reverse tyvars) (reverse cxt) (mk_fun_ty (reverse args) t1) - - mk_fun_ty [] res = res - mk_fun_ty (arg1:args) res = AppT (AppT ArrowT arg1) (mk_fun_ty args res) - --- the first parameter is the list of types the current type is applied to -singTypeRec :: Quasi q => TypeContext -> Type -> q TypeFn -singTypeRec (_:_) (ForallT _ _ _) = - fail "I thought this was impossible in Haskell. Email me at eir@cis.upenn.edu with your code if you see this message." -singTypeRec [] (ForallT _ [] ty) = -- Sing makes handling foralls automatic - singTypeRec [] ty -singTypeRec ctx (ForallT _tvbs cxt innerty) = do - cxt' <- singContext cxt - innerty' <- singTypeRec ctx innerty - return $ \ty -> ForallT [] cxt' (innerty' ty) -singTypeRec (_:_) (VarT _) = - fail "Singling of type variables of arrow kinds not yet supported" -singTypeRec [] (VarT _name) = - return $ \ty -> AppT singFamily ty -singTypeRec _ctx (ConT _name) = -- we don't need to process the context with Sing - return $ \ty -> AppT singFamily ty -singTypeRec _ctx (TupleT _n) = -- just like ConT - return $ \ty -> AppT singFamily ty -singTypeRec _ctx (UnboxedTupleT _n) = - fail "Singling of unboxed tuple types not yet supported" -singTypeRec ctx ArrowT = case ctx of - [ty1, ty2] -> do - t <- qNewName "t" - sty1 <- singTypeRec [] ty1 - sty2 <- singTypeRec [] ty2 - k1 <- promoteType ty1 - return (\f -> ForallT [KindedTV t k1] - [] - (AppT (AppT ArrowT (sty1 (VarT t))) - (sty2 (AppT f (VarT t))))) - _ -> fail "Internal error in Sing: converting ArrowT with improper context" -singTypeRec _ctx ListT = - return $ \ty -> AppT singFamily ty -singTypeRec ctx (AppT ty1 ty2) = - singTypeRec (ty2 : ctx) ty1 -- recur with the ty2 in the applied context -singTypeRec _ctx (SigT _ty _knd) = - fail "Singling of types with explicit kinds not yet supported" -singTypeRec _ctx (LitT _) = fail "Singling of type-level literals not yet supported" -singTypeRec _ctx (PromotedT _) = - fail "Singling of promoted data constructors not yet supported" -singTypeRec _ctx (PromotedTupleT _) = - fail "Singling of type-level tuples not yet supported" -singTypeRec _ctx PromotedNilT = fail "Singling of promoted nil not yet supported" -singTypeRec _ctx PromotedConsT = fail "Singling of type-level cons not yet supported" -singTypeRec _ctx StarT = fail "* used as type" -singTypeRec _ctx ConstraintT = fail "Constraint used as type" - --- refine a constraint context -singContext :: Quasi q => Cxt -> q Cxt -singContext = mapM singPred - -singPred :: Quasi q => Pred -> q Pred -singPred (ClassP name tys) = do - kis <- mapM promoteType tys - let sName = singClassName name - return $ ClassP sName (map kindParam kis) -singPred (EqualP _ty1 _ty2) = - fail "Singling of type equality constraints not yet supported" - -singClause :: Quasi q => ExpTable -> Clause -> q Clause -singClause vars (Clause pats (NormalB exp) []) = do - (sPats, vartbl) <- evalForPair $ mapM (singPat Parameter) pats - let vars' = Map.union vartbl vars - sBody <- NormalB <$> singExp vars' exp - return $ Clause sPats sBody [] -singClause _ (Clause _ (GuardedB _) _) = - fail "Singling of guarded patterns not yet supported" -singClause _ (Clause _ _ (_:_)) = - fail "Singling of <> declarations not yet supported" - -type ExpsQ q = QWithAux ExpTable q - --- we need to know where a pattern is to anticipate when --- GHC's brain might explode -data PatternContext = LetBinding - | CaseStatement - | TopLevel - | Parameter - | Statement - deriving Eq - -checkIfBrainWillExplode :: Quasi q => PatternContext -> ExpsQ q () -checkIfBrainWillExplode CaseStatement = return () -checkIfBrainWillExplode Statement = return () -checkIfBrainWillExplode Parameter = return () -checkIfBrainWillExplode _ = - fail $ "Can't use a singleton pattern outside of a case-statement or\n" ++ - "do expression: GHC's brain will explode if you try. (Do try it!)" - --- convert a pattern, building up the lexical scope as we go -singPat :: Quasi q => PatternContext -> Pat -> ExpsQ q Pat -singPat _patCxt (LitP _lit) = - fail "Singling of literal patterns not yet supported" -singPat patCxt (VarP name) = - let new = if patCxt == TopLevel then singValName name else name in do - addBinding name (VarE new) - return $ VarP new -singPat patCxt (TupP pats) = - singPat patCxt (ConP (tupleDataName (length pats)) pats) -singPat _patCxt (UnboxedTupP _pats) = - fail "Singling of unboxed tuples not supported" -singPat patCxt (ConP name pats) = do - checkIfBrainWillExplode patCxt - pats' <- mapM (singPat patCxt) pats - return $ ConP (singDataConName name) pats' -singPat patCxt (InfixP pat1 name pat2) = singPat patCxt (ConP name [pat1, pat2]) -singPat _patCxt (UInfixP _ _ _) = - fail "Singling of unresolved infix patterns not supported" -singPat _patCxt (ParensP _) = - fail "Singling of unresolved paren patterns not supported" -singPat patCxt (TildeP pat) = do - pat' <- singPat patCxt pat - return $ TildeP pat' -singPat patCxt (BangP pat) = do - pat' <- singPat patCxt pat - return $ BangP pat' -singPat patCxt (AsP name pat) = do - let new = if patCxt == TopLevel then singValName name else name in do - pat' <- singPat patCxt pat - addBinding name (VarE new) - return $ AsP name pat' -singPat _patCxt WildP = return WildP -singPat _patCxt (RecP _name _fields) = - fail "Singling of record patterns not yet supported" -singPat patCxt (ListP pats) = do - checkIfBrainWillExplode patCxt - sPats <- mapM (singPat patCxt) pats - return $ foldr (\elt lst -> ConP sconsName [elt, lst]) (ConP snilName []) sPats -singPat _patCxt (SigP _pat _ty) = - fail "Singling of annotated patterns not yet supported" -singPat _patCxt (ViewP _exp _pat) = - fail "Singling of view patterns not yet supported" - -singExp :: Quasi q => ExpTable -> Exp -> q Exp -singExp vars (VarE name) = case Map.lookup name vars of - Just exp -> return exp - Nothing -> return (singVal name) -singExp _vars (ConE name) = return $ singDataCon name -singExp _vars (LitE lit) = singLit lit -singExp vars (AppE exp1 exp2) = do - exp1' <- singExp vars exp1 - exp2' <- singExp vars exp2 - return $ AppE exp1' exp2' -singExp vars (InfixE mexp1 exp mexp2) = - case (mexp1, mexp2) of - (Nothing, Nothing) -> singExp vars exp - (Just exp1, Nothing) -> singExp vars (AppE exp exp1) - (Nothing, Just _exp2) -> - fail "Singling of right-only sections not yet supported" - (Just exp1, Just exp2) -> singExp vars (AppE (AppE exp exp1) exp2) -singExp _vars (UInfixE _ _ _) = - fail "Singling of unresolved infix expressions not supported" -singExp _vars (ParensE _) = - fail "Singling of unresolved paren expressions not supported" -singExp vars (LamE pats exp) = do - (pats', vartbl) <- evalForPair $ mapM (singPat Parameter) pats - let vars' = Map.union vartbl vars -- order matters; union is left-biased - exp' <- singExp vars' exp - return $ LamE pats' exp' -singExp _vars (LamCaseE _matches) = - fail "Singling of case expressions not yet supported" -singExp vars (TupE exps) = do - sExps <- mapM (singExp vars) exps - sTuple <- singExp vars (ConE (tupleDataName (length exps))) - return $ foldExp sTuple sExps -singExp _vars (UnboxedTupE _exps) = - fail "Singling of unboxed tuple not supported" -singExp vars (CondE bexp texp fexp) = do - exps <- mapM (singExp vars) [bexp, texp, fexp] - return $ foldExp (VarE sIfName) exps -singExp _vars (MultiIfE _alts) = - fail "Singling of multi-way if statements not yet supported" -singExp _vars (LetE _decs _exp) = - fail "Singling of let expressions not yet supported" -singExp _vars (CaseE _exp _matches) = - fail "Singling of case expressions not yet supported" -singExp _vars (DoE _stmts) = - fail "Singling of do expressions not yet supported" -singExp _vars (CompE _stmts) = - fail "Singling of list comprehensions not yet supported" -singExp _vars (ArithSeqE _range) = - fail "Singling of ranges not yet supported" -singExp vars (ListE exps) = do - sExps <- mapM (singExp vars) exps - return $ foldr (\x -> (AppE (AppE (ConE sconsName) x))) - (ConE snilName) sExps -singExp _vars (SigE _exp _ty) = - fail "Singling of annotated expressions not yet supported" -singExp _vars (RecConE _name _fields) = - fail "Singling of record construction not yet supported" -singExp _vars (RecUpdE _exp _fields) = - fail "Singling of record updates not yet supported" - -singLit :: Quasi q => Lit -> q Exp -singLit lit = SigE (VarE singMethName) <$> (AppT singFamily <$> (promoteLit lit)) diff --git a/src/Data/Singletons/TH.hs b/src/Data/Singletons/TH.hs deleted file mode 100644 --- a/src/Data/Singletons/TH.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE ExplicitNamespaces, CPP #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TH --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- This module contains everything you need to derive your own singletons via --- Template Haskell. --- --- TURN ON @-XScopedTypeVariables@ IN YOUR MODULE IF YOU WANT THIS TO WORK. --- ----------------------------------------------------------------------------- - -module Data.Singletons.TH ( - -- * Primary Template Haskell generation functions - singletons, singletonsOnly, genSingletons, - promote, promoteOnly, - - -- ** Functions to generate equality instances - promoteEqInstances, promoteEqInstance, - singEqInstances, singEqInstance, - singEqInstancesOnly, singEqInstanceOnly, - singDecideInstances, singDecideInstance, - - -- ** Utility function - cases, - - -- * Basic singleton definitions - Sing(SFalse, STrue), SingI(..), SingKind(..), KindOf, Demote, - - -- * Auxiliary definitions - -- | These definitions might be mentioned in code generated by Template Haskell, - -- so they must be in scope. - - type (==), (:==), If, sIf, (:&&), SEq(..), - Any, - SDecide(..), (:~:)(..), Void, Refuted, Decision(..), - KProxy(..), SomeSing(..) - ) where - -import Data.Singletons -import Data.Singletons.Singletons -import Data.Singletons.Promote -import Data.Singletons.Instances -import Data.Singletons.Bool -import Data.Singletons.Eq -import Data.Singletons.Types -import Data.Singletons.Void -import Data.Singletons.Decide - -import GHC.Exts -import Language.Haskell.TH -import Language.Haskell.TH.Syntax ( Quasi(..) ) -import Language.Haskell.TH.Desugar -import Data.Singletons.Util -import Control.Applicative - --- | The function 'cases' generates a case expression where each right-hand side --- is identical. This may be useful if the type-checker requires knowledge of which --- constructor is used to satisfy equality or type-class constraints, but where --- each constructor is treated the same. -cases :: Quasi q - => Name -- ^ The head of the type of the scrutinee. (Like @''Maybe@ or @''Bool@.) - -> q Exp -- ^ The scrutinee, in a Template Haskell quote - -> q Exp -- ^ The body, in a Template Haskell quote - -> q Exp -cases tyName expq bodyq = do - info <- reifyWithWarning tyName - case info of - TyConI (DataD _ _ _ ctors _) -> buildCases ctors - TyConI (NewtypeD _ _ _ ctor _) -> buildCases [ctor] - _ -> fail $ "Using <> with something other than a type constructor: " - ++ (show tyName) - where buildCases ctors = - CaseE <$> expq <*> - mapM (\con -> Match (conToPat con) <$> - (NormalB <$> bodyq) <*> pure []) ctors - - conToPat :: Con -> Pat - conToPat = ctor1Case - (\name tys -> ConP name (map (const WildP) tys)) diff --git a/src/Data/Singletons/Tuple.hs b/src/Data/Singletons/Tuple.hs deleted file mode 100644 --- a/src/Data/Singletons/Tuple.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, DataKinds, PolyKinds, - RankNTypes, TypeFamilies, GADTs, CPP #-} - -#if __GLASGOW_HASKELL__ < 707 -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -#endif - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Tuple --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines functions and datatypes relating to the singleton for tuples, --- including a singletons version of all the definitions in @Data.Tuple@. --- --- Because many of these definitions are produced by Template Haskell, --- it is not possible to create proper Haddock documentation. Please look --- up the corresponding operation in @Data.Tuple@. Also, please excuse --- the apparent repeated variable names. This is due to an interaction --- between Template Haskell and Haddock. --- ----------------------------------------------------------------------------- - -module Data.Singletons.Tuple ( - -- * Singleton definitions - -- | See 'Data.Singletons.Prelude.Sing' for more info. - Sing(STuple0, STuple2, STuple3, STuple4, STuple5, STuple6, STuple7), - STuple0, STuple2, STuple3, STuple4, STuple5, STuple6, STuple7, - - -- * Singletons from @Data.Tuple@ - Fst, sFst, Snd, sSnd, Curry, sCurry, Uncurry, sUncurry, Swap, sSwap - ) where - -import Data.Singletons.Instances -import Data.Singletons.TH - -$(singletonsOnly [d| - -- | Extract the first component of a pair. - fst :: (a,b) -> a - fst (x,_) = x - - -- | Extract the second component of a pair. - snd :: (a,b) -> b - snd (_,y) = y - - -- | 'curry' converts an uncurried function to a curried function. - curry :: ((a, b) -> c) -> a -> b -> c - curry f x y = f (x, y) - - -- | 'uncurry' converts a curried function to a function on pairs. - uncurry :: (a -> b -> c) -> ((a, b) -> c) - uncurry f p = f (fst p) (snd p) - - -- | Swap the components of a pair. - swap :: (a,b) -> (b,a) - swap (a,b) = (b,a) - |]) diff --git a/src/Data/Singletons/TypeLits.hs b/src/Data/Singletons/TypeLits.hs deleted file mode 100644 --- a/src/Data/Singletons/TypeLits.hs +++ /dev/null @@ -1,181 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TypeLits --- Copyright : (C) 2014 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines and exports singletons useful for the Nat and Symbol kinds. --- ----------------------------------------------------------------------------- - -{-# LANGUAGE CPP, PolyKinds, DataKinds, TypeFamilies, FlexibleInstances, - UndecidableInstances, ScopedTypeVariables, RankNTypes, - GADTs, FlexibleContexts #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -#if __GLASGOW_HASKELL__ < 707 -{-# OPTIONS_GHC -O0 #-} -- don't optimize SDecide instances in 7.6! -#endif - -module Data.Singletons.TypeLits ( - Nat, Symbol, - SNat, SSymbol, withKnownNat, withKnownSymbol, - Error, sError, - KnownNat, natVal, KnownSymbol, symbolVal - ) where - -import Data.Singletons -import Data.Singletons.Types -import Data.Singletons.Eq -import Data.Singletons.Decide -import Data.Singletons.Bool -#if __GLASGOW_HASKELL__ >= 707 -import GHC.TypeLits -#else -import GHC.TypeLits (Nat, Symbol) -import qualified GHC.TypeLits as TL -#endif -import Unsafe.Coerce - ----------------------------------------------------------------------- ----- TypeLits singletons --------------------------------------------- ----------------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ >= 707 -data instance Sing (n :: Nat) = KnownNat n => SNat - -instance KnownNat n => SingI n where - sing = SNat - -instance SingKind ('KProxy :: KProxy Nat) where - type DemoteRep ('KProxy :: KProxy Nat) = Integer - fromSing (SNat :: Sing n) = natVal (Proxy :: Proxy n) - toSing n = case someNatVal n of - Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNat :: Sing n) - Nothing -> error "Negative singleton nat" - -data instance Sing (n :: Symbol) = KnownSymbol n => SSym - -instance KnownSymbol n => SingI n where - sing = SSym - -instance SingKind ('KProxy :: KProxy Symbol) where - type DemoteRep ('KProxy :: KProxy Symbol) = String - fromSing (SSym :: Sing n) = symbolVal (Proxy :: Proxy n) - toSing s = case someSymbolVal s of - SomeSymbol (_ :: Proxy n) -> SomeSing (SSym :: Sing n) - -#else - -data TLSingInstance (a :: k) where - TLSingInstance :: TL.SingI a => TLSingInstance a - -newtype DI a = Don'tInstantiate (TL.SingI a => TLSingInstance a) - -tlSingInstance :: forall (a :: k). TL.Sing a -> TLSingInstance a -tlSingInstance s = with_sing_i TLSingInstance - where - with_sing_i :: (TL.SingI a => TLSingInstance a) -> TLSingInstance a - with_sing_i si = unsafeCoerce (Don'tInstantiate si) s - -withTLSingI :: TL.Sing n -> (TL.SingI n => r) -> r -withTLSingI sn r = - case tlSingInstance sn of - TLSingInstance -> r - -data instance Sing (n :: Nat) = TL.SingRep n Integer => SNat - -instance TL.SingRep n Integer => SingI (n :: Nat) where - sing = SNat - -instance SingKind ('KProxy :: KProxy Nat) where - type DemoteRep ('KProxy :: KProxy Nat) = Integer - fromSing (SNat :: Sing n) = TL.fromSing (TL.sing :: TL.Sing n) - toSing n - | n >= 0 = case TL.unsafeSingNat n of - (tlsing :: TL.Sing n) -> - withTLSingI tlsing (SomeSing (SNat :: Sing n)) - | otherwise = error "Negative singleton nat" - -data instance Sing (n :: Symbol) = TL.SingRep n String => SSym - -instance TL.SingRep n String => SingI (n :: Symbol) where - sing = SSym - -instance SingKind ('KProxy :: KProxy Symbol) where - type DemoteRep ('KProxy :: KProxy Symbol) = String - fromSing (SSym :: Sing n) = TL.fromSing (TL.sing :: TL.Sing n) - toSing n = case TL.unsafeSingSymbol n of - (tlsing :: TL.Sing n) -> - withTLSingI tlsing (SomeSing (SSym :: Sing n)) - --- create 7.8-style TypeLits definitions: -class KnownNat (n :: Nat) where - natVal :: proxy n -> Integer - -class KnownSymbol (n :: Symbol) where - symbolVal :: proxy n -> String - -instance TL.SingI n => KnownNat n where - natVal _ = TL.fromSing (TL.sing :: TL.Sing n) - -instance TL.SingI n => KnownSymbol n where - symbolVal _ = TL.fromSing (TL.sing :: TL.Sing n) - -#endif - --- SDecide instances: -instance SDecide ('KProxy :: KProxy Nat) where - (SNat :: Sing n) %~ (SNat :: Sing m) - | natVal (Proxy :: Proxy n) == natVal (Proxy :: Proxy m) - = Proved $ unsafeCoerce Refl - | otherwise - = Disproved (\_ -> error errStr) - where errStr = "Broken Nat singletons" - -instance SDecide ('KProxy :: KProxy Symbol) where - (SSym :: Sing n) %~ (SSym :: Sing m) - | symbolVal (Proxy :: Proxy n) == symbolVal (Proxy :: Proxy m) - = Proved $ unsafeCoerce Refl - | otherwise - = Disproved (\_ -> error errStr) - where errStr = "Broken Symbol singletons" - --- need SEq instances for TypeLits kinds -instance SEq ('KProxy :: KProxy Nat) where - a %:== b - | fromSing a == fromSing b = unsafeCoerce STrue - | otherwise = unsafeCoerce SFalse - -instance SEq ('KProxy :: KProxy Symbol) where - a %:== b - | fromSing a == fromSing b = unsafeCoerce STrue - | otherwise = unsafeCoerce SFalse - --- | Kind-restricted synonym for 'Sing' for @Nat@s -type SNat (x :: Nat) = Sing x - --- | Kind-restricted synonym for 'Sing' for @Symbol@s -type SSymbol (x :: Symbol) = Sing x - --- Convenience functions - --- | Given a singleton for @Nat@, call something requiring a --- @KnownNat@ instance. -withKnownNat :: Sing n -> (KnownNat n => r) -> r -withKnownNat SNat f = f - --- | Given a singleton for @Symbol@, call something requiring --- a @KnownSymbol@ instance. -withKnownSymbol :: Sing n -> (KnownSymbol n => r) -> r -withKnownSymbol SSym f = f - --- | The promotion of 'error' -type family Error (str :: Symbol) :: k - --- | The singleton for 'error' -sError :: Sing (str :: Symbol) -> a -sError sstr = error (fromSing sstr) diff --git a/src/Data/Singletons/TypeRepStar.hs b/src/Data/Singletons/TypeRepStar.hs deleted file mode 100644 --- a/src/Data/Singletons/TypeRepStar.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE RankNTypes, TypeFamilies, KindSignatures, FlexibleInstances, - GADTs, UndecidableInstances, ScopedTypeVariables, DataKinds, - MagicHash, CPP, TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TypeRepStar --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- This module defines singleton instances making 'Typeable' the singleton for --- the kind @*@. The definitions don't fully line up with what is expected --- within the singletons library, so expect unusual results! --- ----------------------------------------------------------------------------- - -module Data.Singletons.TypeRepStar ( - Sing(STypeRep) - -- | Here is the definition of the singleton for @*@: - -- - -- > data instance Sing (a :: *) where - -- > STypeRep :: Typeable a => Sing a - -- - -- Instances for 'SingI', 'SingKind', 'SEq', 'SDecide', and 'TestCoercion' are - -- also supplied. - ) where - -import Data.Singletons.Instances -import Data.Singletons -import Data.Singletons.Types -import Data.Singletons.Eq -import Data.Typeable -import Unsafe.Coerce -import Data.Singletons.Decide - -#if __GLASGOW_HASKELL__ >= 707 -import GHC.Exts ( Proxy# ) -import Data.Type.Coercion -#else - -eqT :: (Typeable a, Typeable b) => Maybe (a :~: b) -eqT = gcast Refl - -type instance (a :: *) :== (a :: *) = True - -#endif - -data instance Sing (a :: *) where - STypeRep :: Typeable a => Sing a - -instance Typeable a => SingI (a :: *) where - sing = STypeRep -instance SingKind ('KProxy :: KProxy *) where - type DemoteRep ('KProxy :: KProxy *) = TypeRep - fromSing (STypeRep :: Sing a) = typeOf (undefined :: a) - toSing = dirty_mk_STypeRep - -instance SEq ('KProxy :: KProxy *) where - (STypeRep :: Sing a) %:== (STypeRep :: Sing b) = - case (eqT :: Maybe (a :~: b)) of - Just Refl -> STrue - Nothing -> unsafeCoerce SFalse - -- the Data.Typeable interface isn't strong enough - -- to enable us to define this without unsafeCoerce - -instance SDecide ('KProxy :: KProxy *) where - (STypeRep :: Sing a) %~ (STypeRep :: Sing b) = - case (eqT :: Maybe (a :~: b)) of - Just Refl -> Proved Refl - Nothing -> Disproved (\Refl -> error "Data.Typeable.eqT failed") - -#if __GLASGOW_HASKELL__ >= 707 --- TestEquality instance already defined, but we need this one: -instance TestCoercion Sing where - testCoercion (STypeRep :: Sing a) (STypeRep :: Sing b) = - case (eqT :: Maybe (a :~: b)) of - Just Refl -> Just Coercion - Nothing -> Nothing -#endif - --- everything below here is private and dirty. Don't look! - -newtype DI = Don'tInstantiate (Typeable a => Sing a) -dirty_mk_STypeRep :: TypeRep -> SomeSing ('KProxy :: KProxy *) -dirty_mk_STypeRep rep = -#if __GLASGOW_HASKELL__ >= 707 - let justLikeTypeable :: Proxy# a -> TypeRep - justLikeTypeable _ = rep - in -#else - let justLikeTypeable :: a -> TypeRep - justLikeTypeable _ = rep - in -#endif - unsafeCoerce (Don'tInstantiate STypeRep) justLikeTypeable diff --git a/src/Data/Singletons/Types.hs b/src/Data/Singletons/Types.hs deleted file mode 100644 --- a/src/Data/Singletons/Types.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE PolyKinds, TypeOperators, GADTs, RankNTypes, TypeFamilies, - CPP, DataKinds #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Types --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines and exports types that are useful when working with singletons. --- Some of these are re-exports from @Data.Type.Equality@. --- ----------------------------------------------------------------------------- - - -module Data.Singletons.Types ( - KProxy(..), Proxy(..), - (:~:)(..), gcastWith, TestEquality(..), - Not, If, type (==), (:==) - ) where - -#if __GLASGOW_HASKELL__ < 707 - --- now in Data.Proxy -data KProxy (a :: *) = KProxy -data Proxy a = Proxy - --- now in Data.Type.Equality -data a :~: b where - Refl :: a :~: a - -gcastWith :: (a :~: b) -> ((a ~ b) => r) -> r -gcastWith Refl x = x - -class TestEquality (f :: k -> *) where - testEquality :: f a -> f b -> Maybe (a :~: b) - --- now in Data.Type.Bool --- | Type-level "If". @If True a b@ ==> @a@; @If False a b@ ==> @b@ -type family If (a :: Bool) (b :: k) (c :: k) :: k -type instance If 'True b c = b -type instance If 'False b c = c - -type family (a :: k) :== (b :: k) :: Bool -type a == b = a :== b - -type family Not (b :: Bool) :: Bool -type instance Not True = False -type instance Not False = True - -#else - -import Data.Proxy -import Data.Type.Equality -import Data.Type.Bool - --- | A re-export of the type-level @(==)@ that conforms to the singletons naming --- convention. -type a :== b = a == b - -#endif diff --git a/src/Data/Singletons/Util.hs b/src/Data/Singletons/Util.hs deleted file mode 100644 --- a/src/Data/Singletons/Util.hs +++ /dev/null @@ -1,267 +0,0 @@ -{- Data/Singletons/Util.hs - -(c) Richard Eisenberg 2013 -eir@cis.upenn.edu - -This file contains helper functions internal to the singletons package. -Users of the package should not need to consult this file. --} - -{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances, RankNTypes, - TemplateHaskell, GeneralizedNewtypeDeriving, - MultiParamTypeClasses #-} - -module Data.Singletons.Util ( - module Data.Singletons.Util, - module Language.Haskell.TH.Desugar ) - where - -import Prelude hiding ( exp ) -import Language.Haskell.TH hiding ( Q ) -import Language.Haskell.TH.Syntax ( Quasi(..) ) -import Language.Haskell.TH.Desugar ( reifyWithWarning, getDataD ) -import Data.Char -import Control.Monad -import Control.Applicative -import Control.Monad.Writer -import qualified Data.Map as Map - -mkTyFamInst :: Name -> [Type] -> Type -> Dec -mkTyFamInst name lhs rhs = -#if __GLASGOW_HASKELL__ >= 707 - TySynInstD name (TySynEqn lhs rhs) -#else - TySynInstD name lhs rhs -#endif - --- The list of types that singletons processes by default -basicTypes :: [Name] -basicTypes = [ ''Bool - , ''Maybe - , ''Either - , ''Ordering - , ''[] - , ''() - , ''(,) - , ''(,,) - , ''(,,,) - , ''(,,,,) - , ''(,,,,,) - , ''(,,,,,,) - ] - --- like newName, but even more unique (unique across different splices) --- TH doesn't allow "newName"s to work at the top-level, so we have to --- do this trick to ensure the Extract functions are unique -newUniqueName :: Quasi q => String -> q Name -newUniqueName str = do - n <- qNewName str - return $ mkName $ show n - --- like reportWarning, but generalized to any Quasi -qReportWarning :: Quasi q => String -> q () -qReportWarning = qReport False - --- like reportError, but generalized to any Quasi -qReportError :: Quasi q => String -> q () -qReportError = qReport True - --- extract the degree of a tuple -tupleDegree_maybe :: String -> Maybe Int -tupleDegree_maybe s = do - '(' : s1 <- return s - (commas, ")") <- return $ span (== ',') s1 - let degree - | "" <- commas = 0 - | otherwise = length commas + 1 - return degree - --- extract the degree of a tuple name -tupleNameDegree_maybe :: Name -> Maybe Int -tupleNameDegree_maybe = tupleDegree_maybe . nameBase - --- reduce the four cases of a 'Con' to just two: monomorphic and polymorphic --- and convert 'StrictType' to 'Type' -ctorCases :: (Name -> [Type] -> a) -> ([TyVarBndr] -> Cxt -> Con -> a) -> Con -> a -ctorCases genFun forallFun ctor = case ctor of - NormalC name stypes -> genFun name (map snd stypes) - RecC name vstypes -> genFun name (map (\(_,_,ty) -> ty) vstypes) - InfixC (_,ty1) name (_,ty2) -> genFun name [ty1, ty2] - ForallC [] [] ctor' -> ctorCases genFun forallFun ctor' - ForallC tvbs cx ctor' -> forallFun tvbs cx ctor' - --- reduce the four cases of a 'Con' to just 1: a polymorphic Con is treated --- as a monomorphic one -ctor1Case :: (Name -> [Type] -> a) -> Con -> a -ctor1Case mono = ctorCases mono (\_ _ ctor -> ctor1Case mono ctor) - --- extract the name and number of arguments to a constructor -extractNameArgs :: Con -> (Name, Int) -extractNameArgs = ctor1Case (\name tys -> (name, length tys)) - --- reinterpret a name. This is useful when a Name has an associated --- namespace that we wish to forget -reinterpret :: Name -> Name -reinterpret = mkName . nameBase - --- is an identifier uppercase? -isUpcase :: Name -> Bool -isUpcase n = let first = head (nameBase n) in isUpper first || first == ':' - --- make an identifier uppercase -upcase :: Name -> Name -upcase n = - let str = nameBase n - first = head str in - if isLetter first - then mkName ((toUpper first) : tail str) - else mkName (':' : str) - --- make an identifier lowercase -locase :: Name -> Name -locase n = - let str = nameBase n - first = head str in - if isLetter first - then mkName ((toLower first) : tail str) - else mkName (tail str) -- remove the ":" - --- put an uppercase prefix on a name. Takes two prefixes: one for identifiers --- and one for symbols -prefixUCName :: String -> String -> Name -> Name -prefixUCName pre tyPre n = case (nameBase n) of - (':' : rest) -> mkName (tyPre ++ rest) - alpha -> mkName (pre ++ alpha) - --- put a lowercase prefix on a name. Takes two prefixes: one for identifiers --- and one for symbols -prefixLCName :: String -> String -> Name -> Name -prefixLCName pre tyPre n = - let str = nameBase n - first = head str in - if isLetter first - then mkName (pre ++ str) - else mkName (tyPre ++ str) - --- extract the kind from a TyVarBndr. Returns '*' by default. -extractTvbKind :: TyVarBndr -> Kind -extractTvbKind (PlainTV _) = StarT -- FIXME: This seems wrong. -extractTvbKind (KindedTV _ k) = k - --- extract the name from a TyVarBndr. -extractTvbName :: TyVarBndr -> Name -extractTvbName (PlainTV n) = n -extractTvbName (KindedTV n _) = n - --- apply a type to a list of types -foldType :: Type -> [Type] -> Type -foldType = foldl AppT - --- apply an expression to a list of expressions -foldExp :: Exp -> [Exp] -> Exp -foldExp = foldl AppE - --- is a kind a variable? -isVarK :: Kind -> Bool -isVarK (VarT _) = True -isVarK _ = False - --- tuple up a list of expressions -mkTupleExp :: [Exp] -> Exp -mkTupleExp [x] = x -mkTupleExp xs = TupE xs - --- tuple up a list of patterns -mkTuplePat :: [Pat] -> Pat -mkTuplePat [x] = x -mkTuplePat xs = TupP xs - --- choose the first non-empty list -orIfEmpty :: [a] -> [a] -> [a] -orIfEmpty [] x = x -orIfEmpty x _ = x - --- an empty list of matches, compatible with GHC 7.6.3 -emptyMatches :: [Match] -emptyMatches = [Match WildP (NormalB (AppE (VarE 'error) (LitE (StringL errStr)))) []] - where errStr = "Empty case reached -- this should be impossible" - --- build a pattern match over several expressions, each with only one pattern -multiCase :: [Exp] -> [Pat] -> Exp -> Exp -multiCase [] [] body = body -multiCase scruts pats body = - CaseE (mkTupleExp scruts) - [Match (mkTuplePat pats) (NormalB body) []] - --- a monad transformer for writing a monoid alongside returning a Q -newtype QWithAux m q a = QWA { runQWA :: WriterT m q a } - deriving (Functor, Applicative, Monad, MonadTrans) - -instance (Monoid m, Monad q) => MonadWriter m (QWithAux m q) where - writer = QWA . writer - tell = QWA . tell - listen = QWA . listen . runQWA - pass = QWA . pass . runQWA - --- make a Quasi instance for easy lifting -instance (Quasi q, Monoid m) => Quasi (QWithAux m q) where - qNewName = lift `comp1` qNewName - qReport = lift `comp2` qReport - qLookupName = lift `comp2` qLookupName - qReify = lift `comp1` qReify - qReifyInstances = lift `comp2` qReifyInstances - qLocation = lift qLocation - qRunIO = lift `comp1` qRunIO - qAddDependentFile = lift `comp1` qAddDependentFile -#if __GLASGOW_HASKELL__ >= 707 - qReifyRoles = lift `comp1` qReifyRoles - qReifyAnnotations = lift `comp1` qReifyAnnotations - qReifyModule = lift `comp1` qReifyModule - qAddTopDecls = lift `comp1` qAddTopDecls - qAddModFinalizer = lift `comp1` qAddModFinalizer - qGetQ = lift qGetQ - qPutQ = lift `comp1` qPutQ -#endif - - qRecover exp handler = do - (result, aux) <- lift $ qRecover (evalForPair exp) (evalForPair handler) - tell aux - return result - --- helper functions for composition -comp1 :: (b -> c) -> (a -> b) -> a -> c -comp1 = (.) - -comp2 :: (c -> d) -> (a -> b -> c) -> a -> b -> d -comp2 f g a b = f (g a b) - --- run a computation with an auxiliary monoid, discarding the monoid result -evalWithoutAux :: Quasi q => QWithAux m q a -> q a -evalWithoutAux = liftM fst . runWriterT . runQWA - --- run a computation with an auxiliary monoid, returning only the monoid result -evalForAux :: Quasi q => QWithAux m q a -> q m -evalForAux = execWriterT . runQWA - --- run a computation with an auxiliary monoid, return both the result --- of the computation and the monoid result -evalForPair :: Quasi q => QWithAux m q a -> q (a, m) -evalForPair = runWriterT . runQWA - --- in a computation with an auxiliary map, add a binding to the map -addBinding :: (Quasi q, Ord k) => k -> v -> QWithAux (Map.Map k v) q () -addBinding k v = tell (Map.singleton k v) - --- in a computation with an auxiliar list, add an element to the list -addElement :: Quasi q => elt -> QWithAux [elt] q () -addElement elt = tell [elt] - --- lift concatMap into a monad -concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] -concatMapM fn list = do - bss <- mapM fn list - return $ concat bss - --- make a one-element list -listify :: a -> [a] -listify = return diff --git a/src/Data/Singletons/Void.hs b/src/Data/Singletons/Void.hs deleted file mode 100644 --- a/src/Data/Singletons/Void.hs +++ /dev/null @@ -1,78 +0,0 @@ -{- Data/Singletons/Void.hs - - A reimplementation of a Void type, copied shamelessly from Edward Kmett's void - package, but without inducing a dependency. - --} - -{-# LANGUAGE CPP, Trustworthy, DeriveDataTypeable, DeriveGeneric, StandaloneDeriving #-} - ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2008-2013 Edward Kmett --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- This module is a reimplementation of Edward Kmett's @void@ package. --- It is included within singletons to avoid depending on @void@ and all the --- packages that depends on (including @text@). If this causes problems for --- you (that singletons has its own 'Void' type), please let me (Richard Eisenberg) --- know at @eir@ at @cis.upenn.edu@. --- ----------------------------------------------------------------------------- -module Data.Singletons.Void - ( Void - , absurd - , vacuous - , vacuousM - ) where - -import Control.Monad (liftM) -import Data.Ix -import Data.Data -import GHC.Generics -import Control.Exception - --- | A logically uninhabited data type. -newtype Void = Void Void - deriving (Data, Typeable, Generic) - -instance Eq Void where - _ == _ = True - -instance Ord Void where - compare _ _ = EQ - -instance Show Void where - showsPrec _ = absurd - --- | Reading a 'Void' value is always a parse error, considering 'Void' as --- a data type with no constructors. -instance Read Void where - readsPrec _ _ = [] - --- | Since 'Void' values logically don't exist, this witnesses the logical --- reasoning tool of \"ex falso quodlibet\". -absurd :: Void -> a -absurd a = a `seq` spin a where - spin (Void b) = spin b - --- | If 'Void' is uninhabited then any 'Functor' that holds only values of type 'Void' --- is holding no values. -vacuous :: Functor f => f Void -> f a -vacuous = fmap absurd - --- | If 'Void' is uninhabited then any 'Monad' that holds values of type 'Void' --- is holding no values. -vacuousM :: Monad m => m Void -> m a -vacuousM = liftM absurd - -instance Ix Void where - range _ = [] - index _ = absurd - inRange _ = absurd - rangeSize _ = 0 - -instance Exception Void diff --git a/tests/ByHand.hs b/tests/ByHand.hs new file mode 100644 --- /dev/null +++ b/tests/ByHand.hs @@ -0,0 +1,1088 @@ +{- 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) +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @Nat = +#else +type instance Sing = +#endif + 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 +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @Bool = +#else +type instance Sing = +#endif + 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) +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @(Maybe k) = +#else +type instance Sing = +#endif + 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) +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @(List k) = +#else +type instance Sing = +#endif + 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) +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @(Either k1 k2) = +#else +type instance Sing = +#endif + 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) +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @(Composite k1 k2) = +#else +type instance Sing = +#endif + 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 + +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @Empty = +#else +type instance Sing = +#endif + 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) +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @Type = +#else +type instance Sing = +#endif + 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 +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @(G a) = +#else +type instance Sing = +#endif + SG diff --git a/tests/ByHand2.hs b/tests/ByHand2.hs new file mode 100644 --- /dev/null +++ b/tests/ByHand2.hs @@ -0,0 +1,302 @@ +{-# LANGUAGE DataKinds, PolyKinds, TypeFamilies, GADTs, TypeOperators, + DefaultSignatures, ScopedTypeVariables, InstanceSigs, + MultiParamTypeClasses, FunctionalDependencies, + UndecidableInstances, CPP, TypeApplications #-} +{-# 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) +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @Nat = +#else +type instance Sing = +#endif + 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 +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @Bool = +#else +type instance Sing = +#endif + 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 +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @Ordering = +#else +type instance Sing = +#endif + 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 diff --git a/tests/SingletonsTestSuite.hs b/tests/SingletonsTestSuite.hs --- a/tests/SingletonsTestSuite.hs +++ b/tests/SingletonsTestSuite.hs @@ -1,41 +1,6 @@ -module Main ( - main - ) where - -import Test.Tasty ( TestTree, defaultMain, testGroup ) -import SingletonsTestSuiteUtils ( compileAndDumpStdTest, compileAndDumpTest - , testCompileAndDumpGroup, ghcOpts ) +-- | 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 = defaultMain tests - -tests :: TestTree -tests = - testGroup "Testsuite" $ [ - testCompileAndDumpGroup "Singletons" - [ compileAndDumpStdTest "Nat" - , compileAndDumpStdTest "Empty" - , compileAndDumpStdTest "Maybe" - , compileAndDumpStdTest "BoxUnBox" - , compileAndDumpStdTest "Operators" - , compileAndDumpStdTest "BadPlus" - , compileAndDumpStdTest "HigherOrder" - , compileAndDumpStdTest "Contains" - , compileAndDumpStdTest "AtPattern" - , compileAndDumpStdTest "DataValues" - , compileAndDumpStdTest "EqInstances" - , compileAndDumpStdTest "Star" - ], - testCompileAndDumpGroup "Promote" - [ compileAndDumpStdTest "PatternMatching" - , compileAndDumpStdTest "NumArgs" -- remove once we have eta-expansion - ], - testGroup "Database client" - [ compileAndDumpTest "GradingClient/Database" ghcOpts - , compileAndDumpTest "GradingClient/Main" ghcOpts - ], - testCompileAndDumpGroup "InsertionSort" - [ compileAndDumpStdTest "InsertionSortImp" - ] - ] - +main = pure () diff --git a/tests/SingletonsTestSuiteUtils.hs b/tests/SingletonsTestSuiteUtils.hs deleted file mode 100644 --- a/tests/SingletonsTestSuiteUtils.hs +++ /dev/null @@ -1,233 +0,0 @@ -{-# LANGUAGE CPP, DeriveDataTypeable #-} -module SingletonsTestSuiteUtils ( - compileAndDumpTest - , compileAndDumpStdTest - , testCompileAndDumpGroup - , ghcOpts - , singletonsVersion - ) where - -import Control.Exception ( Exception, throw ) -import Data.List ( intercalate ) -import Data.Typeable ( Typeable ) -import System.Exit ( ExitCode(..) ) -import System.FilePath ( takeBaseName, pathSeparator ) -import System.IO ( IOMode(..), hGetContents, openFile ) -import System.Process ( CreateProcess(..), StdStream(..) - , createProcess, proc, waitForProcess ) -import Test.Tasty ( TestTree, testGroup ) -import Test.Tasty.Golden ( goldenVsFileDiff ) - -import Distribution.PackageDescription.Parse ( readPackageDescription ) -import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) -import Distribution.PackageDescription ( PackageDescription(..) ) -import Distribution.Verbosity ( silent ) -import Distribution.Package ( PackageIdentifier(..) ) -import Data.Version ( showVersion ) -import System.IO.Unsafe ( unsafePerformIO ) - --- Some infractructure for handling external process errors -data ProcessException = ProcessException String deriving (Typeable) - -instance Exception ProcessException - -instance Show ProcessException where - show (ProcessException msg) = msg - --- GHC executable name (if on path) or full path -ghcPath :: FilePath -ghcPath = "ghc" - --- directory storing compile-and-run tests and golden files -goldenPath :: FilePath -goldenPath = "tests/compile-and-dump/" - --- path containing compiled *.hi files. Relative to goldenPath. --- See Note [-package-name hack] -includePath :: FilePath -includePath = "../../dist/build" - -ghcVersion :: String -#if __GLASGOW_HASKELL__ < 706 -ghcVersion = error "testsuite requires GHC 7.6 or newer" -#else -#if __GLASGOW_HASKELL__ >= 706 && __GLASGOW_HASKELL__ < 707 -ghcVersion = ".ghc76" -#else -ghcVersion = ".ghc78" -#endif -#endif - --- the version number of "singletons" -singletonsVersion :: String -singletonsVersion = unsafePerformIO $ do - gpd <- readPackageDescription silent "singletons.cabal" - let pd = flattenPackageDescription gpd - return $ showVersion $ pkgVersion $ package pd - --- GHC options used when running the tests -ghcOpts :: [String] -ghcOpts = [ - "-v0" - , "-c" - , "-package-name singletons-" ++ singletonsVersion -- See Note [-package-name hack] - , "-ddump-splices" - , "-dsuppress-uniques" - , "-fforce-recomp" - , "-i" ++ includePath - , "-XTemplateHaskell" - , "-XDataKinds" - , "-XKindSignatures" - , "-XTypeFamilies" - , "-XTemplateHaskell" - , "-XTypeOperators" - , "-XKindSignatures" - , "-XDataKinds" - , "-XMultiParamTypeClasses" - , "-XGADTs" - , "-XTypeFamilies" - , "-XFlexibleInstances" - , "-XUndecidableInstances" - , "-XRankNTypes" - , "-XScopedTypeVariables" - , "-XPolyKinds" - , "-XFlexibleContexts" - , "-XIncoherentInstances" - , "-XCPP" - ] - --- Note [-package-name hack] --- ~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- We want to avoid installing singletons package before running the --- testsuite, because in this way we prevent double compilation of the --- library. To do this we pass -package-name option to GHC to convince --- it that the test files are actually part of the current --- package. This means that library doesn't have to be installed --- globally and interface files generated during library compilation --- can be used when compiling test cases. We use "-i" option to point --- GHC to directory containing compiled interface files. - --- Compile a test using specified GHC options. Save output to file, filter with --- sed and compare it with golden file. This function also builds golden file --- from a template file. Putting it here is a bit of a hack but it's easy and it --- works. --- --- First parameter is a path to the test file relative to goldenPath directory --- with no ".hs". -compileAndDumpTest :: FilePath -> [String] -> TestTree -compileAndDumpTest testName opts = - goldenVsFileDiff - (takeBaseName testName) - (\ref new -> ["diff", "-w", "-B", ref, new]) -- see Note [Diff options] - goldenFilePath - actualFilePath - compileWithGHC - where - testPath = testName ++ ".hs" - templateFilePath = goldenPath ++ testName ++ ghcVersion ++ ".template" - goldenFilePath = goldenPath ++ testName ++ ".golden" - actualFilePath = goldenPath ++ testName ++ ".actual" - - compileWithGHC :: IO () - compileWithGHC = do - hActualFile <- openFile actualFilePath WriteMode - (_, _, _, pid) <- createProcess (proc ghcPath (testPath : opts)) - { std_out = UseHandle hActualFile - , std_err = UseHandle hActualFile - , cwd = Just goldenPath } - _ <- waitForProcess pid -- see Note [Ignore exit code] - filterWithSed actualFilePath -- see Note [Normalization with sed] - buildGoldenFile templateFilePath goldenFilePath - return () - --- Compile-and-dump test using standard GHC options defined by the testsuite. --- It takes two parameters: name of a file containing a test (no ".hs" --- extension) and directory where the test is located (relative to --- goldenPath). Test name and path are passed separately so that this function --- can be used easily with testCompileAndDumpGroup. -compileAndDumpStdTest :: FilePath -> FilePath -> TestTree -compileAndDumpStdTest testName testPath = - compileAndDumpTest (testPath ++ (pathSeparator : testName)) ghcOpts - --- A convenience function for defining a group of compile-and-dump tests stored --- in the same subdirectory. It takes the name of subdirectory and list of --- functions that given the name of subdirectory create a TestTree. Designed for --- use with compileAndDumpStdTest. -testCompileAndDumpGroup :: FilePath -> [FilePath -> TestTree] -> TestTree -testCompileAndDumpGroup testDir tests = - testGroup testDir $ map ($ testDir) tests - --- Note [Ignore exit code] --- ~~~~~~~~~~~~~~~~~~~~~~~ --- --- It may happen that compilation of a source file fails. We could find out --- whether that happened by inspecting the exit code of GHC process. But it --- would be tricky to get a helpful message from the failing test: we would need --- to display stderr which we just wrote into a file. Luckliy we don't have to --- do that - we can ignore the problem here and let the test fail when the --- actual file is compared with the golden file. - --- Note [Diff options] --- ~~~~~~~~~~~~~~~~~~~ --- --- We use following diff options: --- -w - Ignore all white space. --- -B - Ignore changes whose lines are all blank. - --- Note [Normalization with sed] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- Output file is normalized with sed. Line numbers generated in splices: --- --- Foo:(40,3)-(42,4) --- Foo.hs:7:3: --- Equals_1235967303 --- --- are turned into: --- --- Foo:(0,0)-(0,0) --- Foo.hs:0:0: --- Equals_0123456789 --- --- This allows to insert comments into test file without the need to modify the --- golden file to adjust line numbers. --- --- Note that GNU sed (on Linux) and BSD sed (on MacOS) are slightly different. --- We use conditional compilation to deal with this. - -filterWithSed :: FilePath -> IO () -filterWithSed file = runProcessWithOpts CreatePipe "sed" -#ifdef darwin_HOST_OS - [ "-i", "''" -#else - [ "-i" -#endif - , "-e", "'s/([0-9]*,[0-9]*)-([0-9]*,[0-9]*)/(0,0)-(0,0)/g'" - , "-e", "'s/:[0-9][0-9]*:[0-9][0-9]*/:0:0/g'" - , "-e", "'s/:[0-9]*:[0-9]*-[0-9]*/:0:0:/g'" - , "-e", "'s/[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]/0123456789/g'" - , file - ] - -buildGoldenFile :: FilePath -> FilePath -> IO () -buildGoldenFile templateFilePath goldenFilePath = do - hGoldenFile <- openFile goldenFilePath WriteMode - runProcessWithOpts (UseHandle hGoldenFile) "awk" - [ "-f", "tests/compile-and-dump/buildGoldenFiles.awk" - , templateFilePath - ] - -runProcessWithOpts :: StdStream -> String -> [String] -> IO () -runProcessWithOpts stdout program opts = do - (_, _, Just serr, pid) <- - createProcess (proc "bash" ["-c", (intercalate " " (program : opts))]) - { std_out = stdout - , std_err = CreatePipe } - ecode <- waitForProcess pid - case ecode of - ExitSuccess -> return () - ExitFailure _ -> do - err <- hGetContents serr -- Text would be faster than String, but this is - -- a corner case so probably not worth it. - throw $ ProcessException ("Error when running " ++ program ++ ":\n" ++ err) diff --git a/tests/compile-and-dump/GradingClient/Database.ghc76.template b/tests/compile-and-dump/GradingClient/Database.ghc76.template deleted file mode 100644 --- a/tests/compile-and-dump/GradingClient/Database.ghc76.template +++ /dev/null @@ -1,4470 +0,0 @@ -GradingClient/Database.hs:0:0: Splicing declarations - singletons - [d| data Nat - = Zero | Succ Nat - deriving (Eq, Ord) |] - ======> - GradingClient/Database.hs:(0,0)-(0,0) - data Nat - = Zero | Succ Nat - deriving (Eq, Ord) - type instance (:==) Zero Zero = True - type instance (:==) Zero (Succ b) = False - type instance (:==) (Succ a) Zero = False - type instance (:==) (Succ a) (Succ b) = :== a b - data instance Sing (z :: Nat) - = z ~ Zero => SZero | - forall (n :: Nat). z ~ Succ n => SSucc (Sing n) - type SNat (z :: Nat) = Sing z - instance SingKind (KProxy :: KProxy Nat) where - type instance DemoteRep (KProxy :: KProxy Nat) = Nat - fromSing SZero = Zero - fromSing (SSucc b) = Succ (fromSing b) - toSing Zero = SomeSing SZero - toSing (Succ b) - = case toSing b :: SomeSing (KProxy :: KProxy Nat) of { - SomeSing c -> SomeSing (SSucc c) } - instance SEq (KProxy :: KProxy Nat) where - %:== SZero SZero = STrue - %:== SZero (SSucc _) = SFalse - %:== (SSucc _) SZero = SFalse - %:== (SSucc a) (SSucc b) = (%:==) a b - instance SDecide (KProxy :: KProxy Nat) where - %~ SZero SZero = Proved Refl - %~ SZero (SSucc _) - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ (SSucc _) SZero - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ (SSucc a) (SSucc b) - = case (%~) a b of { - Proved Refl -> Proved Refl - Disproved contra -> Disproved (\ Refl -> contra Refl) } - instance SingI Zero where - sing = SZero - instance SingI n => SingI (Succ (n :: Nat)) where - sing = SSucc sing -GradingClient/Database.hs:0:0: Splicing declarations - singletons - [d| append :: Schema -> Schema -> Schema - append (Sch s1) (Sch s2) = Sch (s1 ++ s2) - attrNotIn :: Attribute -> Schema -> Bool - attrNotIn _ (Sch []) = True - attrNotIn (Attr name u) (Sch ((Attr name' _) : t)) - = (name /= name') && (attrNotIn (Attr name u) (Sch t)) - disjoint :: Schema -> Schema -> Bool - disjoint (Sch []) _ = True - disjoint (Sch (h : t)) s = (attrNotIn h s) && (disjoint (Sch t) s) - occurs :: [AChar] -> Schema -> Bool - occurs _ (Sch []) = False - occurs name (Sch ((Attr name' _) : attrs)) - = name == name' || occurs name (Sch attrs) - lookup :: [AChar] -> Schema -> U - lookup _ (Sch []) = undefined - lookup name (Sch ((Attr name' u) : attrs)) - = if name == name' then u else lookup name (Sch attrs) - - data U - = BOOL | STRING | NAT | VEC U Nat - deriving (Read, Eq, Show) - data AChar - = CA | - CB | - CC | - CD | - CE | - CF | - CG | - CH | - CI | - CJ | - CK | - CL | - CM | - CN | - CO | - CP | - CQ | - CR | - CS | - CT | - CU | - CV | - CW | - CX | - CY | - CZ - deriving (Read, Show, Eq) - data Attribute = Attr [AChar] U - data Schema = Sch [Attribute] |] - ======> - GradingClient/Database.hs:(0,0)-(0,0) - data U - = BOOL | STRING | NAT | VEC U Nat - deriving (Read, Eq, Show) - data AChar - = CA | - CB | - CC | - CD | - CE | - CF | - CG | - CH | - CI | - CJ | - CK | - CL | - CM | - CN | - CO | - CP | - CQ | - CR | - CS | - CT | - CU | - CV | - CW | - CX | - CY | - CZ - deriving (Read, Show, Eq) - data Attribute = Attr [AChar] U - data Schema = Sch [Attribute] - append :: Schema -> Schema -> Schema - append (Sch s1) (Sch s2) = Sch (s1 ++ s2) - attrNotIn :: Attribute -> Schema -> Bool - attrNotIn _ (Sch GHC.Types.[]) = True - attrNotIn (Attr name u) (Sch ((Attr name' _) GHC.Types.: t)) - = ((name /= name') && (attrNotIn (Attr name u) (Sch t))) - disjoint :: Schema -> Schema -> Bool - disjoint (Sch GHC.Types.[]) _ = True - disjoint (Sch (h GHC.Types.: t)) s - = ((attrNotIn h s) && (disjoint (Sch t) s)) - occurs :: [AChar] -> Schema -> Bool - occurs _ (Sch GHC.Types.[]) = False - occurs name (Sch ((Attr name' _) GHC.Types.: attrs)) - = ((name == name') || (occurs name (Sch attrs))) - lookup :: [AChar] -> Schema -> U - lookup _ (Sch GHC.Types.[]) = undefined - lookup name (Sch ((Attr name' u) GHC.Types.: attrs)) - = if (name == name') then u else lookup name (Sch attrs) - type instance (:==) BOOL BOOL = True - type instance (:==) BOOL STRING = False - type instance (:==) BOOL NAT = False - type instance (:==) BOOL (VEC b b) = False - type instance (:==) STRING BOOL = False - type instance (:==) STRING STRING = True - type instance (:==) STRING NAT = False - type instance (:==) STRING (VEC b b) = False - type instance (:==) NAT BOOL = False - type instance (:==) NAT STRING = False - type instance (:==) NAT NAT = True - type instance (:==) NAT (VEC b b) = False - type instance (:==) (VEC a a) BOOL = False - type instance (:==) (VEC a a) STRING = False - type instance (:==) (VEC a a) NAT = False - type instance (:==) (VEC a a) (VEC b b) = :&& (:== a b) (:== a b) - type instance (:==) CA CA = True - type instance (:==) CA CB = False - type instance (:==) CA CC = False - type instance (:==) CA CD = False - type instance (:==) CA CE = False - type instance (:==) CA CF = False - type instance (:==) CA CG = False - type instance (:==) CA CH = False - type instance (:==) CA CI = False - type instance (:==) CA CJ = False - type instance (:==) CA CK = False - type instance (:==) CA CL = False - type instance (:==) CA CM = False - type instance (:==) CA CN = False - type instance (:==) CA CO = False - type instance (:==) CA CP = False - type instance (:==) CA CQ = False - type instance (:==) CA CR = False - type instance (:==) CA CS = False - type instance (:==) CA CT = False - type instance (:==) CA CU = False - type instance (:==) CA CV = False - type instance (:==) CA CW = False - type instance (:==) CA CX = False - type instance (:==) CA CY = False - type instance (:==) CA CZ = False - type instance (:==) CB CA = False - type instance (:==) CB CB = True - type instance (:==) CB CC = False - type instance (:==) CB CD = False - type instance (:==) CB CE = False - type instance (:==) CB CF = False - type instance (:==) CB CG = False - type instance (:==) CB CH = False - type instance (:==) CB CI = False - type instance (:==) CB CJ = False - type instance (:==) CB CK = False - type instance (:==) CB CL = False - type instance (:==) CB CM = False - type instance (:==) CB CN = False - type instance (:==) CB CO = False - type instance (:==) CB CP = False - type instance (:==) CB CQ = False - type instance (:==) CB CR = False - type instance (:==) CB CS = False - type instance (:==) CB CT = False - type instance (:==) CB CU = False - type instance (:==) CB CV = False - type instance (:==) CB CW = False - type instance (:==) CB CX = False - type instance (:==) CB CY = False - type instance (:==) CB CZ = False - type instance (:==) CC CA = False - type instance (:==) CC CB = False - type instance (:==) CC CC = True - type instance (:==) CC CD = False - type instance (:==) CC CE = False - type instance (:==) CC CF = False - type instance (:==) CC CG = False - type instance (:==) CC CH = False - type instance (:==) CC CI = False - type instance (:==) CC CJ = False - type instance (:==) CC CK = False - type instance (:==) CC CL = False - type instance (:==) CC CM = False - type instance (:==) CC CN = False - type instance (:==) CC CO = False - type instance (:==) CC CP = False - type instance (:==) CC CQ = False - type instance (:==) CC CR = False - type instance (:==) CC CS = False - type instance (:==) CC CT = False - type instance (:==) CC CU = False - type instance (:==) CC CV = False - type instance (:==) CC CW = False - type instance (:==) CC CX = False - type instance (:==) CC CY = False - type instance (:==) CC CZ = False - type instance (:==) CD CA = False - type instance (:==) CD CB = False - type instance (:==) CD CC = False - type instance (:==) CD CD = True - type instance (:==) CD CE = False - type instance (:==) CD CF = False - type instance (:==) CD CG = False - type instance (:==) CD CH = False - type instance (:==) CD CI = False - type instance (:==) CD CJ = False - type instance (:==) CD CK = False - type instance (:==) CD CL = False - type instance (:==) CD CM = False - type instance (:==) CD CN = False - type instance (:==) CD CO = False - type instance (:==) CD CP = False - type instance (:==) CD CQ = False - type instance (:==) CD CR = False - type instance (:==) CD CS = False - type instance (:==) CD CT = False - type instance (:==) CD CU = False - type instance (:==) CD CV = False - type instance (:==) CD CW = False - type instance (:==) CD CX = False - type instance (:==) CD CY = False - type instance (:==) CD CZ = False - type instance (:==) CE CA = False - type instance (:==) CE CB = False - type instance (:==) CE CC = False - type instance (:==) CE CD = False - type instance (:==) CE CE = True - type instance (:==) CE CF = False - type instance (:==) CE CG = False - type instance (:==) CE CH = False - type instance (:==) CE CI = False - type instance (:==) CE CJ = False - type instance (:==) CE CK = False - type instance (:==) CE CL = False - type instance (:==) CE CM = False - type instance (:==) CE CN = False - type instance (:==) CE CO = False - type instance (:==) CE CP = False - type instance (:==) CE CQ = False - type instance (:==) CE CR = False - type instance (:==) CE CS = False - type instance (:==) CE CT = False - type instance (:==) CE CU = False - type instance (:==) CE CV = False - type instance (:==) CE CW = False - type instance (:==) CE CX = False - type instance (:==) CE CY = False - type instance (:==) CE CZ = False - type instance (:==) CF CA = False - type instance (:==) CF CB = False - type instance (:==) CF CC = False - type instance (:==) CF CD = False - type instance (:==) CF CE = False - type instance (:==) CF CF = True - type instance (:==) CF CG = False - type instance (:==) CF CH = False - type instance (:==) CF CI = False - type instance (:==) CF CJ = False - type instance (:==) CF CK = False - type instance (:==) CF CL = False - type instance (:==) CF CM = False - type instance (:==) CF CN = False - type instance (:==) CF CO = False - type instance (:==) CF CP = False - type instance (:==) CF CQ = False - type instance (:==) CF CR = False - type instance (:==) CF CS = False - type instance (:==) CF CT = False - type instance (:==) CF CU = False - type instance (:==) CF CV = False - type instance (:==) CF CW = False - type instance (:==) CF CX = False - type instance (:==) CF CY = False - type instance (:==) CF CZ = False - type instance (:==) CG CA = False - type instance (:==) CG CB = False - type instance (:==) CG CC = False - type instance (:==) CG CD = False - type instance (:==) CG CE = False - type instance (:==) CG CF = False - type instance (:==) CG CG = True - type instance (:==) CG CH = False - type instance (:==) CG CI = False - type instance (:==) CG CJ = False - type instance (:==) CG CK = False - type instance (:==) CG CL = False - type instance (:==) CG CM = False - type instance (:==) CG CN = False - type instance (:==) CG CO = False - type instance (:==) CG CP = False - type instance (:==) CG CQ = False - type instance (:==) CG CR = False - type instance (:==) CG CS = False - type instance (:==) CG CT = False - type instance (:==) CG CU = False - type instance (:==) CG CV = False - type instance (:==) CG CW = False - type instance (:==) CG CX = False - type instance (:==) CG CY = False - type instance (:==) CG CZ = False - type instance (:==) CH CA = False - type instance (:==) CH CB = False - type instance (:==) CH CC = False - type instance (:==) CH CD = False - type instance (:==) CH CE = False - type instance (:==) CH CF = False - type instance (:==) CH CG = False - type instance (:==) CH CH = True - type instance (:==) CH CI = False - type instance (:==) CH CJ = False - type instance (:==) CH CK = False - type instance (:==) CH CL = False - type instance (:==) CH CM = False - type instance (:==) CH CN = False - type instance (:==) CH CO = False - type instance (:==) CH CP = False - type instance (:==) CH CQ = False - type instance (:==) CH CR = False - type instance (:==) CH CS = False - type instance (:==) CH CT = False - type instance (:==) CH CU = False - type instance (:==) CH CV = False - type instance (:==) CH CW = False - type instance (:==) CH CX = False - type instance (:==) CH CY = False - type instance (:==) CH CZ = False - type instance (:==) CI CA = False - type instance (:==) CI CB = False - type instance (:==) CI CC = False - type instance (:==) CI CD = False - type instance (:==) CI CE = False - type instance (:==) CI CF = False - type instance (:==) CI CG = False - type instance (:==) CI CH = False - type instance (:==) CI CI = True - type instance (:==) CI CJ = False - type instance (:==) CI CK = False - type instance (:==) CI CL = False - type instance (:==) CI CM = False - type instance (:==) CI CN = False - type instance (:==) CI CO = False - type instance (:==) CI CP = False - type instance (:==) CI CQ = False - type instance (:==) CI CR = False - type instance (:==) CI CS = False - type instance (:==) CI CT = False - type instance (:==) CI CU = False - type instance (:==) CI CV = False - type instance (:==) CI CW = False - type instance (:==) CI CX = False - type instance (:==) CI CY = False - type instance (:==) CI CZ = False - type instance (:==) CJ CA = False - type instance (:==) CJ CB = False - type instance (:==) CJ CC = False - type instance (:==) CJ CD = False - type instance (:==) CJ CE = False - type instance (:==) CJ CF = False - type instance (:==) CJ CG = False - type instance (:==) CJ CH = False - type instance (:==) CJ CI = False - type instance (:==) CJ CJ = True - type instance (:==) CJ CK = False - type instance (:==) CJ CL = False - type instance (:==) CJ CM = False - type instance (:==) CJ CN = False - type instance (:==) CJ CO = False - type instance (:==) CJ CP = False - type instance (:==) CJ CQ = False - type instance (:==) CJ CR = False - type instance (:==) CJ CS = False - type instance (:==) CJ CT = False - type instance (:==) CJ CU = False - type instance (:==) CJ CV = False - type instance (:==) CJ CW = False - type instance (:==) CJ CX = False - type instance (:==) CJ CY = False - type instance (:==) CJ CZ = False - type instance (:==) CK CA = False - type instance (:==) CK CB = False - type instance (:==) CK CC = False - type instance (:==) CK CD = False - type instance (:==) CK CE = False - type instance (:==) CK CF = False - type instance (:==) CK CG = False - type instance (:==) CK CH = False - type instance (:==) CK CI = False - type instance (:==) CK CJ = False - type instance (:==) CK CK = True - type instance (:==) CK CL = False - type instance (:==) CK CM = False - type instance (:==) CK CN = False - type instance (:==) CK CO = False - type instance (:==) CK CP = False - type instance (:==) CK CQ = False - type instance (:==) CK CR = False - type instance (:==) CK CS = False - type instance (:==) CK CT = False - type instance (:==) CK CU = False - type instance (:==) CK CV = False - type instance (:==) CK CW = False - type instance (:==) CK CX = False - type instance (:==) CK CY = False - type instance (:==) CK CZ = False - type instance (:==) CL CA = False - type instance (:==) CL CB = False - type instance (:==) CL CC = False - type instance (:==) CL CD = False - type instance (:==) CL CE = False - type instance (:==) CL CF = False - type instance (:==) CL CG = False - type instance (:==) CL CH = False - type instance (:==) CL CI = False - type instance (:==) CL CJ = False - type instance (:==) CL CK = False - type instance (:==) CL CL = True - type instance (:==) CL CM = False - type instance (:==) CL CN = False - type instance (:==) CL CO = False - type instance (:==) CL CP = False - type instance (:==) CL CQ = False - type instance (:==) CL CR = False - type instance (:==) CL CS = False - type instance (:==) CL CT = False - type instance (:==) CL CU = False - type instance (:==) CL CV = False - type instance (:==) CL CW = False - type instance (:==) CL CX = False - type instance (:==) CL CY = False - type instance (:==) CL CZ = False - type instance (:==) CM CA = False - type instance (:==) CM CB = False - type instance (:==) CM CC = False - type instance (:==) CM CD = False - type instance (:==) CM CE = False - type instance (:==) CM CF = False - type instance (:==) CM CG = False - type instance (:==) CM CH = False - type instance (:==) CM CI = False - type instance (:==) CM CJ = False - type instance (:==) CM CK = False - type instance (:==) CM CL = False - type instance (:==) CM CM = True - type instance (:==) CM CN = False - type instance (:==) CM CO = False - type instance (:==) CM CP = False - type instance (:==) CM CQ = False - type instance (:==) CM CR = False - type instance (:==) CM CS = False - type instance (:==) CM CT = False - type instance (:==) CM CU = False - type instance (:==) CM CV = False - type instance (:==) CM CW = False - type instance (:==) CM CX = False - type instance (:==) CM CY = False - type instance (:==) CM CZ = False - type instance (:==) CN CA = False - type instance (:==) CN CB = False - type instance (:==) CN CC = False - type instance (:==) CN CD = False - type instance (:==) CN CE = False - type instance (:==) CN CF = False - type instance (:==) CN CG = False - type instance (:==) CN CH = False - type instance (:==) CN CI = False - type instance (:==) CN CJ = False - type instance (:==) CN CK = False - type instance (:==) CN CL = False - type instance (:==) CN CM = False - type instance (:==) CN CN = True - type instance (:==) CN CO = False - type instance (:==) CN CP = False - type instance (:==) CN CQ = False - type instance (:==) CN CR = False - type instance (:==) CN CS = False - type instance (:==) CN CT = False - type instance (:==) CN CU = False - type instance (:==) CN CV = False - type instance (:==) CN CW = False - type instance (:==) CN CX = False - type instance (:==) CN CY = False - type instance (:==) CN CZ = False - type instance (:==) CO CA = False - type instance (:==) CO CB = False - type instance (:==) CO CC = False - type instance (:==) CO CD = False - type instance (:==) CO CE = False - type instance (:==) CO CF = False - type instance (:==) CO CG = False - type instance (:==) CO CH = False - type instance (:==) CO CI = False - type instance (:==) CO CJ = False - type instance (:==) CO CK = False - type instance (:==) CO CL = False - type instance (:==) CO CM = False - type instance (:==) CO CN = False - type instance (:==) CO CO = True - type instance (:==) CO CP = False - type instance (:==) CO CQ = False - type instance (:==) CO CR = False - type instance (:==) CO CS = False - type instance (:==) CO CT = False - type instance (:==) CO CU = False - type instance (:==) CO CV = False - type instance (:==) CO CW = False - type instance (:==) CO CX = False - type instance (:==) CO CY = False - type instance (:==) CO CZ = False - type instance (:==) CP CA = False - type instance (:==) CP CB = False - type instance (:==) CP CC = False - type instance (:==) CP CD = False - type instance (:==) CP CE = False - type instance (:==) CP CF = False - type instance (:==) CP CG = False - type instance (:==) CP CH = False - type instance (:==) CP CI = False - type instance (:==) CP CJ = False - type instance (:==) CP CK = False - type instance (:==) CP CL = False - type instance (:==) CP CM = False - type instance (:==) CP CN = False - type instance (:==) CP CO = False - type instance (:==) CP CP = True - type instance (:==) CP CQ = False - type instance (:==) CP CR = False - type instance (:==) CP CS = False - type instance (:==) CP CT = False - type instance (:==) CP CU = False - type instance (:==) CP CV = False - type instance (:==) CP CW = False - type instance (:==) CP CX = False - type instance (:==) CP CY = False - type instance (:==) CP CZ = False - type instance (:==) CQ CA = False - type instance (:==) CQ CB = False - type instance (:==) CQ CC = False - type instance (:==) CQ CD = False - type instance (:==) CQ CE = False - type instance (:==) CQ CF = False - type instance (:==) CQ CG = False - type instance (:==) CQ CH = False - type instance (:==) CQ CI = False - type instance (:==) CQ CJ = False - type instance (:==) CQ CK = False - type instance (:==) CQ CL = False - type instance (:==) CQ CM = False - type instance (:==) CQ CN = False - type instance (:==) CQ CO = False - type instance (:==) CQ CP = False - type instance (:==) CQ CQ = True - type instance (:==) CQ CR = False - type instance (:==) CQ CS = False - type instance (:==) CQ CT = False - type instance (:==) CQ CU = False - type instance (:==) CQ CV = False - type instance (:==) CQ CW = False - type instance (:==) CQ CX = False - type instance (:==) CQ CY = False - type instance (:==) CQ CZ = False - type instance (:==) CR CA = False - type instance (:==) CR CB = False - type instance (:==) CR CC = False - type instance (:==) CR CD = False - type instance (:==) CR CE = False - type instance (:==) CR CF = False - type instance (:==) CR CG = False - type instance (:==) CR CH = False - type instance (:==) CR CI = False - type instance (:==) CR CJ = False - type instance (:==) CR CK = False - type instance (:==) CR CL = False - type instance (:==) CR CM = False - type instance (:==) CR CN = False - type instance (:==) CR CO = False - type instance (:==) CR CP = False - type instance (:==) CR CQ = False - type instance (:==) CR CR = True - type instance (:==) CR CS = False - type instance (:==) CR CT = False - type instance (:==) CR CU = False - type instance (:==) CR CV = False - type instance (:==) CR CW = False - type instance (:==) CR CX = False - type instance (:==) CR CY = False - type instance (:==) CR CZ = False - type instance (:==) CS CA = False - type instance (:==) CS CB = False - type instance (:==) CS CC = False - type instance (:==) CS CD = False - type instance (:==) CS CE = False - type instance (:==) CS CF = False - type instance (:==) CS CG = False - type instance (:==) CS CH = False - type instance (:==) CS CI = False - type instance (:==) CS CJ = False - type instance (:==) CS CK = False - type instance (:==) CS CL = False - type instance (:==) CS CM = False - type instance (:==) CS CN = False - type instance (:==) CS CO = False - type instance (:==) CS CP = False - type instance (:==) CS CQ = False - type instance (:==) CS CR = False - type instance (:==) CS CS = True - type instance (:==) CS CT = False - type instance (:==) CS CU = False - type instance (:==) CS CV = False - type instance (:==) CS CW = False - type instance (:==) CS CX = False - type instance (:==) CS CY = False - type instance (:==) CS CZ = False - type instance (:==) CT CA = False - type instance (:==) CT CB = False - type instance (:==) CT CC = False - type instance (:==) CT CD = False - type instance (:==) CT CE = False - type instance (:==) CT CF = False - type instance (:==) CT CG = False - type instance (:==) CT CH = False - type instance (:==) CT CI = False - type instance (:==) CT CJ = False - type instance (:==) CT CK = False - type instance (:==) CT CL = False - type instance (:==) CT CM = False - type instance (:==) CT CN = False - type instance (:==) CT CO = False - type instance (:==) CT CP = False - type instance (:==) CT CQ = False - type instance (:==) CT CR = False - type instance (:==) CT CS = False - type instance (:==) CT CT = True - type instance (:==) CT CU = False - type instance (:==) CT CV = False - type instance (:==) CT CW = False - type instance (:==) CT CX = False - type instance (:==) CT CY = False - type instance (:==) CT CZ = False - type instance (:==) CU CA = False - type instance (:==) CU CB = False - type instance (:==) CU CC = False - type instance (:==) CU CD = False - type instance (:==) CU CE = False - type instance (:==) CU CF = False - type instance (:==) CU CG = False - type instance (:==) CU CH = False - type instance (:==) CU CI = False - type instance (:==) CU CJ = False - type instance (:==) CU CK = False - type instance (:==) CU CL = False - type instance (:==) CU CM = False - type instance (:==) CU CN = False - type instance (:==) CU CO = False - type instance (:==) CU CP = False - type instance (:==) CU CQ = False - type instance (:==) CU CR = False - type instance (:==) CU CS = False - type instance (:==) CU CT = False - type instance (:==) CU CU = True - type instance (:==) CU CV = False - type instance (:==) CU CW = False - type instance (:==) CU CX = False - type instance (:==) CU CY = False - type instance (:==) CU CZ = False - type instance (:==) CV CA = False - type instance (:==) CV CB = False - type instance (:==) CV CC = False - type instance (:==) CV CD = False - type instance (:==) CV CE = False - type instance (:==) CV CF = False - type instance (:==) CV CG = False - type instance (:==) CV CH = False - type instance (:==) CV CI = False - type instance (:==) CV CJ = False - type instance (:==) CV CK = False - type instance (:==) CV CL = False - type instance (:==) CV CM = False - type instance (:==) CV CN = False - type instance (:==) CV CO = False - type instance (:==) CV CP = False - type instance (:==) CV CQ = False - type instance (:==) CV CR = False - type instance (:==) CV CS = False - type instance (:==) CV CT = False - type instance (:==) CV CU = False - type instance (:==) CV CV = True - type instance (:==) CV CW = False - type instance (:==) CV CX = False - type instance (:==) CV CY = False - type instance (:==) CV CZ = False - type instance (:==) CW CA = False - type instance (:==) CW CB = False - type instance (:==) CW CC = False - type instance (:==) CW CD = False - type instance (:==) CW CE = False - type instance (:==) CW CF = False - type instance (:==) CW CG = False - type instance (:==) CW CH = False - type instance (:==) CW CI = False - type instance (:==) CW CJ = False - type instance (:==) CW CK = False - type instance (:==) CW CL = False - type instance (:==) CW CM = False - type instance (:==) CW CN = False - type instance (:==) CW CO = False - type instance (:==) CW CP = False - type instance (:==) CW CQ = False - type instance (:==) CW CR = False - type instance (:==) CW CS = False - type instance (:==) CW CT = False - type instance (:==) CW CU = False - type instance (:==) CW CV = False - type instance (:==) CW CW = True - type instance (:==) CW CX = False - type instance (:==) CW CY = False - type instance (:==) CW CZ = False - type instance (:==) CX CA = False - type instance (:==) CX CB = False - type instance (:==) CX CC = False - type instance (:==) CX CD = False - type instance (:==) CX CE = False - type instance (:==) CX CF = False - type instance (:==) CX CG = False - type instance (:==) CX CH = False - type instance (:==) CX CI = False - type instance (:==) CX CJ = False - type instance (:==) CX CK = False - type instance (:==) CX CL = False - type instance (:==) CX CM = False - type instance (:==) CX CN = False - type instance (:==) CX CO = False - type instance (:==) CX CP = False - type instance (:==) CX CQ = False - type instance (:==) CX CR = False - type instance (:==) CX CS = False - type instance (:==) CX CT = False - type instance (:==) CX CU = False - type instance (:==) CX CV = False - type instance (:==) CX CW = False - type instance (:==) CX CX = True - type instance (:==) CX CY = False - type instance (:==) CX CZ = False - type instance (:==) CY CA = False - type instance (:==) CY CB = False - type instance (:==) CY CC = False - type instance (:==) CY CD = False - type instance (:==) CY CE = False - type instance (:==) CY CF = False - type instance (:==) CY CG = False - type instance (:==) CY CH = False - type instance (:==) CY CI = False - type instance (:==) CY CJ = False - type instance (:==) CY CK = False - type instance (:==) CY CL = False - type instance (:==) CY CM = False - type instance (:==) CY CN = False - type instance (:==) CY CO = False - type instance (:==) CY CP = False - type instance (:==) CY CQ = False - type instance (:==) CY CR = False - type instance (:==) CY CS = False - type instance (:==) CY CT = False - type instance (:==) CY CU = False - type instance (:==) CY CV = False - type instance (:==) CY CW = False - type instance (:==) CY CX = False - type instance (:==) CY CY = True - type instance (:==) CY CZ = False - type instance (:==) CZ CA = False - type instance (:==) CZ CB = False - type instance (:==) CZ CC = False - type instance (:==) CZ CD = False - type instance (:==) CZ CE = False - type instance (:==) CZ CF = False - type instance (:==) CZ CG = False - type instance (:==) CZ CH = False - type instance (:==) CZ CI = False - type instance (:==) CZ CJ = False - type instance (:==) CZ CK = False - type instance (:==) CZ CL = False - type instance (:==) CZ CM = False - type instance (:==) CZ CN = False - type instance (:==) CZ CO = False - type instance (:==) CZ CP = False - type instance (:==) CZ CQ = False - type instance (:==) CZ CR = False - type instance (:==) CZ CS = False - type instance (:==) CZ CT = False - type instance (:==) CZ CU = False - type instance (:==) CZ CV = False - type instance (:==) CZ CW = False - type instance (:==) CZ CX = False - type instance (:==) CZ CY = False - type instance (:==) CZ CZ = True - type instance Append (Sch s1) (Sch s2) = Sch (:++ s1 s2) - type instance AttrNotIn z (Sch GHC.Types.[]) = True - type instance AttrNotIn (Attr name u) (Sch (GHC.Types.: (Attr name' z) t)) = - :&& (:/= name name') (AttrNotIn (Attr name u) (Sch t)) - type instance Disjoint (Sch GHC.Types.[]) z = True - type instance Disjoint (Sch (GHC.Types.: h t)) s = - :&& (AttrNotIn h s) (Disjoint (Sch t) s) - type instance Occurs z (Sch GHC.Types.[]) = False - type instance Occurs name (Sch (GHC.Types.: (Attr name' z) attrs)) = - :|| (:== name name') (Occurs name (Sch attrs)) - type instance Lookup z (Sch GHC.Types.[]) = Any - type instance Lookup name (Sch (GHC.Types.: (Attr name' u) attrs)) = - If (:== name name') u (Lookup name (Sch attrs)) - type family Append (a :: Schema) (a :: Schema) :: Schema - type family AttrNotIn (a :: Attribute) (a :: Schema) :: Bool - type family Disjoint (a :: Schema) (a :: Schema) :: Bool - type family Occurs (a :: [AChar]) (a :: Schema) :: Bool - type family Lookup (a :: [AChar]) (a :: Schema) :: U - data instance Sing (z :: U) - = z ~ BOOL => SBOOL | - z ~ STRING => SSTRING | - z ~ NAT => SNAT | - forall (n :: U) (n :: Nat). z ~ VEC n n => SVEC (Sing n) (Sing n) - type SU (z :: U) = Sing z - instance SingKind (KProxy :: KProxy U) where - type instance DemoteRep (KProxy :: KProxy U) = U - fromSing SBOOL = BOOL - fromSing SSTRING = STRING - fromSing SNAT = NAT - fromSing (SVEC b b) = VEC (fromSing b) (fromSing b) - toSing BOOL = SomeSing SBOOL - toSing STRING = SomeSing SSTRING - toSing NAT = SomeSing SNAT - toSing (VEC b b) - = case - (toSing b :: SomeSing (KProxy :: KProxy U), - toSing b :: SomeSing (KProxy :: KProxy Nat)) - of { - (SomeSing c, SomeSing c) -> SomeSing (SVEC c c) } - instance SEq (KProxy :: KProxy U) where - %:== SBOOL SBOOL = STrue - %:== SBOOL SSTRING = SFalse - %:== SBOOL SNAT = SFalse - %:== SBOOL (SVEC _ _) = SFalse - %:== SSTRING SBOOL = SFalse - %:== SSTRING SSTRING = STrue - %:== SSTRING SNAT = SFalse - %:== SSTRING (SVEC _ _) = SFalse - %:== SNAT SBOOL = SFalse - %:== SNAT SSTRING = SFalse - %:== SNAT SNAT = STrue - %:== SNAT (SVEC _ _) = SFalse - %:== (SVEC _ _) SBOOL = SFalse - %:== (SVEC _ _) SSTRING = SFalse - %:== (SVEC _ _) SNAT = SFalse - %:== (SVEC a a) (SVEC b b) = (%:&&) ((%:==) a b) ((%:==) a b) - instance SDecide (KProxy :: KProxy U) where - %~ SBOOL SBOOL = Proved Refl - %~ SBOOL SSTRING - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SBOOL SNAT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SBOOL (SVEC _ _) - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SSTRING SBOOL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SSTRING SSTRING = Proved Refl - %~ SSTRING SNAT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SSTRING (SVEC _ _) - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SNAT SBOOL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SNAT SSTRING - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SNAT SNAT = Proved Refl - %~ SNAT (SVEC _ _) - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ (SVEC _ _) SBOOL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ (SVEC _ _) SSTRING - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ (SVEC _ _) SNAT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ (SVEC a a) (SVEC b b) - = case ((%~) a b, (%~) a b) of { - (Proved Refl, Proved Refl) -> Proved Refl - (Disproved contra, _) -> Disproved (\ Refl -> contra Refl) - (_, Disproved contra) -> Disproved (\ Refl -> contra Refl) } - instance SingI BOOL where - sing = SBOOL - instance SingI STRING where - sing = SSTRING - instance SingI NAT where - sing = SNAT - instance (SingI n, SingI n) => - SingI (VEC (n :: U) (n :: Nat)) where - sing = SVEC sing sing - data instance Sing (z :: AChar) - = z ~ CA => SCA | - z ~ CB => SCB | - z ~ CC => SCC | - z ~ CD => SCD | - z ~ CE => SCE | - z ~ CF => SCF | - z ~ CG => SCG | - z ~ CH => SCH | - z ~ CI => SCI | - z ~ CJ => SCJ | - z ~ CK => SCK | - z ~ CL => SCL | - z ~ CM => SCM | - z ~ CN => SCN | - z ~ CO => SCO | - z ~ CP => SCP | - z ~ CQ => SCQ | - z ~ CR => SCR | - z ~ CS => SCS | - z ~ CT => SCT | - z ~ CU => SCU | - z ~ CV => SCV | - z ~ CW => SCW | - z ~ CX => SCX | - z ~ CY => SCY | - z ~ CZ => SCZ - type SAChar (z :: AChar) = Sing z - instance SingKind (KProxy :: KProxy AChar) where - type instance DemoteRep (KProxy :: KProxy AChar) = AChar - fromSing SCA = CA - fromSing SCB = CB - fromSing SCC = CC - fromSing SCD = CD - fromSing SCE = CE - fromSing SCF = CF - fromSing SCG = CG - fromSing SCH = CH - fromSing SCI = CI - fromSing SCJ = CJ - fromSing SCK = CK - fromSing SCL = CL - fromSing SCM = CM - fromSing SCN = CN - fromSing SCO = CO - fromSing SCP = CP - fromSing SCQ = CQ - fromSing SCR = CR - fromSing SCS = CS - fromSing SCT = CT - fromSing SCU = CU - fromSing SCV = CV - fromSing SCW = CW - fromSing SCX = CX - fromSing SCY = CY - fromSing SCZ = CZ - toSing CA = SomeSing SCA - toSing CB = SomeSing SCB - toSing CC = SomeSing SCC - toSing CD = SomeSing SCD - toSing CE = SomeSing SCE - toSing CF = SomeSing SCF - toSing CG = SomeSing SCG - toSing CH = SomeSing SCH - toSing CI = SomeSing SCI - toSing CJ = SomeSing SCJ - toSing CK = SomeSing SCK - toSing CL = SomeSing SCL - toSing CM = SomeSing SCM - toSing CN = SomeSing SCN - toSing CO = SomeSing SCO - toSing CP = SomeSing SCP - toSing CQ = SomeSing SCQ - toSing CR = SomeSing SCR - toSing CS = SomeSing SCS - toSing CT = SomeSing SCT - toSing CU = SomeSing SCU - toSing CV = SomeSing SCV - toSing CW = SomeSing SCW - toSing CX = SomeSing SCX - toSing CY = SomeSing SCY - toSing CZ = SomeSing SCZ - instance SEq (KProxy :: KProxy AChar) where - %:== SCA SCA = STrue - %:== SCA SCB = SFalse - %:== SCA SCC = SFalse - %:== SCA SCD = SFalse - %:== SCA SCE = SFalse - %:== SCA SCF = SFalse - %:== SCA SCG = SFalse - %:== SCA SCH = SFalse - %:== SCA SCI = SFalse - %:== SCA SCJ = SFalse - %:== SCA SCK = SFalse - %:== SCA SCL = SFalse - %:== SCA SCM = SFalse - %:== SCA SCN = SFalse - %:== SCA SCO = SFalse - %:== SCA SCP = SFalse - %:== SCA SCQ = SFalse - %:== SCA SCR = SFalse - %:== SCA SCS = SFalse - %:== SCA SCT = SFalse - %:== SCA SCU = SFalse - %:== SCA SCV = SFalse - %:== SCA SCW = SFalse - %:== SCA SCX = SFalse - %:== SCA SCY = SFalse - %:== SCA SCZ = SFalse - %:== SCB SCA = SFalse - %:== SCB SCB = STrue - %:== SCB SCC = SFalse - %:== SCB SCD = SFalse - %:== SCB SCE = SFalse - %:== SCB SCF = SFalse - %:== SCB SCG = SFalse - %:== SCB SCH = SFalse - %:== SCB SCI = SFalse - %:== SCB SCJ = SFalse - %:== SCB SCK = SFalse - %:== SCB SCL = SFalse - %:== SCB SCM = SFalse - %:== SCB SCN = SFalse - %:== SCB SCO = SFalse - %:== SCB SCP = SFalse - %:== SCB SCQ = SFalse - %:== SCB SCR = SFalse - %:== SCB SCS = SFalse - %:== SCB SCT = SFalse - %:== SCB SCU = SFalse - %:== SCB SCV = SFalse - %:== SCB SCW = SFalse - %:== SCB SCX = SFalse - %:== SCB SCY = SFalse - %:== SCB SCZ = SFalse - %:== SCC SCA = SFalse - %:== SCC SCB = SFalse - %:== SCC SCC = STrue - %:== SCC SCD = SFalse - %:== SCC SCE = SFalse - %:== SCC SCF = SFalse - %:== SCC SCG = SFalse - %:== SCC SCH = SFalse - %:== SCC SCI = SFalse - %:== SCC SCJ = SFalse - %:== SCC SCK = SFalse - %:== SCC SCL = SFalse - %:== SCC SCM = SFalse - %:== SCC SCN = SFalse - %:== SCC SCO = SFalse - %:== SCC SCP = SFalse - %:== SCC SCQ = SFalse - %:== SCC SCR = SFalse - %:== SCC SCS = SFalse - %:== SCC SCT = SFalse - %:== SCC SCU = SFalse - %:== SCC SCV = SFalse - %:== SCC SCW = SFalse - %:== SCC SCX = SFalse - %:== SCC SCY = SFalse - %:== SCC SCZ = SFalse - %:== SCD SCA = SFalse - %:== SCD SCB = SFalse - %:== SCD SCC = SFalse - %:== SCD SCD = STrue - %:== SCD SCE = SFalse - %:== SCD SCF = SFalse - %:== SCD SCG = SFalse - %:== SCD SCH = SFalse - %:== SCD SCI = SFalse - %:== SCD SCJ = SFalse - %:== SCD SCK = SFalse - %:== SCD SCL = SFalse - %:== SCD SCM = SFalse - %:== SCD SCN = SFalse - %:== SCD SCO = SFalse - %:== SCD SCP = SFalse - %:== SCD SCQ = SFalse - %:== SCD SCR = SFalse - %:== SCD SCS = SFalse - %:== SCD SCT = SFalse - %:== SCD SCU = SFalse - %:== SCD SCV = SFalse - %:== SCD SCW = SFalse - %:== SCD SCX = SFalse - %:== SCD SCY = SFalse - %:== SCD SCZ = SFalse - %:== SCE SCA = SFalse - %:== SCE SCB = SFalse - %:== SCE SCC = SFalse - %:== SCE SCD = SFalse - %:== SCE SCE = STrue - %:== SCE SCF = SFalse - %:== SCE SCG = SFalse - %:== SCE SCH = SFalse - %:== SCE SCI = SFalse - %:== SCE SCJ = SFalse - %:== SCE SCK = SFalse - %:== SCE SCL = SFalse - %:== SCE SCM = SFalse - %:== SCE SCN = SFalse - %:== SCE SCO = SFalse - %:== SCE SCP = SFalse - %:== SCE SCQ = SFalse - %:== SCE SCR = SFalse - %:== SCE SCS = SFalse - %:== SCE SCT = SFalse - %:== SCE SCU = SFalse - %:== SCE SCV = SFalse - %:== SCE SCW = SFalse - %:== SCE SCX = SFalse - %:== SCE SCY = SFalse - %:== SCE SCZ = SFalse - %:== SCF SCA = SFalse - %:== SCF SCB = SFalse - %:== SCF SCC = SFalse - %:== SCF SCD = SFalse - %:== SCF SCE = SFalse - %:== SCF SCF = STrue - %:== SCF SCG = SFalse - %:== SCF SCH = SFalse - %:== SCF SCI = SFalse - %:== SCF SCJ = SFalse - %:== SCF SCK = SFalse - %:== SCF SCL = SFalse - %:== SCF SCM = SFalse - %:== SCF SCN = SFalse - %:== SCF SCO = SFalse - %:== SCF SCP = SFalse - %:== SCF SCQ = SFalse - %:== SCF SCR = SFalse - %:== SCF SCS = SFalse - %:== SCF SCT = SFalse - %:== SCF SCU = SFalse - %:== SCF SCV = SFalse - %:== SCF SCW = SFalse - %:== SCF SCX = SFalse - %:== SCF SCY = SFalse - %:== SCF SCZ = SFalse - %:== SCG SCA = SFalse - %:== SCG SCB = SFalse - %:== SCG SCC = SFalse - %:== SCG SCD = SFalse - %:== SCG SCE = SFalse - %:== SCG SCF = SFalse - %:== SCG SCG = STrue - %:== SCG SCH = SFalse - %:== SCG SCI = SFalse - %:== SCG SCJ = SFalse - %:== SCG SCK = SFalse - %:== SCG SCL = SFalse - %:== SCG SCM = SFalse - %:== SCG SCN = SFalse - %:== SCG SCO = SFalse - %:== SCG SCP = SFalse - %:== SCG SCQ = SFalse - %:== SCG SCR = SFalse - %:== SCG SCS = SFalse - %:== SCG SCT = SFalse - %:== SCG SCU = SFalse - %:== SCG SCV = SFalse - %:== SCG SCW = SFalse - %:== SCG SCX = SFalse - %:== SCG SCY = SFalse - %:== SCG SCZ = SFalse - %:== SCH SCA = SFalse - %:== SCH SCB = SFalse - %:== SCH SCC = SFalse - %:== SCH SCD = SFalse - %:== SCH SCE = SFalse - %:== SCH SCF = SFalse - %:== SCH SCG = SFalse - %:== SCH SCH = STrue - %:== SCH SCI = SFalse - %:== SCH SCJ = SFalse - %:== SCH SCK = SFalse - %:== SCH SCL = SFalse - %:== SCH SCM = SFalse - %:== SCH SCN = SFalse - %:== SCH SCO = SFalse - %:== SCH SCP = SFalse - %:== SCH SCQ = SFalse - %:== SCH SCR = SFalse - %:== SCH SCS = SFalse - %:== SCH SCT = SFalse - %:== SCH SCU = SFalse - %:== SCH SCV = SFalse - %:== SCH SCW = SFalse - %:== SCH SCX = SFalse - %:== SCH SCY = SFalse - %:== SCH SCZ = SFalse - %:== SCI SCA = SFalse - %:== SCI SCB = SFalse - %:== SCI SCC = SFalse - %:== SCI SCD = SFalse - %:== SCI SCE = SFalse - %:== SCI SCF = SFalse - %:== SCI SCG = SFalse - %:== SCI SCH = SFalse - %:== SCI SCI = STrue - %:== SCI SCJ = SFalse - %:== SCI SCK = SFalse - %:== SCI SCL = SFalse - %:== SCI SCM = SFalse - %:== SCI SCN = SFalse - %:== SCI SCO = SFalse - %:== SCI SCP = SFalse - %:== SCI SCQ = SFalse - %:== SCI SCR = SFalse - %:== SCI SCS = SFalse - %:== SCI SCT = SFalse - %:== SCI SCU = SFalse - %:== SCI SCV = SFalse - %:== SCI SCW = SFalse - %:== SCI SCX = SFalse - %:== SCI SCY = SFalse - %:== SCI SCZ = SFalse - %:== SCJ SCA = SFalse - %:== SCJ SCB = SFalse - %:== SCJ SCC = SFalse - %:== SCJ SCD = SFalse - %:== SCJ SCE = SFalse - %:== SCJ SCF = SFalse - %:== SCJ SCG = SFalse - %:== SCJ SCH = SFalse - %:== SCJ SCI = SFalse - %:== SCJ SCJ = STrue - %:== SCJ SCK = SFalse - %:== SCJ SCL = SFalse - %:== SCJ SCM = SFalse - %:== SCJ SCN = SFalse - %:== SCJ SCO = SFalse - %:== SCJ SCP = SFalse - %:== SCJ SCQ = SFalse - %:== SCJ SCR = SFalse - %:== SCJ SCS = SFalse - %:== SCJ SCT = SFalse - %:== SCJ SCU = SFalse - %:== SCJ SCV = SFalse - %:== SCJ SCW = SFalse - %:== SCJ SCX = SFalse - %:== SCJ SCY = SFalse - %:== SCJ SCZ = SFalse - %:== SCK SCA = SFalse - %:== SCK SCB = SFalse - %:== SCK SCC = SFalse - %:== SCK SCD = SFalse - %:== SCK SCE = SFalse - %:== SCK SCF = SFalse - %:== SCK SCG = SFalse - %:== SCK SCH = SFalse - %:== SCK SCI = SFalse - %:== SCK SCJ = SFalse - %:== SCK SCK = STrue - %:== SCK SCL = SFalse - %:== SCK SCM = SFalse - %:== SCK SCN = SFalse - %:== SCK SCO = SFalse - %:== SCK SCP = SFalse - %:== SCK SCQ = SFalse - %:== SCK SCR = SFalse - %:== SCK SCS = SFalse - %:== SCK SCT = SFalse - %:== SCK SCU = SFalse - %:== SCK SCV = SFalse - %:== SCK SCW = SFalse - %:== SCK SCX = SFalse - %:== SCK SCY = SFalse - %:== SCK SCZ = SFalse - %:== SCL SCA = SFalse - %:== SCL SCB = SFalse - %:== SCL SCC = SFalse - %:== SCL SCD = SFalse - %:== SCL SCE = SFalse - %:== SCL SCF = SFalse - %:== SCL SCG = SFalse - %:== SCL SCH = SFalse - %:== SCL SCI = SFalse - %:== SCL SCJ = SFalse - %:== SCL SCK = SFalse - %:== SCL SCL = STrue - %:== SCL SCM = SFalse - %:== SCL SCN = SFalse - %:== SCL SCO = SFalse - %:== SCL SCP = SFalse - %:== SCL SCQ = SFalse - %:== SCL SCR = SFalse - %:== SCL SCS = SFalse - %:== SCL SCT = SFalse - %:== SCL SCU = SFalse - %:== SCL SCV = SFalse - %:== SCL SCW = SFalse - %:== SCL SCX = SFalse - %:== SCL SCY = SFalse - %:== SCL SCZ = SFalse - %:== SCM SCA = SFalse - %:== SCM SCB = SFalse - %:== SCM SCC = SFalse - %:== SCM SCD = SFalse - %:== SCM SCE = SFalse - %:== SCM SCF = SFalse - %:== SCM SCG = SFalse - %:== SCM SCH = SFalse - %:== SCM SCI = SFalse - %:== SCM SCJ = SFalse - %:== SCM SCK = SFalse - %:== SCM SCL = SFalse - %:== SCM SCM = STrue - %:== SCM SCN = SFalse - %:== SCM SCO = SFalse - %:== SCM SCP = SFalse - %:== SCM SCQ = SFalse - %:== SCM SCR = SFalse - %:== SCM SCS = SFalse - %:== SCM SCT = SFalse - %:== SCM SCU = SFalse - %:== SCM SCV = SFalse - %:== SCM SCW = SFalse - %:== SCM SCX = SFalse - %:== SCM SCY = SFalse - %:== SCM SCZ = SFalse - %:== SCN SCA = SFalse - %:== SCN SCB = SFalse - %:== SCN SCC = SFalse - %:== SCN SCD = SFalse - %:== SCN SCE = SFalse - %:== SCN SCF = SFalse - %:== SCN SCG = SFalse - %:== SCN SCH = SFalse - %:== SCN SCI = SFalse - %:== SCN SCJ = SFalse - %:== SCN SCK = SFalse - %:== SCN SCL = SFalse - %:== SCN SCM = SFalse - %:== SCN SCN = STrue - %:== SCN SCO = SFalse - %:== SCN SCP = SFalse - %:== SCN SCQ = SFalse - %:== SCN SCR = SFalse - %:== SCN SCS = SFalse - %:== SCN SCT = SFalse - %:== SCN SCU = SFalse - %:== SCN SCV = SFalse - %:== SCN SCW = SFalse - %:== SCN SCX = SFalse - %:== SCN SCY = SFalse - %:== SCN SCZ = SFalse - %:== SCO SCA = SFalse - %:== SCO SCB = SFalse - %:== SCO SCC = SFalse - %:== SCO SCD = SFalse - %:== SCO SCE = SFalse - %:== SCO SCF = SFalse - %:== SCO SCG = SFalse - %:== SCO SCH = SFalse - %:== SCO SCI = SFalse - %:== SCO SCJ = SFalse - %:== SCO SCK = SFalse - %:== SCO SCL = SFalse - %:== SCO SCM = SFalse - %:== SCO SCN = SFalse - %:== SCO SCO = STrue - %:== SCO SCP = SFalse - %:== SCO SCQ = SFalse - %:== SCO SCR = SFalse - %:== SCO SCS = SFalse - %:== SCO SCT = SFalse - %:== SCO SCU = SFalse - %:== SCO SCV = SFalse - %:== SCO SCW = SFalse - %:== SCO SCX = SFalse - %:== SCO SCY = SFalse - %:== SCO SCZ = SFalse - %:== SCP SCA = SFalse - %:== SCP SCB = SFalse - %:== SCP SCC = SFalse - %:== SCP SCD = SFalse - %:== SCP SCE = SFalse - %:== SCP SCF = SFalse - %:== SCP SCG = SFalse - %:== SCP SCH = SFalse - %:== SCP SCI = SFalse - %:== SCP SCJ = SFalse - %:== SCP SCK = SFalse - %:== SCP SCL = SFalse - %:== SCP SCM = SFalse - %:== SCP SCN = SFalse - %:== SCP SCO = SFalse - %:== SCP SCP = STrue - %:== SCP SCQ = SFalse - %:== SCP SCR = SFalse - %:== SCP SCS = SFalse - %:== SCP SCT = SFalse - %:== SCP SCU = SFalse - %:== SCP SCV = SFalse - %:== SCP SCW = SFalse - %:== SCP SCX = SFalse - %:== SCP SCY = SFalse - %:== SCP SCZ = SFalse - %:== SCQ SCA = SFalse - %:== SCQ SCB = SFalse - %:== SCQ SCC = SFalse - %:== SCQ SCD = SFalse - %:== SCQ SCE = SFalse - %:== SCQ SCF = SFalse - %:== SCQ SCG = SFalse - %:== SCQ SCH = SFalse - %:== SCQ SCI = SFalse - %:== SCQ SCJ = SFalse - %:== SCQ SCK = SFalse - %:== SCQ SCL = SFalse - %:== SCQ SCM = SFalse - %:== SCQ SCN = SFalse - %:== SCQ SCO = SFalse - %:== SCQ SCP = SFalse - %:== SCQ SCQ = STrue - %:== SCQ SCR = SFalse - %:== SCQ SCS = SFalse - %:== SCQ SCT = SFalse - %:== SCQ SCU = SFalse - %:== SCQ SCV = SFalse - %:== SCQ SCW = SFalse - %:== SCQ SCX = SFalse - %:== SCQ SCY = SFalse - %:== SCQ SCZ = SFalse - %:== SCR SCA = SFalse - %:== SCR SCB = SFalse - %:== SCR SCC = SFalse - %:== SCR SCD = SFalse - %:== SCR SCE = SFalse - %:== SCR SCF = SFalse - %:== SCR SCG = SFalse - %:== SCR SCH = SFalse - %:== SCR SCI = SFalse - %:== SCR SCJ = SFalse - %:== SCR SCK = SFalse - %:== SCR SCL = SFalse - %:== SCR SCM = SFalse - %:== SCR SCN = SFalse - %:== SCR SCO = SFalse - %:== SCR SCP = SFalse - %:== SCR SCQ = SFalse - %:== SCR SCR = STrue - %:== SCR SCS = SFalse - %:== SCR SCT = SFalse - %:== SCR SCU = SFalse - %:== SCR SCV = SFalse - %:== SCR SCW = SFalse - %:== SCR SCX = SFalse - %:== SCR SCY = SFalse - %:== SCR SCZ = SFalse - %:== SCS SCA = SFalse - %:== SCS SCB = SFalse - %:== SCS SCC = SFalse - %:== SCS SCD = SFalse - %:== SCS SCE = SFalse - %:== SCS SCF = SFalse - %:== SCS SCG = SFalse - %:== SCS SCH = SFalse - %:== SCS SCI = SFalse - %:== SCS SCJ = SFalse - %:== SCS SCK = SFalse - %:== SCS SCL = SFalse - %:== SCS SCM = SFalse - %:== SCS SCN = SFalse - %:== SCS SCO = SFalse - %:== SCS SCP = SFalse - %:== SCS SCQ = SFalse - %:== SCS SCR = SFalse - %:== SCS SCS = STrue - %:== SCS SCT = SFalse - %:== SCS SCU = SFalse - %:== SCS SCV = SFalse - %:== SCS SCW = SFalse - %:== SCS SCX = SFalse - %:== SCS SCY = SFalse - %:== SCS SCZ = SFalse - %:== SCT SCA = SFalse - %:== SCT SCB = SFalse - %:== SCT SCC = SFalse - %:== SCT SCD = SFalse - %:== SCT SCE = SFalse - %:== SCT SCF = SFalse - %:== SCT SCG = SFalse - %:== SCT SCH = SFalse - %:== SCT SCI = SFalse - %:== SCT SCJ = SFalse - %:== SCT SCK = SFalse - %:== SCT SCL = SFalse - %:== SCT SCM = SFalse - %:== SCT SCN = SFalse - %:== SCT SCO = SFalse - %:== SCT SCP = SFalse - %:== SCT SCQ = SFalse - %:== SCT SCR = SFalse - %:== SCT SCS = SFalse - %:== SCT SCT = STrue - %:== SCT SCU = SFalse - %:== SCT SCV = SFalse - %:== SCT SCW = SFalse - %:== SCT SCX = SFalse - %:== SCT SCY = SFalse - %:== SCT SCZ = SFalse - %:== SCU SCA = SFalse - %:== SCU SCB = SFalse - %:== SCU SCC = SFalse - %:== SCU SCD = SFalse - %:== SCU SCE = SFalse - %:== SCU SCF = SFalse - %:== SCU SCG = SFalse - %:== SCU SCH = SFalse - %:== SCU SCI = SFalse - %:== SCU SCJ = SFalse - %:== SCU SCK = SFalse - %:== SCU SCL = SFalse - %:== SCU SCM = SFalse - %:== SCU SCN = SFalse - %:== SCU SCO = SFalse - %:== SCU SCP = SFalse - %:== SCU SCQ = SFalse - %:== SCU SCR = SFalse - %:== SCU SCS = SFalse - %:== SCU SCT = SFalse - %:== SCU SCU = STrue - %:== SCU SCV = SFalse - %:== SCU SCW = SFalse - %:== SCU SCX = SFalse - %:== SCU SCY = SFalse - %:== SCU SCZ = SFalse - %:== SCV SCA = SFalse - %:== SCV SCB = SFalse - %:== SCV SCC = SFalse - %:== SCV SCD = SFalse - %:== SCV SCE = SFalse - %:== SCV SCF = SFalse - %:== SCV SCG = SFalse - %:== SCV SCH = SFalse - %:== SCV SCI = SFalse - %:== SCV SCJ = SFalse - %:== SCV SCK = SFalse - %:== SCV SCL = SFalse - %:== SCV SCM = SFalse - %:== SCV SCN = SFalse - %:== SCV SCO = SFalse - %:== SCV SCP = SFalse - %:== SCV SCQ = SFalse - %:== SCV SCR = SFalse - %:== SCV SCS = SFalse - %:== SCV SCT = SFalse - %:== SCV SCU = SFalse - %:== SCV SCV = STrue - %:== SCV SCW = SFalse - %:== SCV SCX = SFalse - %:== SCV SCY = SFalse - %:== SCV SCZ = SFalse - %:== SCW SCA = SFalse - %:== SCW SCB = SFalse - %:== SCW SCC = SFalse - %:== SCW SCD = SFalse - %:== SCW SCE = SFalse - %:== SCW SCF = SFalse - %:== SCW SCG = SFalse - %:== SCW SCH = SFalse - %:== SCW SCI = SFalse - %:== SCW SCJ = SFalse - %:== SCW SCK = SFalse - %:== SCW SCL = SFalse - %:== SCW SCM = SFalse - %:== SCW SCN = SFalse - %:== SCW SCO = SFalse - %:== SCW SCP = SFalse - %:== SCW SCQ = SFalse - %:== SCW SCR = SFalse - %:== SCW SCS = SFalse - %:== SCW SCT = SFalse - %:== SCW SCU = SFalse - %:== SCW SCV = SFalse - %:== SCW SCW = STrue - %:== SCW SCX = SFalse - %:== SCW SCY = SFalse - %:== SCW SCZ = SFalse - %:== SCX SCA = SFalse - %:== SCX SCB = SFalse - %:== SCX SCC = SFalse - %:== SCX SCD = SFalse - %:== SCX SCE = SFalse - %:== SCX SCF = SFalse - %:== SCX SCG = SFalse - %:== SCX SCH = SFalse - %:== SCX SCI = SFalse - %:== SCX SCJ = SFalse - %:== SCX SCK = SFalse - %:== SCX SCL = SFalse - %:== SCX SCM = SFalse - %:== SCX SCN = SFalse - %:== SCX SCO = SFalse - %:== SCX SCP = SFalse - %:== SCX SCQ = SFalse - %:== SCX SCR = SFalse - %:== SCX SCS = SFalse - %:== SCX SCT = SFalse - %:== SCX SCU = SFalse - %:== SCX SCV = SFalse - %:== SCX SCW = SFalse - %:== SCX SCX = STrue - %:== SCX SCY = SFalse - %:== SCX SCZ = SFalse - %:== SCY SCA = SFalse - %:== SCY SCB = SFalse - %:== SCY SCC = SFalse - %:== SCY SCD = SFalse - %:== SCY SCE = SFalse - %:== SCY SCF = SFalse - %:== SCY SCG = SFalse - %:== SCY SCH = SFalse - %:== SCY SCI = SFalse - %:== SCY SCJ = SFalse - %:== SCY SCK = SFalse - %:== SCY SCL = SFalse - %:== SCY SCM = SFalse - %:== SCY SCN = SFalse - %:== SCY SCO = SFalse - %:== SCY SCP = SFalse - %:== SCY SCQ = SFalse - %:== SCY SCR = SFalse - %:== SCY SCS = SFalse - %:== SCY SCT = SFalse - %:== SCY SCU = SFalse - %:== SCY SCV = SFalse - %:== SCY SCW = SFalse - %:== SCY SCX = SFalse - %:== SCY SCY = STrue - %:== SCY SCZ = SFalse - %:== SCZ SCA = SFalse - %:== SCZ SCB = SFalse - %:== SCZ SCC = SFalse - %:== SCZ SCD = SFalse - %:== SCZ SCE = SFalse - %:== SCZ SCF = SFalse - %:== SCZ SCG = SFalse - %:== SCZ SCH = SFalse - %:== SCZ SCI = SFalse - %:== SCZ SCJ = SFalse - %:== SCZ SCK = SFalse - %:== SCZ SCL = SFalse - %:== SCZ SCM = SFalse - %:== SCZ SCN = SFalse - %:== SCZ SCO = SFalse - %:== SCZ SCP = SFalse - %:== SCZ SCQ = SFalse - %:== SCZ SCR = SFalse - %:== SCZ SCS = SFalse - %:== SCZ SCT = SFalse - %:== SCZ SCU = SFalse - %:== SCZ SCV = SFalse - %:== SCZ SCW = SFalse - %:== SCZ SCX = SFalse - %:== SCZ SCY = SFalse - %:== SCZ SCZ = STrue - instance SDecide (KProxy :: KProxy AChar) where - %~ SCA SCA = Proved Refl - %~ SCA SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCA SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCA SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCA SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCA SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCA SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCA SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCA SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCA SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCA SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCA SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCA SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCA SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCA SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCA SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCA SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCA SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCA SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCA SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCA SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCA SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCA SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCA SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCA SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCA SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCB SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCB SCB = Proved Refl - %~ SCB SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCB SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCB SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCB SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCB SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCB SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCB SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCB SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCB SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCB SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCB SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCB SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCB SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCB SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCB SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCB SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCB SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCB SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCB SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCB SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCB SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCB SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCB SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCB SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCC SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCC SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCC SCC = Proved Refl - %~ SCC SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCC SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCC SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCC SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCC SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCC SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCC SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCC SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCC SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCC SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCC SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCC SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCC SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCC SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCC SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCC SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCC SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCC SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCC SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCC SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCC SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCC SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCC SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCD SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCD SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCD SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCD SCD = Proved Refl - %~ SCD SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCD SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCD SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCD SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCD SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCD SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCD SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCD SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCD SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCD SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCD SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCD SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCD SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCD SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCD SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCD SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCD SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCD SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCD SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCD SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCD SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCD SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCE SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCE SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCE SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCE SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCE SCE = Proved Refl - %~ SCE SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCE SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCE SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCE SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCE SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCE SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCE SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCE SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCE SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCE SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCE SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCE SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCE SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCE SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCE SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCE SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCE SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCE SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCE SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCE SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCE SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCF SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCF SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCF SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCF SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCF SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCF SCF = Proved Refl - %~ SCF SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCF SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCF SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCF SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCF SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCF SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCF SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCF SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCF SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCF SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCF SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCF SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCF SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCF SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCF SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCF SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCF SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCF SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCF SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCF SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCG SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCG SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCG SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCG SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCG SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCG SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCG SCG = Proved Refl - %~ SCG SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCG SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCG SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCG SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCG SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCG SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCG SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCG SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCG SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCG SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCG SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCG SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCG SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCG SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCG SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCG SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCG SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCG SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCG SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCH SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCH SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCH SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCH SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCH SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCH SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCH SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCH SCH = Proved Refl - %~ SCH SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCH SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCH SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCH SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCH SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCH SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCH SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCH SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCH SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCH SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCH SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCH SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCH SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCH SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCH SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCH SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCH SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCH SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCI SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCI SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCI SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCI SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCI SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCI SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCI SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCI SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCI SCI = Proved Refl - %~ SCI SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCI SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCI SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCI SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCI SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCI SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCI SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCI SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCI SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCI SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCI SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCI SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCI SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCI SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCI SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCI SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCI SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCJ SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCJ SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCJ SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCJ SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCJ SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCJ SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCJ SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCJ SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCJ SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCJ SCJ = Proved Refl - %~ SCJ SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCJ SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCJ SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCJ SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCJ SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCJ SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCJ SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCJ SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCJ SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCJ SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCJ SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCJ SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCJ SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCJ SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCJ SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCJ SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCK SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCK SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCK SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCK SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCK SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCK SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCK SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCK SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCK SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCK SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCK SCK = Proved Refl - %~ SCK SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCK SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCK SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCK SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCK SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCK SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCK SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCK SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCK SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCK SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCK SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCK SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCK SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCK SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCK SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCL SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCL SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCL SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCL SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCL SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCL SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCL SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCL SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCL SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCL SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCL SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCL SCL = Proved Refl - %~ SCL SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCL SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCL SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCL SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCL SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCL SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCL SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCL SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCL SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCL SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCL SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCL SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCL SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCL SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCM SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCM SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCM SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCM SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCM SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCM SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCM SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCM SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCM SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCM SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCM SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCM SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCM SCM = Proved Refl - %~ SCM SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCM SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCM SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCM SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCM SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCM SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCM SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCM SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCM SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCM SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCM SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCM SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCM SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCN SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCN SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCN SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCN SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCN SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCN SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCN SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCN SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCN SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCN SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCN SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCN SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCN SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCN SCN = Proved Refl - %~ SCN SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCN SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCN SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCN SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCN SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCN SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCN SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCN SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCN SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCN SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCN SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCN SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCO SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCO SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCO SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCO SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCO SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCO SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCO SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCO SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCO SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCO SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCO SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCO SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCO SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCO SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCO SCO = Proved Refl - %~ SCO SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCO SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCO SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCO SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCO SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCO SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCO SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCO SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCO SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCO SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCO SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCP SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCP SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCP SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCP SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCP SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCP SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCP SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCP SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCP SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCP SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCP SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCP SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCP SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCP SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCP SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCP SCP = Proved Refl - %~ SCP SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCP SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCP SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCP SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCP SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCP SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCP SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCP SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCP SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCP SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCQ SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCQ SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCQ SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCQ SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCQ SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCQ SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCQ SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCQ SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCQ SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCQ SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCQ SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCQ SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCQ SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCQ SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCQ SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCQ SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCQ SCQ = Proved Refl - %~ SCQ SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCQ SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCQ SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCQ SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCQ SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCQ SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCQ SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCQ SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCQ SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCR SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCR SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCR SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCR SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCR SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCR SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCR SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCR SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCR SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCR SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCR SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCR SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCR SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCR SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCR SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCR SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCR SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCR SCR = Proved Refl - %~ SCR SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCR SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCR SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCR SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCR SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCR SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCR SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCR SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCS SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCS SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCS SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCS SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCS SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCS SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCS SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCS SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCS SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCS SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCS SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCS SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCS SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCS SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCS SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCS SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCS SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCS SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCS SCS = Proved Refl - %~ SCS SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCS SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCS SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCS SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCS SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCS SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCS SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCT SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCT SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCT SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCT SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCT SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCT SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCT SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCT SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCT SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCT SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCT SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCT SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCT SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCT SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCT SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCT SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCT SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCT SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCT SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCT SCT = Proved Refl - %~ SCT SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCT SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCT SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCT SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCT SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCT SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCU SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCU SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCU SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCU SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCU SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCU SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCU SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCU SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCU SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCU SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCU SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCU SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCU SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCU SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCU SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCU SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCU SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCU SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCU SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCU SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCU SCU = Proved Refl - %~ SCU SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCU SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCU SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCU SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCU SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCV SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCV SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCV SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCV SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCV SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCV SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCV SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCV SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCV SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCV SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCV SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCV SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCV SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCV SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCV SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCV SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCV SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCV SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCV SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCV SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCV SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCV SCV = Proved Refl - %~ SCV SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCV SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCV SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCV SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCW SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCW SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCW SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCW SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCW SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCW SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCW SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCW SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCW SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCW SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCW SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCW SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCW SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCW SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCW SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCW SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCW SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCW SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCW SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCW SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCW SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCW SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCW SCW = Proved Refl - %~ SCW SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCW SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCW SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCX SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCX SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCX SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCX SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCX SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCX SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCX SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCX SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCX SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCX SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCX SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCX SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCX SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCX SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCX SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCX SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCX SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCX SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCX SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCX SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCX SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCX SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCX SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCX SCX = Proved Refl - %~ SCX SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCX SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCY SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCY SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCY SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCY SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCY SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCY SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCY SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCY SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCY SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCY SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCY SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCY SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCY SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCY SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCY SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCY SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCY SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCY SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCY SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCY SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCY SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCY SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCY SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCY SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCY SCY = Proved Refl - %~ SCY SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCZ SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCZ SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCZ SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCZ SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCZ SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCZ SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCZ SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCZ SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCZ SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCZ SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCZ SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCZ SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCZ SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCZ SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCZ SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCZ SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCZ SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCZ SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCZ SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCZ SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCZ SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCZ SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCZ SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCZ SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCZ SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SCZ SCZ = Proved Refl - instance SingI CA where - sing = SCA - instance SingI CB where - sing = SCB - instance SingI CC where - sing = SCC - instance SingI CD where - sing = SCD - instance SingI CE where - sing = SCE - instance SingI CF where - sing = SCF - instance SingI CG where - sing = SCG - instance SingI CH where - sing = SCH - instance SingI CI where - sing = SCI - instance SingI CJ where - sing = SCJ - instance SingI CK where - sing = SCK - instance SingI CL where - sing = SCL - instance SingI CM where - sing = SCM - instance SingI CN where - sing = SCN - instance SingI CO where - sing = SCO - instance SingI CP where - sing = SCP - instance SingI CQ where - sing = SCQ - instance SingI CR where - sing = SCR - instance SingI CS where - sing = SCS - instance SingI CT where - sing = SCT - instance SingI CU where - sing = SCU - instance SingI CV where - sing = SCV - instance SingI CW where - sing = SCW - instance SingI CX where - sing = SCX - instance SingI CY where - sing = SCY - instance SingI CZ where - sing = SCZ - data instance Sing (z :: Attribute) - = forall (n :: [AChar]) (n :: U). z ~ Attr n n => - SAttr (Sing n) (Sing n) - type SAttribute (z :: Attribute) = Sing z - instance SingKind (KProxy :: KProxy Attribute) where - type instance DemoteRep (KProxy :: KProxy Attribute) = Attribute - fromSing (SAttr b b) = Attr (fromSing b) (fromSing b) - toSing (Attr b b) - = case - (toSing b :: SomeSing (KProxy :: KProxy [AChar]), - toSing b :: SomeSing (KProxy :: KProxy U)) - of { - (SomeSing c, SomeSing c) -> SomeSing (SAttr c c) } - instance (SingI n, SingI n) => - SingI (Attr (n :: [AChar]) (n :: U)) where - sing = SAttr sing sing - data instance Sing (z :: Schema) - = forall (n :: [Attribute]). z ~ Sch n => SSch (Sing n) - type SSchema (z :: Schema) = Sing z - instance SingKind (KProxy :: KProxy Schema) where - type instance DemoteRep (KProxy :: KProxy Schema) = Schema - fromSing (SSch b) = Sch (fromSing b) - toSing (Sch b) - = case toSing b :: SomeSing (KProxy :: KProxy [Attribute]) of { - SomeSing c -> SomeSing (SSch c) } - instance SingI n => SingI (Sch (n :: [Attribute])) where - sing = SSch sing - sAppend :: - forall (t :: Schema) (t :: Schema). - Sing t -> Sing t -> Sing (Append t t) - sAppend (SSch s1) (SSch s2) = SSch ((%:++) s1 s2) - sAttrNotIn :: - forall (t :: Attribute) (t :: Schema). - Sing t -> Sing t -> Sing (AttrNotIn t t) - sAttrNotIn _ (SSch SNil) = STrue - sAttrNotIn (SAttr name u) (SSch (SCons (SAttr name' _) t)) - = (%:&&) ((%:/=) name name') (sAttrNotIn (SAttr name u) (SSch t)) - sDisjoint :: - forall (t :: Schema) (t :: Schema). - Sing t -> Sing t -> Sing (Disjoint t t) - sDisjoint (SSch SNil) _ = STrue - sDisjoint (SSch (SCons h t)) s - = (%:&&) (sAttrNotIn h s) (sDisjoint (SSch t) s) - sOccurs :: - forall (t :: [AChar]) (t :: Schema). - Sing t -> Sing t -> Sing (Occurs t t) - sOccurs _ (SSch SNil) = SFalse - sOccurs name (SSch (SCons (SAttr name' _) attrs)) - = (%:||) ((%:==) name name') (sOccurs name (SSch attrs)) - sLookup :: - forall (t :: [AChar]) (t :: Schema). - Sing t -> Sing t -> Sing (Lookup t t) - sLookup _ (SSch SNil) = undefined - sLookup name (SSch (SCons (SAttr name' u) attrs)) - = sIf ((%:==) name name') u (sLookup name (SSch attrs)) -GradingClient/Database.hs:0:0: Splicing declarations - return [] ======> GradingClient/Database.hs:0:0: -GradingClient/Database.hs:(0,0)-(0,0): Splicing expression - cases ''Row [| r |] [| changeId (n ++ (getId r)) r |] - ======> - case r of { - EmptyRow _ -> changeId (n ++ (getId r)) r - ConsRow _ _ -> changeId (n ++ (getId r)) r } diff --git a/tests/compile-and-dump/GradingClient/Database.ghc78.template b/tests/compile-and-dump/GradingClient/Database.ghc78.template deleted file mode 100644 --- a/tests/compile-and-dump/GradingClient/Database.ghc78.template +++ /dev/null @@ -1,3812 +0,0 @@ -GradingClient/Database.hs:0:0: Splicing declarations - singletons - [d| data Nat - = Zero | Succ Nat - deriving (Eq, Ord) |] - ======> - GradingClient/Database.hs:(0,0)-(0,0) - data Nat - = Zero | Succ Nat - deriving (Eq, Ord) - type family Equals_0123456789 (a :: Nat) (b :: Nat) :: Bool where - Equals_0123456789 Zero Zero = True - Equals_0123456789 (Succ a) (Succ b) = (==) a b - Equals_0123456789 (a :: Nat) (b :: Nat) = False - type instance (==) (a :: Nat) (b :: Nat) = Equals_0123456789 a b - data instance Sing (z :: Nat) - = z ~ Zero => SZero | - forall (n :: Nat). z ~ Succ n => SSucc (Sing n) - type SNat (z :: Nat) = Sing z - instance SingKind (KProxy :: KProxy Nat) where - type DemoteRep (KProxy :: KProxy Nat) = Nat - fromSing SZero = Zero - fromSing (SSucc b) = Succ (fromSing b) - toSing Zero = SomeSing SZero - toSing (Succ b) - = case toSing b :: SomeSing (KProxy :: KProxy Nat) of { - SomeSing c -> SomeSing (SSucc c) } - instance SEq (KProxy :: KProxy Nat) where - (%:==) SZero SZero = STrue - (%:==) SZero (SSucc _) = SFalse - (%:==) (SSucc _) SZero = SFalse - (%:==) (SSucc a) (SSucc b) = (%:==) a b - instance SDecide (KProxy :: KProxy Nat) where - (%~) SZero SZero = Proved Refl - (%~) SZero (SSucc _) - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SSucc _) SZero - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SSucc a) (SSucc b) - = case (%~) a b of { - Proved Refl -> Proved Refl - Disproved contra -> Disproved (\ Refl -> contra Refl) } - instance SingI Zero where - sing = SZero - instance SingI n => SingI (Succ (n :: Nat)) where - sing = SSucc sing -GradingClient/Database.hs:0:0: Splicing declarations - singletons - [d| append :: Schema -> Schema -> Schema - append (Sch s1) (Sch s2) = Sch (s1 ++ s2) - attrNotIn :: Attribute -> Schema -> Bool - attrNotIn _ (Sch []) = True - attrNotIn (Attr name u) (Sch ((Attr name' _) : t)) - = (name /= name') && (attrNotIn (Attr name u) (Sch t)) - disjoint :: Schema -> Schema -> Bool - disjoint (Sch []) _ = True - disjoint (Sch (h : t)) s = (attrNotIn h s) && (disjoint (Sch t) s) - occurs :: [AChar] -> Schema -> Bool - occurs _ (Sch []) = False - occurs name (Sch ((Attr name' _) : attrs)) - = name == name' || occurs name (Sch attrs) - lookup :: [AChar] -> Schema -> U - lookup _ (Sch []) = undefined - lookup name (Sch ((Attr name' u) : attrs)) - = if name == name' then u else lookup name (Sch attrs) - - data U - = BOOL | STRING | NAT | VEC U Nat - deriving (Read, Eq, Show) - data AChar - = CA | - CB | - CC | - CD | - CE | - CF | - CG | - CH | - CI | - CJ | - CK | - CL | - CM | - CN | - CO | - CP | - CQ | - CR | - CS | - CT | - CU | - CV | - CW | - CX | - CY | - CZ - deriving (Read, Show, Eq) - data Attribute = Attr [AChar] U - data Schema = Sch [Attribute] |] - ======> - GradingClient/Database.hs:(0,0)-(0,0) - data U - = BOOL | STRING | NAT | VEC U Nat - deriving (Read, Eq, Show) - data AChar - = CA | - CB | - CC | - CD | - CE | - CF | - CG | - CH | - CI | - CJ | - CK | - CL | - CM | - CN | - CO | - CP | - CQ | - CR | - CS | - CT | - CU | - CV | - CW | - CX | - CY | - CZ - deriving (Read, Show, Eq) - data Attribute = Attr [AChar] U - data Schema = Sch [Attribute] - append :: Schema -> Schema -> Schema - append (Sch s1) (Sch s2) = Sch (s1 ++ s2) - attrNotIn :: Attribute -> Schema -> Bool - attrNotIn _ (Sch GHC.Types.[]) = True - attrNotIn (Attr name u) (Sch ((Attr name' _) GHC.Types.: t)) - = ((name /= name') && (attrNotIn (Attr name u) (Sch t))) - disjoint :: Schema -> Schema -> Bool - disjoint (Sch GHC.Types.[]) _ = True - disjoint (Sch (h GHC.Types.: t)) s - = ((attrNotIn h s) && (disjoint (Sch t) s)) - occurs :: [AChar] -> Schema -> Bool - occurs _ (Sch GHC.Types.[]) = False - occurs name (Sch ((Attr name' _) GHC.Types.: attrs)) - = ((name == name') || (occurs name (Sch attrs))) - lookup :: [AChar] -> Schema -> U - lookup _ (Sch GHC.Types.[]) = undefined - lookup name (Sch ((Attr name' u) GHC.Types.: attrs)) - = if (name == name') then u else lookup name (Sch attrs) - type family Equals_0123456789 (a :: U) (b :: U) :: Bool where - Equals_0123456789 BOOL BOOL = True - Equals_0123456789 STRING STRING = True - Equals_0123456789 NAT NAT = True - Equals_0123456789 (VEC a a) (VEC b b) = (:&&) ((==) a b) ((==) a b) - Equals_0123456789 (a :: U) (b :: U) = False - type instance (==) (a :: U) (b :: U) = Equals_0123456789 a b - type family Equals_0123456789 (a :: AChar) - (b :: AChar) :: Bool where - Equals_0123456789 CA CA = True - Equals_0123456789 CB CB = True - Equals_0123456789 CC CC = True - Equals_0123456789 CD CD = True - Equals_0123456789 CE CE = True - Equals_0123456789 CF CF = True - Equals_0123456789 CG CG = True - Equals_0123456789 CH CH = True - Equals_0123456789 CI CI = True - Equals_0123456789 CJ CJ = True - Equals_0123456789 CK CK = True - Equals_0123456789 CL CL = True - Equals_0123456789 CM CM = True - Equals_0123456789 CN CN = True - Equals_0123456789 CO CO = True - Equals_0123456789 CP CP = True - Equals_0123456789 CQ CQ = True - Equals_0123456789 CR CR = True - Equals_0123456789 CS CS = True - Equals_0123456789 CT CT = True - Equals_0123456789 CU CU = True - Equals_0123456789 CV CV = True - Equals_0123456789 CW CW = True - Equals_0123456789 CX CX = True - Equals_0123456789 CY CY = True - Equals_0123456789 CZ CZ = True - Equals_0123456789 (a :: AChar) (b :: AChar) = False - type instance (==) (a :: AChar) (b :: AChar) = Equals_0123456789 a b - type family Append (a :: Schema) (a :: Schema) :: Schema where - Append (Sch s1) (Sch s2) = Sch ((:++) s1 s2) - type family AttrNotIn (a :: Attribute) (a :: Schema) :: Bool where - AttrNotIn z (Sch GHC.Types.[]) = True - AttrNotIn (Attr name u) (Sch ((GHC.Types.:) (Attr name' z) t)) = (:&&) ((:/=) name name') (AttrNotIn (Attr name u) (Sch t)) - type family Disjoint (a :: Schema) (a :: Schema) :: Bool where - Disjoint (Sch GHC.Types.[]) z = True - Disjoint (Sch ((GHC.Types.:) h t)) s = (:&&) (AttrNotIn h s) (Disjoint (Sch t) s) - type family Occurs (a :: [AChar]) (a :: Schema) :: Bool where - Occurs z (Sch GHC.Types.[]) = False - Occurs name (Sch ((GHC.Types.:) (Attr name' z) attrs)) = (:||) ((:==) name name') (Occurs name (Sch attrs)) - type family Lookup (a :: [AChar]) (a :: Schema) :: U where - Lookup z (Sch GHC.Types.[]) = Any - Lookup name (Sch ((GHC.Types.:) (Attr name' u) attrs)) = If ((:==) name name') u (Lookup name (Sch attrs)) - data instance Sing (z :: U) - = z ~ BOOL => SBOOL | - z ~ STRING => SSTRING | - z ~ NAT => SNAT | - forall (n :: U) (n :: Nat). z ~ VEC n n => SVEC (Sing n) (Sing n) - type SU (z :: U) = Sing z - instance SingKind (KProxy :: KProxy U) where - type DemoteRep (KProxy :: KProxy U) = U - fromSing SBOOL = BOOL - fromSing SSTRING = STRING - fromSing SNAT = NAT - fromSing (SVEC b b) = VEC (fromSing b) (fromSing b) - toSing BOOL = SomeSing SBOOL - toSing STRING = SomeSing SSTRING - toSing NAT = SomeSing SNAT - toSing (VEC b b) - = case - (toSing b :: SomeSing (KProxy :: KProxy U), - toSing b :: SomeSing (KProxy :: KProxy Nat)) - of { - (SomeSing c, SomeSing c) -> SomeSing (SVEC c c) } - instance SEq (KProxy :: KProxy U) where - (%:==) SBOOL SBOOL = STrue - (%:==) SBOOL SSTRING = SFalse - (%:==) SBOOL SNAT = SFalse - (%:==) SBOOL (SVEC _ _) = SFalse - (%:==) SSTRING SBOOL = SFalse - (%:==) SSTRING SSTRING = STrue - (%:==) SSTRING SNAT = SFalse - (%:==) SSTRING (SVEC _ _) = SFalse - (%:==) SNAT SBOOL = SFalse - (%:==) SNAT SSTRING = SFalse - (%:==) SNAT SNAT = STrue - (%:==) SNAT (SVEC _ _) = SFalse - (%:==) (SVEC _ _) SBOOL = SFalse - (%:==) (SVEC _ _) SSTRING = SFalse - (%:==) (SVEC _ _) SNAT = SFalse - (%:==) (SVEC a a) (SVEC b b) = (%:&&) ((%:==) a b) ((%:==) a b) - instance SDecide (KProxy :: KProxy U) where - (%~) SBOOL SBOOL = Proved Refl - (%~) SBOOL SSTRING - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SBOOL SNAT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SBOOL (SVEC _ _) - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SSTRING SBOOL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SSTRING SSTRING = Proved Refl - (%~) SSTRING SNAT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SSTRING (SVEC _ _) - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SNAT SBOOL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SNAT SSTRING - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SNAT SNAT = Proved Refl - (%~) SNAT (SVEC _ _) - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SVEC _ _) SBOOL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SVEC _ _) SSTRING - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SVEC _ _) SNAT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SVEC a a) (SVEC b b) - = case ((%~) a b, (%~) a b) of { - (Proved Refl, Proved Refl) -> Proved Refl - (Disproved contra, _) -> Disproved (\ Refl -> contra Refl) - (_, Disproved contra) -> Disproved (\ Refl -> contra Refl) } - instance SingI BOOL where - sing = SBOOL - instance SingI STRING where - sing = SSTRING - instance SingI NAT where - sing = SNAT - instance (SingI n, SingI n) => - SingI (VEC (n :: U) (n :: Nat)) where - sing = SVEC sing sing - data instance Sing (z :: AChar) - = z ~ CA => SCA | - z ~ CB => SCB | - z ~ CC => SCC | - z ~ CD => SCD | - z ~ CE => SCE | - z ~ CF => SCF | - z ~ CG => SCG | - z ~ CH => SCH | - z ~ CI => SCI | - z ~ CJ => SCJ | - z ~ CK => SCK | - z ~ CL => SCL | - z ~ CM => SCM | - z ~ CN => SCN | - z ~ CO => SCO | - z ~ CP => SCP | - z ~ CQ => SCQ | - z ~ CR => SCR | - z ~ CS => SCS | - z ~ CT => SCT | - z ~ CU => SCU | - z ~ CV => SCV | - z ~ CW => SCW | - z ~ CX => SCX | - z ~ CY => SCY | - z ~ CZ => SCZ - type SAChar (z :: AChar) = Sing z - instance SingKind (KProxy :: KProxy AChar) where - type DemoteRep (KProxy :: KProxy AChar) = AChar - fromSing SCA = CA - fromSing SCB = CB - fromSing SCC = CC - fromSing SCD = CD - fromSing SCE = CE - fromSing SCF = CF - fromSing SCG = CG - fromSing SCH = CH - fromSing SCI = CI - fromSing SCJ = CJ - fromSing SCK = CK - fromSing SCL = CL - fromSing SCM = CM - fromSing SCN = CN - fromSing SCO = CO - fromSing SCP = CP - fromSing SCQ = CQ - fromSing SCR = CR - fromSing SCS = CS - fromSing SCT = CT - fromSing SCU = CU - fromSing SCV = CV - fromSing SCW = CW - fromSing SCX = CX - fromSing SCY = CY - fromSing SCZ = CZ - toSing CA = SomeSing SCA - toSing CB = SomeSing SCB - toSing CC = SomeSing SCC - toSing CD = SomeSing SCD - toSing CE = SomeSing SCE - toSing CF = SomeSing SCF - toSing CG = SomeSing SCG - toSing CH = SomeSing SCH - toSing CI = SomeSing SCI - toSing CJ = SomeSing SCJ - toSing CK = SomeSing SCK - toSing CL = SomeSing SCL - toSing CM = SomeSing SCM - toSing CN = SomeSing SCN - toSing CO = SomeSing SCO - toSing CP = SomeSing SCP - toSing CQ = SomeSing SCQ - toSing CR = SomeSing SCR - toSing CS = SomeSing SCS - toSing CT = SomeSing SCT - toSing CU = SomeSing SCU - toSing CV = SomeSing SCV - toSing CW = SomeSing SCW - toSing CX = SomeSing SCX - toSing CY = SomeSing SCY - toSing CZ = SomeSing SCZ - instance SEq (KProxy :: KProxy AChar) where - (%:==) SCA SCA = STrue - (%:==) SCA SCB = SFalse - (%:==) SCA SCC = SFalse - (%:==) SCA SCD = SFalse - (%:==) SCA SCE = SFalse - (%:==) SCA SCF = SFalse - (%:==) SCA SCG = SFalse - (%:==) SCA SCH = SFalse - (%:==) SCA SCI = SFalse - (%:==) SCA SCJ = SFalse - (%:==) SCA SCK = SFalse - (%:==) SCA SCL = SFalse - (%:==) SCA SCM = SFalse - (%:==) SCA SCN = SFalse - (%:==) SCA SCO = SFalse - (%:==) SCA SCP = SFalse - (%:==) SCA SCQ = SFalse - (%:==) SCA SCR = SFalse - (%:==) SCA SCS = SFalse - (%:==) SCA SCT = SFalse - (%:==) SCA SCU = SFalse - (%:==) SCA SCV = SFalse - (%:==) SCA SCW = SFalse - (%:==) SCA SCX = SFalse - (%:==) SCA SCY = SFalse - (%:==) SCA SCZ = SFalse - (%:==) SCB SCA = SFalse - (%:==) SCB SCB = STrue - (%:==) SCB SCC = SFalse - (%:==) SCB SCD = SFalse - (%:==) SCB SCE = SFalse - (%:==) SCB SCF = SFalse - (%:==) SCB SCG = SFalse - (%:==) SCB SCH = SFalse - (%:==) SCB SCI = SFalse - (%:==) SCB SCJ = SFalse - (%:==) SCB SCK = SFalse - (%:==) SCB SCL = SFalse - (%:==) SCB SCM = SFalse - (%:==) SCB SCN = SFalse - (%:==) SCB SCO = SFalse - (%:==) SCB SCP = SFalse - (%:==) SCB SCQ = SFalse - (%:==) SCB SCR = SFalse - (%:==) SCB SCS = SFalse - (%:==) SCB SCT = SFalse - (%:==) SCB SCU = SFalse - (%:==) SCB SCV = SFalse - (%:==) SCB SCW = SFalse - (%:==) SCB SCX = SFalse - (%:==) SCB SCY = SFalse - (%:==) SCB SCZ = SFalse - (%:==) SCC SCA = SFalse - (%:==) SCC SCB = SFalse - (%:==) SCC SCC = STrue - (%:==) SCC SCD = SFalse - (%:==) SCC SCE = SFalse - (%:==) SCC SCF = SFalse - (%:==) SCC SCG = SFalse - (%:==) SCC SCH = SFalse - (%:==) SCC SCI = SFalse - (%:==) SCC SCJ = SFalse - (%:==) SCC SCK = SFalse - (%:==) SCC SCL = SFalse - (%:==) SCC SCM = SFalse - (%:==) SCC SCN = SFalse - (%:==) SCC SCO = SFalse - (%:==) SCC SCP = SFalse - (%:==) SCC SCQ = SFalse - (%:==) SCC SCR = SFalse - (%:==) SCC SCS = SFalse - (%:==) SCC SCT = SFalse - (%:==) SCC SCU = SFalse - (%:==) SCC SCV = SFalse - (%:==) SCC SCW = SFalse - (%:==) SCC SCX = SFalse - (%:==) SCC SCY = SFalse - (%:==) SCC SCZ = SFalse - (%:==) SCD SCA = SFalse - (%:==) SCD SCB = SFalse - (%:==) SCD SCC = SFalse - (%:==) SCD SCD = STrue - (%:==) SCD SCE = SFalse - (%:==) SCD SCF = SFalse - (%:==) SCD SCG = SFalse - (%:==) SCD SCH = SFalse - (%:==) SCD SCI = SFalse - (%:==) SCD SCJ = SFalse - (%:==) SCD SCK = SFalse - (%:==) SCD SCL = SFalse - (%:==) SCD SCM = SFalse - (%:==) SCD SCN = SFalse - (%:==) SCD SCO = SFalse - (%:==) SCD SCP = SFalse - (%:==) SCD SCQ = SFalse - (%:==) SCD SCR = SFalse - (%:==) SCD SCS = SFalse - (%:==) SCD SCT = SFalse - (%:==) SCD SCU = SFalse - (%:==) SCD SCV = SFalse - (%:==) SCD SCW = SFalse - (%:==) SCD SCX = SFalse - (%:==) SCD SCY = SFalse - (%:==) SCD SCZ = SFalse - (%:==) SCE SCA = SFalse - (%:==) SCE SCB = SFalse - (%:==) SCE SCC = SFalse - (%:==) SCE SCD = SFalse - (%:==) SCE SCE = STrue - (%:==) SCE SCF = SFalse - (%:==) SCE SCG = SFalse - (%:==) SCE SCH = SFalse - (%:==) SCE SCI = SFalse - (%:==) SCE SCJ = SFalse - (%:==) SCE SCK = SFalse - (%:==) SCE SCL = SFalse - (%:==) SCE SCM = SFalse - (%:==) SCE SCN = SFalse - (%:==) SCE SCO = SFalse - (%:==) SCE SCP = SFalse - (%:==) SCE SCQ = SFalse - (%:==) SCE SCR = SFalse - (%:==) SCE SCS = SFalse - (%:==) SCE SCT = SFalse - (%:==) SCE SCU = SFalse - (%:==) SCE SCV = SFalse - (%:==) SCE SCW = SFalse - (%:==) SCE SCX = SFalse - (%:==) SCE SCY = SFalse - (%:==) SCE SCZ = SFalse - (%:==) SCF SCA = SFalse - (%:==) SCF SCB = SFalse - (%:==) SCF SCC = SFalse - (%:==) SCF SCD = SFalse - (%:==) SCF SCE = SFalse - (%:==) SCF SCF = STrue - (%:==) SCF SCG = SFalse - (%:==) SCF SCH = SFalse - (%:==) SCF SCI = SFalse - (%:==) SCF SCJ = SFalse - (%:==) SCF SCK = SFalse - (%:==) SCF SCL = SFalse - (%:==) SCF SCM = SFalse - (%:==) SCF SCN = SFalse - (%:==) SCF SCO = SFalse - (%:==) SCF SCP = SFalse - (%:==) SCF SCQ = SFalse - (%:==) SCF SCR = SFalse - (%:==) SCF SCS = SFalse - (%:==) SCF SCT = SFalse - (%:==) SCF SCU = SFalse - (%:==) SCF SCV = SFalse - (%:==) SCF SCW = SFalse - (%:==) SCF SCX = SFalse - (%:==) SCF SCY = SFalse - (%:==) SCF SCZ = SFalse - (%:==) SCG SCA = SFalse - (%:==) SCG SCB = SFalse - (%:==) SCG SCC = SFalse - (%:==) SCG SCD = SFalse - (%:==) SCG SCE = SFalse - (%:==) SCG SCF = SFalse - (%:==) SCG SCG = STrue - (%:==) SCG SCH = SFalse - (%:==) SCG SCI = SFalse - (%:==) SCG SCJ = SFalse - (%:==) SCG SCK = SFalse - (%:==) SCG SCL = SFalse - (%:==) SCG SCM = SFalse - (%:==) SCG SCN = SFalse - (%:==) SCG SCO = SFalse - (%:==) SCG SCP = SFalse - (%:==) SCG SCQ = SFalse - (%:==) SCG SCR = SFalse - (%:==) SCG SCS = SFalse - (%:==) SCG SCT = SFalse - (%:==) SCG SCU = SFalse - (%:==) SCG SCV = SFalse - (%:==) SCG SCW = SFalse - (%:==) SCG SCX = SFalse - (%:==) SCG SCY = SFalse - (%:==) SCG SCZ = SFalse - (%:==) SCH SCA = SFalse - (%:==) SCH SCB = SFalse - (%:==) SCH SCC = SFalse - (%:==) SCH SCD = SFalse - (%:==) SCH SCE = SFalse - (%:==) SCH SCF = SFalse - (%:==) SCH SCG = SFalse - (%:==) SCH SCH = STrue - (%:==) SCH SCI = SFalse - (%:==) SCH SCJ = SFalse - (%:==) SCH SCK = SFalse - (%:==) SCH SCL = SFalse - (%:==) SCH SCM = SFalse - (%:==) SCH SCN = SFalse - (%:==) SCH SCO = SFalse - (%:==) SCH SCP = SFalse - (%:==) SCH SCQ = SFalse - (%:==) SCH SCR = SFalse - (%:==) SCH SCS = SFalse - (%:==) SCH SCT = SFalse - (%:==) SCH SCU = SFalse - (%:==) SCH SCV = SFalse - (%:==) SCH SCW = SFalse - (%:==) SCH SCX = SFalse - (%:==) SCH SCY = SFalse - (%:==) SCH SCZ = SFalse - (%:==) SCI SCA = SFalse - (%:==) SCI SCB = SFalse - (%:==) SCI SCC = SFalse - (%:==) SCI SCD = SFalse - (%:==) SCI SCE = SFalse - (%:==) SCI SCF = SFalse - (%:==) SCI SCG = SFalse - (%:==) SCI SCH = SFalse - (%:==) SCI SCI = STrue - (%:==) SCI SCJ = SFalse - (%:==) SCI SCK = SFalse - (%:==) SCI SCL = SFalse - (%:==) SCI SCM = SFalse - (%:==) SCI SCN = SFalse - (%:==) SCI SCO = SFalse - (%:==) SCI SCP = SFalse - (%:==) SCI SCQ = SFalse - (%:==) SCI SCR = SFalse - (%:==) SCI SCS = SFalse - (%:==) SCI SCT = SFalse - (%:==) SCI SCU = SFalse - (%:==) SCI SCV = SFalse - (%:==) SCI SCW = SFalse - (%:==) SCI SCX = SFalse - (%:==) SCI SCY = SFalse - (%:==) SCI SCZ = SFalse - (%:==) SCJ SCA = SFalse - (%:==) SCJ SCB = SFalse - (%:==) SCJ SCC = SFalse - (%:==) SCJ SCD = SFalse - (%:==) SCJ SCE = SFalse - (%:==) SCJ SCF = SFalse - (%:==) SCJ SCG = SFalse - (%:==) SCJ SCH = SFalse - (%:==) SCJ SCI = SFalse - (%:==) SCJ SCJ = STrue - (%:==) SCJ SCK = SFalse - (%:==) SCJ SCL = SFalse - (%:==) SCJ SCM = SFalse - (%:==) SCJ SCN = SFalse - (%:==) SCJ SCO = SFalse - (%:==) SCJ SCP = SFalse - (%:==) SCJ SCQ = SFalse - (%:==) SCJ SCR = SFalse - (%:==) SCJ SCS = SFalse - (%:==) SCJ SCT = SFalse - (%:==) SCJ SCU = SFalse - (%:==) SCJ SCV = SFalse - (%:==) SCJ SCW = SFalse - (%:==) SCJ SCX = SFalse - (%:==) SCJ SCY = SFalse - (%:==) SCJ SCZ = SFalse - (%:==) SCK SCA = SFalse - (%:==) SCK SCB = SFalse - (%:==) SCK SCC = SFalse - (%:==) SCK SCD = SFalse - (%:==) SCK SCE = SFalse - (%:==) SCK SCF = SFalse - (%:==) SCK SCG = SFalse - (%:==) SCK SCH = SFalse - (%:==) SCK SCI = SFalse - (%:==) SCK SCJ = SFalse - (%:==) SCK SCK = STrue - (%:==) SCK SCL = SFalse - (%:==) SCK SCM = SFalse - (%:==) SCK SCN = SFalse - (%:==) SCK SCO = SFalse - (%:==) SCK SCP = SFalse - (%:==) SCK SCQ = SFalse - (%:==) SCK SCR = SFalse - (%:==) SCK SCS = SFalse - (%:==) SCK SCT = SFalse - (%:==) SCK SCU = SFalse - (%:==) SCK SCV = SFalse - (%:==) SCK SCW = SFalse - (%:==) SCK SCX = SFalse - (%:==) SCK SCY = SFalse - (%:==) SCK SCZ = SFalse - (%:==) SCL SCA = SFalse - (%:==) SCL SCB = SFalse - (%:==) SCL SCC = SFalse - (%:==) SCL SCD = SFalse - (%:==) SCL SCE = SFalse - (%:==) SCL SCF = SFalse - (%:==) SCL SCG = SFalse - (%:==) SCL SCH = SFalse - (%:==) SCL SCI = SFalse - (%:==) SCL SCJ = SFalse - (%:==) SCL SCK = SFalse - (%:==) SCL SCL = STrue - (%:==) SCL SCM = SFalse - (%:==) SCL SCN = SFalse - (%:==) SCL SCO = SFalse - (%:==) SCL SCP = SFalse - (%:==) SCL SCQ = SFalse - (%:==) SCL SCR = SFalse - (%:==) SCL SCS = SFalse - (%:==) SCL SCT = SFalse - (%:==) SCL SCU = SFalse - (%:==) SCL SCV = SFalse - (%:==) SCL SCW = SFalse - (%:==) SCL SCX = SFalse - (%:==) SCL SCY = SFalse - (%:==) SCL SCZ = SFalse - (%:==) SCM SCA = SFalse - (%:==) SCM SCB = SFalse - (%:==) SCM SCC = SFalse - (%:==) SCM SCD = SFalse - (%:==) SCM SCE = SFalse - (%:==) SCM SCF = SFalse - (%:==) SCM SCG = SFalse - (%:==) SCM SCH = SFalse - (%:==) SCM SCI = SFalse - (%:==) SCM SCJ = SFalse - (%:==) SCM SCK = SFalse - (%:==) SCM SCL = SFalse - (%:==) SCM SCM = STrue - (%:==) SCM SCN = SFalse - (%:==) SCM SCO = SFalse - (%:==) SCM SCP = SFalse - (%:==) SCM SCQ = SFalse - (%:==) SCM SCR = SFalse - (%:==) SCM SCS = SFalse - (%:==) SCM SCT = SFalse - (%:==) SCM SCU = SFalse - (%:==) SCM SCV = SFalse - (%:==) SCM SCW = SFalse - (%:==) SCM SCX = SFalse - (%:==) SCM SCY = SFalse - (%:==) SCM SCZ = SFalse - (%:==) SCN SCA = SFalse - (%:==) SCN SCB = SFalse - (%:==) SCN SCC = SFalse - (%:==) SCN SCD = SFalse - (%:==) SCN SCE = SFalse - (%:==) SCN SCF = SFalse - (%:==) SCN SCG = SFalse - (%:==) SCN SCH = SFalse - (%:==) SCN SCI = SFalse - (%:==) SCN SCJ = SFalse - (%:==) SCN SCK = SFalse - (%:==) SCN SCL = SFalse - (%:==) SCN SCM = SFalse - (%:==) SCN SCN = STrue - (%:==) SCN SCO = SFalse - (%:==) SCN SCP = SFalse - (%:==) SCN SCQ = SFalse - (%:==) SCN SCR = SFalse - (%:==) SCN SCS = SFalse - (%:==) SCN SCT = SFalse - (%:==) SCN SCU = SFalse - (%:==) SCN SCV = SFalse - (%:==) SCN SCW = SFalse - (%:==) SCN SCX = SFalse - (%:==) SCN SCY = SFalse - (%:==) SCN SCZ = SFalse - (%:==) SCO SCA = SFalse - (%:==) SCO SCB = SFalse - (%:==) SCO SCC = SFalse - (%:==) SCO SCD = SFalse - (%:==) SCO SCE = SFalse - (%:==) SCO SCF = SFalse - (%:==) SCO SCG = SFalse - (%:==) SCO SCH = SFalse - (%:==) SCO SCI = SFalse - (%:==) SCO SCJ = SFalse - (%:==) SCO SCK = SFalse - (%:==) SCO SCL = SFalse - (%:==) SCO SCM = SFalse - (%:==) SCO SCN = SFalse - (%:==) SCO SCO = STrue - (%:==) SCO SCP = SFalse - (%:==) SCO SCQ = SFalse - (%:==) SCO SCR = SFalse - (%:==) SCO SCS = SFalse - (%:==) SCO SCT = SFalse - (%:==) SCO SCU = SFalse - (%:==) SCO SCV = SFalse - (%:==) SCO SCW = SFalse - (%:==) SCO SCX = SFalse - (%:==) SCO SCY = SFalse - (%:==) SCO SCZ = SFalse - (%:==) SCP SCA = SFalse - (%:==) SCP SCB = SFalse - (%:==) SCP SCC = SFalse - (%:==) SCP SCD = SFalse - (%:==) SCP SCE = SFalse - (%:==) SCP SCF = SFalse - (%:==) SCP SCG = SFalse - (%:==) SCP SCH = SFalse - (%:==) SCP SCI = SFalse - (%:==) SCP SCJ = SFalse - (%:==) SCP SCK = SFalse - (%:==) SCP SCL = SFalse - (%:==) SCP SCM = SFalse - (%:==) SCP SCN = SFalse - (%:==) SCP SCO = SFalse - (%:==) SCP SCP = STrue - (%:==) SCP SCQ = SFalse - (%:==) SCP SCR = SFalse - (%:==) SCP SCS = SFalse - (%:==) SCP SCT = SFalse - (%:==) SCP SCU = SFalse - (%:==) SCP SCV = SFalse - (%:==) SCP SCW = SFalse - (%:==) SCP SCX = SFalse - (%:==) SCP SCY = SFalse - (%:==) SCP SCZ = SFalse - (%:==) SCQ SCA = SFalse - (%:==) SCQ SCB = SFalse - (%:==) SCQ SCC = SFalse - (%:==) SCQ SCD = SFalse - (%:==) SCQ SCE = SFalse - (%:==) SCQ SCF = SFalse - (%:==) SCQ SCG = SFalse - (%:==) SCQ SCH = SFalse - (%:==) SCQ SCI = SFalse - (%:==) SCQ SCJ = SFalse - (%:==) SCQ SCK = SFalse - (%:==) SCQ SCL = SFalse - (%:==) SCQ SCM = SFalse - (%:==) SCQ SCN = SFalse - (%:==) SCQ SCO = SFalse - (%:==) SCQ SCP = SFalse - (%:==) SCQ SCQ = STrue - (%:==) SCQ SCR = SFalse - (%:==) SCQ SCS = SFalse - (%:==) SCQ SCT = SFalse - (%:==) SCQ SCU = SFalse - (%:==) SCQ SCV = SFalse - (%:==) SCQ SCW = SFalse - (%:==) SCQ SCX = SFalse - (%:==) SCQ SCY = SFalse - (%:==) SCQ SCZ = SFalse - (%:==) SCR SCA = SFalse - (%:==) SCR SCB = SFalse - (%:==) SCR SCC = SFalse - (%:==) SCR SCD = SFalse - (%:==) SCR SCE = SFalse - (%:==) SCR SCF = SFalse - (%:==) SCR SCG = SFalse - (%:==) SCR SCH = SFalse - (%:==) SCR SCI = SFalse - (%:==) SCR SCJ = SFalse - (%:==) SCR SCK = SFalse - (%:==) SCR SCL = SFalse - (%:==) SCR SCM = SFalse - (%:==) SCR SCN = SFalse - (%:==) SCR SCO = SFalse - (%:==) SCR SCP = SFalse - (%:==) SCR SCQ = SFalse - (%:==) SCR SCR = STrue - (%:==) SCR SCS = SFalse - (%:==) SCR SCT = SFalse - (%:==) SCR SCU = SFalse - (%:==) SCR SCV = SFalse - (%:==) SCR SCW = SFalse - (%:==) SCR SCX = SFalse - (%:==) SCR SCY = SFalse - (%:==) SCR SCZ = SFalse - (%:==) SCS SCA = SFalse - (%:==) SCS SCB = SFalse - (%:==) SCS SCC = SFalse - (%:==) SCS SCD = SFalse - (%:==) SCS SCE = SFalse - (%:==) SCS SCF = SFalse - (%:==) SCS SCG = SFalse - (%:==) SCS SCH = SFalse - (%:==) SCS SCI = SFalse - (%:==) SCS SCJ = SFalse - (%:==) SCS SCK = SFalse - (%:==) SCS SCL = SFalse - (%:==) SCS SCM = SFalse - (%:==) SCS SCN = SFalse - (%:==) SCS SCO = SFalse - (%:==) SCS SCP = SFalse - (%:==) SCS SCQ = SFalse - (%:==) SCS SCR = SFalse - (%:==) SCS SCS = STrue - (%:==) SCS SCT = SFalse - (%:==) SCS SCU = SFalse - (%:==) SCS SCV = SFalse - (%:==) SCS SCW = SFalse - (%:==) SCS SCX = SFalse - (%:==) SCS SCY = SFalse - (%:==) SCS SCZ = SFalse - (%:==) SCT SCA = SFalse - (%:==) SCT SCB = SFalse - (%:==) SCT SCC = SFalse - (%:==) SCT SCD = SFalse - (%:==) SCT SCE = SFalse - (%:==) SCT SCF = SFalse - (%:==) SCT SCG = SFalse - (%:==) SCT SCH = SFalse - (%:==) SCT SCI = SFalse - (%:==) SCT SCJ = SFalse - (%:==) SCT SCK = SFalse - (%:==) SCT SCL = SFalse - (%:==) SCT SCM = SFalse - (%:==) SCT SCN = SFalse - (%:==) SCT SCO = SFalse - (%:==) SCT SCP = SFalse - (%:==) SCT SCQ = SFalse - (%:==) SCT SCR = SFalse - (%:==) SCT SCS = SFalse - (%:==) SCT SCT = STrue - (%:==) SCT SCU = SFalse - (%:==) SCT SCV = SFalse - (%:==) SCT SCW = SFalse - (%:==) SCT SCX = SFalse - (%:==) SCT SCY = SFalse - (%:==) SCT SCZ = SFalse - (%:==) SCU SCA = SFalse - (%:==) SCU SCB = SFalse - (%:==) SCU SCC = SFalse - (%:==) SCU SCD = SFalse - (%:==) SCU SCE = SFalse - (%:==) SCU SCF = SFalse - (%:==) SCU SCG = SFalse - (%:==) SCU SCH = SFalse - (%:==) SCU SCI = SFalse - (%:==) SCU SCJ = SFalse - (%:==) SCU SCK = SFalse - (%:==) SCU SCL = SFalse - (%:==) SCU SCM = SFalse - (%:==) SCU SCN = SFalse - (%:==) SCU SCO = SFalse - (%:==) SCU SCP = SFalse - (%:==) SCU SCQ = SFalse - (%:==) SCU SCR = SFalse - (%:==) SCU SCS = SFalse - (%:==) SCU SCT = SFalse - (%:==) SCU SCU = STrue - (%:==) SCU SCV = SFalse - (%:==) SCU SCW = SFalse - (%:==) SCU SCX = SFalse - (%:==) SCU SCY = SFalse - (%:==) SCU SCZ = SFalse - (%:==) SCV SCA = SFalse - (%:==) SCV SCB = SFalse - (%:==) SCV SCC = SFalse - (%:==) SCV SCD = SFalse - (%:==) SCV SCE = SFalse - (%:==) SCV SCF = SFalse - (%:==) SCV SCG = SFalse - (%:==) SCV SCH = SFalse - (%:==) SCV SCI = SFalse - (%:==) SCV SCJ = SFalse - (%:==) SCV SCK = SFalse - (%:==) SCV SCL = SFalse - (%:==) SCV SCM = SFalse - (%:==) SCV SCN = SFalse - (%:==) SCV SCO = SFalse - (%:==) SCV SCP = SFalse - (%:==) SCV SCQ = SFalse - (%:==) SCV SCR = SFalse - (%:==) SCV SCS = SFalse - (%:==) SCV SCT = SFalse - (%:==) SCV SCU = SFalse - (%:==) SCV SCV = STrue - (%:==) SCV SCW = SFalse - (%:==) SCV SCX = SFalse - (%:==) SCV SCY = SFalse - (%:==) SCV SCZ = SFalse - (%:==) SCW SCA = SFalse - (%:==) SCW SCB = SFalse - (%:==) SCW SCC = SFalse - (%:==) SCW SCD = SFalse - (%:==) SCW SCE = SFalse - (%:==) SCW SCF = SFalse - (%:==) SCW SCG = SFalse - (%:==) SCW SCH = SFalse - (%:==) SCW SCI = SFalse - (%:==) SCW SCJ = SFalse - (%:==) SCW SCK = SFalse - (%:==) SCW SCL = SFalse - (%:==) SCW SCM = SFalse - (%:==) SCW SCN = SFalse - (%:==) SCW SCO = SFalse - (%:==) SCW SCP = SFalse - (%:==) SCW SCQ = SFalse - (%:==) SCW SCR = SFalse - (%:==) SCW SCS = SFalse - (%:==) SCW SCT = SFalse - (%:==) SCW SCU = SFalse - (%:==) SCW SCV = SFalse - (%:==) SCW SCW = STrue - (%:==) SCW SCX = SFalse - (%:==) SCW SCY = SFalse - (%:==) SCW SCZ = SFalse - (%:==) SCX SCA = SFalse - (%:==) SCX SCB = SFalse - (%:==) SCX SCC = SFalse - (%:==) SCX SCD = SFalse - (%:==) SCX SCE = SFalse - (%:==) SCX SCF = SFalse - (%:==) SCX SCG = SFalse - (%:==) SCX SCH = SFalse - (%:==) SCX SCI = SFalse - (%:==) SCX SCJ = SFalse - (%:==) SCX SCK = SFalse - (%:==) SCX SCL = SFalse - (%:==) SCX SCM = SFalse - (%:==) SCX SCN = SFalse - (%:==) SCX SCO = SFalse - (%:==) SCX SCP = SFalse - (%:==) SCX SCQ = SFalse - (%:==) SCX SCR = SFalse - (%:==) SCX SCS = SFalse - (%:==) SCX SCT = SFalse - (%:==) SCX SCU = SFalse - (%:==) SCX SCV = SFalse - (%:==) SCX SCW = SFalse - (%:==) SCX SCX = STrue - (%:==) SCX SCY = SFalse - (%:==) SCX SCZ = SFalse - (%:==) SCY SCA = SFalse - (%:==) SCY SCB = SFalse - (%:==) SCY SCC = SFalse - (%:==) SCY SCD = SFalse - (%:==) SCY SCE = SFalse - (%:==) SCY SCF = SFalse - (%:==) SCY SCG = SFalse - (%:==) SCY SCH = SFalse - (%:==) SCY SCI = SFalse - (%:==) SCY SCJ = SFalse - (%:==) SCY SCK = SFalse - (%:==) SCY SCL = SFalse - (%:==) SCY SCM = SFalse - (%:==) SCY SCN = SFalse - (%:==) SCY SCO = SFalse - (%:==) SCY SCP = SFalse - (%:==) SCY SCQ = SFalse - (%:==) SCY SCR = SFalse - (%:==) SCY SCS = SFalse - (%:==) SCY SCT = SFalse - (%:==) SCY SCU = SFalse - (%:==) SCY SCV = SFalse - (%:==) SCY SCW = SFalse - (%:==) SCY SCX = SFalse - (%:==) SCY SCY = STrue - (%:==) SCY SCZ = SFalse - (%:==) SCZ SCA = SFalse - (%:==) SCZ SCB = SFalse - (%:==) SCZ SCC = SFalse - (%:==) SCZ SCD = SFalse - (%:==) SCZ SCE = SFalse - (%:==) SCZ SCF = SFalse - (%:==) SCZ SCG = SFalse - (%:==) SCZ SCH = SFalse - (%:==) SCZ SCI = SFalse - (%:==) SCZ SCJ = SFalse - (%:==) SCZ SCK = SFalse - (%:==) SCZ SCL = SFalse - (%:==) SCZ SCM = SFalse - (%:==) SCZ SCN = SFalse - (%:==) SCZ SCO = SFalse - (%:==) SCZ SCP = SFalse - (%:==) SCZ SCQ = SFalse - (%:==) SCZ SCR = SFalse - (%:==) SCZ SCS = SFalse - (%:==) SCZ SCT = SFalse - (%:==) SCZ SCU = SFalse - (%:==) SCZ SCV = SFalse - (%:==) SCZ SCW = SFalse - (%:==) SCZ SCX = SFalse - (%:==) SCZ SCY = SFalse - (%:==) SCZ SCZ = STrue - instance SDecide (KProxy :: KProxy AChar) where - (%~) SCA SCA = Proved Refl - (%~) SCA SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCB = Proved Refl - (%~) SCB SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCC = Proved Refl - (%~) SCC SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCD = Proved Refl - (%~) SCD SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCE = Proved Refl - (%~) SCE SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCF = Proved Refl - (%~) SCF SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCG = Proved Refl - (%~) SCG SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCH = Proved Refl - (%~) SCH SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCI = Proved Refl - (%~) SCI SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCJ = Proved Refl - (%~) SCJ SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCK = Proved Refl - (%~) SCK SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCL = Proved Refl - (%~) SCL SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCM = Proved Refl - (%~) SCM SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCN = Proved Refl - (%~) SCN SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCO = Proved Refl - (%~) SCO SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCP = Proved Refl - (%~) SCP SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCQ = Proved Refl - (%~) SCQ SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCR = Proved Refl - (%~) SCR SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCS = Proved Refl - (%~) SCS SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCT = Proved Refl - (%~) SCT SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCU = Proved Refl - (%~) SCU SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCV = Proved Refl - (%~) SCV SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCW = Proved Refl - (%~) SCW SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCX = Proved Refl - (%~) SCX SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCY = Proved Refl - (%~) SCY SCZ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCA - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCB - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCC - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCD - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCE - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCF - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCG - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCH - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCI - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCJ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCK - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCL - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCM - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCN - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCO - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCP - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCQ - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCR - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCS - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCT - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCU - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCV - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCW - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCX - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCY - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCZ = Proved Refl - instance SingI CA where - sing = SCA - instance SingI CB where - sing = SCB - instance SingI CC where - sing = SCC - instance SingI CD where - sing = SCD - instance SingI CE where - sing = SCE - instance SingI CF where - sing = SCF - instance SingI CG where - sing = SCG - instance SingI CH where - sing = SCH - instance SingI CI where - sing = SCI - instance SingI CJ where - sing = SCJ - instance SingI CK where - sing = SCK - instance SingI CL where - sing = SCL - instance SingI CM where - sing = SCM - instance SingI CN where - sing = SCN - instance SingI CO where - sing = SCO - instance SingI CP where - sing = SCP - instance SingI CQ where - sing = SCQ - instance SingI CR where - sing = SCR - instance SingI CS where - sing = SCS - instance SingI CT where - sing = SCT - instance SingI CU where - sing = SCU - instance SingI CV where - sing = SCV - instance SingI CW where - sing = SCW - instance SingI CX where - sing = SCX - instance SingI CY where - sing = SCY - instance SingI CZ where - sing = SCZ - data instance Sing (z :: Attribute) - = forall (n :: [AChar]) (n :: U). z ~ Attr n n => - SAttr (Sing n) (Sing n) - type SAttribute (z :: Attribute) = Sing z - instance SingKind (KProxy :: KProxy Attribute) where - type DemoteRep (KProxy :: KProxy Attribute) = Attribute - fromSing (SAttr b b) = Attr (fromSing b) (fromSing b) - toSing (Attr b b) - = case - (toSing b :: SomeSing (KProxy :: KProxy [AChar]), - toSing b :: SomeSing (KProxy :: KProxy U)) - of { - (SomeSing c, SomeSing c) -> SomeSing (SAttr c c) } - instance (SingI n, SingI n) => - SingI (Attr (n :: [AChar]) (n :: U)) where - sing = SAttr sing sing - data instance Sing (z :: Schema) - = forall (n :: [Attribute]). z ~ Sch n => SSch (Sing n) - type SSchema (z :: Schema) = Sing z - instance SingKind (KProxy :: KProxy Schema) where - type DemoteRep (KProxy :: KProxy Schema) = Schema - fromSing (SSch b) = Sch (fromSing b) - toSing (Sch b) - = case toSing b :: SomeSing (KProxy :: KProxy [Attribute]) of { - SomeSing c -> SomeSing (SSch c) } - instance SingI n => SingI (Sch (n :: [Attribute])) where - sing = SSch sing - sAppend :: - forall (t :: Schema) (t :: Schema). - Sing t -> Sing t -> Sing (Append t t) - sAppend (SSch s1) (SSch s2) = SSch ((%:++) s1 s2) - sAttrNotIn :: - forall (t :: Attribute) (t :: Schema). - Sing t -> Sing t -> Sing (AttrNotIn t t) - sAttrNotIn _ (SSch SNil) = STrue - sAttrNotIn (SAttr name u) (SSch (SCons (SAttr name' _) t)) - = (%:&&) ((%:/=) name name') (sAttrNotIn (SAttr name u) (SSch t)) - sDisjoint :: - forall (t :: Schema) (t :: Schema). - Sing t -> Sing t -> Sing (Disjoint t t) - sDisjoint (SSch SNil) _ = STrue - sDisjoint (SSch (SCons h t)) s - = (%:&&) (sAttrNotIn h s) (sDisjoint (SSch t) s) - sOccurs :: - forall (t :: [AChar]) (t :: Schema). - Sing t -> Sing t -> Sing (Occurs t t) - sOccurs _ (SSch SNil) = SFalse - sOccurs name (SSch (SCons (SAttr name' _) attrs)) - = (%:||) ((%:==) name name') (sOccurs name (SSch attrs)) - sLookup :: - forall (t :: [AChar]) (t :: Schema). - Sing t -> Sing t -> Sing (Lookup t t) - sLookup _ (SSch SNil) = undefined - sLookup name (SSch (SCons (SAttr name' u) attrs)) - = sIf ((%:==) name name') u (sLookup name (SSch attrs)) -GradingClient/Database.hs:0:0: Splicing declarations - return [] ======> GradingClient/Database.hs:0:0: -GradingClient/Database.hs:(0,0)-(0,0): Splicing expression - cases ''Row [| r |] [| changeId (n ++ (getId r)) r |] - ======> - case r of { - EmptyRow _ -> changeId (n ++ (getId r)) r - ConsRow _ _ -> changeId (n ++ (getId r)) r } diff --git a/tests/compile-and-dump/GradingClient/Database.hs b/tests/compile-and-dump/GradingClient/Database.hs deleted file mode 100644 --- a/tests/compile-and-dump/GradingClient/Database.hs +++ /dev/null @@ -1,536 +0,0 @@ -{- Database.hs - -(c) Richard Eisenberg 2012 -eir@cis.upenn.edu - -This file contains the full code for the database interface example -presented in /Dependently typed programming with singletons/ - --} - -{-# LANGUAGE PolyKinds, DataKinds, TemplateHaskell, TypeFamilies, - GADTs, TypeOperators, RankNTypes, FlexibleContexts, UndecidableInstances, - FlexibleInstances, ScopedTypeVariables, MultiParamTypeClasses, - OverlappingInstances, ConstraintKinds, CPP #-} - --- The OverlappingInstances is needed only to allow the InC and SubsetC classes. --- This is simply a convenience so that GHC can infer the necessary proofs of --- schema inclusion. The library could easily be designed without this flag, --- but it would require a client to explicity build proof terms from --- InProof and Subset. - -module GradingClient.Database where - -import Prelude hiding ( tail, id ) -import Data.Singletons.TH -import Data.Singletons.Prelude -import Control.Monad -import Data.List hiding ( tail ) -import Control.Monad.Error - -$(singletons [d| - -- Basic Nat type - data Nat = Zero | Succ Nat deriving (Eq, Ord) - |]) - --- Conversions to any from Integers -fromNat :: Nat -> Integer -fromNat Zero = 0 -fromNat (Succ n) = (fromNat n) + 1 - -toNat :: Integer -> Nat -toNat 0 = Zero -toNat n | n > 0 = Succ (toNat (n - 1)) -toNat _ = error "Converting negative to Nat" - --- Display and read Nats using decimal digits -instance Show Nat where - show = show . fromNat -instance Read Nat where - readsPrec n s = map (\(a,rest) -> (toNat a,rest)) $ readsPrec n s - -$(singletons [d| - -- Our "U"niverse of types. These types can be stored in our database. - data U = BOOL - | STRING - | NAT - | VEC U Nat deriving (Read, Eq, Show) - - -- A re-definition of Char as an algebraic data type. - -- This is necessary to allow for promotion and type-level Strings. - data AChar = CA | CB | CC | CD | CE | CF | CG | CH | CI - | CJ | CK | CL | CM | CN | CO | CP | CQ | CR - | CS | CT | CU | CV | CW | CX | CY | CZ - deriving (Read, Show, Eq) - - -- A named attribute in our database - data Attribute = Attr [AChar] U - - -- A schema is an ordered list of named attributes - data Schema = Sch [Attribute] - - -- append two schemas - append :: Schema -> Schema -> Schema - append (Sch s1) (Sch s2) = Sch (s1 ++ s2) - - -- predicate to check that a schema is free of a certain attribute - attrNotIn :: Attribute -> Schema -> Bool - attrNotIn _ (Sch []) = True - attrNotIn (Attr name u) (Sch ((Attr name' _) : t)) = - (name /= name') && (attrNotIn (Attr name u) (Sch t)) - - -- predicate to check that two schemas are disjoint - disjoint :: Schema -> Schema -> Bool - disjoint (Sch []) _ = True - disjoint (Sch (h : t)) s = (attrNotIn h s) && (disjoint (Sch t) s) - - -- predicate to check if a name occurs in a schema - occurs :: [AChar] -> Schema -> Bool - occurs _ (Sch []) = False - occurs name (Sch ((Attr name' _) : attrs)) = - name == name' || occurs name (Sch attrs) - - -- looks up an element type from a schema - lookup :: [AChar] -> Schema -> U - lookup _ (Sch []) = undefined - lookup name (Sch ((Attr name' u) : attrs)) = - if name == name' then u else lookup name (Sch attrs) - |]) - --- The El type family gives us the type associated with a constructor --- of U: -type family El (u :: U) :: * -type instance El BOOL = Bool -type instance El STRING = String -type instance El NAT = Nat -type instance El (VEC u n) = Vec (El u) n - --- Length-indexed vectors -data Vec :: * -> Nat -> * where - VNil :: Vec a Zero - VCons :: a -> Vec a n -> Vec a (Succ n) - --- Read instances are keyed by the index of the vector to aid in parsing -instance Read (Vec a Zero) where - readsPrec _ s = [(VNil, s)] -instance (Read a, Read (Vec a n)) => Read (Vec a (Succ n)) where - readsPrec n s = do - (a, rest) <- readsPrec n s - (tail, restrest) <- readsPrec n rest - return (VCons a tail, restrest) - --- Because the Read instances are keyed by the length of the vector, --- it is not obvious to the compiler that all Vecs have a Read instance. --- We must make a short inductive proof of this fact. - --- First, we define a datatype to store the resulting instance, keyed --- by the parameters to Vec: -data VecReadInstance a n where - VecReadInstance :: Read (Vec a n) => VecReadInstance a n - --- Then, we make a function that produces an instance of Read for a --- Vec, given the datatype it is over and its length, both encoded --- using singleton types: -vecReadInstance :: Read (El u) => SU u -> SNat n -> VecReadInstance (El u) n -vecReadInstance _ SZero = VecReadInstance -vecReadInstance u (SSucc n) = case vecReadInstance u n of - VecReadInstance -> VecReadInstance - --- The Show instance can be straightforwardly defined: -instance Show a => Show (Vec a n) where - show VNil = "" - show (VCons h t) = (show h) ++ " " ++ (show t) - --- We need to be able to Read and Show elements of our database, so --- we must know that any type of the form (El u) for some (u :: U) --- has a Read and Show instance. Because we can't declare this instance --- directly (as, in general, declaring an instance of a type family --- would be unsound), we provide inductive proofs that these instances --- exist: -data ElUReadInstance u where - ElUReadInstance :: Read (El u) => ElUReadInstance u - -elUReadInstance :: Sing u -> ElUReadInstance u -elUReadInstance SBOOL = ElUReadInstance -elUReadInstance SSTRING = ElUReadInstance -elUReadInstance SNAT = ElUReadInstance -elUReadInstance (SVEC u n) = case elUReadInstance u of - ElUReadInstance -> case vecReadInstance u n of - VecReadInstance -> ElUReadInstance - -data ElUShowInstance u where - ElUShowInstance :: Show (El u) => ElUShowInstance u - -elUShowInstance :: Sing u -> ElUShowInstance u -elUShowInstance SBOOL = ElUShowInstance -elUShowInstance SSTRING = ElUShowInstance -elUShowInstance SNAT = ElUShowInstance -elUShowInstance (SVEC u _) = case elUShowInstance u of - ElUShowInstance -> ElUShowInstance - -showAttrProof :: Sing (Attr nm u) -> ElUShowInstance u -showAttrProof (SAttr _ u) = elUShowInstance u - --- A Row is one row of our database table, keyed by its schema. -data Row :: Schema -> * where - EmptyRow :: [Int] -> Row (Sch '[]) -- the Ints are the unique id of the row - ConsRow :: El u -> Row (Sch s) -> Row (Sch ((Attr name u) ': s)) - --- We build Show instances for a Row element by element: -instance Show (Row (Sch '[])) where - show (EmptyRow n) = "(id=" ++ (show n) ++ ")" -instance (Show (El u), Show (Row (Sch attrs))) => - Show (Row (Sch ((Attr name u) ': attrs))) where - show (ConsRow h t) = case t of - EmptyRow n -> (show h) ++ " (id=" ++ (show n) ++ ")" - _ -> (show h) ++ ", " ++ (show t) - --- A Handle in our system is an abstract handle to a loaded table. --- The constructor is not exported. In our simplistic case, we --- just store the list of rows. A more sophisticated implementation --- could store some identifier to the connection to an external database. -data Handle :: Schema -> * where - Handle :: [Row s] -> Handle s - --- The following functions parse our very simple flat file database format. - --- The file, with a name ending in ".dat", consists of a sequence of lines, --- where each line contains one entry in the table. There is no row separator; --- if a row contains n pieces of data, that row is represented in n lines in --- the file. - --- A schema is stored in a file of the same name, except ending in ".schema". --- Each line in the file is a constructor of U indicating the type of the --- corresponding row element. - --- Use Either for error handling in parsing functions -type ErrorM = Either String - --- This function is relatively uninteresting except for its use of --- pattern matching to introduce the instances of Read and Show for --- elements -readRow :: Int -> SSchema s -> [String] -> ErrorM (Row s, [String]) -readRow id (SSch SNil) strs = - return (EmptyRow [id], strs) -readRow _ (SSch (SCons _ _)) [] = - throwError "Ran out of data while processing row" -readRow id (SSch (SCons (SAttr _ u) at)) (sh:st) = do - (rowTail, strTail) <- readRow id (SSch at) st - case elUReadInstance u of - ElUReadInstance -> - let results = readsPrec 0 sh in - if null results - then throwError $ "No parse of " ++ sh ++ " as a " ++ - (show (fromSing u)) - else - let item = fst $ head results in - case elUShowInstance u of - ElUShowInstance -> return (ConsRow item rowTail, strTail) - -readRows :: SSchema s -> [String] -> [Row s] -> ErrorM [Row s] -readRows _ [] soFar = return soFar -readRows sch lst soFar = do - (row, rest) <- readRow (length soFar) sch lst - readRows sch rest (row : soFar) - --- Given the name of a database and its schema, return a handle to the --- database. -connect :: String -> SSchema s -> IO (Handle s) -connect name schema = do - schString <- readFile (name ++ ".schema") - let schEntries = lines schString - usFound = map read schEntries -- load schema just using "read" - (Sch attrs) = fromSing schema - usExpected = map (\(Attr _ u) -> u) attrs - unless (usFound == usExpected) -- compare found schema with expected - (fail "Expected schema does not match found schema") - dataString <- readFile (name ++ ".dat") - let dataEntries = lines dataString - result = readRows schema dataEntries [] -- read actual data - case result of - Left errorMsg -> fail errorMsg - Right rows -> return $ Handle rows - --- In order to define strongly-typed projection from a row, we need to have a notion --- that one schema is a subset of another. We permit the schemas to have their columns --- in different orders. We define this subset relation via two inductively defined --- propositions. In Haskell, these inductively defined propositions take the form of --- GADTs. In their original form, they would look like this: -{- -data InProof :: Attribute -> Schema -> * where - InElt :: InProof attr (Sch (attr ': schTail)) - InTail :: InProof attr (Sch attrs) -> InProof attr (Sch (a ': attrs)) - -data SubsetProof :: Schema -> Schema -> * where - SubsetEmpty :: SubsetProof (Sch '[]) s' - SubsetCons :: InProof attr s' -> SubsetProof (Sch attrs) s' -> - SubsetProof (Sch (attr ': attrs)) s' --} --- However, it would be convenient to users of the database library not to require --- building these proofs manually. So, we define type classes so that the compiler --- builds the proofs automatically. To make everything work well together, we also --- make the parameters to the proof GADT constructors implicit -- i.e. in the form --- of type class constraints. - -data InProof :: Attribute -> Schema -> * where - InElt :: InProof attr (Sch (attr ': schTail)) - InTail :: InC name u (Sch attrs) => InProof (Attr name u) (Sch (a ': attrs)) - -class InC (name :: [AChar]) (u :: U) (sch :: Schema) where - inProof :: InProof (Attr name u) sch -instance InC name u (Sch ((Attr name u) ': schTail)) where - inProof = InElt -instance InC name u (Sch attrs) => InC name u (Sch (a ': attrs)) where - inProof = InTail - -data SubsetProof :: Schema -> Schema -> * where - SubsetEmpty :: SubsetProof (Sch '[]) s' - SubsetCons :: (InC name u s', SubsetC (Sch attrs) s') => - SubsetProof (Sch ((Attr name u) ': attrs)) s' - -class SubsetC (s :: Schema) (s' :: Schema) where - subset :: SubsetProof s s' - -instance SubsetC (Sch '[]) s' where - subset = SubsetEmpty -instance (InC name u s', SubsetC (Sch attrs) s') => - SubsetC (Sch ((Attr name u) ': attrs)) s' where - subset = SubsetCons - --- To access the data in a structured (and well-typed!) way, we use --- an RA (short for Relational Algebra). An RA is indexed by the schema --- of the data it produces. -data RA :: Schema -> * where - -- The RA includes all data represented by the handle. - Read :: Handle s -> RA s - - -- The RA is a union of the rows represented by the two RAs provided. - -- Note that the schemas of the two RAs must be the same for this - -- constructor use to type-check. - Union :: RA s -> RA s -> RA s - - -- The RA is the list of rows in the first RA, omitting those in the - -- second. Once again, the schemas must match. - Diff :: RA s -> RA s -> RA s - - -- The RA is a Cartesian product of the two RAs provided. Note that - -- the schemas of the two provided RAs must be disjoint. - Product :: (Disjoint s s' ~ True, SingI s, SingI s') => - RA s -> RA s' -> RA (Append s s') - - -- The RA is a projection conforming to the schema provided. The - -- type-checker ensures that this schema is a subset of the data - -- included in the provided RA. - Project :: (SubsetC s' s, SingI s) => - SSchema s' -> RA s -> RA s' - - -- The RA contains only those rows of the provided RA for which - -- the provided expression evaluates to True. Note that the - -- schema of the provided RA and the resultant RA are the same - -- because the columns of data are the same. Also note that - -- the expression must return a Bool for this to type-check. - Select :: Expr s BOOL -> RA s -> RA s - --- Other constructors would be added in a more robust database --- implementation. - --- An Expr is used with the Select constructor to choose some --- subset of rows from a table. Expressions are indexed by the --- schema over which they operate and the return value they --- produce. -data Expr :: Schema -> U -> * where - -- Equality among two elements - Equal :: Eq (El u) => Expr s u -> Expr s u -> Expr s BOOL - - -- A less-than comparison among two Nats - LessThan :: Expr s NAT -> Expr s NAT -> Expr s BOOL - - -- A literal number - LiteralNat :: Integer -> Expr s NAT - - -- Projection in an expression -- evaluates to the value - -- of the named attribute. - Element :: (Occurs nm s ~ True) => - SSchema s -> Sing nm -> Expr s (Lookup nm s) - - -- A more robust implementation would include more constructors - --- Retrieves the id from a row. Ids are used when computing unions and --- differences. -getId :: Row s -> [Int] -getId (EmptyRow n) = n -getId (ConsRow _ t) = getId t - --- Changes the id of a row to a new value -changeId :: [Int] -> Row s -> Row s -changeId n (EmptyRow _) = EmptyRow n -changeId n (ConsRow h t) = ConsRow h (changeId n t) - --- Equality for rows based on ids. -eqRow :: Row s -> Row s -> Bool -eqRow r1 r2 = getId r1 == getId r2 - --- Equality for attributes based on names -eqAttr :: Attribute -> Attribute -> Bool -eqAttr (Attr nm _) (Attr nm' _) = nm == nm' - --- Appends two rows. There are three suspicious case statements -- they are --- suspicious in that the different branches are all exactly identical. Here --- is why they are needed: - --- The two case statements on r are necessary to deconstruct the index in the --- type of r; GHC does not use the fact that s' must be (Sch a') for some a'. --- By doing a case analysis on r, GHC uses the types given in the different --- constructors for Row, both of which give the form of s' as (Sch a'). This --- deconstruction is necessary for the type family Append to compute, because --- Append is defined only when its second argument is of the form (Sch a'). - --- The case statement on rowAppend t r is necessary to avoid potential --- overlapping instances for the SingRep class; the instances are needed for --- the call to ConsRow. The potential for overlapping instances comes from --- ambiguity in the component types of (Append s s'). By doing case analysis --- on rowAppend t r, these variables become fixed, and the potential for --- overlapping instances disappears. - --- We use the "cases" Singletons library operation to produce the case --- analysis in the first clause. This "cases" operation produces a case --- statement where each branch is identical and each constructor parameter --- is ignored. The "cases" operation does not work for the second clause --- because the code in the clause depends on definitions generated earlier. --- Template Haskell restricts certain dependencies between auto-generated --- code blocks to prevent the possibility of circular dependencies. --- In this case, if the $(singletons ...) blocks above were in a different --- module, the "cases" operation would be applicable here. - -$( return [] ) - -rowAppend :: Row s -> Row s' -> Row (Append s s') -rowAppend (EmptyRow n) r = $(cases ''Row [| r |] - [| changeId (n ++ (getId r)) r |]) -rowAppend (ConsRow h t) r = case r of - EmptyRow _ -> - case rowAppend t r of - EmptyRow _ -> ConsRow h (rowAppend t r) - ConsRow _ _ -> ConsRow h (rowAppend t r) - ConsRow _ _ -> - case rowAppend t r of - EmptyRow _ -> ConsRow h (rowAppend t r) - ConsRow _ _ -> ConsRow h (rowAppend t r) - --- Choose the elements of one list based on truth values in another -choose :: [Bool] -> [a] -> [a] -choose [] _ = [] -choose (False : btail) (_ : t) = choose btail t -choose (True : btail) (h : t) = h : (choose btail t) -choose _ [] = [] - --- The query function is the eliminator for an RA. It returns a list of --- rows containing the data produced by the RA. -query :: forall s. SingI s => RA s -> IO [Row s] -query (Read (Handle rows)) = return rows -query (Union ra rb) = do - rowsa <- query ra - rowsb <- query rb - return $ unionBy eqRow rowsa rowsb -query (Diff ra rb) = do - rowsa <- query ra - rowsb <- query rb - return $ deleteFirstsBy eqRow rowsa rowsb -query (Product ra rb) = do - rowsa <- query ra - rowsb <- query rb - return $ do -- entering the [] Monad - rowa <- rowsa - rowb <- rowsb - return $ rowAppend rowa rowb -query (Project sch ra) = do - rows <- query ra - return $ map (projectRow sch) rows - where -- The projectRow function uses the relationship encoded in the Subset - -- relation to project the requested columns of data in a type-safe manner. - - -- It recurs on the structure of the provided schema, creating the output - -- row to be in the same order as the input schema. This is necessary for - -- the output to type-check, as it is indexed by the input schema. - - -- We use explicit quantification to get access to scoped type variables. - projectRow :: forall (sch :: Schema) (s' :: Schema). - SubsetC sch s' => SSchema sch -> Row s' -> Row sch - - -- Base case: empty schema - projectRow (SSch SNil) r = EmptyRow (getId r) - - -- In the recursive case, we need to pattern-match on the proof that - -- the provided schema is a subset of the provided RA. We extract this - -- proof (of type SubsetProof s s') from the SubsetC instance using the - -- subset method. - projectRow (SSch (SCons attr tail)) r = - case subset :: SubsetProof sch s' of - - -- Because we know that the schema is non-empty, the only possibility - -- here is SubsetCons: - SubsetCons -> - let rtail = projectRow (SSch tail) r in - case attr of - SAttr _ u -> case elUShowInstance u of - ElUShowInstance -> ConsRow (extractElt attr r) rtail - - -- GHC correctly determines that this case is impossible if it is - -- not commented. - -- SubsetEmpty -> undefined <== IMPOSSIBLE - - -- However, the current version of GHC (7.5) does not suppress warnings - -- for incomplete pattern matches when the remaining cases are impossible. - -- So, we include this case (impossible to reach for any terminated value) - -- to suppress the warning. - _ -> error "Type checking failed" - - -- Retrieves the element, looked up by the name of the provided attribute, - -- from a row. The explicit quantification is necessary to create the scoped - -- type variables to use in the return type of <> - extractElt :: forall nm u sch. InC nm u sch => - Sing (Attr nm u) -> Row sch -> El u - extractElt attr r = case inProof :: InProof (Attr nm u) sch of - InElt -> case r of - ConsRow h _ -> h - -- EmptyRow _ -> undefined <== IMPOSSIBLE - _ -> error "Type checking failed" - InTail -> case r of - ConsRow _ t -> extractElt attr t - -- EmptyRow _ -> undefined <== IMPOSSBLE - _ -> error "Type checking failed" - -query (Select expr r) = do - rows <- query r - let vals = map (eval expr) rows - return $ choose vals rows - where -- Evaluates an expression - eval :: forall s' u. SingI s' => Expr s' u -> Row s' -> El u - eval (Element _ (name :: Sing name)) row = - case row of - -- EmptyRow _ -> undefined <== IMPOSSIBLE - ConsRow h t -> case row of - (ConsRow _ _ :: Row (Sch ((Attr name' u') ': attrs))) -> - case sing :: Sing s' of - -- SSch SNil -> undefined <== IMPOSSIBLE - SSch (SCons (SAttr name' _) stail) -> - case name %:== name' of - STrue -> h - SFalse -> withSingI stail (eval (Element (SSch stail) name) t) - _ -> bugInGHC - _ -> bugInGHC - - eval (Equal (e1 :: Expr s' u') e2) row = - let v1 = eval e1 row - v2 = eval e2 row in - v1 == v2 - - -- Note that the types really help us here: the LessThan constructor is - -- defined only over Expr s NAT, so we know that evaluating e1 and e2 will - -- yield Nats, which are a member of the Ord type class. - eval (LessThan e1 e2) row = - let v1 = eval e1 row - v2 = eval e2 row in - v1 < v2 - - eval (LiteralNat x) _ = toNat x diff --git a/tests/compile-and-dump/GradingClient/Main.ghc76.template b/tests/compile-and-dump/GradingClient/Main.ghc76.template deleted file mode 100644 --- a/tests/compile-and-dump/GradingClient/Main.ghc76.template +++ /dev/null @@ -1,75 +0,0 @@ -GradingClient/Main.hs:0:0: Splicing declarations - singletons - [d| lastName, majorName, gradeName, yearName, firstName :: [AChar] - lastName = [CL, CA, CS, CT] - firstName = [CF, CI, CR, CS, CT] - yearName = [CY, CE, CA, CR] - gradeName = [CG, CR, CA, CD, CE] - majorName = [CM, CA, CJ, CO, CR] - gradingSchema :: Schema - gradingSchema - = Sch - [Attr lastName STRING, Attr firstName STRING, Attr yearName NAT, - Attr gradeName NAT, Attr majorName BOOL] - names :: Schema - names = Sch [Attr firstName STRING, Attr lastName STRING] |] - ======> - GradingClient/Main.hs:(0,0)-(0,0) - lastName :: [AChar] - majorName :: [AChar] - gradeName :: [AChar] - yearName :: [AChar] - firstName :: [AChar] - lastName = [CL, CA, CS, CT] - firstName = [CF, CI, CR, CS, CT] - yearName = [CY, CE, CA, CR] - gradeName = [CG, CR, CA, CD, CE] - majorName = [CM, CA, CJ, CO, CR] - gradingSchema :: Schema - gradingSchema - = Sch - [Attr lastName STRING, Attr firstName STRING, Attr yearName NAT, - Attr gradeName NAT, Attr majorName BOOL] - names :: Schema - names = Sch [Attr firstName STRING, Attr lastName STRING] - type LastName = '[CL, CA, CS, CT] - type FirstName = '[CF, CI, CR, CS, CT] - type YearName = '[CY, CE, CA, CR] - type GradeName = '[CG, CR, CA, CD, CE] - type MajorName = '[CM, CA, CJ, CO, CR] - type GradingSchema = - Sch '[Attr LastName STRING, - Attr FirstName STRING, - Attr YearName NAT, - Attr GradeName NAT, - Attr MajorName BOOL] - type Names = Sch '[Attr FirstName STRING, Attr LastName STRING] - sLastName :: Sing LastName - sMajorName :: Sing MajorName - sGradeName :: Sing GradeName - sYearName :: Sing YearName - sFirstName :: Sing FirstName - sLastName = SCons SCL (SCons SCA (SCons SCS (SCons SCT SNil))) - sFirstName - = SCons SCF (SCons SCI (SCons SCR (SCons SCS (SCons SCT SNil)))) - sYearName = SCons SCY (SCons SCE (SCons SCA (SCons SCR SNil))) - sGradeName - = SCons SCG (SCons SCR (SCons SCA (SCons SCD (SCons SCE SNil)))) - sMajorName - = SCons SCM (SCons SCA (SCons SCJ (SCons SCO (SCons SCR SNil)))) - sGradingSchema :: Sing GradingSchema - sGradingSchema - = SSch - (SCons - (SAttr sLastName SSTRING) - (SCons - (SAttr sFirstName SSTRING) - (SCons - (SAttr sYearName SNAT) - (SCons - (SAttr sGradeName SNAT) (SCons (SAttr sMajorName SBOOL) SNil))))) - sNames :: Sing Names - sNames - = SSch - (SCons - (SAttr sFirstName SSTRING) (SCons (SAttr sLastName SSTRING) SNil)) diff --git a/tests/compile-and-dump/GradingClient/Main.ghc78.template b/tests/compile-and-dump/GradingClient/Main.ghc78.template deleted file mode 100644 --- a/tests/compile-and-dump/GradingClient/Main.ghc78.template +++ /dev/null @@ -1,75 +0,0 @@ -GradingClient/Main.hs:0:0: Splicing declarations - singletons - [d| lastName, majorName, gradeName, yearName, firstName :: [AChar] - lastName = [CL, CA, CS, CT] - firstName = [CF, CI, CR, CS, CT] - yearName = [CY, CE, CA, CR] - gradeName = [CG, CR, CA, CD, CE] - majorName = [CM, CA, CJ, CO, CR] - gradingSchema :: Schema - gradingSchema - = Sch - [Attr lastName STRING, Attr firstName STRING, Attr yearName NAT, - Attr gradeName NAT, Attr majorName BOOL] - names :: Schema - names = Sch [Attr firstName STRING, Attr lastName STRING] |] - ======> - GradingClient/Main.hs:(0,0)-(0,0) - lastName :: [AChar] - majorName :: [AChar] - gradeName :: [AChar] - yearName :: [AChar] - firstName :: [AChar] - lastName = [CL, CA, CS, CT] - firstName = [CF, CI, CR, CS, CT] - yearName = [CY, CE, CA, CR] - gradeName = [CG, CR, CA, CD, CE] - majorName = [CM, CA, CJ, CO, CR] - gradingSchema :: Schema - gradingSchema - = Sch - [Attr lastName STRING, Attr firstName STRING, Attr yearName NAT, - Attr gradeName NAT, Attr majorName BOOL] - names :: Schema - names = Sch [Attr firstName STRING, Attr lastName STRING] - type LastName = '[CL, CA, CS, CT] - type FirstName = '[CF, CI, CR, CS, CT] - type YearName = '[CY, CE, CA, CR] - type GradeName = '[CG, CR, CA, CD, CE] - type MajorName = '[CM, CA, CJ, CO, CR] - type GradingSchema = - Sch '[Attr LastName STRING, - Attr FirstName STRING, - Attr YearName NAT, - Attr GradeName NAT, - Attr MajorName BOOL] - type Names = Sch '[Attr FirstName STRING, Attr LastName STRING] - sLastName :: Sing LastName - sMajorName :: Sing MajorName - sGradeName :: Sing GradeName - sYearName :: Sing YearName - sFirstName :: Sing FirstName - sLastName = SCons SCL (SCons SCA (SCons SCS (SCons SCT SNil))) - sFirstName - = SCons SCF (SCons SCI (SCons SCR (SCons SCS (SCons SCT SNil)))) - sYearName = SCons SCY (SCons SCE (SCons SCA (SCons SCR SNil))) - sGradeName - = SCons SCG (SCons SCR (SCons SCA (SCons SCD (SCons SCE SNil)))) - sMajorName - = SCons SCM (SCons SCA (SCons SCJ (SCons SCO (SCons SCR SNil)))) - sGradingSchema :: Sing GradingSchema - sGradingSchema - = SSch - (SCons - (SAttr sLastName SSTRING) - (SCons - (SAttr sFirstName SSTRING) - (SCons - (SAttr sYearName SNAT) - (SCons - (SAttr sGradeName SNAT) (SCons (SAttr sMajorName SBOOL) SNil))))) - sNames :: Sing Names - sNames - = SSch - (SCons - (SAttr sFirstName SSTRING) (SCons (SAttr sLastName SSTRING) SNil)) diff --git a/tests/compile-and-dump/GradingClient/Main.hs b/tests/compile-and-dump/GradingClient/Main.hs deleted file mode 100644 --- a/tests/compile-and-dump/GradingClient/Main.hs +++ /dev/null @@ -1,53 +0,0 @@ -{- GradingClient.hs - -(c) Richard Eisenberg 2012 -eir@cis.upenn.edu - -This file accesses the database described in Database.hs and performs -some basic queries on it. - --} - -{-# LANGUAGE TemplateHaskell, DataKinds #-} - -module Main where - -import Data.Singletons.TH -import Data.Singletons.List -import GradingClient.Database - -$(singletons [d| - lastName, firstName, yearName, gradeName, majorName :: [AChar] - lastName = [CL, CA, CS, CT] - firstName = [CF, CI, CR, CS, CT] - yearName = [CY, CE, CA, CR] - gradeName = [CG, CR, CA, CD, CE] - majorName = [CM, CA, CJ, CO, CR] - - gradingSchema :: Schema - gradingSchema = Sch [Attr lastName STRING, - Attr firstName STRING, - Attr yearName NAT, - Attr gradeName NAT, - Attr majorName BOOL] - - names :: Schema - names = Sch [Attr firstName STRING, - Attr lastName STRING] - |]) - -main :: IO () -main = do - h <- connect "grades" sGradingSchema - let ra = Read h - - allStudents <- query $ Project sNames ra - putStrLn $ "Names of all students: " ++ (show allStudents) ++ "\n" - - majors <- query $ Select (Element sGradingSchema sMajorName) ra - putStrLn $ "Students in major: " ++ (show majors) ++ "\n" - - b_students <- - query $ Project sNames $ - Select (LessThan (Element sGradingSchema sGradeName) (LiteralNat 90)) ra - putStrLn $ "Names of students with grade < 90: " ++ (show b_students) ++ "\n" diff --git a/tests/compile-and-dump/InsertionSort/InsertionSortImp.ghc76.template b/tests/compile-and-dump/InsertionSort/InsertionSortImp.ghc76.template deleted file mode 100644 --- a/tests/compile-and-dump/InsertionSort/InsertionSortImp.ghc76.template +++ /dev/null @@ -1,77 +0,0 @@ -InsertionSort/InsertionSortImp.hs:0:0: Splicing declarations - singletons [d| data Nat = Zero | Succ Nat |] - ======> - InsertionSort/InsertionSortImp.hs:(0,0)-(0,0) - data Nat = Zero | Succ Nat - data instance Sing (z :: Nat) - = z ~ Zero => SZero | - forall (n :: Nat). z ~ Succ n => SSucc (Sing n) - type SNat (z :: Nat) = Sing z - instance SingKind (KProxy :: KProxy Nat) where - type instance DemoteRep (KProxy :: KProxy Nat) = Nat - fromSing SZero = Zero - fromSing (SSucc b) = Succ (fromSing b) - toSing Zero = SomeSing SZero - toSing (Succ b) - = case toSing b :: SomeSing (KProxy :: KProxy Nat) of { - SomeSing c -> SomeSing (SSucc c) } - instance SingI Zero where - sing = SZero - instance SingI n => SingI (Succ (n :: Nat)) where - sing = SSucc sing -InsertionSort/InsertionSortImp.hs:0:0: Splicing declarations - singletons - [d| leq :: Nat -> Nat -> Bool - leq Zero _ = True - leq (Succ _) Zero = False - leq (Succ a) (Succ b) = leq a b - insert :: Nat -> [Nat] -> [Nat] - insert n [] = [n] - insert n (h : t) - = if leq n h then (n : h : t) else h : (insert n t) - insertionSort :: [Nat] -> [Nat] - insertionSort [] = [] - insertionSort (h : t) = insert h (insertionSort t) |] - ======> - InsertionSort/InsertionSortImp.hs:(0,0)-(0,0) - leq :: Nat -> Nat -> Bool - leq Zero _ = True - leq (Succ _) Zero = False - leq (Succ a) (Succ b) = leq a b - insert :: Nat -> [Nat] -> [Nat] - insert n GHC.Types.[] = [n] - insert n (h GHC.Types.: t) - = if leq n h then - (n GHC.Types.: (h GHC.Types.: t)) - else - (h GHC.Types.: (insert n t)) - insertionSort :: [Nat] -> [Nat] - insertionSort GHC.Types.[] = GHC.Types.[] - insertionSort (h GHC.Types.: t) = insert h (insertionSort t) - type instance Leq Zero z = True - type instance Leq (Succ z) Zero = False - type instance Leq (Succ a) (Succ b) = Leq a b - type instance Insert n GHC.Types.[] = '[n] - type instance Insert n (GHC.Types.: h t) = - If (Leq n h) (GHC.Types.: n (GHC.Types.: h t)) (GHC.Types.: h (Insert n t)) - type instance InsertionSort GHC.Types.[] = GHC.Types.[] - type instance InsertionSort (GHC.Types.: h t) = - Insert h (InsertionSort t) - type family Leq (a :: Nat) (a :: Nat) :: Bool - type family Insert (a :: Nat) (a :: [Nat]) :: [Nat] - type family InsertionSort (a :: [Nat]) :: [Nat] - sLeq :: - forall (t :: Nat) (t :: Nat). Sing t -> Sing t -> Sing (Leq t t) - sLeq SZero _ = STrue - sLeq (SSucc _) SZero = SFalse - sLeq (SSucc a) (SSucc b) = sLeq a b - sInsert :: - forall (t :: Nat) (t :: [Nat]). - Sing t -> Sing t -> Sing (Insert t t) - sInsert n SNil = SCons n SNil - sInsert n (SCons h t) - = sIf (sLeq n h) (SCons n (SCons h t)) (SCons h (sInsert n t)) - sInsertionSort :: - forall (t :: [Nat]). Sing t -> Sing (InsertionSort t) - sInsertionSort SNil = SNil - sInsertionSort (SCons h t) = sInsert h (sInsertionSort t) diff --git a/tests/compile-and-dump/InsertionSort/InsertionSortImp.ghc78.template b/tests/compile-and-dump/InsertionSort/InsertionSortImp.ghc78.template deleted file mode 100644 --- a/tests/compile-and-dump/InsertionSort/InsertionSortImp.ghc78.template +++ /dev/null @@ -1,75 +0,0 @@ -InsertionSort/InsertionSortImp.hs:0:0: Splicing declarations - singletons [d| data Nat = Zero | Succ Nat |] - ======> - InsertionSort/InsertionSortImp.hs:(0,0)-(0,0) - data Nat = Zero | Succ Nat - data instance Sing (z :: Nat) - = z ~ Zero => SZero | - forall (n :: Nat). z ~ Succ n => SSucc (Sing n) - type SNat (z :: Nat) = Sing z - instance SingKind (KProxy :: KProxy Nat) where - type DemoteRep (KProxy :: KProxy Nat) = Nat - fromSing SZero = Zero - fromSing (SSucc b) = Succ (fromSing b) - toSing Zero = SomeSing SZero - toSing (Succ b) - = case toSing b :: SomeSing (KProxy :: KProxy Nat) of { - SomeSing c -> SomeSing (SSucc c) } - instance SingI Zero where - sing = SZero - instance SingI n => SingI (Succ (n :: Nat)) where - sing = SSucc sing -InsertionSort/InsertionSortImp.hs:0:0: Splicing declarations - singletons - [d| leq :: Nat -> Nat -> Bool - leq Zero _ = True - leq (Succ _) Zero = False - leq (Succ a) (Succ b) = leq a b - insert :: Nat -> [Nat] -> [Nat] - insert n [] = [n] - insert n (h : t) - = if leq n h then (n : h : t) else h : (insert n t) - insertionSort :: [Nat] -> [Nat] - insertionSort [] = [] - insertionSort (h : t) = insert h (insertionSort t) |] - ======> - InsertionSort/InsertionSortImp.hs:(0,0)-(0,0) - leq :: Nat -> Nat -> Bool - leq Zero _ = True - leq (Succ _) Zero = False - leq (Succ a) (Succ b) = leq a b - insert :: Nat -> [Nat] -> [Nat] - insert n GHC.Types.[] = [n] - insert n (h GHC.Types.: t) - = if leq n h then - (n GHC.Types.: (h GHC.Types.: t)) - else - (h GHC.Types.: (insert n t)) - insertionSort :: [Nat] -> [Nat] - insertionSort GHC.Types.[] = [] - insertionSort (h GHC.Types.: t) = insert h (insertionSort t) - type family Leq (a :: Nat) (a :: Nat) :: Bool where - Leq Zero z = True - Leq (Succ z) Zero = False - Leq (Succ a) (Succ b) = Leq a b - type family Insert (a :: Nat) (a :: [Nat]) :: [Nat] where - Insert n GHC.Types.[] = '[n] - Insert n ((GHC.Types.:) h t) = If (Leq n h) ((GHC.Types.:) n ((GHC.Types.:) h t)) ((GHC.Types.:) h (Insert n t)) - type family InsertionSort (a :: [Nat]) :: [Nat] where - InsertionSort GHC.Types.[] = '[] - InsertionSort ((GHC.Types.:) h t) = Insert h (InsertionSort t) - sLeq :: - forall (t :: Nat) (t :: Nat). Sing t -> Sing t -> Sing (Leq t t) - sLeq SZero _ = STrue - sLeq (SSucc _) SZero = SFalse - sLeq (SSucc a) (SSucc b) = sLeq a b - sInsert :: - forall (t :: Nat) (t :: [Nat]). - Sing t -> Sing t -> Sing (Insert t t) - sInsert n SNil = SCons n SNil - sInsert n (SCons h t) - = sIf (sLeq n h) (SCons n (SCons h t)) (SCons h (sInsert n t)) - sInsertionSort :: - forall (t :: [Nat]). Sing t -> Sing (InsertionSort t) - sInsertionSort SNil = SNil - sInsertionSort (SCons h t) = sInsert h (sInsertionSort t) diff --git a/tests/compile-and-dump/InsertionSort/InsertionSortImp.hs b/tests/compile-and-dump/InsertionSort/InsertionSortImp.hs deleted file mode 100644 --- a/tests/compile-and-dump/InsertionSort/InsertionSortImp.hs +++ /dev/null @@ -1,206 +0,0 @@ -{- InsertionSortImp.hs - -(c) Richard Eisenberg 2012 -eir@cis.upenn.edu - -This file contains an implementation of insertion sort over natural numbers, -along with a Haskell proof that the sort algorithm is correct. The code below -uses a combination of GADTs and class instances to record the progress and -result of the proof. - -Ideally, the GADTs would be defined so that the constructors take no explicit -parameters --- the information would all be encoded in the constraints to the -constructors. However, due to the nature of the permutation relation, a class -instance definition corresponding to the constructor PermIns would require -existentially-quantified type variables (the l2 variable in the declaration of -PermIns). Type variables in an instance constraint but not mentioned in the -instance head are inherently ambiguous. The compiler would never be able to -infer the value of the variables. Thus, it is not possible to make a class -PermutationC analogous to PermutationProof in the way that AscendingC is -analogous to AscendingProof. (Note that it may be possible to fundamentally -rewrite the inductive definition of the permutation relation to avoid -existentially-quantified variables. We have not attempted that here.) - -If there were a way to offer an explicit dictionary when satisfying a constraint, -this problem could be avoided, as the variable in question could be made -unambiguous. - --} - -{-# LANGUAGE IncoherentInstances #-} - -module InsertionSort.InsertionSortImp where - -import Data.Singletons.TH -import Data.Singletons.Prelude - --- We use the Dict data type from Edward Kmett's constraints package to be --- able to return dictionaries from functions -import Data.Constraint - --- Natural numbers, defined with singleton counterparts -$(singletons [d| - data Nat = Zero | Succ Nat - |]) - --- convenience functions for testing purposes -toNat :: Int -> Nat -toNat 0 = Zero -toNat n | n > 0 = Succ (toNat (n - 1)) -toNat _ = error "Converting negative to Nat" - -fromNat :: Nat -> Int -fromNat Zero = 0 -fromNat (Succ n) = 1 + (fromNat n) - --- A less-than-or-equal relation among naturals -class (a :: Nat) :<=: (b :: Nat) -instance Zero :<=: a -instance (a :<=: b) => (Succ a) :<=: (Succ b) - --- A proof term asserting that a list of naturals is in ascending order -data AscendingProof :: [Nat] -> * where - AscEmpty :: AscendingProof '[] - AscOne :: AscendingProof '[n] - AscCons :: (a :<=: b, AscendingC (b ': rest)) => AscendingProof (a ': b ': rest) - --- The class constraint (implicit parameter definition) corresponding to --- AscendingProof -class AscendingC (lst :: [Nat]) where - ascendingProof :: AscendingProof lst - --- The instances correspond to the constructors of AscendingProof -instance AscendingC '[] where - ascendingProof = AscEmpty -instance AscendingC '[n] where - ascendingProof = AscOne -instance (a :<=: b, AscendingC (b ': rest)) => AscendingC (a ': b ': rest) where - ascendingProof = AscCons - --- A proof term asserting that l2 is the list produced when x is inserted --- (anywhere) into list l1 -data InsertionProof (x :: k) (l1 :: [k]) (l2 :: [k]) where - InsHere :: InsertionProof x l (x ': l) - InsLater :: InsertionC x l1 l2 => InsertionProof x (y ': l1) (y ': l2) - --- The class constraint corresponding to InsertionProof -class InsertionC (x :: k) (l1 :: [k]) (l2 :: [k]) where - insertionProof :: InsertionProof x l1 l2 - -instance InsertionC x l (x ': l) where - insertionProof = InsHere -instance InsertionC x l1 l2 => InsertionC x (y ': l1) (y ': l2) where - insertionProof = InsLater - --- A proof term asserting that l1 and l2 are permutations of each other -data PermutationProof (l1 :: [k]) (l2 :: [k]) where - PermId :: PermutationProof l l - PermIns :: InsertionC x l2 l2' => PermutationProof l1 l2 -> - PermutationProof (x ': l1) l2' - --- Here is the definition of insertion sort about which we will be reasoning: -$(singletons [d| - leq :: Nat -> Nat -> Bool - leq Zero _ = True - leq (Succ _) Zero = False - leq (Succ a) (Succ b) = leq a b - - insert :: Nat -> [Nat] -> [Nat] - insert n [] = [n] - insert n (h:t) = if leq n h then (n:h:t) else h:(insert n t) - - insertionSort :: [Nat] -> [Nat] - insertionSort [] = [] - insertionSort (h:t) = insert h (insertionSort t) - |]) - --- A lemma that states if sLeq a b is STrue, then (a :<=: b) --- This is necessary to convert from the boolean definition of <= to the --- corresponding constraint -sLeq_true__le :: (Leq a b ~ True) => SNat a -> SNat b -> Dict (a :<=: b) -sLeq_true__le a b = case (a, b) of - (SZero, SZero) -> Dict - (SZero, SSucc _) -> Dict - -- (SSucc _, SZero) -> undefined <== IMPOSSIBLE - (SSucc a', SSucc b') -> case sLeq_true__le a' b' of - Dict -> Dict - _ -> error "type checking failed" - --- A lemma that states if sLeq a b is SFalse, then (b :<=: a) -sLeq_false__nle :: (Leq a b ~ False) => SNat a -> SNat b -> Dict (b :<=: a) -sLeq_false__nle a b = case (a, b) of - -- (SZero, SZero) -> undefined <== IMPOSSIBLE - -- (SZero, SSucc _) -> undefined <== IMPOSSIBLE - (SSucc _, SZero) -> Dict - (SSucc a', SSucc b') -> case sLeq_false__nle a' b' of - Dict -> Dict - _ -> error "type checking failed" - --- A lemma that states that inserting into an ascending list produces an --- ascending list -insert_ascending :: forall n lst. - AscendingC lst => SNat n -> SList lst -> Dict (AscendingC (Insert n lst)) -insert_ascending n lst = - case ascendingProof :: AscendingProof lst of - AscEmpty -> Dict -- If lst is empty, then we're done - AscOne -> case lst of -- If lst has one element... - -- SNil -> undefined <== IMPOSSIBLE - SCons h _ -> case sLeq n h of -- then check if n is <= h - STrue -> case sLeq_true__le n h of Dict -> Dict -- if so, we're done - SFalse -> case sLeq_false__nle n h of Dict -> Dict -- if not, we're done - _ -> error "type checking failed" - AscCons -> case lst of -- Otherwise, if lst is more than one element... - -- SNil -> undefined <== IMPOSSIBLE - SCons h t -> case sLeq n h of -- then check if n is <= h - STrue -> case sLeq_true__le n h of Dict -> Dict -- if so, we're done - SFalse -> case sLeq_false__nle n h of -- if not, things are harder... - Dict -> case t of -- destruct t: lst is (h : h2 : t2) - -- SNil -> undefined <== IMPOSSIBLE - SCons h2 _ -> case sLeq n h2 of -- is n <= h2? - STrue -> -- if so, we're done - case sLeq_true__le n h2 of Dict -> Dict - SFalse -> -- otherwise, show that (Insert n t) is sorted - case insert_ascending n t of Dict -> Dict -- and we're done - _ -> error "type checking failed" - _ -> error "type checking failed" - --- A lemma that states that inserting n into lst produces a new list with n --- inserted into lst. -insert_insertion :: SNat n -> SList lst -> Dict (InsertionC n lst (Insert n lst)) -insert_insertion n lst = - case lst of - SNil -> Dict -- if lst is empty, we're done - SCons h t -> case sLeq n h of -- otherwise, is n <= h? - STrue -> Dict -- if so, we're done - SFalse -> case insert_insertion n t of Dict -> Dict -- otherwise, recur - --- A lemma that states that the result of an insertion sort is in ascending order -insertionSort_ascending :: SList lst -> Dict (AscendingC (InsertionSort lst)) -insertionSort_ascending lst = case lst of - SNil -> Dict -- if the list is empty, we're done - - -- otherwise, we recur to find that insertionSort on t produces an ascending list, - -- and then we use the fact that inserting into an ascending list produces an - -- ascending list - SCons h t -> case insertionSort_ascending t of - Dict -> case insert_ascending h (sInsertionSort t) of Dict -> Dict - --- A lemma that states that the result of an insertion sort is a permutation --- of its input -insertionSort_permutes :: SList lst -> PermutationProof lst (InsertionSort lst) -insertionSort_permutes lst = case lst of - SNil -> PermId -- if the list is empty, we're done - - -- otherwise, we wish to use PermIns. We must know that t is a permutation of - -- the insertion sort of t and that inserting h into the insertion sort of t - -- works correctly: - SCons h t -> - case insert_insertion h (sInsertionSort t) of - Dict -> PermIns (insertionSort_permutes t) - --- A theorem that states that the insertion sort of a list is both ascending --- and a permutation of the original -insertionSort_correct :: SList lst -> (Dict (AscendingC (InsertionSort lst)), - PermutationProof lst (InsertionSort lst)) -insertionSort_correct lst = (insertionSort_ascending lst, - insertionSort_permutes lst) diff --git a/tests/compile-and-dump/Promote/NumArgs.ghc76.template b/tests/compile-and-dump/Promote/NumArgs.ghc76.template deleted file mode 100644 --- a/tests/compile-and-dump/Promote/NumArgs.ghc76.template +++ /dev/null @@ -1,10 +0,0 @@ -Promote/NumArgs.hs:0:0: Splicing declarations - promote - [d| returnFunc :: Nat -> Nat -> Nat - returnFunc _ = Succ |] - ======> - Promote/NumArgs.hs:(0,0)-(0,0) - returnFunc :: Nat -> Nat -> Nat - returnFunc _ = Succ - type instance ReturnFunc z = Succ - type family ReturnFunc (a :: Nat) :: Nat -> Nat diff --git a/tests/compile-and-dump/Promote/NumArgs.ghc78.template b/tests/compile-and-dump/Promote/NumArgs.ghc78.template deleted file mode 100644 --- a/tests/compile-and-dump/Promote/NumArgs.ghc78.template +++ /dev/null @@ -1,10 +0,0 @@ -Promote/NumArgs.hs:0:0: Splicing declarations - promote - [d| returnFunc :: Nat -> Nat -> Nat - returnFunc _ = Succ |] - ======> - Promote/NumArgs.hs:(0,0)-(0,0) - returnFunc :: Nat -> Nat -> Nat - returnFunc _ = Succ - type family ReturnFunc (a :: Nat) :: Nat -> Nat where - ReturnFunc z = Succ diff --git a/tests/compile-and-dump/Promote/NumArgs.hs b/tests/compile-and-dump/Promote/NumArgs.hs deleted file mode 100644 --- a/tests/compile-and-dump/Promote/NumArgs.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Promote.NumArgs where - -import Data.Singletons.TH -import Singletons.Nat - --- used to test the "num args" feature of promoteDec --- remove this test once eta-expansion is implemented - -$(promote [d| - returnFunc :: Nat -> Nat -> Nat - returnFunc _ = Succ - |]) diff --git a/tests/compile-and-dump/Promote/PatternMatching.ghc76.template b/tests/compile-and-dump/Promote/PatternMatching.ghc76.template deleted file mode 100644 --- a/tests/compile-and-dump/Promote/PatternMatching.ghc76.template +++ /dev/null @@ -1,65 +0,0 @@ -Promote/PatternMatching.hs:0:0: Splicing declarations - promote - [d| pr = Pair (Succ Zero) ([Zero]) - complex = Pair (Pair (Just Zero) Zero) False - tuple = (False, Just Zero, True) - aList = [Zero, Succ Zero, Succ (Succ Zero)] - - data Pair a b - = Pair a b - deriving (Show) |] - ======> - Promote/PatternMatching.hs:(0,0)-(0,0) - data Pair a b - = Pair a b - deriving (Show) - pr = Pair (Succ Zero) [Zero] - complex = Pair (Pair (Just Zero) Zero) False - tuple = (False, Just Zero, True) - aList = [Zero, Succ Zero, Succ (Succ Zero)] - type Pr = Pair (Succ Zero) '[Zero] - type Complex = Pair (Pair (Just Zero) Zero) False - type Tuple = '(False, Just Zero, True) - type AList = '[Zero, Succ Zero, Succ (Succ Zero)] -Promote/PatternMatching.hs:0:0: Splicing declarations - promote - [d| Pair sz lz = pr - Pair (Pair jz zz) fls = complex - (tf, tjz, tt) = tuple - [_, lsz, (Succ blimy)] = aList |] - ======> - Promote/PatternMatching.hs:(0,0)-(0,0) - Pair sz lz = pr - Pair (Pair jz zz) fls = complex - (tf, tjz, tt) = tuple - [_, lsz, Succ blimy] = aList - type Sz = Extract_0123456789 Pr - type Lz = Extract_0123456789 Pr - type family Extract_0123456789 (a :: Pair a b) :: a - type family Extract_0123456789 (a :: Pair a b) :: b - type instance Extract_0123456789 (Pair a a) = a - type instance Extract_0123456789 (Pair a a) = a - type Jz = Extract_0123456789 (Extract_0123456789 Complex) - type Zz = Extract_0123456789 (Extract_0123456789 Complex) - type Fls = Extract_0123456789 Complex - type family Extract_0123456789 (a :: Pair a b) :: a - type family Extract_0123456789 (a :: Pair a b) :: b - type instance Extract_0123456789 (Pair a a) = a - type instance Extract_0123456789 (Pair a a) = a - type family Extract_0123456789 (a :: Pair a b) :: a - type family Extract_0123456789 (a :: Pair a b) :: b - type instance Extract_0123456789 (Pair a a) = a - type instance Extract_0123456789 (Pair a a) = a - type Tf = Extract_0123456789 Tuple - type Tjz = Extract_0123456789 Tuple - type Tt = Extract_0123456789 Tuple - type family Extract_0123456789 (a :: GHC.Tuple.(,,) a b c) :: a - type family Extract_0123456789 (a :: GHC.Tuple.(,,) a b c) :: b - type family Extract_0123456789 (a :: GHC.Tuple.(,,) a b c) :: c - type instance Extract_0123456789 (GHC.Tuple.(,,) a a a) = a - type instance Extract_0123456789 (GHC.Tuple.(,,) a a a) = a - type instance Extract_0123456789 (GHC.Tuple.(,,) a a a) = a - type Lsz = Head (Tail AList) - type Blimy = Extract_0123456789 (Head (Tail (Tail AList))) - type family Extract_0123456789 (a :: Nat) :: Nat - type instance Extract_0123456789 (Succ a) = a diff --git a/tests/compile-and-dump/Promote/PatternMatching.ghc78.template b/tests/compile-and-dump/Promote/PatternMatching.ghc78.template deleted file mode 100644 --- a/tests/compile-and-dump/Promote/PatternMatching.ghc78.template +++ /dev/null @@ -1,65 +0,0 @@ -Promote/PatternMatching.hs:0:0: Splicing declarations - promote - [d| pr = Pair (Succ Zero) ([Zero]) - complex = Pair (Pair (Just Zero) Zero) False - tuple = (False, Just Zero, True) - aList = [Zero, Succ Zero, Succ (Succ Zero)] - - data Pair a b - = Pair a b - deriving (Show) |] - ======> - Promote/PatternMatching.hs:(0,0)-(0,0) - data Pair a b - = Pair a b - deriving (Show) - pr = Pair (Succ Zero) [Zero] - complex = Pair (Pair (Just Zero) Zero) False - tuple = (False, Just Zero, True) - aList = [Zero, Succ Zero, Succ (Succ Zero)] - type Pr = Pair (Succ Zero) '[Zero] - type Complex = Pair (Pair (Just Zero) Zero) False - type Tuple = '(False, Just Zero, True) - type AList = '[Zero, Succ Zero, Succ (Succ Zero)] -Promote/PatternMatching.hs:0:0: Splicing declarations - promote - [d| Pair sz lz = pr - Pair (Pair jz zz) fls = complex - (tf, tjz, tt) = tuple - [_, lsz, (Succ blimy)] = aList |] - ======> - Promote/PatternMatching.hs:(0,0)-(0,0) - Pair sz lz = pr - Pair (Pair jz zz) fls = complex - (tf, tjz, tt) = tuple - [_, lsz, Succ blimy] = aList - type Sz = Extract_0123456789 Pr - type Lz = Extract_0123456789 Pr - type family Extract_0123456789 (a :: Pair a b) :: a - type family Extract_0123456789 (a :: Pair a b) :: b - type instance Extract_0123456789 (Pair a a) = a - type instance Extract_0123456789 (Pair a a) = a - type Jz = Extract_0123456789 (Extract_0123456789 Complex) - type Zz = Extract_0123456789 (Extract_0123456789 Complex) - type Fls = Extract_0123456789 Complex - type family Extract_0123456789 (a :: Pair a b) :: a - type family Extract_0123456789 (a :: Pair a b) :: b - type instance Extract_0123456789 (Pair a a) = a - type instance Extract_0123456789 (Pair a a) = a - type family Extract_0123456789 (a :: Pair a b) :: a - type family Extract_0123456789 (a :: Pair a b) :: b - type instance Extract_0123456789 (Pair a a) = a - type instance Extract_0123456789 (Pair a a) = a - type Tf = Extract_0123456789 Tuple - type Tjz = Extract_0123456789 Tuple - type Tt = Extract_0123456789 Tuple - type family Extract_0123456789 (a :: GHC.Tuple.(,,) a b c) :: a - type family Extract_0123456789 (a :: GHC.Tuple.(,,) a b c) :: b - type family Extract_0123456789 (a :: GHC.Tuple.(,,) a b c) :: c - type instance Extract_0123456789 (GHC.Tuple.(,,) a a a) = a - type instance Extract_0123456789 (GHC.Tuple.(,,) a a a) = a - type instance Extract_0123456789 (GHC.Tuple.(,,) a a a) = a - type Lsz = Head (Tail AList) - type Blimy = Extract_0123456789 (Head (Tail (Tail AList))) - type family Extract_0123456789 (a :: Nat) :: Nat - type instance Extract_0123456789 (Succ a) = a diff --git a/tests/compile-and-dump/Promote/PatternMatching.hs b/tests/compile-and-dump/Promote/PatternMatching.hs deleted file mode 100644 --- a/tests/compile-and-dump/Promote/PatternMatching.hs +++ /dev/null @@ -1,20 +0,0 @@ -module Promote.PatternMatching where - -import Data.Singletons.TH -import Data.Singletons.Prelude -import Singletons.Nat - -$(promote [d| - data Pair a b = Pair a b deriving Show - pr = Pair (Succ Zero) ([Zero]) - complex = Pair (Pair (Just Zero) Zero) False - tuple = (False, Just Zero, True) - aList = [Zero, Succ Zero, Succ (Succ Zero)] - |]) - -$(promote [d| - Pair sz lz = pr - Pair (Pair jz zz) fls = complex - (tf, tjz, tt) = tuple - [_, lsz, (Succ blimy)] = aList - |]) diff --git a/tests/compile-and-dump/Singletons/AtPattern.ghc76.template b/tests/compile-and-dump/Singletons/AtPattern.ghc76.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/AtPattern.ghc76.template +++ /dev/null @@ -1,16 +0,0 @@ -Singletons/AtPattern.hs:0:0: Splicing declarations - singletons - [d| maybePlus :: Maybe Nat -> Maybe Nat - maybePlus (Just n) = Just (plus (Succ Zero) n) - maybePlus foo@Nothing = foo |] - ======> - Singletons/AtPattern.hs:(0,0)-(0,0) - maybePlus :: Maybe Nat -> Maybe Nat - maybePlus (Just n) = Just (plus (Succ Zero) n) - maybePlus foo@Nothing = foo - type instance MaybePlus (Just n) = Just (Plus (Succ Zero) n) - type instance MaybePlus Nothing = Nothing - type family MaybePlus (a :: Maybe Nat) :: Maybe Nat - sMaybePlus :: forall (t :: Maybe Nat). Sing t -> Sing (MaybePlus t) - sMaybePlus (SJust n) = SJust (sPlus (SSucc SZero) n) - sMaybePlus foo@SNothing = foo diff --git a/tests/compile-and-dump/Singletons/AtPattern.ghc78.template b/tests/compile-and-dump/Singletons/AtPattern.ghc78.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/AtPattern.ghc78.template +++ /dev/null @@ -1,16 +0,0 @@ -Singletons/AtPattern.hs:0:0: Splicing declarations - singletons - [d| maybePlus :: Maybe Nat -> Maybe Nat - maybePlus (Just n) = Just (plus (Succ Zero) n) - maybePlus foo@Nothing = foo |] - ======> - Singletons/AtPattern.hs:(0,0)-(0,0) - maybePlus :: Maybe Nat -> Maybe Nat - maybePlus (Just n) = Just (plus (Succ Zero) n) - maybePlus foo@Nothing = foo - type family MaybePlus (a :: Maybe Nat) :: Maybe Nat where - MaybePlus (Just n) = Just (Plus (Succ Zero) n) - MaybePlus Nothing = Nothing - sMaybePlus :: forall (t :: Maybe Nat). Sing t -> Sing (MaybePlus t) - sMaybePlus (SJust n) = SJust (sPlus (SSucc SZero) n) - sMaybePlus foo@SNothing = foo diff --git a/tests/compile-and-dump/Singletons/AtPattern.hs b/tests/compile-and-dump/Singletons/AtPattern.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/AtPattern.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Singletons.AtPattern where - -import Data.Singletons.TH -import Data.Singletons.Maybe -import Singletons.Nat - -$(singletons [d| - maybePlus :: Maybe Nat -> Maybe Nat - maybePlus (Just n) = Just (plus (Succ Zero) n) - maybePlus foo@Nothing = foo - |]) diff --git a/tests/compile-and-dump/Singletons/BadPlus.ghc76.template b/tests/compile-and-dump/Singletons/BadPlus.ghc76.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/BadPlus.ghc76.template +++ /dev/null @@ -1,2 +0,0 @@ -Singletons/BadPlus.hs:0:0: - No type signature for functions: "badPlus"; cannot promote or make singletons. diff --git a/tests/compile-and-dump/Singletons/BadPlus.ghc78.template b/tests/compile-and-dump/Singletons/BadPlus.ghc78.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/BadPlus.ghc78.template +++ /dev/null @@ -1,2 +0,0 @@ -Singletons/BadPlus.hs:0:0: - No type signature for functions: "badPlus"; cannot promote or make singletons. diff --git a/tests/compile-and-dump/Singletons/BadPlus.hs b/tests/compile-and-dump/Singletons/BadPlus.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/BadPlus.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Singletons.BadPlus where - -import Data.Singletons.TH -import Singletons.Nat - --- Test whether a declaration without type signature is not singletonized. - -$(singletons [d| - badPlus Zero m = m - badPlus (Succ n) m = Succ (plus n m) - |]) diff --git a/tests/compile-and-dump/Singletons/BoxUnBox.ghc76.template b/tests/compile-and-dump/Singletons/BoxUnBox.ghc76.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/BoxUnBox.ghc76.template +++ /dev/null @@ -1,28 +0,0 @@ -Singletons/BoxUnBox.hs:0:0: Splicing declarations - singletons - [d| unBox :: Box a -> a - unBox (FBox a) = a - - data Box a = FBox a |] - ======> - Singletons/BoxUnBox.hs:(0,0)-(0,0) - data Box a = FBox a - unBox :: forall a. Box a -> a - unBox (FBox a) = a - type instance UnBox (FBox a) = a - type family UnBox (a :: Box a) :: a - data instance Sing (z :: Box a) - = forall (n :: a). z ~ FBox n => SFBox (Sing n) - type SBox (z :: Box a) = Sing z - instance SingKind (KProxy :: KProxy a) => - SingKind (KProxy :: KProxy (Box a)) where - type instance DemoteRep (KProxy :: KProxy (Box a)) = - Box (DemoteRep (KProxy :: KProxy a)) - fromSing (SFBox b) = FBox (fromSing b) - toSing (FBox b) - = case toSing b :: SomeSing (KProxy :: KProxy a) of { - SomeSing c -> SomeSing (SFBox c) } - instance SingI n => SingI (FBox (n :: a)) where - sing = SFBox sing - sUnBox :: forall (t :: Box a). Sing t -> Sing (UnBox t) - sUnBox (SFBox a) = a diff --git a/tests/compile-and-dump/Singletons/BoxUnBox.ghc78.template b/tests/compile-and-dump/Singletons/BoxUnBox.ghc78.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/BoxUnBox.ghc78.template +++ /dev/null @@ -1,27 +0,0 @@ -Singletons/BoxUnBox.hs:0:0: Splicing declarations - singletons - [d| unBox :: Box a -> a - unBox (FBox a) = a - - data Box a = FBox a |] - ======> - Singletons/BoxUnBox.hs:(0,0)-(0,0) - data Box a = FBox a - unBox :: forall a. Box a -> a - unBox (FBox a) = a - type family UnBox (a :: Box a) :: a where - UnBox (FBox a) = a - data instance Sing (z :: Box a) - = forall (n :: a). z ~ FBox n => SFBox (Sing n) - type SBox (z :: Box a) = Sing z - instance SingKind (KProxy :: KProxy a) => - SingKind (KProxy :: KProxy (Box a)) where - type DemoteRep (KProxy :: KProxy (Box a)) = Box (DemoteRep (KProxy :: KProxy a)) - fromSing (SFBox b) = FBox (fromSing b) - toSing (FBox b) - = case toSing b :: SomeSing (KProxy :: KProxy a) of { - SomeSing c -> SomeSing (SFBox c) } - instance SingI n => SingI (FBox (n :: a)) where - sing = SFBox sing - sUnBox :: forall (t :: Box a). Sing t -> Sing (UnBox t) - sUnBox (SFBox a) = a diff --git a/tests/compile-and-dump/Singletons/BoxUnBox.hs b/tests/compile-and-dump/Singletons/BoxUnBox.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/BoxUnBox.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Singletons.BoxUnBox where - -import Data.Singletons.TH - -$(singletons [d| - data Box a = FBox a - unBox :: Box a -> a - unBox (FBox a) = a - |]) diff --git a/tests/compile-and-dump/Singletons/Contains.ghc76.template b/tests/compile-and-dump/Singletons/Contains.ghc76.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Contains.ghc76.template +++ /dev/null @@ -1,19 +0,0 @@ -Singletons/Contains.hs:0:0: Splicing declarations - singletons - [d| contains :: Eq a => a -> [a] -> Bool - contains _ [] = False - contains elt (h : t) = (elt == h) || (contains elt t) |] - ======> - Singletons/Contains.hs:(0,0)-(0,0) - contains :: forall a. Eq a => a -> [a] -> Bool - contains _ GHC.Types.[] = False - contains elt (h GHC.Types.: t) = ((elt == h) || (contains elt t)) - type instance Contains z GHC.Types.[] = False - type instance Contains elt (GHC.Types.: h t) = - :|| (:== elt h) (Contains elt t) - type family Contains (a :: a) (a :: [a]) :: Bool - sContains :: - forall (t :: a) (t :: [a]). SEq (KProxy :: KProxy a) => - Sing t -> Sing t -> Sing (Contains t t) - sContains _ SNil = SFalse - sContains elt (SCons h t) = (%:||) ((%:==) elt h) (sContains elt t) diff --git a/tests/compile-and-dump/Singletons/Contains.ghc78.template b/tests/compile-and-dump/Singletons/Contains.ghc78.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Contains.ghc78.template +++ /dev/null @@ -1,18 +0,0 @@ -Singletons/Contains.hs:0:0: Splicing declarations - singletons - [d| contains :: Eq a => a -> [a] -> Bool - contains _ [] = False - contains elt (h : t) = (elt == h) || (contains elt t) |] - ======> - Singletons/Contains.hs:(0,0)-(0,0) - contains :: forall a. Eq a => a -> [a] -> Bool - contains _ GHC.Types.[] = False - contains elt (h GHC.Types.: t) = ((elt == h) || (contains elt t)) - type family Contains (a :: a) (a :: [a]) :: Bool where - Contains z GHC.Types.[] = False - Contains elt ((GHC.Types.:) h t) = (:||) ((:==) elt h) (Contains elt t) - sContains :: - forall (t :: a) (t :: [a]). SEq (KProxy :: KProxy a) => - Sing t -> Sing t -> Sing (Contains t t) - sContains _ SNil = SFalse - sContains elt (SCons h t) = (%:||) ((%:==) elt h) (sContains elt t) diff --git a/tests/compile-and-dump/Singletons/Contains.hs b/tests/compile-and-dump/Singletons/Contains.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Contains.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Singletons.Contains where - -import Data.Singletons.TH -import Data.Singletons.List -import Data.Singletons.Bool - --- polimorphic function with context - -$(singletons [d| - contains :: Eq a => a -> [a] -> Bool - contains _ [] = False - contains elt (h:t) = (elt == h) || (contains elt t) - |]) diff --git a/tests/compile-and-dump/Singletons/DataValues.ghc76.template b/tests/compile-and-dump/Singletons/DataValues.ghc76.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/DataValues.ghc76.template +++ /dev/null @@ -1,46 +0,0 @@ -Singletons/DataValues.hs:0:0: Splicing declarations - singletons - [d| pr = Pair (Succ Zero) ([Zero]) - complex = Pair (Pair (Just Zero) Zero) False - tuple = (False, Just Zero, True) - aList = [Zero, Succ Zero, Succ (Succ Zero)] - - data Pair a b - = Pair a b - deriving (Show) |] - ======> - Singletons/DataValues.hs:(0,0)-(0,0) - data Pair a b - = Pair a b - deriving (Show) - pr = Pair (Succ Zero) [Zero] - complex = Pair (Pair (Just Zero) Zero) False - tuple = (False, Just Zero, True) - aList = [Zero, Succ Zero, Succ (Succ Zero)] - type Pr = Pair (Succ Zero) '[Zero] - type Complex = Pair (Pair (Just Zero) Zero) False - type Tuple = '(False, Just Zero, True) - type AList = '[Zero, Succ Zero, Succ (Succ Zero)] - data instance Sing (z :: Pair a b) - = forall (n :: a) (n :: b). z ~ Pair n n => SPair (Sing n) (Sing n) - type SPair (z :: Pair a b) = Sing z - instance (SingKind (KProxy :: KProxy a), - SingKind (KProxy :: KProxy b)) => - SingKind (KProxy :: KProxy (Pair a b)) where - type instance DemoteRep (KProxy :: KProxy (Pair a b)) = - Pair (DemoteRep (KProxy :: KProxy a)) (DemoteRep (KProxy :: KProxy b)) - fromSing (SPair b b) = Pair (fromSing b) (fromSing b) - toSing (Pair b b) - = case - (toSing b :: SomeSing (KProxy :: KProxy a), - toSing b :: SomeSing (KProxy :: KProxy b)) - of { - (SomeSing c, SomeSing c) -> SomeSing (SPair c c) } - instance (SingI n, SingI n) => SingI (Pair (n :: a) (n :: b)) where - sing = SPair sing sing - sPr = SPair (SSucc SZero) (SCons SZero SNil) - sComplex = SPair (SPair (SJust SZero) SZero) SFalse - sTuple = STuple3 SFalse (SJust SZero) STrue - sAList - = SCons - SZero (SCons (SSucc SZero) (SCons (SSucc (SSucc SZero)) SNil)) diff --git a/tests/compile-and-dump/Singletons/DataValues.ghc78.template b/tests/compile-and-dump/Singletons/DataValues.ghc78.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/DataValues.ghc78.template +++ /dev/null @@ -1,45 +0,0 @@ -Singletons/DataValues.hs:0:0: Splicing declarations - singletons - [d| pr = Pair (Succ Zero) ([Zero]) - complex = Pair (Pair (Just Zero) Zero) False - tuple = (False, Just Zero, True) - aList = [Zero, Succ Zero, Succ (Succ Zero)] - - data Pair a b - = Pair a b - deriving (Show) |] - ======> - Singletons/DataValues.hs:(0,0)-(0,0) - data Pair a b - = Pair a b - deriving (Show) - pr = Pair (Succ Zero) [Zero] - complex = Pair (Pair (Just Zero) Zero) False - tuple = (False, Just Zero, True) - aList = [Zero, Succ Zero, Succ (Succ Zero)] - type Pr = Pair (Succ Zero) '[Zero] - type Complex = Pair (Pair (Just Zero) Zero) False - type Tuple = '(False, Just Zero, True) - type AList = '[Zero, Succ Zero, Succ (Succ Zero)] - data instance Sing (z :: Pair a b) - = forall (n :: a) (n :: b). z ~ Pair n n => SPair (Sing n) (Sing n) - type SPair (z :: Pair a b) = Sing z - instance (SingKind (KProxy :: KProxy a), - SingKind (KProxy :: KProxy b)) => - SingKind (KProxy :: KProxy (Pair a b)) where - type DemoteRep (KProxy :: KProxy (Pair a b)) = Pair (DemoteRep (KProxy :: KProxy a)) (DemoteRep (KProxy :: KProxy b)) - fromSing (SPair b b) = Pair (fromSing b) (fromSing b) - toSing (Pair b b) - = case - (toSing b :: SomeSing (KProxy :: KProxy a), - toSing b :: SomeSing (KProxy :: KProxy b)) - of { - (SomeSing c, SomeSing c) -> SomeSing (SPair c c) } - instance (SingI n, SingI n) => SingI (Pair (n :: a) (n :: b)) where - sing = SPair sing sing - sPr = SPair (SSucc SZero) (SCons SZero SNil) - sComplex = SPair (SPair (SJust SZero) SZero) SFalse - sTuple = STuple3 SFalse (SJust SZero) STrue - sAList - = SCons - SZero (SCons (SSucc SZero) (SCons (SSucc (SSucc SZero)) SNil)) diff --git a/tests/compile-and-dump/Singletons/DataValues.hs b/tests/compile-and-dump/Singletons/DataValues.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/DataValues.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Singletons.DataValues where - -import Data.Singletons.TH -import Data.Singletons.Prelude -import Singletons.Nat - -$(singletons [d| - data Pair a b = Pair a b deriving Show - - pr = Pair (Succ Zero) ([Zero]) - - complex = Pair (Pair (Just Zero) Zero) False - - tuple = (False, Just Zero, True) - - aList = [Zero, Succ Zero, Succ (Succ Zero)] - - |]) diff --git a/tests/compile-and-dump/Singletons/Empty.ghc76.template b/tests/compile-and-dump/Singletons/Empty.ghc76.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Empty.ghc76.template +++ /dev/null @@ -1,15 +0,0 @@ -Singletons/Empty.hs:0:0: Splicing declarations - singletons [d| data Empty |] - ======> - Singletons/Empty.hs:(0,0)-(0,0) - data Empty - data instance Sing (z :: Empty) - type SEmpty (z :: Empty) = Sing z - instance SingKind (KProxy :: KProxy Empty) where - type instance DemoteRep (KProxy :: KProxy Empty) = Empty - fromSing z - = case z of { - _ -> error "Empty case reached -- this should be impossible" } - toSing z - = case z of { - _ -> error "Empty case reached -- this should be impossible" } diff --git a/tests/compile-and-dump/Singletons/Empty.ghc78.template b/tests/compile-and-dump/Singletons/Empty.ghc78.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Empty.ghc78.template +++ /dev/null @@ -1,15 +0,0 @@ -Singletons/Empty.hs:0:0: Splicing declarations - singletons [d| data Empty |] - ======> - Singletons/Empty.hs:(0,0)-(0,0) - data Empty - data instance Sing (z :: Empty) - type SEmpty (z :: Empty) = Sing z - instance SingKind (KProxy :: KProxy Empty) where - type DemoteRep (KProxy :: KProxy Empty) = Empty - fromSing z - = case z of { - _ -> error "Empty case reached -- this should be impossible" } - toSing z - = case z of { - _ -> error "Empty case reached -- this should be impossible" } diff --git a/tests/compile-and-dump/Singletons/Empty.hs b/tests/compile-and-dump/Singletons/Empty.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Empty.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Singletons.Empty where - -import Data.Singletons.TH - -$(singletons [d| - data Empty - |]) diff --git a/tests/compile-and-dump/Singletons/EqInstances.ghc76.template b/tests/compile-and-dump/Singletons/EqInstances.ghc76.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/EqInstances.ghc76.template +++ /dev/null @@ -1,17 +0,0 @@ -Singletons/EqInstances.hs:0:0: Splicing declarations - singEqInstances [''Foo, ''Empty] - ======> - Singletons/EqInstances.hs:0:0: - instance SEq (KProxy :: KProxy Foo) where - %:== SFLeaf SFLeaf = STrue - %:== SFLeaf (:%+: _ _) = SFalse - %:== (:%+: _ _) SFLeaf = SFalse - %:== (:%+: a a) (:%+: b b) = (%:&&) ((%:==) a b) ((%:==) a b) - type instance (:==) FLeaf FLeaf = True - type instance (:==) FLeaf (:+: b b) = False - type instance (:==) (:+: a a) FLeaf = False - type instance (:==) (:+: a a) (:+: b b) = :&& (:== a b) (:== a b) - instance SEq (KProxy :: KProxy Empty) where - %:== a _ - = case a of { - _ -> error "Empty case reached -- this should be impossible" } diff --git a/tests/compile-and-dump/Singletons/EqInstances.ghc78.template b/tests/compile-and-dump/Singletons/EqInstances.ghc78.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/EqInstances.ghc78.template +++ /dev/null @@ -1,22 +0,0 @@ -Singletons/EqInstances.hs:0:0: Splicing declarations - singEqInstances [''Foo, ''Empty] - ======> - Singletons/EqInstances.hs:0:0: - instance SEq (KProxy :: KProxy Foo) where - (%:==) SFLeaf SFLeaf = STrue - (%:==) SFLeaf ((:%+:) _ _) = SFalse - (%:==) ((:%+:) _ _) SFLeaf = SFalse - (%:==) ((:%+:) a a) ((:%+:) b b) = (%:&&) ((%:==) a b) ((%:==) a b) - type family Equals_0123456789 (a :: Foo) (b :: Foo) :: Bool where - Equals_0123456789 FLeaf FLeaf = True - Equals_0123456789 ((:+:) a a) ((:+:) b b) = (:&&) ((==) a b) ((==) a b) - Equals_0123456789 (a :: Foo) (b :: Foo) = False - type instance (==) (a :: Foo) (b :: Foo) = Equals_0123456789 a b - instance SEq (KProxy :: KProxy Empty) where - (%:==) a _ - = case a of { - _ -> error "Empty case reached -- this should be impossible" } - type family Equals_0123456789 (a :: Empty) - (b :: Empty) :: Bool where - Equals_0123456789 (a :: Empty) (b :: Empty) = False - type instance (==) (a :: Empty) (b :: Empty) = Equals_0123456789 a b diff --git a/tests/compile-and-dump/Singletons/EqInstances.hs b/tests/compile-and-dump/Singletons/EqInstances.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/EqInstances.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Singletons.EqInstances where - -import Data.Singletons.TH -import Data.Singletons.Bool -import Singletons.Empty -import Singletons.Operators - -$(singEqInstances [''Foo, ''Empty]) diff --git a/tests/compile-and-dump/Singletons/HigherOrder.ghc76.template b/tests/compile-and-dump/Singletons/HigherOrder.ghc76.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/HigherOrder.ghc76.template +++ /dev/null @@ -1,33 +0,0 @@ -Singletons/HigherOrder.hs:0:0: Splicing declarations - singletons - [d| map :: (a -> b) -> [a] -> [b] - map _ [] = [] - map f (h : t) = (f h) : (map f t) - liftMaybe :: (a -> b) -> Maybe a -> Maybe b - liftMaybe f (Just x) = Just (f x) - liftMaybe _ Nothing = Nothing |] - ======> - Singletons/HigherOrder.hs:(0,0)-(0,0) - map :: forall a b. (a -> b) -> [a] -> [b] - map _ GHC.Types.[] = GHC.Types.[] - map f (h GHC.Types.: t) = ((f h) GHC.Types.: (map f t)) - liftMaybe :: forall a b. (a -> b) -> Maybe a -> Maybe b - liftMaybe f (Just x) = Just (f x) - liftMaybe _ Nothing = Nothing - type instance Map z GHC.Types.[] = GHC.Types.[] - type instance Map f (GHC.Types.: h t) = GHC.Types.: (f h) (Map f t) - type instance LiftMaybe f (Just x) = Just (f x) - type instance LiftMaybe z Nothing = Nothing - type family Map (a :: a -> b) (a :: [a]) :: [b] - type family LiftMaybe (a :: a -> b) (a :: Maybe a) :: Maybe b - sMap :: - forall (t :: a -> b) (t :: [a]). - (forall (t :: a). Sing t -> Sing (t t)) -> Sing t -> Sing (Map t t) - sMap _ SNil = SNil - sMap f (SCons h t) = SCons (f h) (sMap f t) - sLiftMaybe :: - forall (t :: a -> b) (t :: Maybe a). - (forall (t :: a). Sing t -> Sing (t t)) - -> Sing t -> Sing (LiftMaybe t t) - sLiftMaybe f (SJust x) = SJust (f x) - sLiftMaybe _ SNothing = SNothing diff --git a/tests/compile-and-dump/Singletons/HigherOrder.ghc78.template b/tests/compile-and-dump/Singletons/HigherOrder.ghc78.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/HigherOrder.ghc78.template +++ /dev/null @@ -1,33 +0,0 @@ -Singletons/HigherOrder.hs:0:0: Splicing declarations - singletons - [d| map :: (a -> b) -> [a] -> [b] - map _ [] = [] - map f (h : t) = (f h) : (map f t) - liftMaybe :: (a -> b) -> Maybe a -> Maybe b - liftMaybe f (Just x) = Just (f x) - liftMaybe _ Nothing = Nothing |] - ======> - Singletons/HigherOrder.hs:(0,0)-(0,0) - map :: forall a b. (a -> b) -> [a] -> [b] - map _ GHC.Types.[] = [] - map f (h GHC.Types.: t) = ((f h) GHC.Types.: (map f t)) - liftMaybe :: forall a b. (a -> b) -> Maybe a -> Maybe b - liftMaybe f (Just x) = Just (f x) - liftMaybe _ Nothing = Nothing - type family Map (a :: a -> b) (a :: [a]) :: [b] where - Map z GHC.Types.[] = '[] - Map f ((GHC.Types.:) h t) = (GHC.Types.:) (f h) (Map f t) - type family LiftMaybe (a :: a -> b) (a :: Maybe a) :: Maybe b where - LiftMaybe f (Just x) = Just (f x) - LiftMaybe z Nothing = Nothing - sMap :: - forall (t :: a -> b) (t :: [a]). - (forall (t :: a). Sing t -> Sing (t t)) -> Sing t -> Sing (Map t t) - sMap _ SNil = SNil - sMap f (SCons h t) = SCons (f h) (sMap f t) - sLiftMaybe :: - forall (t :: a -> b) (t :: Maybe a). - (forall (t :: a). Sing t -> Sing (t t)) - -> Sing t -> Sing (LiftMaybe t t) - sLiftMaybe f (SJust x) = SJust (f x) - sLiftMaybe _ SNothing = SNothing diff --git a/tests/compile-and-dump/Singletons/HigherOrder.hs b/tests/compile-and-dump/Singletons/HigherOrder.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/HigherOrder.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Singletons.HigherOrder where - -import Data.Singletons.TH -import Data.Singletons.List -import Data.Singletons.Maybe - -$(singletons [d| - map :: (a -> b) -> [a] -> [b] - map _ [] = [] - map f (h:t) = (f h) : (map f t) - - liftMaybe :: (a -> b) -> Maybe a -> Maybe b - liftMaybe f (Just x) = Just (f x) - liftMaybe _ Nothing = Nothing - |]) diff --git a/tests/compile-and-dump/Singletons/Maybe.ghc76.template b/tests/compile-and-dump/Singletons/Maybe.ghc76.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Maybe.ghc76.template +++ /dev/null @@ -1,53 +0,0 @@ -Singletons/Maybe.hs:0:0: Splicing declarations - singletons - [d| data Maybe a - = Nothing | Just a - deriving (Eq, Show) |] - ======> - Singletons/Maybe.hs:(0,0)-(0,0) - data Maybe a - = Nothing | Just a - deriving (Eq, Show) - type instance (:==) Nothing Nothing = True - type instance (:==) Nothing (Just b) = False - type instance (:==) (Just a) Nothing = False - type instance (:==) (Just a) (Just b) = :== a b - data instance Sing (z :: Maybe a) - = z ~ Nothing => SNothing | - forall (n :: a). z ~ Just n => SJust (Sing n) - type SMaybe (z :: Maybe a) = Sing z - instance SingKind (KProxy :: KProxy a) => - SingKind (KProxy :: KProxy (Maybe a)) where - type instance DemoteRep (KProxy :: KProxy (Maybe a)) = - Maybe (DemoteRep (KProxy :: KProxy a)) - fromSing SNothing = Nothing - fromSing (SJust b) = Just (fromSing b) - toSing Nothing = SomeSing SNothing - toSing (Just b) - = case toSing b :: SomeSing (KProxy :: KProxy a) of { - SomeSing c -> SomeSing (SJust c) } - instance SEq (KProxy :: KProxy a) => - SEq (KProxy :: KProxy (Maybe a)) where - %:== SNothing SNothing = STrue - %:== SNothing (SJust _) = SFalse - %:== (SJust _) SNothing = SFalse - %:== (SJust a) (SJust b) = (%:==) a b - instance SDecide (KProxy :: KProxy a) => - SDecide (KProxy :: KProxy (Maybe a)) where - %~ SNothing SNothing = Proved Refl - %~ SNothing (SJust _) - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ (SJust _) SNothing - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ (SJust a) (SJust b) - = case (%~) a b of { - Proved Refl -> Proved Refl - Disproved contra -> Disproved (\ Refl -> contra Refl) } - instance SingI Nothing where - sing = SNothing - instance SingI n => SingI (Just (n :: a)) where - sing = SJust sing diff --git a/tests/compile-and-dump/Singletons/Maybe.ghc78.template b/tests/compile-and-dump/Singletons/Maybe.ghc78.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Maybe.ghc78.template +++ /dev/null @@ -1,54 +0,0 @@ -Singletons/Maybe.hs:0:0: Splicing declarations - singletons - [d| data Maybe a - = Nothing | Just a - deriving (Eq, Show) |] - ======> - Singletons/Maybe.hs:(0,0)-(0,0) - data Maybe a - = Nothing | Just a - deriving (Eq, Show) - type family Equals_0123456789 (a :: Maybe k) - (b :: Maybe k) :: Bool where - Equals_0123456789 Nothing Nothing = True - Equals_0123456789 (Just a) (Just b) = (==) a b - Equals_0123456789 (a :: Maybe k) (b :: Maybe k) = False - type instance (==) (a :: Maybe k) (b :: Maybe k) = Equals_0123456789 a b - data instance Sing (z :: Maybe a) - = z ~ Nothing => SNothing | - forall (n :: a). z ~ Just n => SJust (Sing n) - type SMaybe (z :: Maybe a) = Sing z - instance SingKind (KProxy :: KProxy a) => - SingKind (KProxy :: KProxy (Maybe a)) where - type DemoteRep (KProxy :: KProxy (Maybe a)) = Maybe (DemoteRep (KProxy :: KProxy a)) - fromSing SNothing = Nothing - fromSing (SJust b) = Just (fromSing b) - toSing Nothing = SomeSing SNothing - toSing (Just b) - = case toSing b :: SomeSing (KProxy :: KProxy a) of { - SomeSing c -> SomeSing (SJust c) } - instance SEq (KProxy :: KProxy a) => - SEq (KProxy :: KProxy (Maybe a)) where - (%:==) SNothing SNothing = STrue - (%:==) SNothing (SJust _) = SFalse - (%:==) (SJust _) SNothing = SFalse - (%:==) (SJust a) (SJust b) = (%:==) a b - instance SDecide (KProxy :: KProxy a) => - SDecide (KProxy :: KProxy (Maybe a)) where - (%~) SNothing SNothing = Proved Refl - (%~) SNothing (SJust _) - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SJust _) SNothing - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SJust a) (SJust b) - = case (%~) a b of { - Proved Refl -> Proved Refl - Disproved contra -> Disproved (\ Refl -> contra Refl) } - instance SingI Nothing where - sing = SNothing - instance SingI n => SingI (Just (n :: a)) where - sing = SJust sing diff --git a/tests/compile-and-dump/Singletons/Maybe.hs b/tests/compile-and-dump/Singletons/Maybe.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Maybe.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Singletons.Maybe where - -import Data.Singletons.TH - -$(singletons [d| - data Maybe a = Nothing | Just a deriving (Eq, Show) - |]) diff --git a/tests/compile-and-dump/Singletons/Nat.ghc76.template b/tests/compile-and-dump/Singletons/Nat.ghc76.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Nat.ghc76.template +++ /dev/null @@ -1,79 +0,0 @@ -Singletons/Nat.hs:0:0: Splicing declarations - singletons - - [d| plus :: Nat -> Nat -> Nat - plus Zero m = m - plus (Succ n) m = Succ (plus n m) - - pred :: Nat -> Nat - pred Zero = Zero - pred (Succ n) = n - - data Nat - where - Zero :: Nat - Succ :: Nat -> Nat - deriving (Eq, Show, Read) |] - ======> - Singletons/Nat.hs:(0,0)-(0,0) - data Nat - = Zero | Succ Nat - deriving (Eq, Show, Read) - plus :: Nat -> Nat -> Nat - plus Zero m = m - plus (Succ n) m = Succ (plus n m) - pred :: Nat -> Nat - pred Zero = Zero - pred (Succ n) = n - type instance (:==) Zero Zero = True - type instance (:==) Zero (Succ b) = False - type instance (:==) (Succ a) Zero = False - type instance (:==) (Succ a) (Succ b) = :== a b - type instance Plus Zero m = m - type instance Plus (Succ n) m = Succ (Plus n m) - type instance Pred Zero = Zero - type instance Pred (Succ n) = n - type family Plus (a :: Nat) (a :: Nat) :: Nat - type family Pred (a :: Nat) :: Nat - data instance Sing (z :: Nat) - = z ~ Zero => SZero | - forall (n :: Nat). z ~ Succ n => SSucc (Sing n) - type SNat (z :: Nat) = Sing z - instance SingKind (KProxy :: KProxy Nat) where - type instance DemoteRep (KProxy :: KProxy Nat) = Nat - fromSing SZero = Zero - fromSing (SSucc b) = Succ (fromSing b) - toSing Zero = SomeSing SZero - toSing (Succ b) - = case toSing b :: SomeSing (KProxy :: KProxy Nat) of { - SomeSing c -> SomeSing (SSucc c) } - instance SEq (KProxy :: KProxy Nat) where - %:== SZero SZero = STrue - %:== SZero (SSucc _) = SFalse - %:== (SSucc _) SZero = SFalse - %:== (SSucc a) (SSucc b) = (%:==) a b - instance SDecide (KProxy :: KProxy Nat) where - %~ SZero SZero = Proved Refl - %~ SZero (SSucc _) - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ (SSucc _) SZero - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ (SSucc a) (SSucc b) - = case (%~) a b of { - Proved Refl -> Proved Refl - Disproved contra -> Disproved (\ Refl -> contra Refl) } - instance SingI Zero where - sing = SZero - instance SingI n => SingI (Succ (n :: Nat)) where - sing = SSucc sing - sPlus :: - forall (t :: Nat) (t :: Nat). Sing t -> Sing t -> Sing (Plus t t) - sPlus SZero m = m - sPlus (SSucc n) m = SSucc (sPlus n m) - sPred :: forall (t :: Nat). Sing t -> Sing (Pred t) - sPred SZero = SZero - sPred (SSucc n) = n diff --git a/tests/compile-and-dump/Singletons/Nat.ghc78.template b/tests/compile-and-dump/Singletons/Nat.ghc78.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Nat.ghc78.template +++ /dev/null @@ -1,80 +0,0 @@ -Singletons/Nat.hs:0:0: Splicing declarations - singletons - - [d| plus :: Nat -> Nat -> Nat - plus Zero m = m - plus (Succ n) m = Succ (plus n m) - - pred :: Nat -> Nat - pred Zero = Zero - pred (Succ n) = n - - data Nat - where - Zero :: Nat - Succ :: Nat -> Nat - deriving (Eq, Show, Read) |] - ======> - Singletons/Nat.hs:(0,0)-(0,0) - data Nat - = Zero | Succ Nat - deriving (Eq, Show, Read) - plus :: Nat -> Nat -> Nat - plus Zero m = m - plus (Succ n) m = Succ (plus n m) - pred :: Nat -> Nat - pred Zero = Zero - pred (Succ n) = n - type family Equals_0123456789 (a :: Nat) (b :: Nat) :: Bool where - Equals_0123456789 Zero Zero = True - Equals_0123456789 (Succ a) (Succ b) = (==) a b - Equals_0123456789 (a :: Nat) (b :: Nat) = False - type instance (==) (a :: Nat) (b :: Nat) = Equals_0123456789 a b - type family Plus (a :: Nat) (a :: Nat) :: Nat where - Plus Zero m = m - Plus (Succ n) m = Succ (Plus n m) - type family Pred (a :: Nat) :: Nat where - Pred Zero = Zero - Pred (Succ n) = n - data instance Sing (z :: Nat) - = z ~ Zero => SZero | - forall (n :: Nat). z ~ Succ n => SSucc (Sing n) - type SNat (z :: Nat) = Sing z - instance SingKind (KProxy :: KProxy Nat) where - type DemoteRep (KProxy :: KProxy Nat) = Nat - fromSing SZero = Zero - fromSing (SSucc b) = Succ (fromSing b) - toSing Zero = SomeSing SZero - toSing (Succ b) - = case toSing b :: SomeSing (KProxy :: KProxy Nat) of { - SomeSing c -> SomeSing (SSucc c) } - instance SEq (KProxy :: KProxy Nat) where - (%:==) SZero SZero = STrue - (%:==) SZero (SSucc _) = SFalse - (%:==) (SSucc _) SZero = SFalse - (%:==) (SSucc a) (SSucc b) = (%:==) a b - instance SDecide (KProxy :: KProxy Nat) where - (%~) SZero SZero = Proved Refl - (%~) SZero (SSucc _) - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SSucc _) SZero - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SSucc a) (SSucc b) - = case (%~) a b of { - Proved Refl -> Proved Refl - Disproved contra -> Disproved (\ Refl -> contra Refl) } - instance SingI Zero where - sing = SZero - instance SingI n => SingI (Succ (n :: Nat)) where - sing = SSucc sing - sPlus :: - forall (t :: Nat) (t :: Nat). Sing t -> Sing t -> Sing (Plus t t) - sPlus SZero m = m - sPlus (SSucc n) m = SSucc (sPlus n m) - sPred :: forall (t :: Nat). Sing t -> Sing (Pred t) - sPred SZero = SZero - sPred (SSucc n) = n diff --git a/tests/compile-and-dump/Singletons/Nat.hs b/tests/compile-and-dump/Singletons/Nat.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Nat.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Singletons.Nat where - -import Data.Singletons.TH - -$(singletons [d| - data Nat where - Zero :: Nat - Succ :: Nat -> Nat - deriving (Eq, Show, Read) - - plus :: Nat -> Nat -> Nat - plus Zero m = m - plus (Succ n) m = Succ (plus n m) - - pred :: Nat -> Nat - pred Zero = Zero - pred (Succ n) = n - |]) diff --git a/tests/compile-and-dump/Singletons/Operators.ghc76.template b/tests/compile-and-dump/Singletons/Operators.ghc76.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Operators.ghc76.template +++ /dev/null @@ -1,56 +0,0 @@ -Singletons/Operators.hs:0:0: Splicing declarations - singletons - [d| child :: Foo -> Foo - child FLeaf = FLeaf - child (a :+: _) = a - + :: Nat -> Nat -> Nat - Zero + m = m - (Succ n) + m = Succ (n + m) - - data Foo - where - FLeaf :: Foo - :+: :: Foo -> Foo -> Foo |] - ======> - Singletons/Operators.hs:(0,0)-(0,0) - data Foo = FLeaf | (:+:) Foo Foo - child :: Foo -> Foo - child FLeaf = FLeaf - child (a :+: _) = a - + :: Nat -> Nat -> Nat - + Zero m = m - + (Succ n) m = Succ (n + m) - type instance Child FLeaf = FLeaf - type instance Child (:+: a z) = a - type instance (:+) Zero m = m - type instance (:+) (Succ n) m = Succ (:+ n m) - type family Child (a :: Foo) :: Foo - type family (:+) (a :: Nat) (a :: Nat) :: Nat - data instance Sing (z :: Foo) - = z ~ FLeaf => SFLeaf | - forall (n :: Foo) (n :: Foo). z ~ :+: n n => - (:%+:) (Sing n) (Sing n) - type SFoo (z :: Foo) = Sing z - instance SingKind (KProxy :: KProxy Foo) where - type instance DemoteRep (KProxy :: KProxy Foo) = Foo - fromSing SFLeaf = FLeaf - fromSing (:%+: b b) = (:+:) (fromSing b) (fromSing b) - toSing FLeaf = SomeSing SFLeaf - toSing (:+: b b) - = case - (toSing b :: SomeSing (KProxy :: KProxy Foo), - toSing b :: SomeSing (KProxy :: KProxy Foo)) - of { - (SomeSing c, SomeSing c) -> SomeSing ((:%+:) c c) } - instance SingI FLeaf where - sing = SFLeaf - instance (SingI n, SingI n) => - SingI (:+: (n :: Foo) (n :: Foo)) where - sing = (:%+:) sing sing - sChild :: forall (t :: Foo). Sing t -> Sing (Child t) - sChild SFLeaf = SFLeaf - sChild (:%+: a _) = a - %:+ :: - forall (t :: Nat) (t :: Nat). Sing t -> Sing t -> Sing (:+ t t) - %:+ SZero m = m - %:+ (SSucc n) m = SSucc ((%:+) n m) diff --git a/tests/compile-and-dump/Singletons/Operators.ghc78.template b/tests/compile-and-dump/Singletons/Operators.ghc78.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Operators.ghc78.template +++ /dev/null @@ -1,56 +0,0 @@ -Singletons/Operators.hs:0:0: Splicing declarations - singletons - [d| child :: Foo -> Foo - child FLeaf = FLeaf - child (a :+: _) = a - (+) :: Nat -> Nat -> Nat - Zero + m = m - (Succ n) + m = Succ (n + m) - - data Foo - where - FLeaf :: Foo - :+: :: Foo -> Foo -> Foo |] - ======> - Singletons/Operators.hs:(0,0)-(0,0) - data Foo = FLeaf | (:+:) Foo Foo - child :: Foo -> Foo - child FLeaf = FLeaf - child (a :+: _) = a - (+) :: Nat -> Nat -> Nat - (+) Zero m = m - (+) (Succ n) m = Succ (n + m) - type family Child (a :: Foo) :: Foo where - Child FLeaf = FLeaf - Child ((:+:) a z) = a - type family (:+) (a :: Nat) (a :: Nat) :: Nat where - (:+) Zero m = m - (:+) (Succ n) m = Succ ((:+) n m) - data instance Sing (z :: Foo) - = z ~ FLeaf => SFLeaf | - forall (n :: Foo) (n :: Foo). z ~ (:+:) n n => - (:%+:) (Sing n) (Sing n) - type SFoo (z :: Foo) = Sing z - instance SingKind (KProxy :: KProxy Foo) where - type DemoteRep (KProxy :: KProxy Foo) = Foo - fromSing SFLeaf = FLeaf - fromSing ((:%+:) b b) = (:+:) (fromSing b) (fromSing b) - toSing FLeaf = SomeSing SFLeaf - toSing ((:+:) b b) - = case - (toSing b :: SomeSing (KProxy :: KProxy Foo), - toSing b :: SomeSing (KProxy :: KProxy Foo)) - of { - (SomeSing c, SomeSing c) -> SomeSing ((:%+:) c c) } - instance SingI FLeaf where - sing = SFLeaf - instance (SingI n, SingI n) => - SingI ((:+:) (n :: Foo) (n :: Foo)) where - sing = (:%+:) sing sing - sChild :: forall (t :: Foo). Sing t -> Sing (Child t) - sChild SFLeaf = SFLeaf - sChild ((:%+:) a _) = a - (%:+) :: - forall (t :: Nat) (t :: Nat). Sing t -> Sing t -> Sing ((:+) t t) - (%:+) SZero m = m - (%:+) (SSucc n) m = SSucc ((%:+) n m) diff --git a/tests/compile-and-dump/Singletons/Operators.hs b/tests/compile-and-dump/Singletons/Operators.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Operators.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Singletons.Operators where - -import Data.Singletons.TH -import Singletons.Nat - -$(singletons [d| - data Foo where - FLeaf :: Foo - (:+:) :: Foo -> Foo -> Foo - - child :: Foo -> Foo - child FLeaf = FLeaf - child (a :+: _) = a - - (+) :: Nat -> Nat -> Nat - Zero + m = m - (Succ n) + m = Succ (n + m) - |]) diff --git a/tests/compile-and-dump/Singletons/Star.ghc76.template b/tests/compile-and-dump/Singletons/Star.ghc76.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Star.ghc76.template +++ /dev/null @@ -1,188 +0,0 @@ -Singletons/Star.hs:0:0: Splicing declarations - singletonStar [''Nat, ''Int, ''String, ''Maybe, ''Vec] - ======> - Singletons/Star.hs:0:0: - data Rep - = Nat | Int | String | Maybe Rep | Vec Rep Nat - deriving (Eq, Show, Read) - type instance (:==) Nat Nat = True - type instance (:==) Nat Int = False - type instance (:==) Nat String = False - type instance (:==) Nat (Maybe b) = False - type instance (:==) Nat (Vec b b) = False - type instance (:==) Int Nat = False - type instance (:==) Int Int = True - type instance (:==) Int String = False - type instance (:==) Int (Maybe b) = False - type instance (:==) Int (Vec b b) = False - type instance (:==) String Nat = False - type instance (:==) String Int = False - type instance (:==) String String = True - type instance (:==) String (Maybe b) = False - type instance (:==) String (Vec b b) = False - type instance (:==) (Maybe a) Nat = False - type instance (:==) (Maybe a) Int = False - type instance (:==) (Maybe a) String = False - type instance (:==) (Maybe a) (Maybe b) = :== a b - type instance (:==) (Maybe a) (Vec b b) = False - type instance (:==) (Vec a a) Nat = False - type instance (:==) (Vec a a) Int = False - type instance (:==) (Vec a a) String = False - type instance (:==) (Vec a a) (Maybe b) = False - type instance (:==) (Vec a a) (Vec b b) = :&& (:== a b) (:== a b) - data instance Sing (z :: *) - = z ~ Nat => SNat | - z ~ Int => SInt | - z ~ String => SString | - forall (n :: *). z ~ Maybe n => SMaybe (Sing n) | - forall (n :: *) (n :: Nat). z ~ Vec n n => SVec (Sing n) (Sing n) - type SRep (z :: *) = Sing z - instance SingKind (KProxy :: KProxy *) where - type instance DemoteRep (KProxy :: KProxy *) = Rep - fromSing SNat = Nat - fromSing SInt = Int - fromSing SString = String - fromSing (SMaybe b) = Maybe (fromSing b) - fromSing (SVec b b) = Vec (fromSing b) (fromSing b) - toSing Nat = SomeSing SNat - toSing Int = SomeSing SInt - toSing String = SomeSing SString - toSing (Maybe b) - = case toSing b :: SomeSing (KProxy :: KProxy *) of { - SomeSing c -> SomeSing (SMaybe c) } - toSing (Vec b b) - = case - (toSing b :: SomeSing (KProxy :: KProxy *), - toSing b :: SomeSing (KProxy :: KProxy Nat)) - of { - (SomeSing c, SomeSing c) -> SomeSing (SVec c c) } - instance SEq (KProxy :: KProxy *) where - %:== SNat SNat = STrue - %:== SNat SInt = SFalse - %:== SNat SString = SFalse - %:== SNat (SMaybe _) = SFalse - %:== SNat (SVec _ _) = SFalse - %:== SInt SNat = SFalse - %:== SInt SInt = STrue - %:== SInt SString = SFalse - %:== SInt (SMaybe _) = SFalse - %:== SInt (SVec _ _) = SFalse - %:== SString SNat = SFalse - %:== SString SInt = SFalse - %:== SString SString = STrue - %:== SString (SMaybe _) = SFalse - %:== SString (SVec _ _) = SFalse - %:== (SMaybe _) SNat = SFalse - %:== (SMaybe _) SInt = SFalse - %:== (SMaybe _) SString = SFalse - %:== (SMaybe a) (SMaybe b) = (%:==) a b - %:== (SMaybe _) (SVec _ _) = SFalse - %:== (SVec _ _) SNat = SFalse - %:== (SVec _ _) SInt = SFalse - %:== (SVec _ _) SString = SFalse - %:== (SVec _ _) (SMaybe _) = SFalse - %:== (SVec a a) (SVec b b) = (%:&&) ((%:==) a b) ((%:==) a b) - instance SDecide (KProxy :: KProxy *) where - %~ SNat SNat = Proved Refl - %~ SNat SInt - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SNat SString - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SNat (SMaybe _) - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SNat (SVec _ _) - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SInt SNat - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SInt SInt = Proved Refl - %~ SInt SString - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SInt (SMaybe _) - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SInt (SVec _ _) - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SString SNat - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SString SInt - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SString SString = Proved Refl - %~ SString (SMaybe _) - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ SString (SVec _ _) - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ (SMaybe _) SNat - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ (SMaybe _) SInt - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ (SMaybe _) SString - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ (SMaybe a) (SMaybe b) - = case (%~) a b of { - Proved Refl -> Proved Refl - Disproved contra -> Disproved (\ Refl -> contra Refl) } - %~ (SMaybe _) (SVec _ _) - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ (SVec _ _) SNat - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ (SVec _ _) SInt - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ (SVec _ _) SString - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ (SVec _ _) (SMaybe _) - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - %~ (SVec a a) (SVec b b) - = case ((%~) a b, (%~) a b) of { - (Proved Refl, Proved Refl) -> Proved Refl - (Disproved contra, _) -> Disproved (\ Refl -> contra Refl) - (_, Disproved contra) -> Disproved (\ Refl -> contra Refl) } - instance SingI Nat where - sing = SNat - instance SingI Int where - sing = SInt - instance SingI String where - sing = SString - instance SingI n => SingI (Maybe (n :: *)) where - sing = SMaybe sing - instance (SingI n, SingI n) => - SingI (Vec (n :: *) (n :: Nat)) where - sing = SVec sing sing diff --git a/tests/compile-and-dump/Singletons/Star.ghc78.template b/tests/compile-and-dump/Singletons/Star.ghc78.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Star.ghc78.template +++ /dev/null @@ -1,142 +0,0 @@ -Singletons/Star.hs:0:0: Splicing declarations - singletonStar [''Nat, ''Int, ''String, ''Maybe, ''Vec] - ======> - Singletons/Star.hs:0:0: - data Rep - = Nat | Int | String | Maybe Rep | Vec Rep Nat - deriving (Eq, Show, Read) - instance SDecide (KProxy :: KProxy *) where - (%~) SNat SNat = Proved Refl - (%~) SNat SInt - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SNat SString - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SNat (SMaybe _) - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SNat (SVec _ _) - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SInt SNat - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SInt SInt = Proved Refl - (%~) SInt SString - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SInt (SMaybe _) - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SInt (SVec _ _) - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SString SNat - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SString SInt - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SString SString = Proved Refl - (%~) SString (SMaybe _) - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SString (SVec _ _) - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SMaybe _) SNat - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SMaybe _) SInt - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SMaybe _) SString - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SMaybe a) (SMaybe b) - = case (%~) a b of { - Proved Refl -> Proved Refl - Disproved contra -> Disproved (\ Refl -> contra Refl) } - (%~) (SMaybe _) (SVec _ _) - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SVec _ _) SNat - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SVec _ _) SInt - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SVec _ _) SString - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SVec _ _) (SMaybe _) - = Disproved - (\case { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SVec a a) (SVec b b) - = case ((%~) a b, (%~) a b) of { - (Proved Refl, Proved Refl) -> Proved Refl - (Disproved contra, _) -> Disproved (\ Refl -> contra Refl) - (_, Disproved contra) -> Disproved (\ Refl -> contra Refl) } - instance SEq (KProxy :: KProxy *) where - (%:==) a b - = case (%~) a b of { - Proved Refl -> STrue - Disproved _ -> Unsafe.Coerce.unsafeCoerce SFalse } - data instance Sing (z :: *) - = z ~ Nat => SNat | - z ~ Int => SInt | - z ~ String => SString | - forall (n :: *). z ~ Maybe n => SMaybe (Sing n) | - forall (n :: *) (n :: Nat). z ~ Vec n n => SVec (Sing n) (Sing n) - type SRep (z :: *) = Sing z - instance SingKind (KProxy :: KProxy *) where - type DemoteRep (KProxy :: KProxy *) = Rep - fromSing SNat = Nat - fromSing SInt = Int - fromSing SString = String - fromSing (SMaybe b) = Maybe (fromSing b) - fromSing (SVec b b) = Vec (fromSing b) (fromSing b) - toSing Nat = SomeSing SNat - toSing Int = SomeSing SInt - toSing String = SomeSing SString - toSing (Maybe b) - = case toSing b :: SomeSing (KProxy :: KProxy *) of { - SomeSing c -> SomeSing (SMaybe c) } - toSing (Vec b b) - = case - (toSing b :: SomeSing (KProxy :: KProxy *), - toSing b :: SomeSing (KProxy :: KProxy Nat)) - of { - (SomeSing c, SomeSing c) -> SomeSing (SVec c c) } - instance SingI Nat where - sing = SNat - instance SingI Int where - sing = SInt - instance SingI String where - sing = SString - instance SingI n => SingI (Maybe (n :: *)) where - sing = SMaybe sing - instance (SingI n, SingI n) => - SingI (Vec (n :: *) (n :: Nat)) where - sing = SVec sing sing diff --git a/tests/compile-and-dump/Singletons/Star.hs b/tests/compile-and-dump/Singletons/Star.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Star.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-unused-imports #-} - -module Singletons.Star where - -import Data.Singletons.Prelude -import Data.Singletons.Decide -import Data.Singletons.CustomStar -import Singletons.Nat - -data Vec :: * -> Nat -> * where - VNil :: Vec a Zero - VCons :: a -> Vec a n -> Vec a (Succ n) - -$(singletonStar [''Nat, ''Int, ''String, ''Maybe, ''Vec]) diff --git a/tests/compile-and-dump/buildGoldenFiles.awk b/tests/compile-and-dump/buildGoldenFiles.awk deleted file mode 100644 --- a/tests/compile-and-dump/buildGoldenFiles.awk +++ /dev/null @@ -1,1 +0,0 @@ -/INSERT/{while((getline line < $2) > 0 ){if(line !~ /INSERT/){print line}}close($2);next}1