packages feed

singletons 0.10.0 → 3.0.4

raw patch · 81 files changed

Files

CHANGES.md view
@@ -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 ------
LICENSE view
@@ -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
README.md view
@@ -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`.
singletons.cabal view
@@ -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 <eir@cis.upenn.edu>-maintainer:     Richard Eisenberg <eir@cis.upenn.edu>+author:         Richard Eisenberg <rae@cs.brynmawr.edu>, Jan Stolarek <jan.stolarek@p.lodz.pl>+maintainer:     Ryan Scott <ryan.gl.scott@gmail.com> 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.-    (<http://www.cis.upenn.edu/~eir/papers/2012/singletons/paper.pdf>)--    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.+    (<https://richarde.dev/papers/2012/singletons/paper.pdf>)+    .+    @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@+    @<https://github.com/goldfirere/singletons/blob/master/README.md README>@.+    .+    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
src/Data/Singletons.hs view
@@ -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--- <http://www.cis.upenn.edu/~eir/packages/singletons/README.html> and the--- original paper presenting this library, available at--- <http://www.cis.upenn.edu/~eir/papers/2012/singletons/paper.pdf>.----------------------------------------------------------------------------------#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 <https://ghc.haskell.org/trac/ghc/ticket/3927>.--- 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+-- <https://richarde.dev/papers/2012/singletons/paper.pdf>+-- and <https://richarde.dev/papers/2014/promotion/promotion.pdf>.+--+----------------------------------------------------------------------------++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+-- @<https://github.com/goldfirere/singletons/blob/master/README.md README>@.+--+-- 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+<https://github.com/goldfirere/singletons/issues/366#issuecomment-489469086 here>.+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+@+-}
− src/Data/Singletons/Bool.hs 
@@ -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-  |])
− src/Data/Singletons/CustomStar.hs 
@@ -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
src/Data/Singletons/Decide.hs view
@@ -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
− src/Data/Singletons/Either.hs 
@@ -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-  |])
− src/Data/Singletons/Eq.hs 
@@ -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)
− src/Data/Singletons/Instances.hs 
@@ -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)-
− src/Data/Singletons/List.hs 
@@ -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-  |])
− src/Data/Singletons/Maybe.hs 
@@ -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)-  |])
− src/Data/Singletons/Prelude.hs 
@@ -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
− src/Data/Singletons/Promote.hs 
@@ -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 <<Rep>> 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 <<where>> 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 <<where>> 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)
+ src/Data/Singletons/ShowSing.hs view
@@ -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+-- <https://gitlab.haskell.org/ghc/ghc/issues/14860 this GHC issue> 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
+ src/Data/Singletons/Sigma.hs view
@@ -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
− src/Data/Singletons/Singletons.hs 
@@ -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 <http://www.cis.upenn.edu/~eir/packages/singletons/README.html> 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 <<where>> 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 <<where>> 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))
− src/Data/Singletons/TH.hs 
@@ -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 <<cases>> 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))
− src/Data/Singletons/Tuple.hs 
@@ -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)-  |])
− src/Data/Singletons/TypeLits.hs 
@@ -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)
− src/Data/Singletons/TypeRepStar.hs 
@@ -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
− src/Data/Singletons/Types.hs 
@@ -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
− src/Data/Singletons/Util.hs 
@@ -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
− src/Data/Singletons/Void.hs 
@@ -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
+ tests/ByHand.hs view
@@ -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
+ tests/ByHand2.hs view
@@ -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
tests/SingletonsTestSuite.hs view
@@ -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 ()
− tests/SingletonsTestSuiteUtils.hs 
@@ -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)
− tests/compile-and-dump/GradingClient/Database.ghc76.template 
@@ -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 }
− tests/compile-and-dump/GradingClient/Database.ghc78.template 
@@ -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 }
− tests/compile-and-dump/GradingClient/Database.hs 
@@ -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 <<inProof>>-        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
− tests/compile-and-dump/GradingClient/Main.ghc76.template 
@@ -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))
− tests/compile-and-dump/GradingClient/Main.ghc78.template 
@@ -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))
− tests/compile-and-dump/GradingClient/Main.hs 
@@ -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"
− tests/compile-and-dump/InsertionSort/InsertionSortImp.ghc76.template 
@@ -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)
− tests/compile-and-dump/InsertionSort/InsertionSortImp.ghc78.template 
@@ -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)
− tests/compile-and-dump/InsertionSort/InsertionSortImp.hs 
@@ -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)
− tests/compile-and-dump/Promote/NumArgs.ghc76.template 
@@ -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
− tests/compile-and-dump/Promote/NumArgs.ghc78.template 
@@ -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
− tests/compile-and-dump/Promote/NumArgs.hs 
@@ -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-  |])
− tests/compile-and-dump/Promote/PatternMatching.ghc76.template 
@@ -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
− tests/compile-and-dump/Promote/PatternMatching.ghc78.template 
@@ -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
− tests/compile-and-dump/Promote/PatternMatching.hs 
@@ -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-  |])
− tests/compile-and-dump/Singletons/AtPattern.ghc76.template 
@@ -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
− tests/compile-and-dump/Singletons/AtPattern.ghc78.template 
@@ -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
− tests/compile-and-dump/Singletons/AtPattern.hs 
@@ -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- |])
− tests/compile-and-dump/Singletons/BadPlus.ghc76.template 
@@ -1,2 +0,0 @@-Singletons/BadPlus.hs:0:0:-    No type signature for functions: "badPlus"; cannot promote or make singletons.
− tests/compile-and-dump/Singletons/BadPlus.ghc78.template 
@@ -1,2 +0,0 @@-Singletons/BadPlus.hs:0:0:-    No type signature for functions: "badPlus"; cannot promote or make singletons.
− tests/compile-and-dump/Singletons/BadPlus.hs 
@@ -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)- |])
− tests/compile-and-dump/Singletons/BoxUnBox.ghc76.template 
@@ -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
− tests/compile-and-dump/Singletons/BoxUnBox.ghc78.template 
@@ -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
− tests/compile-and-dump/Singletons/BoxUnBox.hs 
@@ -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- |])
− tests/compile-and-dump/Singletons/Contains.ghc76.template 
@@ -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)
− tests/compile-and-dump/Singletons/Contains.ghc78.template 
@@ -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)
− tests/compile-and-dump/Singletons/Contains.hs 
@@ -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)- |])
− tests/compile-and-dump/Singletons/DataValues.ghc76.template 
@@ -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))
− tests/compile-and-dump/Singletons/DataValues.ghc78.template 
@@ -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))
− tests/compile-and-dump/Singletons/DataValues.hs 
@@ -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)]--  |])
− tests/compile-and-dump/Singletons/Empty.ghc76.template 
@@ -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" }
− tests/compile-and-dump/Singletons/Empty.ghc78.template 
@@ -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" }
− tests/compile-and-dump/Singletons/Empty.hs 
@@ -1,7 +0,0 @@-module Singletons.Empty where--import Data.Singletons.TH--$(singletons [d|-  data Empty- |])
− tests/compile-and-dump/Singletons/EqInstances.ghc76.template 
@@ -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" }
− tests/compile-and-dump/Singletons/EqInstances.ghc78.template 
@@ -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
− tests/compile-and-dump/Singletons/EqInstances.hs 
@@ -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])
− tests/compile-and-dump/Singletons/HigherOrder.ghc76.template 
@@ -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
− tests/compile-and-dump/Singletons/HigherOrder.ghc78.template 
@@ -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
− tests/compile-and-dump/Singletons/HigherOrder.hs 
@@ -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- |])
− tests/compile-and-dump/Singletons/Maybe.ghc76.template 
@@ -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
− tests/compile-and-dump/Singletons/Maybe.ghc78.template 
@@ -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
− tests/compile-and-dump/Singletons/Maybe.hs 
@@ -1,7 +0,0 @@-module Singletons.Maybe where--import Data.Singletons.TH--$(singletons [d|-  data Maybe a = Nothing | Just a deriving (Eq, Show)- |])
− tests/compile-and-dump/Singletons/Nat.ghc76.template 
@@ -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
− tests/compile-and-dump/Singletons/Nat.ghc78.template 
@@ -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
− tests/compile-and-dump/Singletons/Nat.hs 
@@ -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- |])
− tests/compile-and-dump/Singletons/Operators.ghc76.template 
@@ -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)
− tests/compile-and-dump/Singletons/Operators.ghc78.template 
@@ -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)
− tests/compile-and-dump/Singletons/Operators.hs 
@@ -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)- |])
− tests/compile-and-dump/Singletons/Star.ghc76.template 
@@ -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
− tests/compile-and-dump/Singletons/Star.ghc78.template 
@@ -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
− tests/compile-and-dump/Singletons/Star.hs 
@@ -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])
− tests/compile-and-dump/buildGoldenFiles.awk 
@@ -1,1 +0,0 @@-/INSERT/{while((getline line < $2) > 0 ){if(line !~ /INSERT/){print line}}close($2);next}1