packages feed

singletons 0.10.0 → 1.0

raw patch · 169 files changed

+22016/−7710 lines, 169 filesdep ~basedep ~th-desugar

Dependency ranges changed: base, th-desugar

Files

README.md view
@@ -1,32 +1,44 @@-singletons 0.10-===============+singletons 1.0+==============  [![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).+The singletons library was written by Richard Eisenberg, eir@cis.upenn.edu, and+with significant contributions by Jan Stolarek, jan.stolarek@p.lodz.pl.  There+are two papers that describe the library. Original one, _Dependently typed+programming with singletons_, is available+[here](http://www.cis.upenn.edu/~eir/papers/2012/singletons/paper.pdf) and will+be referenced in this documentation as the "singletons paper". A follow-up+paper, _Promoting Functions to Type Families in Haskell_, will be available+online Real Soon Now and will be referenced in this documentation as the+"promotion paper".  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.+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 singletons paper for a more thorough introduction. +The package also allows _promotion_ of term-level functions to type-level+equivalents. Accordingly, it exports a Prelude of promoted and singletonized+functions, mirroring functions and datatypes found in Prelude, `Data.Bool`,+`Data.Maybe`, `Data.Either`, `Data.Tuple` and `Data.List`. See the promotion+paper 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:+The singletons library requires GHC 7.8.2 or greater. We plan to restore GHC+7.6.3 support, but no promises as to when will this happen. Any code that uses+the singleton generation primitives needs to enable a long list of GHC+extensions. This list includes, but is not necessarily limited to, the+following: -* `ScopedTypeVariables` (absolutely required)+* `ScopedTypeVariables` * `TemplateHaskell` * `TypeFamilies` * `GADTs`@@ -39,8 +51,8 @@ * `UndecidableInstances` * `FlexibleInstances` -Modules--------+Modules for singleton types+---------------------------  `Data.Singletons` exports all the basic singletons definitions. Import this module if you are not using Template Haskell and wish only to define your@@ -50,21 +62,21 @@ 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`.+definitions for various Prelude types. This module provides a singletonized+equivalent of the real `Prelude`. Note that not all functions from original+`Prelude` could be turned into singletons. -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.Prelude.*` modules provide singletonized equivalents of+definitions found in the following `base` library modules: `Data.Bool`,+`Data.Maybe`, `Data.Either`, `Data.List`, `Data.Tuple` and `GHC.Base`. We also+provide singletonized `Eq` and `Ord` typeclasses -`Data.Singletons.Eq` and `Data.Singletons.Decide` export type classes for-Boolean and propositional equality, respectively.+`Data.Singletons.Decide` exports type classes for propositional equality.  `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.+`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@@ -74,6 +86,24 @@ `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. +Modules for function promotion+------------------------------++Modules in `Data.Promotion` namespace provide functionality required for+function promotion. They mostly re-export a subset of definitions from+respective `Data.Singletons` modules.++`Data.Promotion.TH` exports all the definitions needed to use the Template+Haskell code to generate promoted definitions.++`Data.Promotion.Prelude` and `Data.Promotion.Prelude.*` modules re-export all+promoted definitions from respective `Data.Singletons.Prelude`+modules. `Data.Promotion.Prelude.List` adds a significant amount of functions+that couldn't be singletonized but can be promoted. Some functions still don't+promote - these are documented in the source code of the module. There is also+`Data.Promotion.Prelude.Bounded` module that provides promoted `PBounded`+typeclass.+ Functions to generate singletons -------------------------------- @@ -87,18 +117,21 @@ 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-      |])+Usage example: +```haskell+$(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+Please refer to the singletons paper 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)@@ -124,14 +157,14 @@       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`. +back to the type `Nat`.      data SingInstance (a :: k) where       SingInstance :: SingI a => SingInstance a@@ -152,7 +185,7 @@  * 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.+`SEq`. See the `Data.Singletons.Prelude.Eq` module for more information.  * Propositional equality is implemented through the constraint `(~)`, the type `(:~:)`, and the class `SDecide`. See modules `Data.Type.Equality` and@@ -186,65 +219,147 @@ operate on these singletons are available from modules such as `Data.Singletons.Bool` and `Data.Singletons.Maybe`. +Promoting functions+------------------- +Function promotion allows to generate type-level equivalents of term-level+definitions. Almost all Haskell source constructs are supported -- see last+section of this README for a full list.++Promoted definitions are usually generated by calling `promote` function:++```haskell+$(promote [d|+  data Nat = Zero | Succ Nat+  pred :: Nat -> Nat+  pred Zero = Zero+  pred (Succ n) = n+  |])+```++Every promoted function and data constructor definition comes with a set of+so-called "symbols". These are required to represent partial application at the+type level. Each function gets N+1 symbols, where N is the arity. Symbols+represent application of between 0 to N arguments. When calling any of the+promoted definitions it is important refer to it using their symbol+name. Moreover, there is new function application at the type level represented+by `Apply` type family. Symbol representing arity X can have X arguments passed+in using normal function application. All other parameters must be passed by+calling `Apply`.++Users also have access to `Data.Promotion.Prelude` and its submodules (`Base`,+`Bool`, `Either`, `List`, `Maybe` and `Tuple`). These provide promoted versions+of function found in GHC's base library.++Refer to the promotion paper for more details on function promotion.+ 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`)  +1. original datatype: `Nat` -original datatype: `:/\:`  -promoted kind: `:/\:`  -singleton type: `:%/\:`  +   promoted kind: `Nat` -original constructor: `Zero`  -promoted type: `'Zero` (you can use `Zero` when unambiguous)  -singleton constructor: `SZero`  +   singleton type: `SNat` (which is really a synonym for `Sing`) -original constructor: `:+:`  -promoted type: `':+:`  -singleton constructor: `:%+:`   -original value: `pred`  -promoted type: `Pred`  -singleton value: `sPred`  +2. original datatype: `:/\:` -original value: `+`  -promoted type: `:+`  -singleton value: `%:+`  +   promoted kind: `:/\:` +   singleton type: `:%/\:` +++3. original constructor: `Succ`++   promoted type: `'Succ` (you can use `Succ` when unambiguous)++   singleton constructor: `SSucc`++   symbols: `SuccSym0`, `SuccSym1`+++4. original constructor: `:+:`++   promoted type: `':+:`++   singleton constructor: `:%+:`++   symbols: `:+:$`, `:+:$$`, `:+:$$$`+++5. original value: `pred`++   promoted type: `Pred`++   singleton value: `sPred`++   symbols: `PredSym0`, `PredSym1`+++6. original value: `+`++   promoted type: `:+`++   singleton value: `%:+`++   symbols: `:+$`, `:+$$`, `:+$$$`++ Special names -------------  There are some special cases: -original datatype: `[]`  -singleton type: `SList`+1. original datatype: `[]` -original constructor: `[]`  -singleton constructor: `SNil`+   singleton type: `SList` -original constructor: `:`  -singleton constructor: `SCons` -original datatype: `(,)`  -singleton type: `STuple2`+2.  original constructor: `[]` -original constructor: `(,)`  -singleton constructor: `STuple2`+    promoted type: `'[]` -All tuples (including the 0-tuple, unit) are treated similarly.+    singleton constructor: `SNil` -original value: `undefined`  -promoted type: `Any`  -singleton value: `undefined`+    symbols: `NilSym0`  +3. original constructor: `:`++   promoted type: `':`++   singleton constructr: `SCons`++   symbols: `ConsSym0`, `ConsSym1`+++4. original datatype: `(,)`++   singleton type: `STuple2`+++5. original constructor: `(,)`++   promoted type: `'(,)`++   singleton constructor: `STuple2`++   symbols: `Tuple2Sym0`, `Tuple2Sym1`, `Tuple2Sym2`++   All tuples (including the 0-tuple, unit) are treated similarly.++6. original value: `undefined`++   promoted type: `Any`++   singleton value: `undefined`++ Supported Haskell constructs ---------------------------- @@ -255,43 +370,71 @@ * constructors * if statements * infix expressions-* !, ~, and _ patterns-* aliased patterns (except at top-level)+* `_` patterns+* aliased patterns * lists-* (+) sections-* (x +) sections+* sections * undefined * error * deriving Eq-* class constraints+* class constraints (though these sometimes fail with `let`, `lambda`, and `case`) * literals (for `Nat` and `Symbol`)--The following constructs will be coming soon:--* unboxed tuples+* unboxed tuples (which are treated as normal tuples) * records-* scoped type variables-* overlapping patterns * pattern guards-* (+ x) sections * case * let-* list comprehensions * lambda expressions++The following constructs are supported for promotion but not singleton generation:++* `!` and `~` patterns (silently but successfully ignored during promotion)+* class and instance declarations+* deriving of promoted `Eq`, `Ord` and `Bounded` instances+* scoped type variables+* overlapping patterns (GHC 7.8.2+ only). Note that overlapping patterns are+  sometime not obvious. For example `filter` function does not singletonize due+  to overlapping patterns:+```haskell+filter :: (a -> Bool) -> [a] -> [a]+filter _pred []    = []+filter pred (x:xs)+  | pred x         = x : filter pred xs+  | otherwise      = filter pred xs+```+Overlap is caused by `otherwise` catch-all guard, that is always true and this+overlaps with `pred x` guard.++The following constructs are not supported:++* list comprehensions * do * arithmetic sequences+* datatypes that store arrows+* literals -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+Why are these out of reach? First two depend on monads, which mention a+higher-kinded type variable. GHC does not support higher-sorted kind variables,+which would be necessary to promote/singletonize monads. There are other tricks+possible, too, but none are likely to work. See the bug report+[here](https://github.com/goldfirere/singletons/issues/37) for more info.+Arithmetic sequences are defined using `Enum` typeclass, which uses infinite+lists. +As described in the promotion paper, promotion of datatypes that store arrows is+currently impossible. 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.+you will quickly run into errors. +Literals are problematic because we rely on GHC's built-in support, which+currently is limited. Functions that operate on strings will not work because+type level strings are no longer considered lists of characters. Function+working on integer literals can be promoted by rewriting them to use+`Nat`. Since `Nat` does not exist at the term level it will only be possible to+use the promoted definition, but not the original, term-level one.+ Support for `*` --------------- @@ -316,8 +459,25 @@ of types with which to work. See the Haddock documentation for the function `singletonStar` for more info. +Known bugs+----------++* Due to GHC bug #9081 deriving of hand-written instances of `Ord`, `Eq` and+  `Bounded` is not supported. Your only option here is to have these instances+  derived automatically.+* Fixity declarations don't promote due to GHC bug #9066.+* Instances with overlapping patterns don't promote. This will be fixed Real+  Soon Now.+* Top-level eta-reduced patterns don't singletonize+* Record updates don't singletonize+ Changes from earlier versions -----------------------------++singletons 1.0 provides promotion mechanism that supports case expressions, let+statements, anonymous functions, higher order functions and many other+features. This version of the library was published together with the promotion+paper.  singletons 0.9 contains a bit of an API change from previous versions. Here is a summary:
singletons.cabal view
@@ -1,15 +1,15 @@ name:           singletons-version:        0.10.0+version:        1.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 category:       Dependent Types-author:         Richard Eisenberg <eir@cis.upenn.edu>-maintainer:     Richard Eisenberg <eir@cis.upenn.edu>+author:         Richard Eisenberg <eir@cis.upenn.edu>, Jan Stolarek <jan.stolarek@p.lodz.pl>+maintainer:     Richard Eisenberg <eir@cis.upenn.edu>, Jan Stolarek <jan.stolarek@p.lodz.pl> bug-reports:    https://github.com/goldfirere/singletons/issues stability:      experimental-tested-with:    GHC ==7.6.3, GHC ==7.8.*+tested-with:    GHC ==7.8.2 extra-source-files: README.md, CHANGES.md,                     tests/compile-and-dump/buildGoldenFiles.awk,                     tests/compile-and-dump/GradingClient/*.hs,@@ -36,42 +36,71 @@     (<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+    GHC 7.6.x, but it does build with 7.8.2. Please see links from the project     homepage to find the built documentation.  source-repository this   type:     git   location: https://github.com/goldfirere/singletons.git-  tag:      v0.10.0+  tag:      v1.0  library   hs-source-dirs:     src-  build-depends:      base >= 4.6 && < 5,+  build-depends:      base >= 4.7 && < 5,                       mtl >= 2.1.1,                       template-haskell,                       containers >= 0.5,-                      th-desugar >= 1.2+                      th-desugar >= 1.4   default-language:   Haskell2010+  default-extensions: TemplateHaskell+        -- TemplateHaskell must be listed in cabal file to work with+        -- ghc7.8   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.Prelude.Base,+                      Data.Singletons.Prelude.Bool,+                      Data.Singletons.Prelude.Either,+                      Data.Singletons.Prelude.Eq,+                      Data.Singletons.Prelude.Ord,+                      Data.Singletons.Prelude.List,+                      Data.Singletons.Prelude.Maybe,+                      Data.Singletons.Prelude.Tuple,+                      Data.Promotion.Prelude,+                      Data.Promotion.TH,+                      Data.Promotion.Prelude.Base,+                      Data.Promotion.Prelude.Bool,+                      Data.Promotion.Prelude.Either,+                      Data.Promotion.Prelude.Eq,+                      Data.Promotion.Prelude.Ord,+                      Data.Promotion.Prelude.Bounded,+                      Data.Promotion.Prelude.List,+                      Data.Promotion.Prelude.Maybe,+                      Data.Promotion.Prelude.Tuple,                       Data.Singletons.Types,                       Data.Singletons.TypeLits,                       Data.Singletons.Decide,-                      Data.Singletons.Void+                      Data.Singletons.Void,+                      Data.Singletons.SuppressUnusedWarnings    other-modules:      Data.Singletons.Promote,-                      Data.Singletons.Singletons,+                      Data.Singletons.Promote.Monad,+                      Data.Singletons.Promote.Eq,+                      Data.Singletons.Promote.Ord,+                      Data.Singletons.Promote.Bounded,+                      Data.Singletons.Promote.Type,+                      Data.Singletons.Promote.Defun,                       Data.Singletons.Util,-                      Data.Singletons.Instances+                      Data.Singletons.Prelude.Instances,+                      Data.Singletons.Names,+                      Data.Singletons.Single.Monad,+                      Data.Singletons.Single.Type,+                      Data.Singletons.Single.Eq,+                      Data.Singletons.Single.Data,+                      Data.Singletons.Single,+                      Data.Singletons.Syntax    ghc-options:        -Wall
+ src/Data/Promotion/Prelude.hs view
@@ -0,0 +1,164 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Promotion.Prelude+-- Copyright   :  (C) 2014 Jan Stolarek+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  Jan Stolarek (jan.stolarek@p.lodz.pl)+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Mimics the Haskell Prelude, but with promoted types.+--+----------------------------------------------------------------------------++{-# LANGUAGE ExplicitNamespaces #-}+module Data.Promotion.Prelude (+  -- * Standard types, classes and related functions+  -- ** Basic data types+  If, Not, (:&&), (:||), Otherwise,++  maybe_, Maybe_, either_, Either_,++  Symbol,++  Fst, Snd, Curry, Uncurry,++  -- * Error reporting+  Error, ErrorSym0,++  -- * Promoted equality+  module Data.Promotion.Prelude.Eq,++  -- * Promoted comparisons+  module Data.Promotion.Prelude.Ord,++  -- * Promoted bounds+  module Data.Promotion.Prelude.Bounded,++  -- * Promoted arithmetic operations+  Nat, (:+), (:-), (:*), (:^),++  -- ** Miscellaneous functions+  Id, Const, (:.), type ($), type ($!), Flip, AsTypeOf, Until, Seq,+++  -- * List operations+  Map, (:++), Filter,+  Head, Last, Tail, Init, Null, Length, (:!!),+  Reverse,+  -- ** Reducing lists (folds)+  Foldl, Foldl1, Foldr, Foldr1,+  -- *** Special folds+  And, Or, any_, Any_, All,+  Sum, Product,+  Concat, ConcatMap,+  Maximum, Minimum,+  -- ** Building lists+  -- *** Scans+  Scanl, Scanl1, Scanr, Scanr1,+  -- *** Infinite lists+  Replicate,+  -- ** Sublists+  Take, Drop, SplitAt,+  TakeWhile, DropWhile, Span, Break,++  -- ** Searching lists+  Elem, NotElem, Lookup,+  -- ** Zipping and unzipping lists+  Zip, Zip3, ZipWith, ZipWith3, Unzip, Unzip3,++  -- * Other datatypes+  KProxy(..),++  -- * Defunctionalization symbols+  FalseSym0, TrueSym0,+  NotSym0, NotSym1, (:&&$), (:&&$$), (:&&$$$), (:||$), (:||$$), (:||$$$),+  OtherwiseSym0,++  NothingSym0, JustSym0, JustSym1,+  Maybe_Sym0, Maybe_Sym1, Maybe_Sym2, Maybe_Sym3,++  LeftSym0, LeftSym1, RightSym0, RightSym1,+  Either_Sym0, Either_Sym1, Either_Sym2, Either_Sym3,++  Tuple0Sym0,+  Tuple2Sym0, Tuple2Sym1, Tuple2Sym2,+  Tuple3Sym0, Tuple3Sym1, Tuple3Sym2, Tuple3Sym3,+  Tuple4Sym0, Tuple4Sym1, Tuple4Sym2, Tuple4Sym3, Tuple4Sym4,+  Tuple5Sym0, Tuple5Sym1, Tuple5Sym2, Tuple5Sym3, Tuple5Sym4, Tuple5Sym5,+  Tuple6Sym0, Tuple6Sym1, Tuple6Sym2, Tuple6Sym3, Tuple6Sym4, Tuple6Sym5, Tuple6Sym6,+  Tuple7Sym0, Tuple7Sym1, Tuple7Sym2, Tuple7Sym3, Tuple7Sym4, Tuple7Sym5, Tuple7Sym6, Tuple7Sym7,+  FstSym0, FstSym1, SndSym0, SndSym1,+  CurrySym0, CurrySym1, CurrySym2, CurrySym3,+  UncurrySym0, UncurrySym1, UncurrySym2,++  (:+$), (:+$$), (:-$), (:-$$),+  (:*$), (:*$$), (:^$), (:^$$),++  IdSym0, IdSym1, ConstSym0, ConstSym1, ConstSym2,+  (:.$), (:.$$), (:.$$$),+  type ($$), type ($$$), type ($$$$),+  type ($!$), type ($!$$), type ($!$$$),+  FlipSym0, FlipSym1, FlipSym2,+  AsTypeOfSym0, AsTypeOfSym1, AsTypeOfSym2, SeqSym0, SeqSym1, SeqSym2,++  (:$), (:$$), (:$$$), NilSym0, ConsSym0, ConsSym1, ConsSym2,+  MapSym0, MapSym1, MapSym2, ReverseSym0, ReverseSym1,+  (:++$$), (:++$), HeadSym0, HeadSym1, LastSym0, LastSym1,+  TailSym0, TailSym1, InitSym0, InitSym1, NullSym0, NullSym1,++  FoldlSym0, FoldlSym1, FoldlSym2, FoldlSym3,+  Foldl1Sym0, Foldl1Sym1, Foldl1Sym2,+  FoldrSym0, FoldrSym1, FoldrSym2, FoldrSym3,+  Foldr1Sym0, Foldr1Sym1, Foldr1Sym2,++  ConcatSym0, ConcatSym1,+  ConcatMapSym0, ConcatMapSym1, ConcatMapSym2,+  MaximumBySym0, MaximumBySym1, MaximumBySym2,+  MinimumBySym0, MinimumBySym1, MinimumBySym2,+  AndSym0, AndSym1, OrSym0, OrSym1,+  Any_Sym0, Any_Sym1, Any_Sym2,+  AllSym0, AllSym1, AllSym2,++  ScanlSym0, ScanlSym1, ScanlSym2, ScanlSym3,+  Scanl1Sym0, Scanl1Sym1, Scanl1Sym2,+  ScanrSym0, ScanrSym1, ScanrSym2, ScanrSym3,+  Scanr1Sym0, Scanr1Sym1, Scanr1Sym2,++  ElemSym0, ElemSym1, ElemSym2,+  NotElemSym0, NotElemSym1, NotElemSym2,++  ZipSym0, ZipSym1, ZipSym2,+  Zip3Sym0, Zip3Sym1, Zip3Sym2, Zip3Sym3,+  ZipWithSym0, ZipWithSym1, ZipWithSym2, ZipWithSym3,+  ZipWith3Sym0, ZipWith3Sym1, ZipWith3Sym2, ZipWith3Sym3,+  UnzipSym0, UnzipSym1,++  UntilSym0, UntilSym1, UntilSym2, UntilSym3,+  LengthSym0, LengthSym1,+  SumSym0, SumSym1,+  ProductSym0, ProductSym1,+  ReplicateSym0, ReplicateSym1, ReplicateSym2,+  TakeSym0, TakeSym1, TakeSym2,+  DropSym0, DropSym1, DropSym2,+  SplitAtSym0, SplitAtSym1, SplitAtSym2,+  TakeWhileSym0, TakeWhileSym1, TakeWhileSym2,+  DropWhileSym0, DropWhileSym1, DropWhileSym2,+  SpanSym0, SpanSym1, SpanSym2,+  BreakSym0, BreakSym1, BreakSym2,+  LookupSym0, LookupSym1, LookupSym2,+  FilterSym0, FilterSym1, FilterSym2,+  (:!!$), (:!!$$), (:!!$$$),+  ) where++import Data.Singletons.Types ( KProxy(..) )+import Data.Promotion.Prelude.Base+import Data.Promotion.Prelude.Bool+import Data.Promotion.Prelude.Either+import Data.Promotion.Prelude.List+import Data.Promotion.Prelude.Maybe+import Data.Promotion.Prelude.Tuple+import Data.Promotion.Prelude.Eq+import Data.Promotion.Prelude.Ord+import Data.Promotion.Prelude.Bounded+import Data.Singletons.TypeLits
+ src/Data/Promotion/Prelude/Base.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE CPP, TemplateHaskell, KindSignatures, PolyKinds, TypeOperators,+             DataKinds, ScopedTypeVariables, TypeFamilies, GADTs,+             UndecidableInstances #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Promotion.Prelude.Base+-- Copyright   :  (C) 2014 Jan Stolarek+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  Jan Stolarek (jan.stolarek@p.lodz.pl)+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Implements promoted functions from GHC.Base module.+--+-- 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 @Prelude@. Also, please excuse+-- the apparent repeated variable names. This is due to an interaction+-- between Template Haskell and Haddock.+--+----------------------------------------------------------------------------++module Data.Promotion.Prelude.Base (+  -- * Promoted functions from @GHC.Base@+  Foldr, Map, (:++), Otherwise, Id, Const, (:.), type ($), type ($!),+  Flip, Until, AsTypeOf, Seq,++  -- * Defunctionalization symbols+  FoldrSym0, FoldrSym1, FoldrSym2, FoldrSym3,+  MapSym0, MapSym1, MapSym2,+  (:++$), (:++$$),+  OtherwiseSym0,+  IdSym0, IdSym1,+  ConstSym0, ConstSym1, ConstSym2,+  (:.$), (:.$$), (:.$$$),+  type ($$), type ($$$), type ($$$$),+  type ($!$), type ($!$$), type ($!$$$),+  FlipSym0, FlipSym1, FlipSym2,+  UntilSym0, UntilSym1, UntilSym2, UntilSym3,+  AsTypeOfSym0, AsTypeOfSym1, AsTypeOfSym2,+  SeqSym0, SeqSym1, SeqSym2+  ) where++import Data.Singletons.TH+import Data.Singletons.Prelude.Base++$(promoteOnly [d|+  -- Does not singletoznize. See #30+  until                   :: (a -> Bool) -> (a -> a) -> a -> a+  until p f = go+    where+      go x | p x          = x+           | otherwise    = go (f x)+ |])
+ src/Data/Promotion/Prelude/Bool.hs view
@@ -0,0 +1,42 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Promotion.Prelude.Bool+-- Copyright   :  (C) 2014 Jan Stolarek+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  Jan Stolarek (jan.stolarek@p.lodz.pl)+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Defines promoted functions and datatypes relating to 'Bool',+-- including a promoted 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.Promotion.Prelude.Bool (+  If,++  -- * Promoted functions from @Data.Bool@+  Bool_, bool_,+  -- | The preceding two definitions are derived from the function 'bool' in+  -- @Data.Bool@. The extra underscore is to avoid name clashes with the type+  -- 'Bool'.++  Not, (:&&), (:||), Otherwise,++  -- * Defunctionalization symbols+  TrueSym0, FalseSym0,++  NotSym0, NotSym1,+  (:&&$), (:&&$$), (:&&$$$),+  (:||$), (:||$$), (:||$$$),+  Bool_Sym0, Bool_Sym1, Bool_Sym2, Bool_Sym3,+  OtherwiseSym0+  ) where++import Data.Singletons.Prelude.Bool
+ src/Data/Promotion/Prelude/Bounded.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE TemplateHaskell, DataKinds, PolyKinds, ScopedTypeVariables,+             TypeFamilies, TypeOperators, GADTs, UndecidableInstances,+             FlexibleContexts, DefaultSignatures #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Promotion.Prelude.Bounded+-- Copyright   :  (C) 2014 Jan Stolarek+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  Jan Stolarek (jan.stolarek@p.lodz.pl)+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Defines the promoted version of Bounded, 'PBounded'+--+-----------------------------------------------------------------------------++module Data.Promotion.Prelude.Bounded (+  PBounded(..),++  -- ** Defunctionalization symbols+  MaxBoundSym0,+  MinBoundSym0+  ) where++import Data.Singletons.Promote+import Data.Singletons.Util++$(promoteOnly [d|+  class Bounded a  where+    minBound, maxBound :: a+  |])++$(promoteBoundedInstances boundedBasicTypes)
+ src/Data/Promotion/Prelude/Either.hs view
@@ -0,0 +1,38 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Promotion.Prelude.Either+-- Copyright   :  (C) 2014 Jan Stolarek+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  jan.stolarek@p.lodz.pl+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Defines promoted functions and datatypes relating to 'Either',+-- including a promoted 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.Promotion.Prelude.Either (+  -- * Promoted functions from @Data.Either@+  either_, Either_,+  -- | 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, Rights, PartitionEithers, IsLeft, IsRight,++  -- * Defunctionalization symbols+  LeftSym0, LeftSym1, RightSym0, RightSym1,++  Either_Sym0, Either_Sym1, Either_Sym2, Either_Sym3,+  LeftsSym0, LeftsSym1, RightsSym0, RightsSym1,+  IsLeftSym0, IsLeftSym1, IsRightSym0, IsRightSym1+  ) where++import Data.Singletons.Prelude.Either
+ src/Data/Promotion/Prelude/Eq.hs view
@@ -0,0 +1,19 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Promotion.Prelude.Eq+-- Copyright   :  (C) 2014 Jan Stolarek+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  Jan Stolarek (jan.stolarek@p.lodz.pl)+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Provided promoted definitions related to type-level equality.+--+-----------------------------------------------------------------------------++{-# LANGUAGE ExplicitNamespaces #-}+module Data.Promotion.Prelude.Eq (+  PEq(..), (:==$), (:==$$), (:==$$$), (:/=$), (:/=$$), (:/=$$$)+  ) where++import Data.Singletons.Prelude.Eq
+ src/Data/Promotion/Prelude/List.hs view
@@ -0,0 +1,579 @@+{-# LANGUAGE CPP, TypeOperators, DataKinds, PolyKinds, TypeFamilies,+             TemplateHaskell, GADTs, UndecidableInstances, RankNTypes,+             ScopedTypeVariables, MultiWayIf #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Promotion.Prelude.List+-- Copyright   :  (C) 2014 Jan Stolarek+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  Jan Stolarek (jan.stolarek@p.lodz.pl)+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Defines promoted functions and datatypes relating to 'List',+-- including a promoted version of all 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.Promotion.Prelude.List (+  -- * Basic functions+  (:++), Head, Last, Tail, Init, Null, Length,++   -- * List transformations+  Map, Reverse, Intersperse, Intercalate, Transpose, Subsequences, Permutations,++  -- * Reducing lists (folds)+  Foldl, Foldl', Foldl1, Foldl1', Foldr, Foldr1,++  -- ** Special folds+  Concat, ConcatMap, And, Or, Any_, All, Sum, Product, Maximum, Minimum,+  any_, -- equivalent of Data.List `any`. Avoids name clash with Any type++  -- * Building lists++  -- ** Scans+  Scanl, Scanl1, Scanr, Scanr1,++  -- ** Accumulating maps+  MapAccumL, MapAccumR,++  -- ** Infinite lists+  Replicate,++  -- ** Unfolding+  Unfoldr,++  -- * Sublists++  -- ** Extracting sublists+  Take, Drop, SplitAt,+  TakeWhile, DropWhile, DropWhileEnd, Span, Break,+  StripPrefix,+  Group,+  Inits, Tails,++  -- ** Predicates+  IsPrefixOf, IsSuffixOf, IsInfixOf,++  -- * Searching lists++  -- ** Searching by equality+  Elem, NotElem, Lookup,++  -- ** Searching with a predicate+  Find, Filter, Partition,++  -- * Indexing lists+  (:!!), ElemIndex, ElemIndices, FindIndex, FindIndices,++  -- * Zipping and unzipping lists+  Zip, Zip3, Zip4, Zip5, Zip6, Zip7,+  ZipWith, ZipWith3, ZipWith4, ZipWith5, ZipWith6, ZipWith7,+  Unzip, Unzip3, Unzip4, Unzip5, Unzip6, Unzip7,++  -- * Special lists++  -- ** \"Set\" operations+  Nub, Delete, (:\\), Union, Intersect,++  -- ** Ordered lists+  Sort, Insert,++  -- * Generalized functions++  -- ** The \"@By@\" operations+  -- *** User-supplied equality (replacing an @Eq@ context)+  NubBy, DeleteBy, DeleteFirstsBy, UnionBy, GroupBy, IntersectBy,++  -- *** User-supplied comparison (replacing an @Ord@ context)+  SortBy, InsertBy,+  MaximumBy, MinimumBy,++   -- ** The \"@generic@\" operations+  GenericLength, GenericTake, GenericDrop,+  GenericSplitAt, GenericIndex, GenericReplicate,++  -- * Defunctionalization symbols+  (:$), (:$$), (:$$$),+  NilSym0, ConsSym0, ConsSym1, ConsSym2,++  (:++$$), (:++$), HeadSym0, HeadSym1, LastSym0, LastSym1,+  TailSym0, TailSym1, InitSym0, InitSym1, NullSym0, NullSym1,++  MapSym0, MapSym1, MapSym2, ReverseSym0, ReverseSym1,+  IntersperseSym0, IntersperseSym1, IntersperseSym2,+  IntercalateSym0, IntercalateSym1, IntercalateSym2,+  SubsequencesSym0, SubsequencesSym1,+  PermutationsSym0, PermutationsSym1,++  FoldlSym0, FoldlSym1, FoldlSym2, FoldlSym3,+  Foldl'Sym0, Foldl'Sym1, Foldl'Sym2, Foldl'Sym3,+  Foldl1Sym0, Foldl1Sym1, Foldl1Sym2,+  Foldl1'Sym0, Foldl1'Sym1, Foldl1'Sym2,+  FoldrSym0, FoldrSym1, FoldrSym2, FoldrSym3,+  Foldr1Sym0, Foldr1Sym1, Foldr1Sym2,++  ConcatSym0, ConcatSym1,+  ConcatMapSym0, ConcatMapSym1, ConcatMapSym2,+  AndSym0, AndSym1, OrSym0, OrSym1,+  Any_Sym0, Any_Sym1, Any_Sym2,+  AllSym0, AllSym1, AllSym2,++  ScanlSym0, ScanlSym1, ScanlSym2, ScanlSym3,+  Scanl1Sym0, Scanl1Sym1, Scanl1Sym2,+  ScanrSym0, ScanrSym1, ScanrSym2, ScanrSym3,+  Scanr1Sym0, Scanr1Sym1, Scanr1Sym2,++  MapAccumLSym0, MapAccumLSym1, MapAccumLSym2, MapAccumLSym3,+  MapAccumRSym0, MapAccumRSym1, MapAccumRSym2, MapAccumRSym3,++  UnfoldrSym0, UnfoldrSym1, UnfoldrSym2,++  InitsSym0, InitsSym1, TailsSym0, TailsSym1,++  IsPrefixOfSym0, IsPrefixOfSym1, IsPrefixOfSym2,+  IsSuffixOfSym0, IsSuffixOfSym1, IsSuffixOfSym2,+  IsInfixOfSym0, IsInfixOfSym1, IsInfixOfSym2,++  ElemSym0, ElemSym1, ElemSym2,+  NotElemSym0, NotElemSym1, NotElemSym2,++  ZipSym0, ZipSym1, ZipSym2,+  Zip3Sym0, Zip3Sym1, Zip3Sym2, Zip3Sym3,+  ZipWithSym0, ZipWithSym1, ZipWithSym2, ZipWithSym3,+  ZipWith3Sym0, ZipWith3Sym1, ZipWith3Sym2, ZipWith3Sym3,+  UnzipSym0, UnzipSym1,+  Unzip3Sym0, Unzip3Sym1,+  Unzip4Sym0, Unzip4Sym1,+  Unzip5Sym0, Unzip5Sym1,+  Unzip6Sym0, Unzip6Sym1,+  Unzip7Sym0, Unzip7Sym1,++  DeleteSym0, DeleteSym1, DeleteSym2,+  (:\\$), (:\\$$), (:\\$$$),+  IntersectSym0, IntersectSym1, IntersectSym2,++  InsertSym0, InsertSym1, InsertSym2,+  SortSym0, SortSym1,++  DeleteBySym0, DeleteBySym1, DeleteBySym2, DeleteBySym3,+  DeleteFirstsBySym0, DeleteFirstsBySym1, DeleteFirstsBySym2, DeleteFirstsBySym3,+  IntersectBySym0, IntersectBySym1, IntersectBySym2,++  SortBySym0, SortBySym1, SortBySym2,+  InsertBySym0, InsertBySym1, InsertBySym2, InsertBySym3,+  MaximumBySym0, MaximumBySym1, MaximumBySym2,+  MinimumBySym0, MinimumBySym1, MinimumBySym2,+  LengthSym0, LengthSym1,+  SumSym0, SumSym1, ProductSym0, ProductSym1,+  ReplicateSym0, ReplicateSym1, ReplicateSym2,+  TransposeSym0, TransposeSym1,+  TakeSym0, TakeSym1, TakeSym2,+  DropSym0, DropSym1, DropSym2,+  SplitAtSym0, SplitAtSym1, SplitAtSym2,+  TakeWhileSym0, TakeWhileSym1, TakeWhileSym2,+  DropWhileSym0, DropWhileSym1, DropWhileSym2,+  DropWhileEndSym0, DropWhileEndSym1, DropWhileEndSym2,+  SpanSym0, SpanSym1, SpanSym2,+  BreakSym0, BreakSym1, BreakSym2,+  StripPrefixSym0, StripPrefixSym1,+  MaximumSym0, MaximumSym1,+  MinimumSym0, MinimumSym1,+  GroupSym0, GroupSym1,+  GroupBySym0, GroupBySym1, GroupBySym2,+  LookupSym0, LookupSym1, LookupSym2,+  FindSym0, FindSym1, FindSym2,+  FilterSym0, FilterSym1, FilterSym2,+  PartitionSym0, PartitionSym1, PartitionSym2,++  (:!!$), (:!!$$), (:!!$$$),++  ElemIndexSym0, ElemIndexSym1, ElemIndexSym2,+  ElemIndicesSym0, ElemIndicesSym1, ElemIndicesSym2,+  FindIndexSym0, FindIndexSym1, FindIndexSym2,+  FindIndicesSym0, FindIndicesSym1, FindIndicesSym2,++  Zip4Sym0, Zip4Sym1, Zip4Sym2, Zip4Sym3, Zip4Sym4,+  Zip5Sym0, Zip5Sym1, Zip5Sym2, Zip5Sym3, Zip5Sym4, Zip5Sym5,+  Zip6Sym0, Zip6Sym1, Zip6Sym2, Zip6Sym3, Zip6Sym4, Zip6Sym5, Zip6Sym6,+  Zip7Sym0, Zip7Sym1, Zip7Sym2, Zip7Sym3, Zip7Sym4, Zip7Sym5, Zip7Sym6, Zip7Sym7,++  ZipWith4Sym0, ZipWith4Sym1, ZipWith4Sym2, ZipWith4Sym3, ZipWith4Sym4,+  ZipWith5Sym0, ZipWith5Sym1, ZipWith5Sym2, ZipWith5Sym3, ZipWith5Sym4, ZipWith5Sym5,+  ZipWith6Sym0, ZipWith6Sym1, ZipWith6Sym2, ZipWith6Sym3, ZipWith6Sym4, ZipWith6Sym5, ZipWith6Sym6,+  ZipWith7Sym0, ZipWith7Sym1, ZipWith7Sym2, ZipWith7Sym3, ZipWith7Sym4, ZipWith7Sym5, ZipWith7Sym6, ZipWith7Sym7,++  NubSym0, NubSym1,+  NubBySym0, NubBySym1, NubBySym2,+  UnionSym0, UnionSym1, UnionSym2,+  UnionBySym0, UnionBySym1, UnionBySym2, UnionBySym3,++  GenericLengthSym0, GenericLengthSym1,+  GenericTakeSym0, GenericTakeSym1, GenericTakeSym2,+  GenericDropSym0, GenericDropSym1, GenericDropSym2,+  GenericSplitAtSym0, GenericSplitAtSym1, GenericSplitAtSym2,+  GenericIndexSym0, GenericIndexSym1, GenericIndexSym2,+  GenericReplicateSym0, GenericReplicateSym1, GenericReplicateSym2,++  ) where++import Data.Singletons.Prelude.Base+import Data.Singletons.Prelude.Bool+import Data.Singletons.Prelude.Eq+import Data.Promotion.Prelude.Ord+import Data.Singletons.Prelude.List+import Data.Singletons.Prelude.Maybe+import Data.Singletons.Prelude.Tuple+import Data.Singletons.TH+import Data.Singletons.TypeLits++import Data.Maybe (listToMaybe)+-- these imports are required fir functions that singletonize but are used+-- in this module by a function that can't be singletonized+import Data.List  (deleteBy, sortBy, insertBy)++$(promoteOnly [d|+-- Can't be promoted because of limitations of Int promotion+-- Below is a re-implementation using Nat+--  length                  :: [a] -> Int+--  length l                =  lenAcc l 0#+--+--  lenAcc :: [a] -> Int# -> Int+--  lenAcc []     a# = I# a#+--  lenAcc (_:xs) a# = lenAcc xs (a# +# 1#)+--+--  incLen :: a -> (Int# -> Int) -> Int# -> Int+--  incLen _ g x = g (x +# 1#)++  length :: [a] -> Nat+  length []     = 0+  length (_:xs) = 1 + length xs++-- Can't be promoted because of limitations of Int promotion+-- Below is a re-implementation using Nat+--  sum                     :: (Num a) => [a] -> a+--  sum     l       = sum' l 0+--    where+--      sum' []     a = a+--      sum' (x:xs) a = sum' xs (a+x)+--+--  product                 :: (Num a) => [a] -> a+--  product l       = prod l 1+--    where+--      prod []     a = a+--      prod (x:xs) a = prod xs (a*x)++  sum                     :: [Nat] -> Nat+  sum     l       = sum' l 0+    where+      sum' []     a = a+      sum' (x:xs) a = sum' xs (a+x)++  product                 :: [Nat] -> Nat+  product l       = prod l 1+    where+      prod []     a = a+      prod (x:xs) a = prod xs (a*x)++-- Functions working on infinite lists don't promote because they create+-- infinite types. replicate also uses integers, but luckily it can be rewritten+--  iterate :: (a -> a) -> a -> [a]+--  iterate f x =  x : iterate f (f x)+--+--  repeat :: a -> [a]+--  repeat x = xs where xs = x : xs+--+--  replicate               :: Int -> a -> [a]+--  replicate n x           =  take n (repeat x)+--+--  cycle                   :: [a] -> [a]+--  cycle []                = error "Data.Singletons.List.cycle: empty list"+--  cycle xs                = xs' where xs' = xs ++ xs'++  replicate               :: Nat -> a -> [a]+  replicate 0 _           = []+  replicate n x           = x : replicate (n-1) x++-- Uses list comprehensions+--  transpose               :: [[a]] -> [[a]]+--  transpose []             = []+--  transpose ([]   : xss)   = transpose xss+--  transpose ((x:xs) : xss) = (x : [h | (h:_) <- xss]) : transpose (xs : [ t | (_:t) <- xss])++  transpose               :: [[a]] -> [[a]]+  transpose []             = []+  transpose ([]   : xss)   = transpose xss+  transpose ((x:xs) : xss) = (x : (map head xss)) : transpose (xs : (map tail xss))++-- Can't be promoted because of limitations of Int promotion+-- Below is a re-implementation using Nat+--  take                   :: Int -> [a] -> [a]+--  take n _      | n <= 0 =  []+--  take _ []              =  []+--  take n (x:xs)          =  x : take (n-1) xs++--  drop                   :: Int -> [a] -> [a]+--  drop n xs     | n <= 0 =  xs+--  drop _ []              =  []+--  drop n (_:xs)          =  drop (n-1) xs++--  splitAt                :: Int -> [a] -> ([a],[a])+--  splitAt n xs           =  (take n xs, drop n xs)++  -- Implementation changed to use case expression to work around #60+  take                   :: Nat -> [a] -> [a]+  take _ []              =  []+  take 0 (_:_)           =  []+  take n (x:xs)          =  x : take (n-1) xs++  drop                   :: Nat -> [a] -> [a]+  drop _ []              =  []+  drop 0 xs@(_:_)        =  xs+  drop n (_:xs)          =  drop (n-1) xs++  splitAt                :: Nat -> [a] -> ([a],[a])+  splitAt n xs           =  (take n xs, drop n xs)+++  takeWhile               :: (a -> Bool) -> [a] -> [a]+  takeWhile _ []          =  []+  takeWhile p (x:xs)+              | p x       =  x : takeWhile p xs+              | otherwise =  []++  dropWhile               :: (a -> Bool) -> [a] -> [a]+  dropWhile _ []          =  []+  dropWhile p xs@(x:xs')+              | p x       =  dropWhile p xs'+              | otherwise =  xs++  dropWhileEnd            :: (a -> Bool) -> [a] -> [a]+  dropWhileEnd p          = foldr (\x xs -> if p x && null xs then [] else x : xs) []++  span                    :: (a -> Bool) -> [a] -> ([a],[a])+  span _ xs@[]            =  (xs, xs)+  span p xs@(x:xs')+           | p x          =  let (ys,zs) = span p xs' in (x:ys,zs)+           | otherwise    =  ([],xs)++  break                   :: (a -> Bool) -> [a] -> ([a],[a])+  break _ xs@[]           =  (xs, xs)+  break p xs@(x:xs')+             | p x        =  ([],xs)+             | otherwise  =  let (ys,zs) = break p xs' in (x:ys,zs)++  -- Overlapping patterns don't singletonize+  stripPrefix :: Eq a => [a] -> [a] -> Maybe [a]+  stripPrefix [] ys = Just ys+  stripPrefix (x:xs) (y:ys)+   | x == y = stripPrefix xs ys+  stripPrefix _ _ = Nothing++  -- Relies on groupBy, which relies on span, which does not singletonize+  group                   :: Eq a => [a] -> [[a]]+  group xs                =  groupBy (==) xs++  -- Requires Ord instance, which does not singletonize+  maximum                 :: (Ord a) => [a] -> a+  maximum []              =  error "Data.Singletons.List.maximum: empty list"+  maximum xs              =  foldl1 max xs++  -- Requires Ord instance, which does not singletonize+  minimum                 :: (Ord a) => [a] -> a+  minimum []              =  error "Data.Singletons.List.minimum: empty list"+  minimum xs              =  foldl1 min xs++  -- Requires Ord instance, which does not singletonize+  insert :: Ord a => a -> [a] -> [a]+  insert e ls = insertBy (compare) e ls++  -- Requires Ord instance, which does not singletonize+  sort :: (Ord a) => [a] -> [a]+  sort = sortBy compare++  -- Relies on span, which does not singletonize+  groupBy                 :: (a -> a -> Bool) -> [a] -> [[a]]+  groupBy _  []           =  []+  groupBy eq (x:xs)       =  (x:ys) : groupBy eq zs+                             where (ys,zs) = span (eq x) xs++  lookup                  :: (Eq a) => a -> [(a,b)] -> Maybe b+  lookup _key []          =  Nothing+  lookup  key ((x,y):xys)+      | key == x          =  Just y+      | otherwise         =  lookup key xys++  -- Relies on filter, which does not singletonize+  find                    :: (a -> Bool) -> [a] -> Maybe a+  find p                  = listToMaybe . filter p++  filter :: (a -> Bool) -> [a] -> [a]+  filter _p []            = []+  filter p (x:xs)+    | p x                 = x : filter p xs+    | otherwise           = filter p xs++  -- Relies on select, which does not singletonize (#30, #33)+  partition               :: (a -> Bool) -> [a] -> ([a],[a])+  partition p xs          = foldr (select p) ([],[]) xs++  -- Lazy pattern removed from select+  select :: (a -> Bool) -> a -> ([a], [a]) -> ([a], [a])+  select p x (ts,fs) | p x       = (x:ts,fs)+                     | otherwise = (ts, x:fs)++-- Can't be promoted because of limitations of Int promotion.+-- Also, #60 and th-desugar #6 get in the way.+-- Below is a re-implementation using Nat+--  (!!)                    :: [a] -> Int -> a+--  xs     !! n | n < 0 =  error "Data.Singletons.List.!!: negative index"+--  []     !! _         =  error "Data.Singletons.List.!!: index too large"+--  (x:_)  !! 0         =  x+--  (_:xs) !! n         =  xs !! (n-1)++  (!!)                    :: [a] -> Nat -> a+  []     !! _ = error "Data.Singletons.List.!!: index too large"+  (x:xs) !! n = if | n == 0    -> x+                   | otherwise -> xs !! (n-1)++-- These three rely on findIndices, which does not promote.+-- Since we have our own implementation of findIndices these are perfectly valid+  elemIndex       :: Eq a => a -> [a] -> Maybe Nat+  elemIndex x     = findIndex (x==)++  elemIndices     :: Eq a => a -> [a] -> [Nat]+  elemIndices x   = findIndices (x==)++  findIndex       :: (a -> Bool) -> [a] -> Maybe Nat+  findIndex p     = listToMaybe . findIndices p++-- Uses list comprehensions, infinite lists and and Ints+--  findIndices      :: (a -> Bool) -> [a] -> [Int]+--  findIndices p xs = [ i | (x,i) <- zip xs [0..], p x]++  findIndices      :: (a -> Bool) -> [a] -> [Nat]+  findIndices p xs = map snd (filter (\(x,_) -> p x)+                                     (zip xs (buildList 0 (length xs))))+    where buildList _ 0 = []+          buildList a n = a : buildList (a+1) (n-1)++  -- To singletonize these we would need to rewrite all patterns+  -- as non-overlapping. This means 2^7 equations for zipWith7.++  zip4                    :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)]+  zip4                    =  zipWith4 (,,,)++  zip5                    :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)]+  zip5                    =  zipWith5 (,,,,)++  zip6                    :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] ->+                              [(a,b,c,d,e,f)]+  zip6                    =  zipWith6 (,,,,,)++  zip7                    :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] ->+                              [g] -> [(a,b,c,d,e,f,g)]+  zip7                    =  zipWith7 (,,,,,,)++  zipWith4                :: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]+  zipWith4 z (a:as) (b:bs) (c:cs) (d:ds)+                          =  z a b c d : zipWith4 z as bs cs ds+  zipWith4 _ _ _ _ _      =  []++  zipWith5                :: (a->b->c->d->e->f) ->+                             [a]->[b]->[c]->[d]->[e]->[f]+  zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es)+                          =  z a b c d e : zipWith5 z as bs cs ds es+  zipWith5 _ _ _ _ _ _    = []++  zipWith6                :: (a->b->c->d->e->f->g) ->+                             [a]->[b]->[c]->[d]->[e]->[f]->[g]+  zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs)+                          =  z a b c d e f : zipWith6 z as bs cs ds es fs+  zipWith6 _ _ _ _ _ _ _  = []++  zipWith7                :: (a->b->c->d->e->f->g->h) ->+                             [a]->[b]->[c]->[d]->[e]->[f]->[g]->[h]+  zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs)+                     =  z a b c d e f g : zipWith7 z as bs cs ds es fs gs+  zipWith7 _ _ _ _ _ _ _ _ = []++  nub                     :: (Eq a) => [a] -> [a]+  nub l                   = nub' l []+    where+      nub' :: [a] -> [a] -> [a]+      nub' [] _           = []+      nub' (x:xs) ls+          | x `elem` ls   = nub' xs ls+          | otherwise     = x : nub' xs (x:ls)++  nubBy                   :: (a -> a -> Bool) -> [a] -> [a]+  nubBy eq l              = nubBy' l []+    where+      nubBy' :: [b] -> [b] -> [b]+      nubBy' [] _         = []+      nubBy' (y:ys) xs+         | elem_by eq y xs = nubBy' ys xs+         | otherwise       = y : nubBy' ys (y:xs)++  elem_by :: (a -> a -> Bool) -> a -> [a] -> Bool+  elem_by _  _ []         =  False+  elem_by eq y (x:xs)     =  y `eq` x || elem_by eq y xs++  -- Relies on nubBy, which does not singletonize+  unionBy                 :: (a -> a -> Bool) -> [a] -> [a] -> [a]+  unionBy eq xs ys        =  xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs++  -- Relies on unionBy, which does not singletonize+  union                   :: (Eq a) => [a] -> [a] -> [a]+  union                   = unionBy (==)++  -- Relies on intersectBy, which does not singletonize+  intersect               :: (Eq a) => [a] -> [a] -> [a]+  intersect               =  intersectBy (==)++-- Uses list comprehensions. Desugared version uses filter, which does+-- not singletonize due to #30+--  intersectBy             :: (a -> a -> Bool) -> [a] -> [a] -> [a]+--  intersectBy _  [] []    =  []+--  intersectBy _  [] (_:_) =  []+--  intersectBy _  (_:_) [] =  []+--  intersectBy eq xs ys    =  [x | x <- xs, any_ (eq x) ys]++  intersectBy             :: (a -> a -> Bool) -> [a] -> [a] -> [a]+  intersectBy _  [] []    =  []+  intersectBy _  [] (_:_) =  []+  intersectBy _  (_:_) [] =  []+  intersectBy eq xs ys    =  filter (\x -> any_ (eq x) ys) xs++-- These functions use Integral or Num typeclass instead of Int.+--+--  genericLength, genericTake, genericDrop, genericSplitAt, genericIndex+--  genericReplicate+--+-- We provide aliases below to improve compatibility++  genericLength :: (Num i) => [a] -> i+  genericLength = length++  genericTake :: (Integral i) => i -> [a] -> [a]+  genericTake = take++  genericDrop :: (Integral i) => i -> [a] -> [a]+  genericDrop = drop++  genericSplitAt :: (Integral i) => i -> [a] -> ([a], [a])+  genericSplitAt = splitAt++  genericIndex :: (Integral i) => [a] -> i -> a+  genericIndex = (!!)++  genericReplicate :: (Integral i) => i -> a -> [a]+  genericReplicate = replicate+ |])
+ src/Data/Promotion/Prelude/Maybe.hs view
@@ -0,0 +1,42 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Promotion.Prelude.Maybe+-- Copyright   :  (C) 2014 Jan Stolarek+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  Jan Stolarek (jan.stolarek@p.lodz.pl)+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Defines promoted functions and datatypes relating to 'Maybe',+-- including a promoted 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.Promotion.Prelude.Maybe (+  -- * Promoted functions from @Data.Maybe@+  maybe_, Maybe_,+  -- | The preceding two definitions is derived from the function 'maybe' in+  -- @Data.Maybe@. The extra underscore is to avoid name clashes with the type+  -- 'Maybe'.++  IsJust, IsNothing, FromJust, FromMaybe, MaybeToList,+  ListToMaybe, CatMaybes, MapMaybe,++  -- * Defunctionalization symbols+  NothingSym0, JustSym0, JustSym1,++  Maybe_Sym0, Maybe_Sym1, Maybe_Sym2, Maybe_Sym3,+  IsJustSym0, IsJustSym1, IsNothingSym0, IsNothingSym1,+  FromJustSym0, FromJustSym1, FromMaybeSym0, FromMaybeSym1, FromMaybeSym2,+  MaybeToListSym0, MaybeToListSym1, ListToMaybeSym0, ListToMaybeSym1,+  CatMaybesSym0, CatMaybesSym1, MapMaybeSym0, MapMaybeSym1, MapMaybeSym2+  ) where++import Data.Singletons.Prelude.Maybe
+ src/Data/Promotion/Prelude/Ord.hs view
@@ -0,0 +1,26 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Promotion.Prelude.Ord+-- Copyright   :  (C) 2014 Jan Stolarek+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  Jan Stolarek (jan.stolarek@p.lodz.pl)+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Provides promoted definitions related to type-level comparisons.+--+-----------------------------------------------------------------------------++module Data.Promotion.Prelude.Ord (+  POrd(..),+  LTSym0, EQSym0, GTSym0,+  CompareSym0, CompareSym1, CompareSym2,+  (:<$), (:<$$), (:<$$$),+  (:<=$), (:<=$$), (:<=$$$),+  (:>$), (:>$$), (:>$$$),+  (:>=$), (:>=$$), (:>=$$$),+  MaxSym0, MaxSym1, MaxSym2,+  MinSym0, MinSym1, MinSym2+  ) where++import Data.Singletons.Prelude.Ord
+ src/Data/Promotion/Prelude/Tuple.hs view
@@ -0,0 +1,39 @@+-- |+-- Module      :  Data.Promotion.Prelude.Tuple+-- Copyright   :  (C) 2014 Jan Stolarek+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  Jan Stolarek (jan.stolarek@p.lodz.pl)+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Defines promoted functions and datatypes relating to tuples,+-- including a promoted 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.Promotion.Prelude.Tuple (+  -- * Promoted functions from @Data.Tuple@+  Fst, Snd, Curry, Uncurry, Swap,++  -- * Defunctionalization symbols+  Tuple0Sym0,+  Tuple2Sym0, Tuple2Sym1, Tuple2Sym2,+  Tuple3Sym0, Tuple3Sym1, Tuple3Sym2, Tuple3Sym3,+  Tuple4Sym0, Tuple4Sym1, Tuple4Sym2, Tuple4Sym3, Tuple4Sym4,+  Tuple5Sym0, Tuple5Sym1, Tuple5Sym2, Tuple5Sym3, Tuple5Sym4, Tuple5Sym5,+  Tuple6Sym0, Tuple6Sym1, Tuple6Sym2, Tuple6Sym3, Tuple6Sym4, Tuple6Sym5, Tuple6Sym6,+  Tuple7Sym0, Tuple7Sym1, Tuple7Sym2, Tuple7Sym3, Tuple7Sym4, Tuple7Sym5, Tuple7Sym6, Tuple7Sym7,++  FstSym0, FstSym1, SndSym0, SndSym1,+  CurrySym0, CurrySym1, CurrySym2, CurrySym3,+  UncurrySym0, UncurrySym1, UncurrySym2,+  SwapSym0, SwapSym1+  ) where++import Data.Singletons.Prelude.Tuple
+ src/Data/Promotion/TH.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE ExplicitNamespaces, CPP #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Promotion.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 promote your own functions via+-- Template Haskell.+--+----------------------------------------------------------------------------++module Data.Promotion.TH (+  -- * Primary Template Haskell generation functions+  promote, promoteOnly, genDefunSymbols, genPromotions,++  -- ** Functions to generate @Eq@ instances+  promoteEqInstances, promoteEqInstance,++  -- ** Functions to generate @Ord@ instances+  promoteOrdInstances, promoteOrdInstance,++  -- ** Functions to generate @Bounded@ instances+  promoteBoundedInstances, promoteBoundedInstance,++  -- ** defunctionalization+  TyFun, Apply, type (@@),++  -- * Auxiliary definitions+  -- | These definitions might be mentioned in code generated by Template Haskell,+  -- so they must be in scope.++  PEq(..), If, (:&&),+  POrd(..),+  Any,+  Proxy(..), KProxy(..), ThenCmp,++  Error, ErrorSym0,+  TrueSym0, FalseSym0,+  LTSym0, EQSym0, GTSym0,+  Tuple0Sym0,+  Tuple2Sym0, Tuple2Sym1, Tuple2Sym2,+  Tuple3Sym0, Tuple3Sym1, Tuple3Sym2, Tuple3Sym3,+  Tuple4Sym0, Tuple4Sym1, Tuple4Sym2, Tuple4Sym3, Tuple4Sym4,+  Tuple5Sym0, Tuple5Sym1, Tuple5Sym2, Tuple5Sym3, Tuple5Sym4, Tuple5Sym5,+  Tuple6Sym0, Tuple6Sym1, Tuple6Sym2, Tuple6Sym3, Tuple6Sym4, Tuple6Sym5, Tuple6Sym6,+  Tuple7Sym0, Tuple7Sym1, Tuple7Sym2, Tuple7Sym3, Tuple7Sym4, Tuple7Sym5, Tuple7Sym6, Tuple7Sym7,++  SuppressUnusedWarnings(..)++ ) where++import Data.Singletons.Types ( Proxy(..) )+import Data.Singletons+import Data.Singletons.Promote+import Data.Singletons.Prelude.Instances+import Data.Singletons.Prelude.Bool+import Data.Singletons.Prelude.Eq+import Data.Singletons.Prelude.Ord+import Data.Singletons.TypeLits+import Data.Singletons.SuppressUnusedWarnings+import GHC.Exts
src/Data/Singletons.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE MagicHash, RankNTypes, PolyKinds, GADTs, DataKinds,-             FlexibleContexts, CPP, TypeFamilies #-}+             FlexibleContexts, CPP, TypeFamilies, TypeOperators,+             UndecidableInstances #-}  ----------------------------------------------------------------------------- -- |@@ -29,7 +30,7 @@ module Data.Singletons (   -- * Main singleton definitions -  Sing,+  Sing(SLambda, applySing),   -- | See also 'Data.Singletons.Prelude.Sing' for exported constructors    SingI(..), SingKind(..),@@ -44,18 +45,31 @@ #endif   withSing, singThat, +  -- ** Defunctionalization+  TyFun, TyCon1, TyCon2, TyCon3, TyCon4, TyCon5, TyCon6, TyCon7,+  Apply, type (@@),++  -- ** 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,+  unSingFun1, unSingFun2, unSingFun3, unSingFun4, unSingFun5,+  unSingFun6, unSingFun7,++-- | These type synonyms are exported only to improve error messages; users+  -- should not have to mention them.+  SingFunction1, SingFunction2, SingFunction3, SingFunction4, SingFunction5,+  SingFunction6, SingFunction7, +   -- * Auxiliary functions   bugInGHC,-  KProxy(..), Proxy(..)+  KProxy(..)   ) where  import Unsafe.Coerce-+import Data.Singletons.Types #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:@@ -125,6 +139,126 @@   where     with_sing_i :: (SingI a => SingInstance a) -> SingInstance a     with_sing_i si = unsafeCoerce (Don'tInstantiate si) s++----------------------------------------------------------------------+---- 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.+data TyFun :: * -> * -> *++-- | Wrapper for converting the normal type-level arrow into a 'TyFun'.+-- For example, given:+--+-- > data Nat = Zero | Succ Nat+-- > type family Map (a :: TyFun 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) -> (TyFun k1 k2) -> *++-- | Similar to 'TyCon1', but for two-parameter type constructors.+data TyCon2 :: (k1 -> k2 -> k3) -> TyFun k1 (TyFun k2 k3 -> *) -> *+data TyCon3 :: (k1 -> k2 -> k3 -> k4) -> TyFun k1 (TyFun k2 (TyFun k3 k4 -> *) -> *) -> *+data TyCon4 :: (k1 -> k2 -> k3 -> k4 -> k5) -> TyFun k1 (TyFun k2 (TyFun k3 (TyFun k4 k5 -> *) -> *) -> *) -> *+data TyCon5 :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6) -> TyFun k1 (TyFun k2 (TyFun k3 (TyFun k4 (TyFun k5 k6 -> *) -> *) -> *) -> *) -> *+data TyCon6 :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7) -> TyFun k1 (TyFun k2 (TyFun k3 (TyFun k4 (TyFun k5 (TyFun k6 k7 -> *) -> *) -> *) -> *) -> *) -> *+data TyCon7 :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7 -> k8) -> TyFun k1 (TyFun k2 (TyFun k3 (TyFun k4 (TyFun k5 (TyFun k6 (TyFun k7 k8 -> *) -> *) -> *) -> *) -> *) -> *) -> *++-- | Type level function application+type family Apply (f :: TyFun k1 k2 -> *) (x :: k1) :: k2+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)++-- | An infix synonym for `Apply`+type a @@ b = Apply a b+infixl 9 @@++----------------------------------------------------------------------+---- Defunctionalized Sing instance and utilities --------------------+----------------------------------------------------------------------++newtype instance Sing (f :: TyFun k1 k2 -> *) =+  SLambda { applySing :: forall t. Sing t -> Sing (f @@ t) }++instance (SingKind ('KProxy :: KProxy k1), SingKind ('KProxy :: KProxy k2))+         => SingKind ('KProxy :: KProxy (TyFun k1 k2 -> *)) where+  type DemoteRep ('KProxy :: KProxy (TyFun k1 k2 -> *)) =+    DemoteRep ('KProxy :: KProxy k1) -> DemoteRep ('KProxy :: KProxy k2)+  fromSing sFun x = withSomeSing x (fromSing . applySing sFun)+  toSing _ = error "Cannot create existentially-quantified singleton functions."++type SingFunction1 f = forall t. Sing t -> Sing (f @@ t)++-- | Use this function when passing a function on singletons as+-- a higher-order function. You will often need an explicit type+-- annotation to get this to work. For example:+--+-- > falses = sMap (singFun1 sNot :: Sing NotSym0)+-- >               (STrue `SCons` STrue `SCons` SNil)+--+-- There are a family of @singFun...@ functions, keyed by the number+-- of parameters of the function.+singFun1 :: Proxy f -> SingFunction1 f -> Sing f+singFun1 _ f = SLambda f++type SingFunction2 f = forall t. Sing t -> SingFunction1 (f @@ t)+singFun2 :: Proxy f -> SingFunction2 f -> Sing f+singFun2 _ f = SLambda (\x -> singFun1 Proxy (f x))++type SingFunction3 f = forall t. Sing t -> SingFunction2 (f @@ t)+singFun3 :: Proxy f -> SingFunction3 f -> Sing f+singFun3 _ f = SLambda (\x -> singFun2 Proxy (f x))++type SingFunction4 f = forall t. Sing t -> SingFunction3 (f @@ t)+singFun4 :: Proxy f -> SingFunction4 f -> Sing f+singFun4 _ f = SLambda (\x -> singFun3 Proxy (f x))++type SingFunction5 f = forall t. Sing t -> SingFunction4 (f @@ t)+singFun5 :: Proxy f -> SingFunction5 f -> Sing f+singFun5 _ f = SLambda (\x -> singFun4 Proxy (f x))++type SingFunction6 f = forall t. Sing t -> SingFunction5 (f @@ t)+singFun6 :: Proxy f -> SingFunction6 f -> Sing f+singFun6 _ f = SLambda (\x -> singFun5 Proxy (f x))++type SingFunction7 f = forall t. Sing t -> SingFunction6 (f @@ t)+singFun7 :: Proxy f -> SingFunction7 f -> Sing f+singFun7 _ f = SLambda (\x -> singFun6 Proxy (f x))++-- | This is the inverse of 'singFun1', and likewise for the other+-- @unSingFun...@ functions.+unSingFun1 :: Proxy f -> Sing f -> SingFunction1 f+unSingFun1 _ sf = applySing sf++unSingFun2 :: Proxy f -> Sing f -> SingFunction2 f+unSingFun2 _ sf x = unSingFun1 Proxy (sf `applySing` x)++unSingFun3 :: Proxy f -> Sing f -> SingFunction3 f+unSingFun3 _ sf x = unSingFun2 Proxy (sf `applySing` x)++unSingFun4 :: Proxy f -> Sing f -> SingFunction4 f+unSingFun4 _ sf x = unSingFun3 Proxy (sf `applySing` x)++unSingFun5 :: Proxy f -> Sing f -> SingFunction5 f+unSingFun5 _ sf x = unSingFun4 Proxy (sf `applySing` x)++unSingFun6 :: Proxy f -> Sing f -> SingFunction6 f+unSingFun6 _ sf x = unSingFun5 Proxy (sf `applySing` x)++unSingFun7 :: Proxy f -> Sing f -> SingFunction7 f+unSingFun7 _ sf x = unSingFun6 Proxy (sf `applySing` x)  ---------------------------------------------------------------------- ---- Convenience -----------------------------------------------------
− 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 view
@@ -16,41 +16,29 @@ -- ---------------------------------------------------------------------------- -module Data.Singletons.CustomStar ( singletonStar ) where+module Data.Singletons.CustomStar (+  singletonStar, +  module Data.Singletons.Prelude.Eq,+  module Data.Singletons.Prelude.Bool+  ) where+ import Language.Haskell.TH import Language.Haskell.TH.Syntax ( Quasi(..) ) import Data.Singletons.Util import Data.Singletons.Promote-import Data.Singletons.Singletons+import Data.Singletons.Promote.Monad+import Data.Singletons.Single.Monad+import Data.Singletons.Single.Data+import Data.Singletons.Syntax+import Data.Singletons.Names 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.--}+import Data.Maybe+import Control.Applicative+import Language.Haskell.TH.Desugar+import Language.Haskell.TH.Desugar.Sweeten+import Data.Singletons.Prelude.Eq+import Data.Singletons.Prelude.Bool  -- | Produce a representation and singleton for the collection of types given. --@@ -84,98 +72,50 @@ singletonStar names = do   kinds <- mapM getKind names   ctors <- zipWithM (mkCtor True) names kinds-  let repDecl = DataD [] repName [] ctors-                      [''Eq, ''Show, ''Read]+  let repDecl = DDataD Data [] 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+  let dataDecl = DataDecl Data repName [] fakeCtors [''Show, ''Read , ''Eq, ''Ord]+  promDecls      <- promoteM_ $ promoteDataDec dataDecl+  singletonDecls <- singDecsM $ singDataD dataDecl+  return $ decsToTH $ repDecl :+                      promDecls +++                      singletonDecls   where -- get the kinds of the arguments to the tycon with the given name-        getKind :: Quasi q => Name -> q [Kind]+        getKind :: Quasi q => Name -> q [DKind]         getKind name = do           info <- reifyWithWarning name-          case info of-            TyConI (DataD (_:_) _ _ _ _) ->+          dinfo <- dsInfo info+          case dinfo of+            DTyConI (DDataD _ (_:_) _ _ _ _) _ ->                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+            DTyConI (DDataD _ [] _ tvbs _ _) _ ->+               return $ map (fromMaybe DStarK . extractTvbKind) tvbs+            DTyConI (DTySynD _ tvbs _) _ ->+               return $ map (fromMaybe DStarK . extractTvbKind) tvbs+            DPrimTyConI _ n _ ->+               return $ replicate n DStarK             _ -> 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 :: Quasi q => Bool -> Name -> [DKind] -> q DCon         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+          dataName <- if real then mkDataName (nameBase name) else return name+          return $ DCon (map DPlainTV vars) [] dataName $+                   DNormalC (map (\ty -> (NotStrict, ty)) types)          -- 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+        kindToType :: Quasi q => DKind -> QWithAux [Name] q DType+        kindToType (DForallK _ _) = fail "Explicit forall encountered in kind"+        kindToType (DVarK n) = do+          addElement n+          return $ DVarT n+        kindToType (DConK n args) = foldType (DConT n) <$> mapM kindToType args+        kindToType (DArrowK 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+          return $ DAppT (DAppT DArrowT t1) t2+        kindToType DStarK = return $ DConT repName -  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/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/Names.hs view
@@ -0,0 +1,243 @@+{- Data/Singletons/Names.hs++(c) Richard Eisenberg 2014+eir@cis.upenn.edu++Defining names and maniuplations on names for use in promotion and singling.+-}++{-# LANGUAGE CPP, TemplateHaskell #-}++module Data.Singletons.Names where++import Data.Singletons+import Data.Singletons.SuppressUnusedWarnings+import Data.Singletons.Types+import Data.Singletons.Decide+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Desugar+import GHC.TypeLits ( Symbol )+import GHC.Exts ( Any )+import Data.Typeable ( TypeRep )+import Data.Singletons.Util++anyTypeName, boolName, andName, tyEqName, tyCompareName, tyminBoundName,+  tymaxBoundName, repName,+  nilName, consName, listName, tyFunName,+  applyName, symbolName, undefinedName, typeRepName, stringName,+  eqName, ordName, boundedName, orderingName, ordLTSymName, ordEQSymName,+  ordGTSymName,+  singFamilyName, singIName, singMethName, demoteRepName,+  singKindClassName, sEqClassName, sEqMethName, sconsName, snilName,+  sIfName, kProxyDataName, kProxyTypeName, proxyTypeName, proxyDataName,+  someSingTypeName, someSingDataName,+  sListName, sDecideClassName, sDecideMethName,+  provedName, disprovedName, reflName, toSingName, fromSingName,+  equalityName, applySingName, suppressClassName, suppressMethodName,+  tyThenCmpName, kindOfName :: Name+anyTypeName = ''Any+boolName = ''Bool+andName = '(&&)+tyCompareName = mkName "Compare"+tyminBoundName = mkName "MinBound"+tymaxBoundName = mkName "MaxBound"+tyEqName = mkName ":=="+repName = mkName "Rep"+nilName = '[]+consName = '(:)+listName = ''[]+tyFunName = ''TyFun+applyName = ''Apply+symbolName = ''Symbol+undefinedName = 'undefined+typeRepName = ''TypeRep+stringName = ''String+eqName = ''Eq+ordName = ''Ord+boundedName = ''Bounded+orderingName = ''Ordering+ordLTSymName = mkName "LTSym0"+ordEQSymName = mkName "EQSym0"+ordGTSymName = mkName "GTSym0"+singFamilyName = ''Sing+singIName = ''SingI+singMethName = 'sing+toSingName = 'toSing+fromSingName = 'fromSing+demoteRepName = ''DemoteRep+singKindClassName = ''SingKind+sEqClassName = mkName "SEq"+sEqMethName = mkName "%:=="+sIfName = mkName "sIf"+sconsName = mkName "SCons"+snilName = mkName "SNil"+kProxyDataName = 'KProxy+kProxyTypeName = ''KProxy+someSingTypeName = ''SomeSing+someSingDataName = 'SomeSing+proxyTypeName = ''Proxy+proxyDataName = 'Proxy+sListName = mkName "SList"+sDecideClassName = ''SDecide+sDecideMethName = '(%~)+provedName = 'Proved+disprovedName = 'Disproved+reflName = 'Refl+equalityName = ''(~)+applySingName = 'applySing+suppressClassName = ''SuppressUnusedWarnings+suppressMethodName = 'suppressUnusedWarnings+tyThenCmpName = mkName "ThenCmp"+kindOfName = ''KindOf++mkTupleName :: Int -> Name+mkTupleName n = mkName $ "STuple" ++ (show n)++-- used when a value name appears in a pattern context+-- works only for proper variables (lower-case names)+promoteValNameLhs :: Name -> Name+promoteValNameLhs = upcase++-- like promoteValNameLhs, but adds a prefix to the promoted name+promoteValNameLhsPrefix :: String -> Name -> Name+promoteValNameLhsPrefix prefix = mkName . (prefix ++) . toUpcaseStr++-- used when a value name appears in an expression context+-- works for both variables and datacons+promoteValRhs :: Name -> DType+promoteValRhs name+  | name == nilName+  = DConT nilName   -- workaround for #21++  | otherwise+  = DConT $ promoteTySym name 0++-- generates type-level symbol for a given name. Int parameter represents+-- saturation: 0 - no parameters passed to the symbol, 1 - one parameter+-- passed to the symbol, and so on. Works on both promoted and unpromoted+-- names.+promoteTySym :: Name -> Int -> Name+promoteTySym name sat+    | name == undefinedName+    = anyTypeName++    | Just degree <- tupleNameDegree_maybe name+    = mkName $ "Tuple" ++ show degree ++ "Sym" ++ (show sat)++       -- treat unboxed tuples like tuples+    | Just degree <- unboxedTupleNameDegree_maybe name+    = mkName $ "Tuple" ++ show degree ++ "Sym" ++ (show sat)++    | otherwise+    = let capped = toUpcaseStr name in+      if isHsLetter (head capped)+      then mkName (capped ++ "Sym" ++ (show sat))+      else mkName (capped ++ (replicate (sat + 1) '$'))++promoteClassName :: Name -> Name+promoteClassName = prefixUCName "P" "#"++-- produce the silly type class used to store the type variables for+-- a class+classTvsName :: Name -> Name+classTvsName = suffixName "TyVars" "^^^"++mkTyName :: Quasi q => Name -> q Name+mkTyName tmName = do+  let nameStr  = nameBase tmName+      symbolic = not (isHsLetter (head nameStr))+  qNewName (if symbolic then "ty" else nameStr)++falseTySym :: DType+falseTySym = promoteValRhs falseName++trueTySym :: DType+trueTySym = promoteValRhs trueName++boolKi :: DKind+boolKi = DConK boolName []++andTySym :: DType+andTySym = promoteValRhs andName++-- make a Name with an unknown kind into a DTyVarBndr.+-- Uses a fresh kind variable for GHC 7.6.3 and PlainTV for 7.8++-- because 7.8+ has kind inference+inferKindTV :: Quasi q => Name -> q DTyVarBndr+inferKindTV n = do+#if __GLASGOW_HASKELL__ < 707+  ki <- fmap DVarK $ qNewName "k"+  return $ DKindedTV n _ki+#else+  return $ DPlainTV n+#endif++inferMaybeKindTV :: Quasi q => Name -> Maybe DKind -> q DTyVarBndr+inferMaybeKindTV n Nothing =+#if __GLASGOW_HASKELL__ < 707+  do k <- qNewName "k"+     return $ DKindedTV n (DVarK k)+#else+  return $ DPlainTV n+#endif+inferMaybeKindTV n (Just k) = return $ DKindedTV n k++-- similar to above, this is for annotating the result kind of+-- a closed type family. Makes it polymorphic in 7.6.3, inferred+-- in 7.8+unknownResult :: DKind -> Maybe DKind+#if __GLASGOW_HASKELL__ < 707+unknownResult = Just+#else+unknownResult = const Nothing+#endif++-- Singletons++singDataConName :: Name -> Name+singDataConName nm+  | nm == nilName                                  = snilName+  | nm == consName                                 = sconsName+  | Just degree <- tupleNameDegree_maybe nm        = mkTupleName degree+  | Just degree <- unboxedTupleNameDegree_maybe nm = mkTupleName degree+  | otherwise                                      = prefixUCName "S" ":%" nm++singTyConName :: Name -> Name+singTyConName name+  | name == listName                                 = sListName+  | Just degree <- tupleNameDegree_maybe name        = mkTupleName degree+  | Just degree <- unboxedTupleNameDegree_maybe name = mkTupleName degree+  | otherwise                                        = prefixUCName "S" ":%" name++singClassName :: Name -> Name+singClassName = singTyConName++singValName :: Name -> Name+singValName n+  | n == undefinedName       = undefinedName+     -- avoid unused variable warnings+  | head (nameBase n) == '_' = (prefixLCName "_s" "%") $ n+  | otherwise                = (prefixLCName "s" "%") $ upcase n++kindParam :: DKind -> DType+kindParam k = DSigT (DConT kProxyDataName) (DConK kProxyTypeName [k])++proxyFor :: DType -> DExp+proxyFor ty = DSigE (DConE proxyDataName) (DAppT (DConT proxyTypeName) ty)++singFamily :: DType+singFamily = DConT singFamilyName++singKindConstraint :: DKind -> DPred+singKindConstraint k = DAppPr (DConPr singKindClassName) (kindParam k)++demote :: DType+demote = DConT demoteRepName++apply :: DType -> DType -> DType+apply t1 t2 = DAppT (DAppT (DConT applyName) t1) t2++-- apply a type to a list of types using Apply type family+-- This is defined here, not in Utils, to avoid cyclic dependencies+foldApply :: DType -> [DType] -> DType+foldApply = foldl apply
src/Data/Singletons/Prelude.hs view
@@ -17,6 +17,7 @@ -- ---------------------------------------------------------------------------- +{-# LANGUAGE ExplicitNamespaces #-} module Data.Singletons.Prelude (   -- * Basic singleton definitions   module Data.Singletons,@@ -78,29 +79,118 @@   STuple0, STuple2, STuple3, STuple4, STuple5, STuple6, STuple7,    -- * Functions working with 'Bool'-  If, sIf, Not, sNot, (:&&), (:||), (%:&&), (%:||),--  -- * Functions working with lists-  Head, Tail, (:++), (%:++),+  If, sIf, Not, sNot, (:&&), (:||), (%:&&), (%:||), Otherwise, sOtherwise,    -- * Error reporting-  Error, sError,+  Error, ErrorSym0, sError,    -- * Singleton equality-  module Data.Singletons.Eq,+  module Data.Singletons.Prelude.Eq, +  -- * Singleton comparisons+  module Data.Singletons.Prelude.Ord,++  -- ** Miscellaneous functions+  Id, sId, Const, sConst, (:.), (%:.), type ($), (%$), type ($!), (%$!),+  Flip, sFlip, AsTypeOf, sAsTypeOf,+  Seq, sSeq,++  -- * List operations+  Map, sMap, (:++), (%:++), Head, sHead, Last, sLast, Tail, sTail,+  Init, sInit, Null, sNull, Reverse, sReverse,+  -- ** Reducing lists (folds)+  Foldl, sFoldl, Foldl1, sFoldl1, Foldr, sFoldr, Foldr1, sFoldr1,+  -- *** Special folds+  And, sAnd, Or, sOr, Any_, sAny_, All, sAll,+  Concat, sConcat, ConcatMap, sConcatMap,+  -- *** Scans+  Scanl, sScanl, Scanl1, sScanl1, Scanr, sScanr, Scanr1, sScanr1,+  -- ** Searching lists+  Elem, sElem, NotElem, sNotElem,+  -- ** Zipping and unzipping lists+  Zip, sZip, Zip3, sZip3, ZipWith, sZipWith, ZipWith3, sZipWith3,+  Unzip, sUnzip, Unzip3, sUnzip3,+   -- * Other datatypes   Maybe_, sMaybe_,   Either_, sEither_,-  Fst, sFst, Snd, sSnd, Curry, sCurry, Uncurry, sUncurry+  Fst, sFst, Snd, sSnd, Curry, sCurry, Uncurry, sUncurry,+  Symbol,++  -- * Other functions+  either_, -- reimplementation of either to be used with singletons library+  maybe_,+  bool_,+  any_,++  -- * Defunctionalization symbols+  FalseSym0, TrueSym0,+  NotSym0, NotSym1, (:&&$), (:&&$$), (:&&$$$), (:||$), (:||$$), (:||$$$),+  OtherwiseSym0,++  NothingSym0, JustSym0, JustSym1,+  Maybe_Sym0, Maybe_Sym1, Maybe_Sym2, Maybe_Sym3,++  LeftSym0, LeftSym1, RightSym0, RightSym1,+  Either_Sym0, Either_Sym1, Either_Sym2, Either_Sym3,++  Tuple0Sym0,+  Tuple2Sym0, Tuple2Sym1, Tuple2Sym2,+  Tuple3Sym0, Tuple3Sym1, Tuple3Sym2, Tuple3Sym3,+  Tuple4Sym0, Tuple4Sym1, Tuple4Sym2, Tuple4Sym3, Tuple4Sym4,+  Tuple5Sym0, Tuple5Sym1, Tuple5Sym2, Tuple5Sym3, Tuple5Sym4, Tuple5Sym5,+  Tuple6Sym0, Tuple6Sym1, Tuple6Sym2, Tuple6Sym3, Tuple6Sym4, Tuple6Sym5, Tuple6Sym6,+  Tuple7Sym0, Tuple7Sym1, Tuple7Sym2, Tuple7Sym3, Tuple7Sym4, Tuple7Sym5, Tuple7Sym6, Tuple7Sym7,+  FstSym0, FstSym1, SndSym0, SndSym1,+  CurrySym0, CurrySym1, CurrySym2, CurrySym3,+  UncurrySym0, UncurrySym1, UncurrySym2,++  IdSym0, IdSym1, ConstSym0, ConstSym1, ConstSym2,+  (:.$), (:.$$), (:.$$$),+  type ($$), type ($$$), type ($$$$),+  type ($!$), type ($!$$), type ($!$$$),+  FlipSym0, FlipSym1, FlipSym2,+  AsTypeOfSym0, AsTypeOfSym1, AsTypeOfSym2, SeqSym0, SeqSym1, SeqSym2,++  (:$), (:$$), (:$$$), NilSym0, ConsSym0, ConsSym1, ConsSym2,+  MapSym0, MapSym1, MapSym2, ReverseSym0, ReverseSym1,+  (:++$$), (:++$), HeadSym0, HeadSym1, LastSym0, LastSym1,+  TailSym0, TailSym1, InitSym0, InitSym1, NullSym0, NullSym1,++  FoldlSym0, FoldlSym1, FoldlSym2, FoldlSym3,+  Foldl1Sym0, Foldl1Sym1, Foldl1Sym2,+  FoldrSym0, FoldrSym1, FoldrSym2, FoldrSym3,+  Foldr1Sym0, Foldr1Sym1, Foldr1Sym2,++  ConcatSym0, ConcatSym1,+  ConcatMapSym0, ConcatMapSym1, ConcatMapSym2,+  AndSym0, AndSym1, OrSym0, OrSym1,+  Any_Sym0, Any_Sym1, Any_Sym2,+  AllSym0, AllSym1, AllSym2,++  ScanlSym0, ScanlSym1, ScanlSym2, ScanlSym3,+  Scanl1Sym0, Scanl1Sym1, Scanl1Sym2,+  ScanrSym0, ScanrSym1, ScanrSym2, ScanrSym3,+  Scanr1Sym0, Scanr1Sym1, Scanr1Sym2,++  ElemSym0, ElemSym1, ElemSym2,+  NotElemSym0, NotElemSym1, NotElemSym2,++  ZipSym0, ZipSym1, ZipSym2,+  Zip3Sym0, Zip3Sym1, Zip3Sym2, Zip3Sym3,+  ZipWithSym0, ZipWithSym1, ZipWithSym2, ZipWithSym3,+  ZipWith3Sym0, ZipWith3Sym1, ZipWith3Sym2, ZipWith3Sym3,+  UnzipSym0, UnzipSym1   ) 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.Prelude.Base+import Data.Singletons.Prelude.Bool+import Data.Singletons.Prelude.Either+import Data.Singletons.Prelude.List+import Data.Singletons.Prelude.Maybe+import Data.Singletons.Prelude.Tuple+import Data.Singletons.Prelude.Eq+import Data.Singletons.Prelude.Ord+import Data.Singletons.Prelude.Instances import Data.Singletons.TypeLits
+ src/Data/Singletons/Prelude/Base.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE CPP, TemplateHaskell, KindSignatures, PolyKinds, TypeOperators,+             DataKinds, ScopedTypeVariables, TypeFamilies, GADTs,+             UndecidableInstances, BangPatterns #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Singletons.Prelude.Base+-- Copyright   :  (C) 2014 Jan Stolarek+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  Jan Stolarek (jan.stolarek@p.lodz.pl)+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Implements singletonized versions of functions from @GHC.Base@ module.+--+-- 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.Prelude.Base (+  -- * Basic functions+  Foldr, sFoldr, Map, sMap, (:++), (%:++), Otherwise, sOtherwise,+  Id, sId, Const, sConst, (:.), (%:.), type ($), type ($!), (%$), (%$!),+  Flip, sFlip, AsTypeOf, sAsTypeOf,+  Seq, sSeq,++  -- * Defunctionalization symbols+  FoldrSym0, FoldrSym1, FoldrSym2, FoldrSym3,+  MapSym0, MapSym1, MapSym2,+  (:++$), (:++$$),+  OtherwiseSym0,+  IdSym0, IdSym1,+  ConstSym0, ConstSym1, ConstSym2,+  (:.$), (:.$$), (:.$$$),+  type ($$), type ($$$), type ($$$$),+  type ($!$), type ($!$$), type ($!$$$),+  FlipSym0, FlipSym1, FlipSym2,+  AsTypeOfSym0, AsTypeOfSym1, AsTypeOfSym2,+  SeqSym0, SeqSym1, SeqSym2+  ) where++import Data.Singletons.Prelude.Instances+import Data.Singletons.TH+import Data.Singletons.Prelude.Bool++-- Promoted and singletonized versions of "otherwise" are imported and+-- re-exported from Data.Singletons.Prelude.Bool. This is done to avoid cyclic+-- module dependencies.++$(singletonsOnly [d|+  foldr                   :: (a -> b -> b) -> b -> [a] -> b+  foldr k z = go+            where+              go []     = z+              go (y:ys) = y `k` go ys++  map                     :: (a -> b) -> [a] -> [b]+  map _ []                = []+  map f (x:xs)            = f x : map f xs++  (++)                    :: [a] -> [a] -> [a]+  (++) []     ys          = ys+  (++) (x:xs) ys          = x : xs ++ ys++  id                      :: a -> a+  id x                    =  x++  const                   :: a -> b -> a+  const x _               =  x++  (.)    :: (b -> c) -> (a -> b) -> a -> c+  (.) f g = \x -> f (g x)++  flip                    :: (a -> b -> c) -> b -> a -> c+  flip f x y              =  f y x++  asTypeOf                :: a -> a -> a+  asTypeOf                =  const++  -- This is not part of GHC.Base, but we need to emulate seq and this is a good+  -- place to do it.+  seq :: a -> b -> b+  seq _ x = x+ |])++-- ($) is a special case, because its kind-inference data constructors+-- clash with (:). See #29.+type family (f :: TyFun a b -> *) $ (x :: a) :: b+type instance f $ x = f @@ x++data ($$) :: TyFun (TyFun a b -> *) (TyFun a b -> *) -> *+type instance Apply ($$) arg = ($$$) arg++data ($$$) :: (TyFun a b -> *) -> TyFun a b -> *+type instance Apply (($$$) f) arg = ($$$$) f arg++type ($$$$) a b = ($) a b++(%$) :: forall (f :: TyFun a b -> *) (x :: a).+        Sing f -> Sing x -> Sing (($$) @@ f @@ x)+f %$ x = applySing f x++type family (f :: TyFun a b -> *) $! (x :: a) :: b+type instance f $! x = f @@ x++data ($!$) :: TyFun (TyFun a b -> *) (TyFun a b -> *) -> *+type instance Apply ($!$) arg = ($!$$) arg++data ($!$$) :: (TyFun a b -> *) -> TyFun a b -> *+type instance Apply (($!$$) f) arg = ($!$$$) f arg++type ($!$$$) a b = ($!) a b++(%$!) :: forall (f :: TyFun a b -> *) (x :: a).+        Sing f -> Sing x -> Sing (($!$) @@ f @@ x)+f %$! x = applySing f x
+ src/Data/Singletons/Prelude/Bool.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE TemplateHaskell, DataKinds, PolyKinds, TypeFamilies, TypeOperators,+             GADTs, CPP, ScopedTypeVariables, DeriveDataTypeable #-}++#if __GLASGOW_HASKELL__ < 707+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+#endif++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Singletons.Prelude.Bool+-- Copyright   :  (C) 2013-2014 Richard Eisenberg, Jan Stolarek+-- 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.Prelude.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_, Bool_, sBool_, Otherwise, sOtherwise,++  -- * Defunctionalization symbols+  TrueSym0, FalseSym0,++  NotSym0, NotSym1,+  (:&&$), (:&&$$), (:&&$$$),+  (:||$), (:||$$), (:||$$$),+  Bool_Sym0, Bool_Sym1, Bool_Sym2, Bool_Sym3,+  OtherwiseSym0+  ) where++import Data.Singletons+import Data.Singletons.Prelude.Instances+import Data.Singletons.Single+import Data.Singletons.Types++$(singletons [d|+  bool_ :: a -> a -> Bool -> a+  bool_ fls _tru False = fls+  bool_ _fls tru True  = tru+ |])++$(singletonsOnly [d|+  (&&) :: Bool -> Bool -> Bool+  False && _ = False+  True  && x = x++  (||) :: Bool -> Bool -> Bool+  False || x = x+  True  || _ = True++  not :: Bool -> Bool+  not False = True+  not True = False++  otherwise               :: Bool+  otherwise               =  True+  |])++-- | Conditional over singletons+sIf :: Sing a -> Sing b -> Sing c -> Sing (If a b c)+sIf STrue b _ = b+sIf SFalse _ c = c
+ src/Data/Singletons/Prelude/Either.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TypeFamilies, GADTs,+             DataKinds, PolyKinds, RankNTypes, UndecidableInstances, CPP #-}++#if __GLASGOW_HASKELL__ < 707+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+#endif++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Singletons.Prelude.Either+-- Copyright   :  (C) 2013-2014 Richard Eisenberg, Jan Stolarek+-- 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.Prelude.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_, 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,++  -- * Defunctionalization symbols+  LeftSym0, LeftSym1, RightSym0, RightSym1,++  Either_Sym0, Either_Sym1, Either_Sym2, Either_Sym3,+  LeftsSym0, LeftsSym1, RightsSym0, RightsSym1,+  IsLeftSym0, IsLeftSym1, IsRightSym0, IsRightSym1+  ) where++import Data.Singletons.Prelude.Instances+import Data.Singletons.TH+import Data.Singletons.Prelude.Base++$(singletons [d|+  -- Renamed to avoid name clash+  -- | 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+ |])++$(singletonsOnly [d|+  -- | Extracts from a list of 'Either' all the 'Left' elements+  -- All the 'Left' elements are extracted in order.++  -- Modified to avoid list comprehensions+  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.++  -- Modified to avoid list comprehensions+  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 = foldr (either_ left right) ([],[])+   where+    left  a (l, r) = (a:l, r)+    right a (l, r) = (l, a:r)++  -- | 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/Prelude/Eq.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE TypeOperators, DataKinds, PolyKinds, TypeFamilies,+             RankNTypes, FlexibleContexts, TemplateHaskell,+             UndecidableInstances, GADTs, CPP, DefaultSignatures #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Singletons.Prelude.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.Prelude.Eq (+  PEq(..), SEq(..),+  (:==$), (:==$$), (:==$$$), (:/=$), (:/=$$), (:/=$$$)+  ) where++import Data.Singletons.Prelude.Bool+import Data.Singletons+import Data.Singletons.Single+import Data.Singletons.Prelude.Instances+import Data.Singletons.Util+import Data.Singletons.Promote++#if __GLASGOW_HASKELL__ >= 707+import Data.Type.Equality+#endif++-- | The promoted analogue of 'Eq'. If you supply no definition for '(:==)' under+-- GHC 7.8+, then it defaults to a use of '(==)', from @Data.Type.Equality@.+class kproxy ~ 'KProxy => PEq (kproxy :: KProxy a) where+  type (:==) (x :: a) (y :: a) :: Bool+  type (:/=) (x :: a) (y :: a) :: Bool++#if __GLASGOW_HASKELL__ < 707+  type (x :: a) :== (y :: a) = Not (x :/= y)+#else+  type (x :: a) :== (y :: a) = x == y+#endif+  type (x :: a) :/= (y :: a) = Not (x :== y)++$(genDefunSymbols [''(:==), ''(:/=)])++-- | 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)+  default (%:/=) :: forall (a :: k) (b :: k).+                    ((a :/= b) ~ Not (a :== b))+                 => Sing a -> Sing b -> Sing (a :/= b)+  a %:/= b = sNot (a %:== b)++$(singEqInstances basicTypes)
+ src/Data/Singletons/Prelude/Instances.hs view
@@ -0,0 +1,28 @@+{- 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.Prelude.Instances where++import Data.Singletons.Single+import Data.Singletons.Util++-- some useful singletons+$(genSingletons basicTypes)+$(singDecideInstances basicTypes)
+ src/Data/Singletons/Prelude/List.hs view
@@ -0,0 +1,507 @@+{-# LANGUAGE CPP, TypeOperators, DataKinds, PolyKinds, TypeFamilies,+             TemplateHaskell, GADTs, UndecidableInstances, RankNTypes,+             ScopedTypeVariables, FlexibleContexts #-}++#if __GLASGOW_HASKELL__ < 707+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Singletons.Prelude.List+-- Copyright   :  (C) 2013-2014 Richard Eisenberg, Jan Stolarek+-- 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.Prelude.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@++  -- * Basic functions+  (:++), (%:++), Head, sHead, Last, sLast, Tail, sTail, Init, sInit,+  Null, sNull,++   -- * List transformations+  Map, sMap, Reverse, sReverse, Intersperse, sIntersperse,+  Intercalate, sIntercalate, Subsequences, sSubsequences,+  Permutations, sPermutations,++  -- * Reducing lists (folds)+  Foldl, sFoldl, Foldl', sFoldl', Foldl1, sFoldl1, Foldl1', sFoldl1',+  Foldr, sFoldr, Foldr1, sFoldr1,++  -- ** Special folds+  Concat, sConcat, ConcatMap, sConcatMap,+  And, sAnd, Or, sOr, Any_, sAny_, All, sAll,+  any_, -- equivalent of Data.List `any`. Avoids name clash with Any type++  -- * Building lists++  -- ** Scans+  Scanl, sScanl, Scanl1, sScanl1, Scanr, sScanr, Scanr1, sScanr1,++  -- ** Accumulating maps+  MapAccumL, sMapAccumL, MapAccumR, sMapAccumR,++  -- ** Unfolding+  Unfoldr, sUnfoldr,++  -- * Sublists++  -- ** Extracting sublists+  Inits, sInits, Tails, sTails,++  -- ** Predicates+  IsPrefixOf, sIsPrefixOf, IsSuffixOf, sIsSuffixOf, IsInfixOf, sIsInfixOf,++  -- * Searching lists++  -- ** Searching by equality+  Elem, sElem, NotElem, sNotElem,++  -- * Zipping and unzipping lists+  Zip, sZip, Zip3, sZip3, ZipWith, sZipWith, ZipWith3, sZipWith3,+  Unzip, sUnzip, Unzip3, sUnzip3, Unzip4, sUnzip4,+  Unzip5, sUnzip5, Unzip6, sUnzip6, Unzip7, sUnzip7,++  -- * Special lists++  -- ** \"Set\" operations+  Delete, sDelete, (:\\), (%:\\),++  -- ** Ordered lists+  -- Insert, sInsert, Sort, sSort,++  -- * Generalized functions++  -- ** The \"@By@\" operations+  DeleteBy, sDeleteBy, DeleteFirstsBy, sDeleteFirstsBy,++  SortBy, sSortBy, InsertBy, sInsertBy,+  MaximumBy, sMaximumBy, MinimumBy, sMinimumBy,++  -- * Defunctionalization symbols+  (:$), (:$$), (:$$$),+  NilSym0, ConsSym0, ConsSym1, ConsSym2,++  (:++$$), (:++$), HeadSym0, HeadSym1, LastSym0, LastSym1,+  TailSym0, TailSym1, InitSym0, InitSym1, NullSym0, NullSym1,++  MapSym0, MapSym1, MapSym2, ReverseSym0, ReverseSym1,+  IntersperseSym0, IntersperseSym1, IntersperseSym2,+  IntercalateSym0, IntercalateSym1, IntercalateSym2,+  SubsequencesSym0, SubsequencesSym1,+  PermutationsSym0, PermutationsSym1,++  FoldlSym0, FoldlSym1, FoldlSym2, FoldlSym3,+  Foldl'Sym0, Foldl'Sym1, Foldl'Sym2, Foldl'Sym3,+  Foldl1Sym0, Foldl1Sym1, Foldl1Sym2,+  Foldl1'Sym0, Foldl1'Sym1, Foldl1'Sym2,+  FoldrSym0, FoldrSym1, FoldrSym2, FoldrSym3,+  Foldr1Sym0, Foldr1Sym1, Foldr1Sym2,++  ConcatSym0, ConcatSym1,+  ConcatMapSym0, ConcatMapSym1, ConcatMapSym2,+  AndSym0, AndSym1, OrSym0, OrSym1,+  Any_Sym0, Any_Sym1, Any_Sym2,+  AllSym0, AllSym1, AllSym2,++  ScanlSym0, ScanlSym1, ScanlSym2, ScanlSym3,+  Scanl1Sym0, Scanl1Sym1, Scanl1Sym2,+  ScanrSym0, ScanrSym1, ScanrSym2, ScanrSym3,+  Scanr1Sym0, Scanr1Sym1, Scanr1Sym2,++  MapAccumLSym0, MapAccumLSym1, MapAccumLSym2, MapAccumLSym3,+  MapAccumRSym0, MapAccumRSym1, MapAccumRSym2, MapAccumRSym3,++  UnfoldrSym0, UnfoldrSym1, UnfoldrSym2,++  InitsSym0, InitsSym1, TailsSym0, TailsSym1,++  IsPrefixOfSym0, IsPrefixOfSym1, IsPrefixOfSym2,+  IsSuffixOfSym0, IsSuffixOfSym1, IsSuffixOfSym2,+  IsInfixOfSym0, IsInfixOfSym1, IsInfixOfSym2,++  ElemSym0, ElemSym1, ElemSym2,+  NotElemSym0, NotElemSym1, NotElemSym2,++  ZipSym0, ZipSym1, ZipSym2,+  Zip3Sym0, Zip3Sym1, Zip3Sym2, Zip3Sym3,+  ZipWithSym0, ZipWithSym1, ZipWithSym2, ZipWithSym3,+  ZipWith3Sym0, ZipWith3Sym1, ZipWith3Sym2, ZipWith3Sym3,+  UnzipSym0, UnzipSym1,+  Unzip3Sym0, Unzip3Sym1,+  Unzip4Sym0, Unzip4Sym1,+  Unzip5Sym0, Unzip5Sym1,+  Unzip6Sym0, Unzip6Sym1,+  Unzip7Sym0, Unzip7Sym1,++  DeleteSym0, DeleteSym1, DeleteSym2,+  (:\\$), (:\\$$), (:\\$$$),++  -- InsertSym0, InsertSym1, InsertSym2,+  -- SortSym0, SortSym1,++  DeleteBySym0, DeleteBySym1, DeleteBySym2, DeleteBySym3,+  DeleteFirstsBySym0, DeleteFirstsBySym1, DeleteFirstsBySym2, DeleteFirstsBySym3,++  SortBySym0, SortBySym1, SortBySym2,+  InsertBySym0, InsertBySym1, InsertBySym2, InsertBySym3,+  MaximumBySym0, MaximumBySym1, MaximumBySym2,+  MinimumBySym0, MinimumBySym1, MinimumBySym2,+  ) where++import Data.Singletons+import Data.Singletons.Prelude.Instances+import Data.Singletons.Single+import Data.Singletons.TypeLits+import Data.Singletons.Prelude.Base+import Data.Singletons.Prelude.Bool+import Data.Singletons.Prelude.Eq++$(singletons [d|+  any_                     :: (a -> Bool) -> [a] -> Bool+  any_ _ []                = False+  any_ p (x:xs)            = p x || any_ p xs+ |])++$(singletonsOnly [d|+  head :: [a] -> a+  head (a : _) = a+  head []      = error "Data.Singletons.List.head: empty list"++  last :: [a] -> a+  last []      =  error "Data.Singletons.List.last: empty list"+  last (x:xs)  =  last' x xs+    where last' :: a -> [a] -> a+          last' y []     = y+          last' _ (y:ys) = last' y ys++  tail :: [a] -> [a]+  tail (_ : t) = t+  tail []      = error "Data.Singletons.List.tail: empty list"++  init                    :: [a] -> [a]+  init []                 =  error "Data.Singletons.List.init: empty list"+  init (x:xs)             =  init' x xs+     where init' :: a -> [a] -> [a]+           init' _ []     = []+           init' y (z:zs) = y : init' z zs++  null                    :: [a] -> Bool+  null []                 =  True+  null (_:_)              =  False++  reverse                 :: [a] -> [a]+  reverse l =  rev l []+    where+      rev :: [a] -> [a] -> [a]+      rev []     a = a+      rev (x:xs) a = rev xs (x:a)++  intersperse             :: a -> [a] -> [a]+  intersperse _   []      = []+  intersperse sep (x:xs)  = x : prependToAll sep xs++  intercalate :: [a] -> [[a]] -> [a]+  intercalate xs xss = concat (intersperse xs xss)++  subsequences            :: [a] -> [[a]]+  subsequences xs         =  [] : nonEmptySubsequences xs++  nonEmptySubsequences         :: [a] -> [[a]]+  nonEmptySubsequences []      =  []+  nonEmptySubsequences (x:xs)  =  [x] : foldr f [] (nonEmptySubsequences xs)+    where f ys r = ys : (x : ys) : r++  prependToAll            :: a -> [a] -> [a]+  prependToAll _   []     = []+  prependToAll sep (x:xs) = sep : x : prependToAll sep xs++  permutations            :: [a] -> [[a]]+  permutations xs0        =  xs0 : perms xs0 []+    where+      perms []     _  = []+      perms (t:ts) is = foldr interleave (perms ts (t:is)) (permutations is)+        where interleave    xs     r = let (_,zs) = interleave' id xs r in zs+              interleave' _ []     r = (ts, r)+              interleave' f (y:ys) r = let (us,zs) = interleave' (f . (y:)) ys r+                                       in  (y:us, f (t:y:us) : zs)++  foldl        :: (b -> a -> b) -> b -> [a] -> b+  foldl f z0 xs0 = lgo z0 xs0+               where+                 lgo :: b -> [a] -> b+                 lgo z []     =  z+                 lgo z (x:xs) = lgo (f z x) xs++  foldl'           :: forall a b. (b -> a -> b) -> b -> [a] -> b+  foldl' f z0 xs0 = lgo z0 xs0+      where lgo :: b -> [a] -> b+            lgo z []     = z+            lgo z (x:xs) = let z' = f z x in z' `seq` lgo z' xs++  foldl1                  :: (a -> a -> a) -> [a] -> a+  foldl1 f (x:xs)         =  foldl f x xs+  foldl1 _ []             =  error "Data.Singletons.List.foldl1: empty list"++  foldl1'                  :: (a -> a -> a) -> [a] -> a+  foldl1' f (x:xs)         =  foldl' f x xs+  foldl1' _ []             =  error "Data.Singletons.List.foldl1': empty list"++  foldr1                  :: (a -> a -> a) -> [a] -> a+  foldr1 _ [x]            =  x+  foldr1 f (x:xs@(_:_))   =  f x (foldr1 f xs)+  foldr1 _ []             =  error "Data.Singletons.List.foldr1: empty list"++  concat :: [[a]] -> [a]+  concat = foldr (++) []++  concatMap               :: (a -> [b]) -> [a] -> [b]+  concatMap f             =  foldr ((++) . f) []++  and                     :: [Bool] -> Bool+  and []                  =  True+  and (x:xs)              =  x && and xs++  or                      :: [Bool] -> Bool+  or []                   =  False+  or (x:xs)               =  x || or xs++  all                     :: (a -> Bool) -> [a] -> Bool+  all _ []                =  True+  all p (x:xs)            =  p x && all p xs++  scanl         :: (b -> a -> b) -> b -> [a] -> [b]+  scanl f q ls  =  q : (case ls of+                        []   -> []+                        x:xs -> scanl f (f q x) xs)+  scanl1                  :: (a -> a -> a) -> [a] -> [a]+  scanl1 f (x:xs)         =  scanl f x xs+  scanl1 _ []             =  []++  scanr                   :: (a -> b -> b) -> b -> [a] -> [b]+  scanr _ q0 []           =  [q0]+  scanr f q0 (x:xs)       =  case scanr f q0 xs of+                               []     -> error "Data.Singletons.List.scanr: empty list"+                               (q:qs) -> f x q : (q:qs)++  scanr1                  :: (a -> a -> a) -> [a] -> [a]+  scanr1 _ []             =  []+  scanr1 _ [x]            =  [x]+  scanr1 f (x:xs@(_:_))   =  case scanr1 f xs of+                               []     -> error "Data.Singletons.List.scanr1: empty list"+                               (q:qs) -> f x q : (q:qs)++  mapAccumL :: (acc -> x -> (acc, y))+            -> acc+            -> [x]+            -> (acc, [y])+  mapAccumL _ s []        =  (s, [])+  mapAccumL f s (x:xs)    =  (s'',y:ys)+                             where (s', y ) = f s x+                                   (s'',ys) = mapAccumL f s' xs++  mapAccumR :: (acc -> x -> (acc, y))+              -> acc+              -> [x]+              -> (acc, [y])+  mapAccumR _ s []        =  (s, [])+  mapAccumR f s (x:xs)    =  (s'', y:ys)+                             where (s'',y ) = f s' x+                                   (s', ys) = mapAccumR f s xs++  unfoldr      :: (b -> Maybe (a, b)) -> b -> [a]+  unfoldr f b  =+    case f b of+     Just (a,new_b) -> a : unfoldr f new_b+     Nothing        -> []++  inits                   :: [a] -> [[a]]+  inits xs                =  [] : case xs of+                                    []      -> []+                                    x : xs' -> map (x :) (inits xs')++  tails                   :: [a] -> [[a]]+  tails xs                =  xs : case xs of+                                    []      -> []+                                    _ : xs' -> tails xs'++  isPrefixOf              :: (Eq a) => [a] -> [a] -> Bool+  isPrefixOf [] []        =  True+  isPrefixOf [] (_:_)     =  True+  isPrefixOf (_:_) []     =  False+  isPrefixOf (x:xs) (y:ys)=  x == y && isPrefixOf xs ys++  isSuffixOf              :: (Eq a) => [a] -> [a] -> Bool+  isSuffixOf x y          =  reverse x `isPrefixOf` reverse y++  isInfixOf               :: (Eq a) => [a] -> [a] -> Bool+  isInfixOf needle haystack = any_ (isPrefixOf needle) (tails haystack)++  elem                    :: (Eq a) => a -> [a] -> Bool+  elem _ []               = False+  elem x (y:ys)           = x==y || elem x ys++  notElem                 :: (Eq a) => a -> [a] -> Bool+  notElem _ []            =  True+  notElem x (y:ys)        =  x /= y && notElem x ys++  zip :: [a] -> [b] -> [(a,b)]+  zip (x:xs) (y:ys) = (x,y) : zip xs ys+  zip [] []         = []+  zip (_:_) []      = []+  zip [] (_:_)      = []++  zip3 :: [a] -> [b] -> [c] -> [(a,b,c)]+  zip3 (a:as) (b:bs) (c:cs) = (a,b,c) : zip3 as bs cs+  zip3 []     []     []     = []+  zip3 []     []     (_:_)  = []+  zip3 []     (_:_)     []  = []+  zip3 []     (_:_)  (_:_)  = []+  zip3 (_:_)  []     []     = []+  zip3 (_:_)  []     (_:_)  = []+  zip3 (_:_)  (_:_)  []     = []++  zipWith :: (a -> b -> c) -> [a] -> [b] -> [c]+  zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys+  zipWith _ [] []         = []+  zipWith _ (_:_) []      = []+  zipWith _ [] (_:_)      = []++  zipWith3                :: (a->b->c->d) -> [a]->[b]->[c]->[d]+  zipWith3 z (a:as) (b:bs) (c:cs) =  z a b c : zipWith3 z as bs cs+  zipWith3 _ []     []     []     = []+  zipWith3 _ []     []     (_:_)  = []+  zipWith3 _ []     (_:_)     []  = []+  zipWith3 _ []     (_:_)  (_:_)  = []+  zipWith3 _ (_:_)  []     []     = []+  zipWith3 _ (_:_)  []     (_:_)  = []+  zipWith3 _ (_:_)  (_:_)  []     = []++  unzip    :: [(a,b)] -> ([a],[b])+  unzip xs =  foldr (\(a,b) (as,bs) -> (a:as,b:bs)) ([],[]) xs++  -- Lazy patterns removed from unzip+  unzip3                  :: [(a,b,c)] -> ([a],[b],[c])+  unzip3 xs               =  foldr (\(a,b,c) (as,bs,cs) -> (a:as,b:bs,c:cs))+                                   ([],[],[]) xs++  unzip4                  :: [(a,b,c,d)] -> ([a],[b],[c],[d])+  unzip4 xs               =  foldr (\(a,b,c,d) (as,bs,cs,ds) ->+                                          (a:as,b:bs,c:cs,d:ds))+                                   ([],[],[],[]) xs++  unzip5                  :: [(a,b,c,d,e)] -> ([a],[b],[c],[d],[e])+  unzip5 xs               =  foldr (\(a,b,c,d,e) (as,bs,cs,ds,es) ->+                                          (a:as,b:bs,c:cs,d:ds,e:es))+                                   ([],[],[],[],[]) xs++  unzip6                  :: [(a,b,c,d,e,f)] -> ([a],[b],[c],[d],[e],[f])+  unzip6 xs               =  foldr (\(a,b,c,d,e,f) (as,bs,cs,ds,es,fs) ->+                                          (a:as,b:bs,c:cs,d:ds,e:es,f:fs))+                                   ([],[],[],[],[],[]) xs++  unzip7                  :: [(a,b,c,d,e,f,g)] -> ([a],[b],[c],[d],[e],[f],[g])+  unzip7 xs               =  foldr (\(a,b,c,d,e,f,g) (as,bs,cs,ds,es,fs,gs) ->+                                          (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs))+                                   ([],[],[],[],[],[],[]) xs++-- We can't promote any of these functions because at the type level+-- String literals are no longer considered to be lists of Chars, so+-- there is mismatch between term-level and type-level semantics+--  lines                   :: String -> [String]+--  lines ""                =  []+--  lines s                 =  cons (case break (== '\n') s of+--                                      (l, s') -> (l, case s' of+--                                                      []      -> []+--                                                      _:s''   -> lines s''))+--      where+--        cons ~(h, t)        =  h : t+--+--  unlines                 :: [String] -> String+--  unlines                 =  concatMap (++ "\n")+--+--  words                   :: String -> [String]+--  words s                 =  case dropWhile isSpace s of+--                                  "" -> []+--                                  s' -> w : words s''+--                                        where (w, s'') =+--                                               break isSpace s'+--+--  unwords                 :: [String] -> String+--  unwords []              =  ""+--  unwords ws              =  foldr1 (\w s -> w ++ ' ':s) ws++  delete                  :: (Eq a) => a -> [a] -> [a]+  delete                  =  deleteBy (==)++  (\\)                    :: (Eq a) => [a] -> [a] -> [a]+  (\\)                    =  foldl (flip delete)++  deleteBy                :: (a -> a -> Bool) -> a -> [a] -> [a]+  deleteBy _  _ []        = []+  deleteBy eq x (y:ys)    = if x `eq` y then ys else y : deleteBy eq x ys++  deleteFirstsBy          :: (a -> a -> Bool) -> [a] -> [a] -> [a]+  deleteFirstsBy eq       =  foldl (flip (deleteBy eq))++  sortBy :: (a -> a -> Ordering) -> [a] -> [a]+  sortBy cmp  = foldr (insertBy cmp) []++  insertBy :: (a -> a -> Ordering) -> a -> [a] -> [a]+  insertBy _   x [] = [x]+  insertBy cmp x ys@(y:ys')+   = case cmp x y of+       GT -> y : insertBy cmp x ys'+       LT  -> x : ys+       EQ  -> x : ys++  maximumBy               :: (a -> a -> Ordering) -> [a] -> a+  maximumBy _ []          =  error "Data.Singletons.List.maximumBy: empty list"+  maximumBy cmp xs@(_:_)  =  foldl1 maxBy xs+                          where+                            maxBy x y = case cmp x y of+                                         GT -> x+                                         EQ -> y+                                         LT -> y++  minimumBy               :: (a -> a -> Ordering) -> [a] -> a+  minimumBy _ []          =  error "Data.Singletons.List.minimumBy: empty list"+  minimumBy cmp xs@(_:_)  =  foldl1 minBy xs+                          where+                            minBy x y = case cmp x y of+                                         GT -> y+                                         EQ -> x+                                         LT -> x++  |])++-- The symbol []$ is clearly malformed, so we have to name this symbol+-- NilSym0+type NilSym0      = '[]++-- If Nil has an alphanumeric symbol, we wouldn't want to leave Cons out...+type ConsSym0     = (:$)+type ConsSym1     = (:$$)+type ConsSym2 a b = (:$$$) a b
+ src/Data/Singletons/Prelude/Maybe.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TypeFamilies,+             DataKinds, PolyKinds, UndecidableInstances, GADTs,+             RankNTypes, CPP #-}++#if __GLASGOW_HASKELL__ < 707+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+#endif++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Singletons.Prelude.Maybe+-- Copyright   :  (C) 2013-2014 Richard Eisenberg, Jan Stolarek+-- 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.Prelude.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_, 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, ListToMaybe, sListToMaybe,+  MaybeToList, sMaybeToList, CatMaybes, sCatMaybes, MapMaybe, sMapMaybe,++  -- * Defunctionalization symbols+  NothingSym0, JustSym0, JustSym1,++  Maybe_Sym0, Maybe_Sym1, Maybe_Sym2, Maybe_Sym3,+  IsJustSym0, IsJustSym1, IsNothingSym0, IsNothingSym1,+  FromJustSym0, FromJustSym1, FromMaybeSym0, FromMaybeSym1, FromMaybeSym2,+  ListToMaybeSym0, ListToMaybeSym1, MaybeToListSym0, MaybeToListSym1,+  CatMaybesSym0, CatMaybesSym1, MapMaybeSym0, MapMaybeSym1, MapMaybeSym2+  ) where++import Data.Singletons.Prelude.Instances+import Data.Singletons+import Data.Singletons.TH+import Data.Singletons.TypeLits++$(singletons [d|+  -- Renamed to avoid name clash+  -- | 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+ |])++$(singletonsOnly [d|+  -- | 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 x = case x of {Nothing -> d;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++  -- Modified to avoid list comprehensions+  -- | 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) =+   let rs = mapMaybe f xs in+   case f x of+    Nothing -> rs+    Just r  -> r:rs+  |])
+ src/Data/Singletons/Prelude/Ord.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE TemplateHaskell, DataKinds, PolyKinds, ScopedTypeVariables,+             TypeFamilies, TypeOperators, GADTs, UndecidableInstances,+             FlexibleContexts, DefaultSignatures #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Singletons.Prelude.Ord+-- Copyright   :  (C) 2013 Richard Eisenberg+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  Richard Eisenberg (eir@cis.upenn.edu)+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Defines the promoted version of Ord, 'POrd', and the singleton version,+-- 'SOrd'.+--+-----------------------------------------------------------------------------++module Data.Singletons.Prelude.Ord (+  POrd(..), SOrd(..),++  -- | 'thenCmp' returns its second argument if its first is 'EQ'; otherwise,+  -- it returns its first argument.+  thenCmp, ThenCmp, sThenCmp,++  Sing(SLT, SEQ, SGT),++  -- ** Defunctionalization symbols+  ThenCmpSym0, ThenCmpSym1, ThenCmpSym2,+  LTSym0, EQSym0, GTSym0,+  CompareSym0, CompareSym1, CompareSym2,+  (:<$), (:<$$), (:<$$$),+  (:<=$), (:<=$$), (:<=$$$),+  (:>$), (:>$$), (:>$$$),+  (:>=$), (:>=$$), (:>=$$$),+  MaxSym0, MaxSym1, MaxSym2,+  MinSym0, MinSym1, MinSym2+  ) where++import Data.Singletons.Promote+import Data.Singletons.Single+import Data.Singletons.Prelude.Eq+import Data.Singletons.Prelude.Instances+import Data.Singletons.Prelude.Bool+import Data.Singletons+import Data.Singletons.Util++$(promoteOnly [d|+  class  (Eq a) => Ord a  where+    compare              :: a -> a -> Ordering+    (<), (<=), (>), (>=) :: a -> a -> Bool+    max, min             :: a -> a -> a++    compare x y = if x == y then EQ+                  -- NB: must be '<=' not '<' to validate the+                  -- above claim about the minimal things that+                  -- can be defined for an instance of Ord:+                  else if x <= y then LT+                  else GT++    x <  y = case compare x y of { LT -> True;  _ -> False }+    x <= y = case compare x y of { GT -> False; _ -> True }+    x >  y = case compare x y of { GT -> True;  _ -> False }+    x >= y = case compare x y of { LT -> False; _ -> True }++        -- These two default methods use '<=' rather than 'compare'+        -- because the latter is often more expensive+    max x y = if x <= y then y else x+    min x y = if x <= y then x else y+    {-# MINIMAL compare | (<=) #-}+  |])++type family CaseOrdering (ord :: Ordering) (lt :: k) (eq :: k) (gt :: k) :: k+type instance CaseOrdering LT lt eq gt = lt+type instance CaseOrdering EQ lt eq gt = eq+type instance CaseOrdering GT lt eq gt = gt++class (kproxy ~ 'KProxy, SEq ('KProxy :: KProxy a))+      => SOrd (kproxy :: KProxy a) where+  sCompare :: forall (x :: a) (y :: a). Sing x -> Sing y -> Sing (Compare x y)+  (%:<)    :: forall (x :: a) (y :: a). Sing x -> Sing y -> Sing (x :< y)+  (%:<=)   :: forall (x :: a) (y :: a). Sing x -> Sing y -> Sing (x :<= y)+  (%:>)    :: forall (x :: a) (y :: a). Sing x -> Sing y -> Sing (x :> y)+  (%:>=)   :: forall (x :: a) (y :: a). Sing x -> Sing y -> Sing (x :>= y)+  sMax      :: forall (x :: a) (y :: a). Sing x -> Sing y -> Sing (Max x y)+  sMin      :: forall (x :: a) (y :: a). Sing x -> Sing y -> Sing (Min x y)++  default sCompare :: forall (x :: a) (y :: a).+                      (Compare x y ~ If (x :== y) EQ (If (x :<= y) LT GT))+                   => Sing x -> Sing y -> Sing (Compare x y)+  sCompare x y = sIf (x %:== y) SEQ+                     (sIf (x %:<= y) SLT SGT)++  default (%:<) :: forall (x :: a) (y :: a).+                   ((x :< y) ~ CaseOrdering (Compare x y) True False False)+                => Sing x -> Sing y -> Sing (x :< y)+  x %:< y = case sCompare x y of { SLT -> STrue; SEQ -> SFalse; SGT -> SFalse }++  default (%:<=) :: forall (x :: a) (y :: a).+                    ((x :<= y) ~ CaseOrdering (Compare x y) True True False)+                 => Sing x -> Sing y -> Sing (x :<= y)+  x %:<= y = case sCompare x y of { SLT -> STrue; SEQ -> STrue; SGT -> SFalse }++  default (%:>) :: forall (x :: a) (y :: a).+                   ((x :> y) ~ CaseOrdering (Compare x y) False False True)+                => Sing x -> Sing y -> Sing (x :> y)+  x %:> y = case sCompare x y of { SLT -> SFalse; SEQ -> SFalse; SGT -> STrue }++  default (%:>=) :: forall (x :: a) (y :: a).+                    ((x :>= y) ~ CaseOrdering (Compare x y) False True True)+                 => Sing x -> Sing y -> Sing (x :>= y)+  x %:>= y = case sCompare x y of { SLT -> SFalse; SEQ -> STrue; SGT -> STrue }++  default sMax :: forall (x :: a) (y :: a).+                  (Max x y ~ If (x :<= y) y x)+               => Sing x -> Sing y -> Sing (Max x y)+  sMax x y = sIf (x %:<= y) y x++  default sMin :: forall (x :: a) (y :: a).+                  (Min x y ~ If (x :<= y) x y)+               => Sing x -> Sing y -> Sing (Min x y)+  sMin x y = sIf (x %:<= y) x y++$(singletons [d|+  thenCmp :: Ordering -> Ordering -> Ordering+  thenCmp EQ x = x+  thenCmp LT _ = LT+  thenCmp GT _ = GT+  |])++$(promoteOrdInstances basicTypes)
+ src/Data/Singletons/Prelude/Tuple.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, DataKinds, PolyKinds,+             RankNTypes, TypeFamilies, GADTs, CPP, UndecidableInstances #-}++#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.Prelude.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,++  -- * Defunctionalization symbols+  Tuple0Sym0,+  Tuple2Sym0, Tuple2Sym1, Tuple2Sym2,+  Tuple3Sym0, Tuple3Sym1, Tuple3Sym2, Tuple3Sym3,+  Tuple4Sym0, Tuple4Sym1, Tuple4Sym2, Tuple4Sym3, Tuple4Sym4,+  Tuple5Sym0, Tuple5Sym1, Tuple5Sym2, Tuple5Sym3, Tuple5Sym4, Tuple5Sym5,+  Tuple6Sym0, Tuple6Sym1, Tuple6Sym2, Tuple6Sym3, Tuple6Sym4, Tuple6Sym5, Tuple6Sym6,+  Tuple7Sym0, Tuple7Sym1, Tuple7Sym2, Tuple7Sym3, Tuple7Sym4, Tuple7Sym5, Tuple7Sym6, Tuple7Sym7,++  FstSym0, FstSym1, SndSym0, SndSym1,+  CurrySym0, CurrySym1, CurrySym2, CurrySym3,+  UncurrySym0, UncurrySym1, UncurrySym2,+  SwapSym0, SwapSym1+  ) where++import Data.Singletons.Prelude.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/Promote.hs view
@@ -7,693 +7,633 @@ 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)+{-# LANGUAGE TemplateHaskell, CPP, MultiWayIf, LambdaCase, TupleSections #-}++module Data.Singletons.Promote where++import Language.Haskell.TH hiding ( Q, cxt )+import Language.Haskell.TH.Syntax ( Quasi(..) )+import Language.Haskell.TH.Desugar+import Language.Haskell.TH.Desugar.Sweeten+import Data.Singletons.Names+import Data.Singletons.Promote.Monad+import Data.Singletons.Promote.Eq+import Data.Singletons.Promote.Ord+import Data.Singletons.Promote.Bounded+import Data.Singletons.Promote.Defun+import Data.Singletons.Promote.Type+import Data.Singletons.Util+import Data.Singletons.Syntax+import Prelude hiding (exp)+import Control.Monad+import Control.Applicative+import Data.Maybe+import qualified Data.Map.Strict as Map+import Data.Map.Strict ( Map )++-- | Generate promoted definitions from a type that is already defined.+-- This is generally only useful with classes.+genPromotions :: Quasi q => [Name] -> q [Dec]+genPromotions names = do+  checkForRep names+  infos <- mapM reifyWithWarning names+  dinfos <- mapM dsInfo infos+  ddecs <- promoteM_ $ mapM_ promoteInfo dinfos+  return $ decsToTH ddecs++-- | Promote every declaration given to the type level, retaining the originals.+promote :: Quasi q => q [Dec] -> q [Dec]+promote qdec = do+  decls <- qdec+  ddecls <- dsDecs decls+  promDecls <- promoteM_ $ promoteDecs ddecls+  return $ decls ++ decsToTH promDecls++-- | Promote each declaration, discarding the originals.+promoteOnly :: Quasi q => q [Dec] -> q [Dec]+promoteOnly qdec = do+  decls  <- qdec+  ddecls <- dsDecs decls+  promDecls <- promoteM_ $ promoteDecs ddecls+  return $ decsToTH promDecls++-- | Generate defunctionalization symbols for existing type family+genDefunSymbols :: Quasi q => [Name] -> q [Dec]+genDefunSymbols names = do+  checkForRep names+  infos <- mapM (dsInfo <=< reifyWithWarning) names+  decs <- promoteMDecs $ concatMapM defunInfo infos+  return $ decsToTH decs++-- | Produce instances for '(:==)' (type-level equality) from the given types+promoteEqInstances :: Quasi q => [Name] -> q [Dec]+promoteEqInstances = concatMapM promoteEqInstance++-- | Produce instances for 'Compare' from the given types+promoteOrdInstances :: Quasi q => [Name] -> q [Dec]+promoteOrdInstances = concatMapM promoteOrdInstance++-- | Produce instances for 'MinBound' and 'MaxBound' from the given types+promoteBoundedInstances :: Quasi q => [Name] -> q [Dec]+promoteBoundedInstances = concatMapM promoteBoundedInstance++-- | 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+  cons' <- mapM dsCon cons+#if __GLASGOW_HASKELL__ >= 707+  vars <- replicateM (length _tvbs) (qNewName "k")+  kind <- promoteType (foldType (DConT name) (map DVarT vars))+  inst_decs <- mkEqTypeInstance kind cons'+  return $ decsToTH inst_decs+#else+  let pairs = [(c1, c2) | c1 <- cons, c2 <- cons]+  mapM (fmap decsToTH . mkEqTypeInstance) pairs+#endif++-- | Produce an instance for 'Compare' from the given type+promoteOrdInstance :: Quasi q => Name -> q [Dec]+promoteOrdInstance name = do+  (_tvbs, cons) <- getDataD "I cannot make an instance of Ord for it." name+  cons' <- mapM dsCon cons+#if __GLASGOW_HASKELL__ >= 707+  vars <- replicateM (length _tvbs) (qNewName "k")+  kind <- promoteType (foldType (DConT name) (map DVarT vars))+  inst_decs <- mkOrdTypeInstance kind cons'+  return $ decsToTH inst_decs+#else+  fail "promoteOrdInstance not implemented for GHC 7.6"+#endif++-- | Produce an instance for 'MinBound' and 'MaxBound' from the given type+promoteBoundedInstance :: Quasi q => Name -> q [Dec]+promoteBoundedInstance name = do+  (_tvbs, cons) <- getDataD "I cannot make an instance of Bounded for it." name+  cons' <- mapM dsCon cons+#if __GLASGOW_HASKELL__ >= 707+  vars <- replicateM (length _tvbs) (qNewName "k")+  kind <- promoteType (foldType (DConT name) (map DVarT vars))+  inst_decs <- mkBoundedTypeInstance kind cons'+  return $ decsToTH inst_decs+#else+  fail "promoteBoundedInstance not implemented for GHC 7.6"+#endif++promoteInfo :: DInfo -> PrM ()+promoteInfo (DTyConI dec _instances) = promoteDecs [dec]+promoteInfo (DPrimTyConI _name _numArgs _unlifted) =+  fail "Promotion of primitive type constructors not supported"+promoteInfo (DVarI _name _ty _mdec _fixity) =+  fail "Promotion of individual values not supported"+promoteInfo (DTyVarI _name _ty) =+  fail "Promotion of individual type variables not supported"++-- Note [Promoting declarations in two stages]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- It is necessary to know the types of things when promoting. So,+-- we promote in two stages: first, we build a LetDecEnv, which allows+-- for easy lookup. Then, we go through the actual elements of the LetDecEnv,+-- performing the promotion.+--+-- Why do we need the types? For kind annotations on the type family. We also+-- need to have both the types and the actual function definition at the same+-- time, because the function definition tells us how many patterns are+-- matched. Note that an eta-contracted function needs to return a TyFun,+-- not a proper type-level function.+--+-- Consider this example:+--+--   foo :: Nat -> Bool -> Bool+--   foo Zero = 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 :: Nat) :: TyFun Bool Bool -> * where+--      Foo Zero = 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 top-level declarations.+promoteDecs :: [DDec] -> PrM ()+promoteDecs decls = do+  checkForRepInDecls decls+  -- See Note [Promoting declarations in two stages]+  PDecs { pd_let_decs              = let_decs+        , pd_class_decs            = classes+        , pd_instance_decs         = insts+        , pd_data_decs             = datas }    <- partitionDecs decls++    -- promoteLetDecs returns LetBinds, which we don't need at top level+  _ <- promoteLetDecs noPrefix let_decs+  (cls_tvb_env, meth_sigs) <- concatMapM promoteClassDec classes+  mapM_ (promoteInstanceDec cls_tvb_env meth_sigs) insts+  promoteDataDecs datas++promoteDataDecs :: [DataDecl] -> PrM ()+promoteDataDecs data_decs = do+  rec_selectors <- concatMapM extract_rec_selectors data_decs+  _ <- promoteLetDecs noPrefix rec_selectors+  mapM_ promoteDataDec data_decs+  where+    extract_rec_selectors :: DataDecl -> PrM [DLetDec]+    extract_rec_selectors (DataDecl _nd data_name tvbs cons _derivings) =+      let arg_ty = foldType (DConT data_name)+                            (map (DVarT . extractTvbName) tvbs)+      in+      concatMapM (getRecordSelectors arg_ty) cons++-- curious about ALetDecEnv? See the LetDecEnv module for an explanation.+promoteLetDecs :: String -- prefix to use on all new definitions+               -> [DLetDec] -> PrM ([LetBind], ALetDecEnv)+promoteLetDecs prefix decls = do+  let_dec_env <- buildLetDecEnv decls+  all_locals <- allLocals+  let binds = [ (name, foldType (DConT sym) (map DVarT all_locals))+              | name <- Map.keys $ lde_defns let_dec_env+              , let proName = promoteValNameLhsPrefix prefix name+                    sym = promoteTySym proName (length all_locals) ]+  (decs, let_dec_env') <- letBind binds $ promoteLetDecEnv prefix let_dec_env+  emitDecs decs+  return (binds, let_dec_env' { lde_proms = Map.fromList binds })++noPrefix :: String+noPrefix = ""++-- Promotion of data types to kinds is automatic (see "Ginving Haskell a+-- Promotion" paper for more details). Here we "plug into" the promotion+-- mechanism to add some extra stuff to the promotion:+--+--  * if data type derives Eq we generate a type family that implements the+--    equality test for the data type.+--+--  * for each data constructor with arity greater than 0 we generate type level+--    symbols for use with Apply type family. In this way promoted data+--    constructors and promoted functions can be used in a uniform way at the+--    type level in the same way they can be used uniformly at the type level.+--+--  * for each nullary data constructor we generate a type synonym+promoteDataDec :: DataDecl -> PrM ()+promoteDataDec (DataDecl _nd name tvbs ctors derivings) = do+#if __GLASGOW_HASKELL__ < 707+  when (_nd == Newtype) $+    fail $ "Newtypes don't promote under GHC 7.6. " +++           "Use <<data>> instead or upgrade GHC."+#endif+  -- deriving Eq instance+  _kvs <- replicateM (length tvbs) (qNewName "k")+  _kind <- promoteType (foldType (DConT name) (map DVarT _kvs))+  when (elem eqName derivings) $ do+#if __GLASGOW_HASKELL__ >= 707+    eq_decs <- mkEqTypeInstance _kind ctors+#else+    let pairs = [ (c1, c2) | c1 <- ctors, c2 <- ctors ]+    eq_decs <- mapM mkEqTypeInstance pairs+#endif+    emitDecs eq_decs++  -- deriving Ord instance+  when (elem ordName derivings) $ do+#if __GLASGOW_HASKELL__ >= 707+    ord_decs <- mkOrdTypeInstance _kind ctors+#else+    fail "Ord deriving not yet implemented in GHC 7.6"+#endif+    emitDecs ord_decs++  -- deriving Bounded instance+  when (elem boundedName derivings) $ do+#if __GLASGOW_HASKELL__ >= 707+    bounded_decs <- mkBoundedTypeInstance _kind ctors+#else+    fail "Bounded deriving not yet implemented in GHC 7.6"+#endif+    emitDecs bounded_decs++  ctorSyms <- buildDefunSymsDataD name tvbs ctors+  emitDecs ctorSyms++promoteClassDec :: ClassDecl+                -> PrM ( Map Name [Name]    -- from class names to tyvar lists+                       , Map Name DType )   -- returns method signatures+promoteClassDec (ClassDecl cxt cls_name tvbs+                           (LetDecEnv { lde_defns = defaults+                                      , lde_types = meth_sigs+                                      , lde_infix = infix_decls })) = do+  let tvbNames = map extractTvbName tvbs+      pClsName = promoteClassName cls_name+  kproxies <- mapM (const $ qNewName "kproxy") tvbs+  pCxt <- mapM promote_superclass_pred cxt+  let proxyCxt = map (\kp -> foldl DAppPr (DConPr equalityName)+                                   [DVarT kp, DConT kProxyDataName]) kproxies+      cxt'  = pCxt ++ proxyCxt+      ptvbs = zipWith (\proxy tvbName -> DKindedTV proxy+                                           (DConK kProxyTypeName [DVarK tvbName]))+                      kproxies tvbNames+  sig_decs     <- mapM (uncurry promote_sig) (Map.toList meth_sigs)+     -- the first arg to promoteMethod is a kind subst. We actually don't+     -- want to subst for default instances, so we pass Map.empty+  default_decs <- concatMapM (promoteMethod Map.empty meth_sigs)+                             (Map.toList defaults)+  let infix_decls' = catMaybes $ map (uncurry promoteInfixDecl) infix_decls+  emitDecs [ DClassD cxt' pClsName ptvbs [] (sig_decs +++                                             default_decs +++                                             infix_decls') ]+  return ( Map.singleton cls_name tvbNames+         , meth_sigs )+  where+    promote_sig :: Name -> DType -> PrM DDec+    promote_sig name ty = do+      let proName = promoteValNameLhs name+      (argKs, resK) <- snocView `liftM` (mapM promoteType (snd $ unravel ty))+      args <- mapM (const $ qNewName "arg") argKs+      emitDecsM $ defunctionalize proName (map Just argKs) (Just resK)+      return $ DFamilyD TypeFam proName+                        (zipWith DKindedTV args argKs)+                        (Just resK)++    promote_superclass_pred :: DPred -> PrM DPred+    promote_superclass_pred = go+      where+      go (DAppPr pr ty) = DAppPr <$> go pr <*> fmap kindParam (promoteType ty)+      go (DSigPr pr _k) = go pr    -- just ignore the kind; it can't matter+      go (DVarPr name)  = fail $ "Cannot promote ConstraintKinds variables like "+                              ++ show name+      go (DConPr name)  = return $ DConPr (promoteClassName name)++promoteInstanceDec :: Map Name [Name] -> Map Name DType -> InstDecl -> PrM ()+promoteInstanceDec cls_tvb_env meth_sigs+                   (InstDecl cls_name inst_tys meths) = do+  cls_tvb_names <- lookup_cls_tvb_names+  inst_kis <- mapM promoteType inst_tys+  let subst = Map.fromList $ zip cls_tvb_names inst_kis+  meths' <- concatMapM (promoteMethod subst meth_sigs) meths+  emitDecs [DInstanceD [] (foldType (DConT pClsName)+                                    (map kindParam inst_kis)) meths']+  where+    pClsName = promoteClassName cls_name++    lookup_cls_tvb_names :: PrM [String]+    lookup_cls_tvb_names = case Map.lookup cls_name cls_tvb_env of+      Nothing -> do+        m_dinfo <- qReifyMaybe pClsName+        case m_dinfo of+          Just (DTyConI (DClassD _cxt _name cls_tvbs _fds _decs) _insts) -> do+            mapM extract_kv_name cls_tvbs+          _ -> fail $ "Cannot find class declaration for " ++ show cls_name+          -- See Note [Bad Names in reification]+      Just tvb_names -> return $ map nameBase tvb_names++    extract_kv_name :: DTyVarBndr -> PrM String+    extract_kv_name (DKindedTV _kpVar (DConK _kpType [DVarK kv])) =+      -- See Note [Bad Names in reification]+      return $ nameBase kv+    extract_kv_name tvb =+      fail $ "Unexpected parameter to promoted class: " ++ show tvb++-- Note [Bad Names in reification]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- For reasons I (RAE) don't understand, reifying a class and reifying an+-- associated type family sometimes produce *different* Names for the+-- associated type/kind variables. This wreaks havoc with the type subst+-- algorithm in promoteMethod. The solution? Ickily compare nameBases+-- instead of proper Names. See also GHC#9081.++-- See Note [Bad Names in reification]+promoteMethod :: Map String DKind   -- instantiations for class tyvars+              -> Map Name DType     -- method types+              -> (Name, ULetDecRHS) -> PrM [DDec]+promoteMethod subst sigs_map (meth_name, meth_rhs) = do+  (payload, _defuns, _ann_rhs)+    <- promoteLetDecRHS sigs_map noPrefix meth_name meth_rhs+  let eqns = payload_to_eqns payload+  (arg_kis, res_ki) <- lookup_meth_ty+  let meth_arg_kis' = map subst_ki arg_kis+      meth_res_ki'  = subst_ki res_ki+      eqns'         = map (apply_kis meth_arg_kis' meth_res_ki') eqns+  return $ map (DTySynInstD proName) eqns'+  where+    proName = promoteValNameLhs meth_name++    payload_to_eqns (Left (_name, tvbs, rhs)) =+      [DTySynEqn (map tvb_to_ty tvbs) rhs]+    payload_to_eqns (Right (_name, _tvbs, _res_ki, eqns)) = eqns++    tvb_to_ty (DPlainTV n)     = DVarT n+    tvb_to_ty (DKindedTV n ki) = DVarT n `DSigT` ki++    lookup_meth_ty :: PrM ([DKind], DKind)+    lookup_meth_ty = case Map.lookup meth_name sigs_map of+      Nothing -> do+          -- lookup the promoted name, just in case the term-level one+          -- isn't defined+        m_dinfo <- qReifyMaybe proName+        case m_dinfo of+          Just (DTyConI (DFamilyD _flav _name tvbs (Just res)) _insts) -> do+            arg_kis <- mapM (expect_just . extractTvbKind) tvbs+            return (arg_kis, res)+          _ -> fail $ "Cannot find type of " ++ show proName+      Just ty -> do+        let (_, tys) = unravel ty+        kis <- mapM promoteType tys+        return $ snocView kis++    expect_just :: Maybe a -> PrM a+    expect_just (Just x) = return x+    expect_just Nothing =+      fail "Internal error: unknown kind of a promoted class method."++    subst_ki :: DKind -> DKind+    subst_ki (DForallK {}) =+      error "Higher-rank kind encountered in instance method promotion."+    subst_ki (DVarK n) =+      -- See Note [Bad Names in reification]+      case Map.lookup (nameBase n) subst of+        Just ki -> ki+        Nothing -> DVarK n+    subst_ki (DConK con kis) = DConK con (map subst_ki kis)+    subst_ki (DArrowK k1 k2) = DArrowK (subst_ki k1) (subst_ki k2)+    subst_ki DStarK = DStarK++    apply_kis :: [DKind] -> DKind -> DTySynEqn -> DTySynEqn+    apply_kis arg_kis res_ki (DTySynEqn lhs rhs) =+      DTySynEqn (zipWith apply_ki lhs arg_kis) (apply_ki rhs res_ki)++    apply_ki :: DType -> DKind -> DType+    apply_ki = DSigT+++promoteLetDecEnv :: String -> ULetDecEnv -> PrM ([DDec], ALetDecEnv)+promoteLetDecEnv prefix (LetDecEnv { lde_defns = value_env+                                   , lde_types = type_env+                                   , lde_infix = infix_decls }) = do+    -- deal with the infix_decls, to get them out of the way+  let infix_decls'  = catMaybes $ map (uncurry promoteInfixDecl) infix_decls++    -- promote all the declarations, producing annotated declarations+      (names, rhss) = unzip $ Map.toList value_env+  (payloads, defun_decss, ann_rhss)+    <- fmap unzip3 $ zipWithM (promoteLetDecRHS type_env prefix) names rhss++  emitDecs $ concat defun_decss+  let decs = map payload_to_dec payloads++    -- build the ALetDecEnv+  let let_dec_env' = LetDecEnv { lde_defns = Map.fromList $ zip names ann_rhss+                               , lde_types = type_env+                               , lde_infix = infix_decls+                               , lde_proms = Map.empty }  -- filled in promoteLetDecs++  return (infix_decls' ++ decs, let_dec_env')+  where+    payload_to_dec (Left  (name, tvbs, ty)) = DTySynD name tvbs ty+    payload_to_dec (Right (name, tvbs, m_ki, eqns)) =+      DClosedTypeFamilyD name tvbs m_ki eqns++promoteInfixDecl :: Fixity -> Name -> Maybe DDec+promoteInfixDecl fixity name+  | isUpcase name = Nothing   -- no need to promote the decl+  | otherwise     = Just $ DLetDec $ DInfixD fixity (promoteValNameLhs name)+++-- This function is used both to promote class method defaults and normal+-- let bindings. Thus, it can't quite do all the work locally and returns+-- an unwiedly intermediate structure. Perhaps a better design is available.+promoteLetDecRHS :: Map Name DType       -- local type env't+                 -> String               -- let-binding prefix+                 -> Name                 -- name of the thing being promoted+                 -> ULetDecRHS           -- body of the thing+                 -> PrM ( Either+                            (Name, [DTyVarBndr], DType) -- "type synonym"+                            (Name, [DTyVarBndr], Maybe DKind, [DTySynEqn])+                                                        -- "type family"+                        , [DDec]        -- defunctionalization+                        , ALetDecRHS )  -- annotated RHS+promoteLetDecRHS type_env prefix name (UValue exp) = do+  (res_kind, mk_rhs, num_arrows)+    <- case Map.lookup name type_env of+         Nothing -> return (Nothing, id, 0)+         Just ty -> do+           ki <- promoteType ty+           return (Just ki, (`DSigT` ki), countArgs ty)+  case num_arrows of+    0 -> do+      all_locals <- allLocals+      (exp', ann_exp) <- promoteExp exp+      let proName = promoteValNameLhsPrefix prefix name+      defuns <- defunctionalize proName (map (const Nothing) all_locals) res_kind+      return ( Left (proName, map DPlainTV all_locals, mk_rhs exp')+             , defuns+             , AValue (foldType (DConT proName) (map DVarT all_locals))+                      num_arrows ann_exp )+    _ -> do+      names <- replicateM num_arrows (newUniqueName "a")+      let pats    = map DVarPa names+          newArgs = map DVarE  names+      promoteLetDecRHS type_env prefix name+                       (UFunction [DClause pats (foldExp exp newArgs)])++promoteLetDecRHS type_env prefix name (UFunction clauses) = do+  numArgs <- count_args clauses+  (m_argKs, m_resK, ty_num_args) <- case Map.lookup name type_env of+#if __GLASGOW_HASKELL__ < 707+      -- we require a type signature here because GHC 7.6.3 doesn't support+      -- kind inference for type families+    Nothing -> fail ("No type signature for function \"" +++                     (nameBase name) ++ "\". Cannot promote in GHC 7.6.3.\n" +++                     "Either add a type signature or upgrade GHC.")+#else+    Nothing -> return (replicate numArgs Nothing, Nothing, numArgs)+#endif+    Just ty -> do+      -- promoteType turns arrows into TyFun. So, we unravel first to+      -- avoid this behavior. Note the use of ravelTyFun in resultK+      -- to make the return kind work out+      kis <- mapM promoteType (snd $ unravel ty)+      let (argKs, resultK) = snocView kis+      -- invariant: countArgs ty == length argKs+      return (map Just argKs, Just resultK, length argKs)++  let proName = promoteValNameLhsPrefix prefix name+  all_locals <- allLocals+  defun_decs <- defunctionalize proName+                (map (const Nothing) all_locals ++ m_argKs) m_resK+  local_tvbs <- mapM inferKindTV all_locals+  tyvarNames <- mapM (const $ qNewName "a") m_argKs+  expClauses <- mapM (etaExpand (ty_num_args - numArgs)) clauses+  (eqns, ann_clauses) <- mapAndUnzipM promoteClause expClauses+  prom_fun <- lookupVarE name+  args <- zipWithM inferMaybeKindTV tyvarNames m_argKs+  let all_args = local_tvbs ++ args+  resultK <- inferKind m_resK+  return ( Right (proName, all_args, resultK, eqns)+         , defun_decs+         , AFunction prom_fun ty_num_args ann_clauses )++  where+    etaExpand :: Int -> DClause -> PrM DClause+    etaExpand n (DClause pats exp) = do+      names <- replicateM n (newUniqueName "a")+      let newPats = map DVarPa names+          newArgs = map DVarE  names+      return $ DClause (pats ++ newPats) (foldExp exp newArgs)++    count_args (DClause pats _ : _) = return $ length pats+    count_args _ = fail $ "Impossible! A function without clauses."++promoteClause :: DClause -> PrM (DTySynEqn, ADClause)+promoteClause (DClause pats exp) = do+  -- promoting the patterns creates variable bindings. These are passed+  -- to the function promoted the RHS+  (types, new_vars) <- evalForPair $ mapM promotePat pats+  (ty, ann_exp) <- lambdaBind new_vars $ promoteExp exp+  all_locals <- allLocals   -- these are bound *outside* of this clause+  return ( DTySynEqn (map DVarT all_locals ++ types) ty+         , ADClause new_vars pats ann_exp )++promoteMatch :: DType -> DMatch -> PrM (DTySynEqn, ADMatch)+promoteMatch prom_case (DMatch pat exp) = do+  -- promoting the patterns creates variable bindings. These are passed+  -- to the function promoted the RHS+  (ty, new_vars) <- evalForPair $ promotePat pat+  (rhs, ann_exp) <- lambdaBind new_vars $ promoteExp exp+  all_locals <- allLocals+  return $ ( DTySynEqn (map DVarT all_locals ++ [ty]) rhs+           , ADMatch new_vars prom_case pat ann_exp)++-- promotes a term pattern into a type pattern, accumulating bound variable names+promotePat :: DPat -> QWithAux VarPromotions PrM DType+promotePat (DLitPa lit) = promoteLit lit+promotePat (DVarPa name) = do+      -- term vars can be symbols... type vars can't!+  tyName <- mkTyName name+  addElement (name, tyName)+  return $ DVarT tyName+promotePat (DConPa name pats) = do+  types <- mapM promotePat pats+  let name' = unboxed_tuple_to_tuple name+  return $ foldType (DConT name') types+  where+    unboxed_tuple_to_tuple n+      | Just deg <- unboxedTupleNameDegree_maybe n = tupleDataName deg+      | otherwise                                  = n+promotePat (DTildePa pat) = do+  qReportWarning "Lazy pattern converted into regular pattern in promotion"+  promotePat pat+promotePat (DBangPa pat) = do+  qReportWarning "Strict pattern converted into regular pattern in promotion"+  promotePat pat+promotePat DWildPa = do+  name <- qNewName "z"+  return $ DVarT name++promoteExp :: DExp -> PrM (DType, ADExp)+promoteExp (DVarE name) = fmap (, ADVarE name) $ lookupVarE name+promoteExp (DConE name) = return $ (promoteValRhs name, ADConE name)+promoteExp (DLitE lit)  = fmap (, ADLitE lit) $ promoteLit lit+promoteExp (DAppE exp1 exp2) = do+  (exp1', ann_exp1) <- promoteExp exp1+  (exp2', ann_exp2) <- promoteExp exp2+  return (apply exp1' exp2', ADAppE ann_exp1 ann_exp2)+promoteExp (DLamE names exp) = do+  lambdaName <- newUniqueName "Lambda"+  resultKVarName  <- qNewName "r"+  tyNames <- mapM mkTyName names+  let var_proms = zip names tyNames+  (rhs, ann_exp) <- lambdaBind var_proms $ promoteExp exp+  tyFamLamTypes <- mapM (const $ qNewName "t") names+  all_locals <- allLocals+  let all_args = all_locals ++ tyFamLamTypes+  tvbs <- mapM inferKindTV all_args+  let resultK       = DVarK resultKVarName+      m_resultK     = unknownResult resultK+  emitDecs [DClosedTypeFamilyD lambdaName+                               tvbs+                               m_resultK+                               [DTySynEqn (map DVarT (all_locals ++ tyNames))+                                          rhs]]+  emitDecsM $ defunctionalize lambdaName (map (const Nothing) all_args) Nothing+  let promLambda = foldl apply (DConT (promoteTySym lambdaName 0))+                               (map DVarT all_locals)+  return (promLambda, ADLamE var_proms promLambda names ann_exp)+promoteExp (DCaseE exp matches) = do+  caseTFName <- newUniqueName "Case"+  all_locals <- allLocals+  let prom_case = foldType (DConT caseTFName) (map DVarT all_locals)+  (exp', ann_exp)     <- promoteExp exp+  (eqns, ann_matches) <- mapAndUnzipM (promoteMatch prom_case) matches+  tyvarName  <- qNewName "t"+  let all_args = all_locals ++ [tyvarName]+  tvbs  <- mapM inferKindTV all_args+  resultK    <- fmap DVarK $ qNewName "r"+  emitDecs [DClosedTypeFamilyD caseTFName tvbs (unknownResult resultK) eqns]+  return ( prom_case `DAppT` exp'+         , ADCaseE ann_exp ann_matches )+promoteExp (DLetE decs exp) = do+  letPrefix <- fmap nameBase $ newUniqueName "Let"+  (binds, ann_env) <- promoteLetDecs letPrefix decs+  (exp', ann_exp) <- letBind binds $ promoteExp exp+  return (exp', ADLetE ann_env ann_exp)+promoteExp (DSigE exp ty) = do+  (exp', ann_exp) <- promoteExp exp+  ty' <- promoteType ty+  return (DSigT exp' ty', ADSigE ann_exp ty)++promoteLit :: Monad m => Lit -> m DType+promoteLit (IntegerL n)+  | n >= 0    = return $ DLitT (NumTyLit n)+  | otherwise = fail ("Promoting negative integers not supported: " ++ (show n))+promoteLit (StringL str) = return $ DLitT (StrTyLit str) promoteLit lit =   fail ("Only string and natural number literals can be promoted: " ++ show lit)
+ src/Data/Singletons/Promote/Bounded.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE TemplateHaskell #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Singletons.Promote.Bounded+-- Copyright   :  (C) 2014 Jan Stolarek+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  Jan Stolarek (jan.stolarek@p.lodz.pl)+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Implements deriving of promoted Bounded instances+--+----------------------------------------------------------------------------++module Data.Singletons.Promote.Bounded where++import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Desugar+import Data.Singletons.Names+import Data.Singletons.Util+import Control.Monad++mkBoundedTypeInstance :: Quasi q => DKind -> [DCon] -> q [DDec]+mkBoundedTypeInstance kind@(DConK name _) cons = do+  -- We can derive instance of Bounded if datatype is an enumeration (all+  -- constructors must be nullary) or has only one constructor. See Section 11+  -- of Haskell 2010 Language Report.+  -- Note that order of conditions below is important.+  when (null cons+       || (any (\(DCon _ _ _ f) -> not . null . tysOfConFields $ f) cons+            && (not . null . tail $ cons))) $+       fail ("Can't derive promoted Bounded instance for " ++ show name+             ++ " datatype.")+  -- at this point we know that either we have a datatype that has only one+  -- constructor or a datatype where each constructor is nullary+  let (DCon _ _ minName fields) = head cons+      (DCon _ _ maxName _)      = last cons+      pbounded_name = promoteClassName boundedName+      fieldsCount   = length $ tysOfConFields fields+      (minRHS, maxRHS) = case fieldsCount of+        0 -> (DConT minName, DConT maxName)+        _ ->+          let minEqnRHS = foldType (DConT minName)+                                   (replicate fieldsCount (DConT tyminBoundName))+              maxEqnRHS = foldType (DConT maxName)+                                   (replicate fieldsCount (DConT tymaxBoundName))+          in (minEqnRHS, maxEqnRHS)+  return $ [ DInstanceD [] (DConT pbounded_name `DAppT` kindParam kind)+             [ DTySynInstD tyminBoundName (DTySynEqn [] minRHS)+             , DTySynInstD tymaxBoundName (DTySynEqn [] maxRHS)+             ]+           ]+mkBoundedTypeInstance _ _ = fail "Error deriving Bounded instance"
+ src/Data/Singletons/Promote/Defun.hs view
@@ -0,0 +1,197 @@+{- Data/Singletons/Promote/Defun.hs++(c) Richard Eisenberg, Jan Stolarek 2014+eir@cis.upenn.edu++This file creates defunctionalization symbols for types during promotion.+-}++{-# LANGUAGE TemplateHaskell #-}++module Data.Singletons.Promote.Defun where++import Language.Haskell.TH.Desugar+import Data.Singletons.Promote.Monad+import Data.Singletons.Promote.Type+import Data.Singletons.Names+import Language.Haskell.TH.Syntax+import Data.Singletons.Util+import Control.Monad++defunInfo :: DInfo -> PrM [DDec]+defunInfo (DTyConI dec _instances) = buildDefunSyms dec+defunInfo (DPrimTyConI _name _numArgs _unlifted) =+  fail $ "Building defunctionalization symbols of primitive " +++         "type constructors not supported"+defunInfo (DVarI _name _ty _mdec _fixity) =+  fail "Building defunctionalization symbols of values not supported"+defunInfo (DTyVarI _name _ty) =+  fail "Building defunctionalization symbols of type variables not supported"++buildDefunSyms :: DDec -> PrM [DDec]+buildDefunSyms (DDataD _new_or_data _cxt tyName tvbs ctors _derivings) =+  buildDefunSymsDataD tyName tvbs ctors+buildDefunSyms (DClosedTypeFamilyD name tvbs returnK_maybe _) = do+  let arg_m_kinds = map extractTvbKind tvbs+  defunctionalize name arg_m_kinds returnK_maybe+buildDefunSyms (DFamilyD TypeFam name tvbs returnK_maybe) = do+  let arg_kinds = map (default_to_star . extractTvbKind) tvbs+      res_kind  = default_to_star returnK_maybe+      default_to_star Nothing  = Just DStarK+      default_to_star (Just k) = Just k+  defunctionalize name arg_kinds res_kind+buildDefunSyms (DTySynD name tvbs _type) = do+  let arg_m_kinds = map extractTvbKind tvbs+  defunctionalize name arg_m_kinds Nothing+buildDefunSyms _ = fail $ "Defunctionalization symbols can only be built for " +++                          "type families and data declarations"++buildDefunSymsDataD :: Name -> [DTyVarBndr] -> [DCon] -> PrM [DDec]+buildDefunSymsDataD tyName tvbs ctors = do+  let res_ty = foldType (DConT tyName) (map (DVarT . extractTvbName) tvbs)+  res_ki <- promoteType res_ty+  concatMapM (promoteCtor res_ki) ctors+  where+    promoteCtor :: DKind -> DCon -> PrM [DDec]+    promoteCtor promotedKind ctor = do+      let (name, arg_tys) = extractNameTypes ctor+      arg_kis <- mapM promoteType arg_tys+      defunctionalize name (map Just arg_kis) (Just promotedKind)++-- Generate data declarations and apply instances+-- required for defunctionalization.+-- For a type family:+--+-- type family Foo (m :: Nat) (n :: Nat) (l :: Nat) :: Nat+--+-- we generate data declarations that allow us to talk about partial+-- application at the type level:+--+-- type FooSym3 a b c = Foo a b c+-- data FooSym2 a b f where+--   FooSym2KindInference :: KindOf (Apply (FooSym2 a b) arg)+--                          ~ KindOf (FooSym3 a b arg)+--                        => FooSym2 a b f+-- type instance Apply (FooSym2 a b) c = FooSym3 a b c+-- data FooSym1 a f where+--   FooSym1KindInference :: KindOf (Apply (FooSym1 a) arg)+--                           ~ KindOf (FooSym2 a arg)+--                        => FooSym1 a f+-- type instance Apply (FooSym1 a) b = FooSym2 a b+-- data FooSym0 f where+--  FooSym0KindInference :: KindOf (Apply FooSym0 arg)+--                          ~ KindOf (FooSym1 arg)+--                       => FooSym0 f+-- type instance Apply FooSym0 a = FooSym1 a+--+-- What's up with all the "KindInference" stuff? In some scenarios, we don't+-- know the kinds that we should be using in these symbols. But, GHC can figure+-- it out using the types of the "KindInference" dummy data constructors. A+-- bit of a hack, but it works quite nicely. The only problem is that GHC will+-- warn about an unused data constructor. So, we use the data constructor in+-- an instance of a dummy class. (See Data.Singletons.Hidden for the class, which+-- should never be seen by anyone, ever.)+--+-- The defunctionalize function takes Maybe DKinds so that the caller can+-- indicate which kinds are known and which need to be inferred.+defunctionalize :: Name -> [Maybe DKind] -> Maybe DKind -> PrM [DDec]+defunctionalize name m_arg_kinds' m_res_kind' = do+  let (m_arg_kinds, m_res_kind) = eta_expand m_arg_kinds' m_res_kind'+      num_args = length m_arg_kinds+      sat_name = promoteTySym name num_args+  tvbNames <- replicateM num_args $ qNewName "t"+  let sat_dec = DTySynD sat_name (zipWith mk_tvb tvbNames m_arg_kinds)+                        (foldType (DConT name) (map DVarT tvbNames))+  other_decs <- go (num_args - 1) (reverse m_arg_kinds) m_res_kind+  return $ sat_dec : other_decs+  where+    mk_tvb :: Name -> Maybe DKind -> DTyVarBndr+    mk_tvb tvb_name Nothing  = DPlainTV tvb_name+    mk_tvb tvb_name (Just k) = DKindedTV tvb_name k++    eta_expand :: [Maybe DKind] -> Maybe DKind -> ([Maybe DKind], Maybe DKind)+    eta_expand m_arg_kinds Nothing = (m_arg_kinds, Nothing)+    eta_expand m_arg_kinds (Just res_kind) =+        let ks                 = unravelK res_kind+            (argKs, [resultK]) =  splitAt (length ks - 1) ks+        in (m_arg_kinds ++ (map Just argKs), Just resultK)++    unravelK :: DKind -> [DKind]+    unravelK (DForallK _name k) = unravelK k+    unravelK (DArrowK (DConK _ ks) DStarK) =+        concatMap unravelK ks+    unravelK (DArrowK k1 k2) = k1 : unravelK k2+    unravelK t = [t]++    go :: Int -> [Maybe DKind] -> Maybe DKind -> PrM [DDec]+    go _ [] _ = return []+    go n (m_arg : m_args) m_result = do+      decls <- go (n - 1) m_args (addStar_maybe (buildTyFun_maybe m_arg m_result))+      fst_name : rest_names <- replicateM (n + 1) (qNewName "l")+      extra_name <- qNewName "arg"+      let data_name   = promoteTySym name n+          next_name   = promoteTySym name (n+1)+          con_name    = suffixName "KindInference" "###" data_name+          m_tyfun     = buildTyFun_maybe m_arg m_result+          arg_params  = zipWith mk_tvb rest_names (reverse m_args)+          tyfun_param = mk_tvb fst_name m_tyfun+          arg_names   = map extractTvbName arg_params+          params      = arg_params ++ [tyfun_param]+          con_eq_ct   = foldl DAppPr (DConPr equalityName)+                          [ DConT kindOfName `DAppT`+                              (foldType (DConT data_name) (map DVarT arg_names)+                               `apply`+                               (DVarT extra_name))+                          , DConT kindOfName `DAppT`+                            foldType (DConT next_name) (map DVarT (arg_names ++ [extra_name]))+                          ]+          con_decl    = DCon [DPlainTV extra_name]+                             [con_eq_ct]+                             con_name+                             (DNormalC [])+          data_decl   = DDataD Data [] data_name params [con_decl] []+          app_eqn     = DTySynEqn [ foldType (DConT data_name)+                                             (map DVarT rest_names)+                                  , DVarT fst_name ]+                                  (foldType (DConT (promoteTySym name (n+1)))+                                            (map DVarT (rest_names ++ [fst_name])))+          app_decl    = DTySynInstD applyName app_eqn+          suppress    = DInstanceD [] (DConT suppressClassName `DAppT` DConT data_name)+                          [DLetDec $ DFunD suppressMethodName+                                           [DClause [DWildPa]+                                                    ((DVarE 'snd) `DAppE`+                                                     mkTupleDExp [DConE con_name,+                                                                  mkTupleDExp []])]]+      return $ suppress : data_decl : app_decl : decls++buildTyFun :: DKind -> DKind -> DKind+buildTyFun k1 k2 = DConK tyFunName [k1, k2]++buildTyFun_maybe :: Maybe DKind -> Maybe DKind -> Maybe DKind+buildTyFun_maybe m_k1 m_k2 = do+  k1 <- m_k1+  k2 <- m_k2+  return $ DConK tyFunName [k1, k2]++-- Counts the arity of type level function represented with TyFun constructors+tyFunArity :: DKind -> Int+tyFunArity (DArrowK (DConK tyFunNm [_, b]) DStarK)+  | tyFunName == tyFunNm+  = 1 + tyFunArity b+tyFunArity _ = 0++-- Checks if type is (TyFun a b -> *)+isTyFun :: DKind -> Bool+isTyFun (DArrowK (DConK tyFunNm [_,_]) DStarK)+  | tyFunName == tyFunNm+  = True+isTyFun _ = False++-- Build TyFun kind from the list of kinds+ravelTyFun :: [DKind] -> DKind+ravelTyFun []    = error "Internal error: TyFun raveling nil"+ravelTyFun [k]   = k+ravelTyFun kinds = go tailK (buildTyFun k2 k1)+    where (k1 : k2 : tailK) = reverse kinds+          go []     acc = addStar acc+          go (k:ks) acc = go ks (buildTyFun k (addStar acc))
+ src/Data/Singletons/Promote/Eq.hs view
@@ -0,0 +1,110 @@+{- Data/Singletons/Promote/Eq.hs++(c) Richard Eisenberg 2014+eir@cis.upenn.edu++This module defines the functions that generate type-level equality type+family instances.+-}++{-# LANGUAGE CPP #-}++module Data.Singletons.Promote.Eq where++import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Desugar+import Data.Singletons.Names+import Data.Singletons.Util+import Control.Monad++-- Why do we have two different versions of this code? Because GHC 7.6, which+-- doesn't allow any overlap among type family equations, needs O(n^2) instances.+-- Yuck. But, GHC 7.8 can get away with only O(n) equations in a closed type+-- family. The difference is significant enough to make it worth maintaining two+-- different generation functions, in RAE's opinion.+--+-- If we wish to change this, delete the 7.8 code -- the 7.6 code should work+-- just fine under 7.8.++#if __GLASGOW_HASKELL__ >= 707+-- produce a closed type family helper and the instance+-- for (:==) over the given list of ctors+mkEqTypeInstance :: Quasi q => DKind -> [DCon] -> q [DDec]+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 = DClosedTypeFamilyD helperName+                                     [ DKindedTV aName kind+                                     , DKindedTV bName kind ]+                                     (Just boolKi)+                                     (true_branches ++ [false_branch])+      eqInst = DTySynInstD tyEqName (DTySynEqn [ DSigT (DVarT aName) kind+                                               , DSigT (DVarT bName) kind ]+                                             (foldType (DConT helperName)+                                                       [DVarT aName, DVarT bName]))+      inst = DInstanceD [] ((DConT $ promoteClassName eqName) `DAppT`+                            kindParam kind) [eqInst]+                                     +  return [closedFam, inst]++  where mk_branch :: Quasi q => DCon -> q DTySynEqn+        mk_branch con = do+          let (name, numArgs) = extractNameArgs con+          lnames <- replicateM numArgs (qNewName "a")+          rnames <- replicateM numArgs (qNewName "b")+          let lvars = map DVarT lnames+              rvars = map DVarT rnames+              ltype = foldType (DConT name) lvars+              rtype = foldType (DConT name) rvars+              results = zipWith (\l r -> foldType (DConT tyEqName) [l, r]) lvars rvars+              result = tyAll results+          return $ DTySynEqn [ltype, rtype] result++        false_case :: Quasi q => q DTySynEqn+        false_case = do+          lvar <- qNewName "a"+          rvar <- qNewName "b"+          return $ DTySynEqn [DSigT (DVarT lvar) kind, DSigT (DVarT rvar) kind]+                             (promoteValRhs falseName)++        tyAll :: [DType] -> DType -- "all" at the type level+        tyAll [] = (promoteValRhs trueName)+        tyAll [one] = one+        tyAll (h:t) = foldType (DConT $ promoteValNameLhs andName) [h, (tyAll t)]+           -- I could use the Apply nonsense here, but there's no reason to++#else++-- produce the type instance for (:==) for the given pair of constructors+mkEqTypeInstance :: Quasi q => (DCon, DCon) -> q DDec+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 DVarT lnames+        rvars = map DVarT rnames+    return $ DTySynInstD tyEqName $ DTySynEqn+      [foldType (DConT name) lvars,+       foldType (DConT name) rvars]+      (tyAll (zipWith (\l r -> foldType (DConT 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 $ DTySynInstD tyEqName $ DTySynEqn+      [foldType (DConT lname) (map DVarT lnames),+       foldType (DConT rname) (map DVarT rnames)]+      falseTySym+  where tyAll :: [DType] -> DType -- "all" at the type level+        tyAll [] = trueTySym+        tyAll [one] = one+        tyAll (h:t) = foldType (DConT $ promoteValNameLhs andName) [h, (tyAll t)]++#endif
+ src/Data/Singletons/Promote/Monad.hs view
@@ -0,0 +1,159 @@+{- Data/Singletons/Promote/Monad.hs++(c) Richard Eisenberg 2014+eir@cis.upenn.edu++This file defines the PrM monad and its operations, for use during promotion.++The PrM monad allows reading from a PrEnv environment and writing to a list+of DDec, and is wrapped around a Q.+-}++{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving, CPP,+             FlexibleContexts, TypeFamilies, KindSignatures #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}   -- we have orphan Quasi instances++module Data.Singletons.Promote.Monad (+  PrM, promoteM, promoteM_, promoteMDecs, VarPromotions,+  allLocals, emitDecs, emitDecsM,+  lambdaBind, LetBind, letBind, lookupVarE+  ) where++import Control.Monad.Reader+import Control.Monad.Writer+import qualified Data.Map.Strict as Map+import Data.Map.Strict ( Map )+import Language.Haskell.TH.Syntax hiding ( lift )+import Language.Haskell.TH.Desugar+import Data.Singletons.Util+import Control.Applicative+import Data.Singletons.Names+import Data.Singletons.Syntax++type LetExpansions = Map Name DType  -- from **term-level** name++-- environment during promotion+data PrEnv =+  PrEnv { pr_lambda_bound :: Map Name Name+        , pr_let_bound    :: LetExpansions+        }++emptyPrEnv :: PrEnv+emptyPrEnv = PrEnv { pr_lambda_bound = Map.empty+                   , pr_let_bound    = Map.empty }++-- the promotion monad+newtype PrM a = PrM (ReaderT PrEnv (WriterT [DDec] Q) a)+  deriving ( Functor, Applicative, Monad, Quasi+           , MonadReader PrEnv, MonadWriter [DDec] )++-- we need Quasi instances for ReaderT and WriterT for the above to work.++instance (Quasi q, Monoid m) => Quasi (WriterT 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 handler body = do+    (result, aux) <- lift $ qRecover (runWriterT handler) (runWriterT body)+    tell aux+    return result++instance Quasi q => Quasi (ReaderT r 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 handler body = do+    env <- ask+    lift $ qRecover (runReaderT handler env) (runReaderT body env)++-- return *type-level* names+allLocals :: MonadReader PrEnv m => m [Name]+allLocals = do+  lambdas <- asks (Map.toList . pr_lambda_bound)+  lets    <- asks pr_let_bound+    -- filter out shadowed variables!+  return [ typeName+         | (termName, typeName) <- lambdas+         , case Map.lookup termName lets of+             Just (DVarT typeName') | typeName' == typeName -> True+             _                                              -> False ]++emitDecs :: MonadWriter [DDec] m => [DDec] -> m ()+emitDecs = tell++emitDecsM :: MonadWriter [DDec] m => m [DDec] -> m ()+emitDecsM action = do+  decs <- action+  emitDecs decs++-- when lambda-binding variables, we still need to add the variables+-- to the let-expansion, because of shadowing. ugh.+lambdaBind :: VarPromotions -> PrM a -> PrM a+lambdaBind binds = local add_binds+  where add_binds env@(PrEnv { pr_lambda_bound = lambdas+                             , pr_let_bound    = lets }) =+          let new_lets = Map.fromList [ (tmN, DVarT tyN) | (tmN, tyN) <- binds ] in+          env { pr_lambda_bound = Map.union (Map.fromList binds) lambdas+              , pr_let_bound    = Map.union new_lets lets }++type LetBind = (Name, DType)+letBind :: [LetBind] -> PrM a -> PrM a+letBind binds = local add_binds+  where add_binds env@(PrEnv { pr_let_bound = lets }) =+          env { pr_let_bound = Map.union (Map.fromList binds) lets }++lookupVarE :: Name -> PrM DType+lookupVarE n = do+  lets <- asks pr_let_bound+  case Map.lookup n lets of+    Just ty -> return ty+    Nothing -> return $ promoteValRhs n++promoteM :: Quasi q => PrM a -> q (a, [DDec])+promoteM (PrM rdr) =+  let wr = runReaderT rdr emptyPrEnv+      q  = runWriterT wr+  in+  runQ q++promoteM_ :: Quasi q => PrM () -> q [DDec]+promoteM_ thing = do+  ((), decs) <- promoteM thing+  return decs++-- promoteM specialized to [DDec]+promoteMDecs :: Quasi q => PrM [DDec] -> q [DDec]+promoteMDecs thing = do+  (decs1, decs2) <- promoteM thing+  return $ decs1 ++ decs2+
+ src/Data/Singletons/Promote/Ord.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE TemplateHaskell #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Singletons.Promote.Ord+-- Copyright   :  (C) 2014 Jan Stolarek+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  Jan Stolarek (jan.stolarek@p.lodz.pl)+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Implements deriving of promoted Ord instances+--+----------------------------------------------------------------------------++module Data.Singletons.Promote.Ord where++import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Desugar+import Data.Singletons.Names+import Data.Singletons.Util++mkOrdTypeInstance :: Quasi q => DKind -> [DCon] -> q [DDec]+mkOrdTypeInstance kind cons = do+  let tagged_cons = zip cons [1..]+      con_pairs   = [ (c1, c2) | c1 <- tagged_cons, c2 <- tagged_cons ]+  eqns <- mapM mkOrdTySynEqn con_pairs+  let tyfam_insts = map (DTySynInstD tyCompareName) eqns+      pord_name   = promoteClassName ordName+      pord_inst   = DInstanceD [] (DConT pord_name `DAppT` kindParam kind)+                               tyfam_insts+  return [pord_inst]++mkOrdTySynEqn :: Quasi q => ((DCon, Int), (DCon, Int)) -> q DTySynEqn+mkOrdTySynEqn ((c1, n1), (c2, n2)) = do+  let DCon _tvbs1 _cxt1 con_name1 con_fields1 = c1+      DCon _tvbs2 _cxt2 con_name2 con_fields2 = c2+  lhs_names <- mapM (const $ qNewName "lhs") (tysOfConFields con_fields1)+  rhs_names <- mapM (const $ qNewName "rhs") (tysOfConFields con_fields2)+  let lhs_ty = foldType (DConT con_name1) (map DVarT lhs_names)+      rhs_ty = foldType (DConT con_name2) (map DVarT rhs_names)+      result = case n1 `compare` n2 of+        EQ -> let cmps   = zipWith (\lhs rhs ->+                                     foldType (DConT tyCompareName) [ DVarT lhs+                                                                    , DVarT rhs ])+                           lhs_names rhs_names+              in+              foldl (\l r -> foldType (DConT tyThenCmpName) [l, r])+                    (DConT 'EQ) cmps++        LT -> DConT 'LT+        GT -> DConT 'GT+  return $ DTySynEqn [lhs_ty, rhs_ty] result++{-+-- Note [Deriving Ord]+-- ~~~~~~~~~~~~~~~~~~~+--+-- We derive instances of Ord by generating promoted instance of Compare.  Under+-- GHC 7.8 this is done by generating a closed type family that does tha+-- comparing for given datatype and then making appropriate instance of Compare+-- open type family. There are two interesting points in this+-- algorithm. Firstly we minimize the number of equations required to compare+-- all existing data constructors. To do this we use a catch-all equations. For+-- example for this data type:+--+--  data Foo = A | B | C | D | E | F deriving (Eq,Ord)+--+-- We generate equations:+--+--  CompareFoo A A = EQ+--  CompareFoo A a = LT -- catch-all case+--  CompareFoo B A = GT+--  CompareFoo B B = EQ+--  CompareFoo B a = LT -- catch-all case+--+-- This however would be very inefficient for the last constructor:+--+--  CompareFoo F A = GT+--  CompareFoo F B = GT+--  CompareFoo F C = GT+--  CompareFoo F D = GT+--  CompareFoo F E = GT+--  CompareFoo F F = EQ+--+-- So once we get past half of the constructors we reverse the order in which we+-- test second constructor passed to Compare:+--+--  CompareFoo F F = EQ+--  CompareFoo F a = GT+--  CompareFoo E F = LT+--  CompareFoo E E = EQ+--  CompareFoo E a = GT+--+-- Second interesting point in our algorithm is comparing identical+-- constructors. Obviously if they store no data they are equal. But if+-- constructor has any fields then they must be compared by calling Compare on+-- every field until we get LT or GT result. To do this we generate a helper+-- type function that does all the comparing. For example (,,) constructor has+-- three fields and we generate this code:+--+-- type family OrderingEqualCase (t1 :: Ordering)+--                               (t2 :: Ordering)+--                               (t3 :: Ordering) :: Ordering where+--   OrderingEqualCase LTSym0 a      b      = LTSym0+--   OrderingEqualCase GTSym0 a      b      = GTSym0+--   OrderingEqualCase EQSym0 LTSym0 b      = LTSym0+--   OrderingEqualCase EQSym0 GTSym0 b      = GTSym0+--   OrderingEqualCase EQSym0 EQSym0 LTSym0 = LTSym0+--   OrderingEqualCase EQSym0 EQSym0 GTSym0 = GTSym0+--   OrderingEqualCase EQSym0 EQSym0 EQSym0 = EQSym0+--+--  type family Compare_helper (a :: (k1,k2,k3)) (b :: (k1,k2,k3) :: Ordering where+--    Compare_helper (a1,a2,a3) (b1,b2,b3) =+--      OrderingEqualCase (Compare a1 b1) (Compare a2 b2) (Compare a3 b3)+--+---- Notice that we perform only necessary comparisons. If we can determine+---- ordering based on comparing first field we ignore the remaining fields+---- (although this implementation requires that we actually compare all fields+---- at the call site).++mkOrdTypeInstance :: Quasi q => DKind -> [DCon] -> q [DDec]+mkOrdTypeInstance kind cons = do+  let taggedCons   = zip cons [1..]+      l            = length cons+      half         = l `div` 2 + l `mod` 2+      combinations = [ (x,y) | x@(_, t1) <- taggedCons+                             , y@(_, t2) <- taggedCons+                             , (t1 <= half && t2 <= t1 + 1) ||+                               (t1 >  half && t2 >= t1 - 1) ]+      groupedCombs = groupBy equalFirstTags combinations+      equalFirstTags ((_,t1),_) ((_,t2),_) = t1 == t2+      reverseOrder [] = []+      reverseOrder xs@(((_,t),_):_) = if t > half+                                      then reverse xs+                                      else xs+      consPairs    = concat (map reverseOrder groupedCombs)+  helperName <- newUniqueName "Compare"+  aName <- qNewName "a"+  bName <- qNewName "b"+  (compareEqns, eqDecs) <- evalForPair $ mapM (mkCompareEqn half) consPairs+  let closedFam = DClosedTypeFamilyD helperName+                                     [ DKindedTV aName kind+                                     , DKindedTV bName kind ]+                                     (Just (DConK orderingName []))+                                     compareEqns+      compareInst = DTySynInstD tyCompareName+                               (DTySynEqn [ DSigT (DVarT aName) kind+                                          , DSigT (DVarT bName) kind ]+                                          (foldType (DConT helperName)+                                                    [DVarT aName, DVarT bName]))+  return (closedFam : compareInst : eqDecs)++  where mkCompareEqn :: Quasi q => Int -> ((DCon, Int), (DCon, Int))+                                -> QWithAux [DDec] q DTySynEqn+        mkCompareEqn half ((con1, tag1), (con2, tag2))+            | tag1 > tag2 && tag1 <= half =+                mkCompareEqnHelper con1 (Just con2) gtT+            | tag1 < tag2 && tag1 >  half = do+                mkCompareEqnHelper con1 (Just con2) ltT+            | tag1 < tag2 && tag1 <= half =+                mkCompareEqnHelper con1 Nothing ltT+            | tag1 > tag2 && tag1 >  half =+                mkCompareEqnHelper con1 Nothing gtT+            | otherwise =+                mkCompareEqual con1++        eqT = DConT ordEQSymName+        ltT = DConT ordLTSymName+        gtT = DConT ordGTSymName++        mkCompareEqnHelper :: Quasi q => DCon -> Maybe DCon -> DType -> q DTySynEqn+        mkCompareEqnHelper con1 con2 result = do+            let (name1, numArgs1) = extractNameArgs con1+            (name2, numArgs2) <- case con2 of+                  Just c  -> let (n, numArgs) = extractNameArgs c+                             in  return (DConT n, numArgs)+                  Nothing -> qNewName "z" >>= (\n -> return (DVarT n, 0))+            lnames <- replicateM numArgs1 (qNewName "a")+            rnames <- replicateM numArgs2 (qNewName "b")+            let lvars = map DVarT lnames+                rvars = map DVarT rnames+                ltype = foldType (DConT name1) lvars+                rtype = foldType name2 rvars+            return $ DTySynEqn [ltype, rtype] result++        mkCompareEqual :: Quasi q => DCon -> QWithAux [DDec] q DTySynEqn+        mkCompareEqual con = do+            let (name, numArgs) = extractNameArgs con+            case numArgs of+              -- If constructor has no fields it is equal to itself+              0 -> return $ DTySynEqn [DConT name, DConT name] eqT+              -- But if it has fields we have to compare them one by one+              _ -> do+                helperName <- newUniqueName "OrderingEqualCase"+                -- Build helper type family that does the comparison+                buildHelperTyFam numArgs helperName++                -- Call the helper function+                lnames <- replicateM numArgs (qNewName "a")+                rnames <- replicateM numArgs (qNewName "b")+                let lvars      = map DVarT lnames+                    rvars      = map DVarT rnames+                    ltype      = foldType (DConT name) lvars+                    rtype      = foldType (DConT name) rvars+                    callParams = zipWith (\l r -> foldType (DConT tyCompareName) [l,r])+                                          lvars rvars+                    call = foldType (DConT helperName) callParams+                return $ DTySynEqn [ltype, rtype] call+            where+                  buildHelperTyFam :: Quasi q => Int -> Name -> QWithAux [DDec] q ()+                  buildHelperTyFam numArgs helperName = do+                    let orderingKCon = DConK orderingName []+                    (patterns, results) <- buildEqnPats numArgs ([[]], [eqT])+                    tyFamParamNames <- replicateM numArgs (qNewName "a")+                    let eqns = map (uncurry DTySynEqn) (zip patterns results)+                        closedFam = DClosedTypeFamilyD helperName+                                      (zipWith DKindedTV tyFamParamNames+                                              (repeat orderingKCon))+                                      (Just orderingKCon)+                                      eqns+                    addElement closedFam+                    return ()++                  buildEqnPats :: Quasi q => Int -> ([[DType]], [DType])+                                          -> q ([[DType]], [DType])+                  buildEqnPats 0 acc = return acc+                  buildEqnPats n acc = do+                    let eqns    = fst acc+                        results = snd acc+                        eqnNo   = length (head eqns)+                        newEqs  = map (eqT :) eqns+                    names <- replicateM eqnNo (qNewName "a")+                    let tys   = map DVarT names+                        ltRow = ltT : tys+                        gtRow = gtT : tys+                    buildEqnPats (n-1) ( ltRow : gtRow : newEqs+                                       , ltT : gtT : results )++-}
+ src/Data/Singletons/Promote/Type.hs view
@@ -0,0 +1,50 @@+{- Data/Singletons/Type.hs++(c) Richard Eisenberg 2013+eir@cis.upenn.edu++This file implements promotion of types into kinds.+-}++module Data.Singletons.Promote.Type ( promoteType ) where++import Language.Haskell.TH.Desugar+import Data.Singletons.Names+import Data.Singletons.Util+import Language.Haskell.TH++-- the only monadic thing we do here is fail. This allows the function+-- to be used from the Singletons module+promoteType :: Monad m => DType -> m DKind+promoteType = go []+  where+    go :: Monad m => [DKind] -> DType -> m DKind+    -- 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.+    go []       (DForallT _tvbs _cxt ty) = go [] ty+    go []       (DAppT (DAppT DArrowT (DForallT (_:_) _ _)) _) =+      fail "Cannot promote types of rank above 1."+    go args     (DAppT t1 t2) = do+      k2 <- go [] t2+      go (k2 : args) t1+    go args     (DSigT ty _) = go args ty  -- just ignore signatures+    go []       (DVarT name) = return $ DVarK name+    go _        (DVarT name) = fail $ "Cannot promote an applied type variable " +++                                      show name ++ "."+    go []       (DConT name)+      | name == typeRepName               = return DStarK+      | name == stringName                = return $ DConK symbolName []+      | nameBase name == nameBase repName = return DStarK+    go args     (DConT name)+      | Just n <- unboxedTupleNameDegree_maybe name+      = return $ DConK (tupleTypeName n) args+      | otherwise+      = return $ DConK name args+    go [k1, k2] DArrowT = return $ addStar (DConK tyFunName [k1, k2])+    go _ (DLitT _) = fail "Cannot promote a type-level literal"++    go args     hd = fail $ "Illegal Haskell construct encountered:\n" +++                            "headed by: " ++ show hd ++ "\n" +++                            "applied to: " ++ show args
+ src/Data/Singletons/Single.hs view
@@ -0,0 +1,363 @@+{- Data/Singletons/Single.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, ParallelListComp #-}++module Data.Singletons.Single where++import Prelude hiding ( exp )+import Language.Haskell.TH hiding ( cxt )+import Language.Haskell.TH.Syntax (Quasi(..))+import Data.Singletons.Util+import Data.Singletons.Promote+import Data.Singletons.Promote.Monad ( promoteM, promoteM_ )+import Data.Singletons.Names+import Data.Singletons.Single.Monad+import Data.Singletons.Single.Type+import Data.Singletons.Single.Data+import Data.Singletons.Single.Eq+import Data.Singletons.Syntax+import Language.Haskell.TH.Desugar+import Language.Haskell.TH.Desugar.Sweeten+import qualified Data.Map.Strict as Map+import Data.Map.Strict ( Map )+import Control.Monad+import Control.Applicative++{-+How singletons works+~~~~~~~~~~~~~~~~~~~~++Singling, on the surface, doesn't seem all that complicated. Promote the type,+and singletonize all the terms. That's essentially what was done singletons < 1.0.+But, now we want to deal with higher-order singletons. So, things are a little+more complicated.++The way to understand all of this is that *every* variable maps to something+of type (Sing t), for an appropriately-kinded t. This includes functions, which+use the "SLambda" instance of Sing. To apply singleton functions, we use the+applySing function.++That, in an of itself, wouldn't be too hard, but it's really annoying from+the user standpoint. After dutifully singling `map`, a user doesn't want to+have to use two `applySing`s to actually use it. So, any let-bound identifier+is eta-expanded so that the singled type has the same number of arrows as+the original type. (If there is no original type signature, then it has as+many arrows as the original had patterns.) Then, we store a use of one of the+singFunX functions in the SgM environment so that every use of a let-bound+identifier has a proper type (Sing t).++It would be consistent to avoid this eta-expansion for local lets (as opposed+to top-level lets), but that seemed like more bother than it was worth. It+may also be possible to be cleverer about nested eta-expansions and contractions,+but that also seemed not to be worth it. Though I haven't tested it, my hope+is that the eta-expansions and contractions have no runtime effect, especially+because SLambda is a *newtype* instance, not a *data* instance.++Note that to maintain the desired invariant, we must also be careful to eta-+contract constructors. This is the point of buildLets.+-}++-- | 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+  ddecs <- concatMapM (singInfo <=< dsInfo <=< reifyWithWarning) names+  return $ decsToTH ddecs++-- | 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 qdecs = do+  decs <- qdecs+  singDecs <- wrapDesugar singTopLevelDecs decs+  return (decs ++ singDecs)++-- | Make promoted and singleton versions of all declarations given, discarding+-- the original declarations.+singletonsOnly :: Quasi q => q [Dec] -> q [Dec]+singletonsOnly = (>>= wrapDesugar singTopLevelDecs)++-- | 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 = 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 = 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+  dtvbs <- mapM dsTvb tvbs+  dcons <- mapM dsCon cons+  let tyvars = map (DVarK . extractTvbName) dtvbs+      kind = DConK name tyvars+  aName <- qNewName "a"+  let aVar = DVarT aName+  (scons, _) <- singM $ mapM (singCtor aVar) dcons+  eqInstance <- mkEqualityInstance kind scons desc+  return $ decToTH eqInstance++singInfo :: Quasi q => DInfo -> q [DDec]+singInfo (DTyConI dec Nothing) = do -- TODO: document this special case+  singTopLevelDecs [dec]+singInfo (DTyConI {}) =+  fail "Singling of things with instances not yet supported" -- TODO: fix+singInfo (DPrimTyConI _name _numArgs _unlifted) =+  fail "Singling of primitive type constructors not supported"+singInfo (DVarI _name _ty _mdec _fixity) =+  fail "Singling of value info not supported"+singInfo (DTyVarI _name _ty) =+  fail "Singling of type variable info not supported"++singTopLevelDecs :: Quasi q => [DDec] -> q [DDec]+singTopLevelDecs decls = do+  PDecs { pd_let_decs              = letDecls+        , pd_class_decs            = classes+        , pd_instance_decs         = insts+        , pd_data_decs             = datas }    <- partitionDecs decls++  when (not (null classes) || not (null insts)) $+    qReportError "Classes and instances may not yet be made into singletons."++  dataDecls' <- promoteM_ $ promoteDataDecs datas+  ((_, letDecEnv), letDecls') <- promoteM $ promoteLetDecs noPrefix letDecls+  singDecsM $ do+    let letBinds = concatMap buildDataLets datas+                ++ concatMap buildMethLets classes+    (newLetDecls, newDataDecls) <- bindLets letBinds $+                                   singLetDecEnv TopLevel letDecEnv $+                                   concatMapM singDataD datas+    return $ dataDecls' ++ letDecls' ++ (map DLetDec newLetDecls) ++ newDataDecls++-- see comment at top of file+buildDataLets :: DataDecl -> [(Name, DExp)]+buildDataLets (DataDecl _nd _name _tvbs cons _derivings) =+  concatMap con_num_args cons+  where+    con_num_args :: DCon -> [(Name, DExp)]+    con_num_args (DCon _tvbs _cxt name fields) =+      (name, wrapSingFun (length (tysOfConFields fields))+                         (promoteValRhs name) (DConE $ singDataConName name))+      : rec_selectors fields++    rec_selectors :: DConFields -> [(Name, DExp)]+    rec_selectors (DNormalC {}) = []+    rec_selectors (DRecC fields) =+      let names = map fstOf3 fields in+      [ (name, wrapSingFun 1 (promoteValRhs name) (DVarE $ singValName name))+      | name <- names ]++buildMethLets :: ClassDecl -> [(Name, DExp)]+buildMethLets = error "Cannot singletonize class definitions yet."+  -- FIXME!++singLetDecEnv :: TopLevelFlag -> ALetDecEnv -> SgM a -> SgM ([DLetDec], a)+singLetDecEnv top_level+              (LetDecEnv { lde_defns = defns+                         , lde_types = types+                         , lde_infix = infix_decls+                         , lde_proms = proms })+              thing_inside = do+  (typeSigs, letBinds, tyvarNames)+    <- mapAndUnzip3M (uncurry sing_ty_sig) (Map.toList proms)+  let infix_decls' = map (uncurry sing_infix_decl) infix_decls+  bindLets letBinds $ do+    let_decs <- mapM (uncurry (sing_let_dec (Map.fromList tyvarNames))) (Map.toList defns)+    thing <- thing_inside+    return (infix_decls' ++ typeSigs ++ let_decs, thing)+  where+    sing_infix_decl :: Fixity -> Name -> DLetDec+    sing_infix_decl fixity name+      | isUpcase name =+        -- is it a tycon name or a datacon name??+        -- it *must* be a datacon name, because symbolic tycons+        -- can't be promoted. This is terrible.+        DInfixD fixity (singDataConName name)+      | otherwise = DInfixD fixity (singValName name)++    sing_ty_sig :: Name -> DType   -- the type is the promoted type, not the type sig!+                -> SgM ( DLetDec               -- the new type signature+                       , (Name, DExp)          -- the let-bind entry+                       , (Name, [Name])        -- the scoped tyvar names in the tysig+                       )+    sing_ty_sig name prom_ty =+      let sName = singValName name in+      case Map.lookup name types of+        Nothing -> do+          num_args <- guess_num_args name+          (sty, tyvar_names) <- mk_sing_ty num_args prom_ty+          return ( DSigD sName sty+                 , (name, wrapSingFun num_args prom_ty (DVarE sName))+                 , (name, tyvar_names) )+        Just ty -> do+          (sty, num_args, tyvar_names) <- singType top_level prom_ty ty+          return ( DSigD sName sty+                 , (name, wrapSingFun num_args prom_ty (DVarE sName))+                 , (name, tyvar_names) )++    guess_num_args :: Name -> SgM Int+    guess_num_args name =+      case Map.lookup name defns of+        Nothing -> fail "Internal error: promotion known for something not let-bound."+        Just (AValue _ n _) -> return n+        Just (AFunction _ n _) -> return n++      -- create a Sing t1 -> Sing t2 -> ... type of a given arity and result type+    mk_sing_ty :: Int -> DType -> SgM (DType, [Name])+    mk_sing_ty n prom_ty = do+      arg_names <- replicateM n (qNewName "arg")+      return ( DForallT (map DPlainTV arg_names) []+                        (ravel (map (\name -> singFamily `DAppT` DVarT name) arg_names+                                ++ [singFamily `DAppT`+                                    (foldl apply prom_ty (map DVarT arg_names))]))+             , arg_names )++    sing_let_dec :: Map Name [Name] -> Name -> ALetDecRHS -> SgM DLetDec+    sing_let_dec _bound_names name (AValue prom num_arrows exp) =+      DValD (DVarPa (singValName name)) <$>+      (wrapUnSingFun num_arrows prom <$> singExp exp)+    sing_let_dec bound_names name (AFunction prom_fun num_arrows clauses) =+      let tyvar_names = case Map.lookup name bound_names of+                          Nothing -> []+                          Just ns -> ns+      in+      DFunD (singValName name) <$> mapM (singClause prom_fun num_arrows tyvar_names) clauses++singClause :: DType   -- the promoted function+           -> Int     -- the number of arrows in the type. If this is more+                      -- than the number of patterns, we need to eta-expand+                      -- with unSingFun.+           -> [Name]  -- the names of the forall'd vars in the type sig of this+                      -- function. This list should have at least the length as the+                      -- number of patterns in the clause+           -> ADClause -> SgM DClause+singClause prom_fun num_arrows bound_names (ADClause var_proms pats exp) = do+  ((sPats, prom_pats), wilds)+    <- evalForPair $ mapAndUnzipM (singPat (Map.fromList var_proms) Parameter) pats+  let equalities = zip (map DVarT bound_names) prom_pats+      applied_ty = foldl apply prom_fun prom_pats+  sBody <- bindTyVarsClause var_proms wilds applied_ty equalities $ singExp exp+    -- when calling unSingFun, the prom_pats aren't in scope, so we use the+    -- bound_names instead+  let pattern_bound_names = zipWith const bound_names pats+       -- this does eta-expansion. See comment at top of file.+      sBody' = wrapUnSingFun (num_arrows - length pats)+                 (foldl apply prom_fun (map DVarT pattern_bound_names)) sBody+  return $ DClause sPats sBody'++-- we need to know where a pattern is to anticipate when+-- GHC's brain might explode+data PatternContext = LetBinding+                    | CaseStatement+                    | Parameter+                    deriving Eq++checkIfBrainWillExplode :: Monad m => PatternContext -> m ()+checkIfBrainWillExplode CaseStatement = 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!)"++singPat :: Map Name Name   -- from term-level names to type-level names+        -> PatternContext -> DPat -> QWithAux [Name]  -- these names must be forall-bound+                                     SgM ( DPat+                                         , DType ) -- the type form of the pat+singPat _var_proms _patCxt (DLitPa _lit) =+  fail "Singling of literal patterns not yet supported"+singPat var_proms _patCxt (DVarPa name) = do+  tyname <- case Map.lookup name var_proms of+              Nothing     -> qNewName (nameBase name)+              Just tyname -> return tyname+  return (DVarPa (singValName name), DVarT tyname)+singPat var_proms patCxt (DConPa name pats) = do+  checkIfBrainWillExplode patCxt+  (pats', tys) <- mapAndUnzipM (singPat var_proms patCxt) pats+  return ( DConPa (singDataConName name) pats'+         , foldl apply (promoteValRhs name) tys )+singPat var_proms patCxt (DTildePa pat) = do+  qReportWarning+    "Lazy pattern converted into regular pattern during singleton generation."+  singPat var_proms patCxt pat+singPat var_proms patCxt (DBangPa pat) = do+  (pat', ty) <- singPat var_proms patCxt pat+  return (DBangPa pat', ty)+singPat _var_proms _patCxt DWildPa = do+  wild <- qNewName "wild"+  addElement wild+  return (DWildPa, DVarT wild)++singExp :: ADExp -> SgM DExp+singExp (ADVarE name)  = lookupVarE name+singExp (ADConE name)  = lookupConE name+singExp (ADLitE lit)   = singLit lit+singExp (ADAppE e1 e2) = do+  e1' <- singExp e1+  e2' <- singExp e2+  return $ (DVarE applySingName) `DAppE` e1' `DAppE` e2'+singExp (ADLamE var_proms prom_lam names exp) = do+  let sNames = map singValName names+  exp' <- bindTyVars var_proms [] (foldl apply prom_lam (map (DVarT . snd) var_proms)) $+          singExp exp+  return $ wrapSingFun (length names) prom_lam $ DLamE sNames exp'+singExp (ADCaseE exp matches) = DCaseE <$> singExp exp <*> mapM singMatch matches+singExp (ADLetE env exp) =+  uncurry DLetE <$> singLetDecEnv NotTopLevel env (singExp exp)+singExp (ADSigE {}) =+  fail "Singling of explicit type annotations not yet supported."++singMatch :: ADMatch -> SgM DMatch+singMatch (ADMatch var_proms prom_match pat exp) = do+  ((sPat, prom_pat), wilds)+    <- evalForPair $ singPat (Map.fromList var_proms) CaseStatement pat+        -- why DAppT below? See comment near decl of ADMatch in LetDecEnv.+  sExp <- bindTyVars var_proms wilds (prom_match `DAppT` prom_pat) $ singExp exp+  return $ DMatch sPat sExp++singLit :: Lit -> SgM DExp+singLit lit = DSigE (DVarE singMethName) <$> (DAppT singFamily <$> (promoteLit lit))
+ src/Data/Singletons/Single/Data.hs view
@@ -0,0 +1,148 @@+{- Data/Singletons/Single/Data.hs++(c) Richard Eisenberg 2013+eir@cis.upenn.edu++Singletonizes constructors.+-}++{-# LANGUAGE ParallelListComp, TupleSections #-}++module Data.Singletons.Single.Data where++import Language.Haskell.TH.Desugar+import Language.Haskell.TH.Syntax+import Data.Singletons.Single.Monad+import Data.Singletons.Single.Type+import Data.Singletons.Promote.Type+import Data.Singletons.Single.Eq+import Data.Singletons.Util+import Data.Singletons.Names+import Data.Singletons.Syntax+import Control.Monad++-- We wish to consider the promotion of "Rep" to be *+-- not a promoted data constructor.+singDataD :: DataDecl -> SgM [DDec]+singDataD (DataDecl _nd name tvbs ctors derivings) = do+  aName <- qNewName "z"+  let a = DVarT aName+  let tvbNames = map extractTvbName tvbs+  k <- promoteType (foldType (DConT name) (map DVarT tvbNames))+  ctors' <- mapM (singCtor a) ctors++  -- instance for SingKind+  fromSingClauses <- mapM mkFromSingClause ctors+  toSingClauses   <- mapM mkToSingClause ctors+  let singKindInst =+        DInstanceD (map (singKindConstraint . DVarK) tvbNames)+                   (DAppT (DConT singKindClassName)+                          (kindParam k))+                   [ DTySynInstD demoteRepName $ DTySynEqn+                      [kindParam k]+                      (foldType (DConT name)+                        (map (DAppT demote . kindParam . DVarK) tvbNames))+                   , DLetDec $ DFunD fromSingName (fromSingClauses `orIfEmpty` emptyMethod aName)+                   , DLetDec $ DFunD 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 =+        DTySynD (singTyConName name)+                [DKindedTV aName k]+                (DAppT singFamily a)++  return $ (DDataInstD Data [] singFamilyName [DSigT a k] ctors' []) :+           kindedSynInst :+           singKindInst :+           sEqInsts+  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 -> SgM Name+        mkConName+          | nameBase name == nameBase repName = mkDataName . nameBase+          | otherwise                         = return++        mkFromSingClause :: DCon -> SgM DClause+        mkFromSingClause c = do+          let (cname, numArgs) = extractNameArgs c+          cname' <- mkConName cname+          varNames <- replicateM numArgs (qNewName "b")+          return $ DClause [DConPa (singDataConName cname) (map DVarPa varNames)]+                           (foldExp+                              (DConE cname')+                              (map (DAppE (DVarE fromSingName) . DVarE) varNames))++        mkToSingClause :: DCon -> SgM DClause+        mkToSingClause (DCon _tvbs _cxt cname fields) = do+          let types = tysOfConFields fields+          varNames  <- mapM (const $ qNewName "b") types+          svarNames <- mapM (const $ qNewName "c") types+          promoted  <- mapM promoteType types+          cname' <- mkConName cname+          let recursiveCalls = zipWith mkRecursiveCall varNames promoted+          return $+            DClause [DConPa cname' (map DVarPa varNames)]+                    (multiCase recursiveCalls+                               (map (DConPa someSingDataName . listify . DVarPa)+                                    svarNames)+                               (DAppE (DConE someSingDataName)+                                         (foldExp (DConE (singDataConName cname))+                                                  (map DVarE svarNames))))++        mkRecursiveCall :: Name -> DKind -> DExp+        mkRecursiveCall var_name ki =+          DSigE (DAppE (DVarE toSingName) (DVarE var_name))+                (DAppT (DConT someSingTypeName) (kindParam ki))++        emptyMethod :: Name -> [DClause]+        emptyMethod n = [DClause [DVarPa n] (DCaseE (DVarE n) emptyMatches)]++-- refine a constructor. the first parameter is the type variable that+-- the singleton GADT is parameterized by+singCtor :: DType -> DCon -> SgM DCon+ -- polymorphic constructors are handled just+ -- like monomorphic ones -- the polymorphism in+ -- the kind is automatic+singCtor a (DCon _tvbs cxt name fields)+  | not (null cxt)+  = fail "Singling of constrained constructors not yet supported"+  | otherwise+  = do+  let types = tysOfConFields fields+      sName = singDataConName name+      sCon = DConE sName+      pCon = DConT name+  indexNames <- mapM (const $ qNewName "n") types+  let indices = map DVarT indexNames+  kinds <- mapM promoteType types+  args <- zipWithM buildArgType types indices+  let tvbs = zipWith DKindedTV indexNames kinds+      kindedIndices = zipWith DSigT indices kinds++  -- SingI instance+  emitDecs +    [DInstanceD (map (DAppPr (DConPr singIName)) indices)+                (DAppT (DConT singIName)+                       (foldType pCon kindedIndices))+                [DLetDec $ DValD (DVarPa singMethName)+                       (foldExp sCon (map (const $ DVarE singMethName) types))]]++  let conFields = case fields of+                    DNormalC _ -> DNormalC $ map (NotStrict,) args+                    DRecC rec_fields ->+                      DRecC [ (singValName field_name, NotStrict, arg)+                            | (field_name, _, _) <- rec_fields+                            | arg <- args ]+  return $ DCon tvbs+                [foldl DAppPr (DConPr equalityName) [a, foldType pCon indices]]+                sName+                conFields+  where buildArgType :: DType -> DType -> SgM DType+        buildArgType ty index = do+          (ty', _, _) <- singType NotTopLevel index ty+          return ty'
+ src/Data/Singletons/Single/Eq.hs view
@@ -0,0 +1,119 @@+{- Data/Singletons/Single/Eq.hs++(c) Richard Eisenberg 2014+eir@cis.upenn.edu++Defines functions to generate SEq and SDecide instances.+-}++module Data.Singletons.Single.Eq where++import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Desugar+import Data.Singletons.Util+import Data.Singletons.Names+import Control.Monad++-- making the SEq instance and the SDecide instance are rather similar,+-- so we generalize+type EqualityClassDesc q = ((DCon, DCon) -> q DClause, 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 => DKind -> [DCon]+                   -> EqualityClassDesc q -> q DDec+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 $ DInstanceD (map (\kvar -> (DConPr className) `DAppPr` kindParam kvar)+                           (getKindVars k))+                     (DAppT (DConT className)+                            (kindParam k))+                     [DLetDec $ DFunD methName methClauses]+  where getKindVars :: DKind -> [DKind]+        getKindVars (DVarK x)         = [DVarK x]+        getKindVars (DConK _ args)    = concatMap getKindVars args+        getKindVars DStarK            = []+        getKindVars (DArrowK arg res) = concatMap getKindVars [arg, res]+        getKindVars other             =+          error ("getKindVars sees an unusual kind: " ++ show other)++        mkEmptyMethClauses :: Quasi q => q [DClause]+        mkEmptyMethClauses = do+          a <- qNewName "a"+          return [DClause [DVarPa a, DWildPa] (DCaseE (DVarE a) emptyMatches)]++mkEqMethClause :: Quasi q => (DCon, DCon) -> q DClause+mkEqMethClause (c1, c2)+  | lname == rname = do+    lnames <- replicateM lNumArgs (qNewName "a")+    rnames <- replicateM lNumArgs (qNewName "b")+    let lpats = map DVarPa lnames+        rpats = map DVarPa rnames+        lvars = map DVarE lnames+        rvars = map DVarE rnames+    return $ DClause+      [DConPa lname lpats, DConPa rname rpats]+      (allExp (zipWith (\l r -> foldExp (DVarE sEqMethName) [l, r])+                        lvars rvars))+  | otherwise =+    return $ DClause+      [DConPa lname (replicate lNumArgs DWildPa),+       DConPa rname (replicate rNumArgs DWildPa)]+      (DConE $ singDataConName falseName)+  where allExp :: [DExp] -> DExp+        allExp [] = DConE $ singDataConName trueName+        allExp [one] = one+        allExp (h:t) = DAppE (DAppE (DVarE $ singValName andName) h) (allExp t)++        (lname, lNumArgs) = extractNameArgs c1+        (rname, rNumArgs) = extractNameArgs c2++mkDecideMethClause :: Quasi q => (DCon, DCon) -> q DClause+mkDecideMethClause (c1, c2)+  | lname == rname =+    if lNumArgs == 0+    then return $ DClause [DConPa lname [], DConPa rname []]+                          (DAppE (DConE provedName) (DConE reflName))+    else do+      lnames <- replicateM lNumArgs (qNewName "a")+      rnames <- replicateM lNumArgs (qNewName "b")+      contra <- qNewName "contra"+      let lpats = map DVarPa lnames+          rpats = map DVarPa rnames+          lvars = map DVarE lnames+          rvars = map DVarE rnames+      refl <- qNewName "refl"+      return $ DClause+        [DConPa lname lpats, DConPa rname rpats]+        (DCaseE (mkTupleDExp $+                 zipWith (\l r -> foldExp (DVarE sDecideMethName) [l, r])+                         lvars rvars)+                ((DMatch (mkTupleDPat (replicate lNumArgs+                                        (DConPa provedName [DConPa reflName []])))+                        (DAppE (DConE provedName) (DConE reflName))) :+                 [DMatch (mkTupleDPat (replicate i DWildPa +++                                       DConPa disprovedName [DVarPa contra] :+                                       replicate (lNumArgs - i - 1) DWildPa))+                         (DAppE (DConE disprovedName)+                                (DLamE [refl] $+                                 DCaseE (DVarE refl)+                                        [DMatch (DConPa reflName []) $+                                         (DAppE (DVarE contra)+                                                (DConE reflName))]))+                 | i <- [0..lNumArgs-1] ]))++  | otherwise = do+    x <- qNewName "x"+    return $ DClause+      [DConPa lname (replicate lNumArgs DWildPa),+       DConPa rname (replicate rNumArgs DWildPa)]+      (DAppE (DConE disprovedName) (DLamE [x] (DCaseE (DVarE x) emptyMatches)))++  where+    (lname, lNumArgs) = extractNameArgs c1+    (rname, rNumArgs) = extractNameArgs c2
+ src/Data/Singletons/Single/Monad.hs view
@@ -0,0 +1,193 @@+{- Data/Singletons/Single/Monad.hs++(c) Richard Eisenberg 2014+eir@cis.upenn.edu++This file defines the SgM monad and its operations, for use during singling.++The SgM monad allows reading from a SgEnv environment and is wrapped around a Q.+-}++{-# LANGUAGE GeneralizedNewtypeDeriving, ParallelListComp,+             TemplateHaskell #-}++module Data.Singletons.Single.Monad (+  SgM, bindLets, bindTyVars, bindTyVarsClause, lookupVarE, lookupConE,+  wrapSingFun, wrapUnSingFun,+  singM, singDecsM,+  emitDecs, emitDecsM+  ) where++import Prelude hiding ( exp )+import Data.Map ( Map )+import qualified Data.Map as Map+import Data.Singletons.Promote.Monad ( emitDecs, emitDecsM, VarPromotions )+import Data.Singletons.Names+import Data.Singletons.Util+import Data.Singletons+import Language.Haskell.TH.Syntax hiding ( lift )+import Language.Haskell.TH.Desugar+import Control.Applicative+import Control.Monad.Reader+import Control.Monad.Writer++-- environment during singling+data SgEnv =+  SgEnv { sg_let_binds :: Map Name DExp   -- from the *original* name+        }++emptySgEnv :: SgEnv+emptySgEnv = SgEnv { sg_let_binds = Map.empty+                   }++-- the singling monad+newtype SgM a = SgM (ReaderT SgEnv (WriterT [DDec] Q) a)+  deriving ( Functor, Applicative, Monad, Quasi+           , MonadReader SgEnv, MonadWriter [DDec] )++bindLets :: [(Name, DExp)] -> SgM a -> SgM a+bindLets lets1 =+  local (\env@(SgEnv { sg_let_binds = lets2 }) ->+               env { sg_let_binds = (Map.fromList lets1) `Map.union` lets2 })++-- bindTyVarsClause+-- ~~~~~~~~~~~~~~~~+--+-- This function does some dirty business.+--+-- The problem is that, whenever we bind a term variable, we would also like+-- to bind a type variable, for use in promotions of any nested lambdas,+-- cases, and lets. The natural idea, something like `(\(foo :: Sing ty_foo)+-- (bar :: Sing ty_bar) -> ...)` doesn't work, because ScopedTypeVariables is+-- stupid (in RAE's opinon). The ScopedTypeVariables extension says that any+-- scoped type variable is a rigid skolem. This means that the types ty_foo+-- and ty_bar must be distinct! That's actually not the problem. The problem+-- is that the implicit kind variables used in ty_foo's and ty_bar's kinds are+-- also skolems, and this breaks the idea.+--+-- The solution? Use scoped type variables from a function signature, where+-- the bound variables' kinds are *inferred*, not skolem. This means that,+-- whenever we lambda-bind variables (that is, in lambdas, let-bound+-- functions, and case matches), we must then pass the variables immediately+-- to a function with an explicit type signature. Thus, something like+--+--   (\foo bar -> ...)+--+-- becomes+--+--   (\foo bar ->+--     let lambda :: forall ty_foo ty_bar. Sing ty_foo -> Sing ty_bar -> Sing ...+--         lambda foo' bar' = ... (with foo |-> foo' and bar |-> bar')+--     in lambda foo bar)+--+-- Getting the ... right in the type above is a major nuisance, and it+-- explains a bunch of the types stored in the ADExp AST. (See LetDecEnv.)+--+-- A further, unsolved problem with all of this is that the type signature+-- generated never has any constraints. Thus, if the body requires a+-- constraint somewhere, the code will fail to compile; we're not quite clever+-- enough to get everything to line up.+--+-- As a stop-gap measure to fix this, in the function clause case, we tie the+-- scoped type variables in this "lambda" to the outer scoped type variables.+-- This has the effect of making sure that the kinds of ty_foo and ty_bar+-- match that of the surrounding scope and makes sure that any constraint is+-- available from within the "lambda".+--+-- This means, though, that using constraints with case statements and lambdas+-- will likely not work. Ugh.++bindTyVarsClause :: VarPromotions   -- the bindings we wish to effect+                 -> [Name]          -- free variables in...+                 -> DType           -- ...this type of the thing_inside+                 -> [(DType, DType)]  -- and asserting these equalities+                 -> SgM DExp -> SgM DExp+bindTyVarsClause var_proms fv_names prom_fun equalities thing_inside = do+  lambda <- qNewName "lambda"+  let (term_names, tyvar_names) = unzip var_proms+      eq_ct  = [ DConPr equalityName `DAppPr` t1 `DAppPr` t2+               | (t1, t2) <- equalities ]+      ty_sig = DSigD lambda $+               DForallT (map DPlainTV tyvar_names)+                        []+                        (DForallT (map DPlainTV fv_names) eq_ct $+                                   ravel (map (\tv_name -> singFamily `DAppT` DVarT tv_name)+                                    tyvar_names+                                ++ [singFamily `DAppT` prom_fun]))+  arg_names <- mapM (qNewName . nameBase) term_names+  body <- bindLets [ (term_name, DVarE arg_name)+                   | term_name <- term_names+                   | arg_name <- arg_names ] $ thing_inside+  let fundef   = DFunD lambda [DClause (map DVarPa arg_names) body]+      let_body = foldExp (DVarE lambda) (map (DVarE . singValName) term_names)+  return $ DLetE [ty_sig, fundef] let_body++bindTyVars :: VarPromotions+           -> [Name]+           -> DType+           -> SgM DExp -> SgM DExp+bindTyVars var_proms fv_names prom_fun =+  bindTyVarsClause var_proms fv_names prom_fun []++lookupVarE :: Name -> SgM DExp+lookupVarE = lookup_var_con singValName (DVarE . singValName)++lookupConE :: Name -> SgM DExp+lookupConE = lookup_var_con singDataConName (DConE . singDataConName)++lookup_var_con :: (Name -> Name) -> (Name -> DExp) -> Name -> SgM DExp+lookup_var_con mk_sing_name mk_exp name = do+  letExpansions <- asks sg_let_binds+  sName <- mkDataName (nameBase (mk_sing_name name)) -- we want *term* names!+  case Map.lookup name letExpansions of+    Nothing -> do+      -- try to get it from the global context+      m_dinfo <- qReifyMaybe sName+      case m_dinfo of+        Just (DVarI _ ty _ _) ->+          let num_args = countArgs ty in+          return $ wrapSingFun num_args (promoteValRhs name) (mk_exp name)+        _ -> return $ mk_exp name   -- lambda-bound+    Just exp -> return exp++wrapSingFun :: Int -> DType -> DExp -> DExp+wrapSingFun 0 _  = id+wrapSingFun n ty =+  let wrap_fun = DVarE $ case n of+                           1 -> 'singFun1+                           2 -> 'singFun2+                           3 -> 'singFun3+                           4 -> 'singFun4+                           5 -> 'singFun5+                           6 -> 'singFun6+                           7 -> 'singFun7+                           _ -> error "No support for functions of arity > 7."+  in+  (wrap_fun `DAppE` proxyFor ty `DAppE`)++wrapUnSingFun :: Int -> DType -> DExp -> DExp+wrapUnSingFun 0 _  = id+wrapUnSingFun n ty =+  let unwrap_fun = DVarE $ case n of+                             1 -> 'unSingFun1+                             2 -> 'unSingFun2+                             3 -> 'unSingFun3+                             4 -> 'unSingFun4+                             5 -> 'unSingFun5+                             6 -> 'unSingFun6+                             7 -> 'unSingFun7+                             _ -> error "No support for functions of arity > 7."+  in+  (unwrap_fun `DAppE` proxyFor ty `DAppE`)++singM :: Quasi q => SgM a -> q (a, [DDec])+singM (SgM rdr) =+  let wr = runReaderT rdr emptySgEnv+      q  = runWriterT wr+  in+  runQ q++singDecsM :: Quasi q => SgM [DDec] -> q [DDec]+singDecsM thing = do+  (decs1, decs2) <- singM thing+  return $ decs1 ++ decs2
+ src/Data/Singletons/Single/Type.hs view
@@ -0,0 +1,66 @@+{- Data/Singletons/Single/Type.hs++(c) Richard Eisenberg 2013+eir@cis.upenn.edu++Singletonizes types.+-}++module Data.Singletons.Single.Type where++import Language.Haskell.TH.Desugar+import Language.Haskell.TH.Syntax+import Data.Singletons.Names+import Data.Singletons.Single.Monad+import Data.Singletons.Promote.Type+import Data.Singletons.Util+import Control.Monad++data TopLevelFlag = TopLevel | NotTopLevel++singType :: TopLevelFlag+         -> DType          -- the promoted version of the thing classified by...+         -> DType          -- ... this type+         -> SgM ( DType    -- the singletonized type+                , Int      -- the number of arguments+                , [Name] ) -- the names of the tyvars used in the sing'd type+singType top_level prom ty = do+  let (cxt, tys) = unravel ty+      args       = init tys+      num_args   = length args+  cxt' <- mapM singPred cxt+  arg_names <- replicateM num_args (qNewName "t")+  let args' = map (\n -> singFamily `DAppT` (DVarT n)) arg_names+      res'  = singFamily `DAppT` (foldl apply prom (map DVarT arg_names))+      tau   = ravel (args' ++ [res'])+  ty' <- case top_level of+           TopLevel -> do+             prom_args <- mapM promoteType args+             return $ DForallT (zipWith DKindedTV arg_names prom_args)+                               cxt' tau+                -- don't annotate kinds. Why? Because the original source+                -- may have used scoped type variables, and we're just+                -- not clever enough to get the scoped kind variables right.+                -- (the business in bindTyVars gets in the way)+                -- If ScopedTypeVariables was actually sane in patterns,+                -- this restriction might be able to be lifted.+           NotTopLevel -> return $ DForallT (map DPlainTV arg_names)+                                            cxt' tau+  return (ty', num_args, arg_names)++singPred :: DPred -> SgM DPred+singPred = singPredRec []++singPredRec :: [DType] -> DPred -> SgM DPred+singPredRec ctx (DAppPr pr ty) = singPredRec (ty : ctx) pr+singPredRec _ctx (DSigPr _pr _ki) =+  fail "Singling of constraints with explicit kinds not yet supported"+singPredRec _ctx (DVarPr _n) =+  fail "Singling of contraint variables not yet supported"+singPredRec ctx (DConPr n)+  | n == equalityName+  = fail "Singling of type equality constraints not yet supported"+  | otherwise = do+    kis <- mapM promoteType ctx+    let sName = singClassName n+    return $ foldl DAppPr (DConPr sName) (map kindParam kis)
− 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/SuppressUnusedWarnings.hs view
@@ -0,0 +1,20 @@+-- Data/Singletons/Hidden.hs+--+-- (c) Richard Eisenberg 2014+-- eir@cis.upenn.edu+--+-- This declares user-oriented exports that are actually meant to be hidden+-- from the user. Why would anyone ever want this? Because what is below+-- is dirty, and no one wants to see it.++{-# LANGUAGE PolyKinds #-}++module Data.Singletons.SuppressUnusedWarnings where++import Data.Proxy++-- | This class (which users should never see) is to be instantiated in order+-- to use an otherwise-unused data constructor, such as the "kind-inference"+-- data constructor for defunctionalization symbols.+class SuppressUnusedWarnings (t :: k) where+  suppressUnusedWarnings :: Proxy t -> ()
+ src/Data/Singletons/Syntax.hs view
@@ -0,0 +1,172 @@+{- Data/Singletons/Syntax.hs++(c) Richard Eisenberg 2014+eir@cis.upenn.edu++Converts a list of DLetDecs into a LetDecEnv for easier processing,+and contains various other AST definitions.+-}++{-# LANGUAGE DataKinds, TypeFamilies, PolyKinds, DeriveDataTypeable,+             StandaloneDeriving, FlexibleInstances #-}++module Data.Singletons.Syntax where++import Prelude hiding ( exp )+import Data.Monoid+import Data.Singletons.Util+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Desugar+import Language.Haskell.TH.Ppr+import Language.Haskell.TH.Desugar.Sweeten+import Data.Map.Strict ( Map )+import qualified Data.Map.Strict as Map+import Data.Maybe+import Control.Monad++type VarPromotions = [(Name, Name)]  -- from term-level name to type-level name++  -- the relevant part of declarations+data DataDecl  = DataDecl NewOrData Name [DTyVarBndr] [DCon] [Name]+data ClassDecl = ClassDecl DCxt Name [DTyVarBndr] ULetDecEnv+data InstDecl  = InstDecl Name [DType] [(Name, ULetDecRHS)]++data PartitionedDecs =+  PDecs { pd_let_decs :: [DLetDec]+        , pd_class_decs :: [ClassDecl]+        , pd_instance_decs :: [InstDecl]+        , pd_data_decs :: [DataDecl]+        }++instance Monoid PartitionedDecs where+  mempty = PDecs [] [] [] []+  mappend (PDecs a1 b1 c1 d1) (PDecs a2 b2 c2 d2) =+    PDecs (a1 <> a2) (b1 <> b2) (c1 <> c2) (d1 <> d2)++-- monadic only because of failure+partitionDecs :: Monad m => [DDec] -> m PartitionedDecs+partitionDecs = concatMapM partitionDec++partitionDec :: Monad m => DDec -> m PartitionedDecs+partitionDec (DLetDec letdec) = return $ mempty { pd_let_decs = [letdec] }+partitionDec (DDataD nd _cxt name tvbs cons derivings) =+  return $ mempty { pd_data_decs = [DataDecl nd name tvbs cons derivings] }+partitionDec (DClassD cxt name tvbs _fds decs) = do+  env <- concatMapM partitionClassDec decs+  return $ mempty { pd_class_decs = [ClassDecl cxt name tvbs env] }+partitionDec (DInstanceD _cxt ty decs) = do+  defns <- liftM catMaybes $ mapM partitionInstanceDec decs+  (name, tys) <- split_app_tys [] ty+  return $ mempty { pd_instance_decs = [InstDecl name tys defns] }+  where+    split_app_tys acc (DAppT t1 t2) = split_app_tys (t2:acc) t1+    split_app_tys acc (DConT name)  = return (name, acc)+    split_app_tys acc (DSigT t _)   = split_app_tys acc t+    split_app_tys _ _ = fail $ "Illegal instance head: " ++ show ty+partitionDec (DRoleAnnotD {}) = return mempty  -- ignore these+partitionDec (DPragmaD {}) = return mempty+partitionDec dec =+  fail $ "Declaration cannot be promoted: " ++ pprint (decToTH dec)++partitionClassDec :: Monad m => DDec -> m ULetDecEnv+partitionClassDec (DLetDec (DSigD name ty)) = return $ typeBinding name ty+partitionClassDec (DLetDec (DValD (DVarPa name) exp)) =+  return $ valueBinding name (UValue exp)+partitionClassDec (DLetDec (DFunD name clauses)) =+  return $ valueBinding name (UFunction clauses)+partitionClassDec (DLetDec (DInfixD fixity name)) =+  return $ infixDecl fixity name+partitionClassDec (DPragmaD {}) = return mempty+partitionClassDec _ =+  fail "Only method declarations can be promoted within a class."++partitionInstanceDec :: Monad m => DDec -> m (Maybe (Name, ULetDecRHS))+partitionInstanceDec (DLetDec (DValD (DVarPa name) exp)) =+  return $ Just (name, UValue exp)+partitionInstanceDec (DLetDec (DFunD name clauses)) =+  return $ Just (name, UFunction clauses)+partitionInstanceDec (DPragmaD {}) = return Nothing+partitionInstanceDec _ =+  fail "Only method bodies can be promoted within an instance."++{-+We see below several datatypes beginning with "A". These are annotated structures,+necessary for Promote to communicate key things to Single. In particular, promotion+of expressions is *not* deterministic, due to the necessity to create unique names+for lets, cases, and lambdas. So, we put these promotions into an annotated AST+so that Single can use the right promotions.+-}++-- A DExp with let and lambda nodes annotated with their type-level equivalents+data ADExp = ADVarE Name+           | ADConE Name+           | ADLitE Lit+           | ADAppE ADExp ADExp+           | ADLamE VarPromotions  -- bind these type variables to these term vars+                    DType          -- the promoted lambda+                    [Name] ADExp+           | ADCaseE ADExp [ADMatch]+           | ADLetE ALetDecEnv ADExp+           | ADSigE ADExp DType++ -- unlike in other places, the DType in an ADMatch (the promoted "case" statement)+ -- should be used with DAppT, *not* apply! (Case statements are not defunctionalized.)+data ADMatch = ADMatch VarPromotions DType DPat ADExp+data ADClause = ADClause VarPromotions+                         [DPat] ADExp++data AnnotationFlag = Annotated | Unannotated++type family IfAnn (ann :: AnnotationFlag) (yes :: k) (no :: k) :: k+type instance IfAnn Annotated   yes no = yes+type instance IfAnn Unannotated yes no = no++data ALetDecRHS = AFunction DType  -- promote function (unapplied)+                            Int    -- number of arrows in type+                            [ADClause]+                | AValue DType -- promoted exp+                         Int   -- number of arrows in type+                         ADExp+data ULetDecRHS = UFunction [DClause]+                | UValue DExp+data LetDecEnv ann = LetDecEnv+                   { lde_defns :: Map Name (IfAnn ann ALetDecRHS ULetDecRHS)+                   , lde_types :: Map Name DType   -- type signatures+                   , lde_infix :: [(Fixity, Name)] -- infix declarations+                   , lde_proms :: IfAnn ann (Map Name DType) () -- possibly, promotions+                   }+type ALetDecEnv = LetDecEnv Annotated+type ULetDecEnv = LetDecEnv Unannotated++instance Monoid ULetDecEnv where+  mempty = LetDecEnv Map.empty Map.empty [] ()+  mappend (LetDecEnv defns1 types1 infx1 _) (LetDecEnv defns2 types2 infx2 _) =+    LetDecEnv (defns1 <> defns2) (types1 <> types2) (infx1 <> infx2) ()++valueBinding :: Name -> ULetDecRHS -> ULetDecEnv+valueBinding n v = emptyLetDecEnv { lde_defns = Map.singleton n v }++typeBinding :: Name -> DType -> ULetDecEnv+typeBinding n t = emptyLetDecEnv { lde_types = Map.singleton n t }++infixDecl :: Fixity -> Name -> ULetDecEnv+infixDecl f n = emptyLetDecEnv { lde_infix = [(f,n)] }++emptyLetDecEnv :: ULetDecEnv+emptyLetDecEnv = mempty++buildLetDecEnv :: Quasi q => [DLetDec] -> q ULetDecEnv+buildLetDecEnv = go emptyLetDecEnv+  where+    go acc [] = return acc+    go acc (DFunD name clauses : rest) =+      go (valueBinding name (UFunction clauses) <> acc) rest+    go acc (DValD (DVarPa name) exp : rest) =+      go (valueBinding name (UValue exp) <> acc) rest+    go acc (dec@(DValD {}) : rest) = do+      flattened <- flattenDValD dec+      go acc (flattened ++ rest)+    go acc (DSigD name ty : rest) =+      go (typeBinding name ty <> acc) rest+    go acc (DInfixD f n : rest) =+      go (infixDecl f n <> acc) rest
src/Data/Singletons/TH.hs view
@@ -19,7 +19,7 @@ module Data.Singletons.TH (   -- * Primary Template Haskell generation functions   singletons, singletonsOnly, genSingletons,-  promote, promoteOnly,+  promote, promoteOnly, genDefunSymbols, genPromotions,    -- ** Functions to generate equality instances   promoteEqInstances, promoteEqInstance,@@ -27,36 +27,62 @@   singEqInstancesOnly, singEqInstanceOnly,   singDecideInstances, singDecideInstance, +  -- ** Functions to generate Ord instances+  promoteOrdInstances, promoteOrdInstance,++  -- ** Functions to generate Ord instances+  promoteBoundedInstances, promoteBoundedInstance,+   -- ** Utility function   cases,    -- * Basic singleton definitions-  Sing(SFalse, STrue), SingI(..), SingKind(..), KindOf, Demote,+  Sing(SFalse, STrue, STuple0, STuple2, STuple3, STuple4, STuple5, STuple6, STuple7),+  module Data.Singletons,    -- * Auxiliary definitions   -- | These definitions might be mentioned in code generated by Template Haskell,   -- so they must be in scope. -  type (==), (:==), If, sIf, (:&&), SEq(..),+  PEq(..), If, sIf, (:&&), SEq(..),+  POrd(..),   Any,   SDecide(..), (:~:)(..), Void, Refuted, Decision(..),-  KProxy(..), SomeSing(..)+  Proxy(..), KProxy(..), SomeSing(..),++  Error, ErrorSym0,+  TrueSym0, FalseSym0,+  LTSym0, EQSym0, GTSym0,+  Tuple0Sym0,+  Tuple2Sym0, Tuple2Sym1, Tuple2Sym2,+  Tuple3Sym0, Tuple3Sym1, Tuple3Sym2, Tuple3Sym3,+  Tuple4Sym0, Tuple4Sym1, Tuple4Sym2, Tuple4Sym3, Tuple4Sym4,+  Tuple5Sym0, Tuple5Sym1, Tuple5Sym2, Tuple5Sym3, Tuple5Sym4, Tuple5Sym5,+  Tuple6Sym0, Tuple6Sym1, Tuple6Sym2, Tuple6Sym3, Tuple6Sym4, Tuple6Sym5, Tuple6Sym6,+  Tuple7Sym0, Tuple7Sym1, Tuple7Sym2, Tuple7Sym3, Tuple7Sym4, Tuple7Sym5, Tuple7Sym6, Tuple7Sym7,++  SuppressUnusedWarnings(..)+  ) where  import Data.Singletons-import Data.Singletons.Singletons+import Data.Singletons.Single import Data.Singletons.Promote-import Data.Singletons.Instances-import Data.Singletons.Bool-import Data.Singletons.Eq+import Data.Singletons.Prelude.Instances+import Data.Singletons.Prelude.Bool+import Data.Singletons.Prelude.Eq+import Data.Singletons.Prelude.Ord import Data.Singletons.Types import Data.Singletons.Void import Data.Singletons.Decide+import Data.Singletons.TypeLits+import Data.Singletons.SuppressUnusedWarnings+import Language.Haskell.TH.Desugar+import Language.Haskell.TH.Desugar.Sweeten  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 @@ -71,16 +97,15 @@       -> q Exp cases tyName expq bodyq = do   info <- reifyWithWarning tyName-  case info of-    TyConI (DataD _ _ _ ctors _) -> buildCases ctors-    TyConI (NewtypeD _ _ _ ctor _) -> buildCases [ctor]+  dinfo <- dsInfo info+  case dinfo of+    DTyConI (DDataD _ _ _ _ ctors _) _ -> fmap expToTH $ buildCases ctors     _ -> 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+          DCaseE <$> (dsExp =<< expq) <*>+                     mapM (\con -> DMatch (conToPat con) <$> (dsExp =<< bodyq)) ctors -        conToPat :: Con -> Pat-        conToPat = ctor1Case-          (\name tys -> ConP name (map (const WildP) tys))+        conToPat :: DCon -> DPat+        conToPat (DCon _ _ name fields) =+          DConPa name (map (const DWildPa) $ tysOfConFields fields)
− 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 view
@@ -13,7 +13,8 @@  {-# LANGUAGE CPP, PolyKinds, DataKinds, TypeFamilies, FlexibleInstances,              UndecidableInstances, ScopedTypeVariables, RankNTypes,-             GADTs, FlexibleContexts #-}+             GADTs, FlexibleContexts, TypeOperators, ConstraintKinds,+             TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  #if __GLASGOW_HASKELL__ < 707@@ -23,17 +24,24 @@ module Data.Singletons.TypeLits (   Nat, Symbol,   SNat, SSymbol, withKnownNat, withKnownSymbol,-  Error, sError,-  KnownNat, natVal, KnownSymbol, symbolVal+  Error, ErrorSym0, sError,+  KnownNat, natVal, KnownSymbol, symbolVal,++  (:+), (:-), (:*), (:^),+  (:+$), (:+$$), (:-$), (:-$$),+  (:*$), (:*$$), (:^$), (:^$$)   ) where  import Data.Singletons import Data.Singletons.Types-import Data.Singletons.Eq+import Data.Singletons.Prelude.Eq+import Data.Singletons.Prelude.Ord import Data.Singletons.Decide-import Data.Singletons.Bool+import Data.Singletons.Prelude.Bool+import Data.Singletons.Promote #if __GLASGOW_HASKELL__ >= 707-import GHC.TypeLits+import GHC.TypeLits as TL+import Data.Type.Equality #else import GHC.TypeLits (Nat, Symbol) import qualified GHC.TypeLits as TL@@ -67,7 +75,7 @@   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@@ -88,7 +96,7 @@  data instance Sing (n :: Nat) = TL.SingRep n Integer => SNat -instance TL.SingRep n Integer => SingI (n :: Nat) where +instance TL.SingRep n Integer => SingI (n :: Nat) where   sing = SNat  instance SingKind ('KProxy :: KProxy Nat) where@@ -127,6 +135,15 @@  #endif +-- Synonyms for GHC.TypeLits operations on Nat. These match our naming+-- conventions.+type x :+ y = x + y+type x :- y = x - y+type x :* y = x * y+type x :^ y = x ^ y++$(genDefunSymbols [ ''(:+), ''(:-), ''(:*), ''(:^)] )+ -- SDecide instances: instance SDecide ('KProxy :: KProxy Nat) where   (SNat :: Sing n) %~ (SNat :: Sing m)@@ -143,7 +160,13 @@     | otherwise     = Disproved (\_ -> error errStr)     where errStr = "Broken Symbol singletons"-                  ++-- PEq instances+instance PEq ('KProxy :: KProxy Nat) where+  type (a :: Nat) :== (b :: Nat) = a == b+instance PEq ('KProxy :: KProxy Symbol) where+  type (a :: Symbol) :== (b :: Symbol) = a == b+ -- need SEq instances for TypeLits kinds instance SEq ('KProxy :: KProxy Nat) where   a %:== b@@ -154,7 +177,14 @@   a %:== b     | fromSing a == fromSing b    = unsafeCoerce STrue     | otherwise                   = unsafeCoerce SFalse-                  ++-- POrd instances+instance POrd ('KProxy :: KProxy Nat) where+  type (a :: Nat) `Compare` (b :: Nat) = a `TL.CmpNat` b++instance POrd ('KProxy :: KProxy Symbol) where+  type (a :: Symbol) `Compare` (b :: Symbol) = a `TL.CmpSymbol` b+ -- | Kind-restricted synonym for 'Sing' for @Nat@s type SNat (x :: Nat) = Sing x @@ -175,6 +205,8 @@  -- | The promotion of 'error' type family Error (str :: Symbol) :: k+data ErrorSym0 (t1 :: TyFun k1 k2)+type instance Apply ErrorSym0 a = Error a  -- | The singleton for 'error' sError :: Sing (str :: Symbol) -> a
src/Data/Singletons/TypeRepStar.hs view
@@ -29,10 +29,10 @@   -- also supplied.   ) where -import Data.Singletons.Instances+import Data.Singletons.Prelude.Instances import Data.Singletons import Data.Singletons.Types-import Data.Singletons.Eq+import Data.Singletons.Prelude.Eq import Data.Typeable import Unsafe.Coerce import Data.Singletons.Decide@@ -40,13 +40,10 @@ #if __GLASGOW_HASKELL__ >= 707 import GHC.Exts ( Proxy# ) import Data.Type.Coercion+import Data.Type.Equality #else- eqT :: (Typeable a, Typeable b) => Maybe (a :~: b) eqT = gcast Refl--type instance (a :: *) :== (a :: *) = True- #endif  data instance Sing (a :: *) where@@ -58,6 +55,13 @@   type DemoteRep ('KProxy :: KProxy *) = TypeRep   fromSing (STypeRep :: Sing a) = typeOf (undefined :: a)   toSing = dirty_mk_STypeRep++instance PEq ('KProxy :: KProxy *) where+#if __GLASGOW_HASKELL__ < 707+  type (a :: *) :== (a :: *) = True+#else+  type (a :: *) :== (b :: *) = a == b+#endif  instance SEq ('KProxy :: KProxy *) where   (STypeRep :: Sing a) %:== (STypeRep :: Sing b) =
src/Data/Singletons/Types.hs view
@@ -19,7 +19,7 @@ module Data.Singletons.Types (   KProxy(..), Proxy(..),   (:~:)(..), gcastWith, TestEquality(..),-  Not, If, type (==), (:==)+  If   ) where  #if __GLASGOW_HASKELL__ < 707@@ -44,21 +44,10 @@ 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 view
@@ -9,38 +9,34 @@  {-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances, RankNTypes,              TemplateHaskell, GeneralizedNewtypeDeriving,-             MultiParamTypeClasses #-}+             MultiParamTypeClasses, StandaloneDeriving,+             UndecidableInstances, MagicHash, UnboxedTuples,+             LambdaCase #-} -module Data.Singletons.Util (-  module Data.Singletons.Util,-  module Language.Haskell.TH.Desugar )-  where+module Data.Singletons.Util 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 Prelude hiding ( exp, foldl, concat, mapM, any )+import Language.Haskell.TH.Syntax hiding ( lift )+import Language.Haskell.TH.Desugar import Data.Char-import Control.Monad+import Control.Monad hiding ( mapM ) import Control.Applicative-import Control.Monad.Writer+import Control.Monad.Writer hiding ( mapM )+import Control.Monad.Reader hiding ( mapM ) 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+import Data.Foldable+import Data.Traversable  -- The list of types that singletons processes by default basicTypes :: [Name]-basicTypes = [ ''Bool-             , ''Maybe+basicTypes = [ ''Maybe+             , ''[]              , ''Either+             ] ++ boundedBasicTypes++boundedBasicTypes :: [Name]+boundedBasicTypes = [ ''Bool              , ''Ordering-             , ''[]              , ''()              , ''(,)              , ''(,,)@@ -48,15 +44,12 @@              , ''(,,,,)              , ''(,,,,,)              , ''(,,,,,,)-             ]+            ] --- 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+qReifyMaybe :: Quasi q => Name -> q (Maybe DInfo)+qReifyMaybe name = do+  m_info <- qRecover (return Nothing) (fmap Just $ qReify name)+  traverse dsInfo m_info  -- like reportWarning, but generalized to any Quasi qReportWarning :: Quasi q => String -> q ()@@ -66,6 +59,17 @@ qReportError :: Quasi q => String -> q () qReportError = qReport True +checkForRep :: Quasi q => [Name] -> q ()+checkForRep names =+  when (any ((== "Rep") . 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 => [DDec] -> q ()+checkForRepInDecls decls =+  checkForRep (allNamesIn decls)+ -- extract the degree of a tuple tupleDegree_maybe :: String -> Maybe Int tupleDegree_maybe s = do@@ -80,29 +84,31 @@ 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'+-- extract the degree of an unboxed tuple+unboxedTupleDegree_maybe :: String -> Maybe Int+unboxedTupleDegree_maybe s = do+  '(' : '#' : s1 <- return s+  (commas, "#)") <- return $ span (== ',') s1+  let degree+        | "" <- commas = 0+        | otherwise    = length commas + 1+  return degree --- 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 degree of a tuple name+unboxedTupleNameDegree_maybe :: Name -> Maybe Int+unboxedTupleNameDegree_maybe = unboxedTupleDegree_maybe . nameBase +tysOfConFields :: DConFields -> [DType]+tysOfConFields (DNormalC stys) = map snd stys+tysOfConFields (DRecC vstys)   = map (\(_,_,ty) -> ty) vstys+ -- extract the name and number of arguments to a constructor-extractNameArgs :: Con -> (Name, Int)-extractNameArgs = ctor1Case (\name tys -> (name, length tys))+extractNameArgs :: DCon -> (Name, Int)+extractNameArgs = liftSnd length . extractNameTypes --- reinterpret a name. This is useful when a Name has an associated--- namespace that we wish to forget-reinterpret :: Name -> Name-reinterpret = mkName . nameBase+-- extract the name and types of constructor arguments+extractNameTypes :: DCon -> (Name, [DType])+extractNameTypes (DCon _ _ n fields) = (n, tysOfConFields fields)  -- is an identifier uppercase? isUpcase :: Name -> Bool@@ -110,19 +116,28 @@  -- 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)+upcase = mkName . toUpcaseStr +-- make an identifier uppercase and return it as a String+toUpcaseStr :: Name -> String+toUpcaseStr n+  |  isUpcase n+  || head (nameBase n) == '$'   -- special case to avoid name clashes. See #29+  = nameBase n++  | otherwise+  = let str   = nameBase n+        first = head str+    in if isHsLetter first+       then (toUpper first) : tail str+       else ':' : str+ -- make an identifier lowercase locase :: Name -> Name locase n =   let str = nameBase n       first = head str in-    if isLetter first+    if isHsLetter first      then mkName ((toLower first) : tail str)      else mkName (tail str) -- remove the ":" @@ -139,42 +154,84 @@ prefixLCName pre tyPre n =   let str = nameBase n       first = head str in-    if isLetter first+    if isHsLetter first      then mkName (pre ++ str)      else mkName (tyPre ++ str) +suffixName :: String -> String -> Name -> Name+suffixName ident symb n =+  let str = nameBase n+      first = head str in+  if isHsLetter first+  then mkName (str ++ ident)+  else mkName (str ++ symb)+ -- extract the kind from a TyVarBndr. Returns '*' by default.-extractTvbKind :: TyVarBndr -> Kind-extractTvbKind (PlainTV _) = StarT -- FIXME: This seems wrong.-extractTvbKind (KindedTV _ k) = k+extractTvbKind :: DTyVarBndr -> Maybe DKind+extractTvbKind (DPlainTV _) = Nothing+extractTvbKind (DKindedTV _ k) = Just k  -- extract the name from a TyVarBndr.-extractTvbName :: TyVarBndr -> Name-extractTvbName (PlainTV n) = n-extractTvbName (KindedTV n _) = n+extractTvbName :: DTyVarBndr -> Name+extractTvbName (DPlainTV n) = n+extractTvbName (DKindedTV n _) = n +-- use the kind provided, or make a fresh kind variable+inferKind :: Quasi q => Maybe DKind -> q (Maybe DKind)+inferKind (Just k) = return $ Just k+#if __GLASGOW_HASKELL__ < 707+inferKind Nothing = do+  newK <- qNewName "k"+  return $ Just $ DVarK newK+#else+inferKind Nothing = return Nothing+#endif++-- Get argument types from an arrow type. Removing ForallT is an+-- important preprocessing step required by promoteType.+unravel :: DType -> ([DPred], [DType])+unravel (DForallT _ cxt ty) =+  let (cxt', tys) = unravel ty in+  (cxt ++ cxt', tys)+unravel (DAppT (DAppT DArrowT t1) t2) =+  let (cxt, tys) = unravel t2 in+  (cxt, t1 : tys)+unravel t = ([], [t])++-- Reconstruct arrow kind from the list of kinds+ravel :: [DType] -> DType+ravel []    = error "Internal error: raveling nil"+ravel [k]   = k+ravel (h:t) = DAppT (DAppT DArrowT h) (ravel t)++-- count the number of arguments in a type+countArgs :: DType -> Int+countArgs ty = length (snd $ unravel ty) - 1++addStar :: DKind -> DKind+addStar t = DArrowK t DStarK++addStar_maybe :: Maybe DKind -> Maybe DKind+addStar_maybe t = DArrowK <$> t <*> pure DStarK+ -- apply a type to a list of types-foldType :: Type -> [Type] -> Type-foldType = foldl AppT+foldType :: DType -> [DType] -> DType+foldType = foldl DAppT  -- apply an expression to a list of expressions-foldExp :: Exp -> [Exp] -> Exp-foldExp = foldl AppE+foldExp :: DExp -> [DExp] -> DExp+foldExp = foldl DAppE  -- is a kind a variable?-isVarK :: Kind -> Bool-isVarK (VarT _) = True+isVarK :: DKind -> Bool+isVarK (DVarK _) = 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+-- is a function type?+isFunTy :: DType -> Bool+isFunTy (DAppT (DAppT DArrowT _) _) = True+isFunTy (DForallT _ _ _)            = True+isFunTy _                           = False  -- choose the first non-empty list orIfEmpty :: [a] -> [a] -> [a]@@ -182,26 +239,27 @@ 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)))) []]+emptyMatches :: [DMatch]+emptyMatches = [DMatch DWildPa (DAppE (DVarE 'error) (DLitE (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 :: [DExp] -> [DPat] -> DExp -> DExp multiCase [] [] body = body multiCase scruts pats body =-  CaseE (mkTupleExp scruts)-        [Match (mkTuplePat pats) (NormalB body) []]+  DCaseE (mkTupleDExp scruts) [DMatch (mkTupleDPat pats) body] +-- Make a desugar function into a TH function.+wrapDesugar :: (Desugar th ds, Quasi q) => (ds -> q ds) -> th -> q th+wrapDesugar f th = do+  ds <- desugar th+  fmap sweeten $ f ds+ -- 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)+  deriving (Functor, Applicative, Monad, MonadTrans, MonadWriter m) -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+deriving instance (Monoid m, MonadReader r q) => MonadReader r (QWithAux m q)  -- make a Quasi instance for easy lifting instance (Quasi q, Monoid m) => Quasi (QWithAux m q) where@@ -257,11 +315,59 @@ addElement elt = tell [elt]  -- lift concatMap into a monad-concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]+-- could this be more efficient?+concatMapM :: (Monad monad, Monoid monoid, Traversable t)+           => (a -> monad monoid) -> t a -> monad monoid concatMapM fn list = do   bss <- mapM fn list-  return $ concat bss+  return $ fold bss  -- make a one-element list listify :: a -> [a]-listify = return+listify = (:[])++fstOf3 :: (a,b,c) -> a+fstOf3 (a,_,_) = a++liftFst :: (a -> b) -> (a, c) -> (b, c)+liftFst f (a, c) = (f a, c)++liftSnd :: (a -> b) -> (c, a) -> (c, b)+liftSnd f (c, a) = (c, f a)++snocView :: [a] -> ([a], a)+snocView [] = error "snocView nil"+snocView [x] = ([], x)+snocView (x : xs) = liftFst (x:) (snocView xs)++partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])+partitionWith f = go [] []+  where go bs cs []     = (reverse bs, reverse cs)+        go bs cs (a:as) =+          case f a of+            Left b  -> go (b:bs) cs as+            Right c -> go bs (c:cs) as++partitionWithM :: Monad m => (a -> m (Either b c)) -> [a] -> m ([b], [c])+partitionWithM f = go [] []+  where go bs cs []     = return (reverse bs, reverse cs)+        go bs cs (a:as) = do+          fa <- f a+          case fa of+            Left b  -> go (b:bs) cs as+            Right c -> go bs (c:cs) as++partitionLetDecs :: [DDec] -> ([DLetDec], [DDec])+partitionLetDecs = partitionWith (\case DLetDec ld -> Left ld+                                        dec        -> Right dec)++mapAndUnzip3M :: Monad m => (a -> m (b,c,d)) -> [a] -> m ([b],[c],[d])+mapAndUnzip3M _ []     = return ([],[],[])+mapAndUnzip3M f (x:xs) = do+    (r1,  r2,  r3)  <- f x+    (rs1, rs2, rs3) <- mapAndUnzip3M f xs+    return (r1:rs1, r2:rs2, r3:rs3)++-- is it a letter or underscore?+isHsLetter :: Char -> Bool+isHsLetter c = isLetter c || c == '_'
tests/SingletonsTestSuite.hs view
@@ -18,17 +18,38 @@     , compileAndDumpStdTest "Maybe"     , compileAndDumpStdTest "BoxUnBox"     , compileAndDumpStdTest "Operators"-    , compileAndDumpStdTest "BadPlus"     , compileAndDumpStdTest "HigherOrder"     , compileAndDumpStdTest "Contains"-    , compileAndDumpStdTest "AtPattern"+    , compileAndDumpStdTest "AsPattern"     , compileAndDumpStdTest "DataValues"     , compileAndDumpStdTest "EqInstances"+    , compileAndDumpStdTest "CaseExpressions"     , compileAndDumpStdTest "Star"+    , compileAndDumpStdTest "Tuples"+    , compileAndDumpStdTest "ReturnFunc"+    , compileAndDumpStdTest "Lambdas"+    , compileAndDumpStdTest "LambdasComprehensive"+    , compileAndDumpStdTest "Error"+    , compileAndDumpStdTest "TopLevelPatterns"+    , compileAndDumpStdTest "LetStatements"+    , compileAndDumpStdTest "LambdaCase"+    , compileAndDumpStdTest "Sections"+    , compileAndDumpStdTest "PatternMatching"+    , compileAndDumpStdTest "Records"+    , compileAndDumpStdTest "T29"+    , compileAndDumpStdTest "T33"     ],     testCompileAndDumpGroup "Promote"-    [ compileAndDumpStdTest "PatternMatching"-    , compileAndDumpStdTest "NumArgs" -- remove once we have eta-expansion+    [ compileAndDumpStdTest "Constructors"+    , compileAndDumpStdTest "GenDefunSymbols"+    , compileAndDumpStdTest "Newtypes"+    , compileAndDumpStdTest "Classes"+    , compileAndDumpStdTest "TopLevelPatterns"+    , compileAndDumpStdTest "Pragmas"+    , compileAndDumpStdTest "OrdDeriving"+    , compileAndDumpStdTest "BoundedDeriving"+    , compileAndDumpStdTest "BadBoundedDeriving"+    , compileAndDumpStdTest "Prelude"     ],     testGroup "Database client"     [ compileAndDumpTest "GradingClient/Database" ghcOpts@@ -38,4 +59,3 @@     [ compileAndDumpStdTest "InsertionSortImp"     ]   ]-
tests/SingletonsTestSuiteUtils.hs view
@@ -7,16 +7,16 @@  , 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 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                           )+                          , createProcess, proc, waitForProcess )+import Test.Tasty         ( TestTree, testGroup                 )+import Test.Tasty.Golden  ( goldenVsFileDiff                    )  import Distribution.PackageDescription.Parse         ( readPackageDescription    ) import Distribution.PackageDescription.Configuration ( flattenPackageDescription )@@ -74,6 +74,7 @@   , "-ddump-splices"   , "-dsuppress-uniques"   , "-fforce-recomp"+  , "-fprint-explicit-kinds"   , "-i" ++ includePath   , "-XTemplateHaskell"   , "-XDataKinds"@@ -94,6 +95,8 @@   , "-XFlexibleContexts"   , "-XIncoherentInstances"   , "-XCPP"+  , "-XLambdaCase"+  , "-XUnboxedTuples"   ]  -- Note [-package-name hack]@@ -160,8 +163,7 @@  -- Note [Ignore exit code] -- ~~~~~~~~~~~~~~~~~~~~~~~------ It may happen that compilation of a source file fails. We could find out+---- 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
tests/compile-and-dump/GradingClient/Database.ghc76.template view
@@ -8,861 +8,934 @@     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+    type instance (:==) Zero Zero = TrueSym0+    type instance (:==) Zero (Succ b) = FalseSym0+    type instance (:==) (Succ a) Zero = FalseSym0+    type instance (:==) (Succ a) (Succ b) = :== a b+    type NatTyCtor = Nat+    type NatTyCtorSym0 = NatTyCtor+    type ZeroSym0 = Zero+    data SuccSym0 (k :: TyFun Nat Nat)+    type instance Apply SuccSym0 a = Succ a+    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 = TrueSym0+    type instance (:==) BOOL STRING = FalseSym0+    type instance (:==) BOOL NAT = FalseSym0+    type instance (:==) BOOL (VEC b b) = FalseSym0+    type instance (:==) STRING BOOL = FalseSym0+    type instance (:==) STRING STRING = TrueSym0+    type instance (:==) STRING NAT = FalseSym0+    type instance (:==) STRING (VEC b b) = FalseSym0+    type instance (:==) NAT BOOL = FalseSym0+    type instance (:==) NAT STRING = FalseSym0+    type instance (:==) NAT NAT = TrueSym0+    type instance (:==) NAT (VEC b b) = FalseSym0+    type instance (:==) (VEC a a) BOOL = FalseSym0+    type instance (:==) (VEC a a) STRING = FalseSym0+    type instance (:==) (VEC a a) NAT = FalseSym0+    type instance (:==) (VEC a a) (VEC b b) = :&& (:== a b) (:== a b)+    type UTyCtor = U+    type UTyCtorSym0 = UTyCtor+    type BOOLSym0 = BOOL+    type STRINGSym0 = STRING+    type NATSym0 = NAT+    data VECSym1 (l :: U) (l :: TyFun Nat U)+    data VECSym0 (k :: TyFun U (TyFun Nat U -> *))+    type instance Apply (VECSym1 a) a = VEC a a+    type instance Apply VECSym0 a = VECSym1 a+    type instance (:==) CA CA = TrueSym0+    type instance (:==) CA CB = FalseSym0+    type instance (:==) CA CC = FalseSym0+    type instance (:==) CA CD = FalseSym0+    type instance (:==) CA CE = FalseSym0+    type instance (:==) CA CF = FalseSym0+    type instance (:==) CA CG = FalseSym0+    type instance (:==) CA CH = FalseSym0+    type instance (:==) CA CI = FalseSym0+    type instance (:==) CA CJ = FalseSym0+    type instance (:==) CA CK = FalseSym0+    type instance (:==) CA CL = FalseSym0+    type instance (:==) CA CM = FalseSym0+    type instance (:==) CA CN = FalseSym0+    type instance (:==) CA CO = FalseSym0+    type instance (:==) CA CP = FalseSym0+    type instance (:==) CA CQ = FalseSym0+    type instance (:==) CA CR = FalseSym0+    type instance (:==) CA CS = FalseSym0+    type instance (:==) CA CT = FalseSym0+    type instance (:==) CA CU = FalseSym0+    type instance (:==) CA CV = FalseSym0+    type instance (:==) CA CW = FalseSym0+    type instance (:==) CA CX = FalseSym0+    type instance (:==) CA CY = FalseSym0+    type instance (:==) CA CZ = FalseSym0+    type instance (:==) CB CA = FalseSym0+    type instance (:==) CB CB = TrueSym0+    type instance (:==) CB CC = FalseSym0+    type instance (:==) CB CD = FalseSym0+    type instance (:==) CB CE = FalseSym0+    type instance (:==) CB CF = FalseSym0+    type instance (:==) CB CG = FalseSym0+    type instance (:==) CB CH = FalseSym0+    type instance (:==) CB CI = FalseSym0+    type instance (:==) CB CJ = FalseSym0+    type instance (:==) CB CK = FalseSym0+    type instance (:==) CB CL = FalseSym0+    type instance (:==) CB CM = FalseSym0+    type instance (:==) CB CN = FalseSym0+    type instance (:==) CB CO = FalseSym0+    type instance (:==) CB CP = FalseSym0+    type instance (:==) CB CQ = FalseSym0+    type instance (:==) CB CR = FalseSym0+    type instance (:==) CB CS = FalseSym0+    type instance (:==) CB CT = FalseSym0+    type instance (:==) CB CU = FalseSym0+    type instance (:==) CB CV = FalseSym0+    type instance (:==) CB CW = FalseSym0+    type instance (:==) CB CX = FalseSym0+    type instance (:==) CB CY = FalseSym0+    type instance (:==) CB CZ = FalseSym0+    type instance (:==) CC CA = FalseSym0+    type instance (:==) CC CB = FalseSym0+    type instance (:==) CC CC = TrueSym0+    type instance (:==) CC CD = FalseSym0+    type instance (:==) CC CE = FalseSym0+    type instance (:==) CC CF = FalseSym0+    type instance (:==) CC CG = FalseSym0+    type instance (:==) CC CH = FalseSym0+    type instance (:==) CC CI = FalseSym0+    type instance (:==) CC CJ = FalseSym0+    type instance (:==) CC CK = FalseSym0+    type instance (:==) CC CL = FalseSym0+    type instance (:==) CC CM = FalseSym0+    type instance (:==) CC CN = FalseSym0+    type instance (:==) CC CO = FalseSym0+    type instance (:==) CC CP = FalseSym0+    type instance (:==) CC CQ = FalseSym0+    type instance (:==) CC CR = FalseSym0+    type instance (:==) CC CS = FalseSym0+    type instance (:==) CC CT = FalseSym0+    type instance (:==) CC CU = FalseSym0+    type instance (:==) CC CV = FalseSym0+    type instance (:==) CC CW = FalseSym0+    type instance (:==) CC CX = FalseSym0+    type instance (:==) CC CY = FalseSym0+    type instance (:==) CC CZ = FalseSym0+    type instance (:==) CD CA = FalseSym0+    type instance (:==) CD CB = FalseSym0+    type instance (:==) CD CC = FalseSym0+    type instance (:==) CD CD = TrueSym0+    type instance (:==) CD CE = FalseSym0+    type instance (:==) CD CF = FalseSym0+    type instance (:==) CD CG = FalseSym0+    type instance (:==) CD CH = FalseSym0+    type instance (:==) CD CI = FalseSym0+    type instance (:==) CD CJ = FalseSym0+    type instance (:==) CD CK = FalseSym0+    type instance (:==) CD CL = FalseSym0+    type instance (:==) CD CM = FalseSym0+    type instance (:==) CD CN = FalseSym0+    type instance (:==) CD CO = FalseSym0+    type instance (:==) CD CP = FalseSym0+    type instance (:==) CD CQ = FalseSym0+    type instance (:==) CD CR = FalseSym0+    type instance (:==) CD CS = FalseSym0+    type instance (:==) CD CT = FalseSym0+    type instance (:==) CD CU = FalseSym0+    type instance (:==) CD CV = FalseSym0+    type instance (:==) CD CW = FalseSym0+    type instance (:==) CD CX = FalseSym0+    type instance (:==) CD CY = FalseSym0+    type instance (:==) CD CZ = FalseSym0+    type instance (:==) CE CA = FalseSym0+    type instance (:==) CE CB = FalseSym0+    type instance (:==) CE CC = FalseSym0+    type instance (:==) CE CD = FalseSym0+    type instance (:==) CE CE = TrueSym0+    type instance (:==) CE CF = FalseSym0+    type instance (:==) CE CG = FalseSym0+    type instance (:==) CE CH = FalseSym0+    type instance (:==) CE CI = FalseSym0+    type instance (:==) CE CJ = FalseSym0+    type instance (:==) CE CK = FalseSym0+    type instance (:==) CE CL = FalseSym0+    type instance (:==) CE CM = FalseSym0+    type instance (:==) CE CN = FalseSym0+    type instance (:==) CE CO = FalseSym0+    type instance (:==) CE CP = FalseSym0+    type instance (:==) CE CQ = FalseSym0+    type instance (:==) CE CR = FalseSym0+    type instance (:==) CE CS = FalseSym0+    type instance (:==) CE CT = FalseSym0+    type instance (:==) CE CU = FalseSym0+    type instance (:==) CE CV = FalseSym0+    type instance (:==) CE CW = FalseSym0+    type instance (:==) CE CX = FalseSym0+    type instance (:==) CE CY = FalseSym0+    type instance (:==) CE CZ = FalseSym0+    type instance (:==) CF CA = FalseSym0+    type instance (:==) CF CB = FalseSym0+    type instance (:==) CF CC = FalseSym0+    type instance (:==) CF CD = FalseSym0+    type instance (:==) CF CE = FalseSym0+    type instance (:==) CF CF = TrueSym0+    type instance (:==) CF CG = FalseSym0+    type instance (:==) CF CH = FalseSym0+    type instance (:==) CF CI = FalseSym0+    type instance (:==) CF CJ = FalseSym0+    type instance (:==) CF CK = FalseSym0+    type instance (:==) CF CL = FalseSym0+    type instance (:==) CF CM = FalseSym0+    type instance (:==) CF CN = FalseSym0+    type instance (:==) CF CO = FalseSym0+    type instance (:==) CF CP = FalseSym0+    type instance (:==) CF CQ = FalseSym0+    type instance (:==) CF CR = FalseSym0+    type instance (:==) CF CS = FalseSym0+    type instance (:==) CF CT = FalseSym0+    type instance (:==) CF CU = FalseSym0+    type instance (:==) CF CV = FalseSym0+    type instance (:==) CF CW = FalseSym0+    type instance (:==) CF CX = FalseSym0+    type instance (:==) CF CY = FalseSym0+    type instance (:==) CF CZ = FalseSym0+    type instance (:==) CG CA = FalseSym0+    type instance (:==) CG CB = FalseSym0+    type instance (:==) CG CC = FalseSym0+    type instance (:==) CG CD = FalseSym0+    type instance (:==) CG CE = FalseSym0+    type instance (:==) CG CF = FalseSym0+    type instance (:==) CG CG = TrueSym0+    type instance (:==) CG CH = FalseSym0+    type instance (:==) CG CI = FalseSym0+    type instance (:==) CG CJ = FalseSym0+    type instance (:==) CG CK = FalseSym0+    type instance (:==) CG CL = FalseSym0+    type instance (:==) CG CM = FalseSym0+    type instance (:==) CG CN = FalseSym0+    type instance (:==) CG CO = FalseSym0+    type instance (:==) CG CP = FalseSym0+    type instance (:==) CG CQ = FalseSym0+    type instance (:==) CG CR = FalseSym0+    type instance (:==) CG CS = FalseSym0+    type instance (:==) CG CT = FalseSym0+    type instance (:==) CG CU = FalseSym0+    type instance (:==) CG CV = FalseSym0+    type instance (:==) CG CW = FalseSym0+    type instance (:==) CG CX = FalseSym0+    type instance (:==) CG CY = FalseSym0+    type instance (:==) CG CZ = FalseSym0+    type instance (:==) CH CA = FalseSym0+    type instance (:==) CH CB = FalseSym0+    type instance (:==) CH CC = FalseSym0+    type instance (:==) CH CD = FalseSym0+    type instance (:==) CH CE = FalseSym0+    type instance (:==) CH CF = FalseSym0+    type instance (:==) CH CG = FalseSym0+    type instance (:==) CH CH = TrueSym0+    type instance (:==) CH CI = FalseSym0+    type instance (:==) CH CJ = FalseSym0+    type instance (:==) CH CK = FalseSym0+    type instance (:==) CH CL = FalseSym0+    type instance (:==) CH CM = FalseSym0+    type instance (:==) CH CN = FalseSym0+    type instance (:==) CH CO = FalseSym0+    type instance (:==) CH CP = FalseSym0+    type instance (:==) CH CQ = FalseSym0+    type instance (:==) CH CR = FalseSym0+    type instance (:==) CH CS = FalseSym0+    type instance (:==) CH CT = FalseSym0+    type instance (:==) CH CU = FalseSym0+    type instance (:==) CH CV = FalseSym0+    type instance (:==) CH CW = FalseSym0+    type instance (:==) CH CX = FalseSym0+    type instance (:==) CH CY = FalseSym0+    type instance (:==) CH CZ = FalseSym0+    type instance (:==) CI CA = FalseSym0+    type instance (:==) CI CB = FalseSym0+    type instance (:==) CI CC = FalseSym0+    type instance (:==) CI CD = FalseSym0+    type instance (:==) CI CE = FalseSym0+    type instance (:==) CI CF = FalseSym0+    type instance (:==) CI CG = FalseSym0+    type instance (:==) CI CH = FalseSym0+    type instance (:==) CI CI = TrueSym0+    type instance (:==) CI CJ = FalseSym0+    type instance (:==) CI CK = FalseSym0+    type instance (:==) CI CL = FalseSym0+    type instance (:==) CI CM = FalseSym0+    type instance (:==) CI CN = FalseSym0+    type instance (:==) CI CO = FalseSym0+    type instance (:==) CI CP = FalseSym0+    type instance (:==) CI CQ = FalseSym0+    type instance (:==) CI CR = FalseSym0+    type instance (:==) CI CS = FalseSym0+    type instance (:==) CI CT = FalseSym0+    type instance (:==) CI CU = FalseSym0+    type instance (:==) CI CV = FalseSym0+    type instance (:==) CI CW = FalseSym0+    type instance (:==) CI CX = FalseSym0+    type instance (:==) CI CY = FalseSym0+    type instance (:==) CI CZ = FalseSym0+    type instance (:==) CJ CA = FalseSym0+    type instance (:==) CJ CB = FalseSym0+    type instance (:==) CJ CC = FalseSym0+    type instance (:==) CJ CD = FalseSym0+    type instance (:==) CJ CE = FalseSym0+    type instance (:==) CJ CF = FalseSym0+    type instance (:==) CJ CG = FalseSym0+    type instance (:==) CJ CH = FalseSym0+    type instance (:==) CJ CI = FalseSym0+    type instance (:==) CJ CJ = TrueSym0+    type instance (:==) CJ CK = FalseSym0+    type instance (:==) CJ CL = FalseSym0+    type instance (:==) CJ CM = FalseSym0+    type instance (:==) CJ CN = FalseSym0+    type instance (:==) CJ CO = FalseSym0+    type instance (:==) CJ CP = FalseSym0+    type instance (:==) CJ CQ = FalseSym0+    type instance (:==) CJ CR = FalseSym0+    type instance (:==) CJ CS = FalseSym0+    type instance (:==) CJ CT = FalseSym0+    type instance (:==) CJ CU = FalseSym0+    type instance (:==) CJ CV = FalseSym0+    type instance (:==) CJ CW = FalseSym0+    type instance (:==) CJ CX = FalseSym0+    type instance (:==) CJ CY = FalseSym0+    type instance (:==) CJ CZ = FalseSym0+    type instance (:==) CK CA = FalseSym0+    type instance (:==) CK CB = FalseSym0+    type instance (:==) CK CC = FalseSym0+    type instance (:==) CK CD = FalseSym0+    type instance (:==) CK CE = FalseSym0+    type instance (:==) CK CF = FalseSym0+    type instance (:==) CK CG = FalseSym0+    type instance (:==) CK CH = FalseSym0+    type instance (:==) CK CI = FalseSym0+    type instance (:==) CK CJ = FalseSym0+    type instance (:==) CK CK = TrueSym0+    type instance (:==) CK CL = FalseSym0+    type instance (:==) CK CM = FalseSym0+    type instance (:==) CK CN = FalseSym0+    type instance (:==) CK CO = FalseSym0+    type instance (:==) CK CP = FalseSym0+    type instance (:==) CK CQ = FalseSym0+    type instance (:==) CK CR = FalseSym0+    type instance (:==) CK CS = FalseSym0+    type instance (:==) CK CT = FalseSym0+    type instance (:==) CK CU = FalseSym0+    type instance (:==) CK CV = FalseSym0+    type instance (:==) CK CW = FalseSym0+    type instance (:==) CK CX = FalseSym0+    type instance (:==) CK CY = FalseSym0+    type instance (:==) CK CZ = FalseSym0+    type instance (:==) CL CA = FalseSym0+    type instance (:==) CL CB = FalseSym0+    type instance (:==) CL CC = FalseSym0+    type instance (:==) CL CD = FalseSym0+    type instance (:==) CL CE = FalseSym0+    type instance (:==) CL CF = FalseSym0+    type instance (:==) CL CG = FalseSym0+    type instance (:==) CL CH = FalseSym0+    type instance (:==) CL CI = FalseSym0+    type instance (:==) CL CJ = FalseSym0+    type instance (:==) CL CK = FalseSym0+    type instance (:==) CL CL = TrueSym0+    type instance (:==) CL CM = FalseSym0+    type instance (:==) CL CN = FalseSym0+    type instance (:==) CL CO = FalseSym0+    type instance (:==) CL CP = FalseSym0+    type instance (:==) CL CQ = FalseSym0+    type instance (:==) CL CR = FalseSym0+    type instance (:==) CL CS = FalseSym0+    type instance (:==) CL CT = FalseSym0+    type instance (:==) CL CU = FalseSym0+    type instance (:==) CL CV = FalseSym0+    type instance (:==) CL CW = FalseSym0+    type instance (:==) CL CX = FalseSym0+    type instance (:==) CL CY = FalseSym0+    type instance (:==) CL CZ = FalseSym0+    type instance (:==) CM CA = FalseSym0+    type instance (:==) CM CB = FalseSym0+    type instance (:==) CM CC = FalseSym0+    type instance (:==) CM CD = FalseSym0+    type instance (:==) CM CE = FalseSym0+    type instance (:==) CM CF = FalseSym0+    type instance (:==) CM CG = FalseSym0+    type instance (:==) CM CH = FalseSym0+    type instance (:==) CM CI = FalseSym0+    type instance (:==) CM CJ = FalseSym0+    type instance (:==) CM CK = FalseSym0+    type instance (:==) CM CL = FalseSym0+    type instance (:==) CM CM = TrueSym0+    type instance (:==) CM CN = FalseSym0+    type instance (:==) CM CO = FalseSym0+    type instance (:==) CM CP = FalseSym0+    type instance (:==) CM CQ = FalseSym0+    type instance (:==) CM CR = FalseSym0+    type instance (:==) CM CS = FalseSym0+    type instance (:==) CM CT = FalseSym0+    type instance (:==) CM CU = FalseSym0+    type instance (:==) CM CV = FalseSym0+    type instance (:==) CM CW = FalseSym0+    type instance (:==) CM CX = FalseSym0+    type instance (:==) CM CY = FalseSym0+    type instance (:==) CM CZ = FalseSym0+    type instance (:==) CN CA = FalseSym0+    type instance (:==) CN CB = FalseSym0+    type instance (:==) CN CC = FalseSym0+    type instance (:==) CN CD = FalseSym0+    type instance (:==) CN CE = FalseSym0+    type instance (:==) CN CF = FalseSym0+    type instance (:==) CN CG = FalseSym0+    type instance (:==) CN CH = FalseSym0+    type instance (:==) CN CI = FalseSym0+    type instance (:==) CN CJ = FalseSym0+    type instance (:==) CN CK = FalseSym0+    type instance (:==) CN CL = FalseSym0+    type instance (:==) CN CM = FalseSym0+    type instance (:==) CN CN = TrueSym0+    type instance (:==) CN CO = FalseSym0+    type instance (:==) CN CP = FalseSym0+    type instance (:==) CN CQ = FalseSym0+    type instance (:==) CN CR = FalseSym0+    type instance (:==) CN CS = FalseSym0+    type instance (:==) CN CT = FalseSym0+    type instance (:==) CN CU = FalseSym0+    type instance (:==) CN CV = FalseSym0+    type instance (:==) CN CW = FalseSym0+    type instance (:==) CN CX = FalseSym0+    type instance (:==) CN CY = FalseSym0+    type instance (:==) CN CZ = FalseSym0+    type instance (:==) CO CA = FalseSym0+    type instance (:==) CO CB = FalseSym0+    type instance (:==) CO CC = FalseSym0+    type instance (:==) CO CD = FalseSym0+    type instance (:==) CO CE = FalseSym0+    type instance (:==) CO CF = FalseSym0+    type instance (:==) CO CG = FalseSym0+    type instance (:==) CO CH = FalseSym0+    type instance (:==) CO CI = FalseSym0+    type instance (:==) CO CJ = FalseSym0+    type instance (:==) CO CK = FalseSym0+    type instance (:==) CO CL = FalseSym0+    type instance (:==) CO CM = FalseSym0+    type instance (:==) CO CN = FalseSym0+    type instance (:==) CO CO = TrueSym0+    type instance (:==) CO CP = FalseSym0+    type instance (:==) CO CQ = FalseSym0+    type instance (:==) CO CR = FalseSym0+    type instance (:==) CO CS = FalseSym0+    type instance (:==) CO CT = FalseSym0+    type instance (:==) CO CU = FalseSym0+    type instance (:==) CO CV = FalseSym0+    type instance (:==) CO CW = FalseSym0+    type instance (:==) CO CX = FalseSym0+    type instance (:==) CO CY = FalseSym0+    type instance (:==) CO CZ = FalseSym0+    type instance (:==) CP CA = FalseSym0+    type instance (:==) CP CB = FalseSym0+    type instance (:==) CP CC = FalseSym0+    type instance (:==) CP CD = FalseSym0+    type instance (:==) CP CE = FalseSym0+    type instance (:==) CP CF = FalseSym0+    type instance (:==) CP CG = FalseSym0+    type instance (:==) CP CH = FalseSym0+    type instance (:==) CP CI = FalseSym0+    type instance (:==) CP CJ = FalseSym0+    type instance (:==) CP CK = FalseSym0+    type instance (:==) CP CL = FalseSym0+    type instance (:==) CP CM = FalseSym0+    type instance (:==) CP CN = FalseSym0+    type instance (:==) CP CO = FalseSym0+    type instance (:==) CP CP = TrueSym0+    type instance (:==) CP CQ = FalseSym0+    type instance (:==) CP CR = FalseSym0+    type instance (:==) CP CS = FalseSym0+    type instance (:==) CP CT = FalseSym0+    type instance (:==) CP CU = FalseSym0+    type instance (:==) CP CV = FalseSym0+    type instance (:==) CP CW = FalseSym0+    type instance (:==) CP CX = FalseSym0+    type instance (:==) CP CY = FalseSym0+    type instance (:==) CP CZ = FalseSym0+    type instance (:==) CQ CA = FalseSym0+    type instance (:==) CQ CB = FalseSym0+    type instance (:==) CQ CC = FalseSym0+    type instance (:==) CQ CD = FalseSym0+    type instance (:==) CQ CE = FalseSym0+    type instance (:==) CQ CF = FalseSym0+    type instance (:==) CQ CG = FalseSym0+    type instance (:==) CQ CH = FalseSym0+    type instance (:==) CQ CI = FalseSym0+    type instance (:==) CQ CJ = FalseSym0+    type instance (:==) CQ CK = FalseSym0+    type instance (:==) CQ CL = FalseSym0+    type instance (:==) CQ CM = FalseSym0+    type instance (:==) CQ CN = FalseSym0+    type instance (:==) CQ CO = FalseSym0+    type instance (:==) CQ CP = FalseSym0+    type instance (:==) CQ CQ = TrueSym0+    type instance (:==) CQ CR = FalseSym0+    type instance (:==) CQ CS = FalseSym0+    type instance (:==) CQ CT = FalseSym0+    type instance (:==) CQ CU = FalseSym0+    type instance (:==) CQ CV = FalseSym0+    type instance (:==) CQ CW = FalseSym0+    type instance (:==) CQ CX = FalseSym0+    type instance (:==) CQ CY = FalseSym0+    type instance (:==) CQ CZ = FalseSym0+    type instance (:==) CR CA = FalseSym0+    type instance (:==) CR CB = FalseSym0+    type instance (:==) CR CC = FalseSym0+    type instance (:==) CR CD = FalseSym0+    type instance (:==) CR CE = FalseSym0+    type instance (:==) CR CF = FalseSym0+    type instance (:==) CR CG = FalseSym0+    type instance (:==) CR CH = FalseSym0+    type instance (:==) CR CI = FalseSym0+    type instance (:==) CR CJ = FalseSym0+    type instance (:==) CR CK = FalseSym0+    type instance (:==) CR CL = FalseSym0+    type instance (:==) CR CM = FalseSym0+    type instance (:==) CR CN = FalseSym0+    type instance (:==) CR CO = FalseSym0+    type instance (:==) CR CP = FalseSym0+    type instance (:==) CR CQ = FalseSym0+    type instance (:==) CR CR = TrueSym0+    type instance (:==) CR CS = FalseSym0+    type instance (:==) CR CT = FalseSym0+    type instance (:==) CR CU = FalseSym0+    type instance (:==) CR CV = FalseSym0+    type instance (:==) CR CW = FalseSym0+    type instance (:==) CR CX = FalseSym0+    type instance (:==) CR CY = FalseSym0+    type instance (:==) CR CZ = FalseSym0+    type instance (:==) CS CA = FalseSym0+    type instance (:==) CS CB = FalseSym0+    type instance (:==) CS CC = FalseSym0+    type instance (:==) CS CD = FalseSym0+    type instance (:==) CS CE = FalseSym0+    type instance (:==) CS CF = FalseSym0+    type instance (:==) CS CG = FalseSym0+    type instance (:==) CS CH = FalseSym0+    type instance (:==) CS CI = FalseSym0+    type instance (:==) CS CJ = FalseSym0+    type instance (:==) CS CK = FalseSym0+    type instance (:==) CS CL = FalseSym0+    type instance (:==) CS CM = FalseSym0+    type instance (:==) CS CN = FalseSym0+    type instance (:==) CS CO = FalseSym0+    type instance (:==) CS CP = FalseSym0+    type instance (:==) CS CQ = FalseSym0+    type instance (:==) CS CR = FalseSym0+    type instance (:==) CS CS = TrueSym0+    type instance (:==) CS CT = FalseSym0+    type instance (:==) CS CU = FalseSym0+    type instance (:==) CS CV = FalseSym0+    type instance (:==) CS CW = FalseSym0+    type instance (:==) CS CX = FalseSym0+    type instance (:==) CS CY = FalseSym0+    type instance (:==) CS CZ = FalseSym0+    type instance (:==) CT CA = FalseSym0+    type instance (:==) CT CB = FalseSym0+    type instance (:==) CT CC = FalseSym0+    type instance (:==) CT CD = FalseSym0+    type instance (:==) CT CE = FalseSym0+    type instance (:==) CT CF = FalseSym0+    type instance (:==) CT CG = FalseSym0+    type instance (:==) CT CH = FalseSym0+    type instance (:==) CT CI = FalseSym0+    type instance (:==) CT CJ = FalseSym0+    type instance (:==) CT CK = FalseSym0+    type instance (:==) CT CL = FalseSym0+    type instance (:==) CT CM = FalseSym0+    type instance (:==) CT CN = FalseSym0+    type instance (:==) CT CO = FalseSym0+    type instance (:==) CT CP = FalseSym0+    type instance (:==) CT CQ = FalseSym0+    type instance (:==) CT CR = FalseSym0+    type instance (:==) CT CS = FalseSym0+    type instance (:==) CT CT = TrueSym0+    type instance (:==) CT CU = FalseSym0+    type instance (:==) CT CV = FalseSym0+    type instance (:==) CT CW = FalseSym0+    type instance (:==) CT CX = FalseSym0+    type instance (:==) CT CY = FalseSym0+    type instance (:==) CT CZ = FalseSym0+    type instance (:==) CU CA = FalseSym0+    type instance (:==) CU CB = FalseSym0+    type instance (:==) CU CC = FalseSym0+    type instance (:==) CU CD = FalseSym0+    type instance (:==) CU CE = FalseSym0+    type instance (:==) CU CF = FalseSym0+    type instance (:==) CU CG = FalseSym0+    type instance (:==) CU CH = FalseSym0+    type instance (:==) CU CI = FalseSym0+    type instance (:==) CU CJ = FalseSym0+    type instance (:==) CU CK = FalseSym0+    type instance (:==) CU CL = FalseSym0+    type instance (:==) CU CM = FalseSym0+    type instance (:==) CU CN = FalseSym0+    type instance (:==) CU CO = FalseSym0+    type instance (:==) CU CP = FalseSym0+    type instance (:==) CU CQ = FalseSym0+    type instance (:==) CU CR = FalseSym0+    type instance (:==) CU CS = FalseSym0+    type instance (:==) CU CT = FalseSym0+    type instance (:==) CU CU = TrueSym0+    type instance (:==) CU CV = FalseSym0+    type instance (:==) CU CW = FalseSym0+    type instance (:==) CU CX = FalseSym0+    type instance (:==) CU CY = FalseSym0+    type instance (:==) CU CZ = FalseSym0+    type instance (:==) CV CA = FalseSym0+    type instance (:==) CV CB = FalseSym0+    type instance (:==) CV CC = FalseSym0+    type instance (:==) CV CD = FalseSym0+    type instance (:==) CV CE = FalseSym0+    type instance (:==) CV CF = FalseSym0+    type instance (:==) CV CG = FalseSym0+    type instance (:==) CV CH = FalseSym0+    type instance (:==) CV CI = FalseSym0+    type instance (:==) CV CJ = FalseSym0+    type instance (:==) CV CK = FalseSym0+    type instance (:==) CV CL = FalseSym0+    type instance (:==) CV CM = FalseSym0+    type instance (:==) CV CN = FalseSym0+    type instance (:==) CV CO = FalseSym0+    type instance (:==) CV CP = FalseSym0+    type instance (:==) CV CQ = FalseSym0+    type instance (:==) CV CR = FalseSym0+    type instance (:==) CV CS = FalseSym0+    type instance (:==) CV CT = FalseSym0+    type instance (:==) CV CU = FalseSym0+    type instance (:==) CV CV = TrueSym0+    type instance (:==) CV CW = FalseSym0+    type instance (:==) CV CX = FalseSym0+    type instance (:==) CV CY = FalseSym0+    type instance (:==) CV CZ = FalseSym0+    type instance (:==) CW CA = FalseSym0+    type instance (:==) CW CB = FalseSym0+    type instance (:==) CW CC = FalseSym0+    type instance (:==) CW CD = FalseSym0+    type instance (:==) CW CE = FalseSym0+    type instance (:==) CW CF = FalseSym0+    type instance (:==) CW CG = FalseSym0+    type instance (:==) CW CH = FalseSym0+    type instance (:==) CW CI = FalseSym0+    type instance (:==) CW CJ = FalseSym0+    type instance (:==) CW CK = FalseSym0+    type instance (:==) CW CL = FalseSym0+    type instance (:==) CW CM = FalseSym0+    type instance (:==) CW CN = FalseSym0+    type instance (:==) CW CO = FalseSym0+    type instance (:==) CW CP = FalseSym0+    type instance (:==) CW CQ = FalseSym0+    type instance (:==) CW CR = FalseSym0+    type instance (:==) CW CS = FalseSym0+    type instance (:==) CW CT = FalseSym0+    type instance (:==) CW CU = FalseSym0+    type instance (:==) CW CV = FalseSym0+    type instance (:==) CW CW = TrueSym0+    type instance (:==) CW CX = FalseSym0+    type instance (:==) CW CY = FalseSym0+    type instance (:==) CW CZ = FalseSym0+    type instance (:==) CX CA = FalseSym0+    type instance (:==) CX CB = FalseSym0+    type instance (:==) CX CC = FalseSym0+    type instance (:==) CX CD = FalseSym0+    type instance (:==) CX CE = FalseSym0+    type instance (:==) CX CF = FalseSym0+    type instance (:==) CX CG = FalseSym0+    type instance (:==) CX CH = FalseSym0+    type instance (:==) CX CI = FalseSym0+    type instance (:==) CX CJ = FalseSym0+    type instance (:==) CX CK = FalseSym0+    type instance (:==) CX CL = FalseSym0+    type instance (:==) CX CM = FalseSym0+    type instance (:==) CX CN = FalseSym0+    type instance (:==) CX CO = FalseSym0+    type instance (:==) CX CP = FalseSym0+    type instance (:==) CX CQ = FalseSym0+    type instance (:==) CX CR = FalseSym0+    type instance (:==) CX CS = FalseSym0+    type instance (:==) CX CT = FalseSym0+    type instance (:==) CX CU = FalseSym0+    type instance (:==) CX CV = FalseSym0+    type instance (:==) CX CW = FalseSym0+    type instance (:==) CX CX = TrueSym0+    type instance (:==) CX CY = FalseSym0+    type instance (:==) CX CZ = FalseSym0+    type instance (:==) CY CA = FalseSym0+    type instance (:==) CY CB = FalseSym0+    type instance (:==) CY CC = FalseSym0+    type instance (:==) CY CD = FalseSym0+    type instance (:==) CY CE = FalseSym0+    type instance (:==) CY CF = FalseSym0+    type instance (:==) CY CG = FalseSym0+    type instance (:==) CY CH = FalseSym0+    type instance (:==) CY CI = FalseSym0+    type instance (:==) CY CJ = FalseSym0+    type instance (:==) CY CK = FalseSym0+    type instance (:==) CY CL = FalseSym0+    type instance (:==) CY CM = FalseSym0+    type instance (:==) CY CN = FalseSym0+    type instance (:==) CY CO = FalseSym0+    type instance (:==) CY CP = FalseSym0+    type instance (:==) CY CQ = FalseSym0+    type instance (:==) CY CR = FalseSym0+    type instance (:==) CY CS = FalseSym0+    type instance (:==) CY CT = FalseSym0+    type instance (:==) CY CU = FalseSym0+    type instance (:==) CY CV = FalseSym0+    type instance (:==) CY CW = FalseSym0+    type instance (:==) CY CX = FalseSym0+    type instance (:==) CY CY = TrueSym0+    type instance (:==) CY CZ = FalseSym0+    type instance (:==) CZ CA = FalseSym0+    type instance (:==) CZ CB = FalseSym0+    type instance (:==) CZ CC = FalseSym0+    type instance (:==) CZ CD = FalseSym0+    type instance (:==) CZ CE = FalseSym0+    type instance (:==) CZ CF = FalseSym0+    type instance (:==) CZ CG = FalseSym0+    type instance (:==) CZ CH = FalseSym0+    type instance (:==) CZ CI = FalseSym0+    type instance (:==) CZ CJ = FalseSym0+    type instance (:==) CZ CK = FalseSym0+    type instance (:==) CZ CL = FalseSym0+    type instance (:==) CZ CM = FalseSym0+    type instance (:==) CZ CN = FalseSym0+    type instance (:==) CZ CO = FalseSym0+    type instance (:==) CZ CP = FalseSym0+    type instance (:==) CZ CQ = FalseSym0+    type instance (:==) CZ CR = FalseSym0+    type instance (:==) CZ CS = FalseSym0+    type instance (:==) CZ CT = FalseSym0+    type instance (:==) CZ CU = FalseSym0+    type instance (:==) CZ CV = FalseSym0+    type instance (:==) CZ CW = FalseSym0+    type instance (:==) CZ CX = FalseSym0+    type instance (:==) CZ CY = FalseSym0+    type instance (:==) CZ CZ = TrueSym0+    type ACharTyCtor = AChar+    type ACharTyCtorSym0 = ACharTyCtor+    type CASym0 = CA+    type CBSym0 = CB+    type CCSym0 = CC+    type CDSym0 = CD+    type CESym0 = CE+    type CFSym0 = CF+    type CGSym0 = CG+    type CHSym0 = CH+    type CISym0 = CI+    type CJSym0 = CJ+    type CKSym0 = CK+    type CLSym0 = CL+    type CMSym0 = CM+    type CNSym0 = CN+    type COSym0 = CO+    type CPSym0 = CP+    type CQSym0 = CQ+    type CRSym0 = CR+    type CSSym0 = CS+    type CTSym0 = CT+    type CUSym0 = CU+    type CVSym0 = CV+    type CWSym0 = CW+    type CXSym0 = CX+    type CYSym0 = CY+    type CZSym0 = CZ+    type AttributeTyCtor = Attribute+    type AttributeTyCtorSym0 = AttributeTyCtor+    data AttrSym1 (l :: [AChar]) (l :: TyFun U Attribute)+    data AttrSym0 (k :: TyFun [AChar] (TyFun U Attribute -> *))+    type instance Apply (AttrSym1 a) a = Attr a a+    type instance Apply AttrSym0 a = AttrSym1 a+    type SchemaTyCtor = Schema+    type SchemaTyCtorSym0 = SchemaTyCtor+    data SchSym0 (k :: TyFun [Attribute] Schema)+    type instance Apply SchSym0 a = Sch a+    type family Append (a :: Schema) (a :: Schema) :: Schema+    type instance Append (Sch s1) (Sch s2) =+        Apply SchSym0 (Apply (Apply :++$ s1) s2)+    data AppendSym1 (l :: Schema) (l :: TyFun Schema Schema)+    data AppendSym0 (k :: TyFun Schema (TyFun Schema Schema -> *))+    type instance Apply (AppendSym1 a) a = Append a a+    type instance Apply AppendSym0 a = AppendSym1 a+    type family AttrNotIn (a :: Attribute) (a :: Schema) :: Bool+    type instance AttrNotIn z (Sch GHC.Types.[]) = TrueSym0+    type instance AttrNotIn (Attr name u) (Sch (GHC.Types.: (Attr name' z) t)) =+        Apply (Apply :&&$ (Apply (Apply :/=$ name) name')) (Apply (Apply AttrNotInSym0 (Apply (Apply AttrSym0 name) u)) (Apply SchSym0 t))+    data AttrNotInSym1 (l :: Attribute) (l :: TyFun Schema Bool)+    data AttrNotInSym0 (k :: TyFun Attribute (TyFun Schema Bool -> *))+    type instance Apply (AttrNotInSym1 a) a = AttrNotIn a a+    type instance Apply AttrNotInSym0 a = AttrNotInSym1 a+    type family Disjoint (a :: Schema) (a :: Schema) :: Bool+    type instance Disjoint (Sch GHC.Types.[]) z = TrueSym0+    type instance Disjoint (Sch (GHC.Types.: h t)) s =+        Apply (Apply :&&$ (Apply (Apply AttrNotInSym0 h) s)) (Apply (Apply DisjointSym0 (Apply SchSym0 t)) s)+    data DisjointSym1 (l :: Schema) (l :: TyFun Schema Bool)+    data DisjointSym0 (k :: TyFun Schema (TyFun Schema Bool -> *))+    type instance Apply (DisjointSym1 a) a = Disjoint a a+    type instance Apply DisjointSym0 a = DisjointSym1 a+    type family Occurs (a :: [AChar]) (a :: Schema) :: Bool+    type instance Occurs z (Sch GHC.Types.[]) = FalseSym0+    type instance Occurs name (Sch (GHC.Types.: (Attr name' z) attrs)) =+        Apply (Apply :||$ (Apply (Apply :==$ name) name')) (Apply (Apply OccursSym0 name) (Apply SchSym0 attrs))+    data OccursSym1 (l :: [AChar]) (l :: TyFun Schema Bool)+    data OccursSym0 (k :: TyFun [AChar] (TyFun Schema Bool -> *))+    type instance Apply (OccursSym1 a) a = Occurs a a+    type instance Apply OccursSym0 a = OccursSym1 a+    type family Lookup (a :: [AChar]) (a :: Schema) :: U+    type instance Lookup z (Sch GHC.Types.[]) = Any+    type instance Lookup name (Sch (GHC.Types.: (Attr name' u) attrs)) =+        If (Apply (Apply :==$ name) name') u (Apply (Apply LookupSym0 name) (Apply SchSym0 attrs))+    data LookupSym1 (l :: [AChar]) (l :: TyFun Schema U)+    data LookupSym0 (k :: TyFun [AChar] (TyFun Schema U -> *))+    type instance Apply (LookupSym1 a) a = Lookup a a+    type instance Apply LookupSym0 a = LookupSym1 a     data instance Sing (z :: U)       = z ~ BOOL => SBOOL |         z ~ STRING => SSTRING |
tests/compile-and-dump/GradingClient/Database.ghc78.template view
@@ -9,3804 +9,4823 @@       = 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 }+      Equals_0123456789 Zero Zero = TrueSym0+      Equals_0123456789 (Succ a) (Succ b) = (:==) a b+      Equals_0123456789 (a :: Nat) (b :: Nat) = FalseSym0+    instance PEq (KProxy :: KProxy Nat) where+      type (:==) (a :: Nat) (b :: Nat) = Equals_0123456789 a b+    instance POrd (KProxy :: KProxy Nat) where+      type Compare Zero Zero = EQ+      type Compare Zero (Succ rhs) = LT+      type Compare (Succ lhs) Zero = GT+      type Compare (Succ lhs) (Succ rhs) = ThenCmp EQ (Compare lhs rhs)+    type ZeroSym0 = Zero+    type SuccSym1 (t :: Nat) = Succ t+    instance SuppressUnusedWarnings SuccSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) SuccSym0KindInference GHC.Tuple.())+    data SuccSym0 (l :: TyFun Nat Nat)+      = forall arg. (GHC.Types.~) (KindOf (Apply SuccSym0 arg)) (KindOf (SuccSym1 arg)) =>+        SuccSym0KindInference+    type instance Apply SuccSym0 l = SuccSym1 l+    data instance Sing (z :: Nat)+      = (GHC.Types.~) z Zero => SZero |+        forall (n :: Nat). (GHC.Types.~) 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+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) (SSucc _) SZero+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) (SSucc a) (SSucc b)+        = case (%~) a b of {+            Proved Refl -> Proved Refl+            Disproved contra+              -> Disproved (\ refl -> case refl of { 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 = TrueSym0+      Equals_0123456789 STRING STRING = TrueSym0+      Equals_0123456789 NAT NAT = TrueSym0+      Equals_0123456789 (VEC a a) (VEC b b) = (:&&) ((:==) a b) ((:==) a b)+      Equals_0123456789 (a :: U) (b :: U) = FalseSym0+    instance PEq (KProxy :: KProxy U) where+      type (:==) (a :: U) (b :: U) = Equals_0123456789 a b+    type BOOLSym0 = BOOL+    type STRINGSym0 = STRING+    type NATSym0 = NAT+    type VECSym2 (t :: U) (t :: Nat) = VEC t t+    instance SuppressUnusedWarnings VECSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) VECSym1KindInference GHC.Tuple.())+    data VECSym1 (l :: U) (l :: TyFun Nat U)+      = forall arg. (GHC.Types.~) (KindOf (Apply (VECSym1 l) arg)) (KindOf (VECSym2 l arg)) =>+        VECSym1KindInference+    type instance Apply (VECSym1 l) l = VECSym2 l l+    instance SuppressUnusedWarnings VECSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) VECSym0KindInference GHC.Tuple.())+    data VECSym0 (l :: TyFun U (TyFun Nat U -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply VECSym0 arg)) (KindOf (VECSym1 arg)) =>+        VECSym0KindInference+    type instance Apply VECSym0 l = VECSym1 l+    type family Equals_0123456789 (a :: AChar)+                                  (b :: AChar) :: Bool where+      Equals_0123456789 CA CA = TrueSym0+      Equals_0123456789 CB CB = TrueSym0+      Equals_0123456789 CC CC = TrueSym0+      Equals_0123456789 CD CD = TrueSym0+      Equals_0123456789 CE CE = TrueSym0+      Equals_0123456789 CF CF = TrueSym0+      Equals_0123456789 CG CG = TrueSym0+      Equals_0123456789 CH CH = TrueSym0+      Equals_0123456789 CI CI = TrueSym0+      Equals_0123456789 CJ CJ = TrueSym0+      Equals_0123456789 CK CK = TrueSym0+      Equals_0123456789 CL CL = TrueSym0+      Equals_0123456789 CM CM = TrueSym0+      Equals_0123456789 CN CN = TrueSym0+      Equals_0123456789 CO CO = TrueSym0+      Equals_0123456789 CP CP = TrueSym0+      Equals_0123456789 CQ CQ = TrueSym0+      Equals_0123456789 CR CR = TrueSym0+      Equals_0123456789 CS CS = TrueSym0+      Equals_0123456789 CT CT = TrueSym0+      Equals_0123456789 CU CU = TrueSym0+      Equals_0123456789 CV CV = TrueSym0+      Equals_0123456789 CW CW = TrueSym0+      Equals_0123456789 CX CX = TrueSym0+      Equals_0123456789 CY CY = TrueSym0+      Equals_0123456789 CZ CZ = TrueSym0+      Equals_0123456789 (a :: AChar) (b :: AChar) = FalseSym0+    instance PEq (KProxy :: KProxy AChar) where+      type (:==) (a :: AChar) (b :: AChar) = Equals_0123456789 a b+    type CASym0 = CA+    type CBSym0 = CB+    type CCSym0 = CC+    type CDSym0 = CD+    type CESym0 = CE+    type CFSym0 = CF+    type CGSym0 = CG+    type CHSym0 = CH+    type CISym0 = CI+    type CJSym0 = CJ+    type CKSym0 = CK+    type CLSym0 = CL+    type CMSym0 = CM+    type CNSym0 = CN+    type COSym0 = CO+    type CPSym0 = CP+    type CQSym0 = CQ+    type CRSym0 = CR+    type CSSym0 = CS+    type CTSym0 = CT+    type CUSym0 = CU+    type CVSym0 = CV+    type CWSym0 = CW+    type CXSym0 = CX+    type CYSym0 = CY+    type CZSym0 = CZ+    type AttrSym2 (t :: GHC.Types.[] AChar) (t :: U) = Attr t t+    instance SuppressUnusedWarnings AttrSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) AttrSym1KindInference GHC.Tuple.())+    data AttrSym1 (l :: GHC.Types.[] AChar) (l :: TyFun U Attribute)+      = forall arg. (GHC.Types.~) (KindOf (Apply (AttrSym1 l) arg)) (KindOf (AttrSym2 l arg)) =>+        AttrSym1KindInference+    type instance Apply (AttrSym1 l) l = AttrSym2 l l+    instance SuppressUnusedWarnings AttrSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) AttrSym0KindInference GHC.Tuple.())+    data AttrSym0 (l :: TyFun (GHC.Types.[] AChar) (TyFun U Attribute+                                                    -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply AttrSym0 arg)) (KindOf (AttrSym1 arg)) =>+        AttrSym0KindInference+    type instance Apply AttrSym0 l = AttrSym1 l+    type SchSym1 (t :: GHC.Types.[] Attribute) = Sch t+    instance SuppressUnusedWarnings SchSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) SchSym0KindInference GHC.Tuple.())+    data SchSym0 (l :: TyFun (GHC.Types.[] Attribute) Schema)+      = forall arg. (GHC.Types.~) (KindOf (Apply SchSym0 arg)) (KindOf (SchSym1 arg)) =>+        SchSym0KindInference+    type instance Apply SchSym0 l = SchSym1 l+    type Let_0123456789Scrutinee_0123456789Sym4 t t t t =+        Let_0123456789Scrutinee_0123456789 t t t t+    instance SuppressUnusedWarnings Let_0123456789Scrutinee_0123456789Sym3 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,)+               Let_0123456789Scrutinee_0123456789Sym3KindInference GHC.Tuple.())+    data Let_0123456789Scrutinee_0123456789Sym3 l l l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Let_0123456789Scrutinee_0123456789Sym3 l l l) arg)) (KindOf (Let_0123456789Scrutinee_0123456789Sym4 l l l arg)) =>+        Let_0123456789Scrutinee_0123456789Sym3KindInference+    type instance Apply (Let_0123456789Scrutinee_0123456789Sym3 l l l) l = Let_0123456789Scrutinee_0123456789Sym4 l l l l+    instance SuppressUnusedWarnings Let_0123456789Scrutinee_0123456789Sym2 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,)+               Let_0123456789Scrutinee_0123456789Sym2KindInference GHC.Tuple.())+    data Let_0123456789Scrutinee_0123456789Sym2 l l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Let_0123456789Scrutinee_0123456789Sym2 l l) arg)) (KindOf (Let_0123456789Scrutinee_0123456789Sym3 l l arg)) =>+        Let_0123456789Scrutinee_0123456789Sym2KindInference+    type instance Apply (Let_0123456789Scrutinee_0123456789Sym2 l l) l = Let_0123456789Scrutinee_0123456789Sym3 l l l+    instance SuppressUnusedWarnings Let_0123456789Scrutinee_0123456789Sym1 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,)+               Let_0123456789Scrutinee_0123456789Sym1KindInference GHC.Tuple.())+    data Let_0123456789Scrutinee_0123456789Sym1 l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Let_0123456789Scrutinee_0123456789Sym1 l) arg)) (KindOf (Let_0123456789Scrutinee_0123456789Sym2 l arg)) =>+        Let_0123456789Scrutinee_0123456789Sym1KindInference+    type instance Apply (Let_0123456789Scrutinee_0123456789Sym1 l) l = Let_0123456789Scrutinee_0123456789Sym2 l l+    instance SuppressUnusedWarnings Let_0123456789Scrutinee_0123456789Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,)+               Let_0123456789Scrutinee_0123456789Sym0KindInference GHC.Tuple.())+    data Let_0123456789Scrutinee_0123456789Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Let_0123456789Scrutinee_0123456789Sym0 arg)) (KindOf (Let_0123456789Scrutinee_0123456789Sym1 arg)) =>+        Let_0123456789Scrutinee_0123456789Sym0KindInference+    type instance Apply Let_0123456789Scrutinee_0123456789Sym0 l = Let_0123456789Scrutinee_0123456789Sym1 l+    type Let_0123456789Scrutinee_0123456789 name name' u attrs =+        Apply (Apply (:==$) name) name'+    type family Case_0123456789 name name' u attrs t where+      Case_0123456789 name name' u attrs True = u+      Case_0123456789 name name' u attrs False = Apply (Apply LookupSym0 name) (Apply SchSym0 attrs)+    type LookupSym2 (t :: GHC.Types.[] AChar) (t :: Schema) =+        Lookup t t+    instance SuppressUnusedWarnings LookupSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) LookupSym1KindInference GHC.Tuple.())+    data LookupSym1 (l :: GHC.Types.[] AChar) (l :: TyFun Schema U)+      = forall arg. (GHC.Types.~) (KindOf (Apply (LookupSym1 l) arg)) (KindOf (LookupSym2 l arg)) =>+        LookupSym1KindInference+    type instance Apply (LookupSym1 l) l = LookupSym2 l l+    instance SuppressUnusedWarnings LookupSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) LookupSym0KindInference GHC.Tuple.())+    data LookupSym0 (l :: TyFun (GHC.Types.[] AChar) (TyFun Schema U+                                                      -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply LookupSym0 arg)) (KindOf (LookupSym1 arg)) =>+        LookupSym0KindInference+    type instance Apply LookupSym0 l = LookupSym1 l+    type OccursSym2 (t :: GHC.Types.[] AChar) (t :: Schema) =+        Occurs t t+    instance SuppressUnusedWarnings OccursSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) OccursSym1KindInference GHC.Tuple.())+    data OccursSym1 (l :: GHC.Types.[] AChar) (l :: TyFun Schema Bool)+      = forall arg. (GHC.Types.~) (KindOf (Apply (OccursSym1 l) arg)) (KindOf (OccursSym2 l arg)) =>+        OccursSym1KindInference+    type instance Apply (OccursSym1 l) l = OccursSym2 l l+    instance SuppressUnusedWarnings OccursSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) OccursSym0KindInference GHC.Tuple.())+    data OccursSym0 (l :: TyFun (GHC.Types.[] AChar) (TyFun Schema Bool+                                                      -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply OccursSym0 arg)) (KindOf (OccursSym1 arg)) =>+        OccursSym0KindInference+    type instance Apply OccursSym0 l = OccursSym1 l+    type AttrNotInSym2 (t :: Attribute) (t :: Schema) = AttrNotIn t t+    instance SuppressUnusedWarnings AttrNotInSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) AttrNotInSym1KindInference GHC.Tuple.())+    data AttrNotInSym1 (l :: Attribute) (l :: TyFun Schema Bool)+      = forall arg. (GHC.Types.~) (KindOf (Apply (AttrNotInSym1 l) arg)) (KindOf (AttrNotInSym2 l arg)) =>+        AttrNotInSym1KindInference+    type instance Apply (AttrNotInSym1 l) l = AttrNotInSym2 l l+    instance SuppressUnusedWarnings AttrNotInSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) AttrNotInSym0KindInference GHC.Tuple.())+    data AttrNotInSym0 (l :: TyFun Attribute (TyFun Schema Bool -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply AttrNotInSym0 arg)) (KindOf (AttrNotInSym1 arg)) =>+        AttrNotInSym0KindInference+    type instance Apply AttrNotInSym0 l = AttrNotInSym1 l+    type DisjointSym2 (t :: Schema) (t :: Schema) = Disjoint t t+    instance SuppressUnusedWarnings DisjointSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) DisjointSym1KindInference GHC.Tuple.())+    data DisjointSym1 (l :: Schema) (l :: TyFun Schema Bool)+      = forall arg. (GHC.Types.~) (KindOf (Apply (DisjointSym1 l) arg)) (KindOf (DisjointSym2 l arg)) =>+        DisjointSym1KindInference+    type instance Apply (DisjointSym1 l) l = DisjointSym2 l l+    instance SuppressUnusedWarnings DisjointSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) DisjointSym0KindInference GHC.Tuple.())+    data DisjointSym0 (l :: TyFun Schema (TyFun Schema Bool -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply DisjointSym0 arg)) (KindOf (DisjointSym1 arg)) =>+        DisjointSym0KindInference+    type instance Apply DisjointSym0 l = DisjointSym1 l+    type AppendSym2 (t :: Schema) (t :: Schema) = Append t t+    instance SuppressUnusedWarnings AppendSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) AppendSym1KindInference GHC.Tuple.())+    data AppendSym1 (l :: Schema) (l :: TyFun Schema Schema)+      = forall arg. (GHC.Types.~) (KindOf (Apply (AppendSym1 l) arg)) (KindOf (AppendSym2 l arg)) =>+        AppendSym1KindInference+    type instance Apply (AppendSym1 l) l = AppendSym2 l l+    instance SuppressUnusedWarnings AppendSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) AppendSym0KindInference GHC.Tuple.())+    data AppendSym0 (l :: TyFun Schema (TyFun Schema Schema -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply AppendSym0 arg)) (KindOf (AppendSym1 arg)) =>+        AppendSym0KindInference+    type instance Apply AppendSym0 l = AppendSym1 l+    type family Lookup (a :: GHC.Types.[] AChar)+                       (a :: Schema) :: U where+      Lookup z (Sch GHC.Types.[]) = Any+      Lookup name (Sch ((GHC.Types.:) (Attr name' u) attrs)) = Case_0123456789 name name' u attrs (Let_0123456789Scrutinee_0123456789Sym4 name name' u attrs)+    type family Occurs (a :: GHC.Types.[] AChar)+                       (a :: Schema) :: Bool where+      Occurs z (Sch GHC.Types.[]) = FalseSym0+      Occurs name (Sch ((GHC.Types.:) (Attr name' z) attrs)) = Apply (Apply (:||$) (Apply (Apply (:==$) name) name')) (Apply (Apply OccursSym0 name) (Apply SchSym0 attrs))+    type family AttrNotIn (a :: Attribute) (a :: Schema) :: Bool where+      AttrNotIn z (Sch GHC.Types.[]) = TrueSym0+      AttrNotIn (Attr name u) (Sch ((GHC.Types.:) (Attr name' z) t)) = Apply (Apply (:&&$) (Apply (Apply (:/=$) name) name')) (Apply (Apply AttrNotInSym0 (Apply (Apply AttrSym0 name) u)) (Apply SchSym0 t))+    type family Disjoint (a :: Schema) (a :: Schema) :: Bool where+      Disjoint (Sch GHC.Types.[]) z = TrueSym0+      Disjoint (Sch ((GHC.Types.:) h t)) s = Apply (Apply (:&&$) (Apply (Apply AttrNotInSym0 h) s)) (Apply (Apply DisjointSym0 (Apply SchSym0 t)) s)+    type family Append (a :: Schema) (a :: Schema) :: Schema where+      Append (Sch s1) (Sch s2) = Apply SchSym0 (Apply (Apply (:++$) s1) s2)+    sLookup ::+      forall (t :: GHC.Types.[] AChar) (t :: Schema).+      Sing t -> Sing t -> Sing (Apply (Apply LookupSym0 t) t)+    sOccurs ::+      forall (t :: GHC.Types.[] AChar) (t :: Schema).+      Sing t -> Sing t -> Sing (Apply (Apply OccursSym0 t) t)+    sAttrNotIn ::+      forall (t :: Attribute) (t :: Schema).+      Sing t -> Sing t -> Sing (Apply (Apply AttrNotInSym0 t) t)+    sDisjoint ::+      forall (t :: Schema) (t :: Schema).+      Sing t -> Sing t -> Sing (Apply (Apply DisjointSym0 t) t)+    sAppend ::+      forall (t :: Schema) (t :: Schema).+      Sing t -> Sing t -> Sing (Apply (Apply AppendSym0 t) t)+    sLookup _ (SSch SNil)+      = let+          lambda ::+            forall wild. ((GHC.Types.~) t wild,+                          (GHC.Types.~) t (Apply SchSym0 GHC.Types.[])) =>+            Sing (Apply (Apply LookupSym0 wild) (Apply SchSym0 GHC.Types.[]))+          lambda = undefined+        in lambda+    sLookup sName (SSch (SCons (SAttr sName' sU) sAttrs))+      = let+          lambda ::+            forall name name' u attrs. ((GHC.Types.~) t name,+                                        (GHC.Types.~) t (Apply SchSym0 (Apply (Apply (:$) (Apply (Apply AttrSym0 name') u)) attrs))) =>+            Sing name+            -> Sing name'+               -> Sing u+                  -> Sing attrs+                     -> Sing (Apply (Apply LookupSym0 name) (Apply SchSym0 (Apply (Apply (:$) (Apply (Apply AttrSym0 name') u)) attrs)))+          lambda name name' u attrs+            = let+                sScrutinee_0123456789 ::+                  Sing (Let_0123456789Scrutinee_0123456789Sym4 name name' u attrs)+                sScrutinee_0123456789+                  = applySing+                      (applySing (singFun2 (Proxy :: Proxy (:==$)) (%:==)) name) name'+              in+                case sScrutinee_0123456789 of {+                  STrue+                    -> let+                         lambda :: Sing (Case_0123456789 name name' u attrs TrueSym0)+                         lambda = u+                       in lambda+                  SFalse+                    -> let+                         lambda :: Sing (Case_0123456789 name name' u attrs FalseSym0)+                         lambda+                           = applySing+                               (applySing (singFun2 (Proxy :: Proxy LookupSym0) sLookup) name)+                               (applySing (singFun1 (Proxy :: Proxy SchSym0) SSch) attrs)+                       in lambda }+        in lambda sName sName' sU sAttrs+    sOccurs _ (SSch SNil)+      = let+          lambda ::+            forall wild. ((GHC.Types.~) t wild,+                          (GHC.Types.~) t (Apply SchSym0 GHC.Types.[])) =>+            Sing (Apply (Apply OccursSym0 wild) (Apply SchSym0 GHC.Types.[]))+          lambda = SFalse+        in lambda+    sOccurs sName (SSch (SCons (SAttr sName' _) sAttrs))+      = let+          lambda ::+            forall name name' attrs wild. ((GHC.Types.~) t name,+                                           (GHC.Types.~) t (Apply SchSym0 (Apply (Apply (:$) (Apply (Apply AttrSym0 name') wild)) attrs))) =>+            Sing name+            -> Sing name'+               -> Sing attrs+                  -> Sing (Apply (Apply OccursSym0 name) (Apply SchSym0 (Apply (Apply (:$) (Apply (Apply AttrSym0 name') wild)) attrs)))+          lambda name name' attrs+            = applySing+                (applySing+                   (singFun2 (Proxy :: Proxy (:||$)) (%:||))+                   (applySing+                      (applySing (singFun2 (Proxy :: Proxy (:==$)) (%:==)) name) name'))+                (applySing+                   (applySing (singFun2 (Proxy :: Proxy OccursSym0) sOccurs) name)+                   (applySing (singFun1 (Proxy :: Proxy SchSym0) SSch) attrs))+        in lambda sName sName' sAttrs+    sAttrNotIn _ (SSch SNil)+      = let+          lambda ::+            forall wild. ((GHC.Types.~) t wild,+                          (GHC.Types.~) t (Apply SchSym0 GHC.Types.[])) =>+            Sing (Apply (Apply AttrNotInSym0 wild) (Apply SchSym0 GHC.Types.[]))+          lambda = STrue+        in lambda+    sAttrNotIn (SAttr sName sU) (SSch (SCons (SAttr sName' _) sT))+      = let+          lambda ::+            forall name+                   u+                   name'+                   t+                   wild. ((GHC.Types.~) t (Apply (Apply AttrSym0 name) u),+                          (GHC.Types.~) t (Apply SchSym0 (Apply (Apply (:$) (Apply (Apply AttrSym0 name') wild)) t))) =>+            Sing name+            -> Sing u+               -> Sing name'+                  -> Sing t+                     -> Sing (Apply (Apply AttrNotInSym0 (Apply (Apply AttrSym0 name) u)) (Apply SchSym0 (Apply (Apply (:$) (Apply (Apply AttrSym0 name') wild)) t)))+          lambda name u name' t+            = applySing+                (applySing+                   (singFun2 (Proxy :: Proxy (:&&$)) (%:&&))+                   (applySing+                      (applySing (singFun2 (Proxy :: Proxy (:/=$)) (%:/=)) name) name'))+                (applySing+                   (applySing+                      (singFun2 (Proxy :: Proxy AttrNotInSym0) sAttrNotIn)+                      (applySing+                         (applySing (singFun2 (Proxy :: Proxy AttrSym0) SAttr) name) u))+                   (applySing (singFun1 (Proxy :: Proxy SchSym0) SSch) t))+        in lambda sName sU sName' sT+    sDisjoint (SSch SNil) _+      = let+          lambda ::+            forall wild. ((GHC.Types.~) t (Apply SchSym0 GHC.Types.[]),+                          (GHC.Types.~) t wild) =>+            Sing (Apply (Apply DisjointSym0 (Apply SchSym0 GHC.Types.[])) wild)+          lambda = STrue+        in lambda+    sDisjoint (SSch (SCons sH sT)) sS+      = let+          lambda ::+            forall h+                   t+                   s. ((GHC.Types.~) t (Apply SchSym0 (Apply (Apply (:$) h) t)),+                       (GHC.Types.~) t s) =>+            Sing h+            -> Sing t+               -> Sing s+                  -> Sing (Apply (Apply DisjointSym0 (Apply SchSym0 (Apply (Apply (:$) h) t))) s)+          lambda h t s+            = applySing+                (applySing+                   (singFun2 (Proxy :: Proxy (:&&$)) (%:&&))+                   (applySing+                      (applySing (singFun2 (Proxy :: Proxy AttrNotInSym0) sAttrNotIn) h)+                      s))+                (applySing+                   (applySing+                      (singFun2 (Proxy :: Proxy DisjointSym0) sDisjoint)+                      (applySing (singFun1 (Proxy :: Proxy SchSym0) SSch) t))+                   s)+        in lambda sH sT sS+    sAppend (SSch sS1) (SSch sS2)+      = let+          lambda ::+            forall s1 s2. ((GHC.Types.~) t (Apply SchSym0 s1),+                           (GHC.Types.~) t (Apply SchSym0 s2)) =>+            Sing s1+            -> Sing s2+               -> Sing (Apply (Apply AppendSym0 (Apply SchSym0 s1)) (Apply SchSym0 s2))+          lambda s1 s2+            = applySing+                (singFun1 (Proxy :: Proxy SchSym0) SSch)+                (applySing+                   (applySing (singFun2 (Proxy :: Proxy (:++$)) (%:++)) s1) s2)+        in lambda sS1 sS2+    data instance Sing (z :: U)+      = (GHC.Types.~) z BOOL => SBOOL |+        (GHC.Types.~) z STRING => SSTRING |+        (GHC.Types.~) z NAT => SNAT |+        forall (n :: U) (n :: Nat). (GHC.Types.~) 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+              GHC.Tuple.(,)+                (toSing b :: SomeSing (KProxy :: KProxy U))+                (toSing b :: SomeSing (KProxy :: KProxy Nat))+          of {+            GHC.Tuple.(,) (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+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SBOOL SNAT+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SBOOL (SVEC _ _)+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SSTRING SBOOL+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SSTRING SSTRING = Proved Refl+      (%~) SSTRING SNAT+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SSTRING (SVEC _ _)+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SNAT SBOOL+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SNAT SSTRING+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SNAT SNAT = Proved Refl+      (%~) SNAT (SVEC _ _)+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) (SVEC _ _) SBOOL+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) (SVEC _ _) SSTRING+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) (SVEC _ _) SNAT+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) (SVEC a a) (SVEC b b)+        = case GHC.Tuple.(,) ((%~) a b) ((%~) a b) of {+            GHC.Tuple.(,) (Proved Refl) (Proved Refl) -> Proved Refl+            GHC.Tuple.(,) (Disproved contra) _+              -> Disproved (\ refl -> case refl of { Refl -> contra Refl })+            GHC.Tuple.(,) _ (Disproved contra)+              -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) }+    data instance Sing (z :: AChar)+      = (GHC.Types.~) z CA => SCA |+        (GHC.Types.~) z CB => SCB |+        (GHC.Types.~) z CC => SCC |+        (GHC.Types.~) z CD => SCD |+        (GHC.Types.~) z CE => SCE |+        (GHC.Types.~) z CF => SCF |+        (GHC.Types.~) z CG => SCG |+        (GHC.Types.~) z CH => SCH |+        (GHC.Types.~) z CI => SCI |+        (GHC.Types.~) z CJ => SCJ |+        (GHC.Types.~) z CK => SCK |+        (GHC.Types.~) z CL => SCL |+        (GHC.Types.~) z CM => SCM |+        (GHC.Types.~) z CN => SCN |+        (GHC.Types.~) z CO => SCO |+        (GHC.Types.~) z CP => SCP |+        (GHC.Types.~) z CQ => SCQ |+        (GHC.Types.~) z CR => SCR |+        (GHC.Types.~) z CS => SCS |+        (GHC.Types.~) z CT => SCT |+        (GHC.Types.~) z CU => SCU |+        (GHC.Types.~) z CV => SCV |+        (GHC.Types.~) z CW => SCW |+        (GHC.Types.~) z CX => SCX |+        (GHC.Types.~) z CY => SCY |+        (GHC.Types.~) 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+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCA SCC+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCA SCD+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCA SCE+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCA SCF+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCA SCG+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCA SCH+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCA SCI+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCA SCJ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCA SCK+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCA SCL+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCA SCM+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCA SCN+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCA SCO+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCA SCP+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCA SCQ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCA SCR+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCA SCS+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCA SCT+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCA SCU+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCA SCV+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCA SCW+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCA SCX+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCA SCY+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCA SCZ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCB SCA+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCB SCB = Proved Refl+      (%~) SCB SCC+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCB SCD+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCB SCE+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCB SCF+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCB SCG+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCB SCH+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCB SCI+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCB SCJ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCB SCK+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCB SCL+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCB SCM+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCB SCN+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCB SCO+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCB SCP+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCB SCQ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCB SCR+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCB SCS+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCB SCT+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCB SCU+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCB SCV+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCB SCW+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCB SCX+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCB SCY+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCB SCZ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCC SCA+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCC SCB+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCC SCC = Proved Refl+      (%~) SCC SCD+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCC SCE+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCC SCF+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCC SCG+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCC SCH+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCC SCI+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCC SCJ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCC SCK+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCC SCL+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCC SCM+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCC SCN+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCC SCO+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCC SCP+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCC SCQ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCC SCR+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCC SCS+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCC SCT+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCC SCU+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCC SCV+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCC SCW+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCC SCX+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCC SCY+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCC SCZ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCD SCA+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCD SCB+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCD SCC+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCD SCD = Proved Refl+      (%~) SCD SCE+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCD SCF+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCD SCG+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCD SCH+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCD SCI+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCD SCJ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCD SCK+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCD SCL+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCD SCM+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCD SCN+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCD SCO+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCD SCP+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCD SCQ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCD SCR+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCD SCS+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCD SCT+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCD SCU+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCD SCV+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCD SCW+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCD SCX+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCD SCY+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCD SCZ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCE SCA+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCE SCB+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCE SCC+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCE SCD+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCE SCE = Proved Refl+      (%~) SCE SCF+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCE SCG+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCE SCH+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCE SCI+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCE SCJ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCE SCK+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCE SCL+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCE SCM+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCE SCN+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCE SCO+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCE SCP+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCE SCQ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCE SCR+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCE SCS+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCE SCT+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCE SCU+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCE SCV+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCE SCW+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCE SCX+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCE SCY+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCE SCZ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCF SCA+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCF SCB+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCF SCC+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCF SCD+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCF SCE+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCF SCF = Proved Refl+      (%~) SCF SCG+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCF SCH+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCF SCI+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCF SCJ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCF SCK+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCF SCL+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCF SCM+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCF SCN+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCF SCO+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCF SCP+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCF SCQ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCF SCR+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCF SCS+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCF SCT+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCF SCU+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCF SCV+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCF SCW+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCF SCX+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCF SCY+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCF SCZ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCG SCA+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCG SCB+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCG SCC+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCG SCD+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCG SCE+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCG SCF+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCG SCG = Proved Refl+      (%~) SCG SCH+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCG SCI+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCG SCJ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCG SCK+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCG SCL+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCG SCM+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCG SCN+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCG SCO+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCG SCP+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCG SCQ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCG SCR+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCG SCS+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCG SCT+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCG SCU+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCG SCV+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCG SCW+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCG SCX+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCG SCY+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCG SCZ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCH SCA+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCH SCB+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCH SCC+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCH SCD+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCH SCE+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCH SCF+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCH SCG+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCH SCH = Proved Refl+      (%~) SCH SCI+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCH SCJ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCH SCK+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCH SCL+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCH SCM+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCH SCN+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCH SCO+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCH SCP+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCH SCQ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCH SCR+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCH SCS+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCH SCT+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCH SCU+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCH SCV+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCH SCW+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCH SCX+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCH SCY+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCH SCZ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCI SCA+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCI SCB+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCI SCC+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCI SCD+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCI SCE+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCI SCF+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCI SCG+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCI SCH+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCI SCI = Proved Refl+      (%~) SCI SCJ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCI SCK+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCI SCL+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCI SCM+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCI SCN+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCI SCO+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCI SCP+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCI SCQ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCI SCR+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCI SCS+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCI SCT+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCI SCU+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCI SCV+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCI SCW+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCI SCX+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCI SCY+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCI SCZ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCJ SCA+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCJ SCB+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCJ SCC+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCJ SCD+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCJ SCE+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCJ SCF+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCJ SCG+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCJ SCH+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCJ SCI+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCJ SCJ = Proved Refl+      (%~) SCJ SCK+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCJ SCL+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCJ SCM+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCJ SCN+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCJ SCO+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCJ SCP+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCJ SCQ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCJ SCR+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCJ SCS+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCJ SCT+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCJ SCU+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCJ SCV+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCJ SCW+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCJ SCX+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCJ SCY+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCJ SCZ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCK SCA+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCK SCB+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCK SCC+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCK SCD+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCK SCE+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCK SCF+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCK SCG+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCK SCH+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCK SCI+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCK SCJ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCK SCK = Proved Refl+      (%~) SCK SCL+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCK SCM+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCK SCN+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCK SCO+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCK SCP+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCK SCQ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCK SCR+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCK SCS+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCK SCT+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCK SCU+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCK SCV+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCK SCW+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCK SCX+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCK SCY+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCK SCZ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCL SCA+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCL SCB+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCL SCC+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCL SCD+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCL SCE+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCL SCF+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCL SCG+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCL SCH+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCL SCI+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCL SCJ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCL SCK+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCL SCL = Proved Refl+      (%~) SCL SCM+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCL SCN+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCL SCO+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCL SCP+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCL SCQ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCL SCR+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCL SCS+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCL SCT+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCL SCU+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCL SCV+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCL SCW+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCL SCX+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCL SCY+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCL SCZ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCM SCA+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCM SCB+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCM SCC+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCM SCD+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCM SCE+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCM SCF+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCM SCG+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCM SCH+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCM SCI+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCM SCJ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCM SCK+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCM SCL+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCM SCM = Proved Refl+      (%~) SCM SCN+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCM SCO+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCM SCP+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCM SCQ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCM SCR+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCM SCS+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCM SCT+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCM SCU+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCM SCV+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCM SCW+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCM SCX+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCM SCY+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCM SCZ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCN SCA+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCN SCB+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCN SCC+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCN SCD+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCN SCE+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCN SCF+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCN SCG+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCN SCH+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCN SCI+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCN SCJ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCN SCK+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCN SCL+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCN SCM+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCN SCN = Proved Refl+      (%~) SCN SCO+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCN SCP+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCN SCQ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCN SCR+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCN SCS+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCN SCT+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCN SCU+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCN SCV+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCN SCW+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCN SCX+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCN SCY+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCN SCZ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCO SCA+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCO SCB+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCO SCC+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCO SCD+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCO SCE+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCO SCF+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCO SCG+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCO SCH+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCO SCI+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCO SCJ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCO SCK+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCO SCL+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCO SCM+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCO SCN+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCO SCO = Proved Refl+      (%~) SCO SCP+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCO SCQ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCO SCR+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCO SCS+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCO SCT+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCO SCU+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCO SCV+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCO SCW+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCO SCX+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCO SCY+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCO SCZ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCP SCA+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCP SCB+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCP SCC+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCP SCD+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCP SCE+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCP SCF+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCP SCG+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCP SCH+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCP SCI+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCP SCJ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCP SCK+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCP SCL+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCP SCM+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCP SCN+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCP SCO+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCP SCP = Proved Refl+      (%~) SCP SCQ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCP SCR+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCP SCS+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCP SCT+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCP SCU+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCP SCV+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCP SCW+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCP SCX+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCP SCY+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCP SCZ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCQ SCA+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCQ SCB+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCQ SCC+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCQ SCD+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCQ SCE+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCQ SCF+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCQ SCG+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCQ SCH+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCQ SCI+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCQ SCJ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCQ SCK+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCQ SCL+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCQ SCM+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCQ SCN+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCQ SCO+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCQ SCP+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCQ SCQ = Proved Refl+      (%~) SCQ SCR+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCQ SCS+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCQ SCT+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCQ SCU+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCQ SCV+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCQ SCW+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCQ SCX+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCQ SCY+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCQ SCZ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCR SCA+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCR SCB+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCR SCC+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCR SCD+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCR SCE+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCR SCF+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCR SCG+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCR SCH+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCR SCI+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCR SCJ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCR SCK+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCR SCL+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCR SCM+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCR SCN+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCR SCO+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCR SCP+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCR SCQ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCR SCR = Proved Refl+      (%~) SCR SCS+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCR SCT+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCR SCU+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCR SCV+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCR SCW+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCR SCX+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCR SCY+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCR SCZ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCS SCA+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCS SCB+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCS SCC+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCS SCD+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCS SCE+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCS SCF+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCS SCG+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCS SCH+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCS SCI+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCS SCJ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCS SCK+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCS SCL+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCS SCM+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCS SCN+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCS SCO+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCS SCP+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCS SCQ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCS SCR+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCS SCS = Proved Refl+      (%~) SCS SCT+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCS SCU+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCS SCV+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCS SCW+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCS SCX+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCS SCY+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCS SCZ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCT SCA+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCT SCB+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCT SCC+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCT SCD+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCT SCE+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCT SCF+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCT SCG+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCT SCH+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCT SCI+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCT SCJ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCT SCK+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCT SCL+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCT SCM+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCT SCN+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCT SCO+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCT SCP+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCT SCQ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCT SCR+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCT SCS+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCT SCT = Proved Refl+      (%~) SCT SCU+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCT SCV+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCT SCW+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCT SCX+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCT SCY+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCT SCZ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCU SCA+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCU SCB+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCU SCC+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCU SCD+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCU SCE+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCU SCF+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCU SCG+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCU SCH+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCU SCI+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCU SCJ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCU SCK+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCU SCL+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCU SCM+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCU SCN+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCU SCO+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCU SCP+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCU SCQ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCU SCR+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCU SCS+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCU SCT+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCU SCU = Proved Refl+      (%~) SCU SCV+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCU SCW+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCU SCX+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCU SCY+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCU SCZ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCV SCA+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCV SCB+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCV SCC+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCV SCD+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCV SCE+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCV SCF+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCV SCG+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCV SCH+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCV SCI+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCV SCJ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCV SCK+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCV SCL+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCV SCM+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCV SCN+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCV SCO+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCV SCP+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCV SCQ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCV SCR+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCV SCS+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCV SCT+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCV SCU+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCV SCV = Proved Refl+      (%~) SCV SCW+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCV SCX+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCV SCY+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCV SCZ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCW SCA+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCW SCB+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCW SCC+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCW SCD+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCW SCE+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCW SCF+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCW SCG+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCW SCH+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCW SCI+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCW SCJ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCW SCK+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCW SCL+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCW SCM+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCW SCN+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCW SCO+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCW SCP+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCW SCQ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCW SCR+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCW SCS+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCW SCT+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCW SCU+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCW SCV+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCW SCW = Proved Refl+      (%~) SCW SCX+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCW SCY+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCW SCZ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCX SCA+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCX SCB+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCX SCC+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCX SCD+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCX SCE+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCX SCF+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCX SCG+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCX SCH+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCX SCI+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCX SCJ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCX SCK+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCX SCL+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCX SCM+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCX SCN+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCX SCO+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCX SCP+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCX SCQ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCX SCR+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCX SCS+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCX SCT+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCX SCU+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCX SCV+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCX SCW+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCX SCX = Proved Refl+      (%~) SCX SCY+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCX SCZ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCY SCA+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCY SCB+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCY SCC+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCY SCD+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCY SCE+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCY SCF+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCY SCG+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCY SCH+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCY SCI+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCY SCJ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCY SCK+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCY SCL+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCY SCM+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCY SCN+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCY SCO+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCY SCP+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCY SCQ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCY SCR+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCY SCS+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCY SCT+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCY SCU+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCY SCV+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCY SCW+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCY SCX+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCY SCY = Proved Refl+      (%~) SCY SCZ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCZ SCA+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCZ SCB+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCZ SCC+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCZ SCD+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCZ SCE+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCZ SCF+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCZ SCG+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCZ SCH+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCZ SCI+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCZ SCJ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCZ SCK+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCZ SCL+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCZ SCM+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCZ SCN+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCZ SCO+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCZ SCP+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCZ SCQ+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCZ SCR+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCZ SCS+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCZ SCT+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCZ SCU+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCZ SCV+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCZ SCW+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCZ SCX+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCZ SCY+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) SCZ SCZ = Proved Refl+    data instance Sing (z :: Attribute)+      = forall (n :: GHC.Types.[] AChar)+               (n :: U). (GHC.Types.~) 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+              GHC.Tuple.(,)+                (toSing b :: SomeSing (KProxy :: KProxy (GHC.Types.[] AChar)))+                (toSing b :: SomeSing (KProxy :: KProxy U))+          of {+            GHC.Tuple.(,) (SomeSing c) (SomeSing c) -> SomeSing (SAttr c c) }+    data instance Sing (z :: Schema)+      = forall (n :: GHC.Types.[] Attribute). (GHC.Types.~) 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 (GHC.Types.[] Attribute))+          of {+            SomeSing c -> SomeSing (SSch c) }+    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+    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+    instance (SingI n, SingI n) =>+             SingI (Attr (n :: GHC.Types.[] AChar) (n :: U)) where+      sing = SAttr sing sing+    instance SingI n => SingI (Sch (n :: GHC.Types.[] Attribute)) where+      sing = SSch sing+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 view
@@ -22,8 +22,9 @@ module GradingClient.Database where  import Prelude hiding ( tail, id )-import Data.Singletons.TH import Data.Singletons.Prelude+import Data.Singletons.SuppressUnusedWarnings+import Data.Singletons.TH import Control.Monad import Data.List hiding ( tail ) import Control.Monad.Error
tests/compile-and-dump/GradingClient/Main.ghc76.template view
@@ -32,18 +32,27 @@            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 LastName = '[CLSym0, CASym0, CSSym0, CTSym0]+    type LastNameSym0 = LastName+    type FirstName = '[CFSym0, CISym0, CRSym0, CSSym0, CTSym0]+    type FirstNameSym0 = FirstName+    type YearName = '[CYSym0, CESym0, CASym0, CRSym0]+    type YearNameSym0 = YearName+    type GradeName = '[CGSym0, CRSym0, CASym0, CDSym0, CESym0]+    type GradeNameSym0 = GradeName+    type MajorName = '[CMSym0, CASym0, CJSym0, COSym0, CRSym0]+    type MajorNameSym0 = MajorName     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]+        Apply SchSym0 '[Apply (Apply AttrSym0 LastNameSym0) STRINGSym0,+                        Apply (Apply AttrSym0 FirstNameSym0) STRINGSym0,+                        Apply (Apply AttrSym0 YearNameSym0) NATSym0,+                        Apply (Apply AttrSym0 GradeNameSym0) NATSym0,+                        Apply (Apply AttrSym0 MajorNameSym0) BOOLSym0]+    type GradingSchemaSym0 = GradingSchema+    type Names =+        Apply SchSym0 '[Apply (Apply AttrSym0 FirstNameSym0) STRINGSym0,+                        Apply (Apply AttrSym0 LastNameSym0) STRINGSym0]+    type NamesSym0 = Names     sLastName :: Sing LastName     sMajorName :: Sing MajorName     sGradeName :: Sing GradeName
tests/compile-and-dump/GradingClient/Main.ghc78.template view
@@ -32,44 +32,132 @@            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 MajorNameSym0 = MajorName+    type GradeNameSym0 = GradeName+    type YearNameSym0 = YearName+    type FirstNameSym0 = FirstName+    type LastNameSym0 = LastName+    type GradingSchemaSym0 = GradingSchema+    type NamesSym0 = Names+    type MajorName =+        (Apply (Apply (:$) CMSym0) (Apply (Apply (:$) CASym0) (Apply (Apply (:$) CJSym0) (Apply (Apply (:$) COSym0) (Apply (Apply (:$) CRSym0) GHC.Types.[])))) :: GHC.Types.[] AChar)+    type GradeName =+        (Apply (Apply (:$) CGSym0) (Apply (Apply (:$) CRSym0) (Apply (Apply (:$) CASym0) (Apply (Apply (:$) CDSym0) (Apply (Apply (:$) CESym0) GHC.Types.[])))) :: GHC.Types.[] AChar)+    type YearName =+        (Apply (Apply (:$) CYSym0) (Apply (Apply (:$) CESym0) (Apply (Apply (:$) CASym0) (Apply (Apply (:$) CRSym0) GHC.Types.[]))) :: GHC.Types.[] AChar)+    type FirstName =+        (Apply (Apply (:$) CFSym0) (Apply (Apply (:$) CISym0) (Apply (Apply (:$) CRSym0) (Apply (Apply (:$) CSSym0) (Apply (Apply (:$) CTSym0) GHC.Types.[])))) :: GHC.Types.[] AChar)+    type LastName =+        (Apply (Apply (:$) CLSym0) (Apply (Apply (:$) CASym0) (Apply (Apply (:$) CSSym0) (Apply (Apply (:$) CTSym0) GHC.Types.[]))) :: GHC.Types.[] AChar)     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))))+        (Apply SchSym0 (Apply (Apply (:$) (Apply (Apply AttrSym0 LastNameSym0) STRINGSym0)) (Apply (Apply (:$) (Apply (Apply AttrSym0 FirstNameSym0) STRINGSym0)) (Apply (Apply (:$) (Apply (Apply AttrSym0 YearNameSym0) NATSym0)) (Apply (Apply (:$) (Apply (Apply AttrSym0 GradeNameSym0) NATSym0)) (Apply (Apply (:$) (Apply (Apply AttrSym0 MajorNameSym0) BOOLSym0)) GHC.Types.[]))))) :: Schema)+    type Names =+        (Apply SchSym0 (Apply (Apply (:$) (Apply (Apply AttrSym0 FirstNameSym0) STRINGSym0)) (Apply (Apply (:$) (Apply (Apply AttrSym0 LastNameSym0) STRINGSym0)) GHC.Types.[])) :: Schema)+    sMajorName :: Sing MajorNameSym0+    sGradeName :: Sing GradeNameSym0+    sYearName :: Sing YearNameSym0+    sFirstName :: Sing FirstNameSym0+    sLastName :: Sing LastNameSym0+    sGradingSchema :: Sing GradingSchemaSym0+    sNames :: Sing NamesSym0     sMajorName-      = SCons SCM (SCons SCA (SCons SCJ (SCons SCO (SCons SCR SNil))))-    sGradingSchema :: Sing GradingSchema+      = applySing+          (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) SCM)+          (applySing+             (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) SCA)+             (applySing+                (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) SCJ)+                (applySing+                   (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) SCO)+                   (applySing+                      (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) SCR) SNil))))+    sGradeName+      = applySing+          (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) SCG)+          (applySing+             (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) SCR)+             (applySing+                (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) SCA)+                (applySing+                   (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) SCD)+                   (applySing+                      (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) SCE) SNil))))+    sYearName+      = applySing+          (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) SCY)+          (applySing+             (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) SCE)+             (applySing+                (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) SCA)+                (applySing+                   (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) SCR) SNil)))+    sFirstName+      = applySing+          (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) SCF)+          (applySing+             (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) SCI)+             (applySing+                (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) SCR)+                (applySing+                   (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) SCS)+                   (applySing+                      (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) SCT) SNil))))+    sLastName+      = applySing+          (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) SCL)+          (applySing+             (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) SCA)+             (applySing+                (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) SCS)+                (applySing+                   (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) SCT) SNil)))     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+      = applySing+          (singFun1 (Proxy :: Proxy SchSym0) SSch)+          (applySing+             (applySing+                (singFun2 (Proxy :: Proxy (:$)) SCons)+                (applySing+                   (applySing (singFun2 (Proxy :: Proxy AttrSym0) SAttr) sLastName)+                   SSTRING))+             (applySing+                (applySing+                   (singFun2 (Proxy :: Proxy (:$)) SCons)+                   (applySing+                      (applySing (singFun2 (Proxy :: Proxy AttrSym0) SAttr) sFirstName)+                      SSTRING))+                (applySing+                   (applySing+                      (singFun2 (Proxy :: Proxy (:$)) SCons)+                      (applySing+                         (applySing (singFun2 (Proxy :: Proxy AttrSym0) SAttr) sYearName)+                         SNAT))+                   (applySing+                      (applySing+                         (singFun2 (Proxy :: Proxy (:$)) SCons)+                         (applySing+                            (applySing (singFun2 (Proxy :: Proxy AttrSym0) SAttr) sGradeName)+                            SNAT))+                      (applySing+                         (applySing+                            (singFun2 (Proxy :: Proxy (:$)) SCons)+                            (applySing+                               (applySing (singFun2 (Proxy :: Proxy AttrSym0) SAttr) sMajorName)+                               SBOOL))+                         SNil)))))     sNames-      = SSch-          (SCons-             (SAttr sFirstName SSTRING) (SCons (SAttr sLastName SSTRING) SNil))+      = applySing+          (singFun1 (Proxy :: Proxy SchSym0) SSch)+          (applySing+             (applySing+                (singFun2 (Proxy :: Proxy (:$)) SCons)+                (applySing+                   (applySing (singFun2 (Proxy :: Proxy AttrSym0) SAttr) sFirstName)+                   SSTRING))+             (applySing+                (applySing+                   (singFun2 (Proxy :: Proxy (:$)) SCons)+                   (applySing+                      (applySing (singFun2 (Proxy :: Proxy AttrSym0) SAttr) sLastName)+                      SSTRING))+                SNil))
tests/compile-and-dump/GradingClient/Main.hs view
@@ -12,8 +12,9 @@  module Main where +import Data.Singletons import Data.Singletons.TH-import Data.Singletons.List+import Data.Singletons.Prelude.List import GradingClient.Database  $(singletons [d|
tests/compile-and-dump/InsertionSort/InsertionSortImp.ghc76.template view
@@ -3,6 +3,11 @@   ======>     InsertionSort/InsertionSortImp.hs:(0,0)-(0,0)     data Nat = Zero | Succ Nat+    type NatTyCtor = Nat+    type NatTyCtorSym0 = NatTyCtor+    type ZeroSym0 = Zero+    data SuccSym0 (k :: TyFun Nat Nat)+    type instance Apply SuccSym0 a = Succ a     data instance Sing (z :: Nat)       = z ~ Zero => SZero |         forall (n :: Nat). z ~ Succ n => SSucc (Sing n)@@ -48,18 +53,28 @@     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 family Leq (a :: Nat) (a :: Nat) :: Bool+    type instance Leq Zero z = TrueSym0+    type instance Leq (Succ z) Zero = FalseSym0+    type instance Leq (Succ a) (Succ b) = Apply (Apply LeqSym0 a) b+    data LeqSym1 (l :: Nat) (l :: TyFun Nat Bool)+    data LeqSym0 (k :: TyFun Nat (TyFun Nat Bool -> *))+    type instance Apply (LeqSym1 a) a = Leq a a+    type instance Apply LeqSym0 a = LeqSym1 a+    type family Insert (a :: Nat) (a :: [Nat]) :: [Nat]     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))+        If (Apply (Apply LeqSym0 n) h) (Apply (Apply :$ n) (Apply (Apply :$ h) t)) (Apply (Apply :$ h) (Apply (Apply InsertSym0 n) t))+    data InsertSym1 (l :: Nat) (l :: TyFun [Nat] [Nat])+    data InsertSym0 (k :: TyFun Nat (TyFun [Nat] [Nat] -> *))+    type instance Apply (InsertSym1 a) a = Insert a a+    type instance Apply InsertSym0 a = InsertSym1 a+    type family InsertionSort (a :: [Nat]) :: [Nat]     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]+        Apply (Apply InsertSym0 h) (Apply InsertionSortSym0 t)+    data InsertionSortSym0 (k :: TyFun [Nat] [Nat])+    type instance Apply InsertionSortSym0 a = InsertionSort a     sLeq ::       forall (t :: Nat) (t :: Nat). Sing t -> Sing t -> Sing (Leq t t)     sLeq SZero _ = STrue
tests/compile-and-dump/InsertionSort/InsertionSortImp.ghc78.template view
@@ -3,9 +3,18 @@   ======>     InsertionSort/InsertionSortImp.hs:(0,0)-(0,0)     data Nat = Zero | Succ Nat+    type ZeroSym0 = Zero+    type SuccSym1 (t :: Nat) = Succ t+    instance SuppressUnusedWarnings SuccSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) SuccSym0KindInference GHC.Tuple.())+    data SuccSym0 (l :: TyFun Nat Nat)+      = forall arg. (GHC.Types.~) (KindOf (Apply SuccSym0 arg)) (KindOf (SuccSym1 arg)) =>+        SuccSym0KindInference+    type instance Apply SuccSym0 l = SuccSym1 l     data instance Sing (z :: Nat)-      = z ~ Zero => SZero |-        forall (n :: Nat). z ~ Succ n => SSucc (Sing n)+      = (GHC.Types.~) z Zero => SZero |+        forall (n :: Nat). (GHC.Types.~) z (Succ n) => SSucc (Sing n)     type SNat (z :: Nat) = Sing z     instance SingKind (KProxy :: KProxy Nat) where       type DemoteRep (KProxy :: KProxy Nat) = Nat@@ -48,28 +57,189 @@     insertionSort :: [Nat] -> [Nat]     insertionSort GHC.Types.[] = []     insertionSort (h GHC.Types.: t) = insert h (insertionSort t)+    type Let_0123456789Scrutinee_0123456789Sym3 t t t =+        Let_0123456789Scrutinee_0123456789 t t t+    instance SuppressUnusedWarnings Let_0123456789Scrutinee_0123456789Sym2 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,)+               Let_0123456789Scrutinee_0123456789Sym2KindInference GHC.Tuple.())+    data Let_0123456789Scrutinee_0123456789Sym2 l l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Let_0123456789Scrutinee_0123456789Sym2 l l) arg)) (KindOf (Let_0123456789Scrutinee_0123456789Sym3 l l arg)) =>+        Let_0123456789Scrutinee_0123456789Sym2KindInference+    type instance Apply (Let_0123456789Scrutinee_0123456789Sym2 l l) l = Let_0123456789Scrutinee_0123456789Sym3 l l l+    instance SuppressUnusedWarnings Let_0123456789Scrutinee_0123456789Sym1 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,)+               Let_0123456789Scrutinee_0123456789Sym1KindInference GHC.Tuple.())+    data Let_0123456789Scrutinee_0123456789Sym1 l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Let_0123456789Scrutinee_0123456789Sym1 l) arg)) (KindOf (Let_0123456789Scrutinee_0123456789Sym2 l arg)) =>+        Let_0123456789Scrutinee_0123456789Sym1KindInference+    type instance Apply (Let_0123456789Scrutinee_0123456789Sym1 l) l = Let_0123456789Scrutinee_0123456789Sym2 l l+    instance SuppressUnusedWarnings Let_0123456789Scrutinee_0123456789Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,)+               Let_0123456789Scrutinee_0123456789Sym0KindInference GHC.Tuple.())+    data Let_0123456789Scrutinee_0123456789Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Let_0123456789Scrutinee_0123456789Sym0 arg)) (KindOf (Let_0123456789Scrutinee_0123456789Sym1 arg)) =>+        Let_0123456789Scrutinee_0123456789Sym0KindInference+    type instance Apply Let_0123456789Scrutinee_0123456789Sym0 l = Let_0123456789Scrutinee_0123456789Sym1 l+    type Let_0123456789Scrutinee_0123456789 n h t =+        Apply (Apply LeqSym0 n) h+    type family Case_0123456789 n h t t where+      Case_0123456789 n h t True = Apply (Apply (:$) n) (Apply (Apply (:$) h) t)+      Case_0123456789 n h t False = Apply (Apply (:$) h) (Apply (Apply InsertSym0 n) t)+    type LeqSym2 (t :: Nat) (t :: Nat) = Leq t t+    instance SuppressUnusedWarnings LeqSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) LeqSym1KindInference GHC.Tuple.())+    data LeqSym1 (l :: Nat) (l :: TyFun Nat Bool)+      = forall arg. (GHC.Types.~) (KindOf (Apply (LeqSym1 l) arg)) (KindOf (LeqSym2 l arg)) =>+        LeqSym1KindInference+    type instance Apply (LeqSym1 l) l = LeqSym2 l l+    instance SuppressUnusedWarnings LeqSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) LeqSym0KindInference GHC.Tuple.())+    data LeqSym0 (l :: TyFun Nat (TyFun Nat Bool -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply LeqSym0 arg)) (KindOf (LeqSym1 arg)) =>+        LeqSym0KindInference+    type instance Apply LeqSym0 l = LeqSym1 l+    type InsertSym2 (t :: Nat) (t :: GHC.Types.[] Nat) = Insert t t+    instance SuppressUnusedWarnings InsertSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) InsertSym1KindInference GHC.Tuple.())+    data InsertSym1 (l :: Nat)+                    (l :: TyFun (GHC.Types.[] Nat) (GHC.Types.[] Nat))+      = forall arg. (GHC.Types.~) (KindOf (Apply (InsertSym1 l) arg)) (KindOf (InsertSym2 l arg)) =>+        InsertSym1KindInference+    type instance Apply (InsertSym1 l) l = InsertSym2 l l+    instance SuppressUnusedWarnings InsertSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) InsertSym0KindInference GHC.Tuple.())+    data InsertSym0 (l :: TyFun Nat (TyFun (GHC.Types.[] Nat) (GHC.Types.[] Nat)+                                     -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply InsertSym0 arg)) (KindOf (InsertSym1 arg)) =>+        InsertSym0KindInference+    type instance Apply InsertSym0 l = InsertSym1 l+    type InsertionSortSym1 (t :: GHC.Types.[] Nat) = InsertionSort t+    instance SuppressUnusedWarnings InsertionSortSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) InsertionSortSym0KindInference GHC.Tuple.())+    data InsertionSortSym0 (l :: TyFun (GHC.Types.[] Nat) (GHC.Types.[] Nat))+      = forall arg. (GHC.Types.~) (KindOf (Apply InsertionSortSym0 arg)) (KindOf (InsertionSortSym1 arg)) =>+        InsertionSortSym0KindInference+    type instance Apply InsertionSortSym0 l = InsertionSortSym1 l     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)+      Leq Zero z = TrueSym0+      Leq (Succ z) Zero = FalseSym0+      Leq (Succ a) (Succ b) = Apply (Apply LeqSym0 a) b+    type family Insert (a :: Nat)+                       (a :: GHC.Types.[] Nat) :: GHC.Types.[] Nat where+      Insert n GHC.Types.[] = Apply (Apply (:$) n) GHC.Types.[]+      Insert n ((GHC.Types.:) h t) = Case_0123456789 n h t (Let_0123456789Scrutinee_0123456789Sym3 n h t)+    type family InsertionSort (a :: GHC.Types.[] Nat) :: GHC.Types.[] Nat where+      InsertionSort GHC.Types.[] = GHC.Types.[]+      InsertionSort ((GHC.Types.:) h t) = Apply (Apply InsertSym0 h) (Apply InsertionSortSym0 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+      forall (t :: Nat) (t :: Nat).+      Sing t -> Sing t -> Sing (Apply (Apply LeqSym0 t) t)     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))+      forall (t :: Nat) (t :: GHC.Types.[] Nat).+      Sing t -> Sing t -> Sing (Apply (Apply InsertSym0 t) t)     sInsertionSort ::-      forall (t :: [Nat]). Sing t -> Sing (InsertionSort t)-    sInsertionSort SNil = SNil-    sInsertionSort (SCons h t) = sInsert h (sInsertionSort t)+      forall (t :: GHC.Types.[] Nat).+      Sing t -> Sing (Apply InsertionSortSym0 t)+    sLeq SZero _+      = let+          lambda ::+            forall wild. ((GHC.Types.~) t ZeroSym0, (GHC.Types.~) t wild) =>+            Sing (Apply (Apply LeqSym0 ZeroSym0) wild)+          lambda = STrue+        in lambda+    sLeq (SSucc _) SZero+      = let+          lambda ::+            forall wild. ((GHC.Types.~) t (Apply SuccSym0 wild),+                          (GHC.Types.~) t ZeroSym0) =>+            Sing (Apply (Apply LeqSym0 (Apply SuccSym0 wild)) ZeroSym0)+          lambda = SFalse+        in lambda+    sLeq (SSucc sA) (SSucc sB)+      = let+          lambda ::+            forall a b. ((GHC.Types.~) t (Apply SuccSym0 a),+                         (GHC.Types.~) t (Apply SuccSym0 b)) =>+            Sing a+            -> Sing b+               -> Sing (Apply (Apply LeqSym0 (Apply SuccSym0 a)) (Apply SuccSym0 b))+          lambda a b+            = applySing+                (applySing (singFun2 (Proxy :: Proxy LeqSym0) sLeq) a) b+        in lambda sA sB+    sInsert sN SNil+      = let+          lambda ::+            forall n. ((GHC.Types.~) t n, (GHC.Types.~) t GHC.Types.[]) =>+            Sing n -> Sing (Apply (Apply InsertSym0 n) GHC.Types.[])+          lambda n+            = applySing+                (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) n) SNil+        in lambda sN+    sInsert sN (SCons sH sT)+      = let+          lambda ::+            forall n h t. ((GHC.Types.~) t n,+                           (GHC.Types.~) t (Apply (Apply (:$) h) t)) =>+            Sing n+            -> Sing h+               -> Sing t+                  -> Sing (Apply (Apply InsertSym0 n) (Apply (Apply (:$) h) t))+          lambda n h t+            = let+                sScrutinee_0123456789 ::+                  Sing (Let_0123456789Scrutinee_0123456789Sym3 n h t)+                sScrutinee_0123456789+                  = applySing+                      (applySing (singFun2 (Proxy :: Proxy LeqSym0) sLeq) n) h+              in+                case sScrutinee_0123456789 of {+                  STrue+                    -> let+                         lambda :: Sing (Case_0123456789 n h t TrueSym0)+                         lambda+                           = applySing+                               (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) n)+                               (applySing (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) h) t)+                       in lambda+                  SFalse+                    -> let+                         lambda :: Sing (Case_0123456789 n h t FalseSym0)+                         lambda+                           = applySing+                               (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) h)+                               (applySing+                                  (applySing (singFun2 (Proxy :: Proxy InsertSym0) sInsert) n) t)+                       in lambda }+        in lambda sN sH sT+    sInsertionSort SNil+      = let+          lambda ::+            (GHC.Types.~) t GHC.Types.[] =>+            Sing (Apply InsertionSortSym0 GHC.Types.[])+          lambda = SNil+        in lambda+    sInsertionSort (SCons sH sT)+      = let+          lambda ::+            forall h t. (GHC.Types.~) t (Apply (Apply (:$) h) t) =>+            Sing h+            -> Sing t+               -> Sing (Apply InsertionSortSym0 (Apply (Apply (:$) h) t))+          lambda h t+            = applySing+                (applySing (singFun2 (Proxy :: Proxy InsertSym0) sInsert) h)+                (applySing+                   (singFun1 (Proxy :: Proxy InsertionSortSym0) sInsertionSort) t)+        in lambda sH sT
tests/compile-and-dump/InsertionSort/InsertionSortImp.hs view
@@ -31,8 +31,9 @@  module InsertionSort.InsertionSortImp where -import Data.Singletons.TH import Data.Singletons.Prelude+import Data.Singletons.SuppressUnusedWarnings+import Data.Singletons.TH  -- We use the Dict data type from Edward Kmett's constraints package to be -- able to return dictionaries from functions
+ tests/compile-and-dump/Promote/BadBoundedDeriving.ghc78.template view
@@ -0,0 +1,5 @@++Promote/BadBoundedDeriving.hs:0:0:+    Can't derive promoted Bounded instance for Foo_0123456789 datatype.++Promote/BadBoundedDeriving.hs:0:0: Q monad failure
+ tests/compile-and-dump/Promote/BadBoundedDeriving.hs view
@@ -0,0 +1,8 @@+module Promote.BadBoundedDeriving where++import Data.Promotion.Prelude+import Data.Promotion.TH++$(promote [d|+  data Foo a = Foo | Bar a deriving (Bounded)+  |])
+ tests/compile-and-dump/Promote/BoundedDeriving.ghc78.template view
@@ -0,0 +1,80 @@+Promote/BoundedDeriving.hs:0:0: Splicing declarations+    promote+      [d| data Foo1+            = Foo1+            deriving (Bounded)+          data Foo2+            = A | B | C | D | E+            deriving (Bounded)+          data Foo3 a+            = Foo3 a+            deriving (Bounded)+          data Foo4 (a :: *) (b :: *)+            = Foo41 | Foo42+            deriving (Bounded)+          data Pair+            = Pair Bool Bool+            deriving (Bounded) |]+  ======>+    Promote/BoundedDeriving.hs:(0,0)-(0,0)+    data Foo1+      = Foo1+      deriving (Bounded)+    data Foo2+      = A | B | C | D | E+      deriving (Bounded)+    data Foo3 a+      = Foo3 a+      deriving (Bounded)+    data Foo4 (a :: *) (b :: *)+      = Foo41 | Foo42+      deriving (Bounded)+    data Pair+      = Pair Bool Bool+      deriving (Bounded)+    instance PBounded (KProxy :: KProxy Foo1) where+      type MinBound = Foo1+      type MaxBound = Foo1+    type Foo1Sym0 = Foo1+    instance PBounded (KProxy :: KProxy Foo2) where+      type MinBound = A+      type MaxBound = E+    type ASym0 = A+    type BSym0 = B+    type CSym0 = C+    type DSym0 = D+    type ESym0 = E+    instance PBounded (KProxy :: KProxy (Foo3 k)) where+      type MinBound = Foo3 MinBound+      type MaxBound = Foo3 MaxBound+    type Foo3Sym1 (t :: a) = Foo3 t+    instance SuppressUnusedWarnings Foo3Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo3Sym0KindInference GHC.Tuple.())+    data Foo3Sym0 (l :: TyFun a (Foo3 a))+      = forall arg. (GHC.Types.~) (Data.Singletons.KindOf (Apply Foo3Sym0 arg)) (Data.Singletons.KindOf (Foo3Sym1 arg)) =>+        Foo3Sym0KindInference+    type instance Apply Foo3Sym0 l = Foo3Sym1 l+    instance PBounded (KProxy :: KProxy (Foo4 k k)) where+      type MinBound = Foo41+      type MaxBound = Foo42+    type Foo41Sym0 = Foo41+    type Foo42Sym0 = Foo42+    instance PBounded (KProxy :: KProxy Pair) where+      type MinBound = Pair MinBound MinBound+      type MaxBound = Pair MaxBound MaxBound+    type PairSym2 (t :: Bool) (t :: Bool) = Pair t t+    instance SuppressUnusedWarnings PairSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) PairSym1KindInference GHC.Tuple.())+    data PairSym1 (l :: Bool) (l :: TyFun Bool Pair)+      = forall arg. (GHC.Types.~) (Data.Singletons.KindOf (Apply (PairSym1 l) arg)) (Data.Singletons.KindOf (PairSym2 l arg)) =>+        PairSym1KindInference+    type instance Apply (PairSym1 l) l = PairSym2 l l+    instance SuppressUnusedWarnings PairSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) PairSym0KindInference GHC.Tuple.())+    data PairSym0 (l :: TyFun Bool (TyFun Bool Pair -> *))+      = forall arg. (GHC.Types.~) (Data.Singletons.KindOf (Apply PairSym0 arg)) (Data.Singletons.KindOf (PairSym1 arg)) =>+        PairSym0KindInference+    type instance Apply PairSym0 l = PairSym1 l
+ tests/compile-and-dump/Promote/BoundedDeriving.hs view
@@ -0,0 +1,51 @@+module Promote.BoundedDeriving where++import Data.Promotion.Prelude+import Data.Promotion.TH++$(promote [d|+  data Foo1 = Foo1 deriving (Bounded)+  data Foo2 = A | B | C | D | E deriving (Bounded)+  data Foo3 a = Foo3 a deriving (Bounded)+  data Foo4 (a :: *) (b :: *) = Foo41 | Foo42 deriving Bounded++  data Pair = Pair Bool Bool+                  deriving Bounded++  |])++foo1a :: Proxy (MinBound :: Foo1)+foo1a = Proxy++foo1b :: Proxy 'Foo1+foo1b = foo1a++foo1c :: Proxy (MaxBound :: Foo1)+foo1c = Proxy++foo1d :: Proxy 'Foo1+foo1d = foo1c++foo2a :: Proxy (MinBound :: Foo2)+foo2a = Proxy++foo2b :: Proxy 'A+foo2b = foo2a++foo2c :: Proxy (MaxBound :: Foo2)+foo2c = Proxy++foo2d :: Proxy 'E+foo2d = foo2c++foo3a :: Proxy (MinBound :: Foo3 Bool)+foo3a = Proxy++foo3b :: Proxy ('Foo3 False)+foo3b = foo3a++foo3c :: Proxy (MaxBound :: Foo3 Bool)+foo3c = Proxy++foo3d :: Proxy ('Foo3 True)+foo3d = foo3c
+ tests/compile-and-dump/Promote/Classes.ghc76.template view
+ tests/compile-and-dump/Promote/Classes.ghc78.template view
@@ -0,0 +1,158 @@+Promote/Classes.hs:0:0: Splicing declarations+    promote+      [d| const :: a -> b -> a+          const x _ = x+          fooCompare :: Foo -> Foo -> Ordering+          fooCompare A A = EQ+          fooCompare A _ = LT+          fooCompare _ _ = GT+          +          class MyOrd a where+            mycompare :: a -> a -> Ordering+            (<=>) :: a -> a -> Ordering+            (<=>) = mycompare+          data Foo = A | B+          +          instance MyOrd Foo where+            mycompare = fooCompare+          instance MyOrd () where+            mycompare _ = const EQ+          instance MyOrd Nat where+            Zero `mycompare` Zero = EQ+            Zero `mycompare` (Succ _) = LT+            (Succ _) `mycompare` Zero = GT+            (Succ n) `mycompare` (Succ m) = m `mycompare` n |]+  ======>+    Promote/Classes.hs:(0,0)-(0,0)+    const :: forall a b. a -> b -> a+    const x _ = x+    class MyOrd a where+      mycompare :: a -> a -> Ordering+      (<=>) :: a -> a -> Ordering+      (<=>) = mycompare+    instance MyOrd Nat where+      mycompare Zero Zero = EQ+      mycompare Zero (Succ _) = LT+      mycompare (Succ _) Zero = GT+      mycompare (Succ n) (Succ m) = (m `mycompare` n)+    instance MyOrd () where+      mycompare _ = const EQ+    data Foo = A | B+    fooCompare :: Foo -> Foo -> Ordering+    fooCompare A A = EQ+    fooCompare A _ = LT+    fooCompare _ _ = GT+    instance MyOrd Foo where+      mycompare = fooCompare+    type FooCompareSym2 (t :: Foo) (t :: Foo) = FooCompare t t+    instance SuppressUnusedWarnings FooCompareSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) FooCompareSym1KindInference GHC.Tuple.())+    data FooCompareSym1 (l :: Foo) (l :: TyFun Foo Ordering)+      = forall arg. (GHC.Types.~) (KindOf (Apply (FooCompareSym1 l) arg)) (KindOf (FooCompareSym2 l arg)) =>+        FooCompareSym1KindInference+    type instance Apply (FooCompareSym1 l) l = FooCompareSym2 l l+    instance SuppressUnusedWarnings FooCompareSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) FooCompareSym0KindInference GHC.Tuple.())+    data FooCompareSym0 (l :: TyFun Foo (TyFun Foo Ordering -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply FooCompareSym0 arg)) (KindOf (FooCompareSym1 arg)) =>+        FooCompareSym0KindInference+    type instance Apply FooCompareSym0 l = FooCompareSym1 l+    type ConstSym2 (t :: a) (t :: b) = Const t t+    instance SuppressUnusedWarnings ConstSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) ConstSym1KindInference GHC.Tuple.())+    data ConstSym1 (l :: a) (l :: TyFun b a)+      = forall arg. (GHC.Types.~) (KindOf (Apply (ConstSym1 l) arg)) (KindOf (ConstSym2 l arg)) =>+        ConstSym1KindInference+    type instance Apply (ConstSym1 l) l = ConstSym2 l l+    instance SuppressUnusedWarnings ConstSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) ConstSym0KindInference GHC.Tuple.())+    data ConstSym0 (l :: TyFun a (TyFun b a -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply ConstSym0 arg)) (KindOf (ConstSym1 arg)) =>+        ConstSym0KindInference+    type instance Apply ConstSym0 l = ConstSym1 l+    type family FooCompare (a :: Foo) (a :: Foo) :: Ordering where+      FooCompare A A = EQSym0+      FooCompare A z = LTSym0+      FooCompare z z = GTSym0+    type family Const (a :: a) (a :: b) :: a where+      Const x z = x+    type MycompareSym2 (t :: a) (t :: a) = Mycompare t t+    instance SuppressUnusedWarnings MycompareSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) MycompareSym1KindInference GHC.Tuple.())+    data MycompareSym1 (l :: a) (l :: TyFun a Ordering)+      = forall arg. (GHC.Types.~) (KindOf (Apply (MycompareSym1 l) arg)) (KindOf (MycompareSym2 l arg)) =>+        MycompareSym1KindInference+    type instance Apply (MycompareSym1 l) l = MycompareSym2 l l+    instance SuppressUnusedWarnings MycompareSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) MycompareSym0KindInference GHC.Tuple.())+    data MycompareSym0 (l :: TyFun a (TyFun a Ordering -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply MycompareSym0 arg)) (KindOf (MycompareSym1 arg)) =>+        MycompareSym0KindInference+    type instance Apply MycompareSym0 l = MycompareSym1 l+    type (:<=>$$$) (t :: a) (t :: a) = (:<=>) t t+    instance SuppressUnusedWarnings (:<=>$$) where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) (:<=>$$###) GHC.Tuple.())+    data (:<=>$$) (l :: a) (l :: TyFun a Ordering)+      = forall arg. (GHC.Types.~) (KindOf (Apply ((:<=>$$) l) arg)) (KindOf ((:<=>$$$) l arg)) =>+        (:<=>$$###)+    type instance Apply ((:<=>$$) l) l = (:<=>$$$) l l+    instance SuppressUnusedWarnings (:<=>$) where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) (:<=>$###) GHC.Tuple.())+    data (:<=>$) (l :: TyFun a (TyFun a Ordering -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply (:<=>$) arg)) (KindOf ((:<=>$$) arg)) =>+        (:<=>$###)+    type instance Apply (:<=>$) l = (:<=>$$) l+    class (GHC.Types.~) kproxy KProxy => PMyOrd (kproxy :: KProxy a) where+      type family Mycompare (arg :: a) (arg :: a) :: Ordering+      type family (:<=>) (arg :: a) (arg :: a) :: Ordering+      type instance (:<=>) (a_0123456789 :: a) (a_0123456789 :: a) = (Apply (Apply MycompareSym0 a_0123456789) a_0123456789 :: Ordering)+    instance PMyOrd (KProxy :: KProxy Nat) where+      type Mycompare (Zero :: Nat) (Zero :: Nat) = (EQSym0 :: Ordering)+      type Mycompare (Zero :: Nat) (Succ z :: Nat) = (LTSym0 :: Ordering)+      type Mycompare (Succ z :: Nat) (Zero :: Nat) = (GTSym0 :: Ordering)+      type Mycompare (Succ n :: Nat) (Succ m :: Nat) = (Apply (Apply MycompareSym0 m) n :: Ordering)+    instance PMyOrd (KProxy :: KProxy GHC.Tuple.()) where+      type Mycompare (z :: GHC.Tuple.()) (a_0123456789 :: GHC.Tuple.()) = (Apply (Apply ConstSym0 EQSym0) a_0123456789 :: Ordering)+    instance PMyOrd (KProxy :: KProxy Foo) where+      type Mycompare (a_0123456789 :: Foo) (a_0123456789 :: Foo) = (Apply (Apply FooCompareSym0 a_0123456789) a_0123456789 :: Ordering)+    type ASym0 = A+    type BSym0 = B+Promote/Classes.hs:0:0: Splicing declarations+    promote+      [d| data Nat' = Zero' | Succ' Nat'+          +          instance MyOrd Nat' where+            Zero' `mycompare` Zero' = EQ+            Zero' `mycompare` (Succ' _) = LT+            (Succ' _) `mycompare` Zero' = GT+            (Succ' n) `mycompare` (Succ' m) = m `mycompare` n |]+  ======>+    Promote/Classes.hs:(0,0)-(0,0)+    data Nat' = Zero' | Succ' Nat'+    instance MyOrd Nat' where+      mycompare Zero' Zero' = EQ+      mycompare Zero' (Succ' _) = LT+      mycompare (Succ' _) Zero' = GT+      mycompare (Succ' n) (Succ' m) = (m `mycompare` n)+    instance PMyOrd (KProxy :: KProxy Nat') where+      type Mycompare (Zero' :: Nat') (Zero' :: Nat') = (EQSym0 :: Ordering)+      type Mycompare (Zero' :: Nat') (Succ' z :: Nat') = (LTSym0 :: Ordering)+      type Mycompare (Succ' z :: Nat') (Zero' :: Nat') = (GTSym0 :: Ordering)+      type Mycompare (Succ' n :: Nat') (Succ' m :: Nat') = (Apply (Apply MycompareSym0 m) n :: Ordering)+    type Zero'Sym0 = Zero'+    type Succ'Sym1 (t :: Nat') = Succ' t+    instance SuppressUnusedWarnings Succ'Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Succ'Sym0KindInference GHC.Tuple.())+    data Succ'Sym0 (l :: TyFun Nat' Nat')+      = forall arg. (GHC.Types.~) (KindOf (Apply Succ'Sym0 arg)) (KindOf (Succ'Sym1 arg)) =>+        Succ'Sym0KindInference+    type instance Apply Succ'Sym0 l = Succ'Sym1 l
+ tests/compile-and-dump/Promote/Classes.hs view
@@ -0,0 +1,73 @@+module Promote.Classes where++import Prelude hiding (Ord(..), const)+import Singletons.Nat+import Data.Singletons+import Data.Singletons.TH+import Data.Singletons.Prelude.Ord (EQSym0, LTSym0, GTSym0)++$(promote [d|+  const :: a -> b -> a+  const x _ = x++  class MyOrd a where+    mycompare :: a -> a -> Ordering+    (<=>) :: a -> a -> Ordering+    (<=>) = mycompare+--    infix 4 <=>  infix decls don't work due to #65++  instance MyOrd Nat where+    Zero `mycompare` Zero = EQ+    Zero `mycompare` (Succ _) = LT+    (Succ _) `mycompare` Zero = GT+    (Succ n) `mycompare` (Succ m) = m `mycompare` n++    -- test eta-expansion+  instance MyOrd () where+    mycompare _ = const EQ++  data Foo = A | B++  fooCompare :: Foo -> Foo -> Ordering+  fooCompare A A = EQ+  fooCompare A _ = LT+  fooCompare _ _ = GT++  instance MyOrd Foo where+    -- test that values in instance definitions are eta-expanded+    mycompare = fooCompare+ |])++-- check promotion across different splices (#55)+$(promote [d|+  data Nat' = Zero' | Succ' Nat'+  instance MyOrd Nat' where+    Zero' `mycompare` Zero' = EQ+    Zero' `mycompare` (Succ' _) = LT+    (Succ' _) `mycompare` Zero' = GT+    (Succ' n) `mycompare` (Succ' m) = m `mycompare` n+ |])++foo1a :: Proxy (Zero `Mycompare` (Succ Zero))+foo1a = Proxy++foo1b :: Proxy LT+foo1b = foo1a++foo2a :: Proxy (A `Mycompare` A)+foo2a = Proxy++foo2b :: Proxy EQ+foo2b = foo2a++foo3a :: Proxy ('() `Mycompare` '())+foo3a = Proxy++foo3b :: Proxy EQ+foo3b = foo3a++foo4a :: Proxy (Succ' Zero' :<=> Zero')+foo4a = Proxy++foo4b :: Proxy GT+foo4b = foo4a
+ tests/compile-and-dump/Promote/Constructors.ghc76.template view
@@ -0,0 +1,42 @@+Promote/Constructors.hs:0:0: Splicing declarations+    promote+      [d| data Foo = Foo | Foo :+ Foo+          data Bar = Bar Bar Bar Bar Bar Foo |]+  ======>+    Promote/Constructors.hs:(0,0)-(0,0)+    data Foo = Foo | Foo :+ Foo+    data Bar = Bar Bar Bar Bar Bar Foo+    type FooTyCtor = Foo+    type FooTyCtorSym0 = FooTyCtor+    type FooSym0 = Foo+    data (:+$$) (l :: Foo) (l :: TyFun Foo Foo)+    data (:+$) (k :: TyFun Foo (TyFun Foo Foo -> *))+    type instance Apply (:+$$ a) a = :+ a a+    type instance Apply :+$ a = :+$$ a+    type BarTyCtor = Bar+    type BarTyCtorSym0 = BarTyCtor+    data BarSym4 (l :: Bar)+                 (l :: Bar)+                 (l :: Bar)+                 (l :: Bar)+                 (l :: TyFun Foo Bar)+    data BarSym3 (l :: Bar)+                 (l :: Bar)+                 (l :: Bar)+                 (l :: TyFun Bar (TyFun Foo Bar -> *))+    data BarSym2 (l :: Bar)+                 (l :: Bar)+                 (l :: TyFun Bar (TyFun Bar (TyFun Foo Bar -> *) -> *))+    data BarSym1 (l :: Bar)+                 (l :: TyFun Bar (TyFun Bar (TyFun Bar (TyFun Foo Bar -> *) -> *)+                                  -> *))+    data BarSym0 (k :: TyFun Bar (TyFun Bar (TyFun Bar (TyFun Bar (TyFun Foo Bar+                                                                   -> *)+                                                        -> *)+                                             -> *)+                                  -> *))+    type instance Apply (BarSym4 a a a a) a = Bar a a a a a+    type instance Apply (BarSym3 a a a) a = BarSym4 a a a a+    type instance Apply (BarSym2 a a) a = BarSym3 a a a+    type instance Apply (BarSym1 a) a = BarSym2 a a+    type instance Apply BarSym0 a = BarSym1 a
+ tests/compile-and-dump/Promote/Constructors.ghc78.template view
@@ -0,0 +1,80 @@+Promote/Constructors.hs:0:0: Splicing declarations+    promote+      [d| data Foo = Foo | Foo :+ Foo+          data Bar = Bar Bar Bar Bar Bar Foo |]+  ======>+    Promote/Constructors.hs:(0,0)-(0,0)+    data Foo = Foo | Foo :+ Foo+    data Bar = Bar Bar Bar Bar Bar Foo+    type FooSym0 = Foo+    type (:+$$$) (t :: Foo) (t :: Foo) = (:+) t t+    instance SuppressUnusedWarnings (:+$$) where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) (:+$$###) GHC.Tuple.())+    data (:+$$) (l :: Foo) (l :: TyFun Foo Foo)+      = forall arg. (GHC.Types.~) (KindOf (Apply ((:+$$) l) arg)) (KindOf ((:+$$$) l arg)) =>+        (:+$$###)+    type instance Apply ((:+$$) l) l = (:+$$$) l l+    instance SuppressUnusedWarnings (:+$) where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) (:+$###) GHC.Tuple.())+    data (:+$) (l :: TyFun Foo (TyFun Foo Foo -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply (:+$) arg)) (KindOf ((:+$$) arg)) =>+        (:+$###)+    type instance Apply (:+$) l = (:+$$) l+    type BarSym5 (t :: Bar)+                 (t :: Bar)+                 (t :: Bar)+                 (t :: Bar)+                 (t :: Foo) =+        Bar t t t t t+    instance SuppressUnusedWarnings BarSym4 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) BarSym4KindInference GHC.Tuple.())+    data BarSym4 (l :: Bar)+                 (l :: Bar)+                 (l :: Bar)+                 (l :: Bar)+                 (l :: TyFun Foo Bar)+      = forall arg. (GHC.Types.~) (KindOf (Apply (BarSym4 l l l l) arg)) (KindOf (BarSym5 l l l l arg)) =>+        BarSym4KindInference+    type instance Apply (BarSym4 l l l l) l = BarSym5 l l l l l+    instance SuppressUnusedWarnings BarSym3 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) BarSym3KindInference GHC.Tuple.())+    data BarSym3 (l :: Bar)+                 (l :: Bar)+                 (l :: Bar)+                 (l :: TyFun Bar (TyFun Foo Bar -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply (BarSym3 l l l) arg)) (KindOf (BarSym4 l l l arg)) =>+        BarSym3KindInference+    type instance Apply (BarSym3 l l l) l = BarSym4 l l l l+    instance SuppressUnusedWarnings BarSym2 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) BarSym2KindInference GHC.Tuple.())+    data BarSym2 (l :: Bar)+                 (l :: Bar)+                 (l :: TyFun Bar (TyFun Bar (TyFun Foo Bar -> *) -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply (BarSym2 l l) arg)) (KindOf (BarSym3 l l arg)) =>+        BarSym2KindInference+    type instance Apply (BarSym2 l l) l = BarSym3 l l l+    instance SuppressUnusedWarnings BarSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) BarSym1KindInference GHC.Tuple.())+    data BarSym1 (l :: Bar)+                 (l :: TyFun Bar (TyFun Bar (TyFun Bar (TyFun Foo Bar -> *) -> *)+                                  -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply (BarSym1 l) arg)) (KindOf (BarSym2 l arg)) =>+        BarSym1KindInference+    type instance Apply (BarSym1 l) l = BarSym2 l l+    instance SuppressUnusedWarnings BarSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) BarSym0KindInference GHC.Tuple.())+    data BarSym0 (l :: TyFun Bar (TyFun Bar (TyFun Bar (TyFun Bar (TyFun Foo Bar+                                                                   -> *)+                                                        -> *)+                                             -> *)+                                  -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply BarSym0 arg)) (KindOf (BarSym1 arg)) =>+        BarSym0KindInference+    type instance Apply BarSym0 l = BarSym1 l
+ tests/compile-and-dump/Promote/Constructors.hs view
@@ -0,0 +1,15 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}++module Promote.Constructors where++import Data.Singletons.SuppressUnusedWarnings+import Data.Singletons.TH++-- Tests defunctionalization symbol generation for :+--  * infix constructors+--  * constructors with arity > 2++$(promote [d|+  data Foo = Foo | Foo :+ Foo+  data Bar = Bar Bar Bar Bar Bar Foo+ |])
+ tests/compile-and-dump/Promote/GenDefunSymbols.ghc76.template view
@@ -0,0 +1,15 @@+Promote/GenDefunSymbols.hs:0:0: Splicing declarations+    genDefunSymbols [''LiftMaybe, ''Nat]+  ======>+    Promote/GenDefunSymbols.hs:0:0:+    data LiftMaybeSym1 (l :: TyFun a b -> *)+                       (l :: TyFun (Maybe a) (Maybe b))+    data LiftMaybeSym0 (k :: TyFun (TyFun a b+                                    -> *) (TyFun (Maybe a) (Maybe b) -> *))+    type instance Apply (LiftMaybeSym1 a) a = LiftMaybe a a+    type instance Apply LiftMaybeSym0 a = LiftMaybeSym1 a+    type NatTyCtor = Nat+    type NatTyCtorSym0 = NatTyCtor+    type ZeroSym0 = Zero+    data SuccSym0 (k :: TyFun Nat Nat)+    type instance Apply SuccSym0 a = Succ a
+ tests/compile-and-dump/Promote/GenDefunSymbols.ghc78.template view
@@ -0,0 +1,46 @@+Promote/GenDefunSymbols.hs:0:0: Splicing declarations+    genDefunSymbols [''LiftMaybe, ''NatT, '':+]+  ======>+    Promote/GenDefunSymbols.hs:0:0:+    type LiftMaybeSym2 (t :: TyFun a b -> *) (t :: Maybe a) =+        LiftMaybe t t+    instance SuppressUnusedWarnings LiftMaybeSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) LiftMaybeSym1KindInference GHC.Tuple.())+    data LiftMaybeSym1 (l :: TyFun a b -> *)+                       (l :: TyFun (Maybe a) (Maybe b))+      = forall arg. (GHC.Types.~) (Data.Singletons.KindOf (Apply (LiftMaybeSym1 l) arg)) (Data.Singletons.KindOf (LiftMaybeSym2 l arg)) =>+        LiftMaybeSym1KindInference+    type instance Apply (LiftMaybeSym1 l) l = LiftMaybeSym2 l l+    instance SuppressUnusedWarnings LiftMaybeSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) LiftMaybeSym0KindInference GHC.Tuple.())+    data LiftMaybeSym0 (l :: TyFun (TyFun a b+                                    -> *) (TyFun (Maybe a) (Maybe b) -> *))+      = forall arg. (GHC.Types.~) (Data.Singletons.KindOf (Apply LiftMaybeSym0 arg)) (Data.Singletons.KindOf (LiftMaybeSym1 arg)) =>+        LiftMaybeSym0KindInference+    type instance Apply LiftMaybeSym0 l = LiftMaybeSym1 l+    type ZeroSym0 = Zero+    type SuccSym1 (t :: NatT) = Succ t+    instance SuppressUnusedWarnings SuccSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) SuccSym0KindInference GHC.Tuple.())+    data SuccSym0 (l :: TyFun NatT NatT)+      = forall arg. (GHC.Types.~) (Data.Singletons.KindOf (Apply SuccSym0 arg)) (Data.Singletons.KindOf (SuccSym1 arg)) =>+        SuccSym0KindInference+    type instance Apply SuccSym0 l = SuccSym1 l+    type (:+$$$) (t :: Nat) (t :: Nat) = (:+) t t+    instance SuppressUnusedWarnings (:+$$) where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) (:+$$###) GHC.Tuple.())+    data (:+$$) (l :: Nat) l+      = forall arg. (GHC.Types.~) (Data.Singletons.KindOf (Apply ((:+$$) l) arg)) (Data.Singletons.KindOf ((:+$$$) l arg)) =>+        (:+$$###)+    type instance Apply ((:+$$) l) l = (:+$$$) l l+    instance SuppressUnusedWarnings (:+$) where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) (:+$###) GHC.Tuple.())+    data (:+$) l+      = forall arg. (GHC.Types.~) (Data.Singletons.KindOf (Apply (:+$) arg)) (Data.Singletons.KindOf ((:+$$) arg)) =>+        (:+$###)+    type instance Apply (:+$) l = (:+$$) l
+ tests/compile-and-dump/Promote/GenDefunSymbols.hs view
@@ -0,0 +1,24 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}++module Promote.GenDefunSymbols where++import Data.Singletons (Apply, TyFun)+import Data.Singletons.Promote+import Data.Singletons.SuppressUnusedWarnings+import GHC.TypeLits++#if __GLASGOW_HASKELL__ >= 707+type family LiftMaybe (f :: TyFun a b -> *) (x :: Maybe a) :: Maybe b where+    LiftMaybe f Nothing = Nothing+    LiftMaybe f (Just a) = Just (Apply f a)+#else+type family LiftMaybe (f :: TyFun a b -> *) (x :: Maybe a) :: Maybe b+type instance LiftMaybe f Nothing = Nothing+type instance LiftMaybe f (Just a) = Just (Apply f a)+#endif++data NatT = Zero | Succ NatT++type a :+ b = a + b++$(genDefunSymbols [ ''LiftMaybe, ''NatT, ''(:+) ])
+ tests/compile-and-dump/Promote/Newtypes.ghc76.template view
@@ -0,0 +1,2 @@+Promote/Newtypes.hs:0:0:+    Newtypes don't promote under GHC 7.6. Use <<data>> instead or upgrade GHC.
+ tests/compile-and-dump/Promote/Newtypes.ghc78.template view
@@ -0,0 +1,43 @@+Promote/Newtypes.hs:0:0: Splicing declarations+    promote+      [d| newtype Foo+            = Foo Nat+            deriving (Eq)+          newtype Bar = Bar {unBar :: Nat} |]+  ======>+    Promote/Newtypes.hs:(0,0)-(0,0)+    newtype Foo+      = Foo Nat+      deriving (Eq)+    newtype Bar = Bar {unBar :: Nat}+    type UnBarSym1 (t :: Bar) = UnBar t+    instance SuppressUnusedWarnings UnBarSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) UnBarSym0KindInference GHC.Tuple.())+    data UnBarSym0 (l :: TyFun Bar Nat)+      = forall arg. (GHC.Types.~) (KindOf (Apply UnBarSym0 arg)) (KindOf (UnBarSym1 arg)) =>+        UnBarSym0KindInference+    type instance Apply UnBarSym0 l = UnBarSym1 l+    type family UnBar (a :: Bar) :: Nat where+      UnBar (Bar field) = field+    type family Equals_0123456789 (a :: Foo) (b :: Foo) :: Bool where+      Equals_0123456789 (Foo a) (Foo b) = (:==) a b+      Equals_0123456789 (a :: Foo) (b :: Foo) = FalseSym0+    instance PEq (KProxy :: KProxy Foo) where+      type (:==) (a :: Foo) (b :: Foo) = Equals_0123456789 a b+    type FooSym1 (t :: Nat) = Foo t+    instance SuppressUnusedWarnings FooSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) FooSym0KindInference GHC.Tuple.())+    data FooSym0 (l :: TyFun Nat Foo)+      = forall arg. (GHC.Types.~) (KindOf (Apply FooSym0 arg)) (KindOf (FooSym1 arg)) =>+        FooSym0KindInference+    type instance Apply FooSym0 l = FooSym1 l+    type BarSym1 (t :: Nat) = Bar t+    instance SuppressUnusedWarnings BarSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) BarSym0KindInference GHC.Tuple.())+    data BarSym0 (l :: TyFun Nat Bar)+      = forall arg. (GHC.Types.~) (KindOf (Apply BarSym0 arg)) (KindOf (BarSym1 arg)) =>+        BarSym0KindInference+    type instance Apply BarSym0 l = BarSym1 l
+ tests/compile-and-dump/Promote/Newtypes.hs view
@@ -0,0 +1,12 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}++module Promote.Newtypes where++import Data.Singletons.SuppressUnusedWarnings+import Data.Singletons.TH+import Singletons.Nat++$(promote [d|+  newtype Foo = Foo Nat deriving (Eq)+  newtype Bar = Bar { unBar :: Nat }+ |])
− 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/OrdDeriving.ghc78.template view
@@ -0,0 +1,304 @@+Promote/OrdDeriving.hs:0:0: Splicing declarations+    promote+      [d| data Nat+            = Zero | Succ Nat+            deriving (Eq, Ord)+          data Foo a b c d+            = A a b c d |+              B a b c d |+              C a b c d |+              D a b c d |+              E a b c d |+              F a b c d+            deriving (Eq, Ord) |]+  ======>+    Promote/OrdDeriving.hs:(0,0)-(0,0)+    data Nat+      = Zero | Succ Nat+      deriving (Eq, Ord)+    data Foo a b c d+      = A a b c d |+        B a b c d |+        C a b c d |+        D a b c d |+        E a b c d |+        F a b c d+      deriving (Eq, Ord)+    type family Equals_0123456789 (a :: Nat) (b :: Nat) :: Bool where+      Equals_0123456789 Zero Zero = TrueSym0+      Equals_0123456789 (Succ a) (Succ b) = (:==) a b+      Equals_0123456789 (a :: Nat) (b :: Nat) = FalseSym0+    instance PEq (KProxy :: KProxy Nat) where+      type (:==) (a :: Nat) (b :: Nat) = Equals_0123456789 a b+    instance POrd (KProxy :: KProxy Nat) where+      type Compare Zero Zero = EQ+      type Compare Zero (Succ rhs) = LT+      type Compare (Succ lhs) Zero = GT+      type Compare (Succ lhs) (Succ rhs) = ThenCmp EQ (Compare lhs rhs)+    type ZeroSym0 = Zero+    type SuccSym1 (t :: Nat) = Succ t+    instance SuppressUnusedWarnings SuccSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) SuccSym0KindInference GHC.Tuple.())+    data SuccSym0 (l :: TyFun Nat Nat)+      = forall arg. (GHC.Types.~) (Data.Singletons.KindOf (Apply SuccSym0 arg)) (Data.Singletons.KindOf (SuccSym1 arg)) =>+        SuccSym0KindInference+    type instance Apply SuccSym0 l = SuccSym1 l+    type family Equals_0123456789 (a :: Foo k k k k)+                                  (b :: Foo k k k k) :: Bool where+      Equals_0123456789 (A a a a a) (A b b b b) = (:&&) ((:==) a b) ((:&&) ((:==) a b) ((:&&) ((:==) a b) ((:==) a b)))+      Equals_0123456789 (B a a a a) (B b b b b) = (:&&) ((:==) a b) ((:&&) ((:==) a b) ((:&&) ((:==) a b) ((:==) a b)))+      Equals_0123456789 (C a a a a) (C b b b b) = (:&&) ((:==) a b) ((:&&) ((:==) a b) ((:&&) ((:==) a b) ((:==) a b)))+      Equals_0123456789 (D a a a a) (D b b b b) = (:&&) ((:==) a b) ((:&&) ((:==) a b) ((:&&) ((:==) a b) ((:==) a b)))+      Equals_0123456789 (E a a a a) (E b b b b) = (:&&) ((:==) a b) ((:&&) ((:==) a b) ((:&&) ((:==) a b) ((:==) a b)))+      Equals_0123456789 (F a a a a) (F b b b b) = (:&&) ((:==) a b) ((:&&) ((:==) a b) ((:&&) ((:==) a b) ((:==) a b)))+      Equals_0123456789 (a :: Foo k k k k) (b :: Foo k k k k) = FalseSym0+    instance PEq (KProxy :: KProxy (Foo k k k k)) where+      type (:==) (a :: Foo k k k k) (b :: Foo k k k k) = Equals_0123456789 a b+    instance POrd (KProxy :: KProxy (Foo k k k k)) where+      type Compare (A lhs lhs lhs lhs) (A rhs rhs rhs rhs) = ThenCmp (ThenCmp (ThenCmp (ThenCmp EQ (Compare lhs rhs)) (Compare lhs rhs)) (Compare lhs rhs)) (Compare lhs rhs)+      type Compare (A lhs lhs lhs lhs) (B rhs rhs rhs rhs) = LT+      type Compare (A lhs lhs lhs lhs) (C rhs rhs rhs rhs) = LT+      type Compare (A lhs lhs lhs lhs) (D rhs rhs rhs rhs) = LT+      type Compare (A lhs lhs lhs lhs) (E rhs rhs rhs rhs) = LT+      type Compare (A lhs lhs lhs lhs) (F rhs rhs rhs rhs) = LT+      type Compare (B lhs lhs lhs lhs) (A rhs rhs rhs rhs) = GT+      type Compare (B lhs lhs lhs lhs) (B rhs rhs rhs rhs) = ThenCmp (ThenCmp (ThenCmp (ThenCmp EQ (Compare lhs rhs)) (Compare lhs rhs)) (Compare lhs rhs)) (Compare lhs rhs)+      type Compare (B lhs lhs lhs lhs) (C rhs rhs rhs rhs) = LT+      type Compare (B lhs lhs lhs lhs) (D rhs rhs rhs rhs) = LT+      type Compare (B lhs lhs lhs lhs) (E rhs rhs rhs rhs) = LT+      type Compare (B lhs lhs lhs lhs) (F rhs rhs rhs rhs) = LT+      type Compare (C lhs lhs lhs lhs) (A rhs rhs rhs rhs) = GT+      type Compare (C lhs lhs lhs lhs) (B rhs rhs rhs rhs) = GT+      type Compare (C lhs lhs lhs lhs) (C rhs rhs rhs rhs) = ThenCmp (ThenCmp (ThenCmp (ThenCmp EQ (Compare lhs rhs)) (Compare lhs rhs)) (Compare lhs rhs)) (Compare lhs rhs)+      type Compare (C lhs lhs lhs lhs) (D rhs rhs rhs rhs) = LT+      type Compare (C lhs lhs lhs lhs) (E rhs rhs rhs rhs) = LT+      type Compare (C lhs lhs lhs lhs) (F rhs rhs rhs rhs) = LT+      type Compare (D lhs lhs lhs lhs) (A rhs rhs rhs rhs) = GT+      type Compare (D lhs lhs lhs lhs) (B rhs rhs rhs rhs) = GT+      type Compare (D lhs lhs lhs lhs) (C rhs rhs rhs rhs) = GT+      type Compare (D lhs lhs lhs lhs) (D rhs rhs rhs rhs) = ThenCmp (ThenCmp (ThenCmp (ThenCmp EQ (Compare lhs rhs)) (Compare lhs rhs)) (Compare lhs rhs)) (Compare lhs rhs)+      type Compare (D lhs lhs lhs lhs) (E rhs rhs rhs rhs) = LT+      type Compare (D lhs lhs lhs lhs) (F rhs rhs rhs rhs) = LT+      type Compare (E lhs lhs lhs lhs) (A rhs rhs rhs rhs) = GT+      type Compare (E lhs lhs lhs lhs) (B rhs rhs rhs rhs) = GT+      type Compare (E lhs lhs lhs lhs) (C rhs rhs rhs rhs) = GT+      type Compare (E lhs lhs lhs lhs) (D rhs rhs rhs rhs) = GT+      type Compare (E lhs lhs lhs lhs) (E rhs rhs rhs rhs) = ThenCmp (ThenCmp (ThenCmp (ThenCmp EQ (Compare lhs rhs)) (Compare lhs rhs)) (Compare lhs rhs)) (Compare lhs rhs)+      type Compare (E lhs lhs lhs lhs) (F rhs rhs rhs rhs) = LT+      type Compare (F lhs lhs lhs lhs) (A rhs rhs rhs rhs) = GT+      type Compare (F lhs lhs lhs lhs) (B rhs rhs rhs rhs) = GT+      type Compare (F lhs lhs lhs lhs) (C rhs rhs rhs rhs) = GT+      type Compare (F lhs lhs lhs lhs) (D rhs rhs rhs rhs) = GT+      type Compare (F lhs lhs lhs lhs) (E rhs rhs rhs rhs) = GT+      type Compare (F lhs lhs lhs lhs) (F rhs rhs rhs rhs) = ThenCmp (ThenCmp (ThenCmp (ThenCmp EQ (Compare lhs rhs)) (Compare lhs rhs)) (Compare lhs rhs)) (Compare lhs rhs)+    type ASym4 (t :: a) (t :: b) (t :: c) (t :: d) = A t t t t+    instance SuppressUnusedWarnings ASym3 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) ASym3KindInference GHC.Tuple.())+    data ASym3 (l :: a) (l :: b) (l :: c) (l :: TyFun d (Foo a b c d))+      = forall arg. (GHC.Types.~) (Data.Singletons.KindOf (Apply (ASym3 l l l) arg)) (Data.Singletons.KindOf (ASym4 l l l arg)) =>+        ASym3KindInference+    type instance Apply (ASym3 l l l) l = ASym4 l l l l+    instance SuppressUnusedWarnings ASym2 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) ASym2KindInference GHC.Tuple.())+    data ASym2 (l :: a)+               (l :: b)+               (l :: TyFun c (TyFun d (Foo a b c d) -> *))+      = forall arg. (GHC.Types.~) (Data.Singletons.KindOf (Apply (ASym2 l l) arg)) (Data.Singletons.KindOf (ASym3 l l arg)) =>+        ASym2KindInference+    type instance Apply (ASym2 l l) l = ASym3 l l l+    instance SuppressUnusedWarnings ASym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) ASym1KindInference GHC.Tuple.())+    data ASym1 (l :: a)+               (l :: TyFun b (TyFun c (TyFun d (Foo a b c d) -> *) -> *))+      = forall arg. (GHC.Types.~) (Data.Singletons.KindOf (Apply (ASym1 l) arg)) (Data.Singletons.KindOf (ASym2 l arg)) =>+        ASym1KindInference+    type instance Apply (ASym1 l) l = ASym2 l l+    instance SuppressUnusedWarnings ASym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) ASym0KindInference GHC.Tuple.())+    data ASym0 (l :: TyFun a (TyFun b (TyFun c (TyFun d (Foo a b c d)+                                                -> *)+                                       -> *)+                              -> *))+      = forall arg. (GHC.Types.~) (Data.Singletons.KindOf (Apply ASym0 arg)) (Data.Singletons.KindOf (ASym1 arg)) =>+        ASym0KindInference+    type instance Apply ASym0 l = ASym1 l+    type BSym4 (t :: a) (t :: b) (t :: c) (t :: d) = B t t t t+    instance SuppressUnusedWarnings BSym3 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) BSym3KindInference GHC.Tuple.())+    data BSym3 (l :: a) (l :: b) (l :: c) (l :: TyFun d (Foo a b c d))+      = forall arg. (GHC.Types.~) (Data.Singletons.KindOf (Apply (BSym3 l l l) arg)) (Data.Singletons.KindOf (BSym4 l l l arg)) =>+        BSym3KindInference+    type instance Apply (BSym3 l l l) l = BSym4 l l l l+    instance SuppressUnusedWarnings BSym2 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) BSym2KindInference GHC.Tuple.())+    data BSym2 (l :: a)+               (l :: b)+               (l :: TyFun c (TyFun d (Foo a b c d) -> *))+      = forall arg. (GHC.Types.~) (Data.Singletons.KindOf (Apply (BSym2 l l) arg)) (Data.Singletons.KindOf (BSym3 l l arg)) =>+        BSym2KindInference+    type instance Apply (BSym2 l l) l = BSym3 l l l+    instance SuppressUnusedWarnings BSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) BSym1KindInference GHC.Tuple.())+    data BSym1 (l :: a)+               (l :: TyFun b (TyFun c (TyFun d (Foo a b c d) -> *) -> *))+      = forall arg. (GHC.Types.~) (Data.Singletons.KindOf (Apply (BSym1 l) arg)) (Data.Singletons.KindOf (BSym2 l arg)) =>+        BSym1KindInference+    type instance Apply (BSym1 l) l = BSym2 l l+    instance SuppressUnusedWarnings BSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) BSym0KindInference GHC.Tuple.())+    data BSym0 (l :: TyFun a (TyFun b (TyFun c (TyFun d (Foo a b c d)+                                                -> *)+                                       -> *)+                              -> *))+      = forall arg. (GHC.Types.~) (Data.Singletons.KindOf (Apply BSym0 arg)) (Data.Singletons.KindOf (BSym1 arg)) =>+        BSym0KindInference+    type instance Apply BSym0 l = BSym1 l+    type CSym4 (t :: a) (t :: b) (t :: c) (t :: d) = C t t t t+    instance SuppressUnusedWarnings CSym3 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) CSym3KindInference GHC.Tuple.())+    data CSym3 (l :: a) (l :: b) (l :: c) (l :: TyFun d (Foo a b c d))+      = forall arg. (GHC.Types.~) (Data.Singletons.KindOf (Apply (CSym3 l l l) arg)) (Data.Singletons.KindOf (CSym4 l l l arg)) =>+        CSym3KindInference+    type instance Apply (CSym3 l l l) l = CSym4 l l l l+    instance SuppressUnusedWarnings CSym2 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) CSym2KindInference GHC.Tuple.())+    data CSym2 (l :: a)+               (l :: b)+               (l :: TyFun c (TyFun d (Foo a b c d) -> *))+      = forall arg. (GHC.Types.~) (Data.Singletons.KindOf (Apply (CSym2 l l) arg)) (Data.Singletons.KindOf (CSym3 l l arg)) =>+        CSym2KindInference+    type instance Apply (CSym2 l l) l = CSym3 l l l+    instance SuppressUnusedWarnings CSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) CSym1KindInference GHC.Tuple.())+    data CSym1 (l :: a)+               (l :: TyFun b (TyFun c (TyFun d (Foo a b c d) -> *) -> *))+      = forall arg. (GHC.Types.~) (Data.Singletons.KindOf (Apply (CSym1 l) arg)) (Data.Singletons.KindOf (CSym2 l arg)) =>+        CSym1KindInference+    type instance Apply (CSym1 l) l = CSym2 l l+    instance SuppressUnusedWarnings CSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) CSym0KindInference GHC.Tuple.())+    data CSym0 (l :: TyFun a (TyFun b (TyFun c (TyFun d (Foo a b c d)+                                                -> *)+                                       -> *)+                              -> *))+      = forall arg. (GHC.Types.~) (Data.Singletons.KindOf (Apply CSym0 arg)) (Data.Singletons.KindOf (CSym1 arg)) =>+        CSym0KindInference+    type instance Apply CSym0 l = CSym1 l+    type DSym4 (t :: a) (t :: b) (t :: c) (t :: d) = D t t t t+    instance SuppressUnusedWarnings DSym3 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) DSym3KindInference GHC.Tuple.())+    data DSym3 (l :: a) (l :: b) (l :: c) (l :: TyFun d (Foo a b c d))+      = forall arg. (GHC.Types.~) (Data.Singletons.KindOf (Apply (DSym3 l l l) arg)) (Data.Singletons.KindOf (DSym4 l l l arg)) =>+        DSym3KindInference+    type instance Apply (DSym3 l l l) l = DSym4 l l l l+    instance SuppressUnusedWarnings DSym2 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) DSym2KindInference GHC.Tuple.())+    data DSym2 (l :: a)+               (l :: b)+               (l :: TyFun c (TyFun d (Foo a b c d) -> *))+      = forall arg. (GHC.Types.~) (Data.Singletons.KindOf (Apply (DSym2 l l) arg)) (Data.Singletons.KindOf (DSym3 l l arg)) =>+        DSym2KindInference+    type instance Apply (DSym2 l l) l = DSym3 l l l+    instance SuppressUnusedWarnings DSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) DSym1KindInference GHC.Tuple.())+    data DSym1 (l :: a)+               (l :: TyFun b (TyFun c (TyFun d (Foo a b c d) -> *) -> *))+      = forall arg. (GHC.Types.~) (Data.Singletons.KindOf (Apply (DSym1 l) arg)) (Data.Singletons.KindOf (DSym2 l arg)) =>+        DSym1KindInference+    type instance Apply (DSym1 l) l = DSym2 l l+    instance SuppressUnusedWarnings DSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) DSym0KindInference GHC.Tuple.())+    data DSym0 (l :: TyFun a (TyFun b (TyFun c (TyFun d (Foo a b c d)+                                                -> *)+                                       -> *)+                              -> *))+      = forall arg. (GHC.Types.~) (Data.Singletons.KindOf (Apply DSym0 arg)) (Data.Singletons.KindOf (DSym1 arg)) =>+        DSym0KindInference+    type instance Apply DSym0 l = DSym1 l+    type ESym4 (t :: a) (t :: b) (t :: c) (t :: d) = E t t t t+    instance SuppressUnusedWarnings ESym3 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) ESym3KindInference GHC.Tuple.())+    data ESym3 (l :: a) (l :: b) (l :: c) (l :: TyFun d (Foo a b c d))+      = forall arg. (GHC.Types.~) (Data.Singletons.KindOf (Apply (ESym3 l l l) arg)) (Data.Singletons.KindOf (ESym4 l l l arg)) =>+        ESym3KindInference+    type instance Apply (ESym3 l l l) l = ESym4 l l l l+    instance SuppressUnusedWarnings ESym2 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) ESym2KindInference GHC.Tuple.())+    data ESym2 (l :: a)+               (l :: b)+               (l :: TyFun c (TyFun d (Foo a b c d) -> *))+      = forall arg. (GHC.Types.~) (Data.Singletons.KindOf (Apply (ESym2 l l) arg)) (Data.Singletons.KindOf (ESym3 l l arg)) =>+        ESym2KindInference+    type instance Apply (ESym2 l l) l = ESym3 l l l+    instance SuppressUnusedWarnings ESym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) ESym1KindInference GHC.Tuple.())+    data ESym1 (l :: a)+               (l :: TyFun b (TyFun c (TyFun d (Foo a b c d) -> *) -> *))+      = forall arg. (GHC.Types.~) (Data.Singletons.KindOf (Apply (ESym1 l) arg)) (Data.Singletons.KindOf (ESym2 l arg)) =>+        ESym1KindInference+    type instance Apply (ESym1 l) l = ESym2 l l+    instance SuppressUnusedWarnings ESym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) ESym0KindInference GHC.Tuple.())+    data ESym0 (l :: TyFun a (TyFun b (TyFun c (TyFun d (Foo a b c d)+                                                -> *)+                                       -> *)+                              -> *))+      = forall arg. (GHC.Types.~) (Data.Singletons.KindOf (Apply ESym0 arg)) (Data.Singletons.KindOf (ESym1 arg)) =>+        ESym0KindInference+    type instance Apply ESym0 l = ESym1 l+    type FSym4 (t :: a) (t :: b) (t :: c) (t :: d) = F t t t t+    instance SuppressUnusedWarnings FSym3 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) FSym3KindInference GHC.Tuple.())+    data FSym3 (l :: a) (l :: b) (l :: c) (l :: TyFun d (Foo a b c d))+      = forall arg. (GHC.Types.~) (Data.Singletons.KindOf (Apply (FSym3 l l l) arg)) (Data.Singletons.KindOf (FSym4 l l l arg)) =>+        FSym3KindInference+    type instance Apply (FSym3 l l l) l = FSym4 l l l l+    instance SuppressUnusedWarnings FSym2 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) FSym2KindInference GHC.Tuple.())+    data FSym2 (l :: a)+               (l :: b)+               (l :: TyFun c (TyFun d (Foo a b c d) -> *))+      = forall arg. (GHC.Types.~) (Data.Singletons.KindOf (Apply (FSym2 l l) arg)) (Data.Singletons.KindOf (FSym3 l l arg)) =>+        FSym2KindInference+    type instance Apply (FSym2 l l) l = FSym3 l l l+    instance SuppressUnusedWarnings FSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) FSym1KindInference GHC.Tuple.())+    data FSym1 (l :: a)+               (l :: TyFun b (TyFun c (TyFun d (Foo a b c d) -> *) -> *))+      = forall arg. (GHC.Types.~) (Data.Singletons.KindOf (Apply (FSym1 l) arg)) (Data.Singletons.KindOf (FSym2 l arg)) =>+        FSym1KindInference+    type instance Apply (FSym1 l) l = FSym2 l l+    instance SuppressUnusedWarnings FSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) FSym0KindInference GHC.Tuple.())+    data FSym0 (l :: TyFun a (TyFun b (TyFun c (TyFun d (Foo a b c d)+                                                -> *)+                                       -> *)+                              -> *))+      = forall arg. (GHC.Types.~) (Data.Singletons.KindOf (Apply FSym0 arg)) (Data.Singletons.KindOf (FSym1 arg)) =>+        FSym0KindInference+    type instance Apply FSym0 l = FSym1 l
+ tests/compile-and-dump/Promote/OrdDeriving.hs view
@@ -0,0 +1,28 @@+module Promote.OrdDeriving where++import Data.Promotion.Prelude+import Data.Promotion.TH++$(promote [d|+  data Nat = Zero | Succ Nat+    deriving (Eq, Ord)++  data Foo a b c d = A a b c d+                   | B a b c d+                   | C a b c d+                   | D a b c d+                   | E a b c d+                   | F a b c d deriving (Eq,Ord)+  |])++foo1a :: Proxy (Zero :< Succ Zero)+foo1a = Proxy++foo1b :: Proxy True+foo1b = foo1a++foo2a :: Proxy (Succ (Succ Zero) `Compare` Zero)+foo2a = Proxy++foo2b :: Proxy GT+foo2b = foo2a
− 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/Promote/Pragmas.ghc78.template view
@@ -0,0 +1,12 @@+Promote/Pragmas.hs:0:0: Splicing declarations+    promote+      [d| {-# INLINE foo #-}+          foo :: Bool+          foo = True |]+  ======>+    Promote/Pragmas.hs:(0,0)-(0,0)+    {-# INLINE foo #-}+    foo :: Bool+    foo = True+    type FooSym0 = Foo+    type Foo = (TrueSym0 :: Bool)
+ tests/compile-and-dump/Promote/Pragmas.hs view
@@ -0,0 +1,10 @@+module Promote.Pragmas where++import Data.Singletons.TH+import Data.Promotion.Prelude++$(promote [d|+  {-# INLINE foo #-}+  foo :: Bool+  foo = True+ |])
+ tests/compile-and-dump/Promote/Prelude.ghc78.template view
@@ -0,0 +1,18 @@+Promote/Prelude.hs:0:0: Splicing declarations+    promoteOnly+      [d| odd :: Nat -> Bool+          odd 0 = False+          odd n = not . odd $ n - 1 |]+  ======>+    Promote/Prelude.hs:(0,0)-(0,0)+    type OddSym1 (t :: Nat) = Odd t+    instance SuppressUnusedWarnings OddSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) OddSym0KindInference GHC.Tuple.())+    data OddSym0 (l :: TyFun Nat Bool)+      = forall arg. (GHC.Types.~) (Data.Singletons.KindOf (Apply OddSym0 arg)) (Data.Singletons.KindOf (OddSym1 arg)) =>+        OddSym0KindInference+    type instance Apply OddSym0 l = OddSym1 l+    type family Odd (a :: Nat) :: Bool where+      Odd 0 = FalseSym0+      Odd n = Apply (Apply ($$) (Apply (Apply (:.$) NotSym0) OddSym0)) (Apply (Apply (:-$) n) 1)
+ tests/compile-and-dump/Promote/Prelude.hs view
@@ -0,0 +1,132 @@+module Promote.Prelude where++import Data.Promotion.TH+import Data.Promotion.Prelude+import Data.Promotion.Prelude.List+import Data.Proxy++lengthTest1a :: Proxy (Length '[True, True, True, True])+lengthTest1a = Proxy++lengthTest1b :: Proxy 4+lengthTest1b = lengthTest1a++lengthTest2a :: Proxy (Length '[])+lengthTest2a = Proxy++lengthTest2b :: Proxy 0+lengthTest2b = lengthTest2a++sumTest1a :: Proxy (Sum '[1, 2, 3, 4])+sumTest1a = Proxy++sumTest1b :: Proxy 10+sumTest1b = sumTest1a++sumTest2a :: Proxy (Sum '[])+sumTest2a = Proxy++sumTest2b :: Proxy 0+sumTest2b = sumTest2a++productTest1a :: Proxy (Product '[1, 2, 3, 4])+productTest1a = Proxy++productTest1b :: Proxy 24+productTest1b = productTest1a++productTest2a :: Proxy (Product '[])+productTest2a = Proxy++productTest2b :: Proxy 1+productTest2b = productTest2a++takeTest1a :: Proxy (Take 2 '[1, 2, 3, 4])+takeTest1a = Proxy++takeTest1b :: Proxy '[1, 2]+takeTest1b = takeTest1a++takeTest2a :: Proxy (Take 2 '[])+takeTest2a = Proxy++takeTest2b :: Proxy '[]+takeTest2b = takeTest2a++dropTest1a :: Proxy (Drop 2 '[1, 2, 3, 4])+dropTest1a = Proxy++dropTest1b :: Proxy '[3, 4]+dropTest1b = dropTest1a++dropTest2a :: Proxy (Drop 2 '[])+dropTest2a = Proxy++dropTest2b :: Proxy '[]+dropTest2b = dropTest2a++splitAtTest1a :: Proxy (SplitAt 2 '[1, 2, 3, 4])+splitAtTest1a = Proxy++splitAtTest1b :: Proxy ( '( '[1,2], '[3, 4] ) )+splitAtTest1b = splitAtTest1a++splitAtTest2a :: Proxy (SplitAt 2 '[])+splitAtTest2a = splitAtTest2b++splitAtTest2b :: Proxy ( '( '[], '[] ) )+splitAtTest2b = Proxy++indexingTest1a :: Proxy ('[4, 3, 2, 1] :!! 1)+indexingTest1a = Proxy++indexingTest1b :: Proxy 3+indexingTest1b = indexingTest1a++indexingTest2a :: Proxy ('[] :!! 0)+indexingTest2a = Proxy++indexingTest2b :: Proxy (Error "Data.Singletons.List.!!: index too large")+indexingTest2b = indexingTest2a++replicateTest1a :: Proxy (Replicate 2 True)+replicateTest1a = Proxy++replicateTest1b :: Proxy '[True, True]+replicateTest1b = replicateTest1a++replicateTest2a :: Proxy (Replicate 0 True)+replicateTest2a = replicateTest2b++replicateTest2b :: Proxy '[]+replicateTest2b = Proxy++$(promoteOnly [d|+  odd :: Nat -> Bool+  odd 0 = False+  odd n = not . odd $ n - 1+ |])++findIndexTest1a :: Proxy (FindIndex OddSym0 '[2,4,6,7])+findIndexTest1a = Proxy++findIndexTest1b :: Proxy (Just 3)+findIndexTest1b = findIndexTest1a++findIndicesTest1a :: Proxy (FindIndices OddSym0 '[1,3,5,2,4,6,7])+findIndicesTest1a = Proxy++findIndicesTest1b :: Proxy '[0,1,2,6]+findIndicesTest1b = findIndicesTest1a++transposeTest1a :: Proxy (Transpose '[[1,2,3]])+transposeTest1a = Proxy++transposeTest1b :: Proxy ('[ '[1], '[2], '[3]])+transposeTest1b = transposeTest1a++transposeTest2a :: Proxy (Transpose '[ '[1], '[2], '[3]])+transposeTest2a = Proxy++transposeTest2b :: Proxy ('[ '[1,2,3]])+transposeTest2b = transposeTest2a
+ tests/compile-and-dump/Promote/TopLevelPatterns.ghc78.template view
@@ -0,0 +1,152 @@+Promote/TopLevelPatterns.hs:0:0: Splicing declarations+    promote+      [d| id :: a -> a+          id x = x+          not :: Bool -> Bool+          not True = False+          not False = True+          f, g :: Bool -> Bool+          [f, g] = [not, id]+          h, i :: Bool -> Bool+          (h, i) = (f, g)+          j, k :: Bool+          (Bar j k) = Bar True (h False)+          l, m :: Bool+          [l, m] = [not True, id False]+          +          data Bool = False | True+          data Foo = Bar Bool Bool |]+  ======>+    Promote/TopLevelPatterns.hs:(0,0)-(0,0)+    data Bool = False | True+    data Foo = Bar Bool Bool+    id :: forall a. a -> a+    id x = x+    not :: Bool -> Bool+    not True = False+    not False = True+    f :: Bool -> Bool+    g :: Bool -> Bool+    [f, g] = [not, id]+    h :: Bool -> Bool+    i :: Bool -> Bool+    (h, i) = (f, g)+    j :: Bool+    k :: Bool+    Bar j k = Bar True (h False)+    l :: Bool+    m :: Bool+    [l, m] = [not True, id False]+    type family Case_0123456789 a_0123456789 t where+      Case_0123456789 a_0123456789 ((GHC.Types.:) y_0123456789 ((GHC.Types.:) z GHC.Types.[])) = y_0123456789+    type family Case_0123456789 a_0123456789 t where+      Case_0123456789 a_0123456789 ((GHC.Types.:) z ((GHC.Types.:) y_0123456789 GHC.Types.[])) = y_0123456789+    type family Case_0123456789 a_0123456789 t where+      Case_0123456789 a_0123456789 (GHC.Tuple.(,) y_0123456789 z) = y_0123456789+    type family Case_0123456789 a_0123456789 t where+      Case_0123456789 a_0123456789 (GHC.Tuple.(,) z y_0123456789) = y_0123456789+    type family Case_0123456789 t where+      Case_0123456789 (Bar y_0123456789 z) = y_0123456789+    type family Case_0123456789 t where+      Case_0123456789 (Bar z y_0123456789) = y_0123456789+    type family Case_0123456789 t where+      Case_0123456789 ((GHC.Types.:) y_0123456789 ((GHC.Types.:) z GHC.Types.[])) = y_0123456789+    type family Case_0123456789 t where+      Case_0123456789 ((GHC.Types.:) z ((GHC.Types.:) y_0123456789 GHC.Types.[])) = y_0123456789+    type NotSym1 (t :: Bool) = Not t+    instance SuppressUnusedWarnings NotSym0 where+      suppressUnusedWarnings _+        = Data.Tuple.snd (GHC.Tuple.(,) NotSym0KindInference GHC.Tuple.())+    data NotSym0 (l :: TyFun Bool Bool)+      = forall arg. (GHC.Types.~) (KindOf (Apply NotSym0 arg)) (KindOf (NotSym1 arg)) =>+        NotSym0KindInference+    type instance Apply NotSym0 l = NotSym1 l+    type IdSym1 (t :: a) = Id t+    instance SuppressUnusedWarnings IdSym0 where+      suppressUnusedWarnings _+        = Data.Tuple.snd (GHC.Tuple.(,) IdSym0KindInference GHC.Tuple.())+    data IdSym0 (l :: TyFun a a)+      = forall arg. (GHC.Types.~) (KindOf (Apply IdSym0 arg)) (KindOf (IdSym1 arg)) =>+        IdSym0KindInference+    type instance Apply IdSym0 l = IdSym1 l+    type FSym1 (t :: Bool) = F t+    instance SuppressUnusedWarnings FSym0 where+      suppressUnusedWarnings _+        = Data.Tuple.snd (GHC.Tuple.(,) FSym0KindInference GHC.Tuple.())+    data FSym0 (l :: TyFun Bool Bool)+      = forall arg. (GHC.Types.~) (KindOf (Apply FSym0 arg)) (KindOf (FSym1 arg)) =>+        FSym0KindInference+    type instance Apply FSym0 l = FSym1 l+    type GSym1 (t :: Bool) = G t+    instance SuppressUnusedWarnings GSym0 where+      suppressUnusedWarnings _+        = Data.Tuple.snd (GHC.Tuple.(,) GSym0KindInference GHC.Tuple.())+    data GSym0 (l :: TyFun Bool Bool)+      = forall arg. (GHC.Types.~) (KindOf (Apply GSym0 arg)) (KindOf (GSym1 arg)) =>+        GSym0KindInference+    type instance Apply GSym0 l = GSym1 l+    type HSym1 (t :: Bool) = H t+    instance SuppressUnusedWarnings HSym0 where+      suppressUnusedWarnings _+        = Data.Tuple.snd (GHC.Tuple.(,) HSym0KindInference GHC.Tuple.())+    data HSym0 (l :: TyFun Bool Bool)+      = forall arg. (GHC.Types.~) (KindOf (Apply HSym0 arg)) (KindOf (HSym1 arg)) =>+        HSym0KindInference+    type instance Apply HSym0 l = HSym1 l+    type ISym1 (t :: Bool) = I t+    instance SuppressUnusedWarnings ISym0 where+      suppressUnusedWarnings _+        = Data.Tuple.snd (GHC.Tuple.(,) ISym0KindInference GHC.Tuple.())+    data ISym0 (l :: TyFun Bool Bool)+      = forall arg. (GHC.Types.~) (KindOf (Apply ISym0 arg)) (KindOf (ISym1 arg)) =>+        ISym0KindInference+    type instance Apply ISym0 l = ISym1 l+    type JSym0 = J+    type KSym0 = K+    type LSym0 = L+    type MSym0 = M+    type X_0123456789Sym0 = X_0123456789+    type X_0123456789Sym0 = X_0123456789+    type X_0123456789Sym0 = X_0123456789+    type X_0123456789Sym0 = X_0123456789+    type family Not (a :: Bool) :: Bool where+      Not True = FalseSym0+      Not False = TrueSym0+    type family Id (a :: a) :: a where+      Id x = x+    type family F (a :: Bool) :: Bool where+      F a_0123456789 = Apply (Case_0123456789 a_0123456789 X_0123456789Sym0) a_0123456789+    type family G (a :: Bool) :: Bool where+      G a_0123456789 = Apply (Case_0123456789 a_0123456789 X_0123456789Sym0) a_0123456789+    type family H (a :: Bool) :: Bool where+      H a_0123456789 = Apply (Case_0123456789 a_0123456789 X_0123456789Sym0) a_0123456789+    type family I (a :: Bool) :: Bool where+      I a_0123456789 = Apply (Case_0123456789 a_0123456789 X_0123456789Sym0) a_0123456789+    type J = (Case_0123456789 X_0123456789Sym0 :: Bool)+    type K = (Case_0123456789 X_0123456789Sym0 :: Bool)+    type L = (Case_0123456789 X_0123456789Sym0 :: Bool)+    type M = (Case_0123456789 X_0123456789Sym0 :: Bool)+    type X_0123456789 =+        Apply (Apply (:$) NotSym0) (Apply (Apply (:$) IdSym0) GHC.Types.[])+    type X_0123456789 = Apply (Apply Tuple2Sym0 FSym0) GSym0+    type X_0123456789 =+        Apply (Apply BarSym0 TrueSym0) (Apply HSym0 FalseSym0)+    type X_0123456789 =+        Apply (Apply (:$) (Apply NotSym0 TrueSym0)) (Apply (Apply (:$) (Apply IdSym0 FalseSym0)) GHC.Types.[])+    type FalseSym0 = False+    type TrueSym0 = True+    type BarSym2 (t :: Bool) (t :: Bool) = Bar t t+    instance SuppressUnusedWarnings BarSym1 where+      suppressUnusedWarnings _+        = Data.Tuple.snd (GHC.Tuple.(,) BarSym1KindInference GHC.Tuple.())+    data BarSym1 (l :: Bool) (l :: TyFun Bool Foo)+      = forall arg. (GHC.Types.~) (KindOf (Apply (BarSym1 l) arg)) (KindOf (BarSym2 l arg)) =>+        BarSym1KindInference+    type instance Apply (BarSym1 l) l = BarSym2 l l+    instance SuppressUnusedWarnings BarSym0 where+      suppressUnusedWarnings _+        = Data.Tuple.snd (GHC.Tuple.(,) BarSym0KindInference GHC.Tuple.())+    data BarSym0 (l :: TyFun Bool (TyFun Bool Foo -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply BarSym0 arg)) (KindOf (BarSym1 arg)) =>+        BarSym0KindInference+    type instance Apply BarSym0 l = BarSym1 l
+ tests/compile-and-dump/Promote/TopLevelPatterns.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}++module Promote.TopLevelPatterns where++import Data.Singletons+import Data.Singletons.Prelude.List+import Data.Singletons.SuppressUnusedWarnings+import Data.Singletons.TH hiding (STrue, SFalse, TrueSym0, FalseSym0)++-- Remove this test once #54 is fixed+$(promote [d|+  data Bool = False | True+  data Foo = Bar Bool Bool++  id :: a -> a+  id x = x++  not :: Bool -> Bool+  not True  = False+  not False = True++  f,g :: Bool -> Bool+  [f,g] = [not, id]++  h,i :: Bool -> Bool+  (h,i) = (f, g)++  j,k :: Bool+  (Bar j k) = Bar True (h False)++  l,m :: Bool+  [l,m] = [not True, id False]+ |])
+ tests/compile-and-dump/Singletons/AsPattern.ghc76.template view
@@ -0,0 +1,104 @@+Singletons/AtPattern.hs:0:0: Splicing declarations+    singletons+      [d| maybePlus :: Maybe Nat -> Maybe Nat+          maybePlus (Just n) = Just (plus (Succ Zero) n)+          maybePlus p@Nothing = p+          bar :: Maybe Nat -> Maybe Nat+          bar x@(Just _) = x+          bar Nothing = Nothing+          baz_ :: Maybe Baz -> Maybe Baz+          baz_ p@Nothing = p+          baz_ p@(Just (Baz _ _ _)) = p+          tup :: (Nat, Nat) -> (Nat, Nat)+          tup p@(_, _) = p+          foo :: [Nat] -> [Nat]+          foo p@[] = p+          foo p@[_] = p+          foo p@(_ : _) = p+          +          data Baz = Baz Nat Nat Nat |]+  ======>+    Singletons/AtPattern.hs:(0,0)-(0,0)+    maybePlus :: Maybe Nat -> Maybe Nat+    maybePlus (Just n) = Just (plus (Succ Zero) n)+    maybePlus p@Nothing = p+    bar :: Maybe Nat -> Maybe Nat+    bar x@(Just _) = x+    bar Nothing = Nothing+    data Baz = Baz Nat Nat Nat+    baz_ :: Maybe Baz -> Maybe Baz+    baz_ p@Nothing = p+    baz_ p@(Just (Baz _ _ _)) = p+    tup :: (Nat, Nat) -> (Nat, Nat)+    tup p@(_, _) = p+    foo :: [Nat] -> [Nat]+    foo p@GHC.Types.[] = p+    foo p@[_] = p+    foo p@(_ GHC.Types.: _) = p+    type BazTyCtor = Baz+    type BazTyCtorSym0 = BazTyCtor+    data BazSym2 (l :: Nat) (l :: Nat) (l :: TyFun Nat Baz)+    data BazSym1 (l :: Nat) (l :: TyFun Nat (TyFun Nat Baz -> *))+    data BazSym0 (k :: TyFun Nat (TyFun Nat (TyFun Nat Baz -> *) -> *))+    type instance Apply (BazSym2 a a) a = Baz a a a+    type instance Apply (BazSym1 a) a = BazSym2 a a+    type instance Apply BazSym0 a = BazSym1 a+    type family MaybePlus (a :: Maybe Nat) :: Maybe Nat+    type instance MaybePlus (Just n) =+        Apply JustSym0 (Apply (Apply PlusSym0 (Apply SuccSym0 ZeroSym0)) n)+    type instance MaybePlus Nothing = NothingSym0+    data MaybePlusSym0 (k :: TyFun (Maybe Nat) (Maybe Nat))+    type instance Apply MaybePlusSym0 a = MaybePlus a+    type family Bar (a :: Maybe Nat) :: Maybe Nat+    type instance Bar (Just z) = Apply JustSym0 z+    type instance Bar Nothing = NothingSym0+    data BarSym0 (k :: TyFun (Maybe Nat) (Maybe Nat))+    type instance Apply BarSym0 a = Bar a+    type family Baz_ (a :: Maybe Baz) :: Maybe Baz+    type instance Baz_ Nothing = NothingSym0+    type instance Baz_ (Just (Baz z z z)) =+        Apply JustSym0 (Apply (Apply (Apply BazSym0 z) z) z)+    data Baz_Sym0 (k :: TyFun (Maybe Baz) (Maybe Baz))+    type instance Apply Baz_Sym0 a = Baz_ a+    type family Tup (a :: (Nat, Nat)) :: (Nat, Nat)+    type instance Tup '(z, z) = Apply (Apply Tuple2Sym0 z) z+    data TupSym0 (k :: TyFun (Nat, Nat) (Nat, Nat))+    type instance Apply TupSym0 a = Tup a+    type family Foo (a :: [Nat]) :: [Nat]+    type instance Foo GHC.Types.[] = GHC.Types.[]+    type instance Foo '[z] = Apply (Apply :$ z) GHC.Types.[]+    type instance Foo (GHC.Types.: z z) = Apply (Apply :$ z) z+    data FooSym0 (k :: TyFun [Nat] [Nat])+    type instance Apply FooSym0 a = Foo a+    sMaybePlus :: forall (t :: Maybe Nat). Sing t -> Sing (MaybePlus t)+    sMaybePlus (SJust n) = SJust (sPlus (SSucc SZero) n)+    sMaybePlus p@SNothing = p+    sBar :: forall (t :: Maybe Nat). Sing t -> Sing (Bar t)+    sBar x@(SJust _) = x+    sBar SNothing = SNothing+    data instance Sing (z :: Baz)+      = forall (n :: Nat) (n :: Nat) (n :: Nat). z ~ Baz n n n =>+        SBaz (Sing n) (Sing n) (Sing n)+    type SBaz (z :: Baz) = Sing z+    instance SingKind (KProxy :: KProxy Baz) where+      type instance DemoteRep (KProxy :: KProxy Baz) = Baz+      fromSing (SBaz b b b) = Baz (fromSing b) (fromSing b) (fromSing b)+      toSing (Baz b b b)+        = case+              (toSing b :: SomeSing (KProxy :: KProxy Nat), +               toSing b :: SomeSing (KProxy :: KProxy Nat), +               toSing b :: SomeSing (KProxy :: KProxy Nat))+          of {+            (SomeSing c, SomeSing c, SomeSing c) -> SomeSing (SBaz c c c) }+    instance (SingI n, SingI n, SingI n) =>+             SingI (Baz (n :: Nat) (n :: Nat) (n :: Nat)) where+      sing = SBaz sing sing sing+    sBaz_ :: forall (t :: Maybe Baz). Sing t -> Sing (Baz_ t)+    sBaz_ p@SNothing = p+    sBaz_ p@(SJust (SBaz _ _ _)) = p+    sTup :: forall (t :: (Nat, Nat)). Sing t -> Sing (Tup t)+    sTup p@(STuple2 _ _) = p+    sFoo :: forall (t :: [Nat]). Sing t -> Sing (Foo t)+    sFoo p@SNil = p+    sFoo p@(SCons _ SNil) = p+    sFoo p@(SCons _ _) = p
+ tests/compile-and-dump/Singletons/AsPattern.ghc78.template view
@@ -0,0 +1,371 @@+Singletons/AsPattern.hs:0:0: Splicing declarations+    singletons+      [d| maybePlus :: Maybe Nat -> Maybe Nat+          maybePlus (Just n) = Just (plus (Succ Zero) n)+          maybePlus p@Nothing = p+          bar :: Maybe Nat -> Maybe Nat+          bar x@(Just _) = x+          bar Nothing = Nothing+          baz_ :: Maybe Baz -> Maybe Baz+          baz_ p@Nothing = p+          baz_ p@(Just (Baz _ _ _)) = p+          tup :: (Nat, Nat) -> (Nat, Nat)+          tup p@(_, _) = p+          foo :: [Nat] -> [Nat]+          foo p@[] = p+          foo p@[_] = p+          foo p@(_ : _) = p++          data Baz = Baz Nat Nat Nat |]+  ======>+    Singletons/AsPattern.hs:(0,0)-(0,0)+    maybePlus :: Maybe Nat -> Maybe Nat+    maybePlus (Just n) = Just (plus (Succ Zero) n)+    maybePlus p@Nothing = p+    bar :: Maybe Nat -> Maybe Nat+    bar x@(Just _) = x+    bar Nothing = Nothing+    data Baz = Baz Nat Nat Nat+    baz_ :: Maybe Baz -> Maybe Baz+    baz_ p@Nothing = p+    baz_ p@(Just (Baz _ _ _)) = p+    tup :: (Nat, Nat) -> (Nat, Nat)+    tup p@(_, _) = p+    foo :: [Nat] -> [Nat]+    foo p@GHC.Types.[] = p+    foo p@[_] = p+    foo p@(_ GHC.Types.: _) = p+    type BazSym3 (t :: Nat) (t :: Nat) (t :: Nat) = Baz t t t+    instance SuppressUnusedWarnings BazSym2 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) BazSym2KindInference GHC.Tuple.())+    data BazSym2 (l :: Nat) (l :: Nat) (l :: TyFun Nat Baz)+      = forall arg. (GHC.Types.~) (KindOf (Apply (BazSym2 l l) arg)) (KindOf (BazSym3 l l arg)) =>+        BazSym2KindInference+    type instance Apply (BazSym2 l l) l = BazSym3 l l l+    instance SuppressUnusedWarnings BazSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) BazSym1KindInference GHC.Tuple.())+    data BazSym1 (l :: Nat) (l :: TyFun Nat (TyFun Nat Baz -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply (BazSym1 l) arg)) (KindOf (BazSym2 l arg)) =>+        BazSym1KindInference+    type instance Apply (BazSym1 l) l = BazSym2 l l+    instance SuppressUnusedWarnings BazSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) BazSym0KindInference GHC.Tuple.())+    data BazSym0 (l :: TyFun Nat (TyFun Nat (TyFun Nat Baz -> *) -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply BazSym0 arg)) (KindOf (BazSym1 arg)) =>+        BazSym0KindInference+    type instance Apply BazSym0 l = BazSym1 l+    type Let_0123456789PSym0 = Let_0123456789P+    type Let_0123456789P = GHC.Types.[]+    type Let_0123456789PSym1 t = Let_0123456789P t+    instance SuppressUnusedWarnings Let_0123456789PSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Let_0123456789PSym0KindInference GHC.Tuple.())+    data Let_0123456789PSym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Let_0123456789PSym0 arg)) (KindOf (Let_0123456789PSym1 arg)) =>+        Let_0123456789PSym0KindInference+    type instance Apply Let_0123456789PSym0 l = Let_0123456789PSym1 l+    type Let_0123456789P wild_0123456789 =+        Apply (Apply (:$) wild_0123456789) GHC.Types.[]+    type Let_0123456789PSym2 t t = Let_0123456789P t t+    instance SuppressUnusedWarnings Let_0123456789PSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Let_0123456789PSym1KindInference GHC.Tuple.())+    data Let_0123456789PSym1 l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Let_0123456789PSym1 l) arg)) (KindOf (Let_0123456789PSym2 l arg)) =>+        Let_0123456789PSym1KindInference+    type instance Apply (Let_0123456789PSym1 l) l = Let_0123456789PSym2 l l+    instance SuppressUnusedWarnings Let_0123456789PSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Let_0123456789PSym0KindInference GHC.Tuple.())+    data Let_0123456789PSym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Let_0123456789PSym0 arg)) (KindOf (Let_0123456789PSym1 arg)) =>+        Let_0123456789PSym0KindInference+    type instance Apply Let_0123456789PSym0 l = Let_0123456789PSym1 l+    type Let_0123456789P wild_0123456789 wild_0123456789 =+        Apply (Apply (:$) wild_0123456789) wild_0123456789+    type Let_0123456789PSym2 t t = Let_0123456789P t t+    instance SuppressUnusedWarnings Let_0123456789PSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Let_0123456789PSym1KindInference GHC.Tuple.())+    data Let_0123456789PSym1 l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Let_0123456789PSym1 l) arg)) (KindOf (Let_0123456789PSym2 l arg)) =>+        Let_0123456789PSym1KindInference+    type instance Apply (Let_0123456789PSym1 l) l = Let_0123456789PSym2 l l+    instance SuppressUnusedWarnings Let_0123456789PSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Let_0123456789PSym0KindInference GHC.Tuple.())+    data Let_0123456789PSym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Let_0123456789PSym0 arg)) (KindOf (Let_0123456789PSym1 arg)) =>+        Let_0123456789PSym0KindInference+    type instance Apply Let_0123456789PSym0 l = Let_0123456789PSym1 l+    type Let_0123456789P wild_0123456789 wild_0123456789 =+        Apply (Apply Tuple2Sym0 wild_0123456789) wild_0123456789+    type Let_0123456789PSym0 = Let_0123456789P+    type Let_0123456789P = NothingSym0+    type Let_0123456789PSym3 t t t = Let_0123456789P t t t+    instance SuppressUnusedWarnings Let_0123456789PSym2 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Let_0123456789PSym2KindInference GHC.Tuple.())+    data Let_0123456789PSym2 l l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Let_0123456789PSym2 l l) arg)) (KindOf (Let_0123456789PSym3 l l arg)) =>+        Let_0123456789PSym2KindInference+    type instance Apply (Let_0123456789PSym2 l l) l = Let_0123456789PSym3 l l l+    instance SuppressUnusedWarnings Let_0123456789PSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Let_0123456789PSym1KindInference GHC.Tuple.())+    data Let_0123456789PSym1 l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Let_0123456789PSym1 l) arg)) (KindOf (Let_0123456789PSym2 l arg)) =>+        Let_0123456789PSym1KindInference+    type instance Apply (Let_0123456789PSym1 l) l = Let_0123456789PSym2 l l+    instance SuppressUnusedWarnings Let_0123456789PSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Let_0123456789PSym0KindInference GHC.Tuple.())+    data Let_0123456789PSym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Let_0123456789PSym0 arg)) (KindOf (Let_0123456789PSym1 arg)) =>+        Let_0123456789PSym0KindInference+    type instance Apply Let_0123456789PSym0 l = Let_0123456789PSym1 l+    type Let_0123456789P wild_0123456789+                         wild_0123456789+                         wild_0123456789 =+        Apply JustSym0 (Apply (Apply (Apply BazSym0 wild_0123456789) wild_0123456789) wild_0123456789)+    type Let_0123456789XSym1 t = Let_0123456789X t+    instance SuppressUnusedWarnings Let_0123456789XSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Let_0123456789XSym0KindInference GHC.Tuple.())+    data Let_0123456789XSym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Let_0123456789XSym0 arg)) (KindOf (Let_0123456789XSym1 arg)) =>+        Let_0123456789XSym0KindInference+    type instance Apply Let_0123456789XSym0 l = Let_0123456789XSym1 l+    type Let_0123456789X wild_0123456789 =+        Apply JustSym0 wild_0123456789+    type Let_0123456789PSym0 = Let_0123456789P+    type Let_0123456789P = NothingSym0+    type FooSym1 (t :: GHC.Types.[] Nat) = Foo t+    instance SuppressUnusedWarnings FooSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) FooSym0KindInference GHC.Tuple.())+    data FooSym0 (l :: TyFun (GHC.Types.[] Nat) (GHC.Types.[] Nat))+      = forall arg. (GHC.Types.~) (KindOf (Apply FooSym0 arg)) (KindOf (FooSym1 arg)) =>+        FooSym0KindInference+    type instance Apply FooSym0 l = FooSym1 l+    type TupSym1 (t :: GHC.Tuple.(,) Nat Nat) = Tup t+    instance SuppressUnusedWarnings TupSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) TupSym0KindInference GHC.Tuple.())+    data TupSym0 (l :: TyFun (GHC.Tuple.(,) Nat Nat) (GHC.Tuple.(,) Nat Nat))+      = forall arg. (GHC.Types.~) (KindOf (Apply TupSym0 arg)) (KindOf (TupSym1 arg)) =>+        TupSym0KindInference+    type instance Apply TupSym0 l = TupSym1 l+    type Baz_Sym1 (t :: Maybe Baz) = Baz_ t+    instance SuppressUnusedWarnings Baz_Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Baz_Sym0KindInference GHC.Tuple.())+    data Baz_Sym0 (l :: TyFun (Maybe Baz) (Maybe Baz))+      = forall arg. (GHC.Types.~) (KindOf (Apply Baz_Sym0 arg)) (KindOf (Baz_Sym1 arg)) =>+        Baz_Sym0KindInference+    type instance Apply Baz_Sym0 l = Baz_Sym1 l+    type BarSym1 (t :: Maybe Nat) = Bar t+    instance SuppressUnusedWarnings BarSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) BarSym0KindInference GHC.Tuple.())+    data BarSym0 (l :: TyFun (Maybe Nat) (Maybe Nat))+      = forall arg. (GHC.Types.~) (KindOf (Apply BarSym0 arg)) (KindOf (BarSym1 arg)) =>+        BarSym0KindInference+    type instance Apply BarSym0 l = BarSym1 l+    type MaybePlusSym1 (t :: Maybe Nat) = MaybePlus t+    instance SuppressUnusedWarnings MaybePlusSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) MaybePlusSym0KindInference GHC.Tuple.())+    data MaybePlusSym0 (l :: TyFun (Maybe Nat) (Maybe Nat))+      = forall arg. (GHC.Types.~) (KindOf (Apply MaybePlusSym0 arg)) (KindOf (MaybePlusSym1 arg)) =>+        MaybePlusSym0KindInference+    type instance Apply MaybePlusSym0 l = MaybePlusSym1 l+    type family Foo (a :: GHC.Types.[] Nat) :: GHC.Types.[] Nat where+      Foo GHC.Types.[] = Let_0123456789PSym0+      Foo ((GHC.Types.:) wild_0123456789 GHC.Types.[]) = Let_0123456789PSym1 wild_0123456789+      Foo ((GHC.Types.:) wild_0123456789 wild_0123456789) = Let_0123456789PSym2 wild_0123456789 wild_0123456789+    type family Tup (a :: GHC.Tuple.(,) Nat Nat) :: GHC.Tuple.(,) Nat Nat where+      Tup (GHC.Tuple.(,) wild_0123456789 wild_0123456789) = Let_0123456789PSym2 wild_0123456789 wild_0123456789+    type family Baz_ (a :: Maybe Baz) :: Maybe Baz where+      Baz_ Nothing = Let_0123456789PSym0+      Baz_ (Just (Baz wild_0123456789 wild_0123456789 wild_0123456789)) = Let_0123456789PSym3 wild_0123456789 wild_0123456789 wild_0123456789+    type family Bar (a :: Maybe Nat) :: Maybe Nat where+      Bar (Just wild_0123456789) = Let_0123456789XSym1 wild_0123456789+      Bar Nothing = NothingSym0+    type family MaybePlus (a :: Maybe Nat) :: Maybe Nat where+      MaybePlus (Just n) = Apply JustSym0 (Apply (Apply PlusSym0 (Apply SuccSym0 ZeroSym0)) n)+      MaybePlus Nothing = Let_0123456789PSym0+    sFoo ::+      forall (t :: GHC.Types.[] Nat). Sing t -> Sing (Apply FooSym0 t)+    sTup ::+      forall (t :: GHC.Tuple.(,) Nat Nat).+      Sing t -> Sing (Apply TupSym0 t)+    sBaz_ :: forall (t :: Maybe Baz). Sing t -> Sing (Apply Baz_Sym0 t)+    sBar :: forall (t :: Maybe Nat). Sing t -> Sing (Apply BarSym0 t)+    sMaybePlus ::+      forall (t :: Maybe Nat). Sing t -> Sing (Apply MaybePlusSym0 t)+    sFoo SNil+      = let+          lambda ::+            (GHC.Types.~) t GHC.Types.[] => Sing (Apply FooSym0 GHC.Types.[])+          lambda+            = let+                sP :: Sing Let_0123456789PSym0+                sP = SNil+              in sP+        in lambda+    sFoo (SCons sWild_0123456789 SNil)+      = let+          lambda ::+            forall wild_0123456789. (GHC.Types.~) t (Apply (Apply (:$) wild_0123456789) GHC.Types.[]) =>+            Sing wild_0123456789+            -> Sing (Apply FooSym0 (Apply (Apply (:$) wild_0123456789) GHC.Types.[]))+          lambda wild_0123456789+            = let+                sP :: Sing (Let_0123456789PSym1 wild_0123456789)+                sP+                  = applySing+                      (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) wild_0123456789)+                      SNil+              in sP+        in lambda sWild_0123456789+    sFoo (SCons sWild_0123456789 sWild_0123456789)+      = let+          lambda ::+            forall wild_0123456789+                   wild_0123456789. (GHC.Types.~) t (Apply (Apply (:$) wild_0123456789) wild_0123456789) =>+            Sing wild_0123456789+            -> Sing wild_0123456789+               -> Sing (Apply FooSym0 (Apply (Apply (:$) wild_0123456789) wild_0123456789))+          lambda wild_0123456789 wild_0123456789+            = let+                sP :: Sing (Let_0123456789PSym2 wild_0123456789 wild_0123456789)+                sP+                  = applySing+                      (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) wild_0123456789)+                      wild_0123456789+              in sP+        in lambda sWild_0123456789 sWild_0123456789+    sTup (STuple2 sWild_0123456789 sWild_0123456789)+      = let+          lambda ::+            forall wild_0123456789+                   wild_0123456789. (GHC.Types.~) t (Apply (Apply Tuple2Sym0 wild_0123456789) wild_0123456789) =>+            Sing wild_0123456789+            -> Sing wild_0123456789+               -> Sing (Apply TupSym0 (Apply (Apply Tuple2Sym0 wild_0123456789) wild_0123456789))+          lambda wild_0123456789 wild_0123456789+            = let+                sP :: Sing (Let_0123456789PSym2 wild_0123456789 wild_0123456789)+                sP+                  = applySing+                      (applySing+                         (singFun2 (Proxy :: Proxy Tuple2Sym0) STuple2) wild_0123456789)+                      wild_0123456789+              in sP+        in lambda sWild_0123456789 sWild_0123456789+    sBaz_ SNothing+      = let+          lambda ::+            (GHC.Types.~) t NothingSym0 => Sing (Apply Baz_Sym0 NothingSym0)+          lambda+            = let+                sP :: Sing Let_0123456789PSym0+                sP = SNothing+              in sP+        in lambda+    sBaz_+      (SJust (SBaz sWild_0123456789 sWild_0123456789 sWild_0123456789))+      = let+          lambda ::+            forall wild_0123456789+                   wild_0123456789+                   wild_0123456789. (GHC.Types.~) t (Apply JustSym0 (Apply (Apply (Apply BazSym0 wild_0123456789) wild_0123456789) wild_0123456789)) =>+            Sing wild_0123456789+            -> Sing wild_0123456789+               -> Sing wild_0123456789+                  -> Sing (Apply Baz_Sym0 (Apply JustSym0 (Apply (Apply (Apply BazSym0 wild_0123456789) wild_0123456789) wild_0123456789)))+          lambda wild_0123456789 wild_0123456789 wild_0123456789+            = let+                sP ::+                  Sing (Let_0123456789PSym3 wild_0123456789 wild_0123456789 wild_0123456789)+                sP+                  = applySing+                      (singFun1 (Proxy :: Proxy JustSym0) SJust)+                      (applySing+                         (applySing+                            (applySing+                               (singFun3 (Proxy :: Proxy BazSym0) SBaz) wild_0123456789)+                            wild_0123456789)+                         wild_0123456789)+              in sP+        in lambda sWild_0123456789 sWild_0123456789 sWild_0123456789+    sBar (SJust sWild_0123456789)+      = let+          lambda ::+            forall wild_0123456789. (GHC.Types.~) t (Apply JustSym0 wild_0123456789) =>+            Sing wild_0123456789+            -> Sing (Apply BarSym0 (Apply JustSym0 wild_0123456789))+          lambda wild_0123456789+            = let+                sX :: Sing (Let_0123456789XSym1 wild_0123456789)+                sX+                  = applySing+                      (singFun1 (Proxy :: Proxy JustSym0) SJust) wild_0123456789+              in sX+        in lambda sWild_0123456789+    sBar SNothing+      = let+          lambda ::+            (GHC.Types.~) t NothingSym0 => Sing (Apply BarSym0 NothingSym0)+          lambda = SNothing+        in lambda+    sMaybePlus (SJust sN)+      = let+          lambda ::+            forall n. (GHC.Types.~) t (Apply JustSym0 n) =>+            Sing n -> Sing (Apply MaybePlusSym0 (Apply JustSym0 n))+          lambda n+            = applySing+                (singFun1 (Proxy :: Proxy JustSym0) SJust)+                (applySing+                   (applySing+                      (singFun2 (Proxy :: Proxy PlusSym0) sPlus)+                      (applySing (singFun1 (Proxy :: Proxy SuccSym0) SSucc) SZero))+                   n)+        in lambda sN+    sMaybePlus SNothing+      = let+          lambda ::+            (GHC.Types.~) t NothingSym0 =>+            Sing (Apply MaybePlusSym0 NothingSym0)+          lambda+            = let+                sP :: Sing Let_0123456789PSym0+                sP = SNothing+              in sP+        in lambda+    data instance Sing (z :: Baz)+      = forall (n :: Nat)+               (n :: Nat)+               (n :: Nat). (GHC.Types.~) z (Baz n n n) =>+        SBaz (Sing n) (Sing n) (Sing n)+    type SBaz (z :: Baz) = Sing z+    instance SingKind (KProxy :: KProxy Baz) where+      type DemoteRep (KProxy :: KProxy Baz) = Baz+      fromSing (SBaz b b b) = Baz (fromSing b) (fromSing b) (fromSing b)+      toSing (Baz b b b)+        = case+              GHC.Tuple.(,,)+                (toSing b :: SomeSing (KProxy :: KProxy Nat))+                (toSing b :: SomeSing (KProxy :: KProxy Nat))+                (toSing b :: SomeSing (KProxy :: KProxy Nat))+          of {+            GHC.Tuple.(,,) (SomeSing c) (SomeSing c) (SomeSing c)+              -> SomeSing (SBaz c c c) }+    instance (SingI n, SingI n, SingI n) =>+             SingI (Baz (n :: Nat) (n :: Nat) (n :: Nat)) where+      sing = SBaz sing sing sing
+ tests/compile-and-dump/Singletons/AsPattern.hs view
@@ -0,0 +1,33 @@+module Singletons.AsPattern where++import Data.Proxy+import Data.Singletons+import Data.Singletons.TH+import Data.Singletons.Prelude.Maybe+import Data.Singletons.Prelude.List+import Singletons.Nat+import Data.Singletons.SuppressUnusedWarnings++$(singletons [d|+  maybePlus :: Maybe Nat -> Maybe Nat+  maybePlus (Just n) = Just (plus (Succ Zero) n)+  maybePlus p@Nothing = p++  bar :: Maybe Nat -> Maybe Nat+  bar x@(Just _) = x+  bar Nothing = Nothing++  data Baz = Baz Nat Nat Nat++  baz_ :: Maybe Baz -> Maybe Baz+  baz_ p@Nothing            = p+  baz_ p@(Just (Baz _ _ _)) = p++  tup :: (Nat, Nat) -> (Nat, Nat)+  tup p@(_, _) = p++  foo :: [Nat] -> [Nat]+  foo p@[]    = p+  foo p@[_]   = p+  foo p@(_:_) = p+ |])
− 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 view
@@ -2,15 +2,22 @@     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 BoxTyCtor = Box+    data BoxTyCtorSym0 (k :: TyFun * *)+    type instance Apply BoxTyCtorSym0 a = BoxTyCtor a+    data FBoxSym0 (k :: TyFun a (Box a))+    type instance Apply FBoxSym0 a = FBox a     type family UnBox (a :: Box a) :: a+    type instance UnBox (FBox a) = a+    data UnBoxSym0 (k :: TyFun (Box a) a)+    type instance Apply UnBoxSym0 a = UnBox a     data instance Sing (z :: Box a)       = forall (n :: a). z ~ FBox n => SFBox (Sing n)     type SBox (z :: Box a) = Sing z
tests/compile-and-dump/Singletons/BoxUnBox.ghc78.template view
@@ -2,17 +2,41 @@     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 FBoxSym1 (t :: a) = FBox t+    instance SuppressUnusedWarnings FBoxSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) FBoxSym0KindInference GHC.Tuple.())+    data FBoxSym0 (l :: TyFun a (Box a))+      = forall arg. (GHC.Types.~) (KindOf (Apply FBoxSym0 arg)) (KindOf (FBoxSym1 arg)) =>+        FBoxSym0KindInference+    type instance Apply FBoxSym0 l = FBoxSym1 l+    type UnBoxSym1 (t :: Box a) = UnBox t+    instance SuppressUnusedWarnings UnBoxSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) UnBoxSym0KindInference GHC.Tuple.())+    data UnBoxSym0 (l :: TyFun (Box a) a)+      = forall arg. (GHC.Types.~) (KindOf (Apply UnBoxSym0 arg)) (KindOf (UnBoxSym1 arg)) =>+        UnBoxSym0KindInference+    type instance Apply UnBoxSym0 l = UnBoxSym1 l     type family UnBox (a :: Box a) :: a where-         UnBox (FBox a) = a+      UnBox (FBox a) = a+    sUnBox :: forall (t :: Box a). Sing t -> Sing (Apply UnBoxSym0 t)+    sUnBox (SFBox sA)+      = let+          lambda ::+            forall a. (GHC.Types.~) t (Apply FBoxSym0 a) =>+            Sing a -> Sing (Apply UnBoxSym0 (Apply FBoxSym0 a))+          lambda a = a+        in lambda sA     data instance Sing (z :: Box a)-      = forall (n :: a). z ~ FBox n => SFBox (Sing n)+      = forall (n :: a). (GHC.Types.~) z (FBox n) => SFBox (Sing n)     type SBox (z :: Box a) = Sing z     instance SingKind (KProxy :: KProxy a) =>              SingKind (KProxy :: KProxy (Box a)) where@@ -23,5 +47,3 @@             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 view
@@ -1,6 +1,9 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+ module Singletons.BoxUnBox where  import Data.Singletons.TH+import Data.Singletons.SuppressUnusedWarnings  $(singletons [d|   data Box a = FBox a
+ tests/compile-and-dump/Singletons/CaseExpressions.ghc76.template view
@@ -0,0 +1,97 @@+Promote/CaseExpressions.hs:0:0: Splicing declarations+    promote+      [d| foo1 :: a -> Maybe a -> a+          foo1 d x+            = case x of {+                Just y -> y+                Nothing -> d }+          foo2 :: a -> Maybe a -> a+          foo2 d _+            = case (Just d) of {+                Just y -> y+                Nothing -> d }+          foo3 :: a -> b -> a+          foo3 a b = case (a, b) of { (p, _) -> p }+          foo4 :: forall a. a -> a+          foo4 x+            = case x of {+                y -> let+                       z :: a+                       z = y+                     in z }+          foo5 :: a -> a+          foo5 x = case x of { y -> (\ _ -> x) y } |]+  ======>+    Promote/CaseExpressions.hs:(0,0)-(0,0)+    foo1 :: forall a. a -> Maybe a -> a+    foo1 d x+      = case x of {+          Just y -> y+          Nothing -> d }+    foo2 :: forall a. a -> Maybe a -> a+    foo2 d _+      = case Just d of {+          Just y -> y+          Nothing -> d }+    foo3 :: forall a b. a -> b -> a+    foo3 a b = case (a, b) of { (p, _) -> p }+    foo4 :: forall a. a -> a+    foo4 x+      = case x of {+          y -> let+                 z :: a+                 z = y+               in z }+    foo5 :: forall a. a -> a+    foo5 x = case x of { y -> \ _ -> x y }+    type family Case_0123456789 (t :: k) (d :: d) (x :: x) :: r+    type instance Case_0123456789 (Just y) d x = y+    type instance Case_0123456789 Nothing d x = d+    type family Case_0123456789 (t :: k) (d :: d) :: r+    type instance Case_0123456789 (Just y) d = y+    type instance Case_0123456789 Nothing d = d+    type family Case_0123456789 (t :: k) (a :: a) (b :: b) :: r+    type instance Case_0123456789 '(p, z) a b = p+    type family Let_0123456789z (a :: x) (a :: y) :: a+    type instance Let_0123456789z x y = y+    data Let_0123456789zSym1 (l :: x) (l :: TyFun y a)+    data Let_0123456789zSym0 (k :: TyFun x (TyFun y a -> *))+    type instance Apply (Let_0123456789zSym1 a) a = Let_0123456789z a a+    type instance Apply Let_0123456789zSym0 a = Let_0123456789zSym1 a+    type family Case_0123456789 (t :: k) (x :: x) :: r+    type instance Case_0123456789 y x =+        Apply (Apply Let_0123456789zSym0 x) y+    type family Lambda_0123456789 (x :: x) (y :: y) (t :: k) :: r+    type instance Lambda_0123456789 x y z = x+    data Lambda_0123456789Sym2 (l :: x) (l :: y) (l :: TyFun k r)+    type instance Apply (Lambda_0123456789Sym2 a a) a =+        Lambda_0123456789 a a a+    type family Case_0123456789 (t :: k) (x :: x) :: r+    type instance Case_0123456789 y x =+        Apply (Lambda_0123456789Sym2 x y) y+    type family Foo1 (a :: a) (a :: Maybe a) :: a+    type instance Foo1 d x = Case_0123456789 x d x+    data Foo1Sym1 (l :: a) (l :: TyFun (Maybe a) a)+    data Foo1Sym0 (k :: TyFun a (TyFun (Maybe a) a -> *))+    type instance Apply (Foo1Sym1 a) a = Foo1 a a+    type instance Apply Foo1Sym0 a = Foo1Sym1 a+    type family Foo2 (a :: a) (a :: Maybe a) :: a+    type instance Foo2 d z = Case_0123456789 (Apply JustSym0 d) d+    data Foo2Sym1 (l :: a) (l :: TyFun (Maybe a) a)+    data Foo2Sym0 (k :: TyFun a (TyFun (Maybe a) a -> *))+    type instance Apply (Foo2Sym1 a) a = Foo2 a a+    type instance Apply Foo2Sym0 a = Foo2Sym1 a+    type family Foo3 (a :: a) (a :: b) :: a+    type instance Foo3 a b = Case_0123456789 '(a, b) a b+    data Foo3Sym1 (l :: a) (l :: TyFun b a)+    data Foo3Sym0 (k :: TyFun a (TyFun b a -> *))+    type instance Apply (Foo3Sym1 a) a = Foo3 a a+    type instance Apply Foo3Sym0 a = Foo3Sym1 a+    type family Foo4 (a :: a) :: a+    type instance Foo4 x = Case_0123456789 x x+    data Foo4Sym0 (k :: TyFun a a)+    type instance Apply Foo4Sym0 a = Foo4 a+    type family Foo5 (a :: a) :: a+    type instance Foo5 x = Case_0123456789 x x+    data Foo5Sym0 (k :: TyFun a a)+    type instance Apply Foo5Sym0 a = Foo5 a
+ tests/compile-and-dump/Singletons/CaseExpressions.ghc78.template view
@@ -0,0 +1,381 @@+Singletons/CaseExpressions.hs:0:0: Splicing declarations+    singletons+      [d| foo1 :: a -> Maybe a -> a+          foo1 d x+            = case x of {+                Just y -> y+                Nothing -> d }+          foo2 :: a -> Maybe a -> a+          foo2 d _ = case (Just d) of { Just y -> y }+          foo3 :: a -> b -> a+          foo3 a b = case (a, b) of { (p, _) -> p }+          foo4 :: forall a. a -> a+          foo4 x+            = case x of {+                y -> let+                       z :: a+                       z = y+                     in z }+          foo5 :: a -> a+          foo5 x = case x of { y -> (\ _ -> x) y } |]+  ======>+    Singletons/CaseExpressions.hs:(0,0)-(0,0)+    foo1 :: forall a. a -> Maybe a -> a+    foo1 d x+      = case x of {+          Just y -> y+          Nothing -> d }+    foo2 :: forall a. a -> Maybe a -> a+    foo2 d _ = case Just d of { Just y -> y }+    foo3 :: forall a b. a -> b -> a+    foo3 a b = case (a, b) of { (p, _) -> p }+    foo4 :: forall a. a -> a+    foo4 x+      = case x of {+          y -> let+                 z :: a+                 z = y+               in z }+    foo5 :: forall a. a -> a+    foo5 x = case x of { y -> \ _ -> x y }+    type Let_0123456789Scrutinee_0123456789Sym1 t =+        Let_0123456789Scrutinee_0123456789 t+    instance SuppressUnusedWarnings Let_0123456789Scrutinee_0123456789Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,)+               Let_0123456789Scrutinee_0123456789Sym0KindInference GHC.Tuple.())+    data Let_0123456789Scrutinee_0123456789Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Let_0123456789Scrutinee_0123456789Sym0 arg)) (KindOf (Let_0123456789Scrutinee_0123456789Sym1 arg)) =>+        Let_0123456789Scrutinee_0123456789Sym0KindInference+    type instance Apply Let_0123456789Scrutinee_0123456789Sym0 l = Let_0123456789Scrutinee_0123456789Sym1 l+    type Let_0123456789Scrutinee_0123456789 x = x+    type family Case_0123456789 x y arg_0123456789 t where+      Case_0123456789 x y arg_0123456789 z = x+    type family Lambda_0123456789 x y t where+      Lambda_0123456789 x y arg_0123456789 = Case_0123456789 x y arg_0123456789 arg_0123456789+    type Lambda_0123456789Sym3 t t t = Lambda_0123456789 t t t+    instance SuppressUnusedWarnings Lambda_0123456789Sym2 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym2KindInference GHC.Tuple.())+    data Lambda_0123456789Sym2 l l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym2 l l) arg)) (KindOf (Lambda_0123456789Sym3 l l arg)) =>+        Lambda_0123456789Sym2KindInference+    type instance Apply (Lambda_0123456789Sym2 l l) l = Lambda_0123456789Sym3 l l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym1 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym1KindInference GHC.Tuple.())+    data Lambda_0123456789Sym1 l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym1 l) arg)) (KindOf (Lambda_0123456789Sym2 l arg)) =>+        Lambda_0123456789Sym1KindInference+    type instance Apply (Lambda_0123456789Sym1 l) l = Lambda_0123456789Sym2 l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym0KindInference GHC.Tuple.())+    data Lambda_0123456789Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Lambda_0123456789Sym0 arg)) (KindOf (Lambda_0123456789Sym1 arg)) =>+        Lambda_0123456789Sym0KindInference+    type instance Apply Lambda_0123456789Sym0 l = Lambda_0123456789Sym1 l+    type family Case_0123456789 x t where+      Case_0123456789 x y = Apply (Apply (Apply Lambda_0123456789Sym0 x) y) y+    type Let_0123456789Scrutinee_0123456789Sym1 t =+        Let_0123456789Scrutinee_0123456789 t+    instance SuppressUnusedWarnings Let_0123456789Scrutinee_0123456789Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,)+               Let_0123456789Scrutinee_0123456789Sym0KindInference GHC.Tuple.())+    data Let_0123456789Scrutinee_0123456789Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Let_0123456789Scrutinee_0123456789Sym0 arg)) (KindOf (Let_0123456789Scrutinee_0123456789Sym1 arg)) =>+        Let_0123456789Scrutinee_0123456789Sym0KindInference+    type instance Apply Let_0123456789Scrutinee_0123456789Sym0 l = Let_0123456789Scrutinee_0123456789Sym1 l+    type Let_0123456789Scrutinee_0123456789 x = x+    type Let_0123456789ZSym2 t t = Let_0123456789Z t t+    instance SuppressUnusedWarnings Let_0123456789ZSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Let_0123456789ZSym1KindInference GHC.Tuple.())+    data Let_0123456789ZSym1 l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Let_0123456789ZSym1 l) arg)) (KindOf (Let_0123456789ZSym2 l arg)) =>+        Let_0123456789ZSym1KindInference+    type instance Apply (Let_0123456789ZSym1 l) l = Let_0123456789ZSym2 l l+    instance SuppressUnusedWarnings Let_0123456789ZSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Let_0123456789ZSym0KindInference GHC.Tuple.())+    data Let_0123456789ZSym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Let_0123456789ZSym0 arg)) (KindOf (Let_0123456789ZSym1 arg)) =>+        Let_0123456789ZSym0KindInference+    type instance Apply Let_0123456789ZSym0 l = Let_0123456789ZSym1 l+    type Let_0123456789Z x y = (y :: a)+    type family Case_0123456789 x t where+      Case_0123456789 x y = Let_0123456789ZSym2 x y+    type Let_0123456789Scrutinee_0123456789Sym2 t t =+        Let_0123456789Scrutinee_0123456789 t t+    instance SuppressUnusedWarnings Let_0123456789Scrutinee_0123456789Sym1 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,)+               Let_0123456789Scrutinee_0123456789Sym1KindInference GHC.Tuple.())+    data Let_0123456789Scrutinee_0123456789Sym1 l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Let_0123456789Scrutinee_0123456789Sym1 l) arg)) (KindOf (Let_0123456789Scrutinee_0123456789Sym2 l arg)) =>+        Let_0123456789Scrutinee_0123456789Sym1KindInference+    type instance Apply (Let_0123456789Scrutinee_0123456789Sym1 l) l = Let_0123456789Scrutinee_0123456789Sym2 l l+    instance SuppressUnusedWarnings Let_0123456789Scrutinee_0123456789Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,)+               Let_0123456789Scrutinee_0123456789Sym0KindInference GHC.Tuple.())+    data Let_0123456789Scrutinee_0123456789Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Let_0123456789Scrutinee_0123456789Sym0 arg)) (KindOf (Let_0123456789Scrutinee_0123456789Sym1 arg)) =>+        Let_0123456789Scrutinee_0123456789Sym0KindInference+    type instance Apply Let_0123456789Scrutinee_0123456789Sym0 l = Let_0123456789Scrutinee_0123456789Sym1 l+    type Let_0123456789Scrutinee_0123456789 a b =+        Apply (Apply Tuple2Sym0 a) b+    type family Case_0123456789 a b t where+      Case_0123456789 a b (GHC.Tuple.(,) p z) = p+    type Let_0123456789Scrutinee_0123456789Sym1 t =+        Let_0123456789Scrutinee_0123456789 t+    instance SuppressUnusedWarnings Let_0123456789Scrutinee_0123456789Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,)+               Let_0123456789Scrutinee_0123456789Sym0KindInference GHC.Tuple.())+    data Let_0123456789Scrutinee_0123456789Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Let_0123456789Scrutinee_0123456789Sym0 arg)) (KindOf (Let_0123456789Scrutinee_0123456789Sym1 arg)) =>+        Let_0123456789Scrutinee_0123456789Sym0KindInference+    type instance Apply Let_0123456789Scrutinee_0123456789Sym0 l = Let_0123456789Scrutinee_0123456789Sym1 l+    type Let_0123456789Scrutinee_0123456789 d = Apply JustSym0 d+    type family Case_0123456789 d t where+      Case_0123456789 d (Just y) = y+    type Let_0123456789Scrutinee_0123456789Sym2 t t =+        Let_0123456789Scrutinee_0123456789 t t+    instance SuppressUnusedWarnings Let_0123456789Scrutinee_0123456789Sym1 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,)+               Let_0123456789Scrutinee_0123456789Sym1KindInference GHC.Tuple.())+    data Let_0123456789Scrutinee_0123456789Sym1 l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Let_0123456789Scrutinee_0123456789Sym1 l) arg)) (KindOf (Let_0123456789Scrutinee_0123456789Sym2 l arg)) =>+        Let_0123456789Scrutinee_0123456789Sym1KindInference+    type instance Apply (Let_0123456789Scrutinee_0123456789Sym1 l) l = Let_0123456789Scrutinee_0123456789Sym2 l l+    instance SuppressUnusedWarnings Let_0123456789Scrutinee_0123456789Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,)+               Let_0123456789Scrutinee_0123456789Sym0KindInference GHC.Tuple.())+    data Let_0123456789Scrutinee_0123456789Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Let_0123456789Scrutinee_0123456789Sym0 arg)) (KindOf (Let_0123456789Scrutinee_0123456789Sym1 arg)) =>+        Let_0123456789Scrutinee_0123456789Sym0KindInference+    type instance Apply Let_0123456789Scrutinee_0123456789Sym0 l = Let_0123456789Scrutinee_0123456789Sym1 l+    type Let_0123456789Scrutinee_0123456789 d x = x+    type family Case_0123456789 d x t where+      Case_0123456789 d x (Just y) = y+      Case_0123456789 d x Nothing = d+    type Foo5Sym1 (t :: a) = Foo5 t+    instance SuppressUnusedWarnings Foo5Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo5Sym0KindInference GHC.Tuple.())+    data Foo5Sym0 (l :: TyFun a a)+      = forall arg. (GHC.Types.~) (KindOf (Apply Foo5Sym0 arg)) (KindOf (Foo5Sym1 arg)) =>+        Foo5Sym0KindInference+    type instance Apply Foo5Sym0 l = Foo5Sym1 l+    type Foo4Sym1 (t :: a) = Foo4 t+    instance SuppressUnusedWarnings Foo4Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo4Sym0KindInference GHC.Tuple.())+    data Foo4Sym0 (l :: TyFun a a)+      = forall arg. (GHC.Types.~) (KindOf (Apply Foo4Sym0 arg)) (KindOf (Foo4Sym1 arg)) =>+        Foo4Sym0KindInference+    type instance Apply Foo4Sym0 l = Foo4Sym1 l+    type Foo3Sym2 (t :: a) (t :: b) = Foo3 t t+    instance SuppressUnusedWarnings Foo3Sym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo3Sym1KindInference GHC.Tuple.())+    data Foo3Sym1 (l :: a) (l :: TyFun b a)+      = forall arg. (GHC.Types.~) (KindOf (Apply (Foo3Sym1 l) arg)) (KindOf (Foo3Sym2 l arg)) =>+        Foo3Sym1KindInference+    type instance Apply (Foo3Sym1 l) l = Foo3Sym2 l l+    instance SuppressUnusedWarnings Foo3Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo3Sym0KindInference GHC.Tuple.())+    data Foo3Sym0 (l :: TyFun a (TyFun b a -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply Foo3Sym0 arg)) (KindOf (Foo3Sym1 arg)) =>+        Foo3Sym0KindInference+    type instance Apply Foo3Sym0 l = Foo3Sym1 l+    type Foo2Sym2 (t :: a) (t :: Maybe a) = Foo2 t t+    instance SuppressUnusedWarnings Foo2Sym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo2Sym1KindInference GHC.Tuple.())+    data Foo2Sym1 (l :: a) (l :: TyFun (Maybe a) a)+      = forall arg. (GHC.Types.~) (KindOf (Apply (Foo2Sym1 l) arg)) (KindOf (Foo2Sym2 l arg)) =>+        Foo2Sym1KindInference+    type instance Apply (Foo2Sym1 l) l = Foo2Sym2 l l+    instance SuppressUnusedWarnings Foo2Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo2Sym0KindInference GHC.Tuple.())+    data Foo2Sym0 (l :: TyFun a (TyFun (Maybe a) a -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply Foo2Sym0 arg)) (KindOf (Foo2Sym1 arg)) =>+        Foo2Sym0KindInference+    type instance Apply Foo2Sym0 l = Foo2Sym1 l+    type Foo1Sym2 (t :: a) (t :: Maybe a) = Foo1 t t+    instance SuppressUnusedWarnings Foo1Sym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo1Sym1KindInference GHC.Tuple.())+    data Foo1Sym1 (l :: a) (l :: TyFun (Maybe a) a)+      = forall arg. (GHC.Types.~) (KindOf (Apply (Foo1Sym1 l) arg)) (KindOf (Foo1Sym2 l arg)) =>+        Foo1Sym1KindInference+    type instance Apply (Foo1Sym1 l) l = Foo1Sym2 l l+    instance SuppressUnusedWarnings Foo1Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo1Sym0KindInference GHC.Tuple.())+    data Foo1Sym0 (l :: TyFun a (TyFun (Maybe a) a -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply Foo1Sym0 arg)) (KindOf (Foo1Sym1 arg)) =>+        Foo1Sym0KindInference+    type instance Apply Foo1Sym0 l = Foo1Sym1 l+    type family Foo5 (a :: a) :: a where+      Foo5 x = Case_0123456789 x (Let_0123456789Scrutinee_0123456789Sym1 x)+    type family Foo4 (a :: a) :: a where+      Foo4 x = Case_0123456789 x (Let_0123456789Scrutinee_0123456789Sym1 x)+    type family Foo3 (a :: a) (a :: b) :: a where+      Foo3 a b = Case_0123456789 a b (Let_0123456789Scrutinee_0123456789Sym2 a b)+    type family Foo2 (a :: a) (a :: Maybe a) :: a where+      Foo2 d z = Case_0123456789 d (Let_0123456789Scrutinee_0123456789Sym1 d)+    type family Foo1 (a :: a) (a :: Maybe a) :: a where+      Foo1 d x = Case_0123456789 d x (Let_0123456789Scrutinee_0123456789Sym2 d x)+    sFoo5 :: forall (t :: a). Sing t -> Sing (Apply Foo5Sym0 t)+    sFoo4 :: forall (t :: a). Sing t -> Sing (Apply Foo4Sym0 t)+    sFoo3 ::+      forall (t :: a) (t :: b).+      Sing t -> Sing t -> Sing (Apply (Apply Foo3Sym0 t) t)+    sFoo2 ::+      forall (t :: a) (t :: Maybe a).+      Sing t -> Sing t -> Sing (Apply (Apply Foo2Sym0 t) t)+    sFoo1 ::+      forall (t :: a) (t :: Maybe a).+      Sing t -> Sing t -> Sing (Apply (Apply Foo1Sym0 t) t)+    sFoo5 sX+      = let+          lambda ::+            forall x. (GHC.Types.~) t x => Sing x -> Sing (Apply Foo5Sym0 x)+          lambda x+            = let+                sScrutinee_0123456789 ::+                  Sing (Let_0123456789Scrutinee_0123456789Sym1 x)+                sScrutinee_0123456789 = x+              in+                case sScrutinee_0123456789 of {+                  sY+                    -> let+                         lambda :: forall y. Sing y -> Sing (Case_0123456789 x y)+                         lambda y+                           = applySing+                               (singFun1+                                  (Proxy :: Proxy (Apply (Apply Lambda_0123456789Sym0 x) y))+                                  (\ sArg_0123456789+                                     -> let+                                          lambda ::+                                            forall arg_0123456789.+                                            Sing arg_0123456789+                                            -> Sing (Apply (Apply (Apply Lambda_0123456789Sym0 x) y) arg_0123456789)+                                          lambda arg_0123456789+                                            = case arg_0123456789 of {+                                                _ -> let+                                                       lambda ::+                                                         forall wild.+                                                         Sing (Case_0123456789 x y arg_0123456789 wild)+                                                       lambda = x+                                                     in lambda }+                                        in lambda sArg_0123456789))+                               y+                       in lambda sY }+        in lambda sX+    sFoo4 sX+      = let+          lambda ::+            forall x. (GHC.Types.~) t x => Sing x -> Sing (Apply Foo4Sym0 x)+          lambda x+            = let+                sScrutinee_0123456789 ::+                  Sing (Let_0123456789Scrutinee_0123456789Sym1 x)+                sScrutinee_0123456789 = x+              in+                case sScrutinee_0123456789 of {+                  sY+                    -> let+                         lambda :: forall y. Sing y -> Sing (Case_0123456789 x y)+                         lambda y+                           = let+                               sZ :: Sing (Let_0123456789ZSym2 x y)+                               sZ = y+                             in sZ+                       in lambda sY }+        in lambda sX+    sFoo3 sA sB+      = let+          lambda ::+            forall a b. ((GHC.Types.~) t a, (GHC.Types.~) t b) =>+            Sing a -> Sing b -> Sing (Apply (Apply Foo3Sym0 a) b)+          lambda a b+            = let+                sScrutinee_0123456789 ::+                  Sing (Let_0123456789Scrutinee_0123456789Sym2 a b)+                sScrutinee_0123456789+                  = applySing+                      (applySing (singFun2 (Proxy :: Proxy Tuple2Sym0) STuple2) a) b+              in+                case sScrutinee_0123456789 of {+                  STuple2 sP _+                    -> let+                         lambda ::+                           forall p wild.+                           Sing p+                           -> Sing (Case_0123456789 a b (Apply (Apply Tuple2Sym0 p) wild))+                         lambda p = p+                       in lambda sP }+        in lambda sA sB+    sFoo2 sD _+      = let+          lambda ::+            forall d wild. ((GHC.Types.~) t d, (GHC.Types.~) t wild) =>+            Sing d -> Sing (Apply (Apply Foo2Sym0 d) wild)+          lambda d+            = let+                sScrutinee_0123456789 ::+                  Sing (Let_0123456789Scrutinee_0123456789Sym1 d)+                sScrutinee_0123456789+                  = applySing (singFun1 (Proxy :: Proxy JustSym0) SJust) d+              in+                case sScrutinee_0123456789 of {+                  SJust sY+                    -> let+                         lambda ::+                           forall y. Sing y -> Sing (Case_0123456789 d (Apply JustSym0 y))+                         lambda y = y+                       in lambda sY }+        in lambda sD+    sFoo1 sD sX+      = let+          lambda ::+            forall d x. ((GHC.Types.~) t d, (GHC.Types.~) t x) =>+            Sing d -> Sing x -> Sing (Apply (Apply Foo1Sym0 d) x)+          lambda d x+            = let+                sScrutinee_0123456789 ::+                  Sing (Let_0123456789Scrutinee_0123456789Sym2 d x)+                sScrutinee_0123456789 = x+              in+                case sScrutinee_0123456789 of {+                  SJust sY+                    -> let+                         lambda ::+                           forall y. Sing y -> Sing (Case_0123456789 d x (Apply JustSym0 y))+                         lambda y = y+                       in lambda sY+                  SNothing+                    -> let+                         lambda :: Sing (Case_0123456789 d x NothingSym0)+                         lambda = d+                       in lambda }+        in lambda sD sX
+ tests/compile-and-dump/Singletons/CaseExpressions.hs view
@@ -0,0 +1,67 @@+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}++module Singletons.CaseExpressions where++import Data.Singletons+import Data.Singletons.TH+import Data.Singletons.Prelude.Maybe+import Data.Singletons.SuppressUnusedWarnings++$(singletons [d|+  foo1 :: a -> Maybe a -> a+  foo1 d x = case x of+               Just y  -> y+               Nothing -> d++  foo2 :: a -> Maybe a -> a+  foo2 d _ = case (Just d) of+               Just y  -> y+--               Nothing -> d+-- the above line causes an "inaccessible code" error. w00t.++  foo3 :: a -> b -> a+  foo3 a b = case (a, b) of+               (p, _)  -> p+++  foo4 :: forall a. a -> a+  foo4 x = case x of+             y -> let z :: a+                      z = y+                  in z++  foo5 :: a -> a+  foo5 x = case x of+             y -> (\_ -> x) y+ |])++foo1a :: Proxy (Foo1 Int (Just Char))+foo1a = Proxy++foo1b :: Proxy Char+foo1b = foo1a++foo2a :: Proxy (Foo2 Char Nothing)+foo2a = Proxy++foo2b :: Proxy Char+foo2b = foo2a++foo3a :: Proxy (Foo3 Int Char)+foo3a = Proxy++foo3b :: Proxy Int+foo3b = foo3a++foo4a :: Proxy (Foo4 Int)+foo4a = Proxy++foo4b :: Proxy Int+foo4b = foo4a++foo5a :: Proxy (Foo5 Int)+foo5a = Proxy++foo5b :: Proxy Int+foo5b = foo5a
tests/compile-and-dump/Singletons/Contains.ghc76.template view
@@ -8,10 +8,14 @@     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+    type instance Contains z GHC.Types.[] = FalseSym0+    type instance Contains elt (GHC.Types.: h t) =+        Apply (Apply :||$ (Apply (Apply :==$ elt) h)) (Apply (Apply ContainsSym0 elt) t)+    data ContainsSym1 (l :: a) (l :: TyFun [a] Bool)+    data ContainsSym0 (k :: TyFun a (TyFun [a] Bool -> *))+    type instance Apply (ContainsSym1 a) a = Contains a a+    type instance Apply ContainsSym0 a = ContainsSym1 a     sContains ::       forall (t :: a) (t :: [a]). SEq (KProxy :: KProxy a) =>       Sing t -> Sing t -> Sing (Contains t t)
tests/compile-and-dump/Singletons/Contains.ghc78.template view
@@ -8,11 +8,51 @@     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)+    type ContainsSym2 (t :: a) (t :: GHC.Types.[] a) = Contains t t+    instance SuppressUnusedWarnings ContainsSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) ContainsSym1KindInference GHC.Tuple.())+    data ContainsSym1 (l :: a) (l :: TyFun (GHC.Types.[] a) Bool)+      = forall arg. (GHC.Types.~) (KindOf (Apply (ContainsSym1 l) arg)) (KindOf (ContainsSym2 l arg)) =>+        ContainsSym1KindInference+    type instance Apply (ContainsSym1 l) l = ContainsSym2 l l+    instance SuppressUnusedWarnings ContainsSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) ContainsSym0KindInference GHC.Tuple.())+    data ContainsSym0 (l :: TyFun a (TyFun (GHC.Types.[] a) Bool -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply ContainsSym0 arg)) (KindOf (ContainsSym1 arg)) =>+        ContainsSym0KindInference+    type instance Apply ContainsSym0 l = ContainsSym1 l+    type family Contains (a :: a) (a :: GHC.Types.[] a) :: Bool where+      Contains z GHC.Types.[] = FalseSym0+      Contains elt ((GHC.Types.:) h t) = Apply (Apply (:||$) (Apply (Apply (:==$) elt) h)) (Apply (Apply ContainsSym0 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)+      forall (t :: a) (t :: GHC.Types.[] a). SEq (KProxy :: KProxy a) =>+      Sing t -> Sing t -> Sing (Apply (Apply ContainsSym0 t) t)+    sContains _ SNil+      = let+          lambda ::+            forall wild. ((GHC.Types.~) t wild,+                          (GHC.Types.~) t GHC.Types.[]) =>+            Sing (Apply (Apply ContainsSym0 wild) GHC.Types.[])+          lambda = SFalse+        in lambda+    sContains sElt (SCons sH sT)+      = let+          lambda ::+            forall elt h t. ((GHC.Types.~) t elt,+                             (GHC.Types.~) t (Apply (Apply (:$) h) t)) =>+            Sing elt+            -> Sing h+               -> Sing t+                  -> Sing (Apply (Apply ContainsSym0 elt) (Apply (Apply (:$) h) t))+          lambda elt h t+            = applySing+                (applySing+                   (singFun2 (Proxy :: Proxy (:||$)) (%:||))+                   (applySing+                      (applySing (singFun2 (Proxy :: Proxy (:==$)) (%:==)) elt) h))+                (applySing+                   (applySing (singFun2 (Proxy :: Proxy ContainsSym0) sContains) elt)+                   t)+        in lambda sElt sH sT
tests/compile-and-dump/Singletons/Contains.hs view
@@ -1,10 +1,10 @@ module Singletons.Contains where  import Data.Singletons.TH-import Data.Singletons.List-import Data.Singletons.Bool+import Data.Singletons.Prelude+import Data.Singletons.SuppressUnusedWarnings --- polimorphic function with context+-- polymorphic function with context  $(singletons [d|   contains :: Eq a => a -> [a] -> Bool
tests/compile-and-dump/Singletons/DataValues.ghc76.template view
@@ -4,7 +4,7 @@           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) |]@@ -17,10 +17,28 @@     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)]+    type PairTyCtor = Pair+    data PairTyCtorSym1 (l :: *) (l :: TyFun * *)+    data PairTyCtorSym0 (k :: TyFun * (TyFun * * -> *))+    type instance Apply (PairTyCtorSym1 a) a = PairTyCtor a a+    type instance Apply PairTyCtorSym0 a = PairTyCtorSym1 a+    data PairSym1 (l :: a) (l :: TyFun b (Pair a b))+    data PairSym0 (k :: TyFun a (TyFun b (Pair a b) -> *))+    type instance Apply (PairSym1 a) a = Pair a a+    type instance Apply PairSym0 a = PairSym1 a+    type Pr =+        Apply (Apply PairSym0 (Apply SuccSym0 ZeroSym0)) '[ZeroSym0]+    type PrSym0 = Pr+    type Complex =+        Apply (Apply PairSym0 (Apply (Apply PairSym0 (Apply JustSym0 ZeroSym0)) ZeroSym0)) FalseSym0+    type ComplexSym0 = Complex+    type Tuple = '(FalseSym0, Apply JustSym0 ZeroSym0, TrueSym0)+    type TupleSym0 = Tuple+    type AList =+        '[ZeroSym0,+          Apply SuccSym0 ZeroSym0,+          Apply SuccSym0 (Apply SuccSym0 ZeroSym0)]+    type AListSym0 = AList     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@@ -32,7 +50,7 @@       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 a),                 toSing b :: SomeSing (KProxy :: KProxy b))           of {             (SomeSing c, SomeSing c) -> SomeSing (SPair c c) }
tests/compile-and-dump/Singletons/DataValues.ghc78.template view
@@ -4,7 +4,7 @@           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) |]@@ -17,29 +17,89 @@     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)]+    type PairSym2 (t :: a) (t :: b) = Pair t t+    instance SuppressUnusedWarnings PairSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) PairSym1KindInference GHC.Tuple.())+    data PairSym1 (l :: a) (l :: TyFun b (Pair a b))+      = forall arg. (GHC.Types.~) (KindOf (Apply (PairSym1 l) arg)) (KindOf (PairSym2 l arg)) =>+        PairSym1KindInference+    type instance Apply (PairSym1 l) l = PairSym2 l l+    instance SuppressUnusedWarnings PairSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) PairSym0KindInference GHC.Tuple.())+    data PairSym0 (l :: TyFun a (TyFun b (Pair a b) -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply PairSym0 arg)) (KindOf (PairSym1 arg)) =>+        PairSym0KindInference+    type instance Apply PairSym0 l = PairSym1 l+    type AListSym0 = AList+    type TupleSym0 = Tuple+    type ComplexSym0 = Complex+    type PrSym0 = Pr+    type AList =+        Apply (Apply (:$) ZeroSym0) (Apply (Apply (:$) (Apply SuccSym0 ZeroSym0)) (Apply (Apply (:$) (Apply SuccSym0 (Apply SuccSym0 ZeroSym0))) GHC.Types.[]))+    type Tuple =+        Apply (Apply (Apply Tuple3Sym0 FalseSym0) (Apply JustSym0 ZeroSym0)) TrueSym0+    type Complex =+        Apply (Apply PairSym0 (Apply (Apply PairSym0 (Apply JustSym0 ZeroSym0)) ZeroSym0)) FalseSym0+    type Pr =+        Apply (Apply PairSym0 (Apply SuccSym0 ZeroSym0)) (Apply (Apply (:$) ZeroSym0) GHC.Types.[])+    sAList :: Sing AListSym0+    sTuple :: Sing TupleSym0+    sComplex :: Sing ComplexSym0+    sPr :: Sing PrSym0+    sAList+      = applySing+          (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) SZero)+          (applySing+             (applySing+                (singFun2 (Proxy :: Proxy (:$)) SCons)+                (applySing (singFun1 (Proxy :: Proxy SuccSym0) SSucc) SZero))+             (applySing+                (applySing+                   (singFun2 (Proxy :: Proxy (:$)) SCons)+                   (applySing+                      (singFun1 (Proxy :: Proxy SuccSym0) SSucc)+                      (applySing (singFun1 (Proxy :: Proxy SuccSym0) SSucc) SZero)))+                SNil))+    sTuple+      = applySing+          (applySing+             (applySing (singFun3 (Proxy :: Proxy Tuple3Sym0) STuple3) SFalse)+             (applySing (singFun1 (Proxy :: Proxy JustSym0) SJust) SZero))+          STrue+    sComplex+      = applySing+          (applySing+             (singFun2 (Proxy :: Proxy PairSym0) SPair)+             (applySing+                (applySing+                   (singFun2 (Proxy :: Proxy PairSym0) SPair)+                   (applySing (singFun1 (Proxy :: Proxy JustSym0) SJust) SZero))+                SZero))+          SFalse+    sPr+      = applySing+          (applySing+             (singFun2 (Proxy :: Proxy PairSym0) SPair)+             (applySing (singFun1 (Proxy :: Proxy SuccSym0) SSucc) SZero))+          (applySing+             (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) SZero) SNil)     data instance Sing (z :: Pair a b)-      = forall (n :: a) (n :: b). z ~ Pair n n => SPair (Sing n) (Sing n)+      = forall (n :: a) (n :: b). (GHC.Types.~) 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))+      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))+              GHC.Tuple.(,)+                (toSing b :: SomeSing (KProxy :: KProxy a))+                (toSing b :: SomeSing (KProxy :: KProxy b))           of {-            (SomeSing c, SomeSing c) -> SomeSing (SPair c c) }+            GHC.Tuple.(,) (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 view
@@ -3,6 +3,7 @@ import Data.Singletons.TH import Data.Singletons.Prelude import Singletons.Nat+import Data.Singletons.SuppressUnusedWarnings  $(singletons [d|   data Pair a b = Pair a b deriving Show
tests/compile-and-dump/Singletons/Empty.ghc76.template view
@@ -3,6 +3,8 @@   ======>     Singletons/Empty.hs:(0,0)-(0,0)     data Empty+    type EmptyTyCtor = Empty+    type EmptyTyCtorSym0 = EmptyTyCtor     data instance Sing (z :: Empty)     type SEmpty (z :: Empty) = Sing z     instance SingKind (KProxy :: KProxy Empty) where
tests/compile-and-dump/Singletons/EqInstances.ghc76.template view
@@ -7,9 +7,9 @@       %:== 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 (:==) FLeaf FLeaf = TrueSym0+    type instance (:==) FLeaf (:+: b b) = FalseSym0+    type instance (:==) (:+: a a) FLeaf = FalseSym0     type instance (:==) (:+: a a) (:+: b b) = :&& (:== a b) (:== a b)     instance SEq (KProxy :: KProxy Empty) where       %:== a _
tests/compile-and-dump/Singletons/EqInstances.ghc78.template view
@@ -8,15 +8,17 @@       (%:==) ((:%+:) _ _) 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+      Equals_0123456789 FLeaf FLeaf = TrueSym0+      Equals_0123456789 ((:+:) a a) ((:+:) b b) = (:&&) ((:==) a b) ((:==) a b)+      Equals_0123456789 (a :: Foo) (b :: Foo) = FalseSym0+    instance PEq (KProxy :: KProxy Foo) where+      type (:==) (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+      Equals_0123456789 (a :: Empty) (b :: Empty) = FalseSym0+    instance PEq (KProxy :: KProxy Empty) where+      type (:==) (a :: Empty) (b :: Empty) = Equals_0123456789 a b
tests/compile-and-dump/Singletons/EqInstances.hs view
@@ -1,7 +1,7 @@ module Singletons.EqInstances where  import Data.Singletons.TH-import Data.Singletons.Bool+import Data.Singletons.Prelude.Bool import Singletons.Empty import Singletons.Operators 
+ tests/compile-and-dump/Singletons/Error.ghc76.template view
@@ -0,0 +1,16 @@+Promote/Error.hs:0:0: Splicing declarations+    promote+      [d| head :: [a] -> a+          head (a : _) = a+          head [] = error "Data.Singletons.List.head: empty list" |]+  ======>+    Promote/Error.hs:(0,0)-(0,0)+    head :: forall a. [a] -> a+    head (a GHC.Types.: _) = a+    head GHC.Types.[] = error "Data.Singletons.List.head: empty list"+    type family Head (a :: [a]) :: a+    type instance Head (GHC.Types.: a z) = a+    type instance Head GHC.Types.[] =+        Apply ErrorSym0 "Data.Singletons.List.head: empty list"+    data HeadSym0 (k :: TyFun [a] a)+    type instance Apply HeadSym0 a = Head a
+ tests/compile-and-dump/Singletons/Error.ghc78.template view
@@ -0,0 +1,39 @@+Singletons/Error.hs:0:0: Splicing declarations+    singletons+      [d| head :: [a] -> a+          head (a : _) = a+          head [] = error "Data.Singletons.List.head: empty list" |]+  ======>+    Singletons/Error.hs:(0,0)-(0,0)+    head :: forall a. [a] -> a+    head (a GHC.Types.: _) = a+    head GHC.Types.[] = error "Data.Singletons.List.head: empty list"+    type HeadSym1 (t :: GHC.Types.[] a) = Head t+    instance SuppressUnusedWarnings HeadSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) HeadSym0KindInference GHC.Tuple.())+    data HeadSym0 (l :: TyFun (GHC.Types.[] a) a)+      = forall arg. (GHC.Types.~) (KindOf (Apply HeadSym0 arg)) (KindOf (HeadSym1 arg)) =>+        HeadSym0KindInference+    type instance Apply HeadSym0 l = HeadSym1 l+    type family Head (a :: GHC.Types.[] a) :: a where+      Head ((GHC.Types.:) a z) = a+      Head GHC.Types.[] = Apply ErrorSym0 "Data.Singletons.List.head: empty list"+    sHead ::+      forall (t :: GHC.Types.[] a). Sing t -> Sing (Apply HeadSym0 t)+    sHead (SCons sA _)+      = let+          lambda ::+            forall a wild. (GHC.Types.~) t (Apply (Apply (:$) a) wild) =>+            Sing a -> Sing (Apply HeadSym0 (Apply (Apply (:$) a) wild))+          lambda a = a+        in lambda sA+    sHead SNil+      = let+          lambda ::+            (GHC.Types.~) t GHC.Types.[] => Sing (Apply HeadSym0 GHC.Types.[])+          lambda+            = applySing+                (singFun1 (Proxy :: Proxy ErrorSym0) sError)+                (sing :: Sing "Data.Singletons.List.head: empty list")+        in lambda
+ tests/compile-and-dump/Singletons/Error.hs view
@@ -0,0 +1,11 @@+module Singletons.Error where++import Data.Singletons+import Data.Singletons.Prelude hiding (Head, HeadSym0, HeadSym1)+import Data.Singletons.TH++$(singletons [d|+  head :: [a] -> a+  head (a : _) = a+  head []      = error "Data.Singletons.List.head: empty list"+ |])
tests/compile-and-dump/Singletons/HigherOrder.ghc76.template view
@@ -5,7 +5,14 @@           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 |]+          liftMaybe _ Nothing = Nothing+          zipWith :: (a -> b -> c) -> [a] -> [b] -> [c]+          zipWith f (x : xs) (y : ys) = f x y : zipWith f xs ys+          zipWith _ [] [] = []+          zipWith _ (_ : _) [] = []+          zipWith _ [] (_ : _) = []+          foo :: ((a -> b) -> a -> b) -> (a -> b) -> a -> b+          foo f g a = f g a |]   ======>     Singletons/HigherOrder.hs:(0,0)-(0,0)     map :: forall a b. (a -> b) -> [a] -> [b]@@ -14,20 +21,102 @@     liftMaybe :: forall a b. (a -> b) -> Maybe a -> Maybe b     liftMaybe f (Just x) = Just (f x)     liftMaybe _ Nothing = Nothing+    zipWith :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]+    zipWith f (x GHC.Types.: xs) (y GHC.Types.: ys)+      = ((f x y) GHC.Types.: (zipWith f xs ys))+    zipWith _ GHC.Types.[] GHC.Types.[] = GHC.Types.[]+    zipWith _ (_ GHC.Types.: _) GHC.Types.[] = GHC.Types.[]+    zipWith _ GHC.Types.[] (_ GHC.Types.: _) = GHC.Types.[]+    foo :: forall a b. ((a -> b) -> a -> b) -> (a -> b) -> a -> b+    foo f g a = f g a+    type family Map (a :: TyFun a b -> *) (a :: [a]) :: [b]     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+    type instance Map f (GHC.Types.: h t) =+        Apply (Apply :$ (Apply f h)) (Apply (Apply MapSym0 f) t)+    data MapSym1 (l :: TyFun a b -> *) (l :: TyFun [a] [b])+    data MapSym0 (k :: TyFun (TyFun a b -> *) (TyFun [a] [b] -> *))+    type instance Apply (MapSym1 a) a = Map a a+    type instance Apply MapSym0 a = MapSym1 a+    type family LiftMaybe (a :: TyFun a b -> *)+                          (a :: Maybe a) :: Maybe b+    type instance LiftMaybe f (Just x) = Apply JustSym0 (Apply f x)+    type instance LiftMaybe z Nothing = NothingSym0+    data LiftMaybeSym1 (l :: TyFun a b -> *)+                       (l :: TyFun (Maybe a) (Maybe b))+    data LiftMaybeSym0 (k :: TyFun (TyFun a b+                                    -> *) (TyFun (Maybe a) (Maybe b) -> *))+    type instance Apply (LiftMaybeSym1 a) a = LiftMaybe a a+    type instance Apply LiftMaybeSym0 a = LiftMaybeSym1 a+    type family ZipWith (a :: TyFun a (TyFun b c -> *) -> *)+                        (a :: [a])+                        (a :: [b]) :: [c]+    type instance ZipWith f (GHC.Types.: x xs) (GHC.Types.: y ys) =+        Apply (Apply :$ (Apply (Apply f x) y)) (Apply (Apply (Apply ZipWithSym0 f) xs) ys)+    type instance ZipWith z GHC.Types.[] GHC.Types.[] = GHC.Types.[]+    type instance ZipWith z (GHC.Types.: z z) GHC.Types.[] =+        GHC.Types.[]+    type instance ZipWith z GHC.Types.[] (GHC.Types.: z z) =+        GHC.Types.[]+    data ZipWithSym2 (l :: TyFun a (TyFun b c -> *) -> *)+                     (l :: [a])+                     (l :: TyFun [b] [c])+    data ZipWithSym1 (l :: TyFun a (TyFun b c -> *) -> *)+                     (l :: TyFun [a] (TyFun [b] [c] -> *))+    data ZipWithSym0 (k :: TyFun (TyFun a (TyFun b c -> *)+                                  -> *) (TyFun [a] (TyFun [b] [c] -> *) -> *))+    type instance Apply (ZipWithSym2 a a) a = ZipWith a a a+    type instance Apply (ZipWithSym1 a) a = ZipWithSym2 a a+    type instance Apply ZipWithSym0 a = ZipWithSym1 a+    type family Foo (a :: TyFun (TyFun a b -> *) (TyFun a b -> *) -> *)+                    (a :: TyFun a b -> *)+                    (a :: a) :: b+    type instance Foo f g a = Apply (Apply f g) a+    data FooSym2 (l :: TyFun (TyFun a b -> *) (TyFun a b -> *) -> *)+                 (l :: TyFun a b -> *)+                 (l :: TyFun a b)+    data FooSym1 (l :: TyFun (TyFun a b -> *) (TyFun a b -> *) -> *)+                 (l :: TyFun (TyFun a b -> *) (TyFun a b -> *))+    data FooSym0 (k :: TyFun (TyFun (TyFun a b -> *) (TyFun a b -> *)+                              -> *) (TyFun (TyFun a b -> *) (TyFun a b -> *) -> *))+    type instance Apply (FooSym2 a a) a = Foo a a a+    type instance Apply (FooSym1 a) a = FooSym2 a a+    type instance Apply FooSym0 a = FooSym1 a     sMap ::-      forall (t :: a -> b) (t :: [a]).-      (forall (t :: a). Sing t -> Sing (t t)) -> Sing t -> Sing (Map t t)+      forall (t :: TyFun a b -> *) (t :: [a]).+      (forall (t :: a).+       Data.Singletons.Types.Proxy t -> Sing t -> Sing (Apply t t))+      -> Sing t -> Sing (Map t t)     sMap _ SNil = SNil-    sMap f (SCons h t) = SCons (f h) (sMap f t)+    sMap f (SCons h t)+      = SCons (f Data.Singletons.Types.Proxy h) (sMap f t)     sLiftMaybe ::-      forall (t :: a -> b) (t :: Maybe a).-      (forall (t :: a). Sing t -> Sing (t t))+      forall (t :: TyFun a b -> *) (t :: Maybe a).+      (forall (t :: a).+       Data.Singletons.Types.Proxy t -> Sing t -> Sing (Apply t t))       -> Sing t -> Sing (LiftMaybe t t)-    sLiftMaybe f (SJust x) = SJust (f x)+    sLiftMaybe f (SJust x) = SJust (f Data.Singletons.Types.Proxy x)     sLiftMaybe _ SNothing = SNothing+    sZipWith ::+      forall (t :: TyFun a (TyFun b c -> *) -> *) (t :: [a]) (t :: [b]).+      (forall (t :: a) (t :: b).+       Data.Singletons.Types.Proxy t+       -> Sing t -> Sing t -> Sing (Apply (Apply t t) t))+      -> Sing t -> Sing t -> Sing (ZipWith t t t)+    sZipWith f (SCons x xs) (SCons y ys)+      = SCons (f Data.Singletons.Types.Proxy x y) (sZipWith f xs ys)+    sZipWith _ SNil SNil = SNil+    sZipWith _ (SCons _ _) SNil = SNil+    sZipWith _ SNil (SCons _ _) = SNil+    sFoo ::+      forall (t :: TyFun (TyFun a b -> *) (TyFun a b -> *) -> *)+             (t :: TyFun a b -> *)+             (t :: a).+      (forall (t :: TyFun a b -> *) (t :: a).+       Data.Singletons.Types.Proxy t+       -> (forall (t :: a).+           Data.Singletons.Types.Proxy t -> Sing t -> Sing (Apply t t))+          -> Sing t -> Sing (Apply (Apply t t) t))+      -> (forall (t :: a).+          Data.Singletons.Types.Proxy t -> Sing t -> Sing (Apply t t))+         -> Sing t -> Sing (Foo t t t)+    sFoo f g a = f Data.Singletons.Types.Proxy g a
tests/compile-and-dump/Singletons/HigherOrder.ghc78.template view
@@ -5,29 +5,613 @@           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 |]+          liftMaybe _ Nothing = Nothing+          zipWith :: (a -> b -> c) -> [a] -> [b] -> [c]+          zipWith f (x : xs) (y : ys) = f x y : zipWith f xs ys+          zipWith _ [] [] = []+          zipWith _ (_ : _) [] = []+          zipWith _ [] (_ : _) = []+          foo :: ((a -> b) -> a -> b) -> (a -> b) -> a -> b+          foo f g a = f g a+          splunge :: [Nat] -> [Bool] -> [Nat]+          splunge ns bs+            = zipWith (\ n b -> if b then Succ (Succ n) else n) ns bs+          etad :: [Nat] -> [Bool] -> [Nat]+          etad = zipWith (\ n b -> if b then Succ (Succ n) else n)+          +          data Either a b = Left a | Right b |]   ======>     Singletons/HigherOrder.hs:(0,0)-(0,0)+    data Either a b = Left a | Right b     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)+    zipWith :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]+    zipWith f (x GHC.Types.: xs) (y GHC.Types.: ys)+      = ((f x y) GHC.Types.: (zipWith f xs ys))+    zipWith _ GHC.Types.[] GHC.Types.[] = []+    zipWith _ (_ GHC.Types.: _) GHC.Types.[] = []+    zipWith _ GHC.Types.[] (_ GHC.Types.: _) = []+    foo :: forall a b. ((a -> b) -> a -> b) -> (a -> b) -> a -> b+    foo f g a = f g a+    splunge :: [Nat] -> [Bool] -> [Nat]+    splunge ns bs+      = zipWith (\ n b -> if b then Succ (Succ n) else n) ns bs+    etad :: [Nat] -> [Bool] -> [Nat]+    etad = zipWith (\ n b -> if b then Succ (Succ n) else n)+    type LeftSym1 (t :: a) = Left t+    instance SuppressUnusedWarnings LeftSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) LeftSym0KindInference GHC.Tuple.())+    data LeftSym0 (l :: TyFun a (Either a b))+      = forall arg. (GHC.Types.~) (KindOf (Apply LeftSym0 arg)) (KindOf (LeftSym1 arg)) =>+        LeftSym0KindInference+    type instance Apply LeftSym0 l = LeftSym1 l+    type RightSym1 (t :: b) = Right t+    instance SuppressUnusedWarnings RightSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) RightSym0KindInference GHC.Tuple.())+    data RightSym0 (l :: TyFun b (Either a b))+      = forall arg. (GHC.Types.~) (KindOf (Apply RightSym0 arg)) (KindOf (RightSym1 arg)) =>+        RightSym0KindInference+    type instance Apply RightSym0 l = RightSym1 l+    type Let_0123456789Scrutinee_0123456789Sym4 t t t t =+        Let_0123456789Scrutinee_0123456789 t t t t+    instance SuppressUnusedWarnings Let_0123456789Scrutinee_0123456789Sym3 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,)+               Let_0123456789Scrutinee_0123456789Sym3KindInference GHC.Tuple.())+    data Let_0123456789Scrutinee_0123456789Sym3 l l l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Let_0123456789Scrutinee_0123456789Sym3 l l l) arg)) (KindOf (Let_0123456789Scrutinee_0123456789Sym4 l l l arg)) =>+        Let_0123456789Scrutinee_0123456789Sym3KindInference+    type instance Apply (Let_0123456789Scrutinee_0123456789Sym3 l l l) l = Let_0123456789Scrutinee_0123456789Sym4 l l l l+    instance SuppressUnusedWarnings Let_0123456789Scrutinee_0123456789Sym2 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,)+               Let_0123456789Scrutinee_0123456789Sym2KindInference GHC.Tuple.())+    data Let_0123456789Scrutinee_0123456789Sym2 l l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Let_0123456789Scrutinee_0123456789Sym2 l l) arg)) (KindOf (Let_0123456789Scrutinee_0123456789Sym3 l l arg)) =>+        Let_0123456789Scrutinee_0123456789Sym2KindInference+    type instance Apply (Let_0123456789Scrutinee_0123456789Sym2 l l) l = Let_0123456789Scrutinee_0123456789Sym3 l l l+    instance SuppressUnusedWarnings Let_0123456789Scrutinee_0123456789Sym1 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,)+               Let_0123456789Scrutinee_0123456789Sym1KindInference GHC.Tuple.())+    data Let_0123456789Scrutinee_0123456789Sym1 l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Let_0123456789Scrutinee_0123456789Sym1 l) arg)) (KindOf (Let_0123456789Scrutinee_0123456789Sym2 l arg)) =>+        Let_0123456789Scrutinee_0123456789Sym1KindInference+    type instance Apply (Let_0123456789Scrutinee_0123456789Sym1 l) l = Let_0123456789Scrutinee_0123456789Sym2 l l+    instance SuppressUnusedWarnings Let_0123456789Scrutinee_0123456789Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,)+               Let_0123456789Scrutinee_0123456789Sym0KindInference GHC.Tuple.())+    data Let_0123456789Scrutinee_0123456789Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Let_0123456789Scrutinee_0123456789Sym0 arg)) (KindOf (Let_0123456789Scrutinee_0123456789Sym1 arg)) =>+        Let_0123456789Scrutinee_0123456789Sym0KindInference+    type instance Apply Let_0123456789Scrutinee_0123456789Sym0 l = Let_0123456789Scrutinee_0123456789Sym1 l+    type Let_0123456789Scrutinee_0123456789 ns bs n b = b+    type family Case_0123456789 ns bs n b t where+      Case_0123456789 ns bs n b True = Apply SuccSym0 (Apply SuccSym0 n)+      Case_0123456789 ns bs n b False = n+    type family Lambda_0123456789 ns bs t t where+      Lambda_0123456789 ns bs n b = Case_0123456789 ns bs n b (Let_0123456789Scrutinee_0123456789Sym4 ns bs n b)+    type Lambda_0123456789Sym4 t t t t = Lambda_0123456789 t t t t+    instance SuppressUnusedWarnings Lambda_0123456789Sym3 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym3KindInference GHC.Tuple.())+    data Lambda_0123456789Sym3 l l l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym3 l l l) arg)) (KindOf (Lambda_0123456789Sym4 l l l arg)) =>+        Lambda_0123456789Sym3KindInference+    type instance Apply (Lambda_0123456789Sym3 l l l) l = Lambda_0123456789Sym4 l l l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym2 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym2KindInference GHC.Tuple.())+    data Lambda_0123456789Sym2 l l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym2 l l) arg)) (KindOf (Lambda_0123456789Sym3 l l arg)) =>+        Lambda_0123456789Sym2KindInference+    type instance Apply (Lambda_0123456789Sym2 l l) l = Lambda_0123456789Sym3 l l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym1 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym1KindInference GHC.Tuple.())+    data Lambda_0123456789Sym1 l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym1 l) arg)) (KindOf (Lambda_0123456789Sym2 l arg)) =>+        Lambda_0123456789Sym1KindInference+    type instance Apply (Lambda_0123456789Sym1 l) l = Lambda_0123456789Sym2 l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym0KindInference GHC.Tuple.())+    data Lambda_0123456789Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Lambda_0123456789Sym0 arg)) (KindOf (Lambda_0123456789Sym1 arg)) =>+        Lambda_0123456789Sym0KindInference+    type instance Apply Lambda_0123456789Sym0 l = Lambda_0123456789Sym1 l+    type Let_0123456789Scrutinee_0123456789Sym4 t t t t =+        Let_0123456789Scrutinee_0123456789 t t t t+    instance SuppressUnusedWarnings Let_0123456789Scrutinee_0123456789Sym3 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,)+               Let_0123456789Scrutinee_0123456789Sym3KindInference GHC.Tuple.())+    data Let_0123456789Scrutinee_0123456789Sym3 l l l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Let_0123456789Scrutinee_0123456789Sym3 l l l) arg)) (KindOf (Let_0123456789Scrutinee_0123456789Sym4 l l l arg)) =>+        Let_0123456789Scrutinee_0123456789Sym3KindInference+    type instance Apply (Let_0123456789Scrutinee_0123456789Sym3 l l l) l = Let_0123456789Scrutinee_0123456789Sym4 l l l l+    instance SuppressUnusedWarnings Let_0123456789Scrutinee_0123456789Sym2 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,)+               Let_0123456789Scrutinee_0123456789Sym2KindInference GHC.Tuple.())+    data Let_0123456789Scrutinee_0123456789Sym2 l l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Let_0123456789Scrutinee_0123456789Sym2 l l) arg)) (KindOf (Let_0123456789Scrutinee_0123456789Sym3 l l arg)) =>+        Let_0123456789Scrutinee_0123456789Sym2KindInference+    type instance Apply (Let_0123456789Scrutinee_0123456789Sym2 l l) l = Let_0123456789Scrutinee_0123456789Sym3 l l l+    instance SuppressUnusedWarnings Let_0123456789Scrutinee_0123456789Sym1 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,)+               Let_0123456789Scrutinee_0123456789Sym1KindInference GHC.Tuple.())+    data Let_0123456789Scrutinee_0123456789Sym1 l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Let_0123456789Scrutinee_0123456789Sym1 l) arg)) (KindOf (Let_0123456789Scrutinee_0123456789Sym2 l arg)) =>+        Let_0123456789Scrutinee_0123456789Sym1KindInference+    type instance Apply (Let_0123456789Scrutinee_0123456789Sym1 l) l = Let_0123456789Scrutinee_0123456789Sym2 l l+    instance SuppressUnusedWarnings Let_0123456789Scrutinee_0123456789Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,)+               Let_0123456789Scrutinee_0123456789Sym0KindInference GHC.Tuple.())+    data Let_0123456789Scrutinee_0123456789Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Let_0123456789Scrutinee_0123456789Sym0 arg)) (KindOf (Let_0123456789Scrutinee_0123456789Sym1 arg)) =>+        Let_0123456789Scrutinee_0123456789Sym0KindInference+    type instance Apply Let_0123456789Scrutinee_0123456789Sym0 l = Let_0123456789Scrutinee_0123456789Sym1 l+    type Let_0123456789Scrutinee_0123456789 n+                                            b+                                            a_0123456789+                                            a_0123456789 =+        b+    type family Case_0123456789 n b a_0123456789 a_0123456789 t where+      Case_0123456789 n b a_0123456789 a_0123456789 True = Apply SuccSym0 (Apply SuccSym0 n)+      Case_0123456789 n b a_0123456789 a_0123456789 False = n+    type family Lambda_0123456789 a_0123456789 a_0123456789 t t where+      Lambda_0123456789 a_0123456789 a_0123456789 n b = Case_0123456789 n b a_0123456789 a_0123456789 (Let_0123456789Scrutinee_0123456789Sym4 n b a_0123456789 a_0123456789)+    type Lambda_0123456789Sym4 t t t t = Lambda_0123456789 t t t t+    instance SuppressUnusedWarnings Lambda_0123456789Sym3 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym3KindInference GHC.Tuple.())+    data Lambda_0123456789Sym3 l l l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym3 l l l) arg)) (KindOf (Lambda_0123456789Sym4 l l l arg)) =>+        Lambda_0123456789Sym3KindInference+    type instance Apply (Lambda_0123456789Sym3 l l l) l = Lambda_0123456789Sym4 l l l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym2 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym2KindInference GHC.Tuple.())+    data Lambda_0123456789Sym2 l l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym2 l l) arg)) (KindOf (Lambda_0123456789Sym3 l l arg)) =>+        Lambda_0123456789Sym2KindInference+    type instance Apply (Lambda_0123456789Sym2 l l) l = Lambda_0123456789Sym3 l l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym1 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym1KindInference GHC.Tuple.())+    data Lambda_0123456789Sym1 l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym1 l) arg)) (KindOf (Lambda_0123456789Sym2 l arg)) =>+        Lambda_0123456789Sym1KindInference+    type instance Apply (Lambda_0123456789Sym1 l) l = Lambda_0123456789Sym2 l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym0KindInference GHC.Tuple.())+    data Lambda_0123456789Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Lambda_0123456789Sym0 arg)) (KindOf (Lambda_0123456789Sym1 arg)) =>+        Lambda_0123456789Sym0KindInference+    type instance Apply Lambda_0123456789Sym0 l = Lambda_0123456789Sym1 l+    type FooSym3 (t :: TyFun (TyFun a b -> *) (TyFun a b -> *) -> *)+                 (t :: TyFun a b -> *)+                 (t :: a) =+        Foo t t t+    instance SuppressUnusedWarnings FooSym2 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) FooSym2KindInference GHC.Tuple.())+    data FooSym2 (l :: TyFun (TyFun a b -> *) (TyFun a b -> *) -> *)+                 (l :: TyFun a b -> *)+                 (l :: TyFun a b)+      = forall arg. (GHC.Types.~) (KindOf (Apply (FooSym2 l l) arg)) (KindOf (FooSym3 l l arg)) =>+        FooSym2KindInference+    type instance Apply (FooSym2 l l) l = FooSym3 l l l+    instance SuppressUnusedWarnings FooSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) FooSym1KindInference GHC.Tuple.())+    data FooSym1 (l :: TyFun (TyFun a b -> *) (TyFun a b -> *) -> *)+                 (l :: TyFun (TyFun a b -> *) (TyFun a b -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply (FooSym1 l) arg)) (KindOf (FooSym2 l arg)) =>+        FooSym1KindInference+    type instance Apply (FooSym1 l) l = FooSym2 l l+    instance SuppressUnusedWarnings FooSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) FooSym0KindInference GHC.Tuple.())+    data FooSym0 (l :: TyFun (TyFun (TyFun a b -> *) (TyFun a b -> *)+                              -> *) (TyFun (TyFun a b -> *) (TyFun a b -> *) -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply FooSym0 arg)) (KindOf (FooSym1 arg)) =>+        FooSym0KindInference+    type instance Apply FooSym0 l = FooSym1 l+    type ZipWithSym3 (t :: TyFun a (TyFun b c -> *) -> *)+                     (t :: GHC.Types.[] a)+                     (t :: GHC.Types.[] b) =+        ZipWith t t t+    instance SuppressUnusedWarnings ZipWithSym2 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) ZipWithSym2KindInference GHC.Tuple.())+    data ZipWithSym2 (l :: TyFun a (TyFun b c -> *) -> *)+                     (l :: GHC.Types.[] a)+                     (l :: TyFun (GHC.Types.[] b) (GHC.Types.[] c))+      = forall arg. (GHC.Types.~) (KindOf (Apply (ZipWithSym2 l l) arg)) (KindOf (ZipWithSym3 l l arg)) =>+        ZipWithSym2KindInference+    type instance Apply (ZipWithSym2 l l) l = ZipWithSym3 l l l+    instance SuppressUnusedWarnings ZipWithSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) ZipWithSym1KindInference GHC.Tuple.())+    data ZipWithSym1 (l :: TyFun a (TyFun b c -> *) -> *)+                     (l :: TyFun (GHC.Types.[] a) (TyFun (GHC.Types.[] b) (GHC.Types.[] c)+                                                   -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply (ZipWithSym1 l) arg)) (KindOf (ZipWithSym2 l arg)) =>+        ZipWithSym1KindInference+    type instance Apply (ZipWithSym1 l) l = ZipWithSym2 l l+    instance SuppressUnusedWarnings ZipWithSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) ZipWithSym0KindInference GHC.Tuple.())+    data ZipWithSym0 (l :: TyFun (TyFun a (TyFun b c -> *)+                                  -> *) (TyFun (GHC.Types.[] a) (TyFun (GHC.Types.[] b) (GHC.Types.[] c)+                                                                 -> *)+                                         -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply ZipWithSym0 arg)) (KindOf (ZipWithSym1 arg)) =>+        ZipWithSym0KindInference+    type instance Apply ZipWithSym0 l = ZipWithSym1 l+    type SplungeSym2 (t :: GHC.Types.[] Nat) (t :: GHC.Types.[] Bool) =+        Splunge t t+    instance SuppressUnusedWarnings SplungeSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) SplungeSym1KindInference GHC.Tuple.())+    data SplungeSym1 (l :: GHC.Types.[] Nat)+                     (l :: TyFun (GHC.Types.[] Bool) (GHC.Types.[] Nat))+      = forall arg. (GHC.Types.~) (KindOf (Apply (SplungeSym1 l) arg)) (KindOf (SplungeSym2 l arg)) =>+        SplungeSym1KindInference+    type instance Apply (SplungeSym1 l) l = SplungeSym2 l l+    instance SuppressUnusedWarnings SplungeSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) SplungeSym0KindInference GHC.Tuple.())+    data SplungeSym0 (l :: TyFun (GHC.Types.[] Nat) (TyFun (GHC.Types.[] Bool) (GHC.Types.[] Nat)+                                                     -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply SplungeSym0 arg)) (KindOf (SplungeSym1 arg)) =>+        SplungeSym0KindInference+    type instance Apply SplungeSym0 l = SplungeSym1 l+    type EtadSym2 (t :: GHC.Types.[] Nat) (t :: GHC.Types.[] Bool) =+        Etad t t+    instance SuppressUnusedWarnings EtadSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) EtadSym1KindInference GHC.Tuple.())+    data EtadSym1 (l :: GHC.Types.[] Nat)+                  (l :: TyFun (GHC.Types.[] Bool) (GHC.Types.[] Nat))+      = forall arg. (GHC.Types.~) (KindOf (Apply (EtadSym1 l) arg)) (KindOf (EtadSym2 l arg)) =>+        EtadSym1KindInference+    type instance Apply (EtadSym1 l) l = EtadSym2 l l+    instance SuppressUnusedWarnings EtadSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) EtadSym0KindInference GHC.Tuple.())+    data EtadSym0 (l :: TyFun (GHC.Types.[] Nat) (TyFun (GHC.Types.[] Bool) (GHC.Types.[] Nat)+                                                  -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply EtadSym0 arg)) (KindOf (EtadSym1 arg)) =>+        EtadSym0KindInference+    type instance Apply EtadSym0 l = EtadSym1 l+    type LiftMaybeSym2 (t :: TyFun a b -> *) (t :: Maybe a) =+        LiftMaybe t t+    instance SuppressUnusedWarnings LiftMaybeSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) LiftMaybeSym1KindInference GHC.Tuple.())+    data LiftMaybeSym1 (l :: TyFun a b -> *)+                       (l :: TyFun (Maybe a) (Maybe b))+      = forall arg. (GHC.Types.~) (KindOf (Apply (LiftMaybeSym1 l) arg)) (KindOf (LiftMaybeSym2 l arg)) =>+        LiftMaybeSym1KindInference+    type instance Apply (LiftMaybeSym1 l) l = LiftMaybeSym2 l l+    instance SuppressUnusedWarnings LiftMaybeSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) LiftMaybeSym0KindInference GHC.Tuple.())+    data LiftMaybeSym0 (l :: TyFun (TyFun a b+                                    -> *) (TyFun (Maybe a) (Maybe b) -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply LiftMaybeSym0 arg)) (KindOf (LiftMaybeSym1 arg)) =>+        LiftMaybeSym0KindInference+    type instance Apply LiftMaybeSym0 l = LiftMaybeSym1 l+    type MapSym2 (t :: TyFun a b -> *) (t :: GHC.Types.[] a) = Map t t+    instance SuppressUnusedWarnings MapSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) MapSym1KindInference GHC.Tuple.())+    data MapSym1 (l :: TyFun a b -> *)+                 (l :: TyFun (GHC.Types.[] a) (GHC.Types.[] b))+      = forall arg. (GHC.Types.~) (KindOf (Apply (MapSym1 l) arg)) (KindOf (MapSym2 l arg)) =>+        MapSym1KindInference+    type instance Apply (MapSym1 l) l = MapSym2 l l+    instance SuppressUnusedWarnings MapSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) MapSym0KindInference GHC.Tuple.())+    data MapSym0 (l :: TyFun (TyFun a b+                              -> *) (TyFun (GHC.Types.[] a) (GHC.Types.[] b) -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply MapSym0 arg)) (KindOf (MapSym1 arg)) =>+        MapSym0KindInference+    type instance Apply MapSym0 l = MapSym1 l+    type family Foo (a :: TyFun (TyFun a b -> *) (TyFun a b -> *) -> *)+                    (a :: TyFun a b -> *)+                    (a :: a) :: b where+      Foo f g a = Apply (Apply f g) a+    type family ZipWith (a :: TyFun a (TyFun b c -> *) -> *)+                        (a :: GHC.Types.[] a)+                        (a :: GHC.Types.[] b) :: GHC.Types.[] c where+      ZipWith f ((GHC.Types.:) x xs) ((GHC.Types.:) y ys) = Apply (Apply (:$) (Apply (Apply f x) y)) (Apply (Apply (Apply ZipWithSym0 f) xs) ys)+      ZipWith z GHC.Types.[] GHC.Types.[] = GHC.Types.[]+      ZipWith z ((GHC.Types.:) z z) GHC.Types.[] = GHC.Types.[]+      ZipWith z GHC.Types.[] ((GHC.Types.:) z z) = GHC.Types.[]+    type family Splunge (a :: GHC.Types.[] Nat)+                        (a :: GHC.Types.[] Bool) :: GHC.Types.[] Nat where+      Splunge ns bs = Apply (Apply (Apply ZipWithSym0 (Apply (Apply Lambda_0123456789Sym0 ns) bs)) ns) bs+    type family Etad (a :: GHC.Types.[] Nat)+                     (a :: GHC.Types.[] Bool) :: GHC.Types.[] Nat where+      Etad a_0123456789 a_0123456789 = Apply (Apply (Apply ZipWithSym0 (Apply (Apply Lambda_0123456789Sym0 a_0123456789) a_0123456789)) a_0123456789) a_0123456789+    type family LiftMaybe (a :: TyFun a b -> *)+                          (a :: Maybe a) :: Maybe b where+      LiftMaybe f (Just x) = Apply JustSym0 (Apply f x)+      LiftMaybe z Nothing = NothingSym0+    type family Map (a :: TyFun a b -> *)+                    (a :: GHC.Types.[] a) :: GHC.Types.[] b where+      Map z GHC.Types.[] = GHC.Types.[]+      Map f ((GHC.Types.:) h t) = Apply (Apply (:$) (Apply f h)) (Apply (Apply MapSym0 f) t)+    sFoo ::+      forall (t :: TyFun (TyFun a b -> *) (TyFun a b -> *) -> *)+             (t :: TyFun a b -> *)+             (t :: a).+      Sing t+      -> Sing t -> Sing t -> Sing (Apply (Apply (Apply FooSym0 t) t) t)+    sZipWith ::+      forall (t :: TyFun a (TyFun b c -> *) -> *)+             (t :: GHC.Types.[] a)+             (t :: GHC.Types.[] b).+      Sing t+      -> Sing t+         -> Sing t -> Sing (Apply (Apply (Apply ZipWithSym0 t) t) t)+    sSplunge ::+      forall (t :: GHC.Types.[] Nat) (t :: GHC.Types.[] Bool).+      Sing t -> Sing t -> Sing (Apply (Apply SplungeSym0 t) t)+    sEtad ::+      forall (t :: GHC.Types.[] Nat) (t :: GHC.Types.[] Bool).+      Sing t -> Sing t -> Sing (Apply (Apply EtadSym0 t) 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+      forall (t :: TyFun a b -> *) (t :: Maybe a).+      Sing t -> Sing t -> Sing (Apply (Apply LiftMaybeSym0 t) t)+    sMap ::+      forall (t :: TyFun a b -> *) (t :: GHC.Types.[] a).+      Sing t -> Sing t -> Sing (Apply (Apply MapSym0 t) t)+    sFoo sF sG sA+      = let+          lambda ::+            forall f g a. ((GHC.Types.~) t f,+                           (GHC.Types.~) t g,+                           (GHC.Types.~) t a) =>+            Sing f+            -> Sing g -> Sing a -> Sing (Apply (Apply (Apply FooSym0 f) g) a)+          lambda f g a = applySing (applySing f g) a+        in lambda sF sG sA+    sZipWith sF (SCons sX sXs) (SCons sY sYs)+      = let+          lambda ::+            forall f x xs y ys. ((GHC.Types.~) t f,+                                 (GHC.Types.~) t (Apply (Apply (:$) x) xs),+                                 (GHC.Types.~) t (Apply (Apply (:$) y) ys)) =>+            Sing f+            -> Sing x+               -> Sing xs+                  -> Sing y+                     -> Sing ys+                        -> Sing (Apply (Apply (Apply ZipWithSym0 f) (Apply (Apply (:$) x) xs)) (Apply (Apply (:$) y) ys))+          lambda f x xs y ys+            = applySing+                (applySing+                   (singFun2 (Proxy :: Proxy (:$)) SCons)+                   (applySing (applySing f x) y))+                (applySing+                   (applySing+                      (applySing (singFun3 (Proxy :: Proxy ZipWithSym0) sZipWith) f) xs)+                   ys)+        in lambda sF sX sXs sY sYs+    sZipWith _ SNil SNil+      = let+          lambda ::+            forall wild. ((GHC.Types.~) t wild,+                          (GHC.Types.~) t GHC.Types.[],+                          (GHC.Types.~) t GHC.Types.[]) =>+            Sing (Apply (Apply (Apply ZipWithSym0 wild) GHC.Types.[]) GHC.Types.[])+          lambda = SNil+        in lambda+    sZipWith _ (SCons _ _) SNil+      = let+          lambda ::+            forall wild wild wild. ((GHC.Types.~) t wild,+                                    (GHC.Types.~) t (Apply (Apply (:$) wild) wild),+                                    (GHC.Types.~) t GHC.Types.[]) =>+            Sing (Apply (Apply (Apply ZipWithSym0 wild) (Apply (Apply (:$) wild) wild)) GHC.Types.[])+          lambda = SNil+        in lambda+    sZipWith _ SNil (SCons _ _)+      = let+          lambda ::+            forall wild wild wild. ((GHC.Types.~) t wild,+                                    (GHC.Types.~) t GHC.Types.[],+                                    (GHC.Types.~) t (Apply (Apply (:$) wild) wild)) =>+            Sing (Apply (Apply (Apply ZipWithSym0 wild) GHC.Types.[]) (Apply (Apply (:$) wild) wild))+          lambda = SNil+        in lambda+    sSplunge sNs sBs+      = let+          lambda ::+            forall ns bs. ((GHC.Types.~) t ns, (GHC.Types.~) t bs) =>+            Sing ns -> Sing bs -> Sing (Apply (Apply SplungeSym0 ns) bs)+          lambda ns bs+            = applySing+                (applySing+                   (applySing+                      (singFun3 (Proxy :: Proxy ZipWithSym0) sZipWith)+                      (singFun2+                         (Proxy :: Proxy (Apply (Apply Lambda_0123456789Sym0 ns) bs))+                         (\ sN sB+                            -> let+                                 lambda ::+                                   forall n b.+                                   Sing n+                                   -> Sing b+                                      -> Sing (Apply (Apply (Apply (Apply Lambda_0123456789Sym0 ns) bs) n) b)+                                 lambda n b+                                   = let+                                       sScrutinee_0123456789 ::+                                         Sing (Let_0123456789Scrutinee_0123456789Sym4 ns bs n b)+                                       sScrutinee_0123456789 = b+                                     in+                                       case sScrutinee_0123456789 of {+                                         STrue+                                           -> let+                                                lambda :: Sing (Case_0123456789 ns bs n b TrueSym0)+                                                lambda+                                                  = applySing+                                                      (singFun1 (Proxy :: Proxy SuccSym0) SSucc)+                                                      (applySing+                                                         (singFun1 (Proxy :: Proxy SuccSym0) SSucc)+                                                         n)+                                              in lambda+                                         SFalse+                                           -> let+                                                lambda :: Sing (Case_0123456789 ns bs n b FalseSym0)+                                                lambda = n+                                              in lambda }+                               in lambda sN sB)))+                   ns)+                bs+        in lambda sNs sBs+    sEtad sA_0123456789 sA_0123456789+      = let+          lambda ::+            forall a_0123456789 a_0123456789. ((GHC.Types.~) t a_0123456789,+                                               (GHC.Types.~) t a_0123456789) =>+            Sing a_0123456789+            -> Sing a_0123456789+               -> Sing (Apply (Apply EtadSym0 a_0123456789) a_0123456789)+          lambda a_0123456789 a_0123456789+            = applySing+                (applySing+                   (applySing+                      (singFun3 (Proxy :: Proxy ZipWithSym0) sZipWith)+                      (singFun2+                         (Proxy ::+                            Proxy (Apply (Apply Lambda_0123456789Sym0 a_0123456789) a_0123456789))+                         (\ sN sB+                            -> let+                                 lambda ::+                                   forall n b.+                                   Sing n+                                   -> Sing b+                                      -> Sing (Apply (Apply (Apply (Apply Lambda_0123456789Sym0 a_0123456789) a_0123456789) n) b)+                                 lambda n b+                                   = let+                                       sScrutinee_0123456789 ::+                                         Sing (Let_0123456789Scrutinee_0123456789Sym4 n b a_0123456789 a_0123456789)+                                       sScrutinee_0123456789 = b+                                     in+                                       case sScrutinee_0123456789 of {+                                         STrue+                                           -> let+                                                lambda ::+                                                  Sing (Case_0123456789 n b a_0123456789 a_0123456789 TrueSym0)+                                                lambda+                                                  = applySing+                                                      (singFun1 (Proxy :: Proxy SuccSym0) SSucc)+                                                      (applySing+                                                         (singFun1 (Proxy :: Proxy SuccSym0) SSucc)+                                                         n)+                                              in lambda+                                         SFalse+                                           -> let+                                                lambda ::+                                                  Sing (Case_0123456789 n b a_0123456789 a_0123456789 FalseSym0)+                                                lambda = n+                                              in lambda }+                               in lambda sN sB)))+                   a_0123456789)+                a_0123456789+        in lambda sA_0123456789 sA_0123456789+    sLiftMaybe sF (SJust sX)+      = let+          lambda ::+            forall f x. ((GHC.Types.~) t f,+                         (GHC.Types.~) t (Apply JustSym0 x)) =>+            Sing f+            -> Sing x+               -> Sing (Apply (Apply LiftMaybeSym0 f) (Apply JustSym0 x))+          lambda f x+            = applySing+                (singFun1 (Proxy :: Proxy JustSym0) SJust) (applySing f x)+        in lambda sF sX+    sLiftMaybe _ SNothing+      = let+          lambda ::+            forall wild. ((GHC.Types.~) t wild, (GHC.Types.~) t NothingSym0) =>+            Sing (Apply (Apply LiftMaybeSym0 wild) NothingSym0)+          lambda = SNothing+        in lambda+    sMap _ SNil+      = let+          lambda ::+            forall wild. ((GHC.Types.~) t wild,+                          (GHC.Types.~) t GHC.Types.[]) =>+            Sing (Apply (Apply MapSym0 wild) GHC.Types.[])+          lambda = SNil+        in lambda+    sMap sF (SCons sH sT)+      = let+          lambda ::+            forall f h t. ((GHC.Types.~) t f,+                           (GHC.Types.~) t (Apply (Apply (:$) h) t)) =>+            Sing f+            -> Sing h+               -> Sing t+                  -> Sing (Apply (Apply MapSym0 f) (Apply (Apply (:$) h) t))+          lambda f h t+            = applySing+                (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) (applySing f h))+                (applySing+                   (applySing (singFun2 (Proxy :: Proxy MapSym0) sMap) f) t)+        in lambda sF sH sT+    data instance Sing (z :: Either a b)+      = forall (n :: a). (GHC.Types.~) z (Left n) => SLeft (Sing n) |+        forall (n :: b). (GHC.Types.~) z (Right n) => SRight (Sing n)+    type SEither (z :: Either a b) = Sing z+    instance (SingKind (KProxy :: KProxy a),+              SingKind (KProxy :: KProxy b)) =>+             SingKind (KProxy :: KProxy (Either a b)) where+      type DemoteRep (KProxy :: KProxy (Either a b)) = Either (DemoteRep (KProxy :: KProxy a)) (DemoteRep (KProxy :: KProxy b))+      fromSing (SLeft b) = Left (fromSing b)+      fromSing (SRight b) = Right (fromSing b)+      toSing (Left b)+        = case toSing b :: SomeSing (KProxy :: KProxy a) of {+            SomeSing c -> SomeSing (SLeft c) }+      toSing (Right b)+        = case toSing b :: SomeSing (KProxy :: KProxy b) of {+            SomeSing c -> SomeSing (SRight c) }+    instance SingI n => SingI (Left (n :: a)) where+      sing = SLeft sing+    instance SingI n => SingI (Right (n :: b)) where+      sing = SRight sing
tests/compile-and-dump/Singletons/HigherOrder.hs view
@@ -1,10 +1,18 @@ module Singletons.HigherOrder where +import Data.Singletons import Data.Singletons.TH-import Data.Singletons.List-import Data.Singletons.Maybe+import Data.Singletons.Prelude.List hiding (+         sMap, Map, MapSym0, MapSym1, MapSym2,+         ZipWith, sZipWith, ZipWithSym0, ZipWithSym1, ZipWithSym2, ZipWithSym3 )+import Data.Singletons.Prelude.Maybe+import Singletons.Nat+import Prelude hiding (Either(..))+import Data.Singletons.SuppressUnusedWarnings  $(singletons [d|+  data Either a b = Left a | Right b+   map :: (a -> b) -> [a] -> [b]   map _ [] = []   map f (h:t) = (f h) : (map f t)@@ -12,4 +20,38 @@   liftMaybe :: (a -> b) -> Maybe a -> Maybe b   liftMaybe f (Just x) = Just (f x)   liftMaybe _ Nothing = Nothing++  zipWith :: (a -> b -> c) -> [a] -> [b] -> [c]+  zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys+  zipWith _ [] []         = []+  zipWith _ (_:_) []      = []+  zipWith _ [] (_:_)      = []++  foo :: ((a -> b) -> a -> b) -> (a -> b)  -> a -> b+  foo f g a = f g a++  splunge :: [Nat] -> [Bool] -> [Nat]+  splunge ns bs = zipWith (\n b -> if b then Succ (Succ n) else n) ns bs++  etad :: [Nat] -> [Bool] -> [Nat]+  etad = zipWith (\n b -> if b then Succ (Succ n) else n)+  |])++foo1a :: Proxy (ZipWith (TyCon2 Either) '[Int, Bool] '[Char, Double])+foo1a = Proxy++foo1b :: Proxy ('[Either Int Char, Either Bool Double])+foo1b = foo1a++foo2a :: Proxy (Map (TyCon1 (Either Int)) '[Bool, Double])+foo2a = Proxy++foo2b :: Proxy ('[Either Int Bool, Either Int Double])+foo2b = foo2a++foo3a :: Proxy (Map PredSym0 '[Succ Zero, Succ (Succ Zero)])+foo3a = Proxy++foo3b :: Proxy '[Zero, Succ Zero]+foo3b = foo3a
+ tests/compile-and-dump/Singletons/LambdaCase.ghc76.template view
@@ -0,0 +1,80 @@+Promote/LambdaCase.hs:0:0: Splicing declarations+    promote+      [d| foo1 :: a -> Maybe a -> a+          foo1 d x+            = (\case {+                 Just y -> y+                 Nothing -> d })+                x+          foo2 :: a -> Maybe a -> a+          foo2 d _+            = (\case {+                 Just y -> y+                 Nothing -> d })+                (Just d)+          foo3 :: a -> b -> a+          foo3 a b = (\case { (p, _) -> p }) (a, b) |]+  ======>+    Promote/LambdaCase.hs:(0,0)-(0,0)+    foo1 :: forall a. a -> Maybe a -> a+    foo1 d x+      = \case {+          Just y -> y+          Nothing -> d }+          x+    foo2 :: forall a. a -> Maybe a -> a+    foo2 d _+      = \case {+          Just y -> y+          Nothing -> d }+          (Just d)+    foo3 :: forall a b. a -> b -> a+    foo3 a b = \case { (p, _) -> p } (a, b)+    type family Case_0123456789 (t :: k)+                                (d :: d)+                                (x :: x)+                                (e :: e) :: r+    type instance Case_0123456789 (Just y) d x e = y+    type instance Case_0123456789 Nothing d x e = d+    type family Lambda_0123456789 (d :: d) (x :: x) (t :: k) :: r+    type instance Lambda_0123456789 d x e = Case_0123456789 e d x e+    data Lambda_0123456789Sym2 (l :: d) (l :: x) (l :: TyFun k r)+    type instance Apply (Lambda_0123456789Sym2 a a) a =+        Lambda_0123456789 a a a+    type family Case_0123456789 (t :: k) (d :: d) (e :: e) :: r+    type instance Case_0123456789 (Just y) d e = y+    type instance Case_0123456789 Nothing d e = d+    type family Lambda_0123456789 (d :: d) (t :: k) :: r+    type instance Lambda_0123456789 d e = Case_0123456789 e d e+    data Lambda_0123456789Sym1 (l :: d) (l :: TyFun k r)+    type instance Apply (Lambda_0123456789Sym1 a) a =+        Lambda_0123456789 a a+    type family Case_0123456789 (t :: k)+                                (a :: a)+                                (b :: b)+                                (e :: e) :: r+    type instance Case_0123456789 '(p, z) a b e = p+    type family Lambda_0123456789 (a :: a) (b :: b) (t :: k) :: r+    type instance Lambda_0123456789 a b e = Case_0123456789 e a b e+    data Lambda_0123456789Sym2 (l :: a) (l :: b) (l :: TyFun k r)+    type instance Apply (Lambda_0123456789Sym2 a a) a =+        Lambda_0123456789 a a a+    type family Foo1 (a :: a) (a :: Maybe a) :: a+    type instance Foo1 d x = Apply (Lambda_0123456789Sym2 d x) x+    data Foo1Sym1 (l :: a) (l :: TyFun (Maybe a) a)+    data Foo1Sym0 (k :: TyFun a (TyFun (Maybe a) a -> *))+    type instance Apply (Foo1Sym1 a) a = Foo1 a a+    type instance Apply Foo1Sym0 a = Foo1Sym1 a+    type family Foo2 (a :: a) (a :: Maybe a) :: a+    type instance Foo2 d z =+        Apply (Lambda_0123456789Sym1 d) (Apply JustSym0 d)+    data Foo2Sym1 (l :: a) (l :: TyFun (Maybe a) a)+    data Foo2Sym0 (k :: TyFun a (TyFun (Maybe a) a -> *))+    type instance Apply (Foo2Sym1 a) a = Foo2 a a+    type instance Apply Foo2Sym0 a = Foo2Sym1 a+    type family Foo3 (a :: a) (a :: b) :: a+    type instance Foo3 a b = Apply (Lambda_0123456789Sym2 a b) '(a, b)+    data Foo3Sym1 (l :: a) (l :: TyFun b a)+    data Foo3Sym0 (k :: TyFun a (TyFun b a -> *))+    type instance Apply (Foo3Sym1 a) a = Foo3 a a+    type instance Apply Foo3Sym0 a = Foo3Sym1 a
+ tests/compile-and-dump/Singletons/LambdaCase.ghc78.template view
@@ -0,0 +1,269 @@+Singletons/LambdaCase.hs:0:0: Splicing declarations+    singletons+      [d| foo1 :: a -> Maybe a -> a+          foo1 d x+            = (\case {+                 Just y -> y+                 Nothing -> d })+                x+          foo2 :: a -> Maybe a -> a+          foo2 d _+            = (\case {+                 Just y -> y+                 Nothing -> d })+                (Just d)+          foo3 :: a -> b -> a+          foo3 a b = (\case { (p, _) -> p }) (a, b) |]+  ======>+    Singletons/LambdaCase.hs:(0,0)-(0,0)+    foo1 :: forall a. a -> Maybe a -> a+    foo1 d x+      = \case {+          Just y -> y+          Nothing -> d }+          x+    foo2 :: forall a. a -> Maybe a -> a+    foo2 d _+      = \case {+          Just y -> y+          Nothing -> d }+          (Just d)+    foo3 :: forall a b. a -> b -> a+    foo3 a b = \case { (p, _) -> p } (a, b)+    type family Case_0123456789 a b x_0123456789 t where+      Case_0123456789 a b x_0123456789 (GHC.Tuple.(,) p z) = p+    type family Lambda_0123456789 a b t where+      Lambda_0123456789 a b x_0123456789 = Case_0123456789 a b x_0123456789 x_0123456789+    type Lambda_0123456789Sym3 t t t = Lambda_0123456789 t t t+    instance SuppressUnusedWarnings Lambda_0123456789Sym2 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym2KindInference GHC.Tuple.())+    data Lambda_0123456789Sym2 l l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym2 l l) arg)) (KindOf (Lambda_0123456789Sym3 l l arg)) =>+        Lambda_0123456789Sym2KindInference+    type instance Apply (Lambda_0123456789Sym2 l l) l = Lambda_0123456789Sym3 l l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym1 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym1KindInference GHC.Tuple.())+    data Lambda_0123456789Sym1 l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym1 l) arg)) (KindOf (Lambda_0123456789Sym2 l arg)) =>+        Lambda_0123456789Sym1KindInference+    type instance Apply (Lambda_0123456789Sym1 l) l = Lambda_0123456789Sym2 l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym0KindInference GHC.Tuple.())+    data Lambda_0123456789Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Lambda_0123456789Sym0 arg)) (KindOf (Lambda_0123456789Sym1 arg)) =>+        Lambda_0123456789Sym0KindInference+    type instance Apply Lambda_0123456789Sym0 l = Lambda_0123456789Sym1 l+    type family Case_0123456789 d x_0123456789 t where+      Case_0123456789 d x_0123456789 (Just y) = y+      Case_0123456789 d x_0123456789 Nothing = d+    type family Lambda_0123456789 d t where+      Lambda_0123456789 d x_0123456789 = Case_0123456789 d x_0123456789 x_0123456789+    type Lambda_0123456789Sym2 t t = Lambda_0123456789 t t+    instance SuppressUnusedWarnings Lambda_0123456789Sym1 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym1KindInference GHC.Tuple.())+    data Lambda_0123456789Sym1 l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym1 l) arg)) (KindOf (Lambda_0123456789Sym2 l arg)) =>+        Lambda_0123456789Sym1KindInference+    type instance Apply (Lambda_0123456789Sym1 l) l = Lambda_0123456789Sym2 l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym0KindInference GHC.Tuple.())+    data Lambda_0123456789Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Lambda_0123456789Sym0 arg)) (KindOf (Lambda_0123456789Sym1 arg)) =>+        Lambda_0123456789Sym0KindInference+    type instance Apply Lambda_0123456789Sym0 l = Lambda_0123456789Sym1 l+    type family Case_0123456789 d x x_0123456789 t where+      Case_0123456789 d x x_0123456789 (Just y) = y+      Case_0123456789 d x x_0123456789 Nothing = d+    type family Lambda_0123456789 d x t where+      Lambda_0123456789 d x x_0123456789 = Case_0123456789 d x x_0123456789 x_0123456789+    type Lambda_0123456789Sym3 t t t = Lambda_0123456789 t t t+    instance SuppressUnusedWarnings Lambda_0123456789Sym2 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym2KindInference GHC.Tuple.())+    data Lambda_0123456789Sym2 l l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym2 l l) arg)) (KindOf (Lambda_0123456789Sym3 l l arg)) =>+        Lambda_0123456789Sym2KindInference+    type instance Apply (Lambda_0123456789Sym2 l l) l = Lambda_0123456789Sym3 l l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym1 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym1KindInference GHC.Tuple.())+    data Lambda_0123456789Sym1 l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym1 l) arg)) (KindOf (Lambda_0123456789Sym2 l arg)) =>+        Lambda_0123456789Sym1KindInference+    type instance Apply (Lambda_0123456789Sym1 l) l = Lambda_0123456789Sym2 l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym0KindInference GHC.Tuple.())+    data Lambda_0123456789Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Lambda_0123456789Sym0 arg)) (KindOf (Lambda_0123456789Sym1 arg)) =>+        Lambda_0123456789Sym0KindInference+    type instance Apply Lambda_0123456789Sym0 l = Lambda_0123456789Sym1 l+    type Foo3Sym2 (t :: a) (t :: b) = Foo3 t t+    instance SuppressUnusedWarnings Foo3Sym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo3Sym1KindInference GHC.Tuple.())+    data Foo3Sym1 (l :: a) (l :: TyFun b a)+      = forall arg. (GHC.Types.~) (KindOf (Apply (Foo3Sym1 l) arg)) (KindOf (Foo3Sym2 l arg)) =>+        Foo3Sym1KindInference+    type instance Apply (Foo3Sym1 l) l = Foo3Sym2 l l+    instance SuppressUnusedWarnings Foo3Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo3Sym0KindInference GHC.Tuple.())+    data Foo3Sym0 (l :: TyFun a (TyFun b a -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply Foo3Sym0 arg)) (KindOf (Foo3Sym1 arg)) =>+        Foo3Sym0KindInference+    type instance Apply Foo3Sym0 l = Foo3Sym1 l+    type Foo2Sym2 (t :: a) (t :: Maybe a) = Foo2 t t+    instance SuppressUnusedWarnings Foo2Sym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo2Sym1KindInference GHC.Tuple.())+    data Foo2Sym1 (l :: a) (l :: TyFun (Maybe a) a)+      = forall arg. (GHC.Types.~) (KindOf (Apply (Foo2Sym1 l) arg)) (KindOf (Foo2Sym2 l arg)) =>+        Foo2Sym1KindInference+    type instance Apply (Foo2Sym1 l) l = Foo2Sym2 l l+    instance SuppressUnusedWarnings Foo2Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo2Sym0KindInference GHC.Tuple.())+    data Foo2Sym0 (l :: TyFun a (TyFun (Maybe a) a -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply Foo2Sym0 arg)) (KindOf (Foo2Sym1 arg)) =>+        Foo2Sym0KindInference+    type instance Apply Foo2Sym0 l = Foo2Sym1 l+    type Foo1Sym2 (t :: a) (t :: Maybe a) = Foo1 t t+    instance SuppressUnusedWarnings Foo1Sym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo1Sym1KindInference GHC.Tuple.())+    data Foo1Sym1 (l :: a) (l :: TyFun (Maybe a) a)+      = forall arg. (GHC.Types.~) (KindOf (Apply (Foo1Sym1 l) arg)) (KindOf (Foo1Sym2 l arg)) =>+        Foo1Sym1KindInference+    type instance Apply (Foo1Sym1 l) l = Foo1Sym2 l l+    instance SuppressUnusedWarnings Foo1Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo1Sym0KindInference GHC.Tuple.())+    data Foo1Sym0 (l :: TyFun a (TyFun (Maybe a) a -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply Foo1Sym0 arg)) (KindOf (Foo1Sym1 arg)) =>+        Foo1Sym0KindInference+    type instance Apply Foo1Sym0 l = Foo1Sym1 l+    type family Foo3 (a :: a) (a :: b) :: a where+      Foo3 a b = Apply (Apply (Apply Lambda_0123456789Sym0 a) b) (Apply (Apply Tuple2Sym0 a) b)+    type family Foo2 (a :: a) (a :: Maybe a) :: a where+      Foo2 d z = Apply (Apply Lambda_0123456789Sym0 d) (Apply JustSym0 d)+    type family Foo1 (a :: a) (a :: Maybe a) :: a where+      Foo1 d x = Apply (Apply (Apply Lambda_0123456789Sym0 d) x) x+    sFoo3 ::+      forall (t :: a) (t :: b).+      Sing t -> Sing t -> Sing (Apply (Apply Foo3Sym0 t) t)+    sFoo2 ::+      forall (t :: a) (t :: Maybe a).+      Sing t -> Sing t -> Sing (Apply (Apply Foo2Sym0 t) t)+    sFoo1 ::+      forall (t :: a) (t :: Maybe a).+      Sing t -> Sing t -> Sing (Apply (Apply Foo1Sym0 t) t)+    sFoo3 sA sB+      = let+          lambda ::+            forall a b. ((GHC.Types.~) t a, (GHC.Types.~) t b) =>+            Sing a -> Sing b -> Sing (Apply (Apply Foo3Sym0 a) b)+          lambda a b+            = applySing+                (singFun1+                   (Proxy :: Proxy (Apply (Apply Lambda_0123456789Sym0 a) b))+                   (\ sX_0123456789+                      -> let+                           lambda ::+                             forall x_0123456789.+                             Sing x_0123456789+                             -> Sing (Apply (Apply (Apply Lambda_0123456789Sym0 a) b) x_0123456789)+                           lambda x_0123456789+                             = case x_0123456789 of {+                                 STuple2 sP _+                                   -> let+                                        lambda ::+                                          forall p wild.+                                          Sing p+                                          -> Sing (Case_0123456789 a b x_0123456789 (Apply (Apply Tuple2Sym0 p) wild))+                                        lambda p = p+                                      in lambda sP }+                         in lambda sX_0123456789))+                (applySing+                   (applySing (singFun2 (Proxy :: Proxy Tuple2Sym0) STuple2) a) b)+        in lambda sA sB+    sFoo2 sD _+      = let+          lambda ::+            forall d wild. ((GHC.Types.~) t d, (GHC.Types.~) t wild) =>+            Sing d -> Sing (Apply (Apply Foo2Sym0 d) wild)+          lambda d+            = applySing+                (singFun1+                   (Proxy :: Proxy (Apply Lambda_0123456789Sym0 d))+                   (\ sX_0123456789+                      -> let+                           lambda ::+                             forall x_0123456789.+                             Sing x_0123456789+                             -> Sing (Apply (Apply Lambda_0123456789Sym0 d) x_0123456789)+                           lambda x_0123456789+                             = case x_0123456789 of {+                                 SJust sY+                                   -> let+                                        lambda ::+                                          forall y.+                                          Sing y+                                          -> Sing (Case_0123456789 d x_0123456789 (Apply JustSym0 y))+                                        lambda y = y+                                      in lambda sY+                                 SNothing+                                   -> let+                                        lambda :: Sing (Case_0123456789 d x_0123456789 NothingSym0)+                                        lambda = d+                                      in lambda }+                         in lambda sX_0123456789))+                (applySing (singFun1 (Proxy :: Proxy JustSym0) SJust) d)+        in lambda sD+    sFoo1 sD sX+      = let+          lambda ::+            forall d x. ((GHC.Types.~) t d, (GHC.Types.~) t x) =>+            Sing d -> Sing x -> Sing (Apply (Apply Foo1Sym0 d) x)+          lambda d x+            = applySing+                (singFun1+                   (Proxy :: Proxy (Apply (Apply Lambda_0123456789Sym0 d) x))+                   (\ sX_0123456789+                      -> let+                           lambda ::+                             forall x_0123456789.+                             Sing x_0123456789+                             -> Sing (Apply (Apply (Apply Lambda_0123456789Sym0 d) x) x_0123456789)+                           lambda x_0123456789+                             = case x_0123456789 of {+                                 SJust sY+                                   -> let+                                        lambda ::+                                          forall y.+                                          Sing y+                                          -> Sing (Case_0123456789 d x x_0123456789 (Apply JustSym0 y))+                                        lambda y = y+                                      in lambda sY+                                 SNothing+                                   -> let+                                        lambda ::+                                          Sing (Case_0123456789 d x x_0123456789 NothingSym0)+                                        lambda = d+                                      in lambda }+                         in lambda sX_0123456789))+                x+        in lambda sD sX
+ tests/compile-and-dump/Singletons/LambdaCase.hs view
@@ -0,0 +1,39 @@+module Singletons.LambdaCase where++import Data.Singletons.Prelude+import Data.Singletons.SuppressUnusedWarnings+import Data.Singletons.TH++$(singletons [d|+  foo1 :: a -> Maybe a -> a+  foo1 d x = (\case+               Just y  -> y+               Nothing -> d) x++  foo2 :: a -> Maybe a -> a+  foo2 d _ = (\case+               Just y  -> y+               Nothing -> d) (Just d)++  foo3 :: a -> b -> a+  foo3 a b = (\case+               (p, _)  -> p) (a, b)+ |])++foo1a :: Proxy (Foo1 Int (Just Char))+foo1a = Proxy++foo1b :: Proxy Char+foo1b = foo1a++foo2a :: Proxy (Foo2 Char Nothing)+foo2a = Proxy++foo2b :: Proxy Char+foo2b = foo2a++foo3a :: Proxy (Foo3 Int Char)+foo3a = Proxy++foo3b :: Proxy Int+foo3b = foo3a
+ tests/compile-and-dump/Singletons/Lambdas.ghc76.template view
@@ -0,0 +1,173 @@+Promote/Lambdas.hs:0:0: Splicing declarations+    promote+      [d| foo0 :: a -> b -> a+          foo0 = (\ x y -> x)+          foo1 :: a -> b -> a+          foo1 x = (\ _ -> x)+          foo2 :: a -> b -> a+          foo2 x y = (\ _ -> x) y+          foo3 :: a -> a+          foo3 x = (\ y -> y) x+          foo4 :: a -> b -> c -> a+          foo4 x y z = (\ _ _ -> x) y z+          foo5 :: a -> b -> b+          foo5 x y = (\ x -> x) y+          foo6 :: a -> b -> a+          foo6 a b = (\ x -> \ _ -> x) a b+          foo7 :: a -> b -> b+          foo7 x y = (\ (_, b) -> b) (x, y)+          foo8 :: Foo a b -> a+          foo8 x = (\ (Foo a _) -> a) x+          +          data Foo a b = Foo a b |]+  ======>+    Promote/Lambdas.hs:(0,0)-(0,0)+    foo0 :: forall a b. a -> b -> a+    foo0 = \ x y -> x+    foo1 :: forall a b. a -> b -> a+    foo1 x = \ _ -> x+    foo2 :: forall a b. a -> b -> a+    foo2 x y = \ _ -> x y+    foo3 :: forall a. a -> a+    foo3 x = \ y -> y x+    foo4 :: forall a b c. a -> b -> c -> a+    foo4 x y z = \ _ _ -> x y z+    foo5 :: forall a b. a -> b -> b+    foo5 x y = \ x -> x y+    foo6 :: forall a b. a -> b -> a+    foo6 a b = \ x -> \ _ -> x a b+    foo7 :: forall a b. a -> b -> b+    foo7 x y = \ (_, b) -> b (x, y)+    data Foo a b = Foo a b+    foo8 :: forall a b. Foo a b -> a+    foo8 x = \ (Foo a _) -> a x+    type Foo0 = Lambda_0123456789Sym0+    type Foo0Sym0 = Foo0+    type family Lambda_0123456789 (t :: k) (t :: k) :: r+    type instance Lambda_0123456789 x y = x+    data Lambda_0123456789Sym1 (l :: k) (l :: TyFun k r)+    data Lambda_0123456789Sym0 (k :: TyFun k (TyFun k r -> *))+    type instance Apply (Lambda_0123456789Sym1 a) a =+        Lambda_0123456789 a a+    type instance Apply Lambda_0123456789Sym0 a =+        Lambda_0123456789Sym1 a+    type family Lambda_0123456789 (x :: x) (t :: k) :: r+    type instance Lambda_0123456789 x z = x+    data Lambda_0123456789Sym1 (l :: x) (l :: TyFun k r)+    type instance Apply (Lambda_0123456789Sym1 a) a =+        Lambda_0123456789 a a+    type family Lambda_0123456789 (x :: x) (y :: y) (t :: k) :: r+    type instance Lambda_0123456789 x y z = x+    data Lambda_0123456789Sym2 (l :: x) (l :: y) (l :: TyFun k r)+    type instance Apply (Lambda_0123456789Sym2 a a) a =+        Lambda_0123456789 a a a+    type family Lambda_0123456789 (x :: x) (t :: k) :: r+    type instance Lambda_0123456789 x y = y+    data Lambda_0123456789Sym1 (l :: x) (l :: TyFun k r)+    type instance Apply (Lambda_0123456789Sym1 a) a =+        Lambda_0123456789 a a+    type family Lambda_0123456789 (x :: x)+                                  (y :: y)+                                  (z :: z)+                                  (t :: k)+                                  (t :: k) :: r+    type instance Lambda_0123456789 x y z z z = x+    data Lambda_0123456789Sym4 (l :: x)+                               (l :: y)+                               (l :: z)+                               (l :: k)+                               (l :: TyFun k r)+    data Lambda_0123456789Sym3 (l :: x)+                               (l :: y)+                               (l :: z)+                               (l :: TyFun k (TyFun k r -> *))+    type instance Apply (Lambda_0123456789Sym4 a a a a) a =+        Lambda_0123456789 a a a a a+    type instance Apply (Lambda_0123456789Sym3 a a a) a =+        Lambda_0123456789Sym4 a a a a+    type family Lambda_0123456789 (x :: x) (y :: y) (t :: k) :: r+    type instance Lambda_0123456789 x y x = x+    data Lambda_0123456789Sym2 (l :: x) (l :: y) (l :: TyFun k r)+    type instance Apply (Lambda_0123456789Sym2 a a) a =+        Lambda_0123456789 a a a+    type family Lambda_0123456789 (a :: a)+                                  (b :: b)+                                  (x :: x)+                                  (t :: k) :: r+    type instance Lambda_0123456789 a b x z = x+    data Lambda_0123456789Sym3 (l :: a)+                               (l :: b)+                               (l :: x)+                               (l :: TyFun k r)+    type instance Apply (Lambda_0123456789Sym3 a a a) a =+        Lambda_0123456789 a a a a+    type family Lambda_0123456789 (a :: a) (b :: b) (t :: k) :: r+    type instance Lambda_0123456789 a b x = Lambda_0123456789Sym3 a b x+    data Lambda_0123456789Sym2 (l :: a) (l :: b) (l :: TyFun k r)+    type instance Apply (Lambda_0123456789Sym2 a a) a =+        Lambda_0123456789 a a a+    type family Lambda_0123456789 (x :: x) (y :: y) (t :: k) :: r+    type instance Lambda_0123456789 x y '(z, b) = b+    data Lambda_0123456789Sym2 (l :: x) (l :: y) (l :: TyFun k r)+    type instance Apply (Lambda_0123456789Sym2 a a) a =+        Lambda_0123456789 a a a+    type FooTyCtor = Foo+    data FooTyCtorSym1 (l :: *) (l :: TyFun * *)+    data FooTyCtorSym0 (k :: TyFun * (TyFun * * -> *))+    type instance Apply (FooTyCtorSym1 a) a = FooTyCtor a a+    type instance Apply FooTyCtorSym0 a = FooTyCtorSym1 a+    data FooSym1 (l :: a) (l :: TyFun b (Foo a b))+    data FooSym0 (k :: TyFun a (TyFun b (Foo a b) -> *))+    type instance Apply (FooSym1 a) a = Foo a a+    type instance Apply FooSym0 a = FooSym1 a+    type family Lambda_0123456789 (x :: x) (t :: k) :: r+    type instance Lambda_0123456789 x (Foo a z) = a+    data Lambda_0123456789Sym1 (l :: x) (l :: TyFun k r)+    type instance Apply (Lambda_0123456789Sym1 a) a =+        Lambda_0123456789 a a+    type family Foo1 (a :: a) :: TyFun a b -> *+    type instance Foo1 x = Lambda_0123456789Sym1 x+    data Foo1Sym0 (k :: TyFun a (TyFun a b -> *))+    type instance Apply Foo1Sym0 a = Foo1 a+    type family Foo2 (a :: a) (a :: b) :: a+    type instance Foo2 x y = Apply (Lambda_0123456789Sym2 x y) y+    data Foo2Sym1 (l :: a) (l :: TyFun b a)+    data Foo2Sym0 (k :: TyFun a (TyFun b a -> *))+    type instance Apply (Foo2Sym1 a) a = Foo2 a a+    type instance Apply Foo2Sym0 a = Foo2Sym1 a+    type family Foo3 (a :: a) :: a+    type instance Foo3 x = Apply (Lambda_0123456789Sym1 x) x+    data Foo3Sym0 (k :: TyFun a a)+    type instance Apply Foo3Sym0 a = Foo3 a+    type family Foo4 (a :: a) (a :: b) (a :: c) :: a+    type instance Foo4 x y z =+        Apply (Apply (Lambda_0123456789Sym3 x y z) y) z+    data Foo4Sym2 (l :: a) (l :: b) (l :: TyFun c a)+    data Foo4Sym1 (l :: a) (l :: TyFun b (TyFun c a -> *))+    data Foo4Sym0 (k :: TyFun a (TyFun b (TyFun c a -> *) -> *))+    type instance Apply (Foo4Sym2 a a) a = Foo4 a a a+    type instance Apply (Foo4Sym1 a) a = Foo4Sym2 a a+    type instance Apply Foo4Sym0 a = Foo4Sym1 a+    type family Foo5 (a :: a) (a :: b) :: b+    type instance Foo5 x y = Apply (Lambda_0123456789Sym2 x y) y+    data Foo5Sym1 (l :: a) (l :: TyFun b b)+    data Foo5Sym0 (k :: TyFun a (TyFun b b -> *))+    type instance Apply (Foo5Sym1 a) a = Foo5 a a+    type instance Apply Foo5Sym0 a = Foo5Sym1 a+    type family Foo6 (a :: a) (a :: b) :: a+    type instance Foo6 a b =+        Apply (Apply (Lambda_0123456789Sym2 a b) a) b+    data Foo6Sym1 (l :: a) (l :: TyFun b a)+    data Foo6Sym0 (k :: TyFun a (TyFun b a -> *))+    type instance Apply (Foo6Sym1 a) a = Foo6 a a+    type instance Apply Foo6Sym0 a = Foo6Sym1 a+    type family Foo7 (a :: a) (a :: b) :: b+    type instance Foo7 x y = Apply (Lambda_0123456789Sym2 x y) '(x, y)+    data Foo7Sym1 (l :: a) (l :: TyFun b b)+    data Foo7Sym0 (k :: TyFun a (TyFun b b -> *))+    type instance Apply (Foo7Sym1 a) a = Foo7 a a+    type instance Apply Foo7Sym0 a = Foo7Sym1 a+    type family Foo8 (a :: Foo a b) :: a+    type instance Foo8 x = Apply (Lambda_0123456789Sym1 x) x+    data Foo8Sym0 (k :: TyFun (Foo a b) a)+    type instance Apply Foo8Sym0 a = Foo8 a
+ tests/compile-and-dump/Singletons/Lambdas.ghc78.template view
@@ -0,0 +1,799 @@+Singletons/Lambdas.hs:0:0: Splicing declarations+    singletons+      [d| foo0 :: a -> b -> a+          foo0 = (\ x y -> x)+          foo1 :: a -> b -> a+          foo1 x = (\ _ -> x)+          foo2 :: a -> b -> a+          foo2 x y = (\ _ -> x) y+          foo3 :: a -> a+          foo3 x = (\ y -> y) x+          foo4 :: a -> b -> c -> a+          foo4 x y z = (\ _ _ -> x) y z+          foo5 :: a -> b -> b+          foo5 x y = (\ x -> x) y+          foo6 :: a -> b -> a+          foo6 a b = (\ x -> \ _ -> x) a b+          foo7 :: a -> b -> b+          foo7 x y = (\ (_, b) -> b) (x, y)+          foo8 :: Foo a b -> a+          foo8 x = (\ (Foo a _) -> a) x+          +          data Foo a b = Foo a b |]+  ======>+    Singletons/Lambdas.hs:(0,0)-(0,0)+    foo0 :: forall a b. a -> b -> a+    foo0 = \ x y -> x+    foo1 :: forall a b. a -> b -> a+    foo1 x = \ _ -> x+    foo2 :: forall a b. a -> b -> a+    foo2 x y = \ _ -> x y+    foo3 :: forall a. a -> a+    foo3 x = \ y -> y x+    foo4 :: forall a b c. a -> b -> c -> a+    foo4 x y z = \ _ _ -> x y z+    foo5 :: forall a b. a -> b -> b+    foo5 x y = \ x -> x y+    foo6 :: forall a b. a -> b -> a+    foo6 a b = \ x -> \ _ -> x a b+    foo7 :: forall a b. a -> b -> b+    foo7 x y = \ (_, b) -> b (x, y)+    data Foo a b = Foo a b+    foo8 :: forall a b. Foo a b -> a+    foo8 x = \ (Foo a _) -> a x+    type FooSym2 (t :: a) (t :: b) = Foo t t+    instance SuppressUnusedWarnings FooSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) FooSym1KindInference GHC.Tuple.())+    data FooSym1 (l :: a) (l :: TyFun b (Foo a b))+      = forall arg. (GHC.Types.~) (KindOf (Apply (FooSym1 l) arg)) (KindOf (FooSym2 l arg)) =>+        FooSym1KindInference+    type instance Apply (FooSym1 l) l = FooSym2 l l+    instance SuppressUnusedWarnings FooSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) FooSym0KindInference GHC.Tuple.())+    data FooSym0 (l :: TyFun a (TyFun b (Foo a b) -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply FooSym0 arg)) (KindOf (FooSym1 arg)) =>+        FooSym0KindInference+    type instance Apply FooSym0 l = FooSym1 l+    type family Case_0123456789 x arg_0123456789 t where+      Case_0123456789 x arg_0123456789 (Foo a z) = a+    type family Lambda_0123456789 x t where+      Lambda_0123456789 x arg_0123456789 = Case_0123456789 x arg_0123456789 arg_0123456789+    type Lambda_0123456789Sym2 t t = Lambda_0123456789 t t+    instance SuppressUnusedWarnings Lambda_0123456789Sym1 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym1KindInference GHC.Tuple.())+    data Lambda_0123456789Sym1 l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym1 l) arg)) (KindOf (Lambda_0123456789Sym2 l arg)) =>+        Lambda_0123456789Sym1KindInference+    type instance Apply (Lambda_0123456789Sym1 l) l = Lambda_0123456789Sym2 l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym0KindInference GHC.Tuple.())+    data Lambda_0123456789Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Lambda_0123456789Sym0 arg)) (KindOf (Lambda_0123456789Sym1 arg)) =>+        Lambda_0123456789Sym0KindInference+    type instance Apply Lambda_0123456789Sym0 l = Lambda_0123456789Sym1 l+    type family Case_0123456789 x y arg_0123456789 t where+      Case_0123456789 x y arg_0123456789 (GHC.Tuple.(,) z b) = b+    type family Lambda_0123456789 x y t where+      Lambda_0123456789 x y arg_0123456789 = Case_0123456789 x y arg_0123456789 arg_0123456789+    type Lambda_0123456789Sym3 t t t = Lambda_0123456789 t t t+    instance SuppressUnusedWarnings Lambda_0123456789Sym2 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym2KindInference GHC.Tuple.())+    data Lambda_0123456789Sym2 l l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym2 l l) arg)) (KindOf (Lambda_0123456789Sym3 l l arg)) =>+        Lambda_0123456789Sym2KindInference+    type instance Apply (Lambda_0123456789Sym2 l l) l = Lambda_0123456789Sym3 l l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym1 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym1KindInference GHC.Tuple.())+    data Lambda_0123456789Sym1 l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym1 l) arg)) (KindOf (Lambda_0123456789Sym2 l arg)) =>+        Lambda_0123456789Sym1KindInference+    type instance Apply (Lambda_0123456789Sym1 l) l = Lambda_0123456789Sym2 l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym0KindInference GHC.Tuple.())+    data Lambda_0123456789Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Lambda_0123456789Sym0 arg)) (KindOf (Lambda_0123456789Sym1 arg)) =>+        Lambda_0123456789Sym0KindInference+    type instance Apply Lambda_0123456789Sym0 l = Lambda_0123456789Sym1 l+    type family Case_0123456789 a b x arg_0123456789 t where+      Case_0123456789 a b x arg_0123456789 z = x+    type family Lambda_0123456789 a b x t where+      Lambda_0123456789 a b x arg_0123456789 = Case_0123456789 a b x arg_0123456789 arg_0123456789+    type Lambda_0123456789Sym4 t t t t = Lambda_0123456789 t t t t+    instance SuppressUnusedWarnings Lambda_0123456789Sym3 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym3KindInference GHC.Tuple.())+    data Lambda_0123456789Sym3 l l l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym3 l l l) arg)) (KindOf (Lambda_0123456789Sym4 l l l arg)) =>+        Lambda_0123456789Sym3KindInference+    type instance Apply (Lambda_0123456789Sym3 l l l) l = Lambda_0123456789Sym4 l l l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym2 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym2KindInference GHC.Tuple.())+    data Lambda_0123456789Sym2 l l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym2 l l) arg)) (KindOf (Lambda_0123456789Sym3 l l arg)) =>+        Lambda_0123456789Sym2KindInference+    type instance Apply (Lambda_0123456789Sym2 l l) l = Lambda_0123456789Sym3 l l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym1 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym1KindInference GHC.Tuple.())+    data Lambda_0123456789Sym1 l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym1 l) arg)) (KindOf (Lambda_0123456789Sym2 l arg)) =>+        Lambda_0123456789Sym1KindInference+    type instance Apply (Lambda_0123456789Sym1 l) l = Lambda_0123456789Sym2 l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym0KindInference GHC.Tuple.())+    data Lambda_0123456789Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Lambda_0123456789Sym0 arg)) (KindOf (Lambda_0123456789Sym1 arg)) =>+        Lambda_0123456789Sym0KindInference+    type instance Apply Lambda_0123456789Sym0 l = Lambda_0123456789Sym1 l+    type family Lambda_0123456789 a b t where+      Lambda_0123456789 a b x = Apply (Apply (Apply Lambda_0123456789Sym0 a) b) x+    type Lambda_0123456789Sym3 t t t = Lambda_0123456789 t t t+    instance SuppressUnusedWarnings Lambda_0123456789Sym2 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym2KindInference GHC.Tuple.())+    data Lambda_0123456789Sym2 l l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym2 l l) arg)) (KindOf (Lambda_0123456789Sym3 l l arg)) =>+        Lambda_0123456789Sym2KindInference+    type instance Apply (Lambda_0123456789Sym2 l l) l = Lambda_0123456789Sym3 l l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym1 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym1KindInference GHC.Tuple.())+    data Lambda_0123456789Sym1 l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym1 l) arg)) (KindOf (Lambda_0123456789Sym2 l arg)) =>+        Lambda_0123456789Sym1KindInference+    type instance Apply (Lambda_0123456789Sym1 l) l = Lambda_0123456789Sym2 l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym0KindInference GHC.Tuple.())+    data Lambda_0123456789Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Lambda_0123456789Sym0 arg)) (KindOf (Lambda_0123456789Sym1 arg)) =>+        Lambda_0123456789Sym0KindInference+    type instance Apply Lambda_0123456789Sym0 l = Lambda_0123456789Sym1 l+    type family Lambda_0123456789 x y t where+      Lambda_0123456789 x y x = x+    type Lambda_0123456789Sym3 t t t = Lambda_0123456789 t t t+    instance SuppressUnusedWarnings Lambda_0123456789Sym2 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym2KindInference GHC.Tuple.())+    data Lambda_0123456789Sym2 l l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym2 l l) arg)) (KindOf (Lambda_0123456789Sym3 l l arg)) =>+        Lambda_0123456789Sym2KindInference+    type instance Apply (Lambda_0123456789Sym2 l l) l = Lambda_0123456789Sym3 l l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym1 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym1KindInference GHC.Tuple.())+    data Lambda_0123456789Sym1 l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym1 l) arg)) (KindOf (Lambda_0123456789Sym2 l arg)) =>+        Lambda_0123456789Sym1KindInference+    type instance Apply (Lambda_0123456789Sym1 l) l = Lambda_0123456789Sym2 l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym0KindInference GHC.Tuple.())+    data Lambda_0123456789Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Lambda_0123456789Sym0 arg)) (KindOf (Lambda_0123456789Sym1 arg)) =>+        Lambda_0123456789Sym0KindInference+    type instance Apply Lambda_0123456789Sym0 l = Lambda_0123456789Sym1 l+    type family Case_0123456789 x+                                y+                                z+                                arg_0123456789+                                arg_0123456789+                                t where+      Case_0123456789 x y z arg_0123456789 arg_0123456789 (GHC.Tuple.(,) z z) = x+    type family Lambda_0123456789 x y z t t where+      Lambda_0123456789 x y z arg_0123456789 arg_0123456789 = Case_0123456789 x y z arg_0123456789 arg_0123456789 (Apply (Apply Tuple2Sym0 arg_0123456789) arg_0123456789)+    type Lambda_0123456789Sym5 t t t t t = Lambda_0123456789 t t t t t+    instance SuppressUnusedWarnings Lambda_0123456789Sym4 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym4KindInference GHC.Tuple.())+    data Lambda_0123456789Sym4 l l l l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym4 l l l l) arg)) (KindOf (Lambda_0123456789Sym5 l l l l arg)) =>+        Lambda_0123456789Sym4KindInference+    type instance Apply (Lambda_0123456789Sym4 l l l l) l = Lambda_0123456789Sym5 l l l l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym3 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym3KindInference GHC.Tuple.())+    data Lambda_0123456789Sym3 l l l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym3 l l l) arg)) (KindOf (Lambda_0123456789Sym4 l l l arg)) =>+        Lambda_0123456789Sym3KindInference+    type instance Apply (Lambda_0123456789Sym3 l l l) l = Lambda_0123456789Sym4 l l l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym2 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym2KindInference GHC.Tuple.())+    data Lambda_0123456789Sym2 l l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym2 l l) arg)) (KindOf (Lambda_0123456789Sym3 l l arg)) =>+        Lambda_0123456789Sym2KindInference+    type instance Apply (Lambda_0123456789Sym2 l l) l = Lambda_0123456789Sym3 l l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym1 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym1KindInference GHC.Tuple.())+    data Lambda_0123456789Sym1 l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym1 l) arg)) (KindOf (Lambda_0123456789Sym2 l arg)) =>+        Lambda_0123456789Sym1KindInference+    type instance Apply (Lambda_0123456789Sym1 l) l = Lambda_0123456789Sym2 l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym0KindInference GHC.Tuple.())+    data Lambda_0123456789Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Lambda_0123456789Sym0 arg)) (KindOf (Lambda_0123456789Sym1 arg)) =>+        Lambda_0123456789Sym0KindInference+    type instance Apply Lambda_0123456789Sym0 l = Lambda_0123456789Sym1 l+    type family Lambda_0123456789 x t where+      Lambda_0123456789 x y = y+    type Lambda_0123456789Sym2 t t = Lambda_0123456789 t t+    instance SuppressUnusedWarnings Lambda_0123456789Sym1 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym1KindInference GHC.Tuple.())+    data Lambda_0123456789Sym1 l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym1 l) arg)) (KindOf (Lambda_0123456789Sym2 l arg)) =>+        Lambda_0123456789Sym1KindInference+    type instance Apply (Lambda_0123456789Sym1 l) l = Lambda_0123456789Sym2 l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym0KindInference GHC.Tuple.())+    data Lambda_0123456789Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Lambda_0123456789Sym0 arg)) (KindOf (Lambda_0123456789Sym1 arg)) =>+        Lambda_0123456789Sym0KindInference+    type instance Apply Lambda_0123456789Sym0 l = Lambda_0123456789Sym1 l+    type family Case_0123456789 x y arg_0123456789 t where+      Case_0123456789 x y arg_0123456789 z = x+    type family Lambda_0123456789 x y t where+      Lambda_0123456789 x y arg_0123456789 = Case_0123456789 x y arg_0123456789 arg_0123456789+    type Lambda_0123456789Sym3 t t t = Lambda_0123456789 t t t+    instance SuppressUnusedWarnings Lambda_0123456789Sym2 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym2KindInference GHC.Tuple.())+    data Lambda_0123456789Sym2 l l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym2 l l) arg)) (KindOf (Lambda_0123456789Sym3 l l arg)) =>+        Lambda_0123456789Sym2KindInference+    type instance Apply (Lambda_0123456789Sym2 l l) l = Lambda_0123456789Sym3 l l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym1 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym1KindInference GHC.Tuple.())+    data Lambda_0123456789Sym1 l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym1 l) arg)) (KindOf (Lambda_0123456789Sym2 l arg)) =>+        Lambda_0123456789Sym1KindInference+    type instance Apply (Lambda_0123456789Sym1 l) l = Lambda_0123456789Sym2 l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym0KindInference GHC.Tuple.())+    data Lambda_0123456789Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Lambda_0123456789Sym0 arg)) (KindOf (Lambda_0123456789Sym1 arg)) =>+        Lambda_0123456789Sym0KindInference+    type instance Apply Lambda_0123456789Sym0 l = Lambda_0123456789Sym1 l+    type family Case_0123456789 x arg_0123456789 a_0123456789 t where+      Case_0123456789 x arg_0123456789 a_0123456789 z = x+    type family Lambda_0123456789 x a_0123456789 t where+      Lambda_0123456789 x a_0123456789 arg_0123456789 = Case_0123456789 x arg_0123456789 a_0123456789 arg_0123456789+    type Lambda_0123456789Sym3 t t t = Lambda_0123456789 t t t+    instance SuppressUnusedWarnings Lambda_0123456789Sym2 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym2KindInference GHC.Tuple.())+    data Lambda_0123456789Sym2 l l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym2 l l) arg)) (KindOf (Lambda_0123456789Sym3 l l arg)) =>+        Lambda_0123456789Sym2KindInference+    type instance Apply (Lambda_0123456789Sym2 l l) l = Lambda_0123456789Sym3 l l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym1 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym1KindInference GHC.Tuple.())+    data Lambda_0123456789Sym1 l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym1 l) arg)) (KindOf (Lambda_0123456789Sym2 l arg)) =>+        Lambda_0123456789Sym1KindInference+    type instance Apply (Lambda_0123456789Sym1 l) l = Lambda_0123456789Sym2 l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym0KindInference GHC.Tuple.())+    data Lambda_0123456789Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Lambda_0123456789Sym0 arg)) (KindOf (Lambda_0123456789Sym1 arg)) =>+        Lambda_0123456789Sym0KindInference+    type instance Apply Lambda_0123456789Sym0 l = Lambda_0123456789Sym1 l+    type family Lambda_0123456789 a_0123456789 a_0123456789 t t where+      Lambda_0123456789 a_0123456789 a_0123456789 x y = x+    type Lambda_0123456789Sym4 t t t t = Lambda_0123456789 t t t t+    instance SuppressUnusedWarnings Lambda_0123456789Sym3 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym3KindInference GHC.Tuple.())+    data Lambda_0123456789Sym3 l l l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym3 l l l) arg)) (KindOf (Lambda_0123456789Sym4 l l l arg)) =>+        Lambda_0123456789Sym3KindInference+    type instance Apply (Lambda_0123456789Sym3 l l l) l = Lambda_0123456789Sym4 l l l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym2 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym2KindInference GHC.Tuple.())+    data Lambda_0123456789Sym2 l l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym2 l l) arg)) (KindOf (Lambda_0123456789Sym3 l l arg)) =>+        Lambda_0123456789Sym2KindInference+    type instance Apply (Lambda_0123456789Sym2 l l) l = Lambda_0123456789Sym3 l l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym1 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym1KindInference GHC.Tuple.())+    data Lambda_0123456789Sym1 l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym1 l) arg)) (KindOf (Lambda_0123456789Sym2 l arg)) =>+        Lambda_0123456789Sym1KindInference+    type instance Apply (Lambda_0123456789Sym1 l) l = Lambda_0123456789Sym2 l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym0KindInference GHC.Tuple.())+    data Lambda_0123456789Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Lambda_0123456789Sym0 arg)) (KindOf (Lambda_0123456789Sym1 arg)) =>+        Lambda_0123456789Sym0KindInference+    type instance Apply Lambda_0123456789Sym0 l = Lambda_0123456789Sym1 l+    type Foo8Sym1 (t :: Foo a b) = Foo8 t+    instance SuppressUnusedWarnings Foo8Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo8Sym0KindInference GHC.Tuple.())+    data Foo8Sym0 (l :: TyFun (Foo a b) a)+      = forall arg. (GHC.Types.~) (KindOf (Apply Foo8Sym0 arg)) (KindOf (Foo8Sym1 arg)) =>+        Foo8Sym0KindInference+    type instance Apply Foo8Sym0 l = Foo8Sym1 l+    type Foo7Sym2 (t :: a) (t :: b) = Foo7 t t+    instance SuppressUnusedWarnings Foo7Sym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo7Sym1KindInference GHC.Tuple.())+    data Foo7Sym1 (l :: a) (l :: TyFun b b)+      = forall arg. (GHC.Types.~) (KindOf (Apply (Foo7Sym1 l) arg)) (KindOf (Foo7Sym2 l arg)) =>+        Foo7Sym1KindInference+    type instance Apply (Foo7Sym1 l) l = Foo7Sym2 l l+    instance SuppressUnusedWarnings Foo7Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo7Sym0KindInference GHC.Tuple.())+    data Foo7Sym0 (l :: TyFun a (TyFun b b -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply Foo7Sym0 arg)) (KindOf (Foo7Sym1 arg)) =>+        Foo7Sym0KindInference+    type instance Apply Foo7Sym0 l = Foo7Sym1 l+    type Foo6Sym2 (t :: a) (t :: b) = Foo6 t t+    instance SuppressUnusedWarnings Foo6Sym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo6Sym1KindInference GHC.Tuple.())+    data Foo6Sym1 (l :: a) (l :: TyFun b a)+      = forall arg. (GHC.Types.~) (KindOf (Apply (Foo6Sym1 l) arg)) (KindOf (Foo6Sym2 l arg)) =>+        Foo6Sym1KindInference+    type instance Apply (Foo6Sym1 l) l = Foo6Sym2 l l+    instance SuppressUnusedWarnings Foo6Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo6Sym0KindInference GHC.Tuple.())+    data Foo6Sym0 (l :: TyFun a (TyFun b a -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply Foo6Sym0 arg)) (KindOf (Foo6Sym1 arg)) =>+        Foo6Sym0KindInference+    type instance Apply Foo6Sym0 l = Foo6Sym1 l+    type Foo5Sym2 (t :: a) (t :: b) = Foo5 t t+    instance SuppressUnusedWarnings Foo5Sym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo5Sym1KindInference GHC.Tuple.())+    data Foo5Sym1 (l :: a) (l :: TyFun b b)+      = forall arg. (GHC.Types.~) (KindOf (Apply (Foo5Sym1 l) arg)) (KindOf (Foo5Sym2 l arg)) =>+        Foo5Sym1KindInference+    type instance Apply (Foo5Sym1 l) l = Foo5Sym2 l l+    instance SuppressUnusedWarnings Foo5Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo5Sym0KindInference GHC.Tuple.())+    data Foo5Sym0 (l :: TyFun a (TyFun b b -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply Foo5Sym0 arg)) (KindOf (Foo5Sym1 arg)) =>+        Foo5Sym0KindInference+    type instance Apply Foo5Sym0 l = Foo5Sym1 l+    type Foo4Sym3 (t :: a) (t :: b) (t :: c) = Foo4 t t t+    instance SuppressUnusedWarnings Foo4Sym2 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo4Sym2KindInference GHC.Tuple.())+    data Foo4Sym2 (l :: a) (l :: b) (l :: TyFun c a)+      = forall arg. (GHC.Types.~) (KindOf (Apply (Foo4Sym2 l l) arg)) (KindOf (Foo4Sym3 l l arg)) =>+        Foo4Sym2KindInference+    type instance Apply (Foo4Sym2 l l) l = Foo4Sym3 l l l+    instance SuppressUnusedWarnings Foo4Sym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo4Sym1KindInference GHC.Tuple.())+    data Foo4Sym1 (l :: a) (l :: TyFun b (TyFun c a -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply (Foo4Sym1 l) arg)) (KindOf (Foo4Sym2 l arg)) =>+        Foo4Sym1KindInference+    type instance Apply (Foo4Sym1 l) l = Foo4Sym2 l l+    instance SuppressUnusedWarnings Foo4Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo4Sym0KindInference GHC.Tuple.())+    data Foo4Sym0 (l :: TyFun a (TyFun b (TyFun c a -> *) -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply Foo4Sym0 arg)) (KindOf (Foo4Sym1 arg)) =>+        Foo4Sym0KindInference+    type instance Apply Foo4Sym0 l = Foo4Sym1 l+    type Foo3Sym1 (t :: a) = Foo3 t+    instance SuppressUnusedWarnings Foo3Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo3Sym0KindInference GHC.Tuple.())+    data Foo3Sym0 (l :: TyFun a a)+      = forall arg. (GHC.Types.~) (KindOf (Apply Foo3Sym0 arg)) (KindOf (Foo3Sym1 arg)) =>+        Foo3Sym0KindInference+    type instance Apply Foo3Sym0 l = Foo3Sym1 l+    type Foo2Sym2 (t :: a) (t :: b) = Foo2 t t+    instance SuppressUnusedWarnings Foo2Sym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo2Sym1KindInference GHC.Tuple.())+    data Foo2Sym1 (l :: a) (l :: TyFun b a)+      = forall arg. (GHC.Types.~) (KindOf (Apply (Foo2Sym1 l) arg)) (KindOf (Foo2Sym2 l arg)) =>+        Foo2Sym1KindInference+    type instance Apply (Foo2Sym1 l) l = Foo2Sym2 l l+    instance SuppressUnusedWarnings Foo2Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo2Sym0KindInference GHC.Tuple.())+    data Foo2Sym0 (l :: TyFun a (TyFun b a -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply Foo2Sym0 arg)) (KindOf (Foo2Sym1 arg)) =>+        Foo2Sym0KindInference+    type instance Apply Foo2Sym0 l = Foo2Sym1 l+    type Foo1Sym2 (t :: a) (t :: b) = Foo1 t t+    instance SuppressUnusedWarnings Foo1Sym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo1Sym1KindInference GHC.Tuple.())+    data Foo1Sym1 (l :: a) (l :: TyFun b a)+      = forall arg. (GHC.Types.~) (KindOf (Apply (Foo1Sym1 l) arg)) (KindOf (Foo1Sym2 l arg)) =>+        Foo1Sym1KindInference+    type instance Apply (Foo1Sym1 l) l = Foo1Sym2 l l+    instance SuppressUnusedWarnings Foo1Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo1Sym0KindInference GHC.Tuple.())+    data Foo1Sym0 (l :: TyFun a (TyFun b a -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply Foo1Sym0 arg)) (KindOf (Foo1Sym1 arg)) =>+        Foo1Sym0KindInference+    type instance Apply Foo1Sym0 l = Foo1Sym1 l+    type Foo0Sym2 (t :: a) (t :: b) = Foo0 t t+    instance SuppressUnusedWarnings Foo0Sym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo0Sym1KindInference GHC.Tuple.())+    data Foo0Sym1 (l :: a) (l :: TyFun b a)+      = forall arg. (GHC.Types.~) (KindOf (Apply (Foo0Sym1 l) arg)) (KindOf (Foo0Sym2 l arg)) =>+        Foo0Sym1KindInference+    type instance Apply (Foo0Sym1 l) l = Foo0Sym2 l l+    instance SuppressUnusedWarnings Foo0Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo0Sym0KindInference GHC.Tuple.())+    data Foo0Sym0 (l :: TyFun a (TyFun b a -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply Foo0Sym0 arg)) (KindOf (Foo0Sym1 arg)) =>+        Foo0Sym0KindInference+    type instance Apply Foo0Sym0 l = Foo0Sym1 l+    type family Foo8 (a :: Foo a b) :: a where+      Foo8 x = Apply (Apply Lambda_0123456789Sym0 x) x+    type family Foo7 (a :: a) (a :: b) :: b where+      Foo7 x y = Apply (Apply (Apply Lambda_0123456789Sym0 x) y) (Apply (Apply Tuple2Sym0 x) y)+    type family Foo6 (a :: a) (a :: b) :: a where+      Foo6 a b = Apply (Apply (Apply (Apply Lambda_0123456789Sym0 a) b) a) b+    type family Foo5 (a :: a) (a :: b) :: b where+      Foo5 x y = Apply (Apply (Apply Lambda_0123456789Sym0 x) y) y+    type family Foo4 (a :: a) (a :: b) (a :: c) :: a where+      Foo4 x y z = Apply (Apply (Apply (Apply (Apply Lambda_0123456789Sym0 x) y) z) y) z+    type family Foo3 (a :: a) :: a where+      Foo3 x = Apply (Apply Lambda_0123456789Sym0 x) x+    type family Foo2 (a :: a) (a :: b) :: a where+      Foo2 x y = Apply (Apply (Apply Lambda_0123456789Sym0 x) y) y+    type family Foo1 (a :: a) (a :: b) :: a where+      Foo1 x a_0123456789 = Apply (Apply (Apply Lambda_0123456789Sym0 x) a_0123456789) a_0123456789+    type family Foo0 (a :: a) (a :: b) :: a where+      Foo0 a_0123456789 a_0123456789 = Apply (Apply (Apply (Apply Lambda_0123456789Sym0 a_0123456789) a_0123456789) a_0123456789) a_0123456789+    sFoo8 :: forall (t :: Foo a b). Sing t -> Sing (Apply Foo8Sym0 t)+    sFoo7 ::+      forall (t :: a) (t :: b).+      Sing t -> Sing t -> Sing (Apply (Apply Foo7Sym0 t) t)+    sFoo6 ::+      forall (t :: a) (t :: b).+      Sing t -> Sing t -> Sing (Apply (Apply Foo6Sym0 t) t)+    sFoo5 ::+      forall (t :: a) (t :: b).+      Sing t -> Sing t -> Sing (Apply (Apply Foo5Sym0 t) t)+    sFoo4 ::+      forall (t :: a) (t :: b) (t :: c).+      Sing t+      -> Sing t -> Sing t -> Sing (Apply (Apply (Apply Foo4Sym0 t) t) t)+    sFoo3 :: forall (t :: a). Sing t -> Sing (Apply Foo3Sym0 t)+    sFoo2 ::+      forall (t :: a) (t :: b).+      Sing t -> Sing t -> Sing (Apply (Apply Foo2Sym0 t) t)+    sFoo1 ::+      forall (t :: a) (t :: b).+      Sing t -> Sing t -> Sing (Apply (Apply Foo1Sym0 t) t)+    sFoo0 ::+      forall (t :: a) (t :: b).+      Sing t -> Sing t -> Sing (Apply (Apply Foo0Sym0 t) t)+    sFoo8 sX+      = let+          lambda ::+            forall x. (GHC.Types.~) t x => Sing x -> Sing (Apply Foo8Sym0 x)+          lambda x+            = applySing+                (singFun1+                   (Proxy :: Proxy (Apply Lambda_0123456789Sym0 x))+                   (\ sArg_0123456789+                      -> let+                           lambda ::+                             forall arg_0123456789.+                             Sing arg_0123456789+                             -> Sing (Apply (Apply Lambda_0123456789Sym0 x) arg_0123456789)+                           lambda arg_0123456789+                             = case arg_0123456789 of {+                                 SFoo sA _+                                   -> let+                                        lambda ::+                                          forall a wild.+                                          Sing a+                                          -> Sing (Case_0123456789 x arg_0123456789 (Apply (Apply FooSym0 a) wild))+                                        lambda a = a+                                      in lambda sA }+                         in lambda sArg_0123456789))+                x+        in lambda sX+    sFoo7 sX sY+      = let+          lambda ::+            forall x y. ((GHC.Types.~) t x, (GHC.Types.~) t y) =>+            Sing x -> Sing y -> Sing (Apply (Apply Foo7Sym0 x) y)+          lambda x y+            = applySing+                (singFun1+                   (Proxy :: Proxy (Apply (Apply Lambda_0123456789Sym0 x) y))+                   (\ sArg_0123456789+                      -> let+                           lambda ::+                             forall arg_0123456789.+                             Sing arg_0123456789+                             -> Sing (Apply (Apply (Apply Lambda_0123456789Sym0 x) y) arg_0123456789)+                           lambda arg_0123456789+                             = case arg_0123456789 of {+                                 STuple2 _ sB+                                   -> let+                                        lambda ::+                                          forall b wild.+                                          Sing b+                                          -> Sing (Case_0123456789 x y arg_0123456789 (Apply (Apply Tuple2Sym0 wild) b))+                                        lambda b = b+                                      in lambda sB }+                         in lambda sArg_0123456789))+                (applySing+                   (applySing (singFun2 (Proxy :: Proxy Tuple2Sym0) STuple2) x) y)+        in lambda sX sY+    sFoo6 sA sB+      = let+          lambda ::+            forall a b. ((GHC.Types.~) t a, (GHC.Types.~) t b) =>+            Sing a -> Sing b -> Sing (Apply (Apply Foo6Sym0 a) b)+          lambda a b+            = applySing+                (applySing+                   (singFun1+                      (Proxy :: Proxy (Apply (Apply Lambda_0123456789Sym0 a) b))+                      (\ sX+                         -> let+                              lambda ::+                                forall x.+                                Sing x -> Sing (Apply (Apply (Apply Lambda_0123456789Sym0 a) b) x)+                              lambda x+                                = singFun1+                                    (Proxy ::+                                       Proxy (Apply (Apply (Apply Lambda_0123456789Sym0 a) b) x))+                                    (\ sArg_0123456789+                                       -> let+                                            lambda ::+                                              forall arg_0123456789.+                                              Sing arg_0123456789+                                              -> Sing (Apply (Apply (Apply (Apply Lambda_0123456789Sym0 a) b) x) arg_0123456789)+                                            lambda arg_0123456789+                                              = case arg_0123456789 of {+                                                  _ -> let+                                                         lambda ::+                                                           forall wild.+                                                           Sing (Case_0123456789 a b x arg_0123456789 wild)+                                                         lambda = x+                                                       in lambda }+                                          in lambda sArg_0123456789)+                            in lambda sX))+                   a)+                b+        in lambda sA sB+    sFoo5 sX sY+      = let+          lambda ::+            forall x y. ((GHC.Types.~) t x, (GHC.Types.~) t y) =>+            Sing x -> Sing y -> Sing (Apply (Apply Foo5Sym0 x) y)+          lambda x y+            = applySing+                (singFun1+                   (Proxy :: Proxy (Apply (Apply Lambda_0123456789Sym0 x) y))+                   (\ sX+                      -> let+                           lambda ::+                             forall x.+                             Sing x -> Sing (Apply (Apply (Apply Lambda_0123456789Sym0 x) y) x)+                           lambda x = x+                         in lambda sX))+                y+        in lambda sX sY+    sFoo4 sX sY sZ+      = let+          lambda ::+            forall x y z. ((GHC.Types.~) t x,+                           (GHC.Types.~) t y,+                           (GHC.Types.~) t z) =>+            Sing x+            -> Sing y -> Sing z -> Sing (Apply (Apply (Apply Foo4Sym0 x) y) z)+          lambda x y z+            = applySing+                (applySing+                   (singFun2+                      (Proxy ::+                         Proxy (Apply (Apply (Apply Lambda_0123456789Sym0 x) y) z))+                      (\ sArg_0123456789 sArg_0123456789+                         -> let+                              lambda ::+                                forall arg_0123456789 arg_0123456789.+                                Sing arg_0123456789+                                -> Sing arg_0123456789+                                   -> Sing (Apply (Apply (Apply (Apply (Apply Lambda_0123456789Sym0 x) y) z) arg_0123456789) arg_0123456789)+                              lambda arg_0123456789 arg_0123456789+                                = case+                                      applySing+                                        (applySing+                                           (singFun2 (Proxy :: Proxy Tuple2Sym0) STuple2)+                                           arg_0123456789)+                                        arg_0123456789+                                  of {+                                    STuple2 _ _+                                      -> let+                                           lambda ::+                                             forall wild wild.+                                             Sing (Case_0123456789 x y z arg_0123456789 arg_0123456789 (Apply (Apply Tuple2Sym0 wild) wild))+                                           lambda = x+                                         in lambda }+                            in lambda sArg_0123456789 sArg_0123456789))+                   y)+                z+        in lambda sX sY sZ+    sFoo3 sX+      = let+          lambda ::+            forall x. (GHC.Types.~) t x => Sing x -> Sing (Apply Foo3Sym0 x)+          lambda x+            = applySing+                (singFun1+                   (Proxy :: Proxy (Apply Lambda_0123456789Sym0 x))+                   (\ sY+                      -> let+                           lambda ::+                             forall y. Sing y -> Sing (Apply (Apply Lambda_0123456789Sym0 x) y)+                           lambda y = y+                         in lambda sY))+                x+        in lambda sX+    sFoo2 sX sY+      = let+          lambda ::+            forall x y. ((GHC.Types.~) t x, (GHC.Types.~) t y) =>+            Sing x -> Sing y -> Sing (Apply (Apply Foo2Sym0 x) y)+          lambda x y+            = applySing+                (singFun1+                   (Proxy :: Proxy (Apply (Apply Lambda_0123456789Sym0 x) y))+                   (\ sArg_0123456789+                      -> let+                           lambda ::+                             forall arg_0123456789.+                             Sing arg_0123456789+                             -> Sing (Apply (Apply (Apply Lambda_0123456789Sym0 x) y) arg_0123456789)+                           lambda arg_0123456789+                             = case arg_0123456789 of {+                                 _ -> let+                                        lambda ::+                                          forall wild.+                                          Sing (Case_0123456789 x y arg_0123456789 wild)+                                        lambda = x+                                      in lambda }+                         in lambda sArg_0123456789))+                y+        in lambda sX sY+    sFoo1 sX sA_0123456789+      = let+          lambda ::+            forall x a_0123456789. ((GHC.Types.~) t x,+                                    (GHC.Types.~) t a_0123456789) =>+            Sing x+            -> Sing a_0123456789+               -> Sing (Apply (Apply Foo1Sym0 x) a_0123456789)+          lambda x a_0123456789+            = applySing+                (singFun1+                   (Proxy ::+                      Proxy (Apply (Apply Lambda_0123456789Sym0 x) a_0123456789))+                   (\ sArg_0123456789+                      -> let+                           lambda ::+                             forall arg_0123456789.+                             Sing arg_0123456789+                             -> Sing (Apply (Apply (Apply Lambda_0123456789Sym0 x) a_0123456789) arg_0123456789)+                           lambda arg_0123456789+                             = case arg_0123456789 of {+                                 _ -> let+                                        lambda ::+                                          forall wild.+                                          Sing (Case_0123456789 x arg_0123456789 a_0123456789 wild)+                                        lambda = x+                                      in lambda }+                         in lambda sArg_0123456789))+                a_0123456789+        in lambda sX sA_0123456789+    sFoo0 sA_0123456789 sA_0123456789+      = let+          lambda ::+            forall a_0123456789 a_0123456789. ((GHC.Types.~) t a_0123456789,+                                               (GHC.Types.~) t a_0123456789) =>+            Sing a_0123456789+            -> Sing a_0123456789+               -> Sing (Apply (Apply Foo0Sym0 a_0123456789) a_0123456789)+          lambda a_0123456789 a_0123456789+            = applySing+                (applySing+                   (singFun2+                      (Proxy ::+                         Proxy (Apply (Apply Lambda_0123456789Sym0 a_0123456789) a_0123456789))+                      (\ sX sY+                         -> let+                              lambda ::+                                forall x y.+                                Sing x+                                -> Sing y+                                   -> Sing (Apply (Apply (Apply (Apply Lambda_0123456789Sym0 a_0123456789) a_0123456789) x) y)+                              lambda x y = x+                            in lambda sX sY))+                   a_0123456789)+                a_0123456789+        in lambda sA_0123456789 sA_0123456789+    data instance Sing (z :: Foo a b)+      = forall (n :: a) (n :: b). (GHC.Types.~) z (Foo n n) =>+        SFoo (Sing n) (Sing n)+    type SFoo (z :: Foo a b) = Sing z+    instance (SingKind (KProxy :: KProxy a),+              SingKind (KProxy :: KProxy b)) =>+             SingKind (KProxy :: KProxy (Foo a b)) where+      type DemoteRep (KProxy :: KProxy (Foo a b)) = Foo (DemoteRep (KProxy :: KProxy a)) (DemoteRep (KProxy :: KProxy b))+      fromSing (SFoo b b) = Foo (fromSing b) (fromSing b)+      toSing (Foo b b)+        = case+              GHC.Tuple.(,)+                (toSing b :: SomeSing (KProxy :: KProxy a))+                (toSing b :: SomeSing (KProxy :: KProxy b))+          of {+            GHC.Tuple.(,) (SomeSing c) (SomeSing c) -> SomeSing (SFoo c c) }+    instance (SingI n, SingI n) => SingI (Foo (n :: a) (n :: b)) where+      sing = SFoo sing sing
+ tests/compile-and-dump/Singletons/Lambdas.hs view
@@ -0,0 +1,94 @@+{-# OPTIONS_GHC -fno-warn-unused-matches -fno-warn-name-shadowing -fno-warn-unused-imports #-}++{-# LANGUAGE UnboxedTuples #-}+-- We expect unused binds and name shadowing in foo5 test.+module Singletons.Lambdas where++import Data.Proxy+import Data.Singletons+import Data.Singletons.TH++$(singletons [d|+  -- nothing in scope+  foo0 :: a -> b -> a+  foo0 = (\x y -> x)++  -- eta-reduced function+  foo1 :: a -> b -> a+  foo1 x = (\_ -> x)++  -- same as before, but without eta-reduction+  foo2 :: a -> b -> a+  foo2 x y = (\_ -> x) y++  foo3 :: a -> a+  foo3 x = (\y -> y) x++  -- more lambda parameters + returning in-scope variable+  foo4 :: a -> b -> c -> a+  foo4 x y z = (\_ _ -> x) y z++  -- name shadowing+  -- Note: due to -dsuppress-uniques output of this test does not really+  -- prove that the result is correct. Compiling this file manually and+  -- examining dumped splise of relevant Lamdba reveals that indeed that Lambda+  -- returns its last parameter (ie. y passed in a call) rather than the+  -- first one (ie. x that is shadowed by the binder in a lambda).+  foo5 :: a -> b -> b+  foo5 x y = (\x -> x) y++  -- nested lambdas+  foo6 :: a -> b -> a+  foo6 a b = (\x -> \_ -> x) a b++  -- tuple patterns+  foo7 :: a -> b -> b+  foo7 x y = (\(_, b) -> b) (x, y)++  -- constructor patters=ns+  data Foo a b = Foo a b+  foo8 :: Foo a b -> a+  foo8 x = (\(Foo a _) -> a) x+ |])++foo1a :: Proxy (Foo1 Int Char)+foo1a = Proxy++foo1b :: Proxy Int+foo1b = foo1a++foo2a :: Proxy (Foo2 Int Char)+foo2a = Proxy++foo2b :: Proxy Int+foo2b = foo2a++foo3a :: Proxy (Foo3 Int)+foo3a = Proxy++foo3b :: Proxy Int+foo3b = foo3a++foo4a :: Proxy (Foo4 Int Char Bool)+foo4a = Proxy++foo4b :: Proxy Int+foo4b = foo4a++foo5a :: Proxy (Foo5 Int Bool)+foo5a = Proxy++foo5b :: Proxy Bool+foo5b = foo5a++foo6a :: Proxy (Foo6 Int Char)+foo6a = Proxy++foo6b :: Proxy Int+foo6b = foo6a++foo7a :: Proxy (Foo7 Int Char)+foo7a = Proxy++foo7b :: Proxy Char+foo7b = foo7a
+ tests/compile-and-dump/Singletons/LambdasComprehensive.ghc76.template view
@@ -0,0 +1,27 @@+Promote/LambdasComprehensive.hs:0:0: Splicing declarations+    promote+      [d| foo :: [Nat]+          foo+            = map (\ x -> either_ pred Succ x) [Left Zero, Right (Succ Zero)]+          bar :: [Nat]+          bar = map (either_ pred Succ) [Left Zero, Right (Succ Zero)] |]+  ======>+    Promote/LambdasComprehensive.hs:(0,0)-(0,0)+    foo :: [Nat]+    foo+      = map (\ x -> either_ pred Succ x) [Left Zero, Right (Succ Zero)]+    bar :: [Nat]+    bar = map (either_ pred Succ) [Left Zero, Right (Succ Zero)]+    type Foo =+        Apply (Apply MapSym0 Lambda_0123456789Sym0) '[Apply LeftSym0 ZeroSym0,+                                                      Apply RightSym0 (Apply SuccSym0 ZeroSym0)]+    type FooSym0 = Foo+    type family Lambda_0123456789 (t :: k) :: r+    type instance Lambda_0123456789 x =+        Apply (Apply (Apply Either_Sym0 PredSym0) SuccSym0) x+    data Lambda_0123456789Sym0 (k :: TyFun k r)+    type instance Apply Lambda_0123456789Sym0 a = Lambda_0123456789 a+    type Bar =+        Apply (Apply MapSym0 (Apply (Apply Either_Sym0 PredSym0) SuccSym0)) '[Apply LeftSym0 ZeroSym0,+                                                                              Apply RightSym0 (Apply SuccSym0 ZeroSym0)]+    type BarSym0 = Bar
+ tests/compile-and-dump/Singletons/LambdasComprehensive.ghc78.template view
@@ -0,0 +1,82 @@+Singletons/LambdasComprehensive.hs:0:0: Splicing declarations+    singletons+      [d| foo :: [Nat]+          foo+            = map (\ x -> either_ pred Succ x) [Left Zero, Right (Succ Zero)]+          bar :: [Nat]+          bar = map (either_ pred Succ) [Left Zero, Right (Succ Zero)] |]+  ======>+    Singletons/LambdasComprehensive.hs:(0,0)-(0,0)+    foo :: [Nat]+    foo+      = map (\ x -> either_ pred Succ x) [Left Zero, Right (Succ Zero)]+    bar :: [Nat]+    bar = map (either_ pred Succ) [Left Zero, Right (Succ Zero)]+    type family Lambda_0123456789 t where+      Lambda_0123456789 x = Apply (Apply (Apply Either_Sym0 PredSym0) SuccSym0) x+    type Lambda_0123456789Sym1 t = Lambda_0123456789 t+    instance SuppressUnusedWarnings Lambda_0123456789Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym0KindInference GHC.Tuple.())+    data Lambda_0123456789Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Lambda_0123456789Sym0 arg)) (KindOf (Lambda_0123456789Sym1 arg)) =>+        Lambda_0123456789Sym0KindInference+    type instance Apply Lambda_0123456789Sym0 l = Lambda_0123456789Sym1 l+    type BarSym0 = Bar+    type FooSym0 = Foo+    type Bar =+        (Apply (Apply MapSym0 (Apply (Apply Either_Sym0 PredSym0) SuccSym0)) (Apply (Apply (:$) (Apply LeftSym0 ZeroSym0)) (Apply (Apply (:$) (Apply RightSym0 (Apply SuccSym0 ZeroSym0))) GHC.Types.[])) :: GHC.Types.[] Nat)+    type Foo =+        (Apply (Apply MapSym0 Lambda_0123456789Sym0) (Apply (Apply (:$) (Apply LeftSym0 ZeroSym0)) (Apply (Apply (:$) (Apply RightSym0 (Apply SuccSym0 ZeroSym0))) GHC.Types.[])) :: GHC.Types.[] Nat)+    sBar :: Sing BarSym0+    sFoo :: Sing FooSym0+    sBar+      = applySing+          (applySing+             (singFun2 (Proxy :: Proxy MapSym0) sMap)+             (applySing+                (applySing+                   (singFun3 (Proxy :: Proxy Either_Sym0) sEither_)+                   (singFun1 (Proxy :: Proxy PredSym0) sPred))+                (singFun1 (Proxy :: Proxy SuccSym0) SSucc)))+          (applySing+             (applySing+                (singFun2 (Proxy :: Proxy (:$)) SCons)+                (applySing (singFun1 (Proxy :: Proxy LeftSym0) SLeft) SZero))+             (applySing+                (applySing+                   (singFun2 (Proxy :: Proxy (:$)) SCons)+                   (applySing+                      (singFun1 (Proxy :: Proxy RightSym0) SRight)+                      (applySing (singFun1 (Proxy :: Proxy SuccSym0) SSucc) SZero)))+                SNil))+    sFoo+      = applySing+          (applySing+             (singFun2 (Proxy :: Proxy MapSym0) sMap)+             (singFun1+                (Proxy :: Proxy Lambda_0123456789Sym0)+                (\ sX+                   -> let+                        lambda :: forall x. Sing x -> Sing (Apply Lambda_0123456789Sym0 x)+                        lambda x+                          = applySing+                              (applySing+                                 (applySing+                                    (singFun3 (Proxy :: Proxy Either_Sym0) sEither_)+                                    (singFun1 (Proxy :: Proxy PredSym0) sPred))+                                 (singFun1 (Proxy :: Proxy SuccSym0) SSucc))+                              x+                      in lambda sX)))+          (applySing+             (applySing+                (singFun2 (Proxy :: Proxy (:$)) SCons)+                (applySing (singFun1 (Proxy :: Proxy LeftSym0) SLeft) SZero))+             (applySing+                (applySing+                   (singFun2 (Proxy :: Proxy (:$)) SCons)+                   (applySing+                      (singFun1 (Proxy :: Proxy RightSym0) SRight)+                      (applySing (singFun1 (Proxy :: Proxy SuccSym0) SSucc) SZero)))+                SNil))
+ tests/compile-and-dump/Singletons/LambdasComprehensive.hs view
@@ -0,0 +1,29 @@+module Singletons.LambdasComprehensive where++import Data.Singletons.SuppressUnusedWarnings+import Data.Singletons.TH+import Data.Singletons.Prelude+import Singletons.Nat++import Prelude hiding (pred)++$(singletons [d|+ foo :: [Nat]+ foo = map (\x -> either_ pred Succ x) [Left Zero, Right (Succ Zero)]++ -- this is the same as above except that it does not use lambdas+ bar :: [Nat]+ bar = map (either_ pred Succ) [Left Zero, Right (Succ Zero)]+ |])++fooTest1a :: Proxy Foo+fooTest1a = Proxy++fooTest1b :: Proxy [Zero, Succ (Succ Zero)]+fooTest1b = fooTest1a++barTest1a :: Proxy Bar+barTest1a = Proxy++barTest1b :: Proxy [Zero, Succ (Succ Zero)]+barTest1b = barTest1a
+ tests/compile-and-dump/Singletons/LetStatements.ghc76.template view
@@ -0,0 +1,364 @@+Promote/LetStatements.hs:0:0: Splicing declarations+    promote+      [d| foo1 :: Nat -> Nat+          foo1 x+            = let+                y :: Nat+                y = Succ Zero+              in y+          foo2 :: Nat+          foo2+            = let+                y = Succ Zero+                z = Succ y+              in z+          foo3 :: Nat -> Nat+          foo3 x+            = let+                y :: Nat+                y = Succ x+              in y+          foo4 :: Nat -> Nat+          foo4 x+            = let+                f :: Nat -> Nat+                f y = Succ y+              in f x+          foo5 :: Nat -> Nat+          foo5 x+            = let+                f :: Nat -> Nat+                f y+                  = let+                      z :: Nat+                      z = Succ y+                    in Succ z+              in f x+          foo6 :: Nat -> Nat+          foo6 x+            = let+                f :: Nat -> Nat+                f y = Succ y in+              let+                z :: Nat+                z = f x+              in z+          foo7 :: Nat -> Nat+          foo7 x+            = let+                x :: Nat+                x = Zero+              in x+          foo8 :: Nat -> Nat+          foo8 x+            = let+                z :: Nat+                z = (\ x -> x) Zero+              in z+          foo9 :: Nat -> Nat+          foo9 x+            = let+                z :: Nat -> Nat+                z = (\ x -> x)+              in z x+          foo10 :: Nat -> Nat+          foo10 x+            = let+                + :: Nat -> Nat -> Nat+                Zero + m = m+                (Succ n) + m = Succ (n + m)+              in (Succ Zero) + x+          foo11 :: Nat -> Nat+          foo11 x+            = let+                + :: Nat -> Nat -> Nat+                Zero + m = m+                (Succ n) + m = Succ (n + m)+                z :: Nat+                z = x+              in (Succ Zero) + z+          foo12 :: Nat -> Nat+          foo12 x+            = let+                + :: Nat -> Nat -> Nat+                Zero + m = m+                (Succ n) + m = Succ (n + x)+              in x + (Succ (Succ Zero))+          foo13 :: forall a. a -> a+          foo13 x+            = let+                bar :: a+                bar = x+              in foo13b bar+          foo13b :: a -> a+          foo13b y = y |]+  ======>+    Promote/LetStatements.hs:(0,0)-(0,0)+    foo1 :: Nat -> Nat+    foo1 x+      = let+          y :: Nat+          y = Succ Zero+        in y+    foo2 :: Nat+    foo2+      = let+          y = Succ Zero+          z = Succ y+        in z+    foo3 :: Nat -> Nat+    foo3 x+      = let+          y :: Nat+          y = Succ x+        in y+    foo4 :: Nat -> Nat+    foo4 x+      = let+          f :: Nat -> Nat+          f y = Succ y+        in f x+    foo5 :: Nat -> Nat+    foo5 x+      = let+          f :: Nat -> Nat+          f y+            = let+                z :: Nat+                z = Succ y+              in Succ z+        in f x+    foo6 :: Nat -> Nat+    foo6 x+      = let+          f :: Nat -> Nat+          f y = Succ y in+        let+          z :: Nat+          z = f x+        in z+    foo7 :: Nat -> Nat+    foo7 x+      = let+          x :: Nat+          x = Zero+        in x+    foo8 :: Nat -> Nat+    foo8 x+      = let+          z :: Nat+          z = \ x -> x Zero+        in z+    foo9 :: Nat -> Nat+    foo9 x+      = let+          z :: Nat -> Nat+          z = \ x -> x+        in z x+    foo10 :: Nat -> Nat+    foo10 x+      = let+          + :: Nat -> Nat -> Nat+          + Zero m = m+          + (Succ n) m = Succ (n + m)+        in ((Succ Zero) + x)+    foo11 :: Nat -> Nat+    foo11 x+      = let+          + :: Nat -> Nat -> Nat+          z :: Nat+          + Zero m = m+          + (Succ n) m = Succ (n + m)+          z = x+        in ((Succ Zero) + z)+    foo12 :: Nat -> Nat+    foo12 x+      = let+          + :: Nat -> Nat -> Nat+          + Zero m = m+          + (Succ n) m = Succ (n + x)+        in (x + (Succ (Succ Zero)))+    foo13 :: forall a. a -> a+    foo13 x+      = let+          bar :: a+          bar = x+        in foo13b bar+    foo13b :: forall a. a -> a+    foo13b y = y+    type family Let_0123456789y (a :: x) :: Nat+    type instance Let_0123456789y x = Apply SuccSym0 ZeroSym0+    data Let_0123456789ySym0 (k :: TyFun x Nat)+    type instance Apply Let_0123456789ySym0 a = Let_0123456789y a+    type Foo2 = Let_0123456789zSym0+    type Foo2Sym0 = Foo2+    type Let_0123456789y = Apply SuccSym0 ZeroSym0+    type Let_0123456789ySym0 = Let_0123456789y+    type Let_0123456789z = Apply SuccSym0 Let_0123456789ySym0+    type Let_0123456789zSym0 = Let_0123456789z+    type family Let_0123456789y (a :: x) :: Nat+    type instance Let_0123456789y x = Apply SuccSym0 x+    data Let_0123456789ySym0 (k :: TyFun x Nat)+    type instance Apply Let_0123456789ySym0 a = Let_0123456789y a+    type family Let_0123456789f (a :: x) (a :: Nat) :: Nat+    type instance Let_0123456789f x y = Apply SuccSym0 y+    data Let_0123456789fSym1 (l :: x) (l :: TyFun Nat Nat)+    data Let_0123456789fSym0 (k :: TyFun x (TyFun Nat Nat -> *))+    type instance Apply (Let_0123456789fSym1 a) a = Let_0123456789f a a+    type instance Apply Let_0123456789fSym0 a = Let_0123456789fSym1 a+    type family Let_0123456789z (a :: x) (a :: y) :: Nat+    type instance Let_0123456789z x y = Apply SuccSym0 y+    data Let_0123456789zSym1 (l :: x) (l :: TyFun y Nat)+    data Let_0123456789zSym0 (k :: TyFun x (TyFun y Nat -> *))+    type instance Apply (Let_0123456789zSym1 a) a = Let_0123456789z a a+    type instance Apply Let_0123456789zSym0 a = Let_0123456789zSym1 a+    type family Let_0123456789f (a :: x) (a :: Nat) :: Nat+    type instance Let_0123456789f x y =+        Apply SuccSym0 (Apply (Apply Let_0123456789zSym0 x) y)+    data Let_0123456789fSym1 (l :: x) (l :: TyFun Nat Nat)+    data Let_0123456789fSym0 (k :: TyFun x (TyFun Nat Nat -> *))+    type instance Apply (Let_0123456789fSym1 a) a = Let_0123456789f a a+    type instance Apply Let_0123456789fSym0 a = Let_0123456789fSym1 a+    type family Let_0123456789f (a :: x) (a :: Nat) :: Nat+    type instance Let_0123456789f x y = Apply SuccSym0 y+    data Let_0123456789fSym1 (l :: x) (l :: TyFun Nat Nat)+    data Let_0123456789fSym0 (k :: TyFun x (TyFun Nat Nat -> *))+    type instance Apply (Let_0123456789fSym1 a) a = Let_0123456789f a a+    type instance Apply Let_0123456789fSym0 a = Let_0123456789fSym1 a+    type family Let_0123456789z (a :: x) :: Nat+    type instance Let_0123456789z x =+        Apply (Apply Let_0123456789fSym0 x) x+    data Let_0123456789zSym0 (k :: TyFun x Nat)+    type instance Apply Let_0123456789zSym0 a = Let_0123456789z a+    type family Let_0123456789x (a :: x) :: Nat+    type instance Let_0123456789x x = ZeroSym0+    data Let_0123456789xSym0 (k :: TyFun x Nat)+    type instance Apply Let_0123456789xSym0 a = Let_0123456789x a+    type family Lambda_0123456789 (x :: x) (t :: k) :: r+    type instance Lambda_0123456789 x x = x+    data Lambda_0123456789Sym1 (l :: x) (l :: TyFun k r)+    type instance Apply (Lambda_0123456789Sym1 a) a =+        Lambda_0123456789 a a+    type family Let_0123456789z (a :: x) :: Nat+    type instance Let_0123456789z x =+        Apply (Lambda_0123456789Sym1 x) ZeroSym0+    data Let_0123456789zSym0 (k :: TyFun x Nat)+    type instance Apply Let_0123456789zSym0 a = Let_0123456789z a+    type family Lambda_0123456789 (x :: x) (t :: k) :: r+    type instance Lambda_0123456789 x x = x+    data Lambda_0123456789Sym1 (l :: x) (l :: TyFun k r)+    type instance Apply (Lambda_0123456789Sym1 a) a =+        Lambda_0123456789 a a+    type family Let_0123456789z (a :: x) :: TyFun Nat Nat -> *+    type instance Let_0123456789z x = Lambda_0123456789Sym1 x+    data Let_0123456789zSym0 (k :: TyFun x (TyFun Nat Nat -> *))+    type instance Apply Let_0123456789zSym0 a = Let_0123456789z a+    type family Let_0123456789+ (a :: x) (a :: Nat) (a :: Nat) :: Nat+    type instance Let_0123456789+ x Zero m = m+    type instance Let_0123456789+ x (Succ n) m =+        Apply SuccSym0 (Apply (Apply (Apply Let_0123456789+Sym0 x) n) m)+    data Let_0123456789+Sym2 (l :: x) (l :: Nat) (l :: TyFun Nat Nat)+    data Let_0123456789+Sym1 (l :: x)+                             (l :: TyFun Nat (TyFun Nat Nat -> *))+    data Let_0123456789+Sym0 (k :: TyFun x (TyFun Nat (TyFun Nat Nat+                                                       -> *)+                                            -> *))+    type instance Apply (Let_0123456789+Sym2 a a) a =+        Let_0123456789+ a a a+    type instance Apply (Let_0123456789+Sym1 a) a =+        Let_0123456789+Sym2 a a+    type instance Apply Let_0123456789+Sym0 a = Let_0123456789+Sym1 a+    type family Let_0123456789+ (a :: x) (a :: Nat) (a :: Nat) :: Nat+    type instance Let_0123456789+ x Zero m = m+    type instance Let_0123456789+ x (Succ n) m =+        Apply SuccSym0 (Apply (Apply (Apply Let_0123456789+Sym0 x) n) m)+    data Let_0123456789+Sym2 (l :: x) (l :: Nat) (l :: TyFun Nat Nat)+    data Let_0123456789+Sym1 (l :: x)+                             (l :: TyFun Nat (TyFun Nat Nat -> *))+    data Let_0123456789+Sym0 (k :: TyFun x (TyFun Nat (TyFun Nat Nat+                                                       -> *)+                                            -> *))+    type instance Apply (Let_0123456789+Sym2 a a) a =+        Let_0123456789+ a a a+    type instance Apply (Let_0123456789+Sym1 a) a =+        Let_0123456789+Sym2 a a+    type instance Apply Let_0123456789+Sym0 a = Let_0123456789+Sym1 a+    type family Let_0123456789z (a :: x) :: Nat+    type instance Let_0123456789z x = x+    data Let_0123456789zSym0 (k :: TyFun x Nat)+    type instance Apply Let_0123456789zSym0 a = Let_0123456789z a+    type family Let_0123456789+ (a :: x) (a :: Nat) (a :: Nat) :: Nat+    type instance Let_0123456789+ x Zero m = m+    type instance Let_0123456789+ x (Succ n) m =+        Apply SuccSym0 (Apply (Apply (Apply Let_0123456789+Sym0 x) n) x)+    data Let_0123456789+Sym2 (l :: x) (l :: Nat) (l :: TyFun Nat Nat)+    data Let_0123456789+Sym1 (l :: x)+                             (l :: TyFun Nat (TyFun Nat Nat -> *))+    data Let_0123456789+Sym0 (k :: TyFun x (TyFun Nat (TyFun Nat Nat+                                                       -> *)+                                            -> *))+    type instance Apply (Let_0123456789+Sym2 a a) a =+        Let_0123456789+ a a a+    type instance Apply (Let_0123456789+Sym1 a) a =+        Let_0123456789+Sym2 a a+    type instance Apply Let_0123456789+Sym0 a = Let_0123456789+Sym1 a+    type family Let_0123456789bar (a :: x) :: a+    type instance Let_0123456789bar x = x+    data Let_0123456789barSym0 (k :: TyFun x a)+    type instance Apply Let_0123456789barSym0 a = Let_0123456789bar a+    type family Foo1 (a :: Nat) :: Nat+    type instance Foo1 x = Apply Let_0123456789ySym0 x+    data Foo1Sym0 (k :: TyFun Nat Nat)+    type instance Apply Foo1Sym0 a = Foo1 a+    type family Foo3 (a :: Nat) :: Nat+    type instance Foo3 x = Apply Let_0123456789ySym0 x+    data Foo3Sym0 (k :: TyFun Nat Nat)+    type instance Apply Foo3Sym0 a = Foo3 a+    type family Foo4 (a :: Nat) :: Nat+    type instance Foo4 x = Apply (Apply Let_0123456789fSym0 x) x+    data Foo4Sym0 (k :: TyFun Nat Nat)+    type instance Apply Foo4Sym0 a = Foo4 a+    type family Foo5 (a :: Nat) :: Nat+    type instance Foo5 x = Apply (Apply Let_0123456789fSym0 x) x+    data Foo5Sym0 (k :: TyFun Nat Nat)+    type instance Apply Foo5Sym0 a = Foo5 a+    type family Foo6 (a :: Nat) :: Nat+    type instance Foo6 x = Apply Let_0123456789zSym0 x+    data Foo6Sym0 (k :: TyFun Nat Nat)+    type instance Apply Foo6Sym0 a = Foo6 a+    type family Foo7 (a :: Nat) :: Nat+    type instance Foo7 x = Apply Let_0123456789xSym0 x+    data Foo7Sym0 (k :: TyFun Nat Nat)+    type instance Apply Foo7Sym0 a = Foo7 a+    type family Foo8 (a :: Nat) :: Nat+    type instance Foo8 x = Apply Let_0123456789zSym0 x+    data Foo8Sym0 (k :: TyFun Nat Nat)+    type instance Apply Foo8Sym0 a = Foo8 a+    type family Foo9 (a :: Nat) :: Nat+    type instance Foo9 x = Apply (Apply Let_0123456789zSym0 x) x+    data Foo9Sym0 (k :: TyFun Nat Nat)+    type instance Apply Foo9Sym0 a = Foo9 a+    type family Foo10 (a :: Nat) :: Nat+    type instance Foo10 x =+        Apply (Apply (Apply Let_0123456789+Sym0 x) (Apply SuccSym0 ZeroSym0)) x+    data Foo10Sym0 (k :: TyFun Nat Nat)+    type instance Apply Foo10Sym0 a = Foo10 a+    type family Foo11 (a :: Nat) :: Nat+    type instance Foo11 x =+        Apply (Apply (Apply Let_0123456789+Sym0 x) (Apply SuccSym0 ZeroSym0)) (Apply Let_0123456789zSym0 x)+    data Foo11Sym0 (k :: TyFun Nat Nat)+    type instance Apply Foo11Sym0 a = Foo11 a+    type family Foo12 (a :: Nat) :: Nat+    type instance Foo12 x =+        Apply (Apply (Apply Let_0123456789+Sym0 x) x) (Apply SuccSym0 (Apply SuccSym0 ZeroSym0))+    data Foo12Sym0 (k :: TyFun Nat Nat)+    type instance Apply Foo12Sym0 a = Foo12 a+    type family Foo13 (a :: a) :: a+    type instance Foo13 x =+        Apply Foo13bSym0 (Apply Let_0123456789barSym0 x)+    data Foo13Sym0 (k :: TyFun a a)+    type instance Apply Foo13Sym0 a = Foo13 a+    type family Foo13b (a :: a) :: a+    type instance Foo13b y = y+    data Foo13bSym0 (k :: TyFun a a)+    type instance Apply Foo13bSym0 a = Foo13b a
+ tests/compile-and-dump/Singletons/LetStatements.ghc78.template view
@@ -0,0 +1,998 @@+Singletons/LetStatements.hs:0:0: Splicing declarations+    singletons+      [d| foo1 :: Nat -> Nat+          foo1 x+            = let+                y :: Nat+                y = Succ Zero+              in y+          foo2 :: Nat+          foo2+            = let+                y = Succ Zero+                z = Succ y+              in z+          foo3 :: Nat -> Nat+          foo3 x+            = let+                y :: Nat+                y = Succ x+              in y+          foo4 :: Nat -> Nat+          foo4 x+            = let+                f :: Nat -> Nat+                f y = Succ y+              in f x+          foo5 :: Nat -> Nat+          foo5 x+            = let+                f :: Nat -> Nat+                f y+                  = let+                      z :: Nat+                      z = Succ y+                    in Succ z+              in f x+          foo6 :: Nat -> Nat+          foo6 x+            = let+                f :: Nat -> Nat+                f y = Succ y in+              let+                z :: Nat+                z = f x+              in z+          foo7 :: Nat -> Nat+          foo7 x+            = let+                x :: Nat+                x = Zero+              in x+          foo8 :: Nat -> Nat+          foo8 x+            = let+                z :: Nat+                z = (\ x -> x) Zero+              in z+          foo9 :: Nat -> Nat+          foo9 x+            = let+                z :: Nat -> Nat+                z = (\ x -> x)+              in z x+          foo10 :: Nat -> Nat+          foo10 x+            = let+                (+) :: Nat -> Nat -> Nat+                Zero + m = m+                (Succ n) + m = Succ (n + m)+              in (Succ Zero) + x+          foo11 :: Nat -> Nat+          foo11 x+            = let+                (+) :: Nat -> Nat -> Nat+                Zero + m = m+                (Succ n) + m = Succ (n + m)+                z :: Nat+                z = x+              in (Succ Zero) + z+          foo12 :: Nat -> Nat+          foo12 x+            = let+                (+) :: Nat -> Nat -> Nat+                Zero + m = m+                (Succ n) + m = Succ (n + x)+              in x + (Succ (Succ Zero))+          foo13 :: forall a. a -> a+          foo13 x+            = let+                bar :: a+                bar = x+              in foo13_ bar+          foo13_ :: a -> a+          foo13_ y = y+          foo14 :: Nat -> (Nat, Nat)+          foo14 x = let (y, z) = (Succ x, x) in (z, y) |]+  ======>+    Singletons/LetStatements.hs:(0,0)-(0,0)+    foo1 :: Nat -> Nat+    foo1 x+      = let+          y :: Nat+          y = Succ Zero+        in y+    foo2 :: Nat+    foo2+      = let+          y = Succ Zero+          z = Succ y+        in z+    foo3 :: Nat -> Nat+    foo3 x+      = let+          y :: Nat+          y = Succ x+        in y+    foo4 :: Nat -> Nat+    foo4 x+      = let+          f :: Nat -> Nat+          f y = Succ y+        in f x+    foo5 :: Nat -> Nat+    foo5 x+      = let+          f :: Nat -> Nat+          f y+            = let+                z :: Nat+                z = Succ y+              in Succ z+        in f x+    foo6 :: Nat -> Nat+    foo6 x+      = let+          f :: Nat -> Nat+          f y = Succ y in+        let+          z :: Nat+          z = f x+        in z+    foo7 :: Nat -> Nat+    foo7 x+      = let+          x :: Nat+          x = Zero+        in x+    foo8 :: Nat -> Nat+    foo8 x+      = let+          z :: Nat+          z = \ x -> x Zero+        in z+    foo9 :: Nat -> Nat+    foo9 x+      = let+          z :: Nat -> Nat+          z = \ x -> x+        in z x+    foo10 :: Nat -> Nat+    foo10 x+      = let+          (+) :: Nat -> Nat -> Nat+          (+) Zero m = m+          (+) (Succ n) m = Succ (n + m)+        in ((Succ Zero) + x)+    foo11 :: Nat -> Nat+    foo11 x+      = let+          (+) :: Nat -> Nat -> Nat+          z :: Nat+          (+) Zero m = m+          (+) (Succ n) m = Succ (n + m)+          z = x+        in ((Succ Zero) + z)+    foo12 :: Nat -> Nat+    foo12 x+      = let+          (+) :: Nat -> Nat -> Nat+          (+) Zero m = m+          (+) (Succ n) m = Succ (n + x)+        in (x + (Succ (Succ Zero)))+    foo13 :: forall a. a -> a+    foo13 x+      = let+          bar :: a+          bar = x+        in foo13_ bar+    foo13_ :: forall a. a -> a+    foo13_ y = y+    foo14 :: Nat -> (Nat, Nat)+    foo14 x = let (y, z) = (Succ x, x) in (z, y)+    type family Case_0123456789 x t where+      Case_0123456789 x (GHC.Tuple.(,) y_0123456789 z) = y_0123456789+    type family Case_0123456789 x t where+      Case_0123456789 x (GHC.Tuple.(,) z y_0123456789) = y_0123456789+    type Let_0123456789YSym1 t = Let_0123456789Y t+    instance SuppressUnusedWarnings Let_0123456789YSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Let_0123456789YSym0KindInference GHC.Tuple.())+    data Let_0123456789YSym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Let_0123456789YSym0 arg)) (KindOf (Let_0123456789YSym1 arg)) =>+        Let_0123456789YSym0KindInference+    type instance Apply Let_0123456789YSym0 l = Let_0123456789YSym1 l+    type Let_0123456789ZSym1 t = Let_0123456789Z t+    instance SuppressUnusedWarnings Let_0123456789ZSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Let_0123456789ZSym0KindInference GHC.Tuple.())+    data Let_0123456789ZSym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Let_0123456789ZSym0 arg)) (KindOf (Let_0123456789ZSym1 arg)) =>+        Let_0123456789ZSym0KindInference+    type instance Apply Let_0123456789ZSym0 l = Let_0123456789ZSym1 l+    type Let_0123456789X_0123456789Sym1 t =+        Let_0123456789X_0123456789 t+    instance SuppressUnusedWarnings Let_0123456789X_0123456789Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,)+               Let_0123456789X_0123456789Sym0KindInference GHC.Tuple.())+    data Let_0123456789X_0123456789Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Let_0123456789X_0123456789Sym0 arg)) (KindOf (Let_0123456789X_0123456789Sym1 arg)) =>+        Let_0123456789X_0123456789Sym0KindInference+    type instance Apply Let_0123456789X_0123456789Sym0 l = Let_0123456789X_0123456789Sym1 l+    type Let_0123456789Y x =+        Case_0123456789 x (Let_0123456789X_0123456789Sym1 x)+    type Let_0123456789Z x =+        Case_0123456789 x (Let_0123456789X_0123456789Sym1 x)+    type Let_0123456789X_0123456789 x =+        Apply (Apply Tuple2Sym0 (Apply SuccSym0 x)) x+    type Let_0123456789BarSym1 t = Let_0123456789Bar t+    instance SuppressUnusedWarnings Let_0123456789BarSym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Let_0123456789BarSym0KindInference GHC.Tuple.())+    data Let_0123456789BarSym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Let_0123456789BarSym0 arg)) (KindOf (Let_0123456789BarSym1 arg)) =>+        Let_0123456789BarSym0KindInference+    type instance Apply Let_0123456789BarSym0 l = Let_0123456789BarSym1 l+    type Let_0123456789Bar x = (x :: a)+    type Let_0123456789:+Sym3 t (t :: Nat) (t :: Nat) =+        Let_0123456789:+ t t t+    instance SuppressUnusedWarnings Let_0123456789:+Sym2 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Let_0123456789:+Sym2KindInference GHC.Tuple.())+    data Let_0123456789:+Sym2 l (l :: Nat) (l :: TyFun Nat Nat)+      = forall arg. (GHC.Types.~) (KindOf (Apply (Let_0123456789:+Sym2 l l) arg)) (KindOf (Let_0123456789:+Sym3 l l arg)) =>+        Let_0123456789:+Sym2KindInference+    type instance Apply (Let_0123456789:+Sym2 l l) l = Let_0123456789:+Sym3 l l l+    instance SuppressUnusedWarnings Let_0123456789:+Sym1 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Let_0123456789:+Sym1KindInference GHC.Tuple.())+    data Let_0123456789:+Sym1 l (l :: TyFun Nat (TyFun Nat Nat -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply (Let_0123456789:+Sym1 l) arg)) (KindOf (Let_0123456789:+Sym2 l arg)) =>+        Let_0123456789:+Sym1KindInference+    type instance Apply (Let_0123456789:+Sym1 l) l = Let_0123456789:+Sym2 l l+    instance SuppressUnusedWarnings Let_0123456789:+Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Let_0123456789:+Sym0KindInference GHC.Tuple.())+    data Let_0123456789:+Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Let_0123456789:+Sym0 arg)) (KindOf (Let_0123456789:+Sym1 arg)) =>+        Let_0123456789:+Sym0KindInference+    type instance Apply Let_0123456789:+Sym0 l = Let_0123456789:+Sym1 l+    type family Let_0123456789:+ x (a :: Nat) (a :: Nat) :: Nat where+      Let_0123456789:+ x Zero m = m+      Let_0123456789:+ x (Succ n) m = Apply SuccSym0 (Apply (Apply (Let_0123456789:+Sym1 x) n) x)+    type Let_0123456789ZSym1 t = Let_0123456789Z t+    instance SuppressUnusedWarnings Let_0123456789ZSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Let_0123456789ZSym0KindInference GHC.Tuple.())+    data Let_0123456789ZSym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Let_0123456789ZSym0 arg)) (KindOf (Let_0123456789ZSym1 arg)) =>+        Let_0123456789ZSym0KindInference+    type instance Apply Let_0123456789ZSym0 l = Let_0123456789ZSym1 l+    type Let_0123456789:+Sym3 t (t :: Nat) (t :: Nat) =+        Let_0123456789:+ t t t+    instance SuppressUnusedWarnings Let_0123456789:+Sym2 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Let_0123456789:+Sym2KindInference GHC.Tuple.())+    data Let_0123456789:+Sym2 l (l :: Nat) (l :: TyFun Nat Nat)+      = forall arg. (GHC.Types.~) (KindOf (Apply (Let_0123456789:+Sym2 l l) arg)) (KindOf (Let_0123456789:+Sym3 l l arg)) =>+        Let_0123456789:+Sym2KindInference+    type instance Apply (Let_0123456789:+Sym2 l l) l = Let_0123456789:+Sym3 l l l+    instance SuppressUnusedWarnings Let_0123456789:+Sym1 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Let_0123456789:+Sym1KindInference GHC.Tuple.())+    data Let_0123456789:+Sym1 l (l :: TyFun Nat (TyFun Nat Nat -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply (Let_0123456789:+Sym1 l) arg)) (KindOf (Let_0123456789:+Sym2 l arg)) =>+        Let_0123456789:+Sym1KindInference+    type instance Apply (Let_0123456789:+Sym1 l) l = Let_0123456789:+Sym2 l l+    instance SuppressUnusedWarnings Let_0123456789:+Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Let_0123456789:+Sym0KindInference GHC.Tuple.())+    data Let_0123456789:+Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Let_0123456789:+Sym0 arg)) (KindOf (Let_0123456789:+Sym1 arg)) =>+        Let_0123456789:+Sym0KindInference+    type instance Apply Let_0123456789:+Sym0 l = Let_0123456789:+Sym1 l+    type Let_0123456789Z x = (x :: Nat)+    type family Let_0123456789:+ x (a :: Nat) (a :: Nat) :: Nat where+      Let_0123456789:+ x Zero m = m+      Let_0123456789:+ x (Succ n) m = Apply SuccSym0 (Apply (Apply (Let_0123456789:+Sym1 x) n) m)+    type Let_0123456789:+Sym3 t (t :: Nat) (t :: Nat) =+        Let_0123456789:+ t t t+    instance SuppressUnusedWarnings Let_0123456789:+Sym2 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Let_0123456789:+Sym2KindInference GHC.Tuple.())+    data Let_0123456789:+Sym2 l (l :: Nat) (l :: TyFun Nat Nat)+      = forall arg. (GHC.Types.~) (KindOf (Apply (Let_0123456789:+Sym2 l l) arg)) (KindOf (Let_0123456789:+Sym3 l l arg)) =>+        Let_0123456789:+Sym2KindInference+    type instance Apply (Let_0123456789:+Sym2 l l) l = Let_0123456789:+Sym3 l l l+    instance SuppressUnusedWarnings Let_0123456789:+Sym1 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Let_0123456789:+Sym1KindInference GHC.Tuple.())+    data Let_0123456789:+Sym1 l (l :: TyFun Nat (TyFun Nat Nat -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply (Let_0123456789:+Sym1 l) arg)) (KindOf (Let_0123456789:+Sym2 l arg)) =>+        Let_0123456789:+Sym1KindInference+    type instance Apply (Let_0123456789:+Sym1 l) l = Let_0123456789:+Sym2 l l+    instance SuppressUnusedWarnings Let_0123456789:+Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Let_0123456789:+Sym0KindInference GHC.Tuple.())+    data Let_0123456789:+Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Let_0123456789:+Sym0 arg)) (KindOf (Let_0123456789:+Sym1 arg)) =>+        Let_0123456789:+Sym0KindInference+    type instance Apply Let_0123456789:+Sym0 l = Let_0123456789:+Sym1 l+    type family Let_0123456789:+ x (a :: Nat) (a :: Nat) :: Nat where+      Let_0123456789:+ x Zero m = m+      Let_0123456789:+ x (Succ n) m = Apply SuccSym0 (Apply (Apply (Let_0123456789:+Sym1 x) n) m)+    type family Lambda_0123456789 x a_0123456789 t where+      Lambda_0123456789 x a_0123456789 x = x+    type Lambda_0123456789Sym3 t t t = Lambda_0123456789 t t t+    instance SuppressUnusedWarnings Lambda_0123456789Sym2 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym2KindInference GHC.Tuple.())+    data Lambda_0123456789Sym2 l l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym2 l l) arg)) (KindOf (Lambda_0123456789Sym3 l l arg)) =>+        Lambda_0123456789Sym2KindInference+    type instance Apply (Lambda_0123456789Sym2 l l) l = Lambda_0123456789Sym3 l l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym1 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym1KindInference GHC.Tuple.())+    data Lambda_0123456789Sym1 l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym1 l) arg)) (KindOf (Lambda_0123456789Sym2 l arg)) =>+        Lambda_0123456789Sym1KindInference+    type instance Apply (Lambda_0123456789Sym1 l) l = Lambda_0123456789Sym2 l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym0KindInference GHC.Tuple.())+    data Lambda_0123456789Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Lambda_0123456789Sym0 arg)) (KindOf (Lambda_0123456789Sym1 arg)) =>+        Lambda_0123456789Sym0KindInference+    type instance Apply Lambda_0123456789Sym0 l = Lambda_0123456789Sym1 l+    type Let_0123456789ZSym2 t (t :: Nat) = Let_0123456789Z t t+    instance SuppressUnusedWarnings Let_0123456789ZSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Let_0123456789ZSym1KindInference GHC.Tuple.())+    data Let_0123456789ZSym1 l (l :: TyFun Nat Nat)+      = forall arg. (GHC.Types.~) (KindOf (Apply (Let_0123456789ZSym1 l) arg)) (KindOf (Let_0123456789ZSym2 l arg)) =>+        Let_0123456789ZSym1KindInference+    type instance Apply (Let_0123456789ZSym1 l) l = Let_0123456789ZSym2 l l+    instance SuppressUnusedWarnings Let_0123456789ZSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Let_0123456789ZSym0KindInference GHC.Tuple.())+    data Let_0123456789ZSym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Let_0123456789ZSym0 arg)) (KindOf (Let_0123456789ZSym1 arg)) =>+        Let_0123456789ZSym0KindInference+    type instance Apply Let_0123456789ZSym0 l = Let_0123456789ZSym1 l+    type family Let_0123456789Z x (a :: Nat) :: Nat where+      Let_0123456789Z x a_0123456789 = Apply (Apply (Apply Lambda_0123456789Sym0 x) a_0123456789) a_0123456789+    type family Lambda_0123456789 x t where+      Lambda_0123456789 x x = x+    type Lambda_0123456789Sym2 t t = Lambda_0123456789 t t+    instance SuppressUnusedWarnings Lambda_0123456789Sym1 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym1KindInference GHC.Tuple.())+    data Lambda_0123456789Sym1 l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym1 l) arg)) (KindOf (Lambda_0123456789Sym2 l arg)) =>+        Lambda_0123456789Sym1KindInference+    type instance Apply (Lambda_0123456789Sym1 l) l = Lambda_0123456789Sym2 l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym0KindInference GHC.Tuple.())+    data Lambda_0123456789Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Lambda_0123456789Sym0 arg)) (KindOf (Lambda_0123456789Sym1 arg)) =>+        Lambda_0123456789Sym0KindInference+    type instance Apply Lambda_0123456789Sym0 l = Lambda_0123456789Sym1 l+    type Let_0123456789ZSym1 t = Let_0123456789Z t+    instance SuppressUnusedWarnings Let_0123456789ZSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Let_0123456789ZSym0KindInference GHC.Tuple.())+    data Let_0123456789ZSym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Let_0123456789ZSym0 arg)) (KindOf (Let_0123456789ZSym1 arg)) =>+        Let_0123456789ZSym0KindInference+    type instance Apply Let_0123456789ZSym0 l = Let_0123456789ZSym1 l+    type Let_0123456789Z x =+        (Apply (Apply Lambda_0123456789Sym0 x) ZeroSym0 :: Nat)+    type Let_0123456789XSym1 t = Let_0123456789X t+    instance SuppressUnusedWarnings Let_0123456789XSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Let_0123456789XSym0KindInference GHC.Tuple.())+    data Let_0123456789XSym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Let_0123456789XSym0 arg)) (KindOf (Let_0123456789XSym1 arg)) =>+        Let_0123456789XSym0KindInference+    type instance Apply Let_0123456789XSym0 l = Let_0123456789XSym1 l+    type Let_0123456789X x = (ZeroSym0 :: Nat)+    type Let_0123456789FSym2 t (t :: Nat) = Let_0123456789F t t+    instance SuppressUnusedWarnings Let_0123456789FSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Let_0123456789FSym1KindInference GHC.Tuple.())+    data Let_0123456789FSym1 l (l :: TyFun Nat Nat)+      = forall arg. (GHC.Types.~) (KindOf (Apply (Let_0123456789FSym1 l) arg)) (KindOf (Let_0123456789FSym2 l arg)) =>+        Let_0123456789FSym1KindInference+    type instance Apply (Let_0123456789FSym1 l) l = Let_0123456789FSym2 l l+    instance SuppressUnusedWarnings Let_0123456789FSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Let_0123456789FSym0KindInference GHC.Tuple.())+    data Let_0123456789FSym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Let_0123456789FSym0 arg)) (KindOf (Let_0123456789FSym1 arg)) =>+        Let_0123456789FSym0KindInference+    type instance Apply Let_0123456789FSym0 l = Let_0123456789FSym1 l+    type family Let_0123456789F x (a :: Nat) :: Nat where+      Let_0123456789F x y = Apply SuccSym0 y+    type Let_0123456789ZSym1 t = Let_0123456789Z t+    instance SuppressUnusedWarnings Let_0123456789ZSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Let_0123456789ZSym0KindInference GHC.Tuple.())+    data Let_0123456789ZSym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Let_0123456789ZSym0 arg)) (KindOf (Let_0123456789ZSym1 arg)) =>+        Let_0123456789ZSym0KindInference+    type instance Apply Let_0123456789ZSym0 l = Let_0123456789ZSym1 l+    type Let_0123456789Z x = (Apply (Let_0123456789FSym1 x) x :: Nat)+    type Let_0123456789ZSym2 t t = Let_0123456789Z t t+    instance SuppressUnusedWarnings Let_0123456789ZSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Let_0123456789ZSym1KindInference GHC.Tuple.())+    data Let_0123456789ZSym1 l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Let_0123456789ZSym1 l) arg)) (KindOf (Let_0123456789ZSym2 l arg)) =>+        Let_0123456789ZSym1KindInference+    type instance Apply (Let_0123456789ZSym1 l) l = Let_0123456789ZSym2 l l+    instance SuppressUnusedWarnings Let_0123456789ZSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Let_0123456789ZSym0KindInference GHC.Tuple.())+    data Let_0123456789ZSym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Let_0123456789ZSym0 arg)) (KindOf (Let_0123456789ZSym1 arg)) =>+        Let_0123456789ZSym0KindInference+    type instance Apply Let_0123456789ZSym0 l = Let_0123456789ZSym1 l+    type Let_0123456789Z x y = (Apply SuccSym0 y :: Nat)+    type Let_0123456789FSym2 t (t :: Nat) = Let_0123456789F t t+    instance SuppressUnusedWarnings Let_0123456789FSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Let_0123456789FSym1KindInference GHC.Tuple.())+    data Let_0123456789FSym1 l (l :: TyFun Nat Nat)+      = forall arg. (GHC.Types.~) (KindOf (Apply (Let_0123456789FSym1 l) arg)) (KindOf (Let_0123456789FSym2 l arg)) =>+        Let_0123456789FSym1KindInference+    type instance Apply (Let_0123456789FSym1 l) l = Let_0123456789FSym2 l l+    instance SuppressUnusedWarnings Let_0123456789FSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Let_0123456789FSym0KindInference GHC.Tuple.())+    data Let_0123456789FSym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Let_0123456789FSym0 arg)) (KindOf (Let_0123456789FSym1 arg)) =>+        Let_0123456789FSym0KindInference+    type instance Apply Let_0123456789FSym0 l = Let_0123456789FSym1 l+    type family Let_0123456789F x (a :: Nat) :: Nat where+      Let_0123456789F x y = Apply SuccSym0 (Let_0123456789ZSym2 x y)+    type Let_0123456789FSym2 t (t :: Nat) = Let_0123456789F t t+    instance SuppressUnusedWarnings Let_0123456789FSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Let_0123456789FSym1KindInference GHC.Tuple.())+    data Let_0123456789FSym1 l (l :: TyFun Nat Nat)+      = forall arg. (GHC.Types.~) (KindOf (Apply (Let_0123456789FSym1 l) arg)) (KindOf (Let_0123456789FSym2 l arg)) =>+        Let_0123456789FSym1KindInference+    type instance Apply (Let_0123456789FSym1 l) l = Let_0123456789FSym2 l l+    instance SuppressUnusedWarnings Let_0123456789FSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Let_0123456789FSym0KindInference GHC.Tuple.())+    data Let_0123456789FSym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Let_0123456789FSym0 arg)) (KindOf (Let_0123456789FSym1 arg)) =>+        Let_0123456789FSym0KindInference+    type instance Apply Let_0123456789FSym0 l = Let_0123456789FSym1 l+    type family Let_0123456789F x (a :: Nat) :: Nat where+      Let_0123456789F x y = Apply SuccSym0 y+    type Let_0123456789YSym1 t = Let_0123456789Y t+    instance SuppressUnusedWarnings Let_0123456789YSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Let_0123456789YSym0KindInference GHC.Tuple.())+    data Let_0123456789YSym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Let_0123456789YSym0 arg)) (KindOf (Let_0123456789YSym1 arg)) =>+        Let_0123456789YSym0KindInference+    type instance Apply Let_0123456789YSym0 l = Let_0123456789YSym1 l+    type Let_0123456789Y x = (Apply SuccSym0 x :: Nat)+    type Let_0123456789YSym0 = Let_0123456789Y+    type Let_0123456789ZSym0 = Let_0123456789Z+    type Let_0123456789Y = Apply SuccSym0 ZeroSym0+    type Let_0123456789Z = Apply SuccSym0 Let_0123456789YSym0+    type Let_0123456789YSym1 t = Let_0123456789Y t+    instance SuppressUnusedWarnings Let_0123456789YSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Let_0123456789YSym0KindInference GHC.Tuple.())+    data Let_0123456789YSym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Let_0123456789YSym0 arg)) (KindOf (Let_0123456789YSym1 arg)) =>+        Let_0123456789YSym0KindInference+    type instance Apply Let_0123456789YSym0 l = Let_0123456789YSym1 l+    type Let_0123456789Y x = (Apply SuccSym0 ZeroSym0 :: Nat)+    type Foo14Sym1 (t :: Nat) = Foo14 t+    instance SuppressUnusedWarnings Foo14Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo14Sym0KindInference GHC.Tuple.())+    data Foo14Sym0 (l :: TyFun Nat (GHC.Tuple.(,) Nat Nat))+      = forall arg. (GHC.Types.~) (KindOf (Apply Foo14Sym0 arg)) (KindOf (Foo14Sym1 arg)) =>+        Foo14Sym0KindInference+    type instance Apply Foo14Sym0 l = Foo14Sym1 l+    type Foo13_Sym1 (t :: a) = Foo13_ t+    instance SuppressUnusedWarnings Foo13_Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo13_Sym0KindInference GHC.Tuple.())+    data Foo13_Sym0 (l :: TyFun a a)+      = forall arg. (GHC.Types.~) (KindOf (Apply Foo13_Sym0 arg)) (KindOf (Foo13_Sym1 arg)) =>+        Foo13_Sym0KindInference+    type instance Apply Foo13_Sym0 l = Foo13_Sym1 l+    type Foo13Sym1 (t :: a) = Foo13 t+    instance SuppressUnusedWarnings Foo13Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo13Sym0KindInference GHC.Tuple.())+    data Foo13Sym0 (l :: TyFun a a)+      = forall arg. (GHC.Types.~) (KindOf (Apply Foo13Sym0 arg)) (KindOf (Foo13Sym1 arg)) =>+        Foo13Sym0KindInference+    type instance Apply Foo13Sym0 l = Foo13Sym1 l+    type Foo12Sym1 (t :: Nat) = Foo12 t+    instance SuppressUnusedWarnings Foo12Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo12Sym0KindInference GHC.Tuple.())+    data Foo12Sym0 (l :: TyFun Nat Nat)+      = forall arg. (GHC.Types.~) (KindOf (Apply Foo12Sym0 arg)) (KindOf (Foo12Sym1 arg)) =>+        Foo12Sym0KindInference+    type instance Apply Foo12Sym0 l = Foo12Sym1 l+    type Foo11Sym1 (t :: Nat) = Foo11 t+    instance SuppressUnusedWarnings Foo11Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo11Sym0KindInference GHC.Tuple.())+    data Foo11Sym0 (l :: TyFun Nat Nat)+      = forall arg. (GHC.Types.~) (KindOf (Apply Foo11Sym0 arg)) (KindOf (Foo11Sym1 arg)) =>+        Foo11Sym0KindInference+    type instance Apply Foo11Sym0 l = Foo11Sym1 l+    type Foo10Sym1 (t :: Nat) = Foo10 t+    instance SuppressUnusedWarnings Foo10Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo10Sym0KindInference GHC.Tuple.())+    data Foo10Sym0 (l :: TyFun Nat Nat)+      = forall arg. (GHC.Types.~) (KindOf (Apply Foo10Sym0 arg)) (KindOf (Foo10Sym1 arg)) =>+        Foo10Sym0KindInference+    type instance Apply Foo10Sym0 l = Foo10Sym1 l+    type Foo9Sym1 (t :: Nat) = Foo9 t+    instance SuppressUnusedWarnings Foo9Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo9Sym0KindInference GHC.Tuple.())+    data Foo9Sym0 (l :: TyFun Nat Nat)+      = forall arg. (GHC.Types.~) (KindOf (Apply Foo9Sym0 arg)) (KindOf (Foo9Sym1 arg)) =>+        Foo9Sym0KindInference+    type instance Apply Foo9Sym0 l = Foo9Sym1 l+    type Foo8Sym1 (t :: Nat) = Foo8 t+    instance SuppressUnusedWarnings Foo8Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo8Sym0KindInference GHC.Tuple.())+    data Foo8Sym0 (l :: TyFun Nat Nat)+      = forall arg. (GHC.Types.~) (KindOf (Apply Foo8Sym0 arg)) (KindOf (Foo8Sym1 arg)) =>+        Foo8Sym0KindInference+    type instance Apply Foo8Sym0 l = Foo8Sym1 l+    type Foo7Sym1 (t :: Nat) = Foo7 t+    instance SuppressUnusedWarnings Foo7Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo7Sym0KindInference GHC.Tuple.())+    data Foo7Sym0 (l :: TyFun Nat Nat)+      = forall arg. (GHC.Types.~) (KindOf (Apply Foo7Sym0 arg)) (KindOf (Foo7Sym1 arg)) =>+        Foo7Sym0KindInference+    type instance Apply Foo7Sym0 l = Foo7Sym1 l+    type Foo6Sym1 (t :: Nat) = Foo6 t+    instance SuppressUnusedWarnings Foo6Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo6Sym0KindInference GHC.Tuple.())+    data Foo6Sym0 (l :: TyFun Nat Nat)+      = forall arg. (GHC.Types.~) (KindOf (Apply Foo6Sym0 arg)) (KindOf (Foo6Sym1 arg)) =>+        Foo6Sym0KindInference+    type instance Apply Foo6Sym0 l = Foo6Sym1 l+    type Foo5Sym1 (t :: Nat) = Foo5 t+    instance SuppressUnusedWarnings Foo5Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo5Sym0KindInference GHC.Tuple.())+    data Foo5Sym0 (l :: TyFun Nat Nat)+      = forall arg. (GHC.Types.~) (KindOf (Apply Foo5Sym0 arg)) (KindOf (Foo5Sym1 arg)) =>+        Foo5Sym0KindInference+    type instance Apply Foo5Sym0 l = Foo5Sym1 l+    type Foo4Sym1 (t :: Nat) = Foo4 t+    instance SuppressUnusedWarnings Foo4Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo4Sym0KindInference GHC.Tuple.())+    data Foo4Sym0 (l :: TyFun Nat Nat)+      = forall arg. (GHC.Types.~) (KindOf (Apply Foo4Sym0 arg)) (KindOf (Foo4Sym1 arg)) =>+        Foo4Sym0KindInference+    type instance Apply Foo4Sym0 l = Foo4Sym1 l+    type Foo3Sym1 (t :: Nat) = Foo3 t+    instance SuppressUnusedWarnings Foo3Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo3Sym0KindInference GHC.Tuple.())+    data Foo3Sym0 (l :: TyFun Nat Nat)+      = forall arg. (GHC.Types.~) (KindOf (Apply Foo3Sym0 arg)) (KindOf (Foo3Sym1 arg)) =>+        Foo3Sym0KindInference+    type instance Apply Foo3Sym0 l = Foo3Sym1 l+    type Foo2Sym0 = Foo2+    type Foo1Sym1 (t :: Nat) = Foo1 t+    instance SuppressUnusedWarnings Foo1Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo1Sym0KindInference GHC.Tuple.())+    data Foo1Sym0 (l :: TyFun Nat Nat)+      = forall arg. (GHC.Types.~) (KindOf (Apply Foo1Sym0 arg)) (KindOf (Foo1Sym1 arg)) =>+        Foo1Sym0KindInference+    type instance Apply Foo1Sym0 l = Foo1Sym1 l+    type family Foo14 (a :: Nat) :: GHC.Tuple.(,) Nat Nat where+      Foo14 x = Apply (Apply Tuple2Sym0 (Let_0123456789ZSym1 x)) (Let_0123456789YSym1 x)+    type family Foo13_ (a :: a) :: a where+      Foo13_ y = y+    type family Foo13 (a :: a) :: a where+      Foo13 x = Apply Foo13_Sym0 (Let_0123456789BarSym1 x)+    type family Foo12 (a :: Nat) :: Nat where+      Foo12 x = Apply (Apply (Let_0123456789:+Sym1 x) x) (Apply SuccSym0 (Apply SuccSym0 ZeroSym0))+    type family Foo11 (a :: Nat) :: Nat where+      Foo11 x = Apply (Apply (Let_0123456789:+Sym1 x) (Apply SuccSym0 ZeroSym0)) (Let_0123456789ZSym1 x)+    type family Foo10 (a :: Nat) :: Nat where+      Foo10 x = Apply (Apply (Let_0123456789:+Sym1 x) (Apply SuccSym0 ZeroSym0)) x+    type family Foo9 (a :: Nat) :: Nat where+      Foo9 x = Apply (Let_0123456789ZSym1 x) x+    type family Foo8 (a :: Nat) :: Nat where+      Foo8 x = Let_0123456789ZSym1 x+    type family Foo7 (a :: Nat) :: Nat where+      Foo7 x = Let_0123456789XSym1 x+    type family Foo6 (a :: Nat) :: Nat where+      Foo6 x = Let_0123456789ZSym1 x+    type family Foo5 (a :: Nat) :: Nat where+      Foo5 x = Apply (Let_0123456789FSym1 x) x+    type family Foo4 (a :: Nat) :: Nat where+      Foo4 x = Apply (Let_0123456789FSym1 x) x+    type family Foo3 (a :: Nat) :: Nat where+      Foo3 x = Let_0123456789YSym1 x+    type Foo2 = (Let_0123456789ZSym0 :: Nat)+    type family Foo1 (a :: Nat) :: Nat where+      Foo1 x = Let_0123456789YSym1 x+    sFoo14 :: forall (t :: Nat). Sing t -> Sing (Apply Foo14Sym0 t)+    sFoo13_ :: forall (t :: a). Sing t -> Sing (Apply Foo13_Sym0 t)+    sFoo13 :: forall (t :: a). Sing t -> Sing (Apply Foo13Sym0 t)+    sFoo12 :: forall (t :: Nat). Sing t -> Sing (Apply Foo12Sym0 t)+    sFoo11 :: forall (t :: Nat). Sing t -> Sing (Apply Foo11Sym0 t)+    sFoo10 :: forall (t :: Nat). Sing t -> Sing (Apply Foo10Sym0 t)+    sFoo9 :: forall (t :: Nat). Sing t -> Sing (Apply Foo9Sym0 t)+    sFoo8 :: forall (t :: Nat). Sing t -> Sing (Apply Foo8Sym0 t)+    sFoo7 :: forall (t :: Nat). Sing t -> Sing (Apply Foo7Sym0 t)+    sFoo6 :: forall (t :: Nat). Sing t -> Sing (Apply Foo6Sym0 t)+    sFoo5 :: forall (t :: Nat). Sing t -> Sing (Apply Foo5Sym0 t)+    sFoo4 :: forall (t :: Nat). Sing t -> Sing (Apply Foo4Sym0 t)+    sFoo3 :: forall (t :: Nat). Sing t -> Sing (Apply Foo3Sym0 t)+    sFoo2 :: Sing Foo2Sym0+    sFoo1 :: forall (t :: Nat). Sing t -> Sing (Apply Foo1Sym0 t)+    sFoo14 sX+      = let+          lambda ::+            forall x. (GHC.Types.~) t x => Sing x -> Sing (Apply Foo14Sym0 x)+          lambda x+            = let+                sY :: Sing (Let_0123456789YSym1 x)+                sZ :: Sing (Let_0123456789ZSym1 x)+                sX_0123456789 :: Sing (Let_0123456789X_0123456789Sym1 x)+                sY+                  = case sX_0123456789 of {+                      STuple2 sY_0123456789 _+                        -> let+                             lambda ::+                               forall y_0123456789 wild.+                               Sing y_0123456789+                               -> Sing (Case_0123456789 x (Apply (Apply Tuple2Sym0 y_0123456789) wild))+                             lambda y_0123456789 = y_0123456789+                           in lambda sY_0123456789 }+                sZ+                  = case sX_0123456789 of {+                      STuple2 _ sY_0123456789+                        -> let+                             lambda ::+                               forall y_0123456789 wild.+                               Sing y_0123456789+                               -> Sing (Case_0123456789 x (Apply (Apply Tuple2Sym0 wild) y_0123456789))+                             lambda y_0123456789 = y_0123456789+                           in lambda sY_0123456789 }+                sX_0123456789+                  = applySing+                      (applySing+                         (singFun2 (Proxy :: Proxy Tuple2Sym0) STuple2)+                         (applySing (singFun1 (Proxy :: Proxy SuccSym0) SSucc) x))+                      x+              in+                applySing+                  (applySing (singFun2 (Proxy :: Proxy Tuple2Sym0) STuple2) sZ) sY+        in lambda sX+    sFoo13_ sY+      = let+          lambda ::+            forall y. (GHC.Types.~) t y => Sing y -> Sing (Apply Foo13_Sym0 y)+          lambda y = y+        in lambda sY+    sFoo13 sX+      = let+          lambda ::+            forall x. (GHC.Types.~) t x => Sing x -> Sing (Apply Foo13Sym0 x)+          lambda x+            = let+                sBar :: Sing (Let_0123456789BarSym1 x)+                sBar = x+              in applySing (singFun1 (Proxy :: Proxy Foo13_Sym0) sFoo13_) sBar+        in lambda sX+    sFoo12 sX+      = let+          lambda ::+            forall x. (GHC.Types.~) t x => Sing x -> Sing (Apply Foo12Sym0 x)+          lambda x+            = let+                (%:+) ::+                  forall t t.+                  Sing t+                  -> Sing t -> Sing (Apply (Apply (Let_0123456789:+Sym1 x) t) t)+                (%:+) SZero sM+                  = let+                      lambda ::+                        forall m. ((GHC.Types.~) t ZeroSym0, (GHC.Types.~) t m) =>+                        Sing m -> Sing (Apply (Apply (Let_0123456789:+Sym1 x) ZeroSym0) m)+                      lambda m = m+                    in lambda sM+                (%:+) (SSucc sN) sM+                  = let+                      lambda ::+                        forall n m. ((GHC.Types.~) t (Apply SuccSym0 n),+                                     (GHC.Types.~) t m) =>+                        Sing n+                        -> Sing m+                           -> Sing (Apply (Apply (Let_0123456789:+Sym1 x) (Apply SuccSym0 n)) m)+                      lambda n m+                        = applySing+                            (singFun1 (Proxy :: Proxy SuccSym0) SSucc)+                            (applySing+                               (applySing+                                  (singFun2 (Proxy :: Proxy (Let_0123456789:+Sym1 x)) (%:+)) n)+                               x)+                    in lambda sN sM+              in+                applySing+                  (applySing+                     (singFun2 (Proxy :: Proxy (Let_0123456789:+Sym1 x)) (%:+)) x)+                  (applySing+                     (singFun1 (Proxy :: Proxy SuccSym0) SSucc)+                     (applySing (singFun1 (Proxy :: Proxy SuccSym0) SSucc) SZero))+        in lambda sX+    sFoo11 sX+      = let+          lambda ::+            forall x. (GHC.Types.~) t x => Sing x -> Sing (Apply Foo11Sym0 x)+          lambda x+            = let+                sZ :: Sing (Let_0123456789ZSym1 x)+                (%:+) ::+                  forall t t.+                  Sing t+                  -> Sing t -> Sing (Apply (Apply (Let_0123456789:+Sym1 x) t) t)+                sZ = x+                (%:+) SZero sM+                  = let+                      lambda ::+                        forall m. ((GHC.Types.~) t ZeroSym0, (GHC.Types.~) t m) =>+                        Sing m -> Sing (Apply (Apply (Let_0123456789:+Sym1 x) ZeroSym0) m)+                      lambda m = m+                    in lambda sM+                (%:+) (SSucc sN) sM+                  = let+                      lambda ::+                        forall n m. ((GHC.Types.~) t (Apply SuccSym0 n),+                                     (GHC.Types.~) t m) =>+                        Sing n+                        -> Sing m+                           -> Sing (Apply (Apply (Let_0123456789:+Sym1 x) (Apply SuccSym0 n)) m)+                      lambda n m+                        = applySing+                            (singFun1 (Proxy :: Proxy SuccSym0) SSucc)+                            (applySing+                               (applySing+                                  (singFun2 (Proxy :: Proxy (Let_0123456789:+Sym1 x)) (%:+)) n)+                               m)+                    in lambda sN sM+              in+                applySing+                  (applySing+                     (singFun2 (Proxy :: Proxy (Let_0123456789:+Sym1 x)) (%:+))+                     (applySing (singFun1 (Proxy :: Proxy SuccSym0) SSucc) SZero))+                  sZ+        in lambda sX+    sFoo10 sX+      = let+          lambda ::+            forall x. (GHC.Types.~) t x => Sing x -> Sing (Apply Foo10Sym0 x)+          lambda x+            = let+                (%:+) ::+                  forall t t.+                  Sing t+                  -> Sing t -> Sing (Apply (Apply (Let_0123456789:+Sym1 x) t) t)+                (%:+) SZero sM+                  = let+                      lambda ::+                        forall m. ((GHC.Types.~) t ZeroSym0, (GHC.Types.~) t m) =>+                        Sing m -> Sing (Apply (Apply (Let_0123456789:+Sym1 x) ZeroSym0) m)+                      lambda m = m+                    in lambda sM+                (%:+) (SSucc sN) sM+                  = let+                      lambda ::+                        forall n m. ((GHC.Types.~) t (Apply SuccSym0 n),+                                     (GHC.Types.~) t m) =>+                        Sing n+                        -> Sing m+                           -> Sing (Apply (Apply (Let_0123456789:+Sym1 x) (Apply SuccSym0 n)) m)+                      lambda n m+                        = applySing+                            (singFun1 (Proxy :: Proxy SuccSym0) SSucc)+                            (applySing+                               (applySing+                                  (singFun2 (Proxy :: Proxy (Let_0123456789:+Sym1 x)) (%:+)) n)+                               m)+                    in lambda sN sM+              in+                applySing+                  (applySing+                     (singFun2 (Proxy :: Proxy (Let_0123456789:+Sym1 x)) (%:+))+                     (applySing (singFun1 (Proxy :: Proxy SuccSym0) SSucc) SZero))+                  x+        in lambda sX+    sFoo9 sX+      = let+          lambda ::+            forall x. (GHC.Types.~) t x => Sing x -> Sing (Apply Foo9Sym0 x)+          lambda x+            = let+                sZ :: forall t. Sing t -> Sing (Apply (Let_0123456789ZSym1 x) t)+                sZ sA_0123456789+                  = let+                      lambda ::+                        forall a_0123456789. (GHC.Types.~) t a_0123456789 =>+                        Sing a_0123456789+                        -> Sing (Apply (Let_0123456789ZSym1 x) a_0123456789)+                      lambda a_0123456789+                        = applySing+                            (singFun1+                               (Proxy ::+                                  Proxy (Apply (Apply Lambda_0123456789Sym0 x) a_0123456789))+                               (\ sX+                                  -> let+                                       lambda ::+                                         forall x.+                                         Sing x+                                         -> Sing (Apply (Apply (Apply Lambda_0123456789Sym0 x) a_0123456789) x)+                                       lambda x = x+                                     in lambda sX))+                            a_0123456789+                    in lambda sA_0123456789+              in+                applySing (singFun1 (Proxy :: Proxy (Let_0123456789ZSym1 x)) sZ) x+        in lambda sX+    sFoo8 sX+      = let+          lambda ::+            forall x. (GHC.Types.~) t x => Sing x -> Sing (Apply Foo8Sym0 x)+          lambda x+            = let+                sZ :: Sing (Let_0123456789ZSym1 x)+                sZ+                  = applySing+                      (singFun1+                         (Proxy :: Proxy (Apply Lambda_0123456789Sym0 x))+                         (\ sX+                            -> let+                                 lambda ::+                                   forall x.+                                   Sing x -> Sing (Apply (Apply Lambda_0123456789Sym0 x) x)+                                 lambda x = x+                               in lambda sX))+                      SZero+              in sZ+        in lambda sX+    sFoo7 sX+      = let+          lambda ::+            forall x. (GHC.Types.~) t x => Sing x -> Sing (Apply Foo7Sym0 x)+          lambda x+            = let+                sX :: Sing (Let_0123456789XSym1 x)+                sX = SZero+              in sX+        in lambda sX+    sFoo6 sX+      = let+          lambda ::+            forall x. (GHC.Types.~) t x => Sing x -> Sing (Apply Foo6Sym0 x)+          lambda x+            = let+                sF :: forall t. Sing t -> Sing (Apply (Let_0123456789FSym1 x) t)+                sF sY+                  = let+                      lambda ::+                        forall y. (GHC.Types.~) t y =>+                        Sing y -> Sing (Apply (Let_0123456789FSym1 x) y)+                      lambda y = applySing (singFun1 (Proxy :: Proxy SuccSym0) SSucc) y+                    in lambda sY in+              let+                sZ :: Sing (Let_0123456789ZSym1 x)+                sZ+                  = applySing+                      (singFun1 (Proxy :: Proxy (Let_0123456789FSym1 x)) sF) x+              in sZ+        in lambda sX+    sFoo5 sX+      = let+          lambda ::+            forall x. (GHC.Types.~) t x => Sing x -> Sing (Apply Foo5Sym0 x)+          lambda x+            = let+                sF :: forall t. Sing t -> Sing (Apply (Let_0123456789FSym1 x) t)+                sF sY+                  = let+                      lambda ::+                        forall y. (GHC.Types.~) t y =>+                        Sing y -> Sing (Apply (Let_0123456789FSym1 x) y)+                      lambda y+                        = let+                            sZ :: Sing (Let_0123456789ZSym2 x y)+                            sZ = applySing (singFun1 (Proxy :: Proxy SuccSym0) SSucc) y+                          in applySing (singFun1 (Proxy :: Proxy SuccSym0) SSucc) sZ+                    in lambda sY+              in+                applySing (singFun1 (Proxy :: Proxy (Let_0123456789FSym1 x)) sF) x+        in lambda sX+    sFoo4 sX+      = let+          lambda ::+            forall x. (GHC.Types.~) t x => Sing x -> Sing (Apply Foo4Sym0 x)+          lambda x+            = let+                sF :: forall t. Sing t -> Sing (Apply (Let_0123456789FSym1 x) t)+                sF sY+                  = let+                      lambda ::+                        forall y. (GHC.Types.~) t y =>+                        Sing y -> Sing (Apply (Let_0123456789FSym1 x) y)+                      lambda y = applySing (singFun1 (Proxy :: Proxy SuccSym0) SSucc) y+                    in lambda sY+              in+                applySing (singFun1 (Proxy :: Proxy (Let_0123456789FSym1 x)) sF) x+        in lambda sX+    sFoo3 sX+      = let+          lambda ::+            forall x. (GHC.Types.~) t x => Sing x -> Sing (Apply Foo3Sym0 x)+          lambda x+            = let+                sY :: Sing (Let_0123456789YSym1 x)+                sY = applySing (singFun1 (Proxy :: Proxy SuccSym0) SSucc) x+              in sY+        in lambda sX+    sFoo2+      = let+          sY :: Sing Let_0123456789YSym0+          sZ :: Sing Let_0123456789ZSym0+          sY = applySing (singFun1 (Proxy :: Proxy SuccSym0) SSucc) SZero+          sZ = applySing (singFun1 (Proxy :: Proxy SuccSym0) SSucc) sY+        in sZ+    sFoo1 sX+      = let+          lambda ::+            forall x. (GHC.Types.~) t x => Sing x -> Sing (Apply Foo1Sym0 x)+          lambda x+            = let+                sY :: Sing (Let_0123456789YSym1 x)+                sY = applySing (singFun1 (Proxy :: Proxy SuccSym0) SSucc) SZero+              in sY+        in lambda sX
+ tests/compile-and-dump/Singletons/LetStatements.hs view
@@ -0,0 +1,193 @@+{-# OPTIONS_GHC -fno-warn-unused-binds   -fno-warn-unused-matches+                -fno-warn-name-shadowing -fno-warn-unused-imports #-}++module Singletons.LetStatements where++import Data.Singletons+import Data.Singletons.Prelude+import Data.Singletons.SuppressUnusedWarnings+import Data.Singletons.TH+import Singletons.Nat++$(singletons [d|+  -- type signature required for a constant+  foo1 :: Nat -> Nat+  foo1 x = let y :: Nat+               y = Succ Zero+           in  y++  -- nothing in scope, no type signatures required+  foo2 :: Nat+  foo2 = let y = Succ Zero+             z = Succ y+         in z++  -- using in-scope variable+  foo3 :: Nat -> Nat+  foo3 x = let y :: Nat+               y = Succ x+           in y++  -- passing in-scope variable to a function. Tests also adding in-scope binders+  -- at the call site of f+  foo4 :: Nat -> Nat+  foo4 x = let f :: Nat -> Nat+               f y = Succ y+           in  f x++  -- nested lets, version 1. This could potentially be problematic.+  foo5 :: Nat -> Nat+  foo5 x = let f :: Nat -> Nat+               f y = let z :: Nat+                         z = Succ y+                     in Succ z+           in  f x++  -- nested lets, version 2. This shouldn't cause any problems, so that's just a+  -- sanity check.+  foo6 :: Nat -> Nat+  foo6 x = let f :: Nat -> Nat+               f y = Succ y+           in let z :: Nat+                  z = f x+              in z++  -- name shadowing+  foo7 :: Nat -> Nat+  foo7 x = let x :: Nat+               x = Zero+           in x++  -- lambda binder in let shadows pattern-bound variable+  foo8 :: Nat -> Nat+  foo8 x = let z :: Nat+               z = (\x -> x) Zero+           in z++  -- let-declaring lambdas+  foo9 :: Nat -> Nat+  foo9 x = let z :: Nat -> Nat+               z = (\x -> x)+           in z x+  -- infix declaration+  foo10 :: Nat -> Nat+  foo10 x = let (+) :: Nat -> Nat -> Nat+                Zero     + m = m+                (Succ n) + m = Succ (n + m)+            in (Succ Zero) + x++  -- infix call uses let-bound binder+  foo11 :: Nat -> Nat+  foo11 x = let (+) :: Nat -> Nat -> Nat+                Zero     + m = m+                (Succ n) + m = Succ (n + m)+                z :: Nat+                z = x+            in (Succ Zero) + z++  -- infix let-declaration uses in-scope variable+  foo12 :: Nat -> Nat+  foo12 x = let (+) :: Nat -> Nat -> Nat+                Zero     + m = m+                (Succ n) + m = Succ (n + x)+            in x + (Succ (Succ Zero))++  -- make sure that calls to functions declared outside of let don't receive+  -- extra parameters with in-scope bindings. See #18.+  foo13 :: forall a. a -> a+  foo13 x = let bar :: a+                bar = x+            in foo13_ bar++  foo13_ :: a -> a+  foo13_ y = y++  -- tuple patterns in let statements. See #20+  foo14 :: Nat -> (Nat, Nat)+  foo14 x = let (y, z) = (Succ x, x)+            in  (z, y)+ |])++foo1a :: Proxy (Foo1 Zero)+foo1a = Proxy++foo1b :: Proxy (Succ Zero)+foo1b = foo1a++foo2a :: Proxy Foo2+foo2a = Proxy++foo2b :: Proxy (Succ (Succ Zero))+foo2b = foo2a++foo3a :: Proxy (Foo3 (Succ Zero))+foo3a = Proxy++foo3b :: Proxy (Succ (Succ Zero))+foo3b = foo3a++foo4a :: Proxy (Foo4 (Succ Zero))+foo4a = Proxy++foo4b :: Proxy (Succ (Succ Zero))+foo4b = foo4a++foo5a :: Proxy (Foo5 Zero)+foo5a = Proxy++foo5b :: Proxy (Succ (Succ Zero))+foo5b = foo5a++foo6a :: Proxy (Foo6 Zero)+foo6a = Proxy++foo6b :: Proxy (Succ Zero)+foo6b = foo6a++foo7a :: Proxy (Foo7 (Succ (Succ Zero)))+foo7a = Proxy++foo7b :: Proxy Zero+foo7b = foo7a++foo8a :: Proxy (Foo8 (Succ (Succ Zero)))+foo8a = Proxy++foo8b :: Proxy Zero+foo8b = foo8a++foo9a :: Proxy (Foo9 (Succ (Succ Zero)))+foo9a = Proxy++foo9b :: Proxy (Succ (Succ Zero))+foo9b = foo9a++foo10a :: Proxy (Foo10 (Succ (Succ Zero)))+foo10a = Proxy++foo10b :: Proxy (Succ (Succ (Succ Zero)))+foo10b = foo10a++foo11a :: Proxy (Foo11 (Succ (Succ Zero)))+foo11a = Proxy++foo11b :: Proxy (Succ (Succ (Succ Zero)))+foo11b = foo11a++foo12a :: Proxy (Foo12 (Succ (Succ (Succ Zero))))+foo12a = Proxy++foo12b :: Proxy (Succ (Succ (Succ (Succ (Succ (Succ Zero))))))+foo12b = foo12a++foo13a :: Proxy (Foo13 Zero)+foo13a = Proxy++foo13b :: Proxy Zero+foo13b = foo13a++foo14a :: Proxy (Foo14 Zero)+foo14a = Proxy++foo14b :: Proxy '(Zero, Succ Zero)+foo14b = foo14a
tests/compile-and-dump/Singletons/Maybe.ghc76.template view
@@ -8,10 +8,16 @@     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 (:==) Nothing Nothing = TrueSym0+    type instance (:==) Nothing (Just b) = FalseSym0+    type instance (:==) (Just a) Nothing = FalseSym0     type instance (:==) (Just a) (Just b) = :== a b+    type MaybeTyCtor = Maybe+    data MaybeTyCtorSym0 (k :: TyFun * *)+    type instance Apply MaybeTyCtorSym0 a = MaybeTyCtor a+    type NothingSym0 = Nothing+    data JustSym0 (k :: TyFun a (Maybe a))+    type instance Apply JustSym0 a = Just a     data instance Sing (z :: Maybe a)       = z ~ Nothing => SNothing |         forall (n :: a). z ~ Just n => SJust (Sing n)
tests/compile-and-dump/Singletons/Maybe.ghc78.template view
@@ -10,13 +10,23 @@       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+      Equals_0123456789 Nothing Nothing = TrueSym0+      Equals_0123456789 (Just a) (Just b) = (:==) a b+      Equals_0123456789 (a :: Maybe k) (b :: Maybe k) = FalseSym0+    instance PEq (KProxy :: KProxy (Maybe k)) where+      type (:==) (a :: Maybe k) (b :: Maybe k) = Equals_0123456789 a b+    type NothingSym0 = Nothing+    type JustSym1 (t :: a) = Just t+    instance SuppressUnusedWarnings JustSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) JustSym0KindInference GHC.Tuple.())+    data JustSym0 (l :: TyFun a (Maybe a))+      = forall arg. (GHC.Types.~) (KindOf (Apply JustSym0 arg)) (KindOf (JustSym1 arg)) =>+        JustSym0KindInference+    type instance Apply JustSym0 l = JustSym1 l     data instance Sing (z :: Maybe a)-      = z ~ Nothing => SNothing |-        forall (n :: a). z ~ Just n => SJust (Sing n)+      = (GHC.Types.~) z Nothing => SNothing |+        forall (n :: a). (GHC.Types.~) z (Just n) => SJust (Sing n)     type SMaybe (z :: Maybe a) = Sing z     instance SingKind (KProxy :: KProxy a) =>              SingKind (KProxy :: KProxy (Maybe a)) where@@ -38,16 +48,19 @@       (%~) SNothing SNothing = Proved Refl       (%~) SNothing (SJust _)         = Disproved-            (\case {-               _ -> error "Empty case reached -- this should be impossible" })+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })       (%~) (SJust _) SNothing         = Disproved-            (\case {-               _ -> error "Empty case reached -- this should be impossible" })+            (\ x+               -> case x of {+                    _ -> 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) }+            Disproved contra+              -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) }     instance SingI Nothing where       sing = SNothing     instance SingI n => SingI (Just (n :: a)) where
tests/compile-and-dump/Singletons/Maybe.hs view
@@ -1,6 +1,10 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+ module Singletons.Maybe where  import Data.Singletons.TH+import Data.Singletons.SuppressUnusedWarnings+import Prelude hiding (Maybe, Nothing, Just)  $(singletons [d|   data Maybe a = Nothing | Just a deriving (Eq, Show)
tests/compile-and-dump/Singletons/Nat.ghc76.template view
@@ -1,79 +1,89 @@ 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+    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 = TrueSym0+    type instance (:==) Zero (Succ b) = FalseSym0+    type instance (:==) (Succ a) Zero = FalseSym0+    type instance (:==) (Succ a) (Succ b) = :== a b+    type NatTyCtor = Nat+    type NatTyCtorSym0 = NatTyCtor+    type ZeroSym0 = Zero+    data SuccSym0 (k :: TyFun Nat Nat)+    type instance Apply SuccSym0 a = Succ a+    type family Plus (a :: Nat) (a :: Nat) :: Nat+    type instance Plus Zero m = m+    type instance Plus (Succ n) m =+        Apply SuccSym0 (Apply (Apply PlusSym0 n) m)+    data PlusSym1 (l :: Nat) (l :: TyFun Nat Nat)+    data PlusSym0 (k :: TyFun Nat (TyFun Nat Nat -> *))+    type instance Apply (PlusSym1 a) a = Plus a a+    type instance Apply PlusSym0 a = PlusSym1 a+    type family Pred (a :: Nat) :: Nat+    type instance Pred Zero = ZeroSym0+    type instance Pred (Succ n) = n+    data PredSym0 (k :: TyFun Nat Nat)+    type instance Apply PredSym0 a = Pred a+    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 view
@@ -1,80 +1,144 @@ 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+    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 = TrueSym0+      Equals_0123456789 (Succ a) (Succ b) = (:==) a b+      Equals_0123456789 (a :: Nat) (b :: Nat) = FalseSym0+    instance PEq (KProxy :: KProxy Nat) where+      type (:==) (a :: Nat) (b :: Nat) = Equals_0123456789 a b+    type ZeroSym0 = Zero+    type SuccSym1 (t :: Nat) = Succ t+    instance SuppressUnusedWarnings SuccSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) SuccSym0KindInference GHC.Tuple.())+    data SuccSym0 (l :: TyFun Nat Nat)+      = forall arg. (GHC.Types.~) (KindOf (Apply SuccSym0 arg)) (KindOf (SuccSym1 arg)) =>+        SuccSym0KindInference+    type instance Apply SuccSym0 l = SuccSym1 l+    type PredSym1 (t :: Nat) = Pred t+    instance SuppressUnusedWarnings PredSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) PredSym0KindInference GHC.Tuple.())+    data PredSym0 (l :: TyFun Nat Nat)+      = forall arg. (GHC.Types.~) (KindOf (Apply PredSym0 arg)) (KindOf (PredSym1 arg)) =>+        PredSym0KindInference+    type instance Apply PredSym0 l = PredSym1 l+    type PlusSym2 (t :: Nat) (t :: Nat) = Plus t t+    instance SuppressUnusedWarnings PlusSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) PlusSym1KindInference GHC.Tuple.())+    data PlusSym1 (l :: Nat) (l :: TyFun Nat Nat)+      = forall arg. (GHC.Types.~) (KindOf (Apply (PlusSym1 l) arg)) (KindOf (PlusSym2 l arg)) =>+        PlusSym1KindInference+    type instance Apply (PlusSym1 l) l = PlusSym2 l l+    instance SuppressUnusedWarnings PlusSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) PlusSym0KindInference GHC.Tuple.())+    data PlusSym0 (l :: TyFun Nat (TyFun Nat Nat -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply PlusSym0 arg)) (KindOf (PlusSym1 arg)) =>+        PlusSym0KindInference+    type instance Apply PlusSym0 l = PlusSym1 l+    type family Pred (a :: Nat) :: Nat where+      Pred Zero = ZeroSym0+      Pred (Succ n) = n+    type family Plus (a :: Nat) (a :: Nat) :: Nat where+      Plus Zero m = m+      Plus (Succ n) m = Apply SuccSym0 (Apply (Apply PlusSym0 n) m)+    sPred :: forall (t :: Nat). Sing t -> Sing (Apply PredSym0 t)+    sPlus ::+      forall (t :: Nat) (t :: Nat).+      Sing t -> Sing t -> Sing (Apply (Apply PlusSym0 t) t)+    sPred SZero+      = let+          lambda ::+            (GHC.Types.~) t ZeroSym0 => Sing (Apply PredSym0 ZeroSym0)+          lambda = SZero+        in lambda+    sPred (SSucc sN)+      = let+          lambda ::+            forall n. (GHC.Types.~) t (Apply SuccSym0 n) =>+            Sing n -> Sing (Apply PredSym0 (Apply SuccSym0 n))+          lambda n = n+        in lambda sN+    sPlus SZero sM+      = let+          lambda ::+            forall m. ((GHC.Types.~) t ZeroSym0, (GHC.Types.~) t m) =>+            Sing m -> Sing (Apply (Apply PlusSym0 ZeroSym0) m)+          lambda m = m+        in lambda sM+    sPlus (SSucc sN) sM+      = let+          lambda ::+            forall n m. ((GHC.Types.~) t (Apply SuccSym0 n),+                         (GHC.Types.~) t m) =>+            Sing n+            -> Sing m -> Sing (Apply (Apply PlusSym0 (Apply SuccSym0 n)) m)+          lambda n m+            = applySing+                (singFun1 (Proxy :: Proxy SuccSym0) SSucc)+                (applySing+                   (applySing (singFun2 (Proxy :: Proxy PlusSym0) sPlus) n) m)+        in lambda sN sM+    data instance Sing (z :: Nat)+      = (GHC.Types.~) z Zero => SZero |+        forall (n :: Nat). (GHC.Types.~) 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+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) (SSucc _) SZero+        = Disproved+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })+      (%~) (SSucc a) (SSucc b)+        = case (%~) a b of {+            Proved Refl -> Proved Refl+            Disproved contra+              -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) }+    instance SingI Zero where+      sing = SZero+    instance SingI n => SingI (Succ (n :: Nat)) where+      sing = SSucc sing
tests/compile-and-dump/Singletons/Nat.hs view
@@ -1,6 +1,11 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+ module Singletons.Nat where  import Data.Singletons.TH+import Data.Singletons+import Data.Proxy+import Data.Singletons.SuppressUnusedWarnings  $(singletons [d|   data Nat where
tests/compile-and-dump/Singletons/Operators.ghc76.template view
@@ -6,7 +6,7 @@           + :: Nat -> Nat -> Nat           Zero + m = m           (Succ n) + m = Succ (n + m)-+                     data Foo             where               FLeaf :: Foo@@ -20,12 +20,26 @@     + :: 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 FooTyCtor = Foo+    type FooTyCtorSym0 = FooTyCtor+    type FLeafSym0 = FLeaf+    data (:+:$$) (l :: Foo) (l :: TyFun Foo Foo)+    data (:+:$) (k :: TyFun Foo (TyFun Foo Foo -> *))+    type instance Apply (:+:$$ a) a = :+: a a+    type instance Apply :+:$ a = :+:$$ a     type family Child (a :: Foo) :: Foo+    type instance Child FLeaf = FLeafSym0+    type instance Child (:+: a z) = a+    data ChildSym0 (k :: TyFun Foo Foo)+    type instance Apply ChildSym0 a = Child a     type family (:+) (a :: Nat) (a :: Nat) :: Nat+    type instance (:+) Zero m = m+    type instance (:+) (Succ n) m =+        Apply SuccSym0 (Apply (Apply :+$ n) m)+    data (:+$$) (l :: Nat) (l :: TyFun Nat Nat)+    data (:+$) (k :: TyFun Nat (TyFun Nat Nat -> *))+    type instance Apply (:+$$ a) a = :+ a a+    type instance Apply :+$ a = :+$$ a     data instance Sing (z :: Foo)       = z ~ FLeaf => SFLeaf |         forall (n :: Foo) (n :: Foo). z ~ :+: n n =>@@ -38,7 +52,7 @@       toSing FLeaf = SomeSing SFLeaf       toSing (:+: b b)         = case-              (toSing b :: SomeSing (KProxy :: KProxy Foo),+              (toSing b :: SomeSing (KProxy :: KProxy Foo),                 toSing b :: SomeSing (KProxy :: KProxy Foo))           of {             (SomeSing c, SomeSing c) -> SomeSing ((:%+:) c c) }
tests/compile-and-dump/Singletons/Operators.ghc78.template view
@@ -6,7 +6,7 @@           (+) :: Nat -> Nat -> Nat           Zero + m = m           (Succ n) + m = Succ (n + m)-+                     data Foo             where               FLeaf :: Foo@@ -20,15 +20,89 @@     (+) :: 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 FLeafSym0 = FLeaf+    type (:+:$$$) (t :: Foo) (t :: Foo) = (:+:) t t+    instance SuppressUnusedWarnings (:+:$$) where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) (:+:$$###) GHC.Tuple.())+    data (:+:$$) (l :: Foo) (l :: TyFun Foo Foo)+      = forall arg. (GHC.Types.~) (KindOf (Apply ((:+:$$) l) arg)) (KindOf ((:+:$$$) l arg)) =>+        (:+:$$###)+    type instance Apply ((:+:$$) l) l = (:+:$$$) l l+    instance SuppressUnusedWarnings (:+:$) where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) (:+:$###) GHC.Tuple.())+    data (:+:$) (l :: TyFun Foo (TyFun Foo Foo -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply (:+:$) arg)) (KindOf ((:+:$$) arg)) =>+        (:+:$###)+    type instance Apply (:+:$) l = (:+:$$) l+    type (:+$$$) (t :: Nat) (t :: Nat) = (:+) t t+    instance SuppressUnusedWarnings (:+$$) where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) (:+$$###) GHC.Tuple.())+    data (:+$$) (l :: Nat) (l :: TyFun Nat Nat)+      = forall arg. (GHC.Types.~) (KindOf (Apply ((:+$$) l) arg)) (KindOf ((:+$$$) l arg)) =>+        (:+$$###)+    type instance Apply ((:+$$) l) l = (:+$$$) l l+    instance SuppressUnusedWarnings (:+$) where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) (:+$###) GHC.Tuple.())+    data (:+$) (l :: TyFun Nat (TyFun Nat Nat -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply (:+$) arg)) (KindOf ((:+$$) arg)) =>+        (:+$###)+    type instance Apply (:+$) l = (:+$$) l+    type ChildSym1 (t :: Foo) = Child t+    instance SuppressUnusedWarnings ChildSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) ChildSym0KindInference GHC.Tuple.())+    data ChildSym0 (l :: TyFun Foo Foo)+      = forall arg. (GHC.Types.~) (KindOf (Apply ChildSym0 arg)) (KindOf (ChildSym1 arg)) =>+        ChildSym0KindInference+    type instance Apply ChildSym0 l = ChildSym1 l     type family (:+) (a :: Nat) (a :: Nat) :: Nat where       (:+) Zero m = m-      (:+) (Succ n) m = Succ ((:+) n m)+      (:+) (Succ n) m = Apply SuccSym0 (Apply (Apply (:+$) n) m)+    type family Child (a :: Foo) :: Foo where+      Child FLeaf = FLeafSym0+      Child ((:+:) a z) = a+    (%:+) ::+      forall (t :: Nat) (t :: Nat).+      Sing t -> Sing t -> Sing (Apply (Apply (:+$) t) t)+    sChild :: forall (t :: Foo). Sing t -> Sing (Apply ChildSym0 t)+    (%:+) SZero sM+      = let+          lambda ::+            forall m. ((GHC.Types.~) t ZeroSym0, (GHC.Types.~) t m) =>+            Sing m -> Sing (Apply (Apply (:+$) ZeroSym0) m)+          lambda m = m+        in lambda sM+    (%:+) (SSucc sN) sM+      = let+          lambda ::+            forall n m. ((GHC.Types.~) t (Apply SuccSym0 n),+                         (GHC.Types.~) t m) =>+            Sing n -> Sing m -> Sing (Apply (Apply (:+$) (Apply SuccSym0 n)) m)+          lambda n m+            = applySing+                (singFun1 (Proxy :: Proxy SuccSym0) SSucc)+                (applySing (applySing (singFun2 (Proxy :: Proxy (:+$)) (%:+)) n) m)+        in lambda sN sM+    sChild SFLeaf+      = let+          lambda ::+            (GHC.Types.~) t FLeafSym0 => Sing (Apply ChildSym0 FLeafSym0)+          lambda = SFLeaf+        in lambda+    sChild ((:%+:) sA _)+      = let+          lambda ::+            forall a wild. (GHC.Types.~) t (Apply (Apply (:+:$) a) wild) =>+            Sing a -> Sing (Apply ChildSym0 (Apply (Apply (:+:$) a) wild))+          lambda a = a+        in lambda sA     data instance Sing (z :: Foo)-      = z ~ FLeaf => SFLeaf |-        forall (n :: Foo) (n :: Foo). z ~ (:+:) n n =>+      = (GHC.Types.~) z FLeaf => SFLeaf |+        forall (n :: Foo) (n :: Foo). (GHC.Types.~) z ((:+:) n n) =>         (:%+:) (Sing n) (Sing n)     type SFoo (z :: Foo) = Sing z     instance SingKind (KProxy :: KProxy Foo) where@@ -38,19 +112,13 @@       toSing FLeaf = SomeSing SFLeaf       toSing ((:+:) b b)         = case-              (toSing b :: SomeSing (KProxy :: KProxy Foo),-               toSing b :: SomeSing (KProxy :: KProxy Foo))+              GHC.Tuple.(,)+                (toSing b :: SomeSing (KProxy :: KProxy Foo))+                (toSing b :: SomeSing (KProxy :: KProxy Foo))           of {-            (SomeSing c, SomeSing c) -> SomeSing ((:%+:) c c) }+            GHC.Tuple.(,) (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 view
@@ -1,7 +1,12 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+ module Singletons.Operators where +import Data.Proxy+import Data.Singletons import Data.Singletons.TH import Singletons.Nat+import Data.Singletons.SuppressUnusedWarnings  $(singletons [d|   data Foo where
+ tests/compile-and-dump/Singletons/PatternMatching.ghc76.template view
@@ -0,0 +1,131 @@+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 PairTyCtor = Pair+    data PairTyCtorSym1 (l :: *) (l :: TyFun * *)+    data PairTyCtorSym0 (k :: TyFun * (TyFun * * -> *))+    type instance Apply (PairTyCtorSym1 a) a = PairTyCtor a a+    type instance Apply PairTyCtorSym0 a = PairTyCtorSym1 a+    data PairSym1 (l :: a) (l :: TyFun b (Pair a b))+    data PairSym0 (k :: TyFun a (TyFun b (Pair a b) -> *))+    type instance Apply (PairSym1 a) a = Pair a a+    type instance Apply PairSym0 a = PairSym1 a+    type Pr =+        Apply (Apply PairSym0 (Apply SuccSym0 ZeroSym0)) '[ZeroSym0]+    type PrSym0 = Pr+    type Complex =+        Apply (Apply PairSym0 (Apply (Apply PairSym0 (Apply JustSym0 ZeroSym0)) ZeroSym0)) FalseSym0+    type ComplexSym0 = Complex+    type Tuple = '(FalseSym0, Apply JustSym0 ZeroSym0, TrueSym0)+    type TupleSym0 = Tuple+    type AList =+        '[ZeroSym0,+          Apply SuccSym0 ZeroSym0,+          Apply SuccSym0 (Apply SuccSym0 ZeroSym0)]+    type AListSym0 = AList+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+          foo1 :: (a, b) -> a+          foo1 (x, y) = (\ _ -> x) y+          foo2 :: (# a, b #) -> a+          foo2 t@(# x, y #) = case t of { (# a, b #) -> (\ _ -> a) b } |]+  ======>+    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+    foo1 :: forall a b. (a, b) -> a+    foo1 (x, y) = \ _ -> x y+    foo2 :: forall a b. (# a, b #) -> a+    foo2 t@(# x, y #) = case t of { (# a, b #) -> \ _ -> a b }+    type Sz = Extract_0123456789 PrSym0+    type SzSym0 = Sz+    type Lz = Extract_0123456789 PrSym0+    type LzSym0 = Lz+    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 ComplexSym0)+    type JzSym0 = Jz+    type Zz = Extract_0123456789 (Extract_0123456789 ComplexSym0)+    type ZzSym0 = Zz+    type Fls = Extract_0123456789 ComplexSym0+    type FlsSym0 = Fls+    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 TupleSym0+    type TfSym0 = Tf+    type Tjz = Extract_0123456789 TupleSym0+    type TjzSym0 = Tjz+    type Tt = Extract_0123456789 TupleSym0+    type TtSym0 = Tt+    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 AListSym0)+    type LszSym0 = Lsz+    type Blimy = Extract_0123456789 (Head (Tail (Tail AListSym0)))+    type BlimySym0 = Blimy+    type family Extract_0123456789 (a :: Nat) :: Nat+    type instance Extract_0123456789 (Succ a) = a+    type family Lambda_0123456789 (x :: x) (y :: y) (t :: k) :: r+    type instance Lambda_0123456789 x y z = x+    data Lambda_0123456789Sym2 (l :: x) (l :: y) (l :: TyFun k r)+    type instance Apply (Lambda_0123456789Sym2 a a) a =+        Lambda_0123456789 a a a+    type family Lambda_0123456789 (x :: x)+                                  (y :: y)+                                  (a :: a)+                                  (b :: b)+                                  (t :: k) :: r+    type instance Lambda_0123456789 x y a b z = a+    data Lambda_0123456789Sym4 (l :: x)+                               (l :: y)+                               (l :: a)+                               (l :: b)+                               (l :: TyFun k r)+    type instance Apply (Lambda_0123456789Sym4 a a a a) a =+        Lambda_0123456789 a a a a a+    type family Case_0123456789 (t :: k) (x :: x) (y :: y) :: r+    type instance Case_0123456789 '(a, b) x y =+        Apply (Lambda_0123456789Sym4 x y a b) b+    type family Foo1 (a :: (a, b)) :: a+    type instance Foo1 '(x, y) = Apply (Lambda_0123456789Sym2 x y) y+    data Foo1Sym0 (k :: TyFun (a, b) a)+    type instance Apply Foo1Sym0 a = Foo1 a+    type family Foo2 (a :: (a, b)) :: a+    type instance Foo2 '(x, y) =+        Case_0123456789 (Apply (Apply Tuple2Sym0 x) y) x y+    data Foo2Sym0 (k :: TyFun (a, b) a)+    type instance Apply Foo2Sym0 a = Foo2 a
+ tests/compile-and-dump/Singletons/PatternMatching.ghc78.template view
@@ -0,0 +1,508 @@+Singletons/PatternMatching.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/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 PairSym2 (t :: a) (t :: b) = Pair t t+    instance SuppressUnusedWarnings PairSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) PairSym1KindInference GHC.Tuple.())+    data PairSym1 (l :: a) (l :: TyFun b (Pair a b))+      = forall arg. (GHC.Types.~) (KindOf (Apply (PairSym1 l) arg)) (KindOf (PairSym2 l arg)) =>+        PairSym1KindInference+    type instance Apply (PairSym1 l) l = PairSym2 l l+    instance SuppressUnusedWarnings PairSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) PairSym0KindInference GHC.Tuple.())+    data PairSym0 (l :: TyFun a (TyFun b (Pair a b) -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply PairSym0 arg)) (KindOf (PairSym1 arg)) =>+        PairSym0KindInference+    type instance Apply PairSym0 l = PairSym1 l+    type AListSym0 = AList+    type TupleSym0 = Tuple+    type ComplexSym0 = Complex+    type PrSym0 = Pr+    type AList =+        Apply (Apply (:$) ZeroSym0) (Apply (Apply (:$) (Apply SuccSym0 ZeroSym0)) (Apply (Apply (:$) (Apply SuccSym0 (Apply SuccSym0 ZeroSym0))) GHC.Types.[]))+    type Tuple =+        Apply (Apply (Apply Tuple3Sym0 FalseSym0) (Apply JustSym0 ZeroSym0)) TrueSym0+    type Complex =+        Apply (Apply PairSym0 (Apply (Apply PairSym0 (Apply JustSym0 ZeroSym0)) ZeroSym0)) FalseSym0+    type Pr =+        Apply (Apply PairSym0 (Apply SuccSym0 ZeroSym0)) (Apply (Apply (:$) ZeroSym0) GHC.Types.[])+    sAList :: Sing AListSym0+    sTuple :: Sing TupleSym0+    sComplex :: Sing ComplexSym0+    sPr :: Sing PrSym0+    sAList+      = applySing+          (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) SZero)+          (applySing+             (applySing+                (singFun2 (Proxy :: Proxy (:$)) SCons)+                (applySing (singFun1 (Proxy :: Proxy SuccSym0) SSucc) SZero))+             (applySing+                (applySing+                   (singFun2 (Proxy :: Proxy (:$)) SCons)+                   (applySing+                      (singFun1 (Proxy :: Proxy SuccSym0) SSucc)+                      (applySing (singFun1 (Proxy :: Proxy SuccSym0) SSucc) SZero)))+                SNil))+    sTuple+      = applySing+          (applySing+             (applySing (singFun3 (Proxy :: Proxy Tuple3Sym0) STuple3) SFalse)+             (applySing (singFun1 (Proxy :: Proxy JustSym0) SJust) SZero))+          STrue+    sComplex+      = applySing+          (applySing+             (singFun2 (Proxy :: Proxy PairSym0) SPair)+             (applySing+                (applySing+                   (singFun2 (Proxy :: Proxy PairSym0) SPair)+                   (applySing (singFun1 (Proxy :: Proxy JustSym0) SJust) SZero))+                SZero))+          SFalse+    sPr+      = applySing+          (applySing+             (singFun2 (Proxy :: Proxy PairSym0) SPair)+             (applySing (singFun1 (Proxy :: Proxy SuccSym0) SSucc) SZero))+          (applySing+             (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) SZero) SNil)+    data instance Sing (z :: Pair a b)+      = forall (n :: a) (n :: b). (GHC.Types.~) 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+              GHC.Tuple.(,)+                (toSing b :: SomeSing (KProxy :: KProxy a))+                (toSing b :: SomeSing (KProxy :: KProxy b))+          of {+            GHC.Tuple.(,) (SomeSing c) (SomeSing c) -> SomeSing (SPair c c) }+    instance (SingI n, SingI n) => SingI (Pair (n :: a) (n :: b)) where+      sing = SPair sing sing+Singletons/PatternMatching.hs:0:0: Splicing declarations+    singletons+      [d| Pair sz lz = pr+          Pair (Pair jz zz) fls = complex+          (tf, tjz, tt) = tuple+          [_, lsz, (Succ blimy)] = aList+          lsz :: Nat+          fls :: Bool+          foo1 :: (a, b) -> a+          foo1 (x, y) = (\ _ -> x) y+          foo2 :: (# a, b #) -> a+          foo2 t@(# x, y #) = case t of { (# a, b #) -> (\ _ -> a) b } |]+  ======>+    Singletons/PatternMatching.hs:(0,0)-(0,0)+    Pair sz lz = pr+    Pair (Pair jz zz) fls = complex+    (tf, tjz, tt) = tuple+    [_, lsz, Succ blimy] = aList+    lsz :: Nat+    fls :: Bool+    foo1 :: forall a b. (a, b) -> a+    foo1 (x, y) = \ _ -> x y+    foo2 :: forall a b. (# a, b #) -> a+    foo2 t@(# x, y #) = case t of { (# a, b #) -> \ _ -> a b }+    type Let_0123456789TSym2 t t = Let_0123456789T t t+    instance SuppressUnusedWarnings Let_0123456789TSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Let_0123456789TSym1KindInference GHC.Tuple.())+    data Let_0123456789TSym1 l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Let_0123456789TSym1 l) arg)) (KindOf (Let_0123456789TSym2 l arg)) =>+        Let_0123456789TSym1KindInference+    type instance Apply (Let_0123456789TSym1 l) l = Let_0123456789TSym2 l l+    instance SuppressUnusedWarnings Let_0123456789TSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Let_0123456789TSym0KindInference GHC.Tuple.())+    data Let_0123456789TSym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Let_0123456789TSym0 arg)) (KindOf (Let_0123456789TSym1 arg)) =>+        Let_0123456789TSym0KindInference+    type instance Apply Let_0123456789TSym0 l = Let_0123456789TSym1 l+    type Let_0123456789T x y = Apply (Apply Tuple2Sym0 x) y+    type Let_0123456789Scrutinee_0123456789Sym2 t t =+        Let_0123456789Scrutinee_0123456789 t t+    instance SuppressUnusedWarnings Let_0123456789Scrutinee_0123456789Sym1 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,)+               Let_0123456789Scrutinee_0123456789Sym1KindInference GHC.Tuple.())+    data Let_0123456789Scrutinee_0123456789Sym1 l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Let_0123456789Scrutinee_0123456789Sym1 l) arg)) (KindOf (Let_0123456789Scrutinee_0123456789Sym2 l arg)) =>+        Let_0123456789Scrutinee_0123456789Sym1KindInference+    type instance Apply (Let_0123456789Scrutinee_0123456789Sym1 l) l = Let_0123456789Scrutinee_0123456789Sym2 l l+    instance SuppressUnusedWarnings Let_0123456789Scrutinee_0123456789Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,)+               Let_0123456789Scrutinee_0123456789Sym0KindInference GHC.Tuple.())+    data Let_0123456789Scrutinee_0123456789Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Let_0123456789Scrutinee_0123456789Sym0 arg)) (KindOf (Let_0123456789Scrutinee_0123456789Sym1 arg)) =>+        Let_0123456789Scrutinee_0123456789Sym0KindInference+    type instance Apply Let_0123456789Scrutinee_0123456789Sym0 l = Let_0123456789Scrutinee_0123456789Sym1 l+    type Let_0123456789Scrutinee_0123456789 x y =+        Let_0123456789TSym2 x y+    type family Case_0123456789 x y a b arg_0123456789 t where+      Case_0123456789 x y a b arg_0123456789 z = a+    type family Lambda_0123456789 x y a b t where+      Lambda_0123456789 x y a b arg_0123456789 = Case_0123456789 x y a b arg_0123456789 arg_0123456789+    type Lambda_0123456789Sym5 t t t t t = Lambda_0123456789 t t t t t+    instance SuppressUnusedWarnings Lambda_0123456789Sym4 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym4KindInference GHC.Tuple.())+    data Lambda_0123456789Sym4 l l l l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym4 l l l l) arg)) (KindOf (Lambda_0123456789Sym5 l l l l arg)) =>+        Lambda_0123456789Sym4KindInference+    type instance Apply (Lambda_0123456789Sym4 l l l l) l = Lambda_0123456789Sym5 l l l l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym3 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym3KindInference GHC.Tuple.())+    data Lambda_0123456789Sym3 l l l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym3 l l l) arg)) (KindOf (Lambda_0123456789Sym4 l l l arg)) =>+        Lambda_0123456789Sym3KindInference+    type instance Apply (Lambda_0123456789Sym3 l l l) l = Lambda_0123456789Sym4 l l l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym2 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym2KindInference GHC.Tuple.())+    data Lambda_0123456789Sym2 l l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym2 l l) arg)) (KindOf (Lambda_0123456789Sym3 l l arg)) =>+        Lambda_0123456789Sym2KindInference+    type instance Apply (Lambda_0123456789Sym2 l l) l = Lambda_0123456789Sym3 l l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym1 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym1KindInference GHC.Tuple.())+    data Lambda_0123456789Sym1 l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym1 l) arg)) (KindOf (Lambda_0123456789Sym2 l arg)) =>+        Lambda_0123456789Sym1KindInference+    type instance Apply (Lambda_0123456789Sym1 l) l = Lambda_0123456789Sym2 l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym0KindInference GHC.Tuple.())+    data Lambda_0123456789Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Lambda_0123456789Sym0 arg)) (KindOf (Lambda_0123456789Sym1 arg)) =>+        Lambda_0123456789Sym0KindInference+    type instance Apply Lambda_0123456789Sym0 l = Lambda_0123456789Sym1 l+    type family Case_0123456789 x y t where+      Case_0123456789 x y (GHC.Tuple.(,) a b) = Apply (Apply (Apply (Apply (Apply Lambda_0123456789Sym0 x) y) a) b) b+    type family Case_0123456789 x y arg_0123456789 t where+      Case_0123456789 x y arg_0123456789 z = x+    type family Lambda_0123456789 x y t where+      Lambda_0123456789 x y arg_0123456789 = Case_0123456789 x y arg_0123456789 arg_0123456789+    type Lambda_0123456789Sym3 t t t = Lambda_0123456789 t t t+    instance SuppressUnusedWarnings Lambda_0123456789Sym2 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym2KindInference GHC.Tuple.())+    data Lambda_0123456789Sym2 l l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym2 l l) arg)) (KindOf (Lambda_0123456789Sym3 l l arg)) =>+        Lambda_0123456789Sym2KindInference+    type instance Apply (Lambda_0123456789Sym2 l l) l = Lambda_0123456789Sym3 l l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym1 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym1KindInference GHC.Tuple.())+    data Lambda_0123456789Sym1 l l+      = forall arg. (GHC.Types.~) (KindOf (Apply (Lambda_0123456789Sym1 l) arg)) (KindOf (Lambda_0123456789Sym2 l arg)) =>+        Lambda_0123456789Sym1KindInference+    type instance Apply (Lambda_0123456789Sym1 l) l = Lambda_0123456789Sym2 l l+    instance SuppressUnusedWarnings Lambda_0123456789Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym0KindInference GHC.Tuple.())+    data Lambda_0123456789Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Lambda_0123456789Sym0 arg)) (KindOf (Lambda_0123456789Sym1 arg)) =>+        Lambda_0123456789Sym0KindInference+    type instance Apply Lambda_0123456789Sym0 l = Lambda_0123456789Sym1 l+    type family Case_0123456789 t where+      Case_0123456789 ((GHC.Types.:) z ((GHC.Types.:) y_0123456789 ((GHC.Types.:) (Succ z) GHC.Types.[]))) = y_0123456789+    type family Case_0123456789 t where+      Case_0123456789 ((GHC.Types.:) z ((GHC.Types.:) z ((GHC.Types.:) (Succ y_0123456789) GHC.Types.[]))) = y_0123456789+    type family Case_0123456789 t where+      Case_0123456789 (GHC.Tuple.(,,) y_0123456789 z z) = y_0123456789+    type family Case_0123456789 t where+      Case_0123456789 (GHC.Tuple.(,,) z y_0123456789 z) = y_0123456789+    type family Case_0123456789 t where+      Case_0123456789 (GHC.Tuple.(,,) z z y_0123456789) = y_0123456789+    type family Case_0123456789 t where+      Case_0123456789 (Pair (Pair y_0123456789 z) z) = y_0123456789+    type family Case_0123456789 t where+      Case_0123456789 (Pair (Pair z y_0123456789) z) = y_0123456789+    type family Case_0123456789 t where+      Case_0123456789 (Pair (Pair z z) y_0123456789) = y_0123456789+    type family Case_0123456789 t where+      Case_0123456789 (Pair y_0123456789 z) = y_0123456789+    type family Case_0123456789 t where+      Case_0123456789 (Pair z y_0123456789) = y_0123456789+    type Foo2Sym1 (t :: GHC.Tuple.(,) a b) = Foo2 t+    instance SuppressUnusedWarnings Foo2Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo2Sym0KindInference GHC.Tuple.())+    data Foo2Sym0 (l :: TyFun (GHC.Tuple.(,) a b) a)+      = forall arg. (GHC.Types.~) (KindOf (Apply Foo2Sym0 arg)) (KindOf (Foo2Sym1 arg)) =>+        Foo2Sym0KindInference+    type instance Apply Foo2Sym0 l = Foo2Sym1 l+    type Foo1Sym1 (t :: GHC.Tuple.(,) a b) = Foo1 t+    instance SuppressUnusedWarnings Foo1Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Foo1Sym0KindInference GHC.Tuple.())+    data Foo1Sym0 (l :: TyFun (GHC.Tuple.(,) a b) a)+      = forall arg. (GHC.Types.~) (KindOf (Apply Foo1Sym0 arg)) (KindOf (Foo1Sym1 arg)) =>+        Foo1Sym0KindInference+    type instance Apply Foo1Sym0 l = Foo1Sym1 l+    type LszSym0 = Lsz+    type BlimySym0 = Blimy+    type TfSym0 = Tf+    type TjzSym0 = Tjz+    type TtSym0 = Tt+    type JzSym0 = Jz+    type ZzSym0 = Zz+    type FlsSym0 = Fls+    type SzSym0 = Sz+    type LzSym0 = Lz+    type X_0123456789Sym0 = X_0123456789+    type X_0123456789Sym0 = X_0123456789+    type X_0123456789Sym0 = X_0123456789+    type X_0123456789Sym0 = X_0123456789+    type family Foo2 (a :: GHC.Tuple.(,) a b) :: a where+      Foo2 (GHC.Tuple.(,) x y) = Case_0123456789 x y (Let_0123456789Scrutinee_0123456789Sym2 x y)+    type family Foo1 (a :: GHC.Tuple.(,) a b) :: a where+      Foo1 (GHC.Tuple.(,) x y) = Apply (Apply (Apply Lambda_0123456789Sym0 x) y) y+    type Lsz = (Case_0123456789 X_0123456789Sym0 :: Nat)+    type Blimy = Case_0123456789 X_0123456789Sym0+    type Tf = Case_0123456789 X_0123456789Sym0+    type Tjz = Case_0123456789 X_0123456789Sym0+    type Tt = Case_0123456789 X_0123456789Sym0+    type Jz = Case_0123456789 X_0123456789Sym0+    type Zz = Case_0123456789 X_0123456789Sym0+    type Fls = (Case_0123456789 X_0123456789Sym0 :: Bool)+    type Sz = Case_0123456789 X_0123456789Sym0+    type Lz = Case_0123456789 X_0123456789Sym0+    type X_0123456789 = PrSym0+    type X_0123456789 = ComplexSym0+    type X_0123456789 = TupleSym0+    type X_0123456789 = AListSym0+    sFoo2 ::+      forall (t :: GHC.Tuple.(,) a b). Sing t -> Sing (Apply Foo2Sym0 t)+    sFoo1 ::+      forall (t :: GHC.Tuple.(,) a b). Sing t -> Sing (Apply Foo1Sym0 t)+    sLsz :: Sing LszSym0+    sBlimy :: Sing BlimySym0+    sTf :: Sing TfSym0+    sTjz :: Sing TjzSym0+    sTt :: Sing TtSym0+    sJz :: Sing JzSym0+    sZz :: Sing ZzSym0+    sFls :: Sing FlsSym0+    sSz :: Sing SzSym0+    sLz :: Sing LzSym0+    sX_0123456789 :: Sing X_0123456789Sym0+    sX_0123456789 :: Sing X_0123456789Sym0+    sX_0123456789 :: Sing X_0123456789Sym0+    sX_0123456789 :: Sing X_0123456789Sym0+    sFoo2 (STuple2 sX sY)+      = let+          lambda ::+            forall x y. (GHC.Types.~) t (Apply (Apply Tuple2Sym0 x) y) =>+            Sing x+            -> Sing y -> Sing (Apply Foo2Sym0 (Apply (Apply Tuple2Sym0 x) y))+          lambda x y+            = let+                sT :: Sing (Let_0123456789TSym2 x y)+                sT+                  = applySing+                      (applySing (singFun2 (Proxy :: Proxy Tuple2Sym0) STuple2) x) y in+              let+                sScrutinee_0123456789 ::+                  Sing (Let_0123456789Scrutinee_0123456789Sym2 x y)+                sScrutinee_0123456789 = sT+              in+                case sScrutinee_0123456789 of {+                  STuple2 sA sB+                    -> let+                         lambda ::+                           forall a b.+                           Sing a+                           -> Sing b+                              -> Sing (Case_0123456789 x y (Apply (Apply Tuple2Sym0 a) b))+                         lambda a b+                           = applySing+                               (singFun1+                                  (Proxy ::+                                     Proxy (Apply (Apply (Apply (Apply Lambda_0123456789Sym0 x) y) a) b))+                                  (\ sArg_0123456789+                                     -> let+                                          lambda ::+                                            forall arg_0123456789.+                                            Sing arg_0123456789+                                            -> Sing (Apply (Apply (Apply (Apply (Apply Lambda_0123456789Sym0 x) y) a) b) arg_0123456789)+                                          lambda arg_0123456789+                                            = case arg_0123456789 of {+                                                _ -> let+                                                       lambda ::+                                                         forall wild.+                                                         Sing (Case_0123456789 x y a b arg_0123456789 wild)+                                                       lambda = a+                                                     in lambda }+                                        in lambda sArg_0123456789))+                               b+                       in lambda sA sB }+        in lambda sX sY+    sFoo1 (STuple2 sX sY)+      = let+          lambda ::+            forall x y. (GHC.Types.~) t (Apply (Apply Tuple2Sym0 x) y) =>+            Sing x+            -> Sing y -> Sing (Apply Foo1Sym0 (Apply (Apply Tuple2Sym0 x) y))+          lambda x y+            = applySing+                (singFun1+                   (Proxy :: Proxy (Apply (Apply Lambda_0123456789Sym0 x) y))+                   (\ sArg_0123456789+                      -> let+                           lambda ::+                             forall arg_0123456789.+                             Sing arg_0123456789+                             -> Sing (Apply (Apply (Apply Lambda_0123456789Sym0 x) y) arg_0123456789)+                           lambda arg_0123456789+                             = case arg_0123456789 of {+                                 _ -> let+                                        lambda ::+                                          forall wild.+                                          Sing (Case_0123456789 x y arg_0123456789 wild)+                                        lambda = x+                                      in lambda }+                         in lambda sArg_0123456789))+                y+        in lambda sX sY+    sLsz+      = case sX_0123456789 of {+          SCons _ (SCons sY_0123456789 (SCons (SSucc _) SNil))+            -> let+                 lambda ::+                   forall y_0123456789 wild wild.+                   Sing y_0123456789+                   -> Sing (Case_0123456789 (Apply (Apply (:$) wild) (Apply (Apply (:$) y_0123456789) (Apply (Apply (:$) (Apply SuccSym0 wild)) GHC.Types.[]))))+                 lambda y_0123456789 = y_0123456789+               in lambda sY_0123456789 }+    sBlimy+      = case sX_0123456789 of {+          SCons _ (SCons _ (SCons (SSucc sY_0123456789) SNil))+            -> let+                 lambda ::+                   forall y_0123456789 wild wild.+                   Sing y_0123456789+                   -> Sing (Case_0123456789 (Apply (Apply (:$) wild) (Apply (Apply (:$) wild) (Apply (Apply (:$) (Apply SuccSym0 y_0123456789)) GHC.Types.[]))))+                 lambda y_0123456789 = y_0123456789+               in lambda sY_0123456789 }+    sTf+      = case sX_0123456789 of {+          STuple3 sY_0123456789 _ _+            -> let+                 lambda ::+                   forall y_0123456789 wild wild.+                   Sing y_0123456789+                   -> Sing (Case_0123456789 (Apply (Apply (Apply Tuple3Sym0 y_0123456789) wild) wild))+                 lambda y_0123456789 = y_0123456789+               in lambda sY_0123456789 }+    sTjz+      = case sX_0123456789 of {+          STuple3 _ sY_0123456789 _+            -> let+                 lambda ::+                   forall y_0123456789 wild wild.+                   Sing y_0123456789+                   -> Sing (Case_0123456789 (Apply (Apply (Apply Tuple3Sym0 wild) y_0123456789) wild))+                 lambda y_0123456789 = y_0123456789+               in lambda sY_0123456789 }+    sTt+      = case sX_0123456789 of {+          STuple3 _ _ sY_0123456789+            -> let+                 lambda ::+                   forall y_0123456789 wild wild.+                   Sing y_0123456789+                   -> Sing (Case_0123456789 (Apply (Apply (Apply Tuple3Sym0 wild) wild) y_0123456789))+                 lambda y_0123456789 = y_0123456789+               in lambda sY_0123456789 }+    sJz+      = case sX_0123456789 of {+          SPair (SPair sY_0123456789 _) _+            -> let+                 lambda ::+                   forall y_0123456789 wild wild.+                   Sing y_0123456789+                   -> Sing (Case_0123456789 (Apply (Apply PairSym0 (Apply (Apply PairSym0 y_0123456789) wild)) wild))+                 lambda y_0123456789 = y_0123456789+               in lambda sY_0123456789 }+    sZz+      = case sX_0123456789 of {+          SPair (SPair _ sY_0123456789) _+            -> let+                 lambda ::+                   forall y_0123456789 wild wild.+                   Sing y_0123456789+                   -> Sing (Case_0123456789 (Apply (Apply PairSym0 (Apply (Apply PairSym0 wild) y_0123456789)) wild))+                 lambda y_0123456789 = y_0123456789+               in lambda sY_0123456789 }+    sFls+      = case sX_0123456789 of {+          SPair (SPair _ _) sY_0123456789+            -> let+                 lambda ::+                   forall y_0123456789 wild wild.+                   Sing y_0123456789+                   -> Sing (Case_0123456789 (Apply (Apply PairSym0 (Apply (Apply PairSym0 wild) wild)) y_0123456789))+                 lambda y_0123456789 = y_0123456789+               in lambda sY_0123456789 }+    sSz+      = case sX_0123456789 of {+          SPair sY_0123456789 _+            -> let+                 lambda ::+                   forall y_0123456789 wild.+                   Sing y_0123456789+                   -> Sing (Case_0123456789 (Apply (Apply PairSym0 y_0123456789) wild))+                 lambda y_0123456789 = y_0123456789+               in lambda sY_0123456789 }+    sLz+      = case sX_0123456789 of {+          SPair _ sY_0123456789+            -> let+                 lambda ::+                   forall y_0123456789 wild.+                   Sing y_0123456789+                   -> Sing (Case_0123456789 (Apply (Apply PairSym0 wild) y_0123456789))+                 lambda y_0123456789 = y_0123456789+               in lambda sY_0123456789 }+    sX_0123456789 = sPr+    sX_0123456789 = sComplex+    sX_0123456789 = sTuple+    sX_0123456789 = sAList
+ tests/compile-and-dump/Singletons/PatternMatching.hs view
@@ -0,0 +1,50 @@+{-# OPTIONS_GHC -fno-warn-unused-matches #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}++module Singletons.PatternMatching where++import Data.Singletons.Prelude+import Data.Singletons.TH+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)]+ |])++$(singletons [d|+  Pair sz lz = pr+  Pair (Pair jz zz) fls = complex+  (tf, tjz, tt) = tuple+  [_, lsz, (Succ blimy)] = aList+  lsz :: Nat+  fls :: Bool+#if __GLASGOW_HASKELL__ < 707+  blimy :: Nat   -- this is necessary to promote nested patterns+#endif++  foo1 :: (a, b) -> a+  foo1 (x, y) = (\_ -> x) y++  foo2 :: (# a, b #) -> a+  foo2 t@(# x, y #) = case t of+                        (# a, b #) -> (\_ -> a) b+  |])++test1 :: Proxy (Foo1 '(Int, Char)) -> Proxy Int+test1 = id++test2 :: Proxy (Foo2 '(Int, Char)) -> Proxy Int+test2 = id++test3 :: Proxy Lsz -> Proxy (Succ Zero)+test3 = id++test4 :: Proxy Blimy -> Proxy (Succ Zero)+test4 = id++test5 :: Proxy Fls -> Proxy False+test5 = id
+ tests/compile-and-dump/Singletons/Records.ghc78.template view
@@ -0,0 +1,60 @@+Singletons/Records.hs:0:0: Splicing declarations+    singletons+      [d| data Record a = MkRecord {field1 :: a, field2 :: Bool} |]+  ======>+    Singletons/Records.hs:(0,0)-(0,0)+    data Record a = MkRecord {field1 :: a, field2 :: Bool}+    type Field1Sym1 (t :: Record a) = Field1 t+    instance SuppressUnusedWarnings Field1Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Field1Sym0KindInference GHC.Tuple.())+    data Field1Sym0 (l :: TyFun (Record a) a)+      = forall arg. (GHC.Types.~) (KindOf (Apply Field1Sym0 arg)) (KindOf (Field1Sym1 arg)) =>+        Field1Sym0KindInference+    type instance Apply Field1Sym0 l = Field1Sym1 l+    type Field2Sym1 (t :: Record a) = Field2 t+    instance SuppressUnusedWarnings Field2Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Field2Sym0KindInference GHC.Tuple.())+    data Field2Sym0 (l :: TyFun (Record a) Bool)+      = forall arg. (GHC.Types.~) (KindOf (Apply Field2Sym0 arg)) (KindOf (Field2Sym1 arg)) =>+        Field2Sym0KindInference+    type instance Apply Field2Sym0 l = Field2Sym1 l+    type family Field1 (a :: Record a) :: a where+      Field1 (MkRecord field z) = field+    type family Field2 (a :: Record a) :: Bool where+      Field2 (MkRecord z field) = field+    type MkRecordSym2 (t :: a) (t :: Bool) = MkRecord t t+    instance SuppressUnusedWarnings MkRecordSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) MkRecordSym1KindInference GHC.Tuple.())+    data MkRecordSym1 (l :: a) (l :: TyFun Bool (Record a))+      = forall arg. (GHC.Types.~) (KindOf (Apply (MkRecordSym1 l) arg)) (KindOf (MkRecordSym2 l arg)) =>+        MkRecordSym1KindInference+    type instance Apply (MkRecordSym1 l) l = MkRecordSym2 l l+    instance SuppressUnusedWarnings MkRecordSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) MkRecordSym0KindInference GHC.Tuple.())+    data MkRecordSym0 (l :: TyFun a (TyFun Bool (Record a) -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply MkRecordSym0 arg)) (KindOf (MkRecordSym1 arg)) =>+        MkRecordSym0KindInference+    type instance Apply MkRecordSym0 l = MkRecordSym1 l+    data instance Sing (z :: Record a)+      = forall (n :: a) (n :: Bool). (GHC.Types.~) z (MkRecord n n) =>+        SMkRecord {sField1 :: Sing n, sField2 :: Sing n}+    type SRecord (z :: Record a) = Sing z+    instance SingKind (KProxy :: KProxy a) =>+             SingKind (KProxy :: KProxy (Record a)) where+      type DemoteRep (KProxy :: KProxy (Record a)) = Record (DemoteRep (KProxy :: KProxy a))+      fromSing (SMkRecord b b) = MkRecord (fromSing b) (fromSing b)+      toSing (MkRecord b b)+        = case+              GHC.Tuple.(,)+                (toSing b :: SomeSing (KProxy :: KProxy a))+                (toSing b :: SomeSing (KProxy :: KProxy Bool))+          of {+            GHC.Tuple.(,) (SomeSing c) (SomeSing c)+              -> SomeSing (SMkRecord c c) }+    instance (SingI n, SingI n) =>+             SingI (MkRecord (n :: a) (n :: Bool)) where+      sing = SMkRecord sing sing
+ tests/compile-and-dump/Singletons/Records.hs view
@@ -0,0 +1,30 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+module Singletons.Records where++import Data.Singletons.SuppressUnusedWarnings+import Data.Singletons.TH+import Data.Singletons.Prelude++$(singletons [d|+  data Record a = MkRecord { field1 :: a+                           , field2 :: Bool }++  |])++-- This fails - see #66+-- $(singletons [d|+--  neg :: Record a -> Record a+--  neg rec@(MkRecord { field1 = _, field2 = b } ) = rec {field2 = not b}+-- |])++foo1a :: Proxy (Field2 (MkRecord 5 True))+foo1a = Proxy++foo1b :: Proxy True+foo1b = foo1a++foo2a :: Proxy (Field1 (MkRecord 5 True))+foo2a = Proxy++foo2b :: Proxy 5+foo2b = foo2a
+ tests/compile-and-dump/Singletons/ReturnFunc.ghc76.template view
+ tests/compile-and-dump/Singletons/ReturnFunc.ghc78.template view
@@ -0,0 +1,93 @@+Singletons/ReturnFunc.hs:0:0: Splicing declarations+    singletons+      [d| returnFunc :: Nat -> Nat -> Nat+          returnFunc _ = Succ+          id :: a -> a+          id x = x+          idFoo :: c -> a -> a+          idFoo _ = id |]+  ======>+    Singletons/ReturnFunc.hs:(0,0)-(0,0)+    returnFunc :: Nat -> Nat -> Nat+    returnFunc _ = Succ+    id :: forall a. a -> a+    id x = x+    idFoo :: forall c a. c -> a -> a+    idFoo _ = id+    type IdSym1 (t :: a) = Id t+    instance SuppressUnusedWarnings IdSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) IdSym0KindInference GHC.Tuple.())+    data IdSym0 (l :: TyFun a a)+      = forall arg. (GHC.Types.~) (KindOf (Apply IdSym0 arg)) (KindOf (IdSym1 arg)) =>+        IdSym0KindInference+    type instance Apply IdSym0 l = IdSym1 l+    type IdFooSym2 (t :: c) (t :: a) = IdFoo t t+    instance SuppressUnusedWarnings IdFooSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) IdFooSym1KindInference GHC.Tuple.())+    data IdFooSym1 (l :: c) (l :: TyFun a a)+      = forall arg. (GHC.Types.~) (KindOf (Apply (IdFooSym1 l) arg)) (KindOf (IdFooSym2 l arg)) =>+        IdFooSym1KindInference+    type instance Apply (IdFooSym1 l) l = IdFooSym2 l l+    instance SuppressUnusedWarnings IdFooSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) IdFooSym0KindInference GHC.Tuple.())+    data IdFooSym0 (l :: TyFun c (TyFun a a -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply IdFooSym0 arg)) (KindOf (IdFooSym1 arg)) =>+        IdFooSym0KindInference+    type instance Apply IdFooSym0 l = IdFooSym1 l+    type ReturnFuncSym2 (t :: Nat) (t :: Nat) = ReturnFunc t t+    instance SuppressUnusedWarnings ReturnFuncSym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) ReturnFuncSym1KindInference GHC.Tuple.())+    data ReturnFuncSym1 (l :: Nat) (l :: TyFun Nat Nat)+      = forall arg. (GHC.Types.~) (KindOf (Apply (ReturnFuncSym1 l) arg)) (KindOf (ReturnFuncSym2 l arg)) =>+        ReturnFuncSym1KindInference+    type instance Apply (ReturnFuncSym1 l) l = ReturnFuncSym2 l l+    instance SuppressUnusedWarnings ReturnFuncSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) ReturnFuncSym0KindInference GHC.Tuple.())+    data ReturnFuncSym0 (l :: TyFun Nat (TyFun Nat Nat -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply ReturnFuncSym0 arg)) (KindOf (ReturnFuncSym1 arg)) =>+        ReturnFuncSym0KindInference+    type instance Apply ReturnFuncSym0 l = ReturnFuncSym1 l+    type family Id (a :: a) :: a where+      Id x = x+    type family IdFoo (a :: c) (a :: a) :: a where+      IdFoo z a_0123456789 = Apply IdSym0 a_0123456789+    type family ReturnFunc (a :: Nat) (a :: Nat) :: Nat where+      ReturnFunc z a_0123456789 = Apply SuccSym0 a_0123456789+    sId :: forall (t :: a). Sing t -> Sing (Apply IdSym0 t)+    sIdFoo ::+      forall (t :: c) (t :: a).+      Sing t -> Sing t -> Sing (Apply (Apply IdFooSym0 t) t)+    sReturnFunc ::+      forall (t :: Nat) (t :: Nat).+      Sing t -> Sing t -> Sing (Apply (Apply ReturnFuncSym0 t) t)+    sId sX+      = let+          lambda ::+            forall x. (GHC.Types.~) t x => Sing x -> Sing (Apply IdSym0 x)+          lambda x = x+        in lambda sX+    sIdFoo _ sA_0123456789+      = let+          lambda ::+            forall a_0123456789 wild. ((GHC.Types.~) t wild,+                                       (GHC.Types.~) t a_0123456789) =>+            Sing a_0123456789+            -> Sing (Apply (Apply IdFooSym0 wild) a_0123456789)+          lambda a_0123456789+            = applySing (singFun1 (Proxy :: Proxy IdSym0) sId) a_0123456789+        in lambda sA_0123456789+    sReturnFunc _ sA_0123456789+      = let+          lambda ::+            forall a_0123456789 wild. ((GHC.Types.~) t wild,+                                       (GHC.Types.~) t a_0123456789) =>+            Sing a_0123456789+            -> Sing (Apply (Apply ReturnFuncSym0 wild) a_0123456789)+          lambda a_0123456789+            = applySing (singFun1 (Proxy :: Proxy SuccSym0) SSucc) a_0123456789+        in lambda sA_0123456789
+ tests/compile-and-dump/Singletons/ReturnFunc.hs view
@@ -0,0 +1,25 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}++module Singletons.ReturnFunc where++import Data.Singletons+import Data.Singletons.SuppressUnusedWarnings+import Data.Singletons.TH+import Singletons.Nat++-- tests the "num args" feature of promoteDec. The idea is that when clauses of+-- a function have less patterns than required by the type signature the+-- promoted type family should have this fact reflected in its return kind,+-- which should be turned into a series of nested TyFuns (type level functions)++$(singletons [d|+  returnFunc :: Nat -> Nat -> Nat+  returnFunc _ = Succ++  -- promotion of two functions below also depends on "num args"+  id :: a -> a+  id x = x++  idFoo :: c -> a -> a+  idFoo _ = id+  |])
+ tests/compile-and-dump/Singletons/Sections.ghc76.template view
@@ -0,0 +1,48 @@+Promote/Sections.hs:0:0: Splicing declarations+    promote+      [d| + :: Nat -> Nat -> Nat+          Zero + m = m+          (Succ n) + m = Succ (n + m)+          foo1 :: [Nat]+          foo1 = map ((Succ Zero) +) [Zero, Succ Zero]+          foo2 :: [Nat]+          foo2 = map (+ (Succ Zero)) [Zero, Succ Zero]+          foo3 :: [Nat]+          foo3 = zipWith (+) [Succ Zero, Succ Zero] [Zero, Succ Zero] |]+  ======>+    Promote/Sections.hs:(0,0)-(0,0)+    + :: Nat -> Nat -> Nat+    + Zero m = m+    + (Succ n) m = Succ (n + m)+    foo1 :: [Nat]+    foo1 = map (Succ Zero +) [Zero, Succ Zero]+    foo2 :: [Nat]+    foo2 = map (+ Succ Zero) [Zero, Succ Zero]+    foo3 :: [Nat]+    foo3 = zipWith (+) [Succ Zero, Succ Zero] [Zero, Succ Zero]+    type Foo1 =+        Apply (Apply MapSym0 (Apply :+$ (Apply SuccSym0 ZeroSym0))) '[ZeroSym0,+                                                                      Apply SuccSym0 ZeroSym0]+    type Foo1Sym0 = Foo1+    type Foo2 =+        Apply (Apply MapSym0 Lambda_0123456789Sym0) '[ZeroSym0,+                                                      Apply SuccSym0 ZeroSym0]+    type Foo2Sym0 = Foo2+    type family Lambda_0123456789 (t :: k) :: r+    type instance Lambda_0123456789 x =+        Apply (Apply :+$ x) (Apply SuccSym0 ZeroSym0)+    data Lambda_0123456789Sym0 (k :: TyFun k r)+    type instance Apply Lambda_0123456789Sym0 a = Lambda_0123456789 a+    type Foo3 =+        Apply (Apply (Apply ZipWithSym0 :+$) '[Apply SuccSym0 ZeroSym0,+                                               Apply SuccSym0 ZeroSym0]) '[ZeroSym0,+                                                                           Apply SuccSym0 ZeroSym0]+    type Foo3Sym0 = Foo3+    type family (:+) (a :: Nat) (a :: Nat) :: Nat+    type instance (:+) Zero m = m+    type instance (:+) (Succ n) m =+        Apply SuccSym0 (Apply (Apply :+$ n) m)+    data (:+$$) (l :: Nat) (l :: TyFun Nat Nat)+    data (:+$) (k :: TyFun Nat (TyFun Nat Nat -> *))+    type instance Apply (:+$$ a) a = :+ a a+    type instance Apply :+$ a = :+$$ a
+ tests/compile-and-dump/Singletons/Sections.ghc78.template view
@@ -0,0 +1,144 @@+Singletons/Sections.hs:0:0: Splicing declarations+    singletons+      [d| (+) :: Nat -> Nat -> Nat+          Zero + m = m+          (Succ n) + m = Succ (n + m)+          foo1 :: [Nat]+          foo1 = map ((Succ Zero) +) [Zero, Succ Zero]+          foo2 :: [Nat]+          foo2 = map (+ (Succ Zero)) [Zero, Succ Zero]+          foo3 :: [Nat]+          foo3 = zipWith (+) [Succ Zero, Succ Zero] [Zero, Succ Zero] |]+  ======>+    Singletons/Sections.hs:(0,0)-(0,0)+    (+) :: Nat -> Nat -> Nat+    (+) Zero m = m+    (+) (Succ n) m = Succ (n + m)+    foo1 :: [Nat]+    foo1 = map (Succ Zero +) [Zero, Succ Zero]+    foo2 :: [Nat]+    foo2 = map (+ Succ Zero) [Zero, Succ Zero]+    foo3 :: [Nat]+    foo3 = zipWith (+) [Succ Zero, Succ Zero] [Zero, Succ Zero]+    type family Lambda_0123456789 t where+      Lambda_0123456789 lhs_0123456789 = Apply (Apply (:+$) lhs_0123456789) (Apply SuccSym0 ZeroSym0)+    type Lambda_0123456789Sym1 t = Lambda_0123456789 t+    instance SuppressUnusedWarnings Lambda_0123456789Sym0 where+      suppressUnusedWarnings _+        = snd+            (GHC.Tuple.(,) Lambda_0123456789Sym0KindInference GHC.Tuple.())+    data Lambda_0123456789Sym0 l+      = forall arg. (GHC.Types.~) (KindOf (Apply Lambda_0123456789Sym0 arg)) (KindOf (Lambda_0123456789Sym1 arg)) =>+        Lambda_0123456789Sym0KindInference+    type instance Apply Lambda_0123456789Sym0 l = Lambda_0123456789Sym1 l+    type (:+$$$) (t :: Nat) (t :: Nat) = (:+) t t+    instance SuppressUnusedWarnings (:+$$) where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) (:+$$###) GHC.Tuple.())+    data (:+$$) (l :: Nat) (l :: TyFun Nat Nat)+      = forall arg. (GHC.Types.~) (KindOf (Apply ((:+$$) l) arg)) (KindOf ((:+$$$) l arg)) =>+        (:+$$###)+    type instance Apply ((:+$$) l) l = (:+$$$) l l+    instance SuppressUnusedWarnings (:+$) where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) (:+$###) GHC.Tuple.())+    data (:+$) (l :: TyFun Nat (TyFun Nat Nat -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply (:+$) arg)) (KindOf ((:+$$) arg)) =>+        (:+$###)+    type instance Apply (:+$) l = (:+$$) l+    type Foo1Sym0 = Foo1+    type Foo2Sym0 = Foo2+    type Foo3Sym0 = Foo3+    type family (:+) (a :: Nat) (a :: Nat) :: Nat where+      (:+) Zero m = m+      (:+) (Succ n) m = Apply SuccSym0 (Apply (Apply (:+$) n) m)+    type Foo1 =+        (Apply (Apply MapSym0 (Apply (:+$) (Apply SuccSym0 ZeroSym0))) (Apply (Apply (:$) ZeroSym0) (Apply (Apply (:$) (Apply SuccSym0 ZeroSym0)) GHC.Types.[])) :: GHC.Types.[] Nat)+    type Foo2 =+        (Apply (Apply MapSym0 Lambda_0123456789Sym0) (Apply (Apply (:$) ZeroSym0) (Apply (Apply (:$) (Apply SuccSym0 ZeroSym0)) GHC.Types.[])) :: GHC.Types.[] Nat)+    type Foo3 =+        (Apply (Apply (Apply ZipWithSym0 (:+$)) (Apply (Apply (:$) (Apply SuccSym0 ZeroSym0)) (Apply (Apply (:$) (Apply SuccSym0 ZeroSym0)) GHC.Types.[]))) (Apply (Apply (:$) ZeroSym0) (Apply (Apply (:$) (Apply SuccSym0 ZeroSym0)) GHC.Types.[])) :: GHC.Types.[] Nat)+    (%:+) ::+      forall (t :: Nat) (t :: Nat).+      Sing t -> Sing t -> Sing (Apply (Apply (:+$) t) t)+    sFoo1 :: Sing Foo1Sym0+    sFoo2 :: Sing Foo2Sym0+    sFoo3 :: Sing Foo3Sym0+    (%:+) SZero sM+      = let+          lambda ::+            forall m. ((GHC.Types.~) t ZeroSym0, (GHC.Types.~) t m) =>+            Sing m -> Sing (Apply (Apply (:+$) ZeroSym0) m)+          lambda m = m+        in lambda sM+    (%:+) (SSucc sN) sM+      = let+          lambda ::+            forall n m. ((GHC.Types.~) t (Apply SuccSym0 n),+                         (GHC.Types.~) t m) =>+            Sing n -> Sing m -> Sing (Apply (Apply (:+$) (Apply SuccSym0 n)) m)+          lambda n m+            = applySing+                (singFun1 (Proxy :: Proxy SuccSym0) SSucc)+                (applySing (applySing (singFun2 (Proxy :: Proxy (:+$)) (%:+)) n) m)+        in lambda sN sM+    sFoo1+      = applySing+          (applySing+             (singFun2 (Proxy :: Proxy MapSym0) sMap)+             (applySing+                (singFun2 (Proxy :: Proxy (:+$)) (%:+))+                (applySing (singFun1 (Proxy :: Proxy SuccSym0) SSucc) SZero)))+          (applySing+             (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) SZero)+             (applySing+                (applySing+                   (singFun2 (Proxy :: Proxy (:$)) SCons)+                   (applySing (singFun1 (Proxy :: Proxy SuccSym0) SSucc) SZero))+                SNil))+    sFoo2+      = applySing+          (applySing+             (singFun2 (Proxy :: Proxy MapSym0) sMap)+             (singFun1+                (Proxy :: Proxy Lambda_0123456789Sym0)+                (\ sLhs_0123456789+                   -> let+                        lambda ::+                          forall lhs_0123456789.+                          Sing lhs_0123456789+                          -> Sing (Apply Lambda_0123456789Sym0 lhs_0123456789)+                        lambda lhs_0123456789+                          = applySing+                              (applySing (singFun2 (Proxy :: Proxy (:+$)) (%:+)) lhs_0123456789)+                              (applySing (singFun1 (Proxy :: Proxy SuccSym0) SSucc) SZero)+                      in lambda sLhs_0123456789)))+          (applySing+             (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) SZero)+             (applySing+                (applySing+                   (singFun2 (Proxy :: Proxy (:$)) SCons)+                   (applySing (singFun1 (Proxy :: Proxy SuccSym0) SSucc) SZero))+                SNil))+    sFoo3+      = applySing+          (applySing+             (applySing+                (singFun3 (Proxy :: Proxy ZipWithSym0) sZipWith)+                (singFun2 (Proxy :: Proxy (:+$)) (%:+)))+             (applySing+                (applySing+                   (singFun2 (Proxy :: Proxy (:$)) SCons)+                   (applySing (singFun1 (Proxy :: Proxy SuccSym0) SSucc) SZero))+                (applySing+                   (applySing+                      (singFun2 (Proxy :: Proxy (:$)) SCons)+                      (applySing (singFun1 (Proxy :: Proxy SuccSym0) SSucc) SZero))+                   SNil)))+          (applySing+             (applySing (singFun2 (Proxy :: Proxy (:$)) SCons) SZero)+             (applySing+                (applySing+                   (singFun2 (Proxy :: Proxy (:$)) SCons)+                   (applySing (singFun1 (Proxy :: Proxy SuccSym0) SSucc) SZero))+                SNil))
+ tests/compile-and-dump/Singletons/Sections.hs view
@@ -0,0 +1,40 @@+module Singletons.Sections where++import Data.Singletons+import Data.Singletons.Prelude.List+import Data.Singletons.SuppressUnusedWarnings+import Data.Singletons.TH+import Singletons.Nat++$(singletons [d|+  (+) :: Nat -> Nat -> Nat+  Zero + m = m+  (Succ n) + m = Succ (n + m)++  foo1 :: [Nat]+  foo1 = map ((Succ Zero)+) [Zero, Succ Zero]++  foo2 :: [Nat]+  foo2 = map (+(Succ Zero)) [Zero, Succ Zero]++  foo3 :: [Nat]+  foo3 = zipWith (+) [Succ Zero, Succ Zero] [Zero, Succ Zero]+ |])++foo1a :: Proxy Foo1+foo1a = Proxy++foo1b :: Proxy [Succ Zero, Succ (Succ Zero)]+foo1b = foo1a++foo2a :: Proxy Foo2+foo2a = Proxy++foo2b :: Proxy [Succ Zero, Succ (Succ Zero)]+foo2b = foo2a++foo3a :: Proxy Foo3+foo3a = Proxy++foo3b :: Proxy [Succ Zero, Succ (Succ Zero)]+foo3b = foo3a
tests/compile-and-dump/Singletons/Star.ghc76.template view
@@ -5,30 +5,30 @@     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 (:==) Nat Nat = TrueSym0+    type instance (:==) Nat Int = FalseSym0+    type instance (:==) Nat String = FalseSym0+    type instance (:==) Nat (Maybe b) = FalseSym0+    type instance (:==) Nat (Vec b b) = FalseSym0+    type instance (:==) Int Nat = FalseSym0+    type instance (:==) Int Int = TrueSym0+    type instance (:==) Int String = FalseSym0+    type instance (:==) Int (Maybe b) = FalseSym0+    type instance (:==) Int (Vec b b) = FalseSym0+    type instance (:==) String Nat = FalseSym0+    type instance (:==) String Int = FalseSym0+    type instance (:==) String String = TrueSym0+    type instance (:==) String (Maybe b) = FalseSym0+    type instance (:==) String (Vec b b) = FalseSym0+    type instance (:==) (Maybe a) Nat = FalseSym0+    type instance (:==) (Maybe a) Int = FalseSym0+    type instance (:==) (Maybe a) String = FalseSym0     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 (:==) (Maybe a) (Vec b b) = FalseSym0+    type instance (:==) (Vec a a) Nat = FalseSym0+    type instance (:==) (Vec a a) Int = FalseSym0+    type instance (:==) (Vec a a) String = FalseSym0+    type instance (:==) (Vec a a) (Maybe b) = FalseSym0     type instance (:==) (Vec a a) (Vec b b) = :&& (:== a b) (:== a b)     data instance Sing (z :: *)       = z ~ Nat => SNat |
tests/compile-and-dump/Singletons/Star.ghc78.template view
@@ -3,132 +3,243 @@   ======>     Singletons/Star.hs:0:0:     data Rep-      = Nat | Int | String | Maybe Rep | Vec Rep Nat+      = Singletons.Star.Nat |+        Singletons.Star.Int |+        Singletons.Star.String |+        Singletons.Star.Maybe Rep |+        Singletons.Star.Vec Rep Nat       deriving (Eq, Show, Read)+    type family Equals_0123456789 (a :: *) (b :: *) :: Bool where+      Equals_0123456789 Nat Nat = TrueSym0+      Equals_0123456789 Int Int = TrueSym0+      Equals_0123456789 String String = TrueSym0+      Equals_0123456789 (Maybe a) (Maybe b) = (:==) a b+      Equals_0123456789 (Vec a a) (Vec b b) = (:&&) ((:==) a b) ((:==) a b)+      Equals_0123456789 (a :: *) (b :: *) = FalseSym0+    instance PEq (KProxy :: KProxy *) where+      type (:==) (a :: *) (b :: *) = Equals_0123456789 a b+    instance POrd (KProxy :: KProxy *) where+      type Compare Nat Nat = EQ+      type Compare Nat Int = LT+      type Compare Nat String = LT+      type Compare Nat (Maybe rhs) = LT+      type Compare Nat (Vec rhs rhs) = LT+      type Compare Int Nat = GT+      type Compare Int Int = EQ+      type Compare Int String = LT+      type Compare Int (Maybe rhs) = LT+      type Compare Int (Vec rhs rhs) = LT+      type Compare String Nat = GT+      type Compare String Int = GT+      type Compare String String = EQ+      type Compare String (Maybe rhs) = LT+      type Compare String (Vec rhs rhs) = LT+      type Compare (Maybe lhs) Nat = GT+      type Compare (Maybe lhs) Int = GT+      type Compare (Maybe lhs) String = GT+      type Compare (Maybe lhs) (Maybe rhs) = ThenCmp EQ (Compare lhs rhs)+      type Compare (Maybe lhs) (Vec rhs rhs) = LT+      type Compare (Vec lhs lhs) Nat = GT+      type Compare (Vec lhs lhs) Int = GT+      type Compare (Vec lhs lhs) String = GT+      type Compare (Vec lhs lhs) (Maybe rhs) = GT+      type Compare (Vec lhs lhs) (Vec rhs rhs) = ThenCmp (ThenCmp EQ (Compare lhs rhs)) (Compare lhs rhs)+    type NatSym0 = Nat+    type IntSym0 = Int+    type StringSym0 = String+    type MaybeSym1 (t :: *) = Maybe t+    instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings MaybeSym0 where+      Data.Singletons.SuppressUnusedWarnings.suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) MaybeSym0KindInference GHC.Tuple.())+    data MaybeSym0 (l :: TyFun * *)+      = forall arg. (GHC.Types.~) (KindOf (Apply MaybeSym0 arg)) (KindOf (MaybeSym1 arg)) =>+        MaybeSym0KindInference+    type instance Apply MaybeSym0 l = MaybeSym1 l+    type VecSym2 (t :: *) (t :: Nat) = Vec t t+    instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings VecSym1 where+      Data.Singletons.SuppressUnusedWarnings.suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) VecSym1KindInference GHC.Tuple.())+    data VecSym1 (l :: *) (l :: TyFun Nat *)+      = forall arg. (GHC.Types.~) (KindOf (Apply (VecSym1 l) arg)) (KindOf (VecSym2 l arg)) =>+        VecSym1KindInference+    type instance Apply (VecSym1 l) l = VecSym2 l l+    instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings VecSym0 where+      Data.Singletons.SuppressUnusedWarnings.suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) VecSym0KindInference GHC.Tuple.())+    data VecSym0 (l :: TyFun * (TyFun Nat * -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply VecSym0 arg)) (KindOf (VecSym1 arg)) =>+        VecSym0KindInference+    type instance Apply VecSym0 l = VecSym1 l+    data instance Sing (z :: *)+      = (GHC.Types.~) z Nat => SNat |+        (GHC.Types.~) z Int => SInt |+        (GHC.Types.~) z String => SString |+        forall (n :: *). (GHC.Types.~) z (Maybe n) => SMaybe (Sing n) |+        forall (n :: *) (n :: Nat). (GHC.Types.~) 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 = Singletons.Star.Nat+      fromSing SInt = Singletons.Star.Int+      fromSing SString = Singletons.Star.String+      fromSing (SMaybe b) = Singletons.Star.Maybe (fromSing b)+      fromSing (SVec b b) = Singletons.Star.Vec (fromSing b) (fromSing b)+      toSing Singletons.Star.Nat = SomeSing SNat+      toSing Singletons.Star.Int = SomeSing SInt+      toSing Singletons.Star.String = SomeSing SString+      toSing (Singletons.Star.Maybe b)+        = case toSing b :: SomeSing (KProxy :: KProxy *) of {+            SomeSing c -> SomeSing (SMaybe c) }+      toSing (Singletons.Star.Vec b b)+        = case+              GHC.Tuple.(,)+                (toSing b :: SomeSing (KProxy :: KProxy *))+                (toSing b :: SomeSing (KProxy :: KProxy Nat))+          of {+            GHC.Tuple.(,) (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" })+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })       (%~) SNat SString         = Disproved-            (\case {-               _ -> error "Empty case reached -- this should be impossible" })+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })       (%~) SNat (SMaybe _)         = Disproved-            (\case {-               _ -> error "Empty case reached -- this should be impossible" })+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })       (%~) SNat (SVec _ _)         = Disproved-            (\case {-               _ -> error "Empty case reached -- this should be impossible" })+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })       (%~) SInt SNat         = Disproved-            (\case {-               _ -> error "Empty case reached -- this should be impossible" })+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })       (%~) SInt SInt = Proved Refl       (%~) SInt SString         = Disproved-            (\case {-               _ -> error "Empty case reached -- this should be impossible" })+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })       (%~) SInt (SMaybe _)         = Disproved-            (\case {-               _ -> error "Empty case reached -- this should be impossible" })+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })       (%~) SInt (SVec _ _)         = Disproved-            (\case {-               _ -> error "Empty case reached -- this should be impossible" })+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })       (%~) SString SNat         = Disproved-            (\case {-               _ -> error "Empty case reached -- this should be impossible" })+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })       (%~) SString SInt         = Disproved-            (\case {-               _ -> error "Empty case reached -- this should be impossible" })+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })       (%~) SString SString = Proved Refl       (%~) SString (SMaybe _)         = Disproved-            (\case {-               _ -> error "Empty case reached -- this should be impossible" })+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })       (%~) SString (SVec _ _)         = Disproved-            (\case {-               _ -> error "Empty case reached -- this should be impossible" })+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })       (%~) (SMaybe _) SNat         = Disproved-            (\case {-               _ -> error "Empty case reached -- this should be impossible" })+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })       (%~) (SMaybe _) SInt         = Disproved-            (\case {-               _ -> error "Empty case reached -- this should be impossible" })+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })       (%~) (SMaybe _) SString         = Disproved-            (\case {-               _ -> error "Empty case reached -- this should be impossible" })+            (\ x+               -> case x of {+                    _ -> 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) }+            Disproved contra+              -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) }       (%~) (SMaybe _) (SVec _ _)         = Disproved-            (\case {-               _ -> error "Empty case reached -- this should be impossible" })+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })       (%~) (SVec _ _) SNat         = Disproved-            (\case {-               _ -> error "Empty case reached -- this should be impossible" })+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })       (%~) (SVec _ _) SInt         = Disproved-            (\case {-               _ -> error "Empty case reached -- this should be impossible" })+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })       (%~) (SVec _ _) SString         = Disproved-            (\case {-               _ -> error "Empty case reached -- this should be impossible" })+            (\ x+               -> case x of {+                    _ -> error "Empty case reached -- this should be impossible" })       (%~) (SVec _ _) (SMaybe _)         = Disproved-            (\case {-               _ -> error "Empty case reached -- this should be impossible" })+            (\ x+               -> case x of {+                    _ -> 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) }+        = case GHC.Tuple.(,) ((%~) a b) ((%~) a b) of {+            GHC.Tuple.(,) (Proved Refl) (Proved Refl) -> Proved Refl+            GHC.Tuple.(,) (Disproved contra) _+              -> Disproved (\ refl -> case refl of { Refl -> contra Refl })+            GHC.Tuple.(,) _ (Disproved contra)+              -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) }     instance SingI Nat where       sing = SNat     instance SingI Int where
+ tests/compile-and-dump/Singletons/T29.ghc78.template view
@@ -0,0 +1,124 @@+Singletons/T29.hs:0:0: Splicing declarations+    singletons+      [d| foo :: Bool -> Bool+          foo x = not $ x+          bar :: Bool -> Bool+          bar x = not . not . not $ x+          baz :: Bool -> Bool+          baz x = not $! x+          ban :: Bool -> Bool+          ban x = not . not . not $! x |]+  ======>+    Singletons/T29.hs:(0,0)-(0,0)+    foo :: Bool -> Bool+    foo x = (not $ x)+    bar :: Bool -> Bool+    bar x = ((not . (not . not)) $ x)+    baz :: Bool -> Bool+    baz x = (not $! x)+    ban :: Bool -> Bool+    ban x = ((not . (not . not)) $! x)+    type BanSym1 (t :: Bool) = Ban t+    instance SuppressUnusedWarnings BanSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) BanSym0KindInference GHC.Tuple.())+    data BanSym0 (l :: TyFun Bool Bool)+      = forall arg. (GHC.Types.~) (KindOf (Apply BanSym0 arg)) (KindOf (BanSym1 arg)) =>+        BanSym0KindInference+    type instance Apply BanSym0 l = BanSym1 l+    type BazSym1 (t :: Bool) = Baz t+    instance SuppressUnusedWarnings BazSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) BazSym0KindInference GHC.Tuple.())+    data BazSym0 (l :: TyFun Bool Bool)+      = forall arg. (GHC.Types.~) (KindOf (Apply BazSym0 arg)) (KindOf (BazSym1 arg)) =>+        BazSym0KindInference+    type instance Apply BazSym0 l = BazSym1 l+    type BarSym1 (t :: Bool) = Bar t+    instance SuppressUnusedWarnings BarSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) BarSym0KindInference GHC.Tuple.())+    data BarSym0 (l :: TyFun Bool Bool)+      = forall arg. (GHC.Types.~) (KindOf (Apply BarSym0 arg)) (KindOf (BarSym1 arg)) =>+        BarSym0KindInference+    type instance Apply BarSym0 l = BarSym1 l+    type FooSym1 (t :: Bool) = Foo t+    instance SuppressUnusedWarnings FooSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) FooSym0KindInference GHC.Tuple.())+    data FooSym0 (l :: TyFun Bool Bool)+      = forall arg. (GHC.Types.~) (KindOf (Apply FooSym0 arg)) (KindOf (FooSym1 arg)) =>+        FooSym0KindInference+    type instance Apply FooSym0 l = FooSym1 l+    type family Ban (a :: Bool) :: Bool where+      Ban x = Apply (Apply ($!$) (Apply (Apply (:.$) NotSym0) (Apply (Apply (:.$) NotSym0) NotSym0))) x+    type family Baz (a :: Bool) :: Bool where+      Baz x = Apply (Apply ($!$) NotSym0) x+    type family Bar (a :: Bool) :: Bool where+      Bar x = Apply (Apply ($$) (Apply (Apply (:.$) NotSym0) (Apply (Apply (:.$) NotSym0) NotSym0))) x+    type family Foo (a :: Bool) :: Bool where+      Foo x = Apply (Apply ($$) NotSym0) x+    sBan :: forall (t :: Bool). Sing t -> Sing (Apply BanSym0 t)+    sBaz :: forall (t :: Bool). Sing t -> Sing (Apply BazSym0 t)+    sBar :: forall (t :: Bool). Sing t -> Sing (Apply BarSym0 t)+    sFoo :: forall (t :: Bool). Sing t -> Sing (Apply FooSym0 t)+    sBan sX+      = let+          lambda ::+            forall x. (GHC.Types.~) t x => Sing x -> Sing (Apply BanSym0 x)+          lambda x+            = applySing+                (applySing+                   (singFun2 (Proxy :: Proxy ($!$)) (%$!))+                   (applySing+                      (applySing+                         (singFun3 (Proxy :: Proxy (:.$)) (%:.))+                         (singFun1 (Proxy :: Proxy NotSym0) sNot))+                      (applySing+                         (applySing+                            (singFun3 (Proxy :: Proxy (:.$)) (%:.))+                            (singFun1 (Proxy :: Proxy NotSym0) sNot))+                         (singFun1 (Proxy :: Proxy NotSym0) sNot))))+                x+        in lambda sX+    sBaz sX+      = let+          lambda ::+            forall x. (GHC.Types.~) t x => Sing x -> Sing (Apply BazSym0 x)+          lambda x+            = applySing+                (applySing+                   (singFun2 (Proxy :: Proxy ($!$)) (%$!))+                   (singFun1 (Proxy :: Proxy NotSym0) sNot))+                x+        in lambda sX+    sBar sX+      = let+          lambda ::+            forall x. (GHC.Types.~) t x => Sing x -> Sing (Apply BarSym0 x)+          lambda x+            = applySing+                (applySing+                   (singFun2 (Proxy :: Proxy ($$)) (%$))+                   (applySing+                      (applySing+                         (singFun3 (Proxy :: Proxy (:.$)) (%:.))+                         (singFun1 (Proxy :: Proxy NotSym0) sNot))+                      (applySing+                         (applySing+                            (singFun3 (Proxy :: Proxy (:.$)) (%:.))+                            (singFun1 (Proxy :: Proxy NotSym0) sNot))+                         (singFun1 (Proxy :: Proxy NotSym0) sNot))))+                x+        in lambda sX+    sFoo sX+      = let+          lambda ::+            forall x. (GHC.Types.~) t x => Sing x -> Sing (Apply FooSym0 x)+          lambda x+            = applySing+                (applySing+                   (singFun2 (Proxy :: Proxy ($$)) (%$))+                   (singFun1 (Proxy :: Proxy NotSym0) sNot))+                x+        in lambda sX
+ tests/compile-and-dump/Singletons/T29.hs view
@@ -0,0 +1,44 @@+module Singletons.T29 where++import Data.Singletons.TH+import Data.Singletons.Prelude++$(singletons [d|+  foo :: Bool -> Bool+  foo x = not $ x++  -- test that $ works with function composition+  bar :: Bool -> Bool+  bar x = not . not . not $ x++  baz :: Bool -> Bool+  baz x = not $! x++  -- test that $! works with function composition+  ban :: Bool -> Bool+  ban x = not . not . not $! x+  |])++foo1a :: Proxy (Foo True)+foo1a = Proxy++foo1b :: Proxy False+foo1b = foo1b++bar1a :: Proxy (Bar True)+bar1a = Proxy++bar1b :: Proxy False+bar1b = bar1b++baz1a :: Proxy (Baz True)+baz1a = Proxy++baz1b :: Proxy False+baz1b = baz1b++ban1a :: Proxy (Ban True)+ban1a = Proxy++ban1b :: Proxy False+ban1b = ban1b
+ tests/compile-and-dump/Singletons/T33.ghc78.template view
@@ -0,0 +1,35 @@+Singletons/T33.hs:0:0: Splicing declarations+    singletons+      [d| foo :: (Bool, Bool) -> ()+          foo ~(_, _) = () |]+  ======>+    Singletons/T33.hs:(0,0)-(0,0)+    foo :: (Bool, Bool) -> ()+    foo ~(_, _) = GHC.Tuple.()+    type FooSym1 (t :: GHC.Tuple.(,) Bool Bool) = Foo t+    instance SuppressUnusedWarnings FooSym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) FooSym0KindInference GHC.Tuple.())+    data FooSym0 (l :: TyFun (GHC.Tuple.(,) Bool Bool) GHC.Tuple.())+      = forall arg. (GHC.Types.~) (KindOf (Apply FooSym0 arg)) (KindOf (FooSym1 arg)) =>+        FooSym0KindInference+    type instance Apply FooSym0 l = FooSym1 l+    type family Foo (a :: GHC.Tuple.(,) Bool Bool) :: GHC.Tuple.() where+      Foo (GHC.Tuple.(,) z z) = Tuple0Sym0+    sFoo ::+      forall (t :: GHC.Tuple.(,) Bool Bool).+      Sing t -> Sing (Apply FooSym0 t)+    sFoo (STuple2 _ _)+      = let+          lambda ::+            forall wild+                   wild. (GHC.Types.~) t (Apply (Apply Tuple2Sym0 wild) wild) =>+            Sing (Apply FooSym0 (Apply (Apply Tuple2Sym0 wild) wild))+          lambda = STuple0+        in lambda++Singletons/T33.hs:0:0: Warning:+    Lazy pattern converted into regular pattern in promotion++Singletons/T33.hs:0:0: Warning:+    Lazy pattern converted into regular pattern during singleton generation.
+ tests/compile-and-dump/Singletons/T33.hs view
@@ -0,0 +1,9 @@+module Singletons.T33 where++import Data.Singletons.TH+import Data.Singletons.Prelude++$(singletons [d|+  foo :: (Bool, Bool) -> ()+  foo ~(_, _) = ()+  |])
+ tests/compile-and-dump/Singletons/TopLevelPatterns.ghc76.template view
@@ -0,0 +1,98 @@+Promote/TopLevelPatterns.hs:0:0: Splicing declarations+    promote+      [d| data Bool = False | True+          data Foo = Bar Bool Bool |]+  ======>+    Promote/TopLevelPatterns.hs:(0,0)-(0,0)+    data Bool = False | True+    data Foo = Bar Bool Bool+    type BoolTyCtor = Bool+    type BoolTyCtorSym0 = BoolTyCtor+    type FalseSym0 = False+    type TrueSym0 = True+    type FooTyCtor = Foo+    type FooTyCtorSym0 = FooTyCtor+    data BarSym1 (l :: Bool) (l :: TyFun Bool Foo)+    data BarSym0 (k :: TyFun Bool (TyFun Bool Foo -> *))+    type instance Apply (BarSym1 a) a = Bar a a+    type instance Apply BarSym0 a = BarSym1 a+Promote/TopLevelPatterns.hs:0:0: Splicing declarations+    promote+      [d| otherwise :: Bool+          otherwise = True+          id :: a -> a+          id x = x+          not :: Bool -> Bool+          not True = False+          not False = True+          false_ = False+          f, g :: Bool -> Bool+          [f, g] = [not, id]+          h, i :: Bool -> Bool+          (h, i) = (f, g)+          j, k :: Bool+          (Bar j k) = Bar True (h False)+          l, m :: Bool+          [l, m] = [not True, id False] |]+  ======>+    Promote/TopLevelPatterns.hs:(0,0)-(0,0)+    otherwise :: Bool+    otherwise = True+    id :: forall a. a -> a+    id x = x+    not :: Bool -> Bool+    not True = False+    not False = True+    false_ = False+    f :: Bool -> Bool+    g :: Bool -> Bool+    [f, g] = [not, id]+    h :: Bool -> Bool+    i :: Bool -> Bool+    (h, i) = (f, g)+    j :: Bool+    k :: Bool+    Bar j k = Bar True (h False)+    l :: Bool+    m :: Bool+    [l, m] = [not True, id False]+    type Otherwise = TrueSym0+    type OtherwiseSym0 = Otherwise+    type False_ = FalseSym0+    type False_Sym0 = False_+    type F = Head '[NotSym0, IdSym0]+    type FSym0 = F+    type G = Head (Tail '[NotSym0, IdSym0])+    type GSym0 = G+    type H = Extract_0123456789 '(FSym0, GSym0)+    type HSym0 = H+    type I = Extract_0123456789 '(FSym0, GSym0)+    type ISym0 = I+    type family Extract_0123456789 (a :: GHC.Tuple.(,) a b) :: a+    type family Extract_0123456789 (a :: GHC.Tuple.(,) a b) :: b+    type instance Extract_0123456789 (GHC.Tuple.(,) a a) = a+    type instance Extract_0123456789 (GHC.Tuple.(,) a a) = a+    type J =+        Extract_0123456789 (Apply (Apply BarSym0 TrueSym0) (Apply HSym0 FalseSym0))+    type JSym0 = J+    type K =+        Extract_0123456789 (Apply (Apply BarSym0 TrueSym0) (Apply HSym0 FalseSym0))+    type KSym0 = K+    type family Extract_0123456789 (a :: Foo) :: Bool+    type family Extract_0123456789 (a :: Foo) :: Bool+    type instance Extract_0123456789 (Bar a a) = a+    type instance Extract_0123456789 (Bar a a) = a+    type L = Head '[Apply NotSym0 TrueSym0, Apply IdSym0 FalseSym0]+    type LSym0 = L+    type M =+        Head (Tail '[Apply NotSym0 TrueSym0, Apply IdSym0 FalseSym0])+    type MSym0 = M+    type family Id (a :: a) :: a+    type instance Id x = x+    data IdSym0 (k :: TyFun a a)+    type instance Apply IdSym0 a = Id a+    type family Not (a :: Bool) :: Bool+    type instance Not True = FalseSym0+    type instance Not False = TrueSym0+    data NotSym0 (k :: TyFun Bool Bool)+    type instance Apply NotSym0 a = Not a
+ tests/compile-and-dump/Singletons/TopLevelPatterns.ghc78.template view
@@ -0,0 +1,123 @@+Singletons/TopLevelPatterns.hs:0:0: Splicing declarations+    singletons+      [d| data Bool = False | True+          data Foo = Bar Bool Bool |]+  ======>+    Singletons/TopLevelPatterns.hs:(0,0)-(0,0)+    data Bool = False | True+    data Foo = Bar Bool Bool+    type FalseSym0 = False+    type TrueSym0 = True+    type BarSym2 (t :: Bool) (t :: Bool) = Bar t t+    instance SuppressUnusedWarnings BarSym1 where+      suppressUnusedWarnings _+        = Data.Tuple.snd (GHC.Tuple.(,) BarSym1KindInference GHC.Tuple.())+    data BarSym1 (l :: Bool) (l :: TyFun Bool Foo)+      = forall arg. (GHC.Types.~) (KindOf (Apply (BarSym1 l) arg)) (KindOf (BarSym2 l arg)) =>+        BarSym1KindInference+    type instance Apply (BarSym1 l) l = BarSym2 l l+    instance SuppressUnusedWarnings BarSym0 where+      suppressUnusedWarnings _+        = Data.Tuple.snd (GHC.Tuple.(,) BarSym0KindInference GHC.Tuple.())+    data BarSym0 (l :: TyFun Bool (TyFun Bool Foo -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply BarSym0 arg)) (KindOf (BarSym1 arg)) =>+        BarSym0KindInference+    type instance Apply BarSym0 l = BarSym1 l+    data instance Sing (z :: Bool)+      = (GHC.Types.~) z False => SFalse | (GHC.Types.~) z True => STrue+    type SBool (z :: Bool) = Sing z+    instance SingKind (KProxy :: KProxy Bool) where+      type DemoteRep (KProxy :: KProxy Bool) = Bool+      fromSing SFalse = False+      fromSing STrue = True+      toSing False = SomeSing SFalse+      toSing True = SomeSing STrue+    data instance Sing (z :: Foo)+      = forall (n :: Bool) (n :: Bool). (GHC.Types.~) z (Bar n n) =>+        SBar (Sing n) (Sing n)+    type SFoo (z :: Foo) = Sing z+    instance SingKind (KProxy :: KProxy Foo) where+      type DemoteRep (KProxy :: KProxy Foo) = Foo+      fromSing (SBar b b) = Bar (fromSing b) (fromSing b)+      toSing (Bar b b)+        = case+              GHC.Tuple.(,)+                (toSing b :: SomeSing (KProxy :: KProxy Bool))+                (toSing b :: SomeSing (KProxy :: KProxy Bool))+          of {+            GHC.Tuple.(,) (SomeSing c) (SomeSing c) -> SomeSing (SBar c c) }+    instance SingI False where+      sing = SFalse+    instance SingI True where+      sing = STrue+    instance (SingI n, SingI n) =>+             SingI (Bar (n :: Bool) (n :: Bool)) where+      sing = SBar sing sing+Singletons/TopLevelPatterns.hs:0:0: Splicing declarations+    singletons+      [d| otherwise :: Bool+          otherwise = True+          id :: a -> a+          id x = x+          not :: Bool -> Bool+          not True = False+          not False = True+          false_ = False |]+  ======>+    Singletons/TopLevelPatterns.hs:(0,0)-(0,0)+    otherwise :: Bool+    otherwise = True+    id :: forall a. a -> a+    id x = x+    not :: Bool -> Bool+    not True = False+    not False = True+    false_ = False+    type False_Sym0 = False_+    type NotSym1 (t :: Bool) = Not t+    instance SuppressUnusedWarnings NotSym0 where+      suppressUnusedWarnings _+        = Data.Tuple.snd (GHC.Tuple.(,) NotSym0KindInference GHC.Tuple.())+    data NotSym0 (l :: TyFun Bool Bool)+      = forall arg. (GHC.Types.~) (KindOf (Apply NotSym0 arg)) (KindOf (NotSym1 arg)) =>+        NotSym0KindInference+    type instance Apply NotSym0 l = NotSym1 l+    type IdSym1 (t :: a) = Id t+    instance SuppressUnusedWarnings IdSym0 where+      suppressUnusedWarnings _+        = Data.Tuple.snd (GHC.Tuple.(,) IdSym0KindInference GHC.Tuple.())+    data IdSym0 (l :: TyFun a a)+      = forall arg. (GHC.Types.~) (KindOf (Apply IdSym0 arg)) (KindOf (IdSym1 arg)) =>+        IdSym0KindInference+    type instance Apply IdSym0 l = IdSym1 l+    type OtherwiseSym0 = Otherwise+    type False_ = FalseSym0+    type family Not (a :: Bool) :: Bool where+      Not True = FalseSym0+      Not False = TrueSym0+    type family Id (a :: a) :: a where+      Id x = x+    type Otherwise = (TrueSym0 :: Bool)+    sFalse_ :: Sing False_Sym0+    sNot :: forall (t :: Bool). Sing t -> Sing (Apply NotSym0 t)+    sId :: forall (t :: a). Sing t -> Sing (Apply IdSym0 t)+    sOtherwise :: Sing OtherwiseSym0+    sFalse_ = SFalse+    sNot STrue+      = let+          lambda :: (GHC.Types.~) t TrueSym0 => Sing (Apply NotSym0 TrueSym0)+          lambda = SFalse+        in lambda+    sNot SFalse+      = let+          lambda ::+            (GHC.Types.~) t FalseSym0 => Sing (Apply NotSym0 FalseSym0)+          lambda = STrue+        in lambda+    sId sX+      = let+          lambda ::+            forall x. (GHC.Types.~) t x => Sing x -> Sing (Apply IdSym0 x)+          lambda x = x+        in lambda sX+    sOtherwise = STrue
+ tests/compile-and-dump/Singletons/TopLevelPatterns.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}++module Singletons.TopLevelPatterns where++import Data.Singletons+import Data.Singletons.Prelude.List+import Data.Singletons.SuppressUnusedWarnings+import Data.Singletons.TH hiding (STrue, SFalse, TrueSym0, FalseSym0)++$(singletons [d|+  data Bool = False | True+  data Foo = Bar Bool Bool+ |])++$(singletons [d|+  otherwise :: Bool+  otherwise = True++  id :: a -> a+  id x = x++  not :: Bool -> Bool+  not True  = False+  not False = True++  false_ = False++{- Commented out until #54 is fixed+  f,g :: Bool -> Bool+  [f,g] = [not, id]++  h,i :: Bool -> Bool+  (h,i) = (f, g)++  j,k :: Bool+  (Bar j k) = Bar True (h False)++  l,m :: Bool+  [l,m] = [not True, id False]+-}+ |])
+ tests/compile-and-dump/Singletons/Tuples.ghc76.template view
@@ -0,0 +1,532 @@+Singletons/Tuples.hs:0:0: Splicing declarations+    genSingletons+      [''(), ''(,), ''(,,), ''(,,,), ''(,,,,), ''(,,,,,), ''(,,,,,,)]+  ======>+    Singletons/Tuples.hs:(0,0)-(0,0)+    type TupleTyCtor0 = GHC.Tuple.()+    type TupleTyCtor0Sym0 = TupleTyCtor0+    type Tuple0Sym0 = GHC.Tuple.()+    data instance Sing (z :: GHC.Tuple.())+      = z ~ GHC.Tuple.() => STuple0+    type STuple0 (z :: GHC.Tuple.()) = Sing z+    instance SingKind (KProxy :: KProxy GHC.Tuple.()) where+      type instance DemoteRep (KProxy :: KProxy GHC.Tuple.()) =+          GHC.Tuple.()+      fromSing STuple0 = GHC.Tuple.()+      toSing GHC.Tuple.() = SomeSing STuple0+    instance SingI GHC.Tuple.() where+      sing = STuple0+    type TupleTyCtor2 = GHC.Tuple.(,)+    data TupleTyCtor2Sym1 (l :: *) (l :: TyFun * *)+    data TupleTyCtor2Sym0 (k :: TyFun * (TyFun * * -> *))+    type instance Apply (TupleTyCtor2Sym1 a) a = TupleTyCtor2 a a+    type instance Apply TupleTyCtor2Sym0 a = TupleTyCtor2Sym1 a+    data Tuple2Sym1 (l :: a) (l :: TyFun b (GHC.Tuple.(,) a b))+    data Tuple2Sym0 (k :: TyFun a (TyFun b (GHC.Tuple.(,) a b) -> *))+    type instance Apply (Tuple2Sym1 a) a = GHC.Tuple.(,) a a+    type instance Apply Tuple2Sym0 a = Tuple2Sym1 a+    data instance Sing (z :: GHC.Tuple.(,) a b)+      = forall (n :: a) (n :: b). z ~ GHC.Tuple.(,) n n =>+        STuple2 (Sing n) (Sing n)+    type STuple2 (z :: GHC.Tuple.(,) a b) = Sing z+    instance (SingKind (KProxy :: KProxy a),+              SingKind (KProxy :: KProxy b)) =>+             SingKind (KProxy :: KProxy (GHC.Tuple.(,) a b)) where+      type instance DemoteRep (KProxy :: KProxy (GHC.Tuple.(,) a b)) =+          GHC.Tuple.(,) (DemoteRep (KProxy :: KProxy a)) (DemoteRep (KProxy :: KProxy b))+      fromSing (STuple2 b b) = GHC.Tuple.(,) (fromSing b) (fromSing b)+      toSing (GHC.Tuple.(,) b b)+        = case+              (toSing b :: SomeSing (KProxy :: KProxy a), +               toSing b :: SomeSing (KProxy :: KProxy b))+          of {+            (SomeSing c, SomeSing c) -> SomeSing (STuple2 c c) }+    instance (SingI n, SingI n) =>+             SingI (GHC.Tuple.(,) (n :: a) (n :: b)) where+      sing = STuple2 sing sing+    type TupleTyCtor3 = GHC.Tuple.(,,)+    data TupleTyCtor3Sym2 (l :: *) (l :: *) (l :: TyFun * *)+    data TupleTyCtor3Sym1 (l :: *) (l :: TyFun * (TyFun * * -> *))+    data TupleTyCtor3Sym0 (k :: TyFun * (TyFun * (TyFun * * -> *)+                                         -> *))+    type instance Apply (TupleTyCtor3Sym2 a a) a = TupleTyCtor3 a a a+    type instance Apply (TupleTyCtor3Sym1 a) a = TupleTyCtor3Sym2 a a+    type instance Apply TupleTyCtor3Sym0 a = TupleTyCtor3Sym1 a+    data Tuple3Sym2 (l :: a)+                    (l :: b)+                    (l :: TyFun c (GHC.Tuple.(,,) a b c))+    data Tuple3Sym1 (l :: a)+                    (l :: TyFun b (TyFun c (GHC.Tuple.(,,) a b c) -> *))+    data Tuple3Sym0 (k :: TyFun a (TyFun b (TyFun c (GHC.Tuple.(,,) a b c)+                                            -> *)+                                   -> *))+    type instance Apply (Tuple3Sym2 a a) a = GHC.Tuple.(,,) a a a+    type instance Apply (Tuple3Sym1 a) a = Tuple3Sym2 a a+    type instance Apply Tuple3Sym0 a = Tuple3Sym1 a+    data instance Sing (z :: GHC.Tuple.(,,) a b c)+      = forall (n :: a) (n :: b) (n :: c). z ~ GHC.Tuple.(,,) n n n =>+        STuple3 (Sing n) (Sing n) (Sing n)+    type STuple3 (z :: GHC.Tuple.(,,) a b c) = Sing z+    instance (SingKind (KProxy :: KProxy a),+              SingKind (KProxy :: KProxy b),+              SingKind (KProxy :: KProxy c)) =>+             SingKind (KProxy :: KProxy (GHC.Tuple.(,,) a b c)) where+      type instance DemoteRep (KProxy :: KProxy (GHC.Tuple.(,,) a b c)) =+          GHC.Tuple.(,,) (DemoteRep (KProxy :: KProxy a)) (DemoteRep (KProxy :: KProxy b)) (DemoteRep (KProxy :: KProxy c))+      fromSing (STuple3 b b b)+        = GHC.Tuple.(,,) (fromSing b) (fromSing b) (fromSing b)+      toSing (GHC.Tuple.(,,) b b b)+        = case+              (toSing b :: SomeSing (KProxy :: KProxy a), +               toSing b :: SomeSing (KProxy :: KProxy b), +               toSing b :: SomeSing (KProxy :: KProxy c))+          of {+            (SomeSing c, SomeSing c, SomeSing c) -> SomeSing (STuple3 c c c) }+    instance (SingI n, SingI n, SingI n) =>+             SingI (GHC.Tuple.(,,) (n :: a) (n :: b) (n :: c)) where+      sing = STuple3 sing sing sing+    type TupleTyCtor4 = GHC.Tuple.(,,,)+    data TupleTyCtor4Sym3 (l :: *) (l :: *) (l :: *) (l :: TyFun * *)+    data TupleTyCtor4Sym2 (l :: *)+                          (l :: *)+                          (l :: TyFun * (TyFun * * -> *))+    data TupleTyCtor4Sym1 (l :: *)+                          (l :: TyFun * (TyFun * (TyFun * * -> *) -> *))+    data TupleTyCtor4Sym0 (k :: TyFun * (TyFun * (TyFun * (TyFun * *+                                                           -> *)+                                                  -> *)+                                         -> *))+    type instance Apply (TupleTyCtor4Sym3 a a a) a =+        TupleTyCtor4 a a a a+    type instance Apply (TupleTyCtor4Sym2 a a) a =+        TupleTyCtor4Sym3 a a a+    type instance Apply (TupleTyCtor4Sym1 a) a = TupleTyCtor4Sym2 a a+    type instance Apply TupleTyCtor4Sym0 a = TupleTyCtor4Sym1 a+    data Tuple4Sym3 (l :: a)+                    (l :: b)+                    (l :: c)+                    (l :: TyFun d (GHC.Tuple.(,,,) a b c d))+    data Tuple4Sym2 (l :: a)+                    (l :: b)+                    (l :: TyFun c (TyFun d (GHC.Tuple.(,,,) a b c d) -> *))+    data Tuple4Sym1 (l :: a)+                    (l :: TyFun b (TyFun c (TyFun d (GHC.Tuple.(,,,) a b c d) -> *)+                                   -> *))+    data Tuple4Sym0 (k :: TyFun a (TyFun b (TyFun c (TyFun d (GHC.Tuple.(,,,) a b c d)+                                                     -> *)+                                            -> *)+                                   -> *))+    type instance Apply (Tuple4Sym3 a a a) a = GHC.Tuple.(,,,) a a a a+    type instance Apply (Tuple4Sym2 a a) a = Tuple4Sym3 a a a+    type instance Apply (Tuple4Sym1 a) a = Tuple4Sym2 a a+    type instance Apply Tuple4Sym0 a = Tuple4Sym1 a+    data instance Sing (z :: GHC.Tuple.(,,,) a b c d)+      = forall (n :: a)+               (n :: b)+               (n :: c)+               (n :: d). z ~ GHC.Tuple.(,,,) n n n n =>+        STuple4 (Sing n) (Sing n) (Sing n) (Sing n)+    type STuple4 (z :: GHC.Tuple.(,,,) a b c d) = Sing z+    instance (SingKind (KProxy :: KProxy a),+              SingKind (KProxy :: KProxy b),+              SingKind (KProxy :: KProxy c),+              SingKind (KProxy :: KProxy d)) =>+             SingKind (KProxy :: KProxy (GHC.Tuple.(,,,) a b c d)) where+      type instance DemoteRep (KProxy :: KProxy (GHC.Tuple.(,,,) a b c d)) =+          GHC.Tuple.(,,,) (DemoteRep (KProxy :: KProxy a)) (DemoteRep (KProxy :: KProxy b)) (DemoteRep (KProxy :: KProxy c)) (DemoteRep (KProxy :: KProxy d))+      fromSing (STuple4 b b b b)+        = GHC.Tuple.(,,,)+            (fromSing b) (fromSing b) (fromSing b) (fromSing b)+      toSing (GHC.Tuple.(,,,) b b b b)+        = case+              (toSing b :: SomeSing (KProxy :: KProxy a), +               toSing b :: SomeSing (KProxy :: KProxy b), +               toSing b :: SomeSing (KProxy :: KProxy c), +               toSing b :: SomeSing (KProxy :: KProxy d))+          of {+            (SomeSing c, SomeSing c, SomeSing c, SomeSing c)+              -> SomeSing (STuple4 c c c c) }+    instance (SingI n, SingI n, SingI n, SingI n) =>+             SingI (GHC.Tuple.(,,,) (n :: a) (n :: b) (n :: c) (n :: d)) where+      sing = STuple4 sing sing sing sing+    type TupleTyCtor5 = GHC.Tuple.(,,,,)+    data TupleTyCtor5Sym4 (l :: *)+                          (l :: *)+                          (l :: *)+                          (l :: *)+                          (l :: TyFun * *)+    data TupleTyCtor5Sym3 (l :: *)+                          (l :: *)+                          (l :: *)+                          (l :: TyFun * (TyFun * * -> *))+    data TupleTyCtor5Sym2 (l :: *)+                          (l :: *)+                          (l :: TyFun * (TyFun * (TyFun * * -> *) -> *))+    data TupleTyCtor5Sym1 (l :: *)+                          (l :: TyFun * (TyFun * (TyFun * (TyFun * * -> *) -> *) -> *))+    data TupleTyCtor5Sym0 (k :: TyFun * (TyFun * (TyFun * (TyFun * (TyFun * *+                                                                    -> *)+                                                           -> *)+                                                  -> *)+                                         -> *))+    type instance Apply (TupleTyCtor5Sym4 a a a a) a =+        TupleTyCtor5 a a a a a+    type instance Apply (TupleTyCtor5Sym3 a a a) a =+        TupleTyCtor5Sym4 a a a a+    type instance Apply (TupleTyCtor5Sym2 a a) a =+        TupleTyCtor5Sym3 a a a+    type instance Apply (TupleTyCtor5Sym1 a) a = TupleTyCtor5Sym2 a a+    type instance Apply TupleTyCtor5Sym0 a = TupleTyCtor5Sym1 a+    data Tuple5Sym4 (l :: a)+                    (l :: b)+                    (l :: c)+                    (l :: d)+                    (l :: TyFun e (GHC.Tuple.(,,,,) a b c d e))+    data Tuple5Sym3 (l :: a)+                    (l :: b)+                    (l :: c)+                    (l :: TyFun d (TyFun e (GHC.Tuple.(,,,,) a b c d e) -> *))+    data Tuple5Sym2 (l :: a)+                    (l :: b)+                    (l :: TyFun c (TyFun d (TyFun e (GHC.Tuple.(,,,,) a b c d e) -> *)+                                   -> *))+    data Tuple5Sym1 (l :: a)+                    (l :: TyFun b (TyFun c (TyFun d (TyFun e (GHC.Tuple.(,,,,) a b c d e)+                                                     -> *)+                                            -> *)+                                   -> *))+    data Tuple5Sym0 (k :: TyFun a (TyFun b (TyFun c (TyFun d (TyFun e (GHC.Tuple.(,,,,) a b c d e)+                                                              -> *)+                                                     -> *)+                                            -> *)+                                   -> *))+    type instance Apply (Tuple5Sym4 a a a a) a =+        GHC.Tuple.(,,,,) a a a a a+    type instance Apply (Tuple5Sym3 a a a) a = Tuple5Sym4 a a a a+    type instance Apply (Tuple5Sym2 a a) a = Tuple5Sym3 a a a+    type instance Apply (Tuple5Sym1 a) a = Tuple5Sym2 a a+    type instance Apply Tuple5Sym0 a = Tuple5Sym1 a+    data instance Sing (z :: GHC.Tuple.(,,,,) a b c d e)+      = forall (n :: a)+               (n :: b)+               (n :: c)+               (n :: d)+               (n :: e). z ~ GHC.Tuple.(,,,,) n n n n n =>+        STuple5 (Sing n) (Sing n) (Sing n) (Sing n) (Sing n)+    type STuple5 (z :: GHC.Tuple.(,,,,) a b c d e) = Sing z+    instance (SingKind (KProxy :: KProxy a),+              SingKind (KProxy :: KProxy b),+              SingKind (KProxy :: KProxy c),+              SingKind (KProxy :: KProxy d),+              SingKind (KProxy :: KProxy e)) =>+             SingKind (KProxy :: KProxy (GHC.Tuple.(,,,,) a b c d e)) where+      type instance DemoteRep (KProxy :: KProxy (GHC.Tuple.(,,,,) a b c d e)) =+          GHC.Tuple.(,,,,) (DemoteRep (KProxy :: KProxy a)) (DemoteRep (KProxy :: KProxy b)) (DemoteRep (KProxy :: KProxy c)) (DemoteRep (KProxy :: KProxy d)) (DemoteRep (KProxy :: KProxy e))+      fromSing (STuple5 b b b b b)+        = GHC.Tuple.(,,,,)+            (fromSing b) (fromSing b) (fromSing b) (fromSing b) (fromSing b)+      toSing (GHC.Tuple.(,,,,) b b b b b)+        = case+              (toSing b :: SomeSing (KProxy :: KProxy a), +               toSing b :: SomeSing (KProxy :: KProxy b), +               toSing b :: SomeSing (KProxy :: KProxy c), +               toSing b :: SomeSing (KProxy :: KProxy d), +               toSing b :: SomeSing (KProxy :: KProxy e))+          of {+            (SomeSing c, SomeSing c, SomeSing c, SomeSing c, SomeSing c)+              -> SomeSing (STuple5 c c c c c) }+    instance (SingI n, SingI n, SingI n, SingI n, SingI n) =>+             SingI (GHC.Tuple.(,,,,) (n :: a) (n :: b) (n :: c) (n :: d) (n :: e)) where+      sing = STuple5 sing sing sing sing sing+    type TupleTyCtor6 = GHC.Tuple.(,,,,,)+    data TupleTyCtor6Sym5 (l :: *)+                          (l :: *)+                          (l :: *)+                          (l :: *)+                          (l :: *)+                          (l :: TyFun * *)+    data TupleTyCtor6Sym4 (l :: *)+                          (l :: *)+                          (l :: *)+                          (l :: *)+                          (l :: TyFun * (TyFun * * -> *))+    data TupleTyCtor6Sym3 (l :: *)+                          (l :: *)+                          (l :: *)+                          (l :: TyFun * (TyFun * (TyFun * * -> *) -> *))+    data TupleTyCtor6Sym2 (l :: *)+                          (l :: *)+                          (l :: TyFun * (TyFun * (TyFun * (TyFun * * -> *) -> *) -> *))+    data TupleTyCtor6Sym1 (l :: *)+                          (l :: TyFun * (TyFun * (TyFun * (TyFun * (TyFun * * -> *) -> *)+                                                  -> *)+                                         -> *))+    data TupleTyCtor6Sym0 (k :: TyFun * (TyFun * (TyFun * (TyFun * (TyFun * (TyFun * *+                                                                             -> *)+                                                                    -> *)+                                                           -> *)+                                                  -> *)+                                         -> *))+    type instance Apply (TupleTyCtor6Sym5 a a a a a) a =+        TupleTyCtor6 a a a a a a+    type instance Apply (TupleTyCtor6Sym4 a a a a) a =+        TupleTyCtor6Sym5 a a a a a+    type instance Apply (TupleTyCtor6Sym3 a a a) a =+        TupleTyCtor6Sym4 a a a a+    type instance Apply (TupleTyCtor6Sym2 a a) a =+        TupleTyCtor6Sym3 a a a+    type instance Apply (TupleTyCtor6Sym1 a) a = TupleTyCtor6Sym2 a a+    type instance Apply TupleTyCtor6Sym0 a = TupleTyCtor6Sym1 a+    data Tuple6Sym5 (l :: a)+                    (l :: b)+                    (l :: c)+                    (l :: d)+                    (l :: e)+                    (l :: TyFun f (GHC.Tuple.(,,,,,) a b c d e f))+    data Tuple6Sym4 (l :: a)+                    (l :: b)+                    (l :: c)+                    (l :: d)+                    (l :: TyFun e (TyFun f (GHC.Tuple.(,,,,,) a b c d e f) -> *))+    data Tuple6Sym3 (l :: a)+                    (l :: b)+                    (l :: c)+                    (l :: TyFun d (TyFun e (TyFun f (GHC.Tuple.(,,,,,) a b c d e f)+                                            -> *)+                                   -> *))+    data Tuple6Sym2 (l :: a)+                    (l :: b)+                    (l :: TyFun c (TyFun d (TyFun e (TyFun f (GHC.Tuple.(,,,,,) a b c d e f)+                                                     -> *)+                                            -> *)+                                   -> *))+    data Tuple6Sym1 (l :: a)+                    (l :: TyFun b (TyFun c (TyFun d (TyFun e (TyFun f (GHC.Tuple.(,,,,,) a b c d e f)+                                                              -> *)+                                                     -> *)+                                            -> *)+                                   -> *))+    data Tuple6Sym0 (k :: TyFun a (TyFun b (TyFun c (TyFun d (TyFun e (TyFun f (GHC.Tuple.(,,,,,) a b c d e f)+                                                                       -> *)+                                                              -> *)+                                                     -> *)+                                            -> *)+                                   -> *))+    type instance Apply (Tuple6Sym5 a a a a a) a =+        GHC.Tuple.(,,,,,) a a a a a a+    type instance Apply (Tuple6Sym4 a a a a) a = Tuple6Sym5 a a a a a+    type instance Apply (Tuple6Sym3 a a a) a = Tuple6Sym4 a a a a+    type instance Apply (Tuple6Sym2 a a) a = Tuple6Sym3 a a a+    type instance Apply (Tuple6Sym1 a) a = Tuple6Sym2 a a+    type instance Apply Tuple6Sym0 a = Tuple6Sym1 a+    data instance Sing (z :: GHC.Tuple.(,,,,,) a b c d e f)+      = forall (n :: a)+               (n :: b)+               (n :: c)+               (n :: d)+               (n :: e)+               (n :: f). z ~ GHC.Tuple.(,,,,,) n n n n n n =>+        STuple6 (Sing n) (Sing n) (Sing n) (Sing n) (Sing n) (Sing n)+    type STuple6 (z :: GHC.Tuple.(,,,,,) a b c d e f) = Sing z+    instance (SingKind (KProxy :: KProxy a),+              SingKind (KProxy :: KProxy b),+              SingKind (KProxy :: KProxy c),+              SingKind (KProxy :: KProxy d),+              SingKind (KProxy :: KProxy e),+              SingKind (KProxy :: KProxy f)) =>+             SingKind (KProxy :: KProxy (GHC.Tuple.(,,,,,) a b c d e f)) where+      type instance DemoteRep (KProxy :: KProxy (GHC.Tuple.(,,,,,) a b c d e f)) =+          GHC.Tuple.(,,,,,) (DemoteRep (KProxy :: KProxy a)) (DemoteRep (KProxy :: KProxy b)) (DemoteRep (KProxy :: KProxy c)) (DemoteRep (KProxy :: KProxy d)) (DemoteRep (KProxy :: KProxy e)) (DemoteRep (KProxy :: KProxy f))+      fromSing (STuple6 b b b b b b)+        = GHC.Tuple.(,,,,,)+            (fromSing b)+            (fromSing b)+            (fromSing b)+            (fromSing b)+            (fromSing b)+            (fromSing b)+      toSing (GHC.Tuple.(,,,,,) b b b b b b)+        = case+              (toSing b :: SomeSing (KProxy :: KProxy a), +               toSing b :: SomeSing (KProxy :: KProxy b), +               toSing b :: SomeSing (KProxy :: KProxy c), +               toSing b :: SomeSing (KProxy :: KProxy d), +               toSing b :: SomeSing (KProxy :: KProxy e), +               toSing b :: SomeSing (KProxy :: KProxy f))+          of {+            (SomeSing c,+             SomeSing c,+             SomeSing c,+             SomeSing c,+             SomeSing c,+             SomeSing c)+              -> SomeSing (STuple6 c c c c c c) }+    instance (SingI n, SingI n, SingI n, SingI n, SingI n, SingI n) =>+             SingI (GHC.Tuple.(,,,,,) (n :: a) (n :: b) (n :: c) (n :: d) (n :: e) (n :: f)) where+      sing = STuple6 sing sing sing sing sing sing+    type TupleTyCtor7 = GHC.Tuple.(,,,,,,)+    data TupleTyCtor7Sym6 (l :: *)+                          (l :: *)+                          (l :: *)+                          (l :: *)+                          (l :: *)+                          (l :: *)+                          (l :: TyFun * *)+    data TupleTyCtor7Sym5 (l :: *)+                          (l :: *)+                          (l :: *)+                          (l :: *)+                          (l :: *)+                          (l :: TyFun * (TyFun * * -> *))+    data TupleTyCtor7Sym4 (l :: *)+                          (l :: *)+                          (l :: *)+                          (l :: *)+                          (l :: TyFun * (TyFun * (TyFun * * -> *) -> *))+    data TupleTyCtor7Sym3 (l :: *)+                          (l :: *)+                          (l :: *)+                          (l :: TyFun * (TyFun * (TyFun * (TyFun * * -> *) -> *) -> *))+    data TupleTyCtor7Sym2 (l :: *)+                          (l :: *)+                          (l :: TyFun * (TyFun * (TyFun * (TyFun * (TyFun * * -> *) -> *)+                                                  -> *)+                                         -> *))+    data TupleTyCtor7Sym1 (l :: *)+                          (l :: TyFun * (TyFun * (TyFun * (TyFun * (TyFun * (TyFun * * -> *)+                                                                    -> *)+                                                           -> *)+                                                  -> *)+                                         -> *))+    data TupleTyCtor7Sym0 (k :: TyFun * (TyFun * (TyFun * (TyFun * (TyFun * (TyFun * (TyFun * *+                                                                                      -> *)+                                                                             -> *)+                                                                    -> *)+                                                           -> *)+                                                  -> *)+                                         -> *))+    type instance Apply (TupleTyCtor7Sym6 a a a a a a) a =+        TupleTyCtor7 a a a a a a a+    type instance Apply (TupleTyCtor7Sym5 a a a a a) a =+        TupleTyCtor7Sym6 a a a a a a+    type instance Apply (TupleTyCtor7Sym4 a a a a) a =+        TupleTyCtor7Sym5 a a a a a+    type instance Apply (TupleTyCtor7Sym3 a a a) a =+        TupleTyCtor7Sym4 a a a a+    type instance Apply (TupleTyCtor7Sym2 a a) a =+        TupleTyCtor7Sym3 a a a+    type instance Apply (TupleTyCtor7Sym1 a) a = TupleTyCtor7Sym2 a a+    type instance Apply TupleTyCtor7Sym0 a = TupleTyCtor7Sym1 a+    data Tuple7Sym6 (l :: a)+                    (l :: b)+                    (l :: c)+                    (l :: d)+                    (l :: e)+                    (l :: f)+                    (l :: TyFun g (GHC.Tuple.(,,,,,,) a b c d e f g))+    data Tuple7Sym5 (l :: a)+                    (l :: b)+                    (l :: c)+                    (l :: d)+                    (l :: e)+                    (l :: TyFun f (TyFun g (GHC.Tuple.(,,,,,,) a b c d e f g) -> *))+    data Tuple7Sym4 (l :: a)+                    (l :: b)+                    (l :: c)+                    (l :: d)+                    (l :: TyFun e (TyFun f (TyFun g (GHC.Tuple.(,,,,,,) a b c d e f g)+                                            -> *)+                                   -> *))+    data Tuple7Sym3 (l :: a)+                    (l :: b)+                    (l :: c)+                    (l :: TyFun d (TyFun e (TyFun f (TyFun g (GHC.Tuple.(,,,,,,) a b c d e f g)+                                                     -> *)+                                            -> *)+                                   -> *))+    data Tuple7Sym2 (l :: a)+                    (l :: b)+                    (l :: TyFun c (TyFun d (TyFun e (TyFun f (TyFun g (GHC.Tuple.(,,,,,,) a b c d e f g)+                                                              -> *)+                                                     -> *)+                                            -> *)+                                   -> *))+    data Tuple7Sym1 (l :: a)+                    (l :: TyFun b (TyFun c (TyFun d (TyFun e (TyFun f (TyFun g (GHC.Tuple.(,,,,,,) a b c d e f g)+                                                                       -> *)+                                                              -> *)+                                                     -> *)+                                            -> *)+                                   -> *))+    data Tuple7Sym0 (k :: TyFun a (TyFun b (TyFun c (TyFun d (TyFun e (TyFun f (TyFun g (GHC.Tuple.(,,,,,,) a b c d e f g)+                                                                                -> *)+                                                                       -> *)+                                                              -> *)+                                                     -> *)+                                            -> *)+                                   -> *))+    type instance Apply (Tuple7Sym6 a a a a a a) a =+        GHC.Tuple.(,,,,,,) a a a a a a a+    type instance Apply (Tuple7Sym5 a a a a a) a =+        Tuple7Sym6 a a a a a a+    type instance Apply (Tuple7Sym4 a a a a) a = Tuple7Sym5 a a a a a+    type instance Apply (Tuple7Sym3 a a a) a = Tuple7Sym4 a a a a+    type instance Apply (Tuple7Sym2 a a) a = Tuple7Sym3 a a a+    type instance Apply (Tuple7Sym1 a) a = Tuple7Sym2 a a+    type instance Apply Tuple7Sym0 a = Tuple7Sym1 a+    data instance Sing (z :: GHC.Tuple.(,,,,,,) a b c d e f g)+      = forall (n :: a)+               (n :: b)+               (n :: c)+               (n :: d)+               (n :: e)+               (n :: f)+               (n :: g). z ~ GHC.Tuple.(,,,,,,) n n n n n n n =>+        STuple7 (Sing n) (Sing n) (Sing n) (Sing n) (Sing n) (Sing n) (Sing n)+    type STuple7 (z :: GHC.Tuple.(,,,,,,) a b c d e f g) = Sing z+    instance (SingKind (KProxy :: KProxy a),+              SingKind (KProxy :: KProxy b),+              SingKind (KProxy :: KProxy c),+              SingKind (KProxy :: KProxy d),+              SingKind (KProxy :: KProxy e),+              SingKind (KProxy :: KProxy f),+              SingKind (KProxy :: KProxy g)) =>+             SingKind (KProxy :: KProxy (GHC.Tuple.(,,,,,,) a b c d e f g)) where+      type instance DemoteRep (KProxy :: KProxy (GHC.Tuple.(,,,,,,) a b c d e f g)) =+          GHC.Tuple.(,,,,,,) (DemoteRep (KProxy :: KProxy a)) (DemoteRep (KProxy :: KProxy b)) (DemoteRep (KProxy :: KProxy c)) (DemoteRep (KProxy :: KProxy d)) (DemoteRep (KProxy :: KProxy e)) (DemoteRep (KProxy :: KProxy f)) (DemoteRep (KProxy :: KProxy g))+      fromSing (STuple7 b b b b b b b)+        = GHC.Tuple.(,,,,,,)+            (fromSing b)+            (fromSing b)+            (fromSing b)+            (fromSing b)+            (fromSing b)+            (fromSing b)+            (fromSing b)+      toSing (GHC.Tuple.(,,,,,,) b b b b b b b)+        = case+              (toSing b :: SomeSing (KProxy :: KProxy a), +               toSing b :: SomeSing (KProxy :: KProxy b), +               toSing b :: SomeSing (KProxy :: KProxy c), +               toSing b :: SomeSing (KProxy :: KProxy d), +               toSing b :: SomeSing (KProxy :: KProxy e), +               toSing b :: SomeSing (KProxy :: KProxy f), +               toSing b :: SomeSing (KProxy :: KProxy g))+          of {+            (SomeSing c,+             SomeSing c,+             SomeSing c,+             SomeSing c,+             SomeSing c,+             SomeSing c,+             SomeSing c)+              -> SomeSing (STuple7 c c c c c c c) }+    instance (SingI n,+              SingI n,+              SingI n,+              SingI n,+              SingI n,+              SingI n,+              SingI n) =>+             SingI (GHC.Tuple.(,,,,,,) (n :: a) (n :: b) (n :: c) (n :: d) (n :: e) (n :: f) (n :: g)) where+      sing = STuple7 sing sing sing sing sing sing sing
+ tests/compile-and-dump/Singletons/Tuples.ghc78.template view
@@ -0,0 +1,538 @@+Singletons/Tuples.hs:0:0: Splicing declarations+    genSingletons+      [''(), ''(,), ''(,,), ''(,,,), ''(,,,,), ''(,,,,,), ''(,,,,,,)]+  ======>+    Singletons/Tuples.hs:(0,0)-(0,0)+    type Tuple0Sym0 = GHC.Tuple.()+    data instance Sing (z :: GHC.Tuple.())+      = (GHC.Types.~) z GHC.Tuple.() => STuple0+    type STuple0 (z :: GHC.Tuple.()) = Sing z+    instance SingKind (KProxy :: KProxy GHC.Tuple.()) where+      type DemoteRep (KProxy :: KProxy GHC.Tuple.()) = GHC.Tuple.()+      fromSing STuple0 = GHC.Tuple.()+      toSing GHC.Tuple.() = SomeSing STuple0+    instance SingI GHC.Tuple.() where+      sing = STuple0+    type Tuple2Sym2 (t :: a) (t :: b) = GHC.Tuple.(,) t t+    instance SuppressUnusedWarnings Tuple2Sym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Tuple2Sym1KindInference GHC.Tuple.())+    data Tuple2Sym1 (l :: a) (l :: TyFun b (GHC.Tuple.(,) a b))+      = forall arg. (GHC.Types.~) (KindOf (Apply (Tuple2Sym1 l) arg)) (KindOf (Tuple2Sym2 l arg)) =>+        Tuple2Sym1KindInference+    type instance Apply (Tuple2Sym1 l) l = Tuple2Sym2 l l+    instance SuppressUnusedWarnings Tuple2Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Tuple2Sym0KindInference GHC.Tuple.())+    data Tuple2Sym0 (l :: TyFun a (TyFun b (GHC.Tuple.(,) a b) -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply Tuple2Sym0 arg)) (KindOf (Tuple2Sym1 arg)) =>+        Tuple2Sym0KindInference+    type instance Apply Tuple2Sym0 l = Tuple2Sym1 l+    data instance Sing (z :: GHC.Tuple.(,) a b)+      = forall (n :: a) (n :: b). (GHC.Types.~) z (GHC.Tuple.(,) n n) =>+        STuple2 (Sing n) (Sing n)+    type STuple2 (z :: GHC.Tuple.(,) a b) = Sing z+    instance (SingKind (KProxy :: KProxy a),+              SingKind (KProxy :: KProxy b)) =>+             SingKind (KProxy :: KProxy (GHC.Tuple.(,) a b)) where+      type DemoteRep (KProxy :: KProxy (GHC.Tuple.(,) a b)) = GHC.Tuple.(,) (DemoteRep (KProxy :: KProxy a)) (DemoteRep (KProxy :: KProxy b))+      fromSing (STuple2 b b) = GHC.Tuple.(,) (fromSing b) (fromSing b)+      toSing (GHC.Tuple.(,) b b)+        = case+              GHC.Tuple.(,)+                (toSing b :: SomeSing (KProxy :: KProxy a))+                (toSing b :: SomeSing (KProxy :: KProxy b))+          of {+            GHC.Tuple.(,) (SomeSing c) (SomeSing c) -> SomeSing (STuple2 c c) }+    instance (SingI n, SingI n) =>+             SingI (GHC.Tuple.(,) (n :: a) (n :: b)) where+      sing = STuple2 sing sing+    type Tuple3Sym3 (t :: a) (t :: b) (t :: c) = GHC.Tuple.(,,) t t t+    instance SuppressUnusedWarnings Tuple3Sym2 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Tuple3Sym2KindInference GHC.Tuple.())+    data Tuple3Sym2 (l :: a)+                    (l :: b)+                    (l :: TyFun c (GHC.Tuple.(,,) a b c))+      = forall arg. (GHC.Types.~) (KindOf (Apply (Tuple3Sym2 l l) arg)) (KindOf (Tuple3Sym3 l l arg)) =>+        Tuple3Sym2KindInference+    type instance Apply (Tuple3Sym2 l l) l = Tuple3Sym3 l l l+    instance SuppressUnusedWarnings Tuple3Sym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Tuple3Sym1KindInference GHC.Tuple.())+    data Tuple3Sym1 (l :: a)+                    (l :: TyFun b (TyFun c (GHC.Tuple.(,,) a b c) -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply (Tuple3Sym1 l) arg)) (KindOf (Tuple3Sym2 l arg)) =>+        Tuple3Sym1KindInference+    type instance Apply (Tuple3Sym1 l) l = Tuple3Sym2 l l+    instance SuppressUnusedWarnings Tuple3Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Tuple3Sym0KindInference GHC.Tuple.())+    data Tuple3Sym0 (l :: TyFun a (TyFun b (TyFun c (GHC.Tuple.(,,) a b c)+                                            -> *)+                                   -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply Tuple3Sym0 arg)) (KindOf (Tuple3Sym1 arg)) =>+        Tuple3Sym0KindInference+    type instance Apply Tuple3Sym0 l = Tuple3Sym1 l+    data instance Sing (z :: GHC.Tuple.(,,) a b c)+      = forall (n :: a)+               (n :: b)+               (n :: c). (GHC.Types.~) z (GHC.Tuple.(,,) n n n) =>+        STuple3 (Sing n) (Sing n) (Sing n)+    type STuple3 (z :: GHC.Tuple.(,,) a b c) = Sing z+    instance (SingKind (KProxy :: KProxy a),+              SingKind (KProxy :: KProxy b),+              SingKind (KProxy :: KProxy c)) =>+             SingKind (KProxy :: KProxy (GHC.Tuple.(,,) a b c)) where+      type DemoteRep (KProxy :: KProxy (GHC.Tuple.(,,) a b c)) = GHC.Tuple.(,,) (DemoteRep (KProxy :: KProxy a)) (DemoteRep (KProxy :: KProxy b)) (DemoteRep (KProxy :: KProxy c))+      fromSing (STuple3 b b b)+        = GHC.Tuple.(,,) (fromSing b) (fromSing b) (fromSing b)+      toSing (GHC.Tuple.(,,) b b b)+        = case+              GHC.Tuple.(,,)+                (toSing b :: SomeSing (KProxy :: KProxy a))+                (toSing b :: SomeSing (KProxy :: KProxy b))+                (toSing b :: SomeSing (KProxy :: KProxy c))+          of {+            GHC.Tuple.(,,) (SomeSing c) (SomeSing c) (SomeSing c)+              -> SomeSing (STuple3 c c c) }+    instance (SingI n, SingI n, SingI n) =>+             SingI (GHC.Tuple.(,,) (n :: a) (n :: b) (n :: c)) where+      sing = STuple3 sing sing sing+    type Tuple4Sym4 (t :: a) (t :: b) (t :: c) (t :: d) =+        GHC.Tuple.(,,,) t t t t+    instance SuppressUnusedWarnings Tuple4Sym3 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Tuple4Sym3KindInference GHC.Tuple.())+    data Tuple4Sym3 (l :: a)+                    (l :: b)+                    (l :: c)+                    (l :: TyFun d (GHC.Tuple.(,,,) a b c d))+      = forall arg. (GHC.Types.~) (KindOf (Apply (Tuple4Sym3 l l l) arg)) (KindOf (Tuple4Sym4 l l l arg)) =>+        Tuple4Sym3KindInference+    type instance Apply (Tuple4Sym3 l l l) l = Tuple4Sym4 l l l l+    instance SuppressUnusedWarnings Tuple4Sym2 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Tuple4Sym2KindInference GHC.Tuple.())+    data Tuple4Sym2 (l :: a)+                    (l :: b)+                    (l :: TyFun c (TyFun d (GHC.Tuple.(,,,) a b c d) -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply (Tuple4Sym2 l l) arg)) (KindOf (Tuple4Sym3 l l arg)) =>+        Tuple4Sym2KindInference+    type instance Apply (Tuple4Sym2 l l) l = Tuple4Sym3 l l l+    instance SuppressUnusedWarnings Tuple4Sym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Tuple4Sym1KindInference GHC.Tuple.())+    data Tuple4Sym1 (l :: a)+                    (l :: TyFun b (TyFun c (TyFun d (GHC.Tuple.(,,,) a b c d) -> *)+                                   -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply (Tuple4Sym1 l) arg)) (KindOf (Tuple4Sym2 l arg)) =>+        Tuple4Sym1KindInference+    type instance Apply (Tuple4Sym1 l) l = Tuple4Sym2 l l+    instance SuppressUnusedWarnings Tuple4Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Tuple4Sym0KindInference GHC.Tuple.())+    data Tuple4Sym0 (l :: TyFun a (TyFun b (TyFun c (TyFun d (GHC.Tuple.(,,,) a b c d)+                                                     -> *)+                                            -> *)+                                   -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply Tuple4Sym0 arg)) (KindOf (Tuple4Sym1 arg)) =>+        Tuple4Sym0KindInference+    type instance Apply Tuple4Sym0 l = Tuple4Sym1 l+    data instance Sing (z :: GHC.Tuple.(,,,) a b c d)+      = forall (n :: a)+               (n :: b)+               (n :: c)+               (n :: d). (GHC.Types.~) z (GHC.Tuple.(,,,) n n n n) =>+        STuple4 (Sing n) (Sing n) (Sing n) (Sing n)+    type STuple4 (z :: GHC.Tuple.(,,,) a b c d) = Sing z+    instance (SingKind (KProxy :: KProxy a),+              SingKind (KProxy :: KProxy b),+              SingKind (KProxy :: KProxy c),+              SingKind (KProxy :: KProxy d)) =>+             SingKind (KProxy :: KProxy (GHC.Tuple.(,,,) a b c d)) where+      type DemoteRep (KProxy :: KProxy (GHC.Tuple.(,,,) a b c d)) = GHC.Tuple.(,,,) (DemoteRep (KProxy :: KProxy a)) (DemoteRep (KProxy :: KProxy b)) (DemoteRep (KProxy :: KProxy c)) (DemoteRep (KProxy :: KProxy d))+      fromSing (STuple4 b b b b)+        = GHC.Tuple.(,,,)+            (fromSing b) (fromSing b) (fromSing b) (fromSing b)+      toSing (GHC.Tuple.(,,,) b b b b)+        = case+              GHC.Tuple.(,,,)+                (toSing b :: SomeSing (KProxy :: KProxy a))+                (toSing b :: SomeSing (KProxy :: KProxy b))+                (toSing b :: SomeSing (KProxy :: KProxy c))+                (toSing b :: SomeSing (KProxy :: KProxy d))+          of {+            GHC.Tuple.(,,,) (SomeSing c) (SomeSing c) (SomeSing c) (SomeSing c)+              -> SomeSing (STuple4 c c c c) }+    instance (SingI n, SingI n, SingI n, SingI n) =>+             SingI (GHC.Tuple.(,,,) (n :: a) (n :: b) (n :: c) (n :: d)) where+      sing = STuple4 sing sing sing sing+    type Tuple5Sym5 (t :: a) (t :: b) (t :: c) (t :: d) (t :: e) =+        GHC.Tuple.(,,,,) t t t t t+    instance SuppressUnusedWarnings Tuple5Sym4 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Tuple5Sym4KindInference GHC.Tuple.())+    data Tuple5Sym4 (l :: a)+                    (l :: b)+                    (l :: c)+                    (l :: d)+                    (l :: TyFun e (GHC.Tuple.(,,,,) a b c d e))+      = forall arg. (GHC.Types.~) (KindOf (Apply (Tuple5Sym4 l l l l) arg)) (KindOf (Tuple5Sym5 l l l l arg)) =>+        Tuple5Sym4KindInference+    type instance Apply (Tuple5Sym4 l l l l) l = Tuple5Sym5 l l l l l+    instance SuppressUnusedWarnings Tuple5Sym3 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Tuple5Sym3KindInference GHC.Tuple.())+    data Tuple5Sym3 (l :: a)+                    (l :: b)+                    (l :: c)+                    (l :: TyFun d (TyFun e (GHC.Tuple.(,,,,) a b c d e) -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply (Tuple5Sym3 l l l) arg)) (KindOf (Tuple5Sym4 l l l arg)) =>+        Tuple5Sym3KindInference+    type instance Apply (Tuple5Sym3 l l l) l = Tuple5Sym4 l l l l+    instance SuppressUnusedWarnings Tuple5Sym2 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Tuple5Sym2KindInference GHC.Tuple.())+    data Tuple5Sym2 (l :: a)+                    (l :: b)+                    (l :: TyFun c (TyFun d (TyFun e (GHC.Tuple.(,,,,) a b c d e) -> *)+                                   -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply (Tuple5Sym2 l l) arg)) (KindOf (Tuple5Sym3 l l arg)) =>+        Tuple5Sym2KindInference+    type instance Apply (Tuple5Sym2 l l) l = Tuple5Sym3 l l l+    instance SuppressUnusedWarnings Tuple5Sym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Tuple5Sym1KindInference GHC.Tuple.())+    data Tuple5Sym1 (l :: a)+                    (l :: TyFun b (TyFun c (TyFun d (TyFun e (GHC.Tuple.(,,,,) a b c d e)+                                                     -> *)+                                            -> *)+                                   -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply (Tuple5Sym1 l) arg)) (KindOf (Tuple5Sym2 l arg)) =>+        Tuple5Sym1KindInference+    type instance Apply (Tuple5Sym1 l) l = Tuple5Sym2 l l+    instance SuppressUnusedWarnings Tuple5Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Tuple5Sym0KindInference GHC.Tuple.())+    data Tuple5Sym0 (l :: TyFun a (TyFun b (TyFun c (TyFun d (TyFun e (GHC.Tuple.(,,,,) a b c d e)+                                                              -> *)+                                                     -> *)+                                            -> *)+                                   -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply Tuple5Sym0 arg)) (KindOf (Tuple5Sym1 arg)) =>+        Tuple5Sym0KindInference+    type instance Apply Tuple5Sym0 l = Tuple5Sym1 l+    data instance Sing (z :: GHC.Tuple.(,,,,) a b c d e)+      = forall (n :: a)+               (n :: b)+               (n :: c)+               (n :: d)+               (n :: e). (GHC.Types.~) z (GHC.Tuple.(,,,,) n n n n n) =>+        STuple5 (Sing n) (Sing n) (Sing n) (Sing n) (Sing n)+    type STuple5 (z :: GHC.Tuple.(,,,,) a b c d e) = Sing z+    instance (SingKind (KProxy :: KProxy a),+              SingKind (KProxy :: KProxy b),+              SingKind (KProxy :: KProxy c),+              SingKind (KProxy :: KProxy d),+              SingKind (KProxy :: KProxy e)) =>+             SingKind (KProxy :: KProxy (GHC.Tuple.(,,,,) a b c d e)) where+      type DemoteRep (KProxy :: KProxy (GHC.Tuple.(,,,,) a b c d e)) = GHC.Tuple.(,,,,) (DemoteRep (KProxy :: KProxy a)) (DemoteRep (KProxy :: KProxy b)) (DemoteRep (KProxy :: KProxy c)) (DemoteRep (KProxy :: KProxy d)) (DemoteRep (KProxy :: KProxy e))+      fromSing (STuple5 b b b b b)+        = GHC.Tuple.(,,,,)+            (fromSing b) (fromSing b) (fromSing b) (fromSing b) (fromSing b)+      toSing (GHC.Tuple.(,,,,) b b b b b)+        = case+              GHC.Tuple.(,,,,)+                (toSing b :: SomeSing (KProxy :: KProxy a))+                (toSing b :: SomeSing (KProxy :: KProxy b))+                (toSing b :: SomeSing (KProxy :: KProxy c))+                (toSing b :: SomeSing (KProxy :: KProxy d))+                (toSing b :: SomeSing (KProxy :: KProxy e))+          of {+            GHC.Tuple.(,,,,) (SomeSing c)+                             (SomeSing c)+                             (SomeSing c)+                             (SomeSing c)+                             (SomeSing c)+              -> SomeSing (STuple5 c c c c c) }+    instance (SingI n, SingI n, SingI n, SingI n, SingI n) =>+             SingI (GHC.Tuple.(,,,,) (n :: a) (n :: b) (n :: c) (n :: d) (n :: e)) where+      sing = STuple5 sing sing sing sing sing+    type Tuple6Sym6 (t :: a)+                    (t :: b)+                    (t :: c)+                    (t :: d)+                    (t :: e)+                    (t :: f) =+        GHC.Tuple.(,,,,,) t t t t t t+    instance SuppressUnusedWarnings Tuple6Sym5 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Tuple6Sym5KindInference GHC.Tuple.())+    data Tuple6Sym5 (l :: a)+                    (l :: b)+                    (l :: c)+                    (l :: d)+                    (l :: e)+                    (l :: TyFun f (GHC.Tuple.(,,,,,) a b c d e f))+      = forall arg. (GHC.Types.~) (KindOf (Apply (Tuple6Sym5 l l l l l) arg)) (KindOf (Tuple6Sym6 l l l l l arg)) =>+        Tuple6Sym5KindInference+    type instance Apply (Tuple6Sym5 l l l l l) l = Tuple6Sym6 l l l l l l+    instance SuppressUnusedWarnings Tuple6Sym4 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Tuple6Sym4KindInference GHC.Tuple.())+    data Tuple6Sym4 (l :: a)+                    (l :: b)+                    (l :: c)+                    (l :: d)+                    (l :: TyFun e (TyFun f (GHC.Tuple.(,,,,,) a b c d e f) -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply (Tuple6Sym4 l l l l) arg)) (KindOf (Tuple6Sym5 l l l l arg)) =>+        Tuple6Sym4KindInference+    type instance Apply (Tuple6Sym4 l l l l) l = Tuple6Sym5 l l l l l+    instance SuppressUnusedWarnings Tuple6Sym3 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Tuple6Sym3KindInference GHC.Tuple.())+    data Tuple6Sym3 (l :: a)+                    (l :: b)+                    (l :: c)+                    (l :: TyFun d (TyFun e (TyFun f (GHC.Tuple.(,,,,,) a b c d e f)+                                            -> *)+                                   -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply (Tuple6Sym3 l l l) arg)) (KindOf (Tuple6Sym4 l l l arg)) =>+        Tuple6Sym3KindInference+    type instance Apply (Tuple6Sym3 l l l) l = Tuple6Sym4 l l l l+    instance SuppressUnusedWarnings Tuple6Sym2 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Tuple6Sym2KindInference GHC.Tuple.())+    data Tuple6Sym2 (l :: a)+                    (l :: b)+                    (l :: TyFun c (TyFun d (TyFun e (TyFun f (GHC.Tuple.(,,,,,) a b c d e f)+                                                     -> *)+                                            -> *)+                                   -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply (Tuple6Sym2 l l) arg)) (KindOf (Tuple6Sym3 l l arg)) =>+        Tuple6Sym2KindInference+    type instance Apply (Tuple6Sym2 l l) l = Tuple6Sym3 l l l+    instance SuppressUnusedWarnings Tuple6Sym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Tuple6Sym1KindInference GHC.Tuple.())+    data Tuple6Sym1 (l :: a)+                    (l :: TyFun b (TyFun c (TyFun d (TyFun e (TyFun f (GHC.Tuple.(,,,,,) a b c d e f)+                                                              -> *)+                                                     -> *)+                                            -> *)+                                   -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply (Tuple6Sym1 l) arg)) (KindOf (Tuple6Sym2 l arg)) =>+        Tuple6Sym1KindInference+    type instance Apply (Tuple6Sym1 l) l = Tuple6Sym2 l l+    instance SuppressUnusedWarnings Tuple6Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Tuple6Sym0KindInference GHC.Tuple.())+    data Tuple6Sym0 (l :: TyFun a (TyFun b (TyFun c (TyFun d (TyFun e (TyFun f (GHC.Tuple.(,,,,,) a b c d e f)+                                                                       -> *)+                                                              -> *)+                                                     -> *)+                                            -> *)+                                   -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply Tuple6Sym0 arg)) (KindOf (Tuple6Sym1 arg)) =>+        Tuple6Sym0KindInference+    type instance Apply Tuple6Sym0 l = Tuple6Sym1 l+    data instance Sing (z :: GHC.Tuple.(,,,,,) a b c d e f)+      = forall (n :: a)+               (n :: b)+               (n :: c)+               (n :: d)+               (n :: e)+               (n :: f). (GHC.Types.~) z (GHC.Tuple.(,,,,,) n n n n n n) =>+        STuple6 (Sing n) (Sing n) (Sing n) (Sing n) (Sing n) (Sing n)+    type STuple6 (z :: GHC.Tuple.(,,,,,) a b c d e f) = Sing z+    instance (SingKind (KProxy :: KProxy a),+              SingKind (KProxy :: KProxy b),+              SingKind (KProxy :: KProxy c),+              SingKind (KProxy :: KProxy d),+              SingKind (KProxy :: KProxy e),+              SingKind (KProxy :: KProxy f)) =>+             SingKind (KProxy :: KProxy (GHC.Tuple.(,,,,,) a b c d e f)) where+      type DemoteRep (KProxy :: KProxy (GHC.Tuple.(,,,,,) a b c d e f)) = GHC.Tuple.(,,,,,) (DemoteRep (KProxy :: KProxy a)) (DemoteRep (KProxy :: KProxy b)) (DemoteRep (KProxy :: KProxy c)) (DemoteRep (KProxy :: KProxy d)) (DemoteRep (KProxy :: KProxy e)) (DemoteRep (KProxy :: KProxy f))+      fromSing (STuple6 b b b b b b)+        = GHC.Tuple.(,,,,,)+            (fromSing b)+            (fromSing b)+            (fromSing b)+            (fromSing b)+            (fromSing b)+            (fromSing b)+      toSing (GHC.Tuple.(,,,,,) b b b b b b)+        = case+              GHC.Tuple.(,,,,,)+                (toSing b :: SomeSing (KProxy :: KProxy a))+                (toSing b :: SomeSing (KProxy :: KProxy b))+                (toSing b :: SomeSing (KProxy :: KProxy c))+                (toSing b :: SomeSing (KProxy :: KProxy d))+                (toSing b :: SomeSing (KProxy :: KProxy e))+                (toSing b :: SomeSing (KProxy :: KProxy f))+          of {+            GHC.Tuple.(,,,,,) (SomeSing c)+                              (SomeSing c)+                              (SomeSing c)+                              (SomeSing c)+                              (SomeSing c)+                              (SomeSing c)+              -> SomeSing (STuple6 c c c c c c) }+    instance (SingI n, SingI n, SingI n, SingI n, SingI n, SingI n) =>+             SingI (GHC.Tuple.(,,,,,) (n :: a) (n :: b) (n :: c) (n :: d) (n :: e) (n :: f)) where+      sing = STuple6 sing sing sing sing sing sing+    type Tuple7Sym7 (t :: a)+                    (t :: b)+                    (t :: c)+                    (t :: d)+                    (t :: e)+                    (t :: f)+                    (t :: g) =+        GHC.Tuple.(,,,,,,) t t t t t t t+    instance SuppressUnusedWarnings Tuple7Sym6 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Tuple7Sym6KindInference GHC.Tuple.())+    data Tuple7Sym6 (l :: a)+                    (l :: b)+                    (l :: c)+                    (l :: d)+                    (l :: e)+                    (l :: f)+                    (l :: TyFun g (GHC.Tuple.(,,,,,,) a b c d e f g))+      = forall arg. (GHC.Types.~) (KindOf (Apply (Tuple7Sym6 l l l l l l) arg)) (KindOf (Tuple7Sym7 l l l l l l arg)) =>+        Tuple7Sym6KindInference+    type instance Apply (Tuple7Sym6 l l l l l l) l = Tuple7Sym7 l l l l l l l+    instance SuppressUnusedWarnings Tuple7Sym5 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Tuple7Sym5KindInference GHC.Tuple.())+    data Tuple7Sym5 (l :: a)+                    (l :: b)+                    (l :: c)+                    (l :: d)+                    (l :: e)+                    (l :: TyFun f (TyFun g (GHC.Tuple.(,,,,,,) a b c d e f g) -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply (Tuple7Sym5 l l l l l) arg)) (KindOf (Tuple7Sym6 l l l l l arg)) =>+        Tuple7Sym5KindInference+    type instance Apply (Tuple7Sym5 l l l l l) l = Tuple7Sym6 l l l l l l+    instance SuppressUnusedWarnings Tuple7Sym4 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Tuple7Sym4KindInference GHC.Tuple.())+    data Tuple7Sym4 (l :: a)+                    (l :: b)+                    (l :: c)+                    (l :: d)+                    (l :: TyFun e (TyFun f (TyFun g (GHC.Tuple.(,,,,,,) a b c d e f g)+                                            -> *)+                                   -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply (Tuple7Sym4 l l l l) arg)) (KindOf (Tuple7Sym5 l l l l arg)) =>+        Tuple7Sym4KindInference+    type instance Apply (Tuple7Sym4 l l l l) l = Tuple7Sym5 l l l l l+    instance SuppressUnusedWarnings Tuple7Sym3 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Tuple7Sym3KindInference GHC.Tuple.())+    data Tuple7Sym3 (l :: a)+                    (l :: b)+                    (l :: c)+                    (l :: TyFun d (TyFun e (TyFun f (TyFun g (GHC.Tuple.(,,,,,,) a b c d e f g)+                                                     -> *)+                                            -> *)+                                   -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply (Tuple7Sym3 l l l) arg)) (KindOf (Tuple7Sym4 l l l arg)) =>+        Tuple7Sym3KindInference+    type instance Apply (Tuple7Sym3 l l l) l = Tuple7Sym4 l l l l+    instance SuppressUnusedWarnings Tuple7Sym2 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Tuple7Sym2KindInference GHC.Tuple.())+    data Tuple7Sym2 (l :: a)+                    (l :: b)+                    (l :: TyFun c (TyFun d (TyFun e (TyFun f (TyFun g (GHC.Tuple.(,,,,,,) a b c d e f g)+                                                              -> *)+                                                     -> *)+                                            -> *)+                                   -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply (Tuple7Sym2 l l) arg)) (KindOf (Tuple7Sym3 l l arg)) =>+        Tuple7Sym2KindInference+    type instance Apply (Tuple7Sym2 l l) l = Tuple7Sym3 l l l+    instance SuppressUnusedWarnings Tuple7Sym1 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Tuple7Sym1KindInference GHC.Tuple.())+    data Tuple7Sym1 (l :: a)+                    (l :: TyFun b (TyFun c (TyFun d (TyFun e (TyFun f (TyFun g (GHC.Tuple.(,,,,,,) a b c d e f g)+                                                                       -> *)+                                                              -> *)+                                                     -> *)+                                            -> *)+                                   -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply (Tuple7Sym1 l) arg)) (KindOf (Tuple7Sym2 l arg)) =>+        Tuple7Sym1KindInference+    type instance Apply (Tuple7Sym1 l) l = Tuple7Sym2 l l+    instance SuppressUnusedWarnings Tuple7Sym0 where+      suppressUnusedWarnings _+        = snd (GHC.Tuple.(,) Tuple7Sym0KindInference GHC.Tuple.())+    data Tuple7Sym0 (l :: TyFun a (TyFun b (TyFun c (TyFun d (TyFun e (TyFun f (TyFun g (GHC.Tuple.(,,,,,,) a b c d e f g)+                                                                                -> *)+                                                                       -> *)+                                                              -> *)+                                                     -> *)+                                            -> *)+                                   -> *))+      = forall arg. (GHC.Types.~) (KindOf (Apply Tuple7Sym0 arg)) (KindOf (Tuple7Sym1 arg)) =>+        Tuple7Sym0KindInference+    type instance Apply Tuple7Sym0 l = Tuple7Sym1 l+    data instance Sing (z :: GHC.Tuple.(,,,,,,) a b c d e f g)+      = forall (n :: a)+               (n :: b)+               (n :: c)+               (n :: d)+               (n :: e)+               (n :: f)+               (n :: g). (GHC.Types.~) z (GHC.Tuple.(,,,,,,) n n n n n n n) =>+        STuple7 (Sing n) (Sing n) (Sing n) (Sing n) (Sing n) (Sing n) (Sing n)+    type STuple7 (z :: GHC.Tuple.(,,,,,,) a b c d e f g) = Sing z+    instance (SingKind (KProxy :: KProxy a),+              SingKind (KProxy :: KProxy b),+              SingKind (KProxy :: KProxy c),+              SingKind (KProxy :: KProxy d),+              SingKind (KProxy :: KProxy e),+              SingKind (KProxy :: KProxy f),+              SingKind (KProxy :: KProxy g)) =>+             SingKind (KProxy :: KProxy (GHC.Tuple.(,,,,,,) a b c d e f g)) where+      type DemoteRep (KProxy :: KProxy (GHC.Tuple.(,,,,,,) a b c d e f g)) = GHC.Tuple.(,,,,,,) (DemoteRep (KProxy :: KProxy a)) (DemoteRep (KProxy :: KProxy b)) (DemoteRep (KProxy :: KProxy c)) (DemoteRep (KProxy :: KProxy d)) (DemoteRep (KProxy :: KProxy e)) (DemoteRep (KProxy :: KProxy f)) (DemoteRep (KProxy :: KProxy g))+      fromSing (STuple7 b b b b b b b)+        = GHC.Tuple.(,,,,,,)+            (fromSing b)+            (fromSing b)+            (fromSing b)+            (fromSing b)+            (fromSing b)+            (fromSing b)+            (fromSing b)+      toSing (GHC.Tuple.(,,,,,,) b b b b b b b)+        = case+              GHC.Tuple.(,,,,,,)+                (toSing b :: SomeSing (KProxy :: KProxy a))+                (toSing b :: SomeSing (KProxy :: KProxy b))+                (toSing b :: SomeSing (KProxy :: KProxy c))+                (toSing b :: SomeSing (KProxy :: KProxy d))+                (toSing b :: SomeSing (KProxy :: KProxy e))+                (toSing b :: SomeSing (KProxy :: KProxy f))+                (toSing b :: SomeSing (KProxy :: KProxy g))+          of {+            GHC.Tuple.(,,,,,,) (SomeSing c)+                               (SomeSing c)+                               (SomeSing c)+                               (SomeSing c)+                               (SomeSing c)+                               (SomeSing c)+                               (SomeSing c)+              -> SomeSing (STuple7 c c c c c c c) }+    instance (SingI n,+              SingI n,+              SingI n,+              SingI n,+              SingI n,+              SingI n,+              SingI n) =>+             SingI (GHC.Tuple.(,,,,,,) (n :: a) (n :: b) (n :: c) (n :: d) (n :: e) (n :: f) (n :: g)) where+      sing = STuple7 sing sing sing sing sing sing sing
+ tests/compile-and-dump/Singletons/Tuples.hs view
@@ -0,0 +1,15 @@+module Singletons.Tuples where++import Data.Singletons+import Data.Singletons.Single+import Data.Singletons.SuppressUnusedWarnings+import Data.Singletons.Types++$(genSingletons [ ''()+                , ''(,)+                , ''(,,)+                , ''(,,,)+                , ''(,,,,)+                , ''(,,,,,)+                , ''(,,,,,,)+                ])