diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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: diff --git a/singletons.cabal b/singletons.cabal --- a/singletons.cabal +++ b/singletons.cabal @@ -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 -maintainer: Richard Eisenberg +author: Richard Eisenberg , Jan Stolarek +maintainer: Richard Eisenberg , Jan Stolarek 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 @@ () 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 diff --git a/src/Data/Promotion/Prelude.hs b/src/Data/Promotion/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Data/Promotion/Prelude.hs @@ -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 diff --git a/src/Data/Promotion/Prelude/Base.hs b/src/Data/Promotion/Prelude/Base.hs new file mode 100644 --- /dev/null +++ b/src/Data/Promotion/Prelude/Base.hs @@ -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) + |]) diff --git a/src/Data/Promotion/Prelude/Bool.hs b/src/Data/Promotion/Prelude/Bool.hs new file mode 100644 --- /dev/null +++ b/src/Data/Promotion/Prelude/Bool.hs @@ -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 diff --git a/src/Data/Promotion/Prelude/Bounded.hs b/src/Data/Promotion/Prelude/Bounded.hs new file mode 100644 --- /dev/null +++ b/src/Data/Promotion/Prelude/Bounded.hs @@ -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) diff --git a/src/Data/Promotion/Prelude/Either.hs b/src/Data/Promotion/Prelude/Either.hs new file mode 100644 --- /dev/null +++ b/src/Data/Promotion/Prelude/Either.hs @@ -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 diff --git a/src/Data/Promotion/Prelude/Eq.hs b/src/Data/Promotion/Prelude/Eq.hs new file mode 100644 --- /dev/null +++ b/src/Data/Promotion/Prelude/Eq.hs @@ -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 diff --git a/src/Data/Promotion/Prelude/List.hs b/src/Data/Promotion/Prelude/List.hs new file mode 100644 --- /dev/null +++ b/src/Data/Promotion/Prelude/List.hs @@ -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 + |]) diff --git a/src/Data/Promotion/Prelude/Maybe.hs b/src/Data/Promotion/Prelude/Maybe.hs new file mode 100644 --- /dev/null +++ b/src/Data/Promotion/Prelude/Maybe.hs @@ -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 diff --git a/src/Data/Promotion/Prelude/Ord.hs b/src/Data/Promotion/Prelude/Ord.hs new file mode 100644 --- /dev/null +++ b/src/Data/Promotion/Prelude/Ord.hs @@ -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 diff --git a/src/Data/Promotion/Prelude/Tuple.hs b/src/Data/Promotion/Prelude/Tuple.hs new file mode 100644 --- /dev/null +++ b/src/Data/Promotion/Prelude/Tuple.hs @@ -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 diff --git a/src/Data/Promotion/TH.hs b/src/Data/Promotion/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Promotion/TH.hs @@ -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 diff --git a/src/Data/Singletons.hs b/src/Data/Singletons.hs --- a/src/Data/Singletons.hs +++ b/src/Data/Singletons.hs @@ -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 ----------------------------------------------------- diff --git a/src/Data/Singletons/Bool.hs b/src/Data/Singletons/Bool.hs deleted file mode 100644 --- a/src/Data/Singletons/Bool.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE TemplateHaskell, DataKinds, PolyKinds, TypeFamilies, TypeOperators, - GADTs, CPP #-} - -#if __GLASGOW_HASKELL__ < 707 -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -#endif - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Bool --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines functions and datatypes relating to the singleton for 'Bool', --- including a singletons version of all the definitions in @Data.Bool@. --- --- Because many of these definitions are produced by Template Haskell, --- it is not possible to create proper Haddock documentation. Please look --- up the corresponding operation in @Data.Bool@. Also, please excuse --- the apparent repeated variable names. This is due to an interaction --- between Template Haskell and Haddock. --- ----------------------------------------------------------------------------- - -module Data.Singletons.Bool ( - -- * The 'Bool' singleton - - Sing(SFalse, STrue), - -- | Though Haddock doesn't show it, the 'Sing' instance above declares - -- constructors - -- - -- > SFalse :: Sing False - -- > STrue :: Sing True - - SBool, - -- | 'SBool' is a kind-restricted synonym for 'Sing': @type SBool (a :: Bool) = Sing a@ - - -- * Conditionals - If, sIf, - - -- * Singletons from @Data.Bool@ - Not, sNot, (:&&), (:||), (%:&&), (%:||), - - -- | The following are derived from the function 'bool' in @Data.Bool@. The extra - -- underscore is to avoid name clashes with the type 'Bool'. - Bool_, sBool_, Otherwise, sOtherwise - ) where - -import Data.Singletons -import Data.Singletons.Instances -import Data.Singletons.Singletons -import Data.Singletons.Types - -#if __GLASGOW_HASKELL__ >= 707 -import Data.Type.Bool - -type a :&& b = a && b -type a :|| b = a || b - -(%:&&) :: SBool a -> SBool b -> SBool (a :&& b) -SFalse %:&& _ = SFalse -STrue %:&& a = a - -(%:||) :: SBool a -> SBool b -> SBool (a :|| b) -SFalse %:|| a = a -STrue %:|| _ = STrue - -#else - -$(singletonsOnly [d| - (&&) :: Bool -> Bool -> Bool - False && _ = False - True && x = x - - (||) :: Bool -> Bool -> Bool - False || x = x - True || _ = True - |]) - -#endif - -sNot :: SBool a -> SBool (Not a) -sNot SFalse = STrue -sNot STrue = SFalse - --- | Conditional over singletons -sIf :: Sing a -> Sing b -> Sing c -> Sing (If a b c) -sIf STrue b _ = b -sIf SFalse _ c = c - --- ... with some functions over Booleans -$(singletonsOnly [d| - bool_ :: a -> a -> Bool -> a - bool_ fls _tru False = fls - bool_ _fls tru True = tru - - otherwise :: Bool - otherwise = True - |]) diff --git a/src/Data/Singletons/CustomStar.hs b/src/Data/Singletons/CustomStar.hs --- a/src/Data/Singletons/CustomStar.hs +++ b/src/Data/Singletons/CustomStar.hs @@ -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 diff --git a/src/Data/Singletons/Either.hs b/src/Data/Singletons/Either.hs deleted file mode 100644 --- a/src/Data/Singletons/Either.hs +++ /dev/null @@ -1,107 +0,0 @@ -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TypeFamilies, GADTs, - DataKinds, PolyKinds, RankNTypes, UndecidableInstances, CPP #-} - -#if __GLASGOW_HASKELL__ < 707 -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -#endif - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Either --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines functions and datatypes relating to the singleton for 'Either', --- including a singletons version of all the definitions in @Data.Either@. --- --- Because many of these definitions are produced by Template Haskell, --- it is not possible to create proper Haddock documentation. Please look --- up the corresponding operation in @Data.Either@. Also, please excuse --- the apparent repeated variable names. This is due to an interaction --- between Template Haskell and Haddock. --- ----------------------------------------------------------------------------- - -module Data.Singletons.Either ( - -- * The 'Either' singleton - Sing(SLeft, SRight), - -- | Though Haddock doesn't show it, the 'Sing' instance above declares - -- constructors - -- - -- > SLeft :: Sing a -> Sing (Left a) - -- > SRight :: Sing b -> Sing (Right b) - - SEither, - -- | 'SEither' is a kind-restricted synonym for 'Sing': - -- @type SEither (a :: Either x y) = Sing a@ - - -- * Singletons from @Data.Either@ - Either_, sEither_, - -- | The preceding two definitions are derived from the function 'either' in - -- @Data.Either@. The extra underscore is to avoid name clashes with the type - -- 'Either'. - - Lefts, sLefts, Rights, sRights, - PartitionEithers, sPartitionEithers, IsLeft, sIsLeft, IsRight, sIsRight - ) where - -import Data.Singletons.Instances -import Data.Singletons.TH -import Data.Singletons.List - -$(singletonsOnly [d| - -- | Case analysis for the 'Either' type. - -- If the value is @'Left' a@, apply the first function to @a@; - -- if it is @'Right' b@, apply the second function to @b@. - either_ :: (a -> c) -> (b -> c) -> Either a b -> c - either_ f _ (Left x) = f x - either_ _ g (Right y) = g y - - -- | Extracts from a list of 'Either' all the 'Left' elements - -- All the 'Left' elements are extracted in order. - - lefts :: [Either a b] -> [a] - lefts [] = [] - lefts (Left x : xs) = x : lefts xs - lefts (Right _ : xs) = lefts xs - - -- | Extracts from a list of 'Either' all the 'Right' elements - -- All the 'Right' elements are extracted in order. - - rights :: [Either a b] -> [b] - rights [] = [] - rights (Left _ : xs) = rights xs - rights (Right x : xs) = x : rights xs - - -- | Partitions a list of 'Either' into two lists - -- All the 'Left' elements are extracted, in order, to the first - -- component of the output. Similarly the 'Right' elements are extracted - -- to the second component of the output. - - partitionEithers :: [Either a b] -> ([a],[b]) - partitionEithers es = partitionEithers_aux ([], []) es - - partitionEithers_aux :: ([a],[b]) -> [Either a b] -> ([a],[b]) - partitionEithers_aux (as,bs) [] = (reverse as,reverse bs) - partitionEithers_aux (as,bs) (Left a : es) = - partitionEithers_aux (a : as, bs) es - partitionEithers_aux (as,bs) (Right b : es) = - partitionEithers_aux (as, b : bs) es - - -- | Return `True` if the given value is a `Left`-value, `False` otherwise. - -- - -- /Since: 4.7.0.0/ - isLeft :: Either a b -> Bool - isLeft (Left _) = True - isLeft (Right _) = False - - -- | Return `True` if the given value is a `Right`-value, `False` otherwise. - -- - -- /Since: 4.7.0.0/ - isRight :: Either a b -> Bool - isRight (Left _) = False - isRight (Right _) = True - |]) diff --git a/src/Data/Singletons/Eq.hs b/src/Data/Singletons/Eq.hs deleted file mode 100644 --- a/src/Data/Singletons/Eq.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE TypeOperators, DataKinds, PolyKinds, TypeFamilies, - RankNTypes, FlexibleContexts, TemplateHaskell, - UndecidableInstances, GADTs, CPP #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Eq --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines the SEq singleton version of the Eq type class. --- ------------------------------------------------------------------------------ - -module Data.Singletons.Eq ( - SEq(..), - type (==), (:==), (:/=) - ) where - -import Data.Singletons.Util -import Data.Singletons.Bool -import Data.Singletons -import Data.Singletons.Singletons -import Data.Singletons.Instances -import Data.Singletons.Types -#if __GLASGOW_HASKELL__ < 707 -import Data.Singletons.Promote ( promoteEqInstances ) -#endif - --- | A type synonym conforming to singletons naming conventions -type a :/= b = Not (a :== b) - --- | The singleton analogue of 'Eq'. Unlike the definition for 'Eq', it is required --- that instances define a body for '(%:==)'. You may also supply a body for '(%:/=)'. -class (kparam ~ 'KProxy) => SEq (kparam :: KProxy k) where - -- | Boolean equality on singletons - (%:==) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Sing (a :== b) - - -- | Boolean disequality on singletons - (%:/=) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Sing (a :/= b) - a %:/= b = sNot (a %:== b) - - -#if __GLASGOW_HASKELL__ < 707 -$(promoteEqInstances basicTypes) -- these instances are in Data.Type.Equality -#endif - -$(singEqInstancesOnly basicTypes) diff --git a/src/Data/Singletons/Instances.hs b/src/Data/Singletons/Instances.hs deleted file mode 100644 --- a/src/Data/Singletons/Instances.hs +++ /dev/null @@ -1,29 +0,0 @@ -{- Data/Singletons/Instances.hs - -(c) Richard Eisenberg 2013 -eir@cis.upenn.edu - -This (internal) module contains the main class definitions for singletons, -re-exported from various places. - --} - -{-# LANGUAGE CPP, RankNTypes, DataKinds, PolyKinds, GADTs, TypeFamilies, - FlexibleContexts, TemplateHaskell, ScopedTypeVariables, - UndecidableInstances, TypeOperators, FlexibleInstances #-} -#if __GLASGOW_HASKELL__ < 707 - -- optimizing instances of SDecide cause GHC to die (#8467) -{-# OPTIONS_GHC -O0 #-} -#endif - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Data.Singletons.Instances where - -import Data.Singletons.Singletons -import Data.Singletons.Util - --- some useful singletons -$(genSingletons basicTypes) -$(singDecideInstances basicTypes) - diff --git a/src/Data/Singletons/List.hs b/src/Data/Singletons/List.hs deleted file mode 100644 --- a/src/Data/Singletons/List.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE CPP, TypeOperators, DataKinds, PolyKinds, TypeFamilies, - TemplateHaskell, GADTs, UndecidableInstances #-} - -#if __GLASGOW_HASKELL__ < 707 -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -#endif - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.List --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines functions and datatypes relating to the singleton for '[]', --- including a singletons version of a few of the definitions in @Data.List@. --- --- Because many of these definitions are produced by Template Haskell, --- it is not possible to create proper Haddock documentation. Please look --- up the corresponding operation in @Data.List@. Also, please excuse --- the apparent repeated variable names. This is due to an interaction --- between Template Haskell and Haddock. --- ----------------------------------------------------------------------------- - -module Data.Singletons.List ( - -- * The singleton for lists - Sing(SNil, SCons), - -- | Though Haddock doesn't show it, the 'Sing' instance above declares - -- constructors - -- - -- > SNil :: Sing '[] - -- > SCons :: Sing (h :: k) -> Sing (t :: [k]) -> Sing (h ': t) - - SList, - -- | 'SList' is a kind-restricted synonym for 'Sing': @type SList (a :: [k]) = Sing a@ - - Head, Tail, sHead, sTail, - (:++), (%:++), - Reverse, sReverse - ) where - -import Data.Singletons.Instances -import Data.Singletons -import Data.Singletons.Singletons -import Data.Singletons.TypeLits - -$(singletonsOnly [d| - (++) :: [a] -> [a] -> [a] - [] ++ a = a - (h:t) ++ a = h:(t ++ a) - - head :: [a] -> a - head (a : _) = a - head [] = error "Data.Singletons.List.head: empty list" - - tail :: [a] -> [a] - tail (_ : t) = t - tail [] = error "Data.Singletons.List.tail: empty list" - - reverse :: [a] -> [a] - reverse list = reverse_aux [] list - - reverse_aux :: [a] -> [a] -> [a] - reverse_aux acc [] = acc - reverse_aux acc (h : t) = reverse_aux (h : acc) t - |]) diff --git a/src/Data/Singletons/Maybe.hs b/src/Data/Singletons/Maybe.hs deleted file mode 100644 --- a/src/Data/Singletons/Maybe.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TypeFamilies, - DataKinds, PolyKinds, UndecidableInstances, GADTs, - RankNTypes, CPP #-} - -#if __GLASGOW_HASKELL__ < 707 -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -#endif - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Maybe --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines functions and datatypes relating to the singleton for 'Maybe', --- including a singletons version of all the definitions in @Data.Maybe@. --- --- Because many of these definitions are produced by Template Haskell, --- it is not possible to create proper Haddock documentation. Please look --- up the corresponding operation in @Data.Maybe@. Also, please excuse --- the apparent repeated variable names. This is due to an interaction --- between Template Haskell and Haddock. --- ----------------------------------------------------------------------------- - - -module Data.Singletons.Maybe ( - -- The 'Maybe' singleton - - Sing(SNothing, SJust), - -- | Though Haddock doesn't show it, the 'Sing' instance above declares - -- constructors - -- - -- > SNothing :: Sing Nothing - -- > SJust :: Sing a -> Sing (Just a) - - SMaybe, - -- | 'SBool' is a kind-restricted synonym for 'Sing': @type SMaybe (a :: Maybe k) = Sing a@ - - -- * Singletons from @Data.Maybe@ - - Maybe_, sMaybe_, - -- | The preceding two definitions are derived from the function 'maybe' in - -- @Data.Maybe@. The extra underscore is to avoid name clashes with the type - -- 'Maybe'. - - IsJust, sIsJust, IsNothing, sIsNothing, - FromJust, sFromJust, FromMaybe, sFromMaybe, MaybeToList, sMaybeToList, - ListToMaybe, sListToMaybe, CatMaybes, sCatMaybes, MapMaybe, sMapMaybe - ) where - -import Data.Singletons.Instances -import Data.Singletons -import Data.Singletons.TH -import Data.Singletons.List -import Data.Singletons.TypeLits - -$(singletonsOnly [d| - -- | The 'maybe' function takes a default value, a function, and a 'Maybe' - -- value. If the 'Maybe' value is 'Nothing', the function returns the - -- default value. Otherwise, it applies the function to the value inside - -- the 'Just' and returns the result. - maybe_ :: b -> (a -> b) -> Maybe a -> b - maybe_ n _ Nothing = n - maybe_ _ f (Just x) = f x - - -- | The 'isJust' function returns 'True' iff its argument is of the - -- form @Just _@. - isJust :: Maybe a -> Bool - isJust Nothing = False - isJust (Just _) = True - - -- | The 'isNothing' function returns 'True' iff its argument is 'Nothing'. - isNothing :: Maybe a -> Bool - isNothing Nothing = True - isNothing (Just _) = False - - -- | The 'fromJust' function extracts the element out of a 'Just' and - -- throws an error if its argument is 'Nothing'. - fromJust :: Maybe a -> a - fromJust Nothing = error "Maybe.fromJust: Nothing" -- yuck - fromJust (Just x) = x - - -- | The 'fromMaybe' function takes a default value and and 'Maybe' - -- value. If the 'Maybe' is 'Nothing', it returns the default values; - -- otherwise, it returns the value contained in the 'Maybe'. - fromMaybe :: a -> Maybe a -> a - fromMaybe d Nothing = d - fromMaybe _ (Just v) = v - - -- | The 'maybeToList' function returns an empty list when given - -- 'Nothing' or a singleton list when not given 'Nothing'. - maybeToList :: Maybe a -> [a] - maybeToList Nothing = [] - maybeToList (Just x) = [x] - - -- | The 'listToMaybe' function returns 'Nothing' on an empty list - -- or @'Just' a@ where @a@ is the first element of the list. - listToMaybe :: [a] -> Maybe a - listToMaybe [] = Nothing - listToMaybe (a:_) = Just a - - -- | The 'catMaybes' function takes a list of 'Maybe's and returns - -- a list of all the 'Just' values. - catMaybes :: [Maybe a] -> [a] - catMaybes [] = [] - catMaybes (Just x : xs) = x : catMaybes xs - catMaybes (Nothing : xs) = catMaybes xs - - -- | The 'mapMaybe' function is a version of 'map' which can throw - -- out elements. In particular, the functional argument returns - -- something of type @'Maybe' b@. If this is 'Nothing', no element - -- is added on to the result list. If it just @'Just' b@, then @b@ is - -- included in the result list. - mapMaybe :: (a -> Maybe b) -> [a] -> [b] - mapMaybe _ [] = [] - mapMaybe f (x:xs) = maybeToList (f x) ++ (mapMaybe f xs) - |]) diff --git a/src/Data/Singletons/Names.hs b/src/Data/Singletons/Names.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Names.hs @@ -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 diff --git a/src/Data/Singletons/Prelude.hs b/src/Data/Singletons/Prelude.hs --- a/src/Data/Singletons/Prelude.hs +++ b/src/Data/Singletons/Prelude.hs @@ -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 diff --git a/src/Data/Singletons/Prelude/Base.hs b/src/Data/Singletons/Prelude/Base.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Prelude/Base.hs @@ -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 diff --git a/src/Data/Singletons/Prelude/Bool.hs b/src/Data/Singletons/Prelude/Bool.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Prelude/Bool.hs @@ -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 diff --git a/src/Data/Singletons/Prelude/Either.hs b/src/Data/Singletons/Prelude/Either.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Prelude/Either.hs @@ -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 + |]) diff --git a/src/Data/Singletons/Prelude/Eq.hs b/src/Data/Singletons/Prelude/Eq.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Prelude/Eq.hs @@ -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) diff --git a/src/Data/Singletons/Prelude/Instances.hs b/src/Data/Singletons/Prelude/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Prelude/Instances.hs @@ -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) diff --git a/src/Data/Singletons/Prelude/List.hs b/src/Data/Singletons/Prelude/List.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Prelude/List.hs @@ -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 diff --git a/src/Data/Singletons/Prelude/Maybe.hs b/src/Data/Singletons/Prelude/Maybe.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Prelude/Maybe.hs @@ -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 + |]) diff --git a/src/Data/Singletons/Prelude/Ord.hs b/src/Data/Singletons/Prelude/Ord.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Prelude/Ord.hs @@ -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) diff --git a/src/Data/Singletons/Prelude/Tuple.hs b/src/Data/Singletons/Prelude/Tuple.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Prelude/Tuple.hs @@ -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) + |]) diff --git a/src/Data/Singletons/Promote.hs b/src/Data/Singletons/Promote.hs --- a/src/Data/Singletons/Promote.hs +++ b/src/Data/Singletons/Promote.hs @@ -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 <> is a special case.\n" ++ - "Promoting it will not work as expected.\n" ++ - "Please choose another name for your data type.") - -checkForRepInDecls :: Quasi q => [Dec] -> q () -checkForRepInDecls decls = - checkForRep (map extractNameFromDec decls) - where extractNameFromDec :: Dec -> Name - extractNameFromDec (DataD _ name _ _ _) = name - extractNameFromDec (NewtypeD _ name _ _ _) = name - extractNameFromDec (TySynD name _ _) = name - extractNameFromDec (FamilyD _ name _ _) = name - extractNameFromDec _ = mkName "NotRep" - --- Note [Promoting declarations in two stages] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- Promoting declarations proceeds in two stages: --- 1) Promote everything except type signatures --- 2) Promote type signatures. This must be done in a second pass --- because a function type signature gets promoted to a type family --- declaration. Although function signatures do not differentiate --- between uniform parameters and non-uniform parameters, type --- family declarations do. We need to process a function's --- definition to get the count of non-uniform parameters before --- producing the type family declaration. At this point, any --- function written without a type signature is rejected and --- removed. --- --- Consider this example: --- --- foo :: Int -> Bool -> Bool --- foo 0 = id --- foo _ = not --- --- Here the first parameter to foo is non-uniform, because it is --- inspected in a pattern and can be different in each defining --- equation of foo. The second parameter to foo, specified in the type --- signature as Bool, is a uniform parameter - it is not inspected and --- each defining equation of foo uses it the same way. The foo --- function will be promoted to a type familty Foo like this: --- --- type family Foo (n :: Int) :: Bool -> Bool where --- Foo 0 = Id --- Foo a = Not --- --- To generate type signature for Foo type family we must first learn --- what is the actual number of patterns used in defining cequations --- of foo. In this case there is only one so we declare Foo to take --- one argument and have return type of Bool -> Bool. - --- Promote a list of declarations. -promoteDecs :: Quasi q => [Dec] -> q [Dec] -promoteDecs decls = do - checkForRepInDecls decls - let vartbl = Map.empty - -- See Note [Promoting declarations in two stages] - (newDecls, table) <- evalForPair $ mapM (promoteDec vartbl) decls - (declss, namess) <- mapAndUnzipM (promoteDec' table) decls - let moreNewDecls = concat declss - names = concat namess - noTypeSigs = Set.toList $ Set.difference (Map.keysSet $ -#if __GLASGOW_HASKELL__ >= 707 - Map.filter ((>= 0) . fst) table) -#else - Map.filter (>= 0) table) -#endif - (Set.fromList names) - when (not . null $ noTypeSigs) $ fail ("No type signature for functions: " - ++ intercalate ", " (map (show . nameBase) noTypeSigs) - ++ "; cannot promote or make singletons.") - return (concat newDecls ++ moreNewDecls) - --- | Produce instances for '(:==)' (type-level equality) from the given types -promoteEqInstances :: Quasi q => [Name] -> q [Dec] -promoteEqInstances = concatMapM promoteEqInstance - --- | Produce an instance for '(:==)' (type-level equality) from the given type -promoteEqInstance :: Quasi q => Name -> q [Dec] -promoteEqInstance name = do - (_tvbs, cons) <- getDataD "I cannot make an instance of (:==:) for it." name -#if __GLASGOW_HASKELL__ >= 707 - vars <- replicateM (length _tvbs) (qNewName "k") - let tyvars = map VarT vars - kind = foldType (ConT name) tyvars - inst_decs <- mkEqTypeInstance kind cons - return inst_decs -#else - let pairs = [(c1, c2) | c1 <- cons, c2 <- cons] - mapM mkEqTypeInstance pairs -#endif - -#if __GLASGOW_HASKELL__ >= 707 - --- produce a closed type family helper and the instance --- for (:==) over the given list of ctors -mkEqTypeInstance :: Quasi q => Kind -> [Con] -> q [Dec] -mkEqTypeInstance kind cons = do - helperName <- newUniqueName "Equals" - aName <- qNewName "a" - bName <- qNewName "b" - true_branches <- mapM mk_branch cons - false_branch <- false_case - let closedFam = ClosedTypeFamilyD helperName - [ KindedTV aName kind - , KindedTV bName kind ] - (Just boolTy) - (true_branches ++ [false_branch]) - eqInst = TySynInstD tyEqName (TySynEqn [ SigT (VarT aName) kind - , SigT (VarT bName) kind ] - (foldType (ConT helperName) - [VarT aName, VarT bName])) - return [closedFam, eqInst] - - where mk_branch :: Quasi q => Con -> q TySynEqn - mk_branch con = do - let (name, numArgs) = extractNameArgs con - lnames <- replicateM numArgs (qNewName "a") - rnames <- replicateM numArgs (qNewName "b") - let lvars = map VarT lnames - rvars = map VarT rnames - ltype = foldType (PromotedT name) lvars - rtype = foldType (PromotedT name) rvars - results = zipWith (\l r -> foldType (ConT tyEqName) [l, r]) lvars rvars - result = tyAll results - return $ TySynEqn [ltype, rtype] result - - false_case :: Quasi q => q TySynEqn - false_case = do - lvar <- qNewName "a" - rvar <- qNewName "b" - return $ TySynEqn [SigT (VarT lvar) kind, SigT (VarT rvar) kind] falseTy - - tyAll :: [Type] -> Type -- "all" at the type level - tyAll [] = trueTy - tyAll [one] = one - tyAll (h:t) = foldType andTy [h, (tyAll t)] - -#else - --- produce the type instance for (:==) for the given pair of constructors -mkEqTypeInstance :: Quasi q => (Con, Con) -> q Dec -mkEqTypeInstance (c1, c2) = - if c1 == c2 - then do - let (name, numArgs) = extractNameArgs c1 - lnames <- replicateM numArgs (qNewName "a") - rnames <- replicateM numArgs (qNewName "b") - let lvars = map VarT lnames - rvars = map VarT rnames - return $ TySynInstD - tyEqName - [foldType (PromotedT name) lvars, - foldType (PromotedT name) rvars] - (tyAll (zipWith (\l r -> foldType (ConT tyEqName) [l, r]) - lvars rvars)) - else do - let (lname, lNumArgs) = extractNameArgs c1 - (rname, rNumArgs) = extractNameArgs c2 - lnames <- replicateM lNumArgs (qNewName "a") - rnames <- replicateM rNumArgs (qNewName "b") - return $ TySynInstD - tyEqName - [foldType (PromotedT lname) (map VarT lnames), - foldType (PromotedT rname) (map VarT rnames)] - falseTy - where tyAll :: [Type] -> Type -- "all" at the type level - tyAll [] = trueTy - tyAll [one] = one - tyAll (h:t) = foldType andTy [h, (tyAll t)] - -#endif - --- keeps track of the number of non-uniform parameters to promoted values --- and all of the instance equations for those values -#if __GLASGOW_HASKELL__ >= 707 -type PromoteTable = Map.Map Name (Int, [TySynEqn]) -#else -type PromoteTable = Map.Map Name Int -#endif -type PromoteQ q = QWithAux PromoteTable q - --- used when a type is declared as a type synonym, not a type family --- no need to declare "type family ..." for these -typeSynonymFlag :: Int -typeSynonymFlag = -1 - -promoteDec :: Quasi q => TypeTable -> Dec -> PromoteQ q [Dec] -promoteDec vars (FunD name clauses) = do - let proName = promoteValName name - vars' = Map.insert name (promoteVal name) vars - numArgs = getNumPats (head clauses) -- count the parameters - -- Haskell requires all clauses to have the same number of parameters - (eqns, instDecls) <- evalForPair $ - mapM (promoteClause vars' proName) clauses -#if __GLASGOW_HASKELL__ >= 707 - addBinding name (numArgs, eqns) -- remember the number of parameters and the eqns - return instDecls -#else - addBinding name numArgs -- remember the number of parameters - return $ eqns ++ instDecls -#endif - where getNumPats :: Clause -> Int - getNumPats (Clause pats _ _) = length pats -promoteDec vars (ValD pat body decs) = do - -- see also the comment for promoteTopLevelPat - when (length decs > 0) - (fail $ "Promotion of global variable with <> clause " ++ - "not yet supported") - (rhs, decls) <- evalForPair $ promoteBody vars body - (lhss, decls') <- evalForPair $ promoteTopLevelPat pat - -- just use "type" decls -#if __GLASGOW_HASKELL__ >= 707 - mapM_ (flip addBinding (typeSynonymFlag, [])) (map lhsRawName lhss) -#else - mapM_ (flip addBinding typeSynonymFlag) (map lhsRawName lhss) -#endif - return $ (map (\(LHS _ nm hole) -> TySynD nm [] (hole rhs)) lhss) ++ - decls ++ decls' -promoteDec vars (DataD cxt name tvbs ctors derivings) = - promoteDataD vars cxt name tvbs ctors derivings -promoteDec vars (NewtypeD cxt name tvbs ctor derivings) = - promoteDataD vars cxt name tvbs [ctor] derivings -promoteDec _vars (TySynD _name _tvbs _ty) = - fail "Promotion of type synonym declaration not yet supported" -promoteDec _vars (ClassD _cxt _name _tvbs _fundeps _decs) = - fail "Promotion of class declaration not yet supported" -promoteDec _vars (InstanceD _cxt _ty _decs) = - fail "Promotion of instance declaration not yet supported" -promoteDec _vars (SigD _name _ty) = return [] -- handle in promoteDec' -promoteDec _vars (ForeignD _fgn) = - fail "Promotion of foreign function declaration not yet supported" -promoteDec _vars (InfixD fixity name) - | isUpcase name = return [] -- automatic: promoting a type or data ctor - | otherwise = return [InfixD fixity (promoteValName name)] -- value -promoteDec _vars (PragmaD _prag) = - fail "Promotion of pragmas not yet supported" -promoteDec _vars (FamilyD _flavour _name _tvbs _mkind) = - fail "Promotion of type and data families not yet supported" -promoteDec _vars (DataInstD _cxt _name _tys _ctors _derivings) = - fail "Promotion of data instances not yet supported" -promoteDec _vars (NewtypeInstD _cxt _name _tys _ctors _derivings) = - fail "Promotion of newtype instances not yet supported" -#if __GLASGOW_HASKELL__ >= 707 -promoteDec _vars (RoleAnnotD _name _roles) = - return [] -- silently ignore role annotations, as they're harmless here -promoteDec _vars (ClosedTypeFamilyD _name _tvs _mkind _eqns) = - fail "Promotion of closed type families not yet supported" -promoteDec _vars (TySynInstD _name _eqn) = -#else -promoteDec _vars (TySynInstD _name _lhs _rhs) = -#endif - fail "Promotion of type synonym instances not yet supported" - --- only need to check if the datatype derives Eq. The rest is automatic. -promoteDataD :: Quasi q => TypeTable -> Cxt -> Name -> [TyVarBndr] -> [Con] -> - [Name] -> PromoteQ q [Dec] -promoteDataD _vars _cxt _name _tvbs ctors derivings = - if any (\n -> (nameBase n) == "Eq") derivings - then do -#if __GLASGOW_HASKELL__ >= 707 - kvs <- replicateM (length _tvbs) (qNewName "k") - inst_decs <- mkEqTypeInstance (foldType (ConT _name) (map VarT kvs)) ctors - return inst_decs -#else - let pairs = [ (c1, c2) | c1 <- ctors, c2 <- ctors ] - mapM mkEqTypeInstance pairs -#endif - else return [] -- the actual promotion is automatic - --- second pass through declarations to deal with type signatures --- returns the new declarations and the list of names that have been --- processed -promoteDec' :: Quasi q => PromoteTable -> Dec -> q ([Dec], [Name]) -promoteDec' tab (SigD name ty) = case Map.lookup name tab of - Nothing -> fail $ "Type declaration is missing its binding: " ++ (show name) -#if __GLASGOW_HASKELL__ >= 707 - Just (numArgs, eqns) -> -#else - Just numArgs -> -#endif - -- if there are no args, then use a type synonym, not a type family - -- in the type synonym case, we ignore the type signature - if numArgs == typeSynonymFlag then return $ ([], [name]) else do - k <- promoteType ty - let ks = unravel k - (argKs, resultKs) = splitAt numArgs ks -- divide by uniformity - resultK <- ravel resultKs -- rebuild the arrow kind - tyvarNames <- mapM qNewName (replicate (length argKs) "a") -#if __GLASGOW_HASKELL__ >= 707 - return ([ClosedTypeFamilyD (promoteValName name) - (zipWith KindedTV tyvarNames argKs) - (Just resultK) - eqns], [name]) -#else - return ([FamilyD TypeFam - (promoteValName name) - (zipWith KindedTV tyvarNames argKs) - (Just resultK)], [name]) -#endif - where unravel :: Kind -> [Kind] -- get argument kinds from an arrow kind - unravel (AppT (AppT ArrowT k1) k2) = - let ks = unravel k2 in k1 : ks - unravel k = [k] - - ravel :: Quasi q => [Kind] -> q Kind - ravel [] = fail "Internal error: raveling nil" - ravel [k] = return k - ravel (h:t) = do - k <- ravel t - return $ (AppT (AppT ArrowT h) k) -promoteDec' _ _ = return ([], []) - -#if __GLASGOW_HASKELL__ >= 707 -promoteClause :: Quasi q => TypeTable -> Name -> Clause -> QWithDecs q TySynEqn -#else -promoteClause :: Quasi q => TypeTable -> Name -> Clause -> QWithDecs q Dec -#endif -promoteClause vars _name (Clause pats body []) = do - -- promoting the patterns creates variable bindings. These are passed - -- to the function promoted the RHS - (types, vartbl) <- evalForPair $ mapM promotePat pats - let vars' = Map.union vars vartbl - ty <- promoteBody vars' body -#if __GLASGOW_HASKELL__ >= 707 - return $ TySynEqn types ty -#else - return $ TySynInstD _name types ty -#endif -promoteClause _ _ (Clause _ _ (_:_)) = - fail "A <> clause in a function definition is not yet supported" - --- the LHS of a top-level expression is a name and "type with hole" --- the hole is filled in by the RHS -data TopLevelLHS = LHS { lhsRawName :: Name -- the unpromoted name - , lhsName :: Name - , lhsHole :: Type -> Type - } - --- Treatment of top-level patterns is different from other patterns --- because type families have type patterns as their LHS. However, --- it is not possible to use type patterns at the top level, so we --- have to use other techniques. -promoteTopLevelPat :: Quasi q => Pat -> QWithDecs q [TopLevelLHS] -promoteTopLevelPat (LitP _) = fail "Cannot declare a global literal." -promoteTopLevelPat (VarP name) = return [LHS name (promoteValName name) id] -promoteTopLevelPat (TupP pats) = case length pats of - 0 -> return [] -- unit as LHS of pattern... ignore - 1 -> fail "1-tuple encountered during top-level pattern promotion" - n -> promoteTopLevelPat (ConP (tupleDataName n) pats) -promoteTopLevelPat (UnboxedTupP _) = - fail "Promotion of unboxed tuples not supported" - --- to promote a constructor pattern, we need to create extraction type --- families to pull out the individual arguments of the constructor -promoteTopLevelPat (ConP name pats) = do - ctorInfo <- reifyWithWarning name - (ctorType, argTypes) <- extractTypes ctorInfo - when (length argTypes /= length pats) $ - fail $ "Inconsistent data constructor pattern: " ++ (show name) ++ " " ++ - (show pats) - kind <- promoteType ctorType - argKinds <- mapM promoteType argTypes - extractorNames <- replicateM (length pats) (newUniqueName "Extract") - - varName <- qNewName "a" - zipWithM_ (\nm arg -> addElement $ FamilyD TypeFam - nm - [KindedTV varName kind] - (Just arg)) - extractorNames argKinds - componentNames <- replicateM (length pats) (qNewName "a") - zipWithM_ (\extractorName componentName -> - addElement $ mkTyFamInst extractorName - [foldType (PromotedT name) - (map VarT componentNames)] - (VarT componentName)) - extractorNames componentNames - - -- now we have the extractor families. Use the appropriate families - -- in the "holes" - promotedPats <- mapM promoteTopLevelPat pats - return $ concat $ - zipWith (\lhslist extractor -> - map (\(LHS raw nm hole) -> LHS raw nm - (hole . (AppT (ConT extractor)))) - lhslist) - promotedPats extractorNames - where extractTypes :: Quasi q => Info -> q (Type, [Type]) - extractTypes (DataConI datacon _dataconTy tyname _fixity) = do - tyinfo <- reifyWithWarning tyname - extractTypesHelper datacon tyinfo - extractTypes _ = fail "Internal error: unexpected Info in extractTypes" - - extractTypesHelper :: Quasi q => Name -> Info -> q (Type, [Type]) - extractTypesHelper datacon - (TyConI (DataD _cxt tyname tvbs cons _derivs)) = - let mcon = find ((== datacon) . fst . extractNameArgs) cons in - case mcon of - Nothing -> fail $ "Internal error reifying " ++ (show datacon) - Just con -> return (foldType (ConT tyname) - (map (VarT . extractTvbName) tvbs), - extractConArgs con) - extractTypesHelper datacon - (TyConI (NewtypeD cxt tyname tvbs con derivs)) = - extractTypesHelper datacon (TyConI (DataD cxt tyname tvbs [con] derivs)) - extractTypesHelper datacon _ = - fail $ "Cannot promote data constructor " ++ (show datacon) - - extractConArgs :: Con -> [Type] - extractConArgs = ctor1Case (\_ tys -> tys) -promoteTopLevelPat (InfixP l name r) = promoteTopLevelPat (ConP name [l, r]) -promoteTopLevelPat (UInfixP _ _ _) = - fail "Unresolved infix constructors not supported" -promoteTopLevelPat (ParensP _) = - fail "Unresolved infix constructors not supported" -promoteTopLevelPat (TildeP pat) = do - qReportWarning "Lazy pattern converted into regular pattern in promotion" - promoteTopLevelPat pat -promoteTopLevelPat (BangP pat) = do - qReportWarning "Strict pattern converted into regular pattern in promotion" - promoteTopLevelPat pat -promoteTopLevelPat (AsP _name _pat) = - fail "Promotion of aliased patterns at top level not yet supported" -promoteTopLevelPat WildP = return [] -promoteTopLevelPat (RecP _ _) = - fail "Promotion of record patterns at top level not yet supported" - --- must do a similar trick as what is in the ConP case, but this is easier --- because Lib defined Head and Tail -promoteTopLevelPat (ListP pats) = do - promotedPats <- mapM promoteTopLevelPat pats - return $ concat $ snd $ - mapAccumL (\extractFn lhss -> - ((AppT tailTyFam) . extractFn, - map (\(LHS raw nm hole) -> - LHS raw nm (hole . (AppT headTyFam) . extractFn)) lhss)) - id promotedPats -promoteTopLevelPat (SigP pat _) = do - qReportWarning $ "Promotion of explicit type annotation in pattern " ++ - "not yet supported." - promoteTopLevelPat pat -promoteTopLevelPat (ViewP _ _) = - fail "Promotion of view patterns not yet supported" - -type TypesQ q = QWithAux TypeTable q - --- promotes a term pattern into a type pattern, accumulating variable --- binding in the auxiliary TypeTable -promotePat :: Quasi q => Pat -> TypesQ q Type -promotePat (LitP lit) = promoteLit lit -promotePat (VarP name) = do - tyVar <- qNewName (nameBase name) - addBinding name (VarT tyVar) - return $ VarT tyVar -promotePat (TupP pats) = do - types <- mapM promotePat pats - let baseTup = PromotedTupleT (length types) - tup = foldType baseTup types - return tup -promotePat (UnboxedTupP _) = fail "Unboxed tuples not supported" -promotePat (ConP name pats) = do - types <- mapM promotePat pats - let tyCon = foldType (PromotedT name) types - return tyCon -promotePat (InfixP pat1 name pat2) = promotePat (ConP name [pat1, pat2]) -promotePat (UInfixP _ _ _) = fail "Unresolved infix constructions not supported" -promotePat (ParensP _) = fail "Unresolved infix constructions not supported" -promotePat (TildeP pat) = do - qReportWarning "Lazy pattern converted into regular pattern in promotion" - promotePat pat -promotePat (BangP pat) = do - qReportWarning "Strict pattern converted into regular pattern in promotion" - promotePat pat -promotePat (AsP name pat) = do - ty <- promotePat pat - addBinding name ty - return ty -promotePat WildP = do - name <- qNewName "z" - return $ VarT name -promotePat (RecP _ _) = fail "Promotion of record patterns not yet supported" -promotePat (ListP pats) = do - types <- mapM promotePat pats - return $ foldr (\h t -> AppT (AppT PromotedConsT h) t) PromotedNilT types -promotePat (SigP pat _) = do - qReportWarning $ "Promotion of explicit type annotation in pattern " ++ - "not yet supported" - promotePat pat -promotePat (ViewP _ _) = fail "View patterns not yet supported" - --- promoting a body may produce auxiliary declarations. Accumulate these. -type QWithDecs q = QWithAux [Dec] q - -promoteBody :: Quasi q => TypeTable -> Body -> QWithDecs q Type -promoteBody vars (NormalB exp) = promoteExp vars exp -promoteBody _vars (GuardedB _) = - fail "Promoting guards in patterns not yet supported" - -promoteExp :: Quasi q => TypeTable -> Exp -> QWithDecs q Type -promoteExp vars (VarE name) = case Map.lookup name vars of - Just ty -> return ty - Nothing -> return $ promoteVal name -promoteExp _vars (ConE name) = return $ PromotedT name -promoteExp _vars (LitE lit) = promoteLit lit -promoteExp vars (AppE exp1 exp2) = do - ty1 <- promoteExp vars exp1 - ty2 <- promoteExp vars exp2 - return $ AppT ty1 ty2 -promoteExp vars (InfixE mexp1 exp mexp2) = - case (mexp1, mexp2) of - (Nothing, Nothing) -> promoteExp vars exp - (Just exp1, Nothing) -> promoteExp vars (AppE exp exp1) - (Nothing, Just _exp2) -> - fail "Promotion of right-only sections not yet supported" - (Just exp1, Just exp2) -> promoteExp vars (AppE (AppE exp exp1) exp2) -promoteExp _vars (UInfixE _ _ _) = - fail "Promotion of unresolved infix operators not supported" -promoteExp _vars (ParensE _) = fail "Promotion of unresolved parens not supported" -promoteExp _vars (LamE _pats _exp) = - fail "Promotion of lambda expressions not yet supported" -promoteExp _vars (LamCaseE _alts) = - fail "Promotion of lambda-case expressions not yet supported" -promoteExp vars (TupE exps) = do - tys <- mapM (promoteExp vars) exps - let tuple = PromotedTupleT (length tys) - tup = foldType tuple tys - return tup -promoteExp _vars (UnboxedTupE _) = fail "Promotion of unboxed tuples not supported" -promoteExp vars (CondE bexp texp fexp) = do - tys <- mapM (promoteExp vars) [bexp, texp, fexp] - return $ foldType ifTyFam tys -promoteExp _vars (MultiIfE _alts) = - fail "Promotion of multi-way if not yet supported" -promoteExp _vars (LetE _decs _exp) = - fail "Promotion of let statements not yet supported" -promoteExp _vars (CaseE _exp _matches) = - fail "Promotion of case statements not yet supported" -promoteExp _vars (DoE _stmts) = fail "Promotion of do statements not supported" -promoteExp _vars (CompE _stmts) = - fail "Promotion of list comprehensions not yet supported" -promoteExp _vars (ArithSeqE _) = fail "Promotion of ranges not supported" -promoteExp vars (ListE exps) = do - tys <- mapM (promoteExp vars) exps - return $ foldr (\ty lst -> AppT (AppT PromotedConsT ty) lst) PromotedNilT tys -promoteExp _vars (SigE _exp _ty) = - fail "Promotion of explicit type annotations not yet supported" -promoteExp _vars (RecConE _name _fields) = - fail "Promotion of record construction not yet supported" -promoteExp _vars (RecUpdE _exp _fields) = - fail "Promotion of record updates not yet supported" - -promoteLit :: Monad m => Lit -> m Type -promoteLit (IntegerL n) - | n >= 0 = return $ LitT (NumTyLit n) - | otherwise = fail ("Promoting negative integers not supported: " ++ (show n)) -promoteLit (StringL str) = return $ LitT (StrTyLit str) +{-# 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 <> 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) diff --git a/src/Data/Singletons/Promote/Bounded.hs b/src/Data/Singletons/Promote/Bounded.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Promote/Bounded.hs @@ -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" diff --git a/src/Data/Singletons/Promote/Defun.hs b/src/Data/Singletons/Promote/Defun.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Promote/Defun.hs @@ -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)) diff --git a/src/Data/Singletons/Promote/Eq.hs b/src/Data/Singletons/Promote/Eq.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Promote/Eq.hs @@ -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 diff --git a/src/Data/Singletons/Promote/Monad.hs b/src/Data/Singletons/Promote/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Promote/Monad.hs @@ -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 + diff --git a/src/Data/Singletons/Promote/Ord.hs b/src/Data/Singletons/Promote/Ord.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Promote/Ord.hs @@ -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 ) + +-} diff --git a/src/Data/Singletons/Promote/Type.hs b/src/Data/Singletons/Promote/Type.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Promote/Type.hs @@ -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 diff --git a/src/Data/Singletons/Single.hs b/src/Data/Singletons/Single.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Single.hs @@ -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 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)) diff --git a/src/Data/Singletons/Single/Data.hs b/src/Data/Singletons/Single/Data.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Single/Data.hs @@ -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' diff --git a/src/Data/Singletons/Single/Eq.hs b/src/Data/Singletons/Single/Eq.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Single/Eq.hs @@ -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 diff --git a/src/Data/Singletons/Single/Monad.hs b/src/Data/Singletons/Single/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Single/Monad.hs @@ -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 diff --git a/src/Data/Singletons/Single/Type.hs b/src/Data/Singletons/Single/Type.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Single/Type.hs @@ -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) diff --git a/src/Data/Singletons/Singletons.hs b/src/Data/Singletons/Singletons.hs deleted file mode 100644 --- a/src/Data/Singletons/Singletons.hs +++ /dev/null @@ -1,738 +0,0 @@ -{- Data/Singletons/Singletons.hs - -(c) Richard Eisenberg 2013 -eir@cis.upenn.edu - -This file contains functions to refine constructs to work with singleton -types. It is an internal module to the singletons package. --} -{-# LANGUAGE TemplateHaskell, CPP, TupleSections #-} - -module Data.Singletons.Singletons where - -import Prelude hiding ( exp ) -import Language.Haskell.TH hiding ( cxt ) -import Language.Haskell.TH.Syntax (falseName, trueName, Quasi(..)) -import Data.Singletons.Util -import Data.Singletons.Promote -import Data.Singletons -import Data.Singletons.Decide -import qualified Data.Map as Map -import Control.Monad -import Control.Applicative - --- map to track bound variables -type ExpTable = Map.Map Name Exp - --- translating a type gives a type with a hole in it, --- represented here as a function -type TypeFn = Type -> Type - --- a list of argument types extracted from a type application -type TypeContext = [Type] - -singFamilyName, singIName, singMethName, demoteRepName, singKindClassName, - sEqClassName, sEqMethName, sconsName, snilName, sIfName, undefinedName, - kProxyDataName, kProxyTypeName, someSingTypeName, someSingDataName, - nilName, consName, sListName, eqName, sDecideClassName, sDecideMethName, - provedName, disprovedName, reflName, toSingName, fromSingName, listName :: Name -singFamilyName = ''Sing -singIName = ''SingI -singMethName = 'sing -toSingName = 'toSing -fromSingName = 'fromSing -demoteRepName = ''DemoteRep -singKindClassName = ''SingKind -sEqClassName = mkName "SEq" -sEqMethName = mkName "%:==" -sIfName = mkName "sIf" -undefinedName = 'undefined -sconsName = mkName "SCons" -snilName = mkName "SNil" -kProxyDataName = 'KProxy -kProxyTypeName = ''KProxy -someSingTypeName = ''SomeSing -someSingDataName = 'SomeSing -nilName = '[] -consName = '(:) -listName = ''[] -sListName = mkName "SList" -eqName = ''Eq -sDecideClassName = ''SDecide -sDecideMethName = '(%~) -provedName = 'Proved -disprovedName = 'Disproved -reflName = 'Refl - -mkTupleName :: Int -> Name -mkTupleName n = mkName $ "STuple" ++ (show n) - -singFamily :: Type -singFamily = ConT singFamilyName - -singKindConstraint :: Kind -> Pred -singKindConstraint k = ClassP singKindClassName [kindParam k] - -demote :: Type -demote = ConT demoteRepName - -singDataConName :: Name -> Name -singDataConName nm - | nm == nilName = snilName - | nm == consName = sconsName - | Just degree <- tupleNameDegree_maybe nm = mkTupleName degree - | otherwise = prefixUCName "S" ":%" nm - -singTyConName :: Name -> Name -singTyConName name - | name == listName = sListName - | Just degree <- tupleNameDegree_maybe name = mkTupleName degree - | otherwise = prefixUCName "S" ":%" name - -singClassName :: Name -> Name -singClassName = singTyConName - -singDataCon :: Name -> Exp -singDataCon = ConE . singDataConName - -singValName :: Name -> Name -singValName n - | nameBase n == "undefined" = undefinedName - | otherwise = (prefixLCName "s" "%") $ upcase n - -singVal :: Name -> Exp -singVal = VarE . singValName - -kindParam :: Kind -> Type -kindParam k = SigT (ConT kProxyDataName) (AppT (ConT kProxyTypeName) k) - --- | Generate singleton definitions from a type that is already defined. --- For example, the singletons package itself uses --- --- > $(genSingletons [''Bool, ''Maybe, ''Either, ''[]]) --- --- to generate singletons for Prelude types. -genSingletons :: Quasi q => [Name] -> q [Dec] -genSingletons names = do - checkForRep names - concatMapM (singInfo <=< reifyWithWarning) names - -singInfo :: Quasi q => Info -> q [Dec] -singInfo (ClassI _dec _instances) = - fail "Singling of class info not supported" -singInfo (ClassOpI _name _ty _className _fixity) = - fail "Singling of class members info not supported" -singInfo (TyConI dec) = singDec dec -singInfo (FamilyI _dec _instances) = - fail "Singling of type family info not yet supported" -- KindFams -singInfo (PrimTyConI _name _numArgs _unlifted) = - fail "Singling of primitive type constructors not supported" -singInfo (DataConI _name _ty _tyname _fixity) = - fail $ "Singling of individual constructors not supported; " ++ - "single the type instead" -singInfo (VarI _name _ty _mdec _fixity) = - fail "Singling of value info not supported" -singInfo (TyVarI _name _ty) = - fail "Singling of type variable info not supported" - --- refine a constructor. the first parameter is the type variable that --- the singleton GADT is parameterized by --- runs in the QWithDecs monad because auxiliary declarations are produced -singCtor :: Quasi q => Type -> Con -> QWithDecs q Con -singCtor a = ctorCases - -- monomorphic case - (\name types -> do - let sName = singDataConName name - sCon = singDataCon name - pCon = PromotedT name - indexNames <- replicateM (length types) (qNewName "n") - let indices = map VarT indexNames - kinds <- mapM promoteType types - args <- buildArgTypes types indices - let tvbs = zipWith KindedTV indexNames kinds - kindedIndices = zipWith SigT indices kinds - - -- SingI instance - addElement $ InstanceD (map (ClassP singIName . listify) indices) - (AppT (ConT singIName) - (foldType pCon kindedIndices)) - [ValD (VarP singMethName) - (NormalB $ foldExp sCon (replicate (length types) - (VarE singMethName))) - []] - - return $ ForallC tvbs - [EqualP a (foldType pCon indices)] - (NormalC sName $ map (NotStrict,) args)) - - -- polymorphic case - (\_tvbs cxt ctor -> case cxt of - _:_ -> fail "Singling of constrained constructors not yet supported" - [] -> singCtor a ctor) -- polymorphic constructors are handled just - -- like monomorphic ones -- the polymorphism in - -- the kind is automatic - where buildArgTypes :: Quasi q => [Type] -> [Type] -> q [Type] - buildArgTypes types indices = do - typeFns <- mapM singType types - return $ zipWith id typeFns indices - --- | Make promoted and singleton versions of all declarations given, retaining --- the original declarations. --- See for --- further explanation. -singletons :: Quasi q => q [Dec] -> q [Dec] -singletons = (>>= singDecs True) - --- | Make promoted and singleton versions of all declarations given, discarding --- the original declarations. -singletonsOnly :: Quasi q => q [Dec] -> q [Dec] -singletonsOnly = (>>= singDecs False) - --- first parameter says whether or not to include original decls -singDecs :: Quasi q => Bool -> [Dec] -> q [Dec] -singDecs originals decls = do - promDecls <- promoteDecs decls - newDecls <- mapM singDec decls - return $ (if originals then (decls ++) else id) $ promDecls ++ (concat newDecls) - -singDec :: Quasi q => Dec -> q [Dec] -singDec (FunD name clauses) = do - let sName = singValName name - vars = Map.singleton name (VarE sName) - listify <$> FunD sName <$> (mapM (singClause vars) clauses) -singDec (ValD _ (GuardedB _) _) = - fail "Singling of definitions of values with a pattern guard not yet supported" -singDec (ValD _ _ (_:_)) = - fail "Singling of definitions of values with a <> clause not yet supported" -singDec (ValD pat (NormalB exp) []) = do - (sPat, vartbl) <- evalForPair $ singPat TopLevel pat - sExp <- singExp vartbl exp - return [ValD sPat (NormalB sExp) []] -singDec (DataD cxt name tvbs ctors derivings) = - singDataD False cxt name tvbs ctors derivings -singDec (NewtypeD cxt name tvbs ctor derivings) = - singDataD False cxt name tvbs [ctor] derivings -singDec (TySynD _name _tvbs _ty) = - fail "Singling of type synonyms not yet supported" -singDec (ClassD _cxt _name _tvbs _fundeps _decs) = - fail "Singling of class declaration not yet supported" -singDec (InstanceD _cxt _ty _decs) = - fail "Singling of class instance not yet supported" -singDec (SigD name ty) = do - tyTrans <- singType ty - return [SigD (singValName name) (tyTrans (promoteVal name))] -singDec (ForeignD fgn) = - let name = extractName fgn in do - qReportWarning $ "Singling of foreign functions not supported -- " ++ - (show name) ++ " ignored" - return [] - where extractName :: Foreign -> Name - extractName (ImportF _ _ _ n _) = n - extractName (ExportF _ _ n _) = n -singDec (InfixD fixity name) - | isUpcase name = return [InfixD fixity (singDataConName name)] - | otherwise = return [InfixD fixity (singValName name)] -singDec (PragmaD _prag) = do - qReportWarning "Singling of pragmas not supported" - return [] -singDec (FamilyD _flavour _name _tvbs _mkind) = - fail "Singling of type and data families not yet supported" -singDec (DataInstD _cxt _name _tys _ctors _derivings) = - fail "Singling of data instances not yet supported" -singDec (NewtypeInstD _cxt _name _tys _ctor _derivings) = - fail "Singling of newtype instances not yet supported" -#if __GLASGOW_HASKELL__ >= 707 -singDec (RoleAnnotD _name _roles) = - return [] -- silently ignore role annotations, as they're harmless -singDec (ClosedTypeFamilyD _name _tvs _mkind _eqns) = - fail "Singling of closed type families not yet supported" -singDec (TySynInstD _name _eqns) = -#else -singDec (TySynInstD _name _lhs _rhs) = -#endif - fail "Singling of type family instances not yet supported" - --- | Create instances of 'SEq' and type-level '(:==)' for each type in the list -singEqInstances :: Quasi q => [Name] -> q [Dec] -singEqInstances = concatMapM singEqInstance - --- | Create instance of 'SEq' and type-level '(:==)' for the given type -singEqInstance :: Quasi q => Name -> q [Dec] -singEqInstance name = do - promotion <- promoteEqInstance name - dec <- singEqualityInstance sEqClassDesc name - return $ dec : promotion - --- | Create instances of 'SEq' (only -- no instance for '(:==)', which 'SEq' generally --- relies on) for each type in the list -singEqInstancesOnly :: Quasi q => [Name] -> q [Dec] -singEqInstancesOnly = concatMapM singEqInstanceOnly - --- | Create instances of 'SEq' (only -- no instance for '(:==)', which 'SEq' generally --- relies on) for the given type -singEqInstanceOnly :: Quasi q => Name -> q [Dec] -singEqInstanceOnly name = listify <$> singEqualityInstance sEqClassDesc name - --- | Create instances of 'SDecide' for each type in the list. --- --- Note that, due to a bug in GHC 7.6.3 (and lower) optimizing instances --- for SDecide can make GHC hang. You may want to put --- @{-# OPTIONS_GHC -O0 #-}@ in your file. -singDecideInstances :: Quasi q => [Name] -> q [Dec] -singDecideInstances = concatMapM singDecideInstance - --- | Create instance of 'SDecide' for the given type. --- --- Note that, due to a bug in GHC 7.6.3 (and lower) optimizing instances --- for SDecide can make GHC hang. You may want to put --- @{-# OPTIONS_GHC -O0 #-}@ in your file. -singDecideInstance :: Quasi q => Name -> q [Dec] -singDecideInstance name = listify <$> singEqualityInstance sDecideClassDesc name - --- generalized function for creating equality instances -singEqualityInstance :: Quasi q => EqualityClassDesc q -> Name -> q Dec -singEqualityInstance desc@(_, className, _) name = do - (tvbs, cons) <- getDataD ("I cannot make an instance of " ++ - show className ++ " for it.") name - let tyvars = map (VarT . extractTvbName) tvbs - kind = foldType (ConT name) tyvars - aName <- qNewName "a" - let aVar = VarT aName - scons <- mapM (evalWithoutAux . singCtor aVar) cons - mkEqualityInstance kind scons desc - --- making the SEq instance and the SDecide instance are rather similar, --- so we generalize -type EqualityClassDesc q = ((Con, Con) -> q Clause, Name, Name) -sEqClassDesc, sDecideClassDesc :: Quasi q => EqualityClassDesc q -sEqClassDesc = (mkEqMethClause, sEqClassName, sEqMethName) -sDecideClassDesc = (mkDecideMethClause, sDecideClassName, sDecideMethName) - --- pass the *singleton* constructors, not the originals -mkEqualityInstance :: Quasi q => Kind -> [Con] - -> EqualityClassDesc q -> q Dec -mkEqualityInstance k ctors (mkMeth, className, methName) = do - let ctorPairs = [ (c1, c2) | c1 <- ctors, c2 <- ctors ] - methClauses <- if null ctors - then mkEmptyMethClauses - else mapM mkMeth ctorPairs - return $ InstanceD (map (\kvar -> ClassP className [kindParam kvar]) - (getKindVars k)) - (AppT (ConT className) - (kindParam k)) - [FunD methName methClauses] - where getKindVars :: Kind -> [Kind] - getKindVars (AppT l r) = getKindVars l ++ getKindVars r - getKindVars (VarT x) = [VarT x] - getKindVars (ConT _) = [] - getKindVars StarT = [] - getKindVars other = - error ("getKindVars sees an unusual kind: " ++ show other) - - mkEmptyMethClauses :: Quasi q => q [Clause] - mkEmptyMethClauses = do - a <- qNewName "a" - return [Clause [VarP a, WildP] (NormalB (CaseE (VarE a) emptyMatches)) []] - -mkEqMethClause :: Quasi q => (Con, Con) -> q Clause -mkEqMethClause (c1, c2) - | lname == rname = do - lnames <- replicateM lNumArgs (qNewName "a") - rnames <- replicateM lNumArgs (qNewName "b") - let lpats = map VarP lnames - rpats = map VarP rnames - lvars = map VarE lnames - rvars = map VarE rnames - return $ Clause - [ConP lname lpats, ConP rname rpats] - (NormalB $ - allExp (zipWith (\l r -> foldExp (VarE sEqMethName) [l, r]) - lvars rvars)) - [] - | otherwise = - return $ Clause - [ConP lname (replicate lNumArgs WildP), - ConP rname (replicate rNumArgs WildP)] - (NormalB (singDataCon falseName)) - [] - where allExp :: [Exp] -> Exp - allExp [] = singDataCon trueName - allExp [one] = one - allExp (h:t) = AppE (AppE (singVal andName) h) (allExp t) - - (lname, lNumArgs) = extractNameArgs c1 - (rname, rNumArgs) = extractNameArgs c2 - -mkDecideMethClause :: Quasi q => (Con, Con) -> q Clause -mkDecideMethClause (c1, c2) - | lname == rname = - if lNumArgs == 0 - then return $ Clause [ConP lname [], ConP rname []] - (NormalB (AppE (ConE provedName) (ConE reflName))) [] - else do - lnames <- replicateM lNumArgs (qNewName "a") - rnames <- replicateM lNumArgs (qNewName "b") - contra <- qNewName "contra" - let lpats = map VarP lnames - rpats = map VarP rnames - lvars = map VarE lnames - rvars = map VarE rnames - return $ Clause - [ConP lname lpats, ConP rname rpats] - (NormalB $ - CaseE (mkTupleExp $ - zipWith (\l r -> foldExp (VarE sDecideMethName) [l, r]) - lvars rvars) - ((Match (mkTuplePat (replicate lNumArgs - (ConP provedName [ConP reflName []]))) - (NormalB $ AppE (ConE provedName) (ConE reflName)) - []) : - [Match (mkTuplePat (replicate i WildP ++ - ConP disprovedName [VarP contra] : - replicate (lNumArgs - i - 1) WildP)) - (NormalB $ AppE (ConE disprovedName) - (LamE [ConP reflName []] - (AppE (VarE contra) - (ConE reflName)))) - [] | i <- [0..lNumArgs-1] ])) - [] - - | otherwise = - return $ Clause - [ConP lname (replicate lNumArgs WildP), - ConP rname (replicate rNumArgs WildP)] - (NormalB (AppE (ConE disprovedName) (LamCaseE emptyMatches))) - [] - - where - (lname, lNumArgs) = extractNameArgs c1 - (rname, rNumArgs) = extractNameArgs c2 - --- the first parameter is True when we're refining the special case "Rep" --- and false otherwise. We wish to consider the promotion of "Rep" to be * --- not a promoted data constructor. -singDataD :: Quasi q => Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> [Name] -> q [Dec] -singDataD rep cxt name tvbs ctors derivings - | (_:_) <- cxt = fail "Singling of constrained datatypes is not supported" - | otherwise = do - aName <- qNewName "z" - let a = VarT aName - let tvbNames = map extractTvbName tvbs - k <- promoteType (foldType (ConT name) (map VarT tvbNames)) - (ctors', ctorInstDecls) <- evalForPair $ mapM (singCtor a) ctors - - -- instance for SingKind - fromSingClauses <- mapM mkFromSingClause ctors - toSingClauses <- mapM mkToSingClause ctors - let singKindInst = - InstanceD (map (singKindConstraint . VarT) tvbNames) - (AppT (ConT singKindClassName) - (kindParam k)) - [ mkTyFamInst demoteRepName - [kindParam k] - (foldType (ConT name) - (map (AppT demote . kindParam . VarT) tvbNames)) - , FunD fromSingName (fromSingClauses `orIfEmpty` emptyMethod aName) - , FunD toSingName (toSingClauses `orIfEmpty` emptyMethod aName) ] - - -- SEq instance - sEqInsts <- if elem eqName derivings - then mapM (mkEqualityInstance k ctors') [sEqClassDesc, sDecideClassDesc] - else return [] - - -- e.g. type SNat (a :: Nat) = Sing a - let kindedSynInst = - TySynD (singTyConName name) - [KindedTV aName k] - (AppT singFamily a) - - return $ (DataInstD [] singFamilyName [SigT a k] ctors' []) : - kindedSynInst : - singKindInst : - sEqInsts ++ - ctorInstDecls - where -- in the Rep case, the names of the constructors are in the wrong scope - -- (they're types, not datacons), so we have to reinterpret them. - mkConName :: Name -> Name - mkConName = if rep then reinterpret else id - - mkFromSingClause :: Quasi q => Con -> q Clause - mkFromSingClause c = do - let (cname, numArgs) = extractNameArgs c - varNames <- replicateM numArgs (qNewName "b") - return $ Clause [ConP (singDataConName cname) (map VarP varNames)] - (NormalB $ foldExp - (ConE $ mkConName cname) - (map (AppE (VarE fromSingName) . VarE) varNames)) - [] - - mkToSingClause :: Quasi q => Con -> q Clause - mkToSingClause = ctor1Case $ \cname types -> do - varNames <- mapM (const $ qNewName "b") types - svarNames <- mapM (const $ qNewName "c") types - promoted <- mapM promoteType types - let recursiveCalls = zipWith mkRecursiveCall varNames promoted - return $ - Clause [ConP (mkConName cname) (map VarP varNames)] - (NormalB $ - multiCase recursiveCalls - (map (ConP someSingDataName . listify . VarP) - svarNames) - (AppE (ConE someSingDataName) - (foldExp (ConE (singDataConName cname)) - (map VarE svarNames)))) - [] - - mkRecursiveCall :: Name -> Kind -> Exp - mkRecursiveCall var_name ki = - SigE (AppE (VarE toSingName) (VarE var_name)) - (AppT (ConT someSingTypeName) (kindParam ki)) - - emptyMethod :: Name -> [Clause] - emptyMethod n = [Clause [VarP n] (NormalB $ CaseE (VarE n) emptyMatches) []] - -singKind :: Quasi q => Kind -> q (Kind -> Kind) -singKind (ForallT _ _ _) = - fail "Singling of explicitly quantified kinds not yet supported" -singKind (VarT _) = fail "Singling of kind variables not yet supported" -singKind (ConT _) = fail "Singling of named kinds not yet supported" -singKind (TupleT _) = fail "Singling of tuple kinds not yet supported" -singKind (UnboxedTupleT _) = fail "Unboxed tuple used as kind" -singKind ArrowT = fail "Singling of unsaturated arrow kinds not yet supported" -singKind ListT = fail "Singling of list kinds not yet supported" -singKind (AppT (AppT ArrowT k1) k2) = do - k1fn <- singKind k1 - k2fn <- singKind k2 - k <- qNewName "k" - return $ \f -> AppT (AppT ArrowT (k1fn (VarT k))) (k2fn (AppT f (VarT k))) -singKind (AppT _ _) = fail "Singling of kind applications not yet supported" -singKind (SigT _ _) = - fail "Singling of explicitly annotated kinds not yet supported" -singKind (LitT _) = fail "Type literal used as kind" -singKind (PromotedT _) = fail "Promoted data constructor used as kind" -singKind (PromotedTupleT _) = fail "Promoted tuple used as kind" -singKind PromotedNilT = fail "Promoted nil used as kind" -singKind PromotedConsT = fail "Promoted cons used as kind" -singKind StarT = return $ \k -> AppT (AppT ArrowT k) StarT -singKind ConstraintT = fail "Singling of constraint kinds not yet supported" - -singType :: Quasi q => Type -> q TypeFn -singType ty = do -- replace with singTypeRec [] ty after GHC bug #??? is fixed - sTypeFn <- singTypeRec [] ty - return $ \inner_ty -> liftOutForalls $ sTypeFn inner_ty - --- Lifts all foralls to the top-level. This is a workaround for bug #8031 on GHC --- Trac -liftOutForalls :: Type -> Type -liftOutForalls = - go [] [] [] - where - go tyvars cxt args (ForallT tyvars1 cxt1 t1) - = go (reverse tyvars1 ++ tyvars) (reverse cxt1 ++ cxt) args t1 - go tyvars cxt args (SigT t1 _kind) -- ignore these kind annotations, which have to be * - = go tyvars cxt args t1 - go tyvars cxt args (AppT (AppT ArrowT arg1) res1) - = go tyvars cxt (arg1 : args) res1 - go [] [] args t1 - = mk_fun_ty (reverse args) t1 - go tyvars cxt args t1 - = ForallT (reverse tyvars) (reverse cxt) (mk_fun_ty (reverse args) t1) - - mk_fun_ty [] res = res - mk_fun_ty (arg1:args) res = AppT (AppT ArrowT arg1) (mk_fun_ty args res) - --- the first parameter is the list of types the current type is applied to -singTypeRec :: Quasi q => TypeContext -> Type -> q TypeFn -singTypeRec (_:_) (ForallT _ _ _) = - fail "I thought this was impossible in Haskell. Email me at eir@cis.upenn.edu with your code if you see this message." -singTypeRec [] (ForallT _ [] ty) = -- Sing makes handling foralls automatic - singTypeRec [] ty -singTypeRec ctx (ForallT _tvbs cxt innerty) = do - cxt' <- singContext cxt - innerty' <- singTypeRec ctx innerty - return $ \ty -> ForallT [] cxt' (innerty' ty) -singTypeRec (_:_) (VarT _) = - fail "Singling of type variables of arrow kinds not yet supported" -singTypeRec [] (VarT _name) = - return $ \ty -> AppT singFamily ty -singTypeRec _ctx (ConT _name) = -- we don't need to process the context with Sing - return $ \ty -> AppT singFamily ty -singTypeRec _ctx (TupleT _n) = -- just like ConT - return $ \ty -> AppT singFamily ty -singTypeRec _ctx (UnboxedTupleT _n) = - fail "Singling of unboxed tuple types not yet supported" -singTypeRec ctx ArrowT = case ctx of - [ty1, ty2] -> do - t <- qNewName "t" - sty1 <- singTypeRec [] ty1 - sty2 <- singTypeRec [] ty2 - k1 <- promoteType ty1 - return (\f -> ForallT [KindedTV t k1] - [] - (AppT (AppT ArrowT (sty1 (VarT t))) - (sty2 (AppT f (VarT t))))) - _ -> fail "Internal error in Sing: converting ArrowT with improper context" -singTypeRec _ctx ListT = - return $ \ty -> AppT singFamily ty -singTypeRec ctx (AppT ty1 ty2) = - singTypeRec (ty2 : ctx) ty1 -- recur with the ty2 in the applied context -singTypeRec _ctx (SigT _ty _knd) = - fail "Singling of types with explicit kinds not yet supported" -singTypeRec _ctx (LitT _) = fail "Singling of type-level literals not yet supported" -singTypeRec _ctx (PromotedT _) = - fail "Singling of promoted data constructors not yet supported" -singTypeRec _ctx (PromotedTupleT _) = - fail "Singling of type-level tuples not yet supported" -singTypeRec _ctx PromotedNilT = fail "Singling of promoted nil not yet supported" -singTypeRec _ctx PromotedConsT = fail "Singling of type-level cons not yet supported" -singTypeRec _ctx StarT = fail "* used as type" -singTypeRec _ctx ConstraintT = fail "Constraint used as type" - --- refine a constraint context -singContext :: Quasi q => Cxt -> q Cxt -singContext = mapM singPred - -singPred :: Quasi q => Pred -> q Pred -singPred (ClassP name tys) = do - kis <- mapM promoteType tys - let sName = singClassName name - return $ ClassP sName (map kindParam kis) -singPred (EqualP _ty1 _ty2) = - fail "Singling of type equality constraints not yet supported" - -singClause :: Quasi q => ExpTable -> Clause -> q Clause -singClause vars (Clause pats (NormalB exp) []) = do - (sPats, vartbl) <- evalForPair $ mapM (singPat Parameter) pats - let vars' = Map.union vartbl vars - sBody <- NormalB <$> singExp vars' exp - return $ Clause sPats sBody [] -singClause _ (Clause _ (GuardedB _) _) = - fail "Singling of guarded patterns not yet supported" -singClause _ (Clause _ _ (_:_)) = - fail "Singling of <> declarations not yet supported" - -type ExpsQ q = QWithAux ExpTable q - --- we need to know where a pattern is to anticipate when --- GHC's brain might explode -data PatternContext = LetBinding - | CaseStatement - | TopLevel - | Parameter - | Statement - deriving Eq - -checkIfBrainWillExplode :: Quasi q => PatternContext -> ExpsQ q () -checkIfBrainWillExplode CaseStatement = return () -checkIfBrainWillExplode Statement = return () -checkIfBrainWillExplode Parameter = return () -checkIfBrainWillExplode _ = - fail $ "Can't use a singleton pattern outside of a case-statement or\n" ++ - "do expression: GHC's brain will explode if you try. (Do try it!)" - --- convert a pattern, building up the lexical scope as we go -singPat :: Quasi q => PatternContext -> Pat -> ExpsQ q Pat -singPat _patCxt (LitP _lit) = - fail "Singling of literal patterns not yet supported" -singPat patCxt (VarP name) = - let new = if patCxt == TopLevel then singValName name else name in do - addBinding name (VarE new) - return $ VarP new -singPat patCxt (TupP pats) = - singPat patCxt (ConP (tupleDataName (length pats)) pats) -singPat _patCxt (UnboxedTupP _pats) = - fail "Singling of unboxed tuples not supported" -singPat patCxt (ConP name pats) = do - checkIfBrainWillExplode patCxt - pats' <- mapM (singPat patCxt) pats - return $ ConP (singDataConName name) pats' -singPat patCxt (InfixP pat1 name pat2) = singPat patCxt (ConP name [pat1, pat2]) -singPat _patCxt (UInfixP _ _ _) = - fail "Singling of unresolved infix patterns not supported" -singPat _patCxt (ParensP _) = - fail "Singling of unresolved paren patterns not supported" -singPat patCxt (TildeP pat) = do - pat' <- singPat patCxt pat - return $ TildeP pat' -singPat patCxt (BangP pat) = do - pat' <- singPat patCxt pat - return $ BangP pat' -singPat patCxt (AsP name pat) = do - let new = if patCxt == TopLevel then singValName name else name in do - pat' <- singPat patCxt pat - addBinding name (VarE new) - return $ AsP name pat' -singPat _patCxt WildP = return WildP -singPat _patCxt (RecP _name _fields) = - fail "Singling of record patterns not yet supported" -singPat patCxt (ListP pats) = do - checkIfBrainWillExplode patCxt - sPats <- mapM (singPat patCxt) pats - return $ foldr (\elt lst -> ConP sconsName [elt, lst]) (ConP snilName []) sPats -singPat _patCxt (SigP _pat _ty) = - fail "Singling of annotated patterns not yet supported" -singPat _patCxt (ViewP _exp _pat) = - fail "Singling of view patterns not yet supported" - -singExp :: Quasi q => ExpTable -> Exp -> q Exp -singExp vars (VarE name) = case Map.lookup name vars of - Just exp -> return exp - Nothing -> return (singVal name) -singExp _vars (ConE name) = return $ singDataCon name -singExp _vars (LitE lit) = singLit lit -singExp vars (AppE exp1 exp2) = do - exp1' <- singExp vars exp1 - exp2' <- singExp vars exp2 - return $ AppE exp1' exp2' -singExp vars (InfixE mexp1 exp mexp2) = - case (mexp1, mexp2) of - (Nothing, Nothing) -> singExp vars exp - (Just exp1, Nothing) -> singExp vars (AppE exp exp1) - (Nothing, Just _exp2) -> - fail "Singling of right-only sections not yet supported" - (Just exp1, Just exp2) -> singExp vars (AppE (AppE exp exp1) exp2) -singExp _vars (UInfixE _ _ _) = - fail "Singling of unresolved infix expressions not supported" -singExp _vars (ParensE _) = - fail "Singling of unresolved paren expressions not supported" -singExp vars (LamE pats exp) = do - (pats', vartbl) <- evalForPair $ mapM (singPat Parameter) pats - let vars' = Map.union vartbl vars -- order matters; union is left-biased - exp' <- singExp vars' exp - return $ LamE pats' exp' -singExp _vars (LamCaseE _matches) = - fail "Singling of case expressions not yet supported" -singExp vars (TupE exps) = do - sExps <- mapM (singExp vars) exps - sTuple <- singExp vars (ConE (tupleDataName (length exps))) - return $ foldExp sTuple sExps -singExp _vars (UnboxedTupE _exps) = - fail "Singling of unboxed tuple not supported" -singExp vars (CondE bexp texp fexp) = do - exps <- mapM (singExp vars) [bexp, texp, fexp] - return $ foldExp (VarE sIfName) exps -singExp _vars (MultiIfE _alts) = - fail "Singling of multi-way if statements not yet supported" -singExp _vars (LetE _decs _exp) = - fail "Singling of let expressions not yet supported" -singExp _vars (CaseE _exp _matches) = - fail "Singling of case expressions not yet supported" -singExp _vars (DoE _stmts) = - fail "Singling of do expressions not yet supported" -singExp _vars (CompE _stmts) = - fail "Singling of list comprehensions not yet supported" -singExp _vars (ArithSeqE _range) = - fail "Singling of ranges not yet supported" -singExp vars (ListE exps) = do - sExps <- mapM (singExp vars) exps - return $ foldr (\x -> (AppE (AppE (ConE sconsName) x))) - (ConE snilName) sExps -singExp _vars (SigE _exp _ty) = - fail "Singling of annotated expressions not yet supported" -singExp _vars (RecConE _name _fields) = - fail "Singling of record construction not yet supported" -singExp _vars (RecUpdE _exp _fields) = - fail "Singling of record updates not yet supported" - -singLit :: Quasi q => Lit -> q Exp -singLit lit = SigE (VarE singMethName) <$> (AppT singFamily <$> (promoteLit lit)) diff --git a/src/Data/Singletons/SuppressUnusedWarnings.hs b/src/Data/Singletons/SuppressUnusedWarnings.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/SuppressUnusedWarnings.hs @@ -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 -> () diff --git a/src/Data/Singletons/Syntax.hs b/src/Data/Singletons/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Syntax.hs @@ -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 diff --git a/src/Data/Singletons/TH.hs b/src/Data/Singletons/TH.hs --- a/src/Data/Singletons/TH.hs +++ b/src/Data/Singletons/TH.hs @@ -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 <> 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) diff --git a/src/Data/Singletons/Tuple.hs b/src/Data/Singletons/Tuple.hs deleted file mode 100644 --- a/src/Data/Singletons/Tuple.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, DataKinds, PolyKinds, - RankNTypes, TypeFamilies, GADTs, CPP #-} - -#if __GLASGOW_HASKELL__ < 707 -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -#endif - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Tuple --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines functions and datatypes relating to the singleton for tuples, --- including a singletons version of all the definitions in @Data.Tuple@. --- --- Because many of these definitions are produced by Template Haskell, --- it is not possible to create proper Haddock documentation. Please look --- up the corresponding operation in @Data.Tuple@. Also, please excuse --- the apparent repeated variable names. This is due to an interaction --- between Template Haskell and Haddock. --- ----------------------------------------------------------------------------- - -module Data.Singletons.Tuple ( - -- * Singleton definitions - -- | See 'Data.Singletons.Prelude.Sing' for more info. - Sing(STuple0, STuple2, STuple3, STuple4, STuple5, STuple6, STuple7), - STuple0, STuple2, STuple3, STuple4, STuple5, STuple6, STuple7, - - -- * Singletons from @Data.Tuple@ - Fst, sFst, Snd, sSnd, Curry, sCurry, Uncurry, sUncurry, Swap, sSwap - ) where - -import Data.Singletons.Instances -import Data.Singletons.TH - -$(singletonsOnly [d| - -- | Extract the first component of a pair. - fst :: (a,b) -> a - fst (x,_) = x - - -- | Extract the second component of a pair. - snd :: (a,b) -> b - snd (_,y) = y - - -- | 'curry' converts an uncurried function to a curried function. - curry :: ((a, b) -> c) -> a -> b -> c - curry f x y = f (x, y) - - -- | 'uncurry' converts a curried function to a function on pairs. - uncurry :: (a -> b -> c) -> ((a, b) -> c) - uncurry f p = f (fst p) (snd p) - - -- | Swap the components of a pair. - swap :: (a,b) -> (b,a) - swap (a,b) = (b,a) - |]) diff --git a/src/Data/Singletons/TypeLits.hs b/src/Data/Singletons/TypeLits.hs --- a/src/Data/Singletons/TypeLits.hs +++ b/src/Data/Singletons/TypeLits.hs @@ -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 diff --git a/src/Data/Singletons/TypeRepStar.hs b/src/Data/Singletons/TypeRepStar.hs --- a/src/Data/Singletons/TypeRepStar.hs +++ b/src/Data/Singletons/TypeRepStar.hs @@ -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) = diff --git a/src/Data/Singletons/Types.hs b/src/Data/Singletons/Types.hs --- a/src/Data/Singletons/Types.hs +++ b/src/Data/Singletons/Types.hs @@ -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 diff --git a/src/Data/Singletons/Util.hs b/src/Data/Singletons/Util.hs --- a/src/Data/Singletons/Util.hs +++ b/src/Data/Singletons/Util.hs @@ -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 <> 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 == '_' diff --git a/tests/SingletonsTestSuite.hs b/tests/SingletonsTestSuite.hs --- a/tests/SingletonsTestSuite.hs +++ b/tests/SingletonsTestSuite.hs @@ -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" ] ] - diff --git a/tests/SingletonsTestSuiteUtils.hs b/tests/SingletonsTestSuiteUtils.hs --- a/tests/SingletonsTestSuiteUtils.hs +++ b/tests/SingletonsTestSuiteUtils.hs @@ -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 diff --git a/tests/compile-and-dump/GradingClient/Database.ghc76.template b/tests/compile-and-dump/GradingClient/Database.ghc76.template --- a/tests/compile-and-dump/GradingClient/Database.ghc76.template +++ b/tests/compile-and-dump/GradingClient/Database.ghc76.template @@ -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 | diff --git a/tests/compile-and-dump/GradingClient/Database.ghc78.template b/tests/compile-and-dump/GradingClient/Database.ghc78.template --- a/tests/compile-and-dump/GradingClient/Database.ghc78.template +++ b/tests/compile-and-dump/GradingClient/Database.ghc78.template @@ -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 } diff --git a/tests/compile-and-dump/GradingClient/Database.hs b/tests/compile-and-dump/GradingClient/Database.hs --- a/tests/compile-and-dump/GradingClient/Database.hs +++ b/tests/compile-and-dump/GradingClient/Database.hs @@ -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 diff --git a/tests/compile-and-dump/GradingClient/Main.ghc76.template b/tests/compile-and-dump/GradingClient/Main.ghc76.template --- a/tests/compile-and-dump/GradingClient/Main.ghc76.template +++ b/tests/compile-and-dump/GradingClient/Main.ghc76.template @@ -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 diff --git a/tests/compile-and-dump/GradingClient/Main.ghc78.template b/tests/compile-and-dump/GradingClient/Main.ghc78.template --- a/tests/compile-and-dump/GradingClient/Main.ghc78.template +++ b/tests/compile-and-dump/GradingClient/Main.ghc78.template @@ -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)) diff --git a/tests/compile-and-dump/GradingClient/Main.hs b/tests/compile-and-dump/GradingClient/Main.hs --- a/tests/compile-and-dump/GradingClient/Main.hs +++ b/tests/compile-and-dump/GradingClient/Main.hs @@ -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| diff --git a/tests/compile-and-dump/InsertionSort/InsertionSortImp.ghc76.template b/tests/compile-and-dump/InsertionSort/InsertionSortImp.ghc76.template --- a/tests/compile-and-dump/InsertionSort/InsertionSortImp.ghc76.template +++ b/tests/compile-and-dump/InsertionSort/InsertionSortImp.ghc76.template @@ -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 diff --git a/tests/compile-and-dump/InsertionSort/InsertionSortImp.ghc78.template b/tests/compile-and-dump/InsertionSort/InsertionSortImp.ghc78.template --- a/tests/compile-and-dump/InsertionSort/InsertionSortImp.ghc78.template +++ b/tests/compile-and-dump/InsertionSort/InsertionSortImp.ghc78.template @@ -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 diff --git a/tests/compile-and-dump/InsertionSort/InsertionSortImp.hs b/tests/compile-and-dump/InsertionSort/InsertionSortImp.hs --- a/tests/compile-and-dump/InsertionSort/InsertionSortImp.hs +++ b/tests/compile-and-dump/InsertionSort/InsertionSortImp.hs @@ -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 diff --git a/tests/compile-and-dump/Promote/BadBoundedDeriving.ghc78.template b/tests/compile-and-dump/Promote/BadBoundedDeriving.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Promote/BadBoundedDeriving.ghc78.template @@ -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 diff --git a/tests/compile-and-dump/Promote/BadBoundedDeriving.hs b/tests/compile-and-dump/Promote/BadBoundedDeriving.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Promote/BadBoundedDeriving.hs @@ -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) + |]) diff --git a/tests/compile-and-dump/Promote/BoundedDeriving.ghc78.template b/tests/compile-and-dump/Promote/BoundedDeriving.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Promote/BoundedDeriving.ghc78.template @@ -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 diff --git a/tests/compile-and-dump/Promote/BoundedDeriving.hs b/tests/compile-and-dump/Promote/BoundedDeriving.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Promote/BoundedDeriving.hs @@ -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 diff --git a/tests/compile-and-dump/Promote/Classes.ghc76.template b/tests/compile-and-dump/Promote/Classes.ghc76.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Promote/Classes.ghc76.template diff --git a/tests/compile-and-dump/Promote/Classes.ghc78.template b/tests/compile-and-dump/Promote/Classes.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Promote/Classes.ghc78.template @@ -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 diff --git a/tests/compile-and-dump/Promote/Classes.hs b/tests/compile-and-dump/Promote/Classes.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Promote/Classes.hs @@ -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 diff --git a/tests/compile-and-dump/Promote/Constructors.ghc76.template b/tests/compile-and-dump/Promote/Constructors.ghc76.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Promote/Constructors.ghc76.template @@ -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 diff --git a/tests/compile-and-dump/Promote/Constructors.ghc78.template b/tests/compile-and-dump/Promote/Constructors.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Promote/Constructors.ghc78.template @@ -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 diff --git a/tests/compile-and-dump/Promote/Constructors.hs b/tests/compile-and-dump/Promote/Constructors.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Promote/Constructors.hs @@ -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 + |]) diff --git a/tests/compile-and-dump/Promote/GenDefunSymbols.ghc76.template b/tests/compile-and-dump/Promote/GenDefunSymbols.ghc76.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Promote/GenDefunSymbols.ghc76.template @@ -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 diff --git a/tests/compile-and-dump/Promote/GenDefunSymbols.ghc78.template b/tests/compile-and-dump/Promote/GenDefunSymbols.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Promote/GenDefunSymbols.ghc78.template @@ -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 diff --git a/tests/compile-and-dump/Promote/GenDefunSymbols.hs b/tests/compile-and-dump/Promote/GenDefunSymbols.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Promote/GenDefunSymbols.hs @@ -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, ''(:+) ]) diff --git a/tests/compile-and-dump/Promote/Newtypes.ghc76.template b/tests/compile-and-dump/Promote/Newtypes.ghc76.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Promote/Newtypes.ghc76.template @@ -0,0 +1,2 @@ +Promote/Newtypes.hs:0:0: + Newtypes don't promote under GHC 7.6. Use <> instead or upgrade GHC. diff --git a/tests/compile-and-dump/Promote/Newtypes.ghc78.template b/tests/compile-and-dump/Promote/Newtypes.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Promote/Newtypes.ghc78.template @@ -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 diff --git a/tests/compile-and-dump/Promote/Newtypes.hs b/tests/compile-and-dump/Promote/Newtypes.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Promote/Newtypes.hs @@ -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 } + |]) diff --git a/tests/compile-and-dump/Promote/NumArgs.ghc76.template b/tests/compile-and-dump/Promote/NumArgs.ghc76.template deleted file mode 100644 --- a/tests/compile-and-dump/Promote/NumArgs.ghc76.template +++ /dev/null @@ -1,10 +0,0 @@ -Promote/NumArgs.hs:0:0: Splicing declarations - promote - [d| returnFunc :: Nat -> Nat -> Nat - returnFunc _ = Succ |] - ======> - Promote/NumArgs.hs:(0,0)-(0,0) - returnFunc :: Nat -> Nat -> Nat - returnFunc _ = Succ - type instance ReturnFunc z = Succ - type family ReturnFunc (a :: Nat) :: Nat -> Nat diff --git a/tests/compile-and-dump/Promote/NumArgs.ghc78.template b/tests/compile-and-dump/Promote/NumArgs.ghc78.template deleted file mode 100644 --- a/tests/compile-and-dump/Promote/NumArgs.ghc78.template +++ /dev/null @@ -1,10 +0,0 @@ -Promote/NumArgs.hs:0:0: Splicing declarations - promote - [d| returnFunc :: Nat -> Nat -> Nat - returnFunc _ = Succ |] - ======> - Promote/NumArgs.hs:(0,0)-(0,0) - returnFunc :: Nat -> Nat -> Nat - returnFunc _ = Succ - type family ReturnFunc (a :: Nat) :: Nat -> Nat where - ReturnFunc z = Succ diff --git a/tests/compile-and-dump/Promote/NumArgs.hs b/tests/compile-and-dump/Promote/NumArgs.hs deleted file mode 100644 --- a/tests/compile-and-dump/Promote/NumArgs.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Promote.NumArgs where - -import Data.Singletons.TH -import Singletons.Nat - --- used to test the "num args" feature of promoteDec --- remove this test once eta-expansion is implemented - -$(promote [d| - returnFunc :: Nat -> Nat -> Nat - returnFunc _ = Succ - |]) diff --git a/tests/compile-and-dump/Promote/OrdDeriving.ghc78.template b/tests/compile-and-dump/Promote/OrdDeriving.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Promote/OrdDeriving.ghc78.template @@ -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 diff --git a/tests/compile-and-dump/Promote/OrdDeriving.hs b/tests/compile-and-dump/Promote/OrdDeriving.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Promote/OrdDeriving.hs @@ -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 diff --git a/tests/compile-and-dump/Promote/PatternMatching.ghc76.template b/tests/compile-and-dump/Promote/PatternMatching.ghc76.template deleted file mode 100644 --- a/tests/compile-and-dump/Promote/PatternMatching.ghc76.template +++ /dev/null @@ -1,65 +0,0 @@ -Promote/PatternMatching.hs:0:0: Splicing declarations - promote - [d| pr = Pair (Succ Zero) ([Zero]) - complex = Pair (Pair (Just Zero) Zero) False - tuple = (False, Just Zero, True) - aList = [Zero, Succ Zero, Succ (Succ Zero)] - - data Pair a b - = Pair a b - deriving (Show) |] - ======> - Promote/PatternMatching.hs:(0,0)-(0,0) - data Pair a b - = Pair a b - deriving (Show) - pr = Pair (Succ Zero) [Zero] - complex = Pair (Pair (Just Zero) Zero) False - tuple = (False, Just Zero, True) - aList = [Zero, Succ Zero, Succ (Succ Zero)] - type Pr = Pair (Succ Zero) '[Zero] - type Complex = Pair (Pair (Just Zero) Zero) False - type Tuple = '(False, Just Zero, True) - type AList = '[Zero, Succ Zero, Succ (Succ Zero)] -Promote/PatternMatching.hs:0:0: Splicing declarations - promote - [d| Pair sz lz = pr - Pair (Pair jz zz) fls = complex - (tf, tjz, tt) = tuple - [_, lsz, (Succ blimy)] = aList |] - ======> - Promote/PatternMatching.hs:(0,0)-(0,0) - Pair sz lz = pr - Pair (Pair jz zz) fls = complex - (tf, tjz, tt) = tuple - [_, lsz, Succ blimy] = aList - type Sz = Extract_0123456789 Pr - type Lz = Extract_0123456789 Pr - type family Extract_0123456789 (a :: Pair a b) :: a - type family Extract_0123456789 (a :: Pair a b) :: b - type instance Extract_0123456789 (Pair a a) = a - type instance Extract_0123456789 (Pair a a) = a - type Jz = Extract_0123456789 (Extract_0123456789 Complex) - type Zz = Extract_0123456789 (Extract_0123456789 Complex) - type Fls = Extract_0123456789 Complex - type family Extract_0123456789 (a :: Pair a b) :: a - type family Extract_0123456789 (a :: Pair a b) :: b - type instance Extract_0123456789 (Pair a a) = a - type instance Extract_0123456789 (Pair a a) = a - type family Extract_0123456789 (a :: Pair a b) :: a - type family Extract_0123456789 (a :: Pair a b) :: b - type instance Extract_0123456789 (Pair a a) = a - type instance Extract_0123456789 (Pair a a) = a - type Tf = Extract_0123456789 Tuple - type Tjz = Extract_0123456789 Tuple - type Tt = Extract_0123456789 Tuple - type family Extract_0123456789 (a :: GHC.Tuple.(,,) a b c) :: a - type family Extract_0123456789 (a :: GHC.Tuple.(,,) a b c) :: b - type family Extract_0123456789 (a :: GHC.Tuple.(,,) a b c) :: c - type instance Extract_0123456789 (GHC.Tuple.(,,) a a a) = a - type instance Extract_0123456789 (GHC.Tuple.(,,) a a a) = a - type instance Extract_0123456789 (GHC.Tuple.(,,) a a a) = a - type Lsz = Head (Tail AList) - type Blimy = Extract_0123456789 (Head (Tail (Tail AList))) - type family Extract_0123456789 (a :: Nat) :: Nat - type instance Extract_0123456789 (Succ a) = a diff --git a/tests/compile-and-dump/Promote/PatternMatching.ghc78.template b/tests/compile-and-dump/Promote/PatternMatching.ghc78.template deleted file mode 100644 --- a/tests/compile-and-dump/Promote/PatternMatching.ghc78.template +++ /dev/null @@ -1,65 +0,0 @@ -Promote/PatternMatching.hs:0:0: Splicing declarations - promote - [d| pr = Pair (Succ Zero) ([Zero]) - complex = Pair (Pair (Just Zero) Zero) False - tuple = (False, Just Zero, True) - aList = [Zero, Succ Zero, Succ (Succ Zero)] - - data Pair a b - = Pair a b - deriving (Show) |] - ======> - Promote/PatternMatching.hs:(0,0)-(0,0) - data Pair a b - = Pair a b - deriving (Show) - pr = Pair (Succ Zero) [Zero] - complex = Pair (Pair (Just Zero) Zero) False - tuple = (False, Just Zero, True) - aList = [Zero, Succ Zero, Succ (Succ Zero)] - type Pr = Pair (Succ Zero) '[Zero] - type Complex = Pair (Pair (Just Zero) Zero) False - type Tuple = '(False, Just Zero, True) - type AList = '[Zero, Succ Zero, Succ (Succ Zero)] -Promote/PatternMatching.hs:0:0: Splicing declarations - promote - [d| Pair sz lz = pr - Pair (Pair jz zz) fls = complex - (tf, tjz, tt) = tuple - [_, lsz, (Succ blimy)] = aList |] - ======> - Promote/PatternMatching.hs:(0,0)-(0,0) - Pair sz lz = pr - Pair (Pair jz zz) fls = complex - (tf, tjz, tt) = tuple - [_, lsz, Succ blimy] = aList - type Sz = Extract_0123456789 Pr - type Lz = Extract_0123456789 Pr - type family Extract_0123456789 (a :: Pair a b) :: a - type family Extract_0123456789 (a :: Pair a b) :: b - type instance Extract_0123456789 (Pair a a) = a - type instance Extract_0123456789 (Pair a a) = a - type Jz = Extract_0123456789 (Extract_0123456789 Complex) - type Zz = Extract_0123456789 (Extract_0123456789 Complex) - type Fls = Extract_0123456789 Complex - type family Extract_0123456789 (a :: Pair a b) :: a - type family Extract_0123456789 (a :: Pair a b) :: b - type instance Extract_0123456789 (Pair a a) = a - type instance Extract_0123456789 (Pair a a) = a - type family Extract_0123456789 (a :: Pair a b) :: a - type family Extract_0123456789 (a :: Pair a b) :: b - type instance Extract_0123456789 (Pair a a) = a - type instance Extract_0123456789 (Pair a a) = a - type Tf = Extract_0123456789 Tuple - type Tjz = Extract_0123456789 Tuple - type Tt = Extract_0123456789 Tuple - type family Extract_0123456789 (a :: GHC.Tuple.(,,) a b c) :: a - type family Extract_0123456789 (a :: GHC.Tuple.(,,) a b c) :: b - type family Extract_0123456789 (a :: GHC.Tuple.(,,) a b c) :: c - type instance Extract_0123456789 (GHC.Tuple.(,,) a a a) = a - type instance Extract_0123456789 (GHC.Tuple.(,,) a a a) = a - type instance Extract_0123456789 (GHC.Tuple.(,,) a a a) = a - type Lsz = Head (Tail AList) - type Blimy = Extract_0123456789 (Head (Tail (Tail AList))) - type family Extract_0123456789 (a :: Nat) :: Nat - type instance Extract_0123456789 (Succ a) = a diff --git a/tests/compile-and-dump/Promote/PatternMatching.hs b/tests/compile-and-dump/Promote/PatternMatching.hs deleted file mode 100644 --- a/tests/compile-and-dump/Promote/PatternMatching.hs +++ /dev/null @@ -1,20 +0,0 @@ -module Promote.PatternMatching where - -import Data.Singletons.TH -import Data.Singletons.Prelude -import Singletons.Nat - -$(promote [d| - data Pair a b = Pair a b deriving Show - pr = Pair (Succ Zero) ([Zero]) - complex = Pair (Pair (Just Zero) Zero) False - tuple = (False, Just Zero, True) - aList = [Zero, Succ Zero, Succ (Succ Zero)] - |]) - -$(promote [d| - Pair sz lz = pr - Pair (Pair jz zz) fls = complex - (tf, tjz, tt) = tuple - [_, lsz, (Succ blimy)] = aList - |]) diff --git a/tests/compile-and-dump/Promote/Pragmas.ghc78.template b/tests/compile-and-dump/Promote/Pragmas.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Promote/Pragmas.ghc78.template @@ -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) diff --git a/tests/compile-and-dump/Promote/Pragmas.hs b/tests/compile-and-dump/Promote/Pragmas.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Promote/Pragmas.hs @@ -0,0 +1,10 @@ +module Promote.Pragmas where + +import Data.Singletons.TH +import Data.Promotion.Prelude + +$(promote [d| + {-# INLINE foo #-} + foo :: Bool + foo = True + |]) diff --git a/tests/compile-and-dump/Promote/Prelude.ghc78.template b/tests/compile-and-dump/Promote/Prelude.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Promote/Prelude.ghc78.template @@ -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) diff --git a/tests/compile-and-dump/Promote/Prelude.hs b/tests/compile-and-dump/Promote/Prelude.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Promote/Prelude.hs @@ -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 diff --git a/tests/compile-and-dump/Promote/TopLevelPatterns.ghc78.template b/tests/compile-and-dump/Promote/TopLevelPatterns.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Promote/TopLevelPatterns.ghc78.template @@ -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 diff --git a/tests/compile-and-dump/Promote/TopLevelPatterns.hs b/tests/compile-and-dump/Promote/TopLevelPatterns.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Promote/TopLevelPatterns.hs @@ -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] + |]) diff --git a/tests/compile-and-dump/Singletons/AsPattern.ghc76.template b/tests/compile-and-dump/Singletons/AsPattern.ghc76.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/AsPattern.ghc76.template @@ -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 diff --git a/tests/compile-and-dump/Singletons/AsPattern.ghc78.template b/tests/compile-and-dump/Singletons/AsPattern.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/AsPattern.ghc78.template @@ -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 diff --git a/tests/compile-and-dump/Singletons/AsPattern.hs b/tests/compile-and-dump/Singletons/AsPattern.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/AsPattern.hs @@ -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 + |]) diff --git a/tests/compile-and-dump/Singletons/AtPattern.ghc76.template b/tests/compile-and-dump/Singletons/AtPattern.ghc76.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/AtPattern.ghc76.template +++ /dev/null @@ -1,16 +0,0 @@ -Singletons/AtPattern.hs:0:0: Splicing declarations - singletons - [d| maybePlus :: Maybe Nat -> Maybe Nat - maybePlus (Just n) = Just (plus (Succ Zero) n) - maybePlus foo@Nothing = foo |] - ======> - Singletons/AtPattern.hs:(0,0)-(0,0) - maybePlus :: Maybe Nat -> Maybe Nat - maybePlus (Just n) = Just (plus (Succ Zero) n) - maybePlus foo@Nothing = foo - type instance MaybePlus (Just n) = Just (Plus (Succ Zero) n) - type instance MaybePlus Nothing = Nothing - type family MaybePlus (a :: Maybe Nat) :: Maybe Nat - sMaybePlus :: forall (t :: Maybe Nat). Sing t -> Sing (MaybePlus t) - sMaybePlus (SJust n) = SJust (sPlus (SSucc SZero) n) - sMaybePlus foo@SNothing = foo diff --git a/tests/compile-and-dump/Singletons/AtPattern.ghc78.template b/tests/compile-and-dump/Singletons/AtPattern.ghc78.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/AtPattern.ghc78.template +++ /dev/null @@ -1,16 +0,0 @@ -Singletons/AtPattern.hs:0:0: Splicing declarations - singletons - [d| maybePlus :: Maybe Nat -> Maybe Nat - maybePlus (Just n) = Just (plus (Succ Zero) n) - maybePlus foo@Nothing = foo |] - ======> - Singletons/AtPattern.hs:(0,0)-(0,0) - maybePlus :: Maybe Nat -> Maybe Nat - maybePlus (Just n) = Just (plus (Succ Zero) n) - maybePlus foo@Nothing = foo - type family MaybePlus (a :: Maybe Nat) :: Maybe Nat where - MaybePlus (Just n) = Just (Plus (Succ Zero) n) - MaybePlus Nothing = Nothing - sMaybePlus :: forall (t :: Maybe Nat). Sing t -> Sing (MaybePlus t) - sMaybePlus (SJust n) = SJust (sPlus (SSucc SZero) n) - sMaybePlus foo@SNothing = foo diff --git a/tests/compile-and-dump/Singletons/AtPattern.hs b/tests/compile-and-dump/Singletons/AtPattern.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/AtPattern.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Singletons.AtPattern where - -import Data.Singletons.TH -import Data.Singletons.Maybe -import Singletons.Nat - -$(singletons [d| - maybePlus :: Maybe Nat -> Maybe Nat - maybePlus (Just n) = Just (plus (Succ Zero) n) - maybePlus foo@Nothing = foo - |]) diff --git a/tests/compile-and-dump/Singletons/BadPlus.ghc76.template b/tests/compile-and-dump/Singletons/BadPlus.ghc76.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/BadPlus.ghc76.template +++ /dev/null @@ -1,2 +0,0 @@ -Singletons/BadPlus.hs:0:0: - No type signature for functions: "badPlus"; cannot promote or make singletons. diff --git a/tests/compile-and-dump/Singletons/BadPlus.ghc78.template b/tests/compile-and-dump/Singletons/BadPlus.ghc78.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/BadPlus.ghc78.template +++ /dev/null @@ -1,2 +0,0 @@ -Singletons/BadPlus.hs:0:0: - No type signature for functions: "badPlus"; cannot promote or make singletons. diff --git a/tests/compile-and-dump/Singletons/BadPlus.hs b/tests/compile-and-dump/Singletons/BadPlus.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/BadPlus.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Singletons.BadPlus where - -import Data.Singletons.TH -import Singletons.Nat - --- Test whether a declaration without type signature is not singletonized. - -$(singletons [d| - badPlus Zero m = m - badPlus (Succ n) m = Succ (plus n m) - |]) diff --git a/tests/compile-and-dump/Singletons/BoxUnBox.ghc76.template b/tests/compile-and-dump/Singletons/BoxUnBox.ghc76.template --- a/tests/compile-and-dump/Singletons/BoxUnBox.ghc76.template +++ b/tests/compile-and-dump/Singletons/BoxUnBox.ghc76.template @@ -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 diff --git a/tests/compile-and-dump/Singletons/BoxUnBox.ghc78.template b/tests/compile-and-dump/Singletons/BoxUnBox.ghc78.template --- a/tests/compile-and-dump/Singletons/BoxUnBox.ghc78.template +++ b/tests/compile-and-dump/Singletons/BoxUnBox.ghc78.template @@ -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 diff --git a/tests/compile-and-dump/Singletons/BoxUnBox.hs b/tests/compile-and-dump/Singletons/BoxUnBox.hs --- a/tests/compile-and-dump/Singletons/BoxUnBox.hs +++ b/tests/compile-and-dump/Singletons/BoxUnBox.hs @@ -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 diff --git a/tests/compile-and-dump/Singletons/CaseExpressions.ghc76.template b/tests/compile-and-dump/Singletons/CaseExpressions.ghc76.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/CaseExpressions.ghc76.template @@ -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 diff --git a/tests/compile-and-dump/Singletons/CaseExpressions.ghc78.template b/tests/compile-and-dump/Singletons/CaseExpressions.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/CaseExpressions.ghc78.template @@ -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 diff --git a/tests/compile-and-dump/Singletons/CaseExpressions.hs b/tests/compile-and-dump/Singletons/CaseExpressions.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/CaseExpressions.hs @@ -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 diff --git a/tests/compile-and-dump/Singletons/Contains.ghc76.template b/tests/compile-and-dump/Singletons/Contains.ghc76.template --- a/tests/compile-and-dump/Singletons/Contains.ghc76.template +++ b/tests/compile-and-dump/Singletons/Contains.ghc76.template @@ -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) diff --git a/tests/compile-and-dump/Singletons/Contains.ghc78.template b/tests/compile-and-dump/Singletons/Contains.ghc78.template --- a/tests/compile-and-dump/Singletons/Contains.ghc78.template +++ b/tests/compile-and-dump/Singletons/Contains.ghc78.template @@ -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 diff --git a/tests/compile-and-dump/Singletons/Contains.hs b/tests/compile-and-dump/Singletons/Contains.hs --- a/tests/compile-and-dump/Singletons/Contains.hs +++ b/tests/compile-and-dump/Singletons/Contains.hs @@ -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 diff --git a/tests/compile-and-dump/Singletons/DataValues.ghc76.template b/tests/compile-and-dump/Singletons/DataValues.ghc76.template --- a/tests/compile-and-dump/Singletons/DataValues.ghc76.template +++ b/tests/compile-and-dump/Singletons/DataValues.ghc76.template @@ -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) } diff --git a/tests/compile-and-dump/Singletons/DataValues.ghc78.template b/tests/compile-and-dump/Singletons/DataValues.ghc78.template --- a/tests/compile-and-dump/Singletons/DataValues.ghc78.template +++ b/tests/compile-and-dump/Singletons/DataValues.ghc78.template @@ -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)) diff --git a/tests/compile-and-dump/Singletons/DataValues.hs b/tests/compile-and-dump/Singletons/DataValues.hs --- a/tests/compile-and-dump/Singletons/DataValues.hs +++ b/tests/compile-and-dump/Singletons/DataValues.hs @@ -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 diff --git a/tests/compile-and-dump/Singletons/Empty.ghc76.template b/tests/compile-and-dump/Singletons/Empty.ghc76.template --- a/tests/compile-and-dump/Singletons/Empty.ghc76.template +++ b/tests/compile-and-dump/Singletons/Empty.ghc76.template @@ -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 diff --git a/tests/compile-and-dump/Singletons/EqInstances.ghc76.template b/tests/compile-and-dump/Singletons/EqInstances.ghc76.template --- a/tests/compile-and-dump/Singletons/EqInstances.ghc76.template +++ b/tests/compile-and-dump/Singletons/EqInstances.ghc76.template @@ -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 _ diff --git a/tests/compile-and-dump/Singletons/EqInstances.ghc78.template b/tests/compile-and-dump/Singletons/EqInstances.ghc78.template --- a/tests/compile-and-dump/Singletons/EqInstances.ghc78.template +++ b/tests/compile-and-dump/Singletons/EqInstances.ghc78.template @@ -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 diff --git a/tests/compile-and-dump/Singletons/EqInstances.hs b/tests/compile-and-dump/Singletons/EqInstances.hs --- a/tests/compile-and-dump/Singletons/EqInstances.hs +++ b/tests/compile-and-dump/Singletons/EqInstances.hs @@ -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 diff --git a/tests/compile-and-dump/Singletons/Error.ghc76.template b/tests/compile-and-dump/Singletons/Error.ghc76.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/Error.ghc76.template @@ -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 diff --git a/tests/compile-and-dump/Singletons/Error.ghc78.template b/tests/compile-and-dump/Singletons/Error.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/Error.ghc78.template @@ -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 diff --git a/tests/compile-and-dump/Singletons/Error.hs b/tests/compile-and-dump/Singletons/Error.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/Error.hs @@ -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" + |]) diff --git a/tests/compile-and-dump/Singletons/HigherOrder.ghc76.template b/tests/compile-and-dump/Singletons/HigherOrder.ghc76.template --- a/tests/compile-and-dump/Singletons/HigherOrder.ghc76.template +++ b/tests/compile-and-dump/Singletons/HigherOrder.ghc76.template @@ -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 diff --git a/tests/compile-and-dump/Singletons/HigherOrder.ghc78.template b/tests/compile-and-dump/Singletons/HigherOrder.ghc78.template --- a/tests/compile-and-dump/Singletons/HigherOrder.ghc78.template +++ b/tests/compile-and-dump/Singletons/HigherOrder.ghc78.template @@ -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 diff --git a/tests/compile-and-dump/Singletons/HigherOrder.hs b/tests/compile-and-dump/Singletons/HigherOrder.hs --- a/tests/compile-and-dump/Singletons/HigherOrder.hs +++ b/tests/compile-and-dump/Singletons/HigherOrder.hs @@ -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 diff --git a/tests/compile-and-dump/Singletons/LambdaCase.ghc76.template b/tests/compile-and-dump/Singletons/LambdaCase.ghc76.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/LambdaCase.ghc76.template @@ -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 diff --git a/tests/compile-and-dump/Singletons/LambdaCase.ghc78.template b/tests/compile-and-dump/Singletons/LambdaCase.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/LambdaCase.ghc78.template @@ -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 diff --git a/tests/compile-and-dump/Singletons/LambdaCase.hs b/tests/compile-and-dump/Singletons/LambdaCase.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/LambdaCase.hs @@ -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 diff --git a/tests/compile-and-dump/Singletons/Lambdas.ghc76.template b/tests/compile-and-dump/Singletons/Lambdas.ghc76.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/Lambdas.ghc76.template @@ -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 diff --git a/tests/compile-and-dump/Singletons/Lambdas.ghc78.template b/tests/compile-and-dump/Singletons/Lambdas.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/Lambdas.ghc78.template @@ -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 diff --git a/tests/compile-and-dump/Singletons/Lambdas.hs b/tests/compile-and-dump/Singletons/Lambdas.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/Lambdas.hs @@ -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 diff --git a/tests/compile-and-dump/Singletons/LambdasComprehensive.ghc76.template b/tests/compile-and-dump/Singletons/LambdasComprehensive.ghc76.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/LambdasComprehensive.ghc76.template @@ -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 diff --git a/tests/compile-and-dump/Singletons/LambdasComprehensive.ghc78.template b/tests/compile-and-dump/Singletons/LambdasComprehensive.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/LambdasComprehensive.ghc78.template @@ -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)) diff --git a/tests/compile-and-dump/Singletons/LambdasComprehensive.hs b/tests/compile-and-dump/Singletons/LambdasComprehensive.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/LambdasComprehensive.hs @@ -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 diff --git a/tests/compile-and-dump/Singletons/LetStatements.ghc76.template b/tests/compile-and-dump/Singletons/LetStatements.ghc76.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/LetStatements.ghc76.template @@ -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 diff --git a/tests/compile-and-dump/Singletons/LetStatements.ghc78.template b/tests/compile-and-dump/Singletons/LetStatements.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/LetStatements.ghc78.template @@ -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 diff --git a/tests/compile-and-dump/Singletons/LetStatements.hs b/tests/compile-and-dump/Singletons/LetStatements.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/LetStatements.hs @@ -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 diff --git a/tests/compile-and-dump/Singletons/Maybe.ghc76.template b/tests/compile-and-dump/Singletons/Maybe.ghc76.template --- a/tests/compile-and-dump/Singletons/Maybe.ghc76.template +++ b/tests/compile-and-dump/Singletons/Maybe.ghc76.template @@ -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) diff --git a/tests/compile-and-dump/Singletons/Maybe.ghc78.template b/tests/compile-and-dump/Singletons/Maybe.ghc78.template --- a/tests/compile-and-dump/Singletons/Maybe.ghc78.template +++ b/tests/compile-and-dump/Singletons/Maybe.ghc78.template @@ -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 diff --git a/tests/compile-and-dump/Singletons/Maybe.hs b/tests/compile-and-dump/Singletons/Maybe.hs --- a/tests/compile-and-dump/Singletons/Maybe.hs +++ b/tests/compile-and-dump/Singletons/Maybe.hs @@ -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) diff --git a/tests/compile-and-dump/Singletons/Nat.ghc76.template b/tests/compile-and-dump/Singletons/Nat.ghc76.template --- a/tests/compile-and-dump/Singletons/Nat.ghc76.template +++ b/tests/compile-and-dump/Singletons/Nat.ghc76.template @@ -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 diff --git a/tests/compile-and-dump/Singletons/Nat.ghc78.template b/tests/compile-and-dump/Singletons/Nat.ghc78.template --- a/tests/compile-and-dump/Singletons/Nat.ghc78.template +++ b/tests/compile-and-dump/Singletons/Nat.ghc78.template @@ -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 diff --git a/tests/compile-and-dump/Singletons/Nat.hs b/tests/compile-and-dump/Singletons/Nat.hs --- a/tests/compile-and-dump/Singletons/Nat.hs +++ b/tests/compile-and-dump/Singletons/Nat.hs @@ -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 diff --git a/tests/compile-and-dump/Singletons/Operators.ghc76.template b/tests/compile-and-dump/Singletons/Operators.ghc76.template --- a/tests/compile-and-dump/Singletons/Operators.ghc76.template +++ b/tests/compile-and-dump/Singletons/Operators.ghc76.template @@ -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) } diff --git a/tests/compile-and-dump/Singletons/Operators.ghc78.template b/tests/compile-and-dump/Singletons/Operators.ghc78.template --- a/tests/compile-and-dump/Singletons/Operators.ghc78.template +++ b/tests/compile-and-dump/Singletons/Operators.ghc78.template @@ -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) diff --git a/tests/compile-and-dump/Singletons/Operators.hs b/tests/compile-and-dump/Singletons/Operators.hs --- a/tests/compile-and-dump/Singletons/Operators.hs +++ b/tests/compile-and-dump/Singletons/Operators.hs @@ -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 diff --git a/tests/compile-and-dump/Singletons/PatternMatching.ghc76.template b/tests/compile-and-dump/Singletons/PatternMatching.ghc76.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/PatternMatching.ghc76.template @@ -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 diff --git a/tests/compile-and-dump/Singletons/PatternMatching.ghc78.template b/tests/compile-and-dump/Singletons/PatternMatching.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/PatternMatching.ghc78.template @@ -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 diff --git a/tests/compile-and-dump/Singletons/PatternMatching.hs b/tests/compile-and-dump/Singletons/PatternMatching.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/PatternMatching.hs @@ -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 diff --git a/tests/compile-and-dump/Singletons/Records.ghc78.template b/tests/compile-and-dump/Singletons/Records.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/Records.ghc78.template @@ -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 diff --git a/tests/compile-and-dump/Singletons/Records.hs b/tests/compile-and-dump/Singletons/Records.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/Records.hs @@ -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 diff --git a/tests/compile-and-dump/Singletons/ReturnFunc.ghc76.template b/tests/compile-and-dump/Singletons/ReturnFunc.ghc76.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/ReturnFunc.ghc76.template diff --git a/tests/compile-and-dump/Singletons/ReturnFunc.ghc78.template b/tests/compile-and-dump/Singletons/ReturnFunc.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/ReturnFunc.ghc78.template @@ -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 diff --git a/tests/compile-and-dump/Singletons/ReturnFunc.hs b/tests/compile-and-dump/Singletons/ReturnFunc.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/ReturnFunc.hs @@ -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 + |]) diff --git a/tests/compile-and-dump/Singletons/Sections.ghc76.template b/tests/compile-and-dump/Singletons/Sections.ghc76.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/Sections.ghc76.template @@ -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 diff --git a/tests/compile-and-dump/Singletons/Sections.ghc78.template b/tests/compile-and-dump/Singletons/Sections.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/Sections.ghc78.template @@ -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)) diff --git a/tests/compile-and-dump/Singletons/Sections.hs b/tests/compile-and-dump/Singletons/Sections.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/Sections.hs @@ -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 diff --git a/tests/compile-and-dump/Singletons/Star.ghc76.template b/tests/compile-and-dump/Singletons/Star.ghc76.template --- a/tests/compile-and-dump/Singletons/Star.ghc76.template +++ b/tests/compile-and-dump/Singletons/Star.ghc76.template @@ -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 | diff --git a/tests/compile-and-dump/Singletons/Star.ghc78.template b/tests/compile-and-dump/Singletons/Star.ghc78.template --- a/tests/compile-and-dump/Singletons/Star.ghc78.template +++ b/tests/compile-and-dump/Singletons/Star.ghc78.template @@ -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 diff --git a/tests/compile-and-dump/Singletons/T29.ghc78.template b/tests/compile-and-dump/Singletons/T29.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/T29.ghc78.template @@ -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 diff --git a/tests/compile-and-dump/Singletons/T29.hs b/tests/compile-and-dump/Singletons/T29.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/T29.hs @@ -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 diff --git a/tests/compile-and-dump/Singletons/T33.ghc78.template b/tests/compile-and-dump/Singletons/T33.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/T33.ghc78.template @@ -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. diff --git a/tests/compile-and-dump/Singletons/T33.hs b/tests/compile-and-dump/Singletons/T33.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/T33.hs @@ -0,0 +1,9 @@ +module Singletons.T33 where + +import Data.Singletons.TH +import Data.Singletons.Prelude + +$(singletons [d| + foo :: (Bool, Bool) -> () + foo ~(_, _) = () + |]) diff --git a/tests/compile-and-dump/Singletons/TopLevelPatterns.ghc76.template b/tests/compile-and-dump/Singletons/TopLevelPatterns.ghc76.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/TopLevelPatterns.ghc76.template @@ -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 diff --git a/tests/compile-and-dump/Singletons/TopLevelPatterns.ghc78.template b/tests/compile-and-dump/Singletons/TopLevelPatterns.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/TopLevelPatterns.ghc78.template @@ -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 diff --git a/tests/compile-and-dump/Singletons/TopLevelPatterns.hs b/tests/compile-and-dump/Singletons/TopLevelPatterns.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/TopLevelPatterns.hs @@ -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] +-} + |]) diff --git a/tests/compile-and-dump/Singletons/Tuples.ghc76.template b/tests/compile-and-dump/Singletons/Tuples.ghc76.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/Tuples.ghc76.template @@ -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 diff --git a/tests/compile-and-dump/Singletons/Tuples.ghc78.template b/tests/compile-and-dump/Singletons/Tuples.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/Tuples.ghc78.template @@ -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 diff --git a/tests/compile-and-dump/Singletons/Tuples.hs b/tests/compile-and-dump/Singletons/Tuples.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/Tuples.hs @@ -0,0 +1,15 @@ +module Singletons.Tuples where + +import Data.Singletons +import Data.Singletons.Single +import Data.Singletons.SuppressUnusedWarnings +import Data.Singletons.Types + +$(genSingletons [ ''() + , ''(,) + , ''(,,) + , ''(,,,) + , ''(,,,,) + , ''(,,,,,) + , ''(,,,,,,) + ])