diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,11 +1,170 @@ -Changelog for singletons project -================================ +Changelog for the `singletons` project +====================================== +3.0.4 [2024.12.11] +------------------ +* Define `Sing` instances such that they explicitly match on their types on the + left-hand sides (e.g., define `type instance Sing @(k1 ~> k2) = SLambda` + instead of `type instance Sing = SLambda`. Doing so will make `singletons` + future-proof once + [GHC#23515](https://gitlab.haskell.org/ghc/ghc/-/issues/23515) is fixed. + +3.0.3 [2024.05.12] +------------------ +* Allow building with GHC 9.10. + +3.0.2 [2022.08.23] +------------------ +* Allow building with GHC 9.4. +* When building with GHC 9.4 or later, use the new + [`withDict`](https://hackage.haskell.org/package/ghc-prim-0.9.0/docs/GHC-Magic-Dict.html#v:withDict) + primitive to implement `withSingI` instead of `unsafeCoerce`. This change + should not have any consequences for user-facing code. + +3.0.1 [2021.10.30] +------------------ +* Add `SingI1` and `SingI2`, higher-order versions of `SingI`, to + `Data.Singletons`, along with various derived functions: + + * `sing{1,2}` + * `singByProxy{1,2}` and `singByProxy{1,2}#` + * `usingSing{1,2}` + * `withSing{1,2}` + * `singThat{1,2}` + +3.0 [2021.03.12] +---------------- +* The `singletons` library has been split into three libraries: + + * The new `singletons` library is now a minimal library that only provides + `Data.Singletons`, `Data.Singletons.Decide`, `Data.Singletons.Sigma`, and + `Data.Singletons.ShowSing` (if compiled with GHC 8.6 or later). + `singletons` now supports building GHCs back to GHC 8.0, as well as GHCJS. + * The `singletons-th` library defines Template Haskell functionality for + promoting and singling term-level definitions, but but nothing else. This + library continues to require the latest stable release of GHC. + * The `singletons-base` library defines promoted and singled versions of + definitions from the `base` library, including the `Prelude`. This library + continues to require the latest stable release of GHC. + + Consult the changelogs for `singletons-th` and `singletons-base` for changes + specific to those libraries. For more information on this split, see the + [relevant GitHub discussion](https://github.com/goldfirere/singletons/issues/420). +* The internals of `ShowSing` have been tweaked to make it possible to derive + `Show` instances for singleton types, e.g., + + ```hs + deriving instance ShowSing a => Show (SList (z :: [a])) + ``` + + For the most part, this is a backwards-compatible change, although there + exists at least one corner case where the new internals of `ShowSing` require + extra work to play nicely with GHC's constraint solver. For more details, + refer to the Haddocks for `ShowSing'` in `Data.Singletons.ShowSing`. + +2.7 +--- +* Require GHC 8.10. +* Record selectors are now singled as top-level functions. For instance, + `$(singletons [d| data T = MkT { unT :: Bool } |])` will now generate this: + + ```hs + data ST :: T -> Type where + SMkT :: Sing b -> Sing (MkT b) + + sUnT :: Sing (t :: T) -> Sing (UnT t :: Bool) + sUnT (SMkT sb) = sb + + ... + ``` + + Instead of this: + + ```hs + data ST :: T -> Type where + SMkT :: { sUnT :: Sing b } -> Sing (MkT b) + ``` + + Note that the new type of `sUnT` is more general than the previous type + (`Sing (MkT b) -> Sing b`). + + There are two primary reasons for this change: + + 1. Singling record selectors as top-level functions is consistent with how + promoting records works (note that `MkT` is also a top-level function). As + 2. Embedding record selectors directly into a singleton data constructor can + result in surprising behavior. This can range from simple code using a + record selector not typechecking to the inability to define multiple + constructors that share the same record name. + + See [this GitHub issue](https://github.com/goldfirere/singletons/issues/364) + for an extended discussion on the motivation behind this change. +* The Template Haskell machinery now supports fine-grained configuration in + the way of an `Options` data type, which lives in the new + `Data.Singletons.TH.Options` module. Besides `Options`, this module also + contains: + * `Options`' record selectors. Currently, these include options to toggle + generating quoted declarations, toggle generating `SingKind` instances, + and configure how `singletons` generates the names of promoted or singled + types. In the future, there may be additional options. + * A `defaultOptions` value. + * An `mtl`-like `OptionsMonad` class for monads that support carrying + `Option`s. This includes `Q`, which uses `defaultOptions` if it is the + top of the monad transformer stack. + * An `OptionM` monad transformer that turns any `DsMonad` into an + `OptionsMonad`. + * A `withOptions` function which allows passing `Options` to TH functions + (e.g., `promote` or `singletons`). See the `README` for a full example + of how to use `withOptions`. + Most TH functions are now polymorphic over `OptionsMonad` instead of + `DsMonad`. +* `singletons` now does a much better job of preserving the order of type + variables in type signatures during promotion and singling. See the + `Support for TypeApplications` section of the `README` for more details. + + When generating type-level declarations in particular (e.g., promoted type + families or defunctionalization symbols), `singletons` will likely also + generate standalone kind signatures to preserve type variable order. As a + result, most `singletons` code that uses Template Haskell will require the + use of the `StandaloneKindSignatures` extension (and, by extension, the + `NoCUSKs` extension) to work. +* `singletons` now does a more much thorough job of rejecting higher-rank types + during promotion or singling, as `singletons` cannot support them. + (Previously, `singletons` would sometimes accept them, often changing rank-2 + types to rank-1 types incorrectly in the process.) +* Add the `Data.Singletons.Prelude.Proxy` module. +* Remove the promoted versions of `genericTake`, `genericDrop`, + `genericSplitAt`, `genericIndex`, and `genericReplicate` from + `Data.Singletons.Prelude.List`. These definitions were subtly wrong since + (1) they claim to work over any `Integral` type `i`, but in practice would + only work on `Nat`s, and (2) wouldn't even typecheck if they were singled. +* Export `ApplyTyConAux1`, `ApplyTyConAux2`, as well as the record pattern + synonyms selector `applySing2`, `applySing3`, etc. from `Data.Singletons`. + These were unintentionally left out in previous releases. +* Export promoted and singled versions of the `getDown` record selector in + `Data.Singletons.Prelude.Ord`. +* Fix a slew of bugs related to fixity declarations: + * Fixity declarations for data types are no longer singled, as fixity + declarations do not serve any purpose for singled data type constructors, + which always have exactly one argument. + * `singletons` now promotes fixity declarations for class names. + `genPromotions`/`genSingletons` now also handle fixity declarations for + classes, class methods, data types, and record selectors correctly. + * `singletons` will no longer erroneously try to single fixity declarations + for type synonym or type family names. + * A bug that caused fixity declarations for certain defunctionalization + symbols not to be generated has been fixed. + * `promoteOnly` and `singletonsOnly` will now produce fixity declarations + for values with infix names. + 2.6 --- * Require GHC 8.8. -* `Sing` has switched from a data family to a type family. This has a number of - consequences: +* `Sing` has switched from a data family to a type family. This + [GitHub issue comment](https://github.com/goldfirere/singletons/issues/318#issuecomment-467067257) + provides a detailed explanation for the motivation behind this change. + + This has a number of consequences: * Names like `SBool`, `SMaybe`, etc. are no longer type synonyms for particular instantiations of `Sing` but are instead the names of the singleton data types themselves. In other words, previous versions of diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2012, Richard Eisenberg +Copyright (c) 2012-2020, Richard Eisenberg All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,746 +1,24 @@ -singletons 2.6 -============== +`singletons` +============ [![Hackage](https://img.shields.io/hackage/v/singletons.svg)](http://hackage.haskell.org/package/singletons) -[![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, , and -with significant contributions by Jan Stolarek, . There -are two papers that describe the library. Original one, _Dependently typed -programming with singletons_, is available -[here](https://cs.brynmawr.edu/~rae/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_, is available -[here](https://cs.brynmawr.edu/~rae/papers/2014/promotion/promotion.pdf) -and will be referenced in this documentation as the -"promotion paper". - -Ryan Scott, , is an active maintainer. - -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 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. - -[This blog series](https://blog.jle.im/entry/introduction-to-singletons-1.html), -authored by Justin Le, offers a tutorial for this library that assumes no -knowledge of dependent types. - -Compatibility -------------- - -The singletons library requires GHC 8.8.1 or greater. 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: - -* `DataKinds` -* `DefaultSignatures` -* `EmptyCase` -* `ExistentialQuantification` -* `FlexibleContexts` -* `FlexibleInstances` -* `GADTs` -* `InstanceSigs` -* `KindSignatures` -* `NoStarIsType` -* `PolyKinds` -* `RankNTypes` -* `ScopedTypeVariables` -* `TemplateHaskell` -* `TypeApplications` -* `TypeFamilies` -* `TypeOperators` -* `UndecidableInstances` - -In particular, `NoStarIsType` is needed to use the `*` type family from the -`PNum` class because with `StarIsType` enabled, GHC thinks `*` is a synonym -for `Type`. - -You may also want - -* `-Wno-redundant-constraints` - -as the code that `singletons` generates uses redundant constraints, and there -seems to be no way, without a large library redesign, to avoid this. - -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 -own singletons. - -`Data.Singletons.TH` exports all the definitions needed to use the Template -Haskell code to generate new singletons. - -`Data.Singletons.Prelude` re-exports `Data.Singletons` along with singleton -definitions for various Prelude types. This module provides a singletonized -equivalent of the real `Prelude`. Note that not all functions from original -`Prelude` could be turned into singletons. - -`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`, `Data.Void` and -`GHC.Base`. We also provide singletonized `Eq`, `Ord`, `Show`, `Enum`, and -`Bounded` typeclasses. - -`Data.Singletons.Decide` exports type classes for propositional equality. - -`Data.Singletons.TypeLits` exports definitions for working with `GHC.TypeLits`. - -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 --------------------------------- - -The top-level functions used to generate singletons are documented in the -`Data.Singletons.TH` module. The most common case is just calling `singletons`, -which I'll describe here: - -```haskell -singletons :: Q [Dec] -> Q [Dec] -``` - -Generates singletons from the definitions given. Because singleton generation -requires promotion, this also promotes all of the definitions given to the -type level. - -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 singletons paper for a more in-depth explanation of these -definitions. Many of the definitions were developed in tandem with Iavor Diatchki. - -```haskell -type family Sing :: k -> Type -``` - -The type family of singleton types. A new instance of this type family is -generated for every new singleton type. - -```haskell -class SingI (a :: k) where - sing :: Sing a -``` - -A class used to pass singleton values implicitly. The `sing` method produces -an explicit singleton value. - -```haskell -data SomeSing k where - SomeSing :: Sing (a :: k) -> SomeSing k -``` - -The `SomeSing` type wraps up an _existentially-quantified_ singleton. Note that -the type parameter `a` does not appear in the `SomeSing` type. Thus, this type -can be used when you have a singleton, but you don't know at compile time what -it will be. `SomeSing Thing` is isomorphic to `Thing`. - -```haskell -class SingKind k where - type Demote k :: * - fromSing :: Sing (a :: k) -> Demote k - toSing :: Demote k -> SomeSing k -``` - -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 `Demote` associated -kind-indexed type family maps the kind `Nat` back to the type `Nat`. - -```haskell -data SingInstance (a :: k) where - SingInstance :: SingI a => SingInstance a -singInstance :: Sing a -> SingInstance a -``` - -Sometimes you have an explicit singleton (a `Sing`) where you need an implicit -one (a dictionary for `SingI`). The `SingInstance` type simply wraps a `SingI` -dictionary, and the `singInstance` function produces this dictionary from an -explicit singleton. The `singInstance` function runs in constant time, using -a little magic. - - -Equality classes ----------------- - -There are two different notions of equality applicable to singletons: Boolean -equality and propositional equality. - -* Boolean equality is implemented in the type family `(:==)` (which is actually -a synonym for the type family `(==)` from `Data.Type.Equality`) and the class -`SEq`. See the `Data.Singletons.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 -`Data.Singletons.Decide` for more information. - -Which one do you need? That depends on your application. Boolean equality has -the advantage that your program can take action when two types do _not_ equal, -while propositional equality has the advantage that GHC can use the equality -of types during type inference. - -Instances of `SEq`, `SDecide`, `TestEquality`, and `TestCoercion` are generated -when `singletons` is called on a datatype that has `deriving Eq`. You can also -generate these instances directly through functions exported from -`Data.Singletons.TH`. - - -`Show` classes --------------- - -Promoted and singled versions of the `Show` class (`PShow` and `SShow`, -respectively) are provided in the `Data.Singletons.Prelude.Show` module. In -addition, there is a `ShowSing` constraint synonym provided in the -`Data.Singletons.ShowSing` module: - -```haskell -type ShowSing k = (forall z. Show (Sing (z :: k)) -``` - -This facilitates the ability to write `Show` instances for `Sing` instances. - -What distinguishes all of these `Show`s? Let's use the `False` constructor as -an example. If you used the `PShow Bool` instance, then the output of calling -`Show_` on `False` is `"False"`, much like the value-level `Show Bool` instance -(similarly for the `SShow Bool` instance). However, the `Show (Sing (z :: Bool))` -instance (i.e., `ShowSing Bool`) is intended for printing the value of the -_singleton_ constructor `SFalse`, so calling `show SFalse` yields `"SFalse"`. - -Instance of `PShow`, `SShow`, and `Show` (for the singleton type) are generated -when `singletons` is called on a datatype that has `deriving Show`. You can also -generate these instances directly through functions exported from -`Data.Singletons.TH`. - -A promoted and singled `Show` instance is provided for `Symbol`, but it is only -a crude approximation of the value-level `Show` instance for `String`. On the -value level, showing `String`s escapes special characters (such as double -quotes), but implementing this requires pattern-matching on character literals, -something which is currently impossible at the type level. As a consequence, the -type-level `Show` instance for `Symbol`s does not do any character escaping. - -Errors ------- - -The `singletons` library provides two different ways to handle errors: - -* The `Error` type family, from `Data.Singletons.TypeLits`: - - ```haskell - type family Error (str :: a) :: k where {} - ``` - - This is simply an empty, closed type family, which means that it will fail - to reduce regardless of its input. The typical use case is giving it a - `Symbol` as an argument, so that something akin to - `Error "This is an error message"` appears in error messages. -* The `TypeError` type family, from `Data.Singletons.TypeError`. This is a - drop-in replacement for `TypeError` from `GHC.TypeLits` which can be used - at both the type level and the value level (via the `typeError` function). - - Unlike `Error`, `TypeError` will result in an actual compile-time error - message, which may be more desirable depending on the use case. - -Pre-defined singletons ----------------------- - -The singletons library defines a number of singleton types and functions -by default: - -* `Bool` -* `Maybe` -* `Either` -* `Ordering` -* `()` -* tuples up to length 7 -* lists - -These are all available through `Data.Singletons.Prelude`. Functions that -operate on these singletons are available from modules such as `Data.Singletons.Bool` -and `Data.Singletons.Maybe`. - -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. - -Note that GHC resolves variable names in Template Haskell quotes. You cannot -then use an undefined identifier in a quote, making idioms like this not -work: -```haskell -type family Foo a where ... -$(promote [d| ... foo x ... |]) -``` -In this example, `foo` would be out of scope. - -Refer to the promotion paper for more details on function promotion. - -Classes and instances ---------------------- - -This is best understood by example. Let's look at a stripped down `Ord`: - -```haskell -class Eq a => Ord a where - compare :: a -> a -> Ordering - (<) :: a -> a -> Bool - x < y = case x `compare` y of - LT -> True - EQ -> False - GT -> False -``` - -This class gets promoted to a "kind class" thus: - -```haskell -class PEq a => POrd a where - type Compare (x :: a) (y :: a) :: Ordering - type (:<) (x :: a) (y :: a) :: Bool - type x :< y = ... -- promoting `case` is yucky. -``` - -Note that default method definitions become default associated type family -instances. This works out quite nicely. - -We also get this singleton class: - -```haskell -class SEq a => SOrd 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) - - default (%:<) :: forall (x :: a) (y :: a). - ((x :< y) ~ {- RHS from (:<) above -}) - => Sing x -> Sing y -> Sing (x :< y) - x %:< y = ... -- this is a bit yucky too -``` - -Note that a singletonized class needs to use `default` signatures, because -type-checking the default body requires that the default associated type -family instance was used in the promoted class. The extra equality constraint -on the default signature asserts this fact to the type checker. - -Instances work roughly similarly. - -```haskell -instance Ord Bool where - compare False False = EQ - compare False True = LT - compare True False = GT - compare True True = EQ - -instance POrd Bool where - type Compare 'False 'False = 'EQ - type Compare 'False 'True = 'LT - type Compare 'True 'False = 'GT - type Compare 'True 'True = 'EQ - -instance SOrd Bool where - sCompare :: forall (x :: a) (y :: a). Sing x -> Sing y -> Sing (Compare x y) - sCompare SFalse SFalse = SEQ - sCompare SFalse STrue = SLT - sCompare STrue SFalse = SGT - sCompare STrue STrue = SEQ -``` - -The only interesting bit here is the instance signature. It's not necessary -in such a simple scenario, but more complicated functions need to refer to -scoped type variables, which the instance signature can bring into scope. -The defaults all just work. - -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: - -1. original datatype: `Nat` - - promoted kind: `Nat` - - singleton type: `SNat` (which is really a synonym for `Sing`) - - -2. original datatype: `/\` - - 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: `+@#@$`, `+@#@$$`, `+@#@$$$` - - -7. original class: `Num` - - promoted class: `PNum` - - singleton class: `SNum` - - -8. original class: `~>` - - promoted class: `#~>` - - singleton class: `%~>` - - -Special names -------------- - -There are some special cases, listed below (with asterisks\* denoting special -treatment): - -1. original datatype: `[]` - - promoted kind: `[]` - - singleton type\*: `SList` - - -2. original constructor: `[]` - - promoted type: `'[]` - - singleton constructor\*: `SNil` - - symbols\*: `NilSym0` - - -3. original constructor: `:` - - promoted type: `':` - - singleton constructor\*: `SCons` - - symbols: `:@#@$`, `:@#@$$`, `:@#@$$$` - - -4. original datatype: `(,)` - - promoted kind: `(,)` - - 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: `___foo` - - promoted type\*: `US___foo` ("`US`" stands for "underscore") - - singleton value\*: `___sfoo` - - symbols\*: `US___fooSym0` - - All functions that begin with leading underscores are treated similarly. - -Supported Haskell constructs ----------------------------- - -The following constructs are fully supported: - -* variables -* tuples -* constructors -* if statements -* infix expressions and types -* `_` patterns -* aliased patterns -* lists (including list comprehensions) -* `do`-notation -* sections -* undefined -* error -* deriving `Eq`, `Ord`, `Show`, `Bounded`, `Enum`, `Functor`, `Foldable`, and - `Traversable`, as well as the `stock` and `anyclass` deriving strategies -* class constraints (though these sometimes fail with `let`, `lambda`, and `case`) -* literals (for `Nat` and `Symbol`), including overloaded number literals -* unboxed tuples (which are treated as normal tuples) -* records -* pattern guards -* case -* let -* lambda expressions -* `!` and `~` patterns (silently but successfully ignored during promotion) -* class and instance declarations -* scoped type variables -* signatures (e.g., `(x :: Maybe a)`) in expressions and patterns -* `InstanceSigs` -* higher-kinded type variables (see below) -* finite arithmetic sequences (see below) -* functional dependencies (with limitations -- see below) -* type families (with limitations -- see below) - -Higher-kinded type variables in `class`/`data` declarations must be annotated -explicitly. This is due to GHC's handling of *complete -user-specified kind signatures*, or [CUSKs](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#complete-user-supplied-kind-signatures-and-polymorphic-recursion). -Briefly, `singletons` has a hard -time conforming to the precise rules that GHC imposes around CUSKs and so -needs a little help around kind inference here. See -[this pull request](https://github.com/goldfirere/singletons/pull/171) for more -background. - -`singletons` is slightly more conservative with respect to `deriving` than GHC is. -The stock classes listed above (`Eq`, `Ord`, `Show`, `Bounded`, `Enum`, `Functor`, -`Foldable`, and `Traversable`) are the only ones that `singletons` will derive -without an explicit deriving strategy. To do anything more exotic, one must -explicitly indicate one's intentions by using the `DerivingStrategies` extension. - -`singletons` fully supports the `anyclass` strategy as well as the `stock` strategy -(at least, for the classes listed above). `singletons` does not support the -`newtype` strategy, as there is not an equivalent of `coerce` at the type level. - -`singletons` has partial support for arithmetic sequences (which desugar to -methods from the `Enum` class under the hood). _Finite_ sequences (e.g., -[0..42]) are fully supported. However, _infinite_ sequences (e.g., [0..]), -which desugar to calls to `enumFromTo` or `enumFromThenTo`, are not supported, -as these would require using infinite lists at the type level. - -The following constructs are supported for promotion but not singleton generation: - -* datatypes with constructors which have contexts. For example, the following - datatype does not singletonize: - - ```haskell - data T a where - MkT :: Show a => a -> T a - ``` - - Constructors like these do not interact well with the current design of the - `SingKind` class. But see - [this bug report](https://github.com/goldfirere/singletons/issues/150), which - proposes a redesign for `SingKind` (in a future version of GHC with certain - bugfixes) which could permit constructors with equality constraints. - -* overlapping patterns. Note that overlapping patterns are - sometimes not obvious. For example, the `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, which is always true and thus -overlaps with `pred x` guard. - - Another non-obvious source of overlapping patterns comes from partial pattern - matches in `do`-notation. For example: - - ```haskell - f :: [()] - f = do - Just () <- [Nothing] - return () - ``` - - This has overlap because the partial pattern match desugars to the following: - - ```haskell - f :: [()] - f = case [Nothing] of - Just () -> return () - _ -> fail "Partial pattern match in do notation" - ``` - - Here, it is more evident that the catch-all pattern `_` overlaps with the - one above it. - -The following constructs are not supported: - -* datatypes that store arrows, `Nat`, or `Symbol` -* literals (limited support) - -Why are these out of reach? - -As described in the promotion paper, promotion of datatypes that store arrows is -currently impossible. So if you have a declaration such as - -```haskell -data Foo = Bar (Bool -> Maybe Bool) -``` - -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. - -This is the same line of reasoning that forbids the use of `Nat` or `Symbol` -in datatype definitions. But, see [this bug -report](https://github.com/goldfirere/singletons/issues/76) for a workaround. - -Support for `*` ---------------- - -The built-in Haskell promotion mechanism does not yet have a full story around -the kind `*` (the kind of types that have values). Ideally, promoting some form -of `TypeRep` would yield `*`, but the implementation of `TypeRep` would have to -be updated for this to really work out. In the meantime, users who wish to -experiment with this feature have two options: - -1) The module `Data.Singletons.TypeRepTYPE` has all the definitions possible for -making `*` the promoted version of `TypeRep`, as `TypeRep` is currently implemented. -The singleton associated with `TypeRep` has one constructor: - - ```haskell - type instance Sing @(TYPE rep) = TypeRep - ``` - - (Recall that `type * = TYPE LiftedRep`.) Note that any datatypes that store -`TypeRep`s will not generally work as expected; the built-in promotion -mechanism will not promote `TypeRep` to `*`. - -2) The module `Data.Singletons.CustomStar` allows the programmer to define a subset -of types with which to work. See the Haddock documentation for the function -`singletonStar` for more info. - -Known bugs ----------- - -* Record updates don't singletonize -* Inference dependent on functional dependencies is unpredictably bad. The - problem is that a use of an associated type family tied to a class with - fundeps doesn't provoke the fundep to kick in. This is GHC's problem, in - the end. -* Singled code that contains uses type families is likely to fail due to GHC - Trac #12564. Note that singling type family declarations themselves is fine - (and often desired, since that produces defunctionalization symbols for them). -* Singling instances of poly-kinded type classes is likely to fail due to - [#358](https://github.com/goldfirere/singletons/issues/358). - However, one can often work around the issue by using `InstanceSigs`. For - instance, the following code will not single: - - ```haskell - class C (f :: k -> Type) where - method :: f a +`singletons` contains the basic types and definitions needed to support +dependently typed programming techniques in Haskell. This library was +originally presented in +[_Dependently Typed Programming with Singletons_](https://richarde.dev/papers/2012/singletons/paper.pdf), +published at the Haskell Symposium, 2012. - instance C [] where - method = [] - ``` +`singletons` is intended to be a small, foundational library on which other +projects can build. As such, `singletons` has a minimal dependency +footprint and supports GHCs dating back to GHC 8.0. For more information, +consult the `singletons` +[`README`](https://github.com/goldfirere/singletons/blob/master/README.md). - Adding a type signature for `method` in the `C []` is sufficient - to work around the issue, though: +You may also be interested in the following related libraries: - ```haskell - instance C [] where - method :: [a] - method = [] - ``` +* The `singletons-th` library defines Template Haskell functionality that + allows _promotion_ of term-level functions to type-level equivalents and + _singling_ functions to dependently typed equivalents. +* The `singletons-base` library uses `singletons-th` to define promoted and + singled functions from the `base` library, including the `Prelude`. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,138 +1,2 @@ -{-# OPTIONS_GHC -Wall #-} -module Main (main) where - -import Control.Monad - -import Data.List -import Data.String - -import Distribution.PackageDescription import Distribution.Simple -import Distribution.Simple.BuildPaths -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.PackageIndex -import Distribution.Simple.Program -import Distribution.Simple.Setup -import Distribution.Simple.Utils -import Distribution.Text - -import System.Directory -import System.FilePath - -main :: IO () -main = defaultMainWithHooks simpleUserHooks - { buildHook = \pkg lbi hooks flags -> do - generateBuildModule flags pkg lbi - buildHook simpleUserHooks pkg lbi hooks flags - , confHook = \(gpd, hbi) flags -> - confHook simpleUserHooks (amendGPD gpd, hbi) flags - , haddockHook = \pkg lbi hooks flags -> do - generateBuildModule (haddockToBuildFlags flags) pkg lbi - haddockHook simpleUserHooks pkg lbi hooks flags - } - --- | Convert only flags used by 'generateBuildModule'. -haddockToBuildFlags :: HaddockFlags -> BuildFlags -haddockToBuildFlags f = emptyBuildFlags - { buildVerbosity = haddockVerbosity f - , buildDistPref = haddockDistPref f - } - -generateBuildModule :: BuildFlags -> PackageDescription -> LocalBuildInfo -> IO () -generateBuildModule flags pkg lbi = do - rootDir <- getCurrentDirectory - let verbosity = fromFlag (buildVerbosity flags) - distPref = fromFlag (buildDistPref flags) - distPref' | isRelative distPref = rootDir distPref - | otherwise = distPref - -- Package DBs - dbStack = withPackageDB lbi ++ [ SpecificPackageDB $ distPref' "package.conf.inplace" ] - dbFlags = "-hide-all-packages" : "-package-env=-" : packageDbArgsDb dbStack - - ghc = case lookupProgram ghcProgram (withPrograms lbi) of - Just fp -> locationPath $ programLocation fp - Nothing -> error "Can't find GHC path" - withTestLBI pkg lbi $ \suite suitecfg -> when (testName suite == fromString testSuiteName) $ do - let testAutogenDir = autogenComponentModulesDir lbi suitecfg - createDirectoryIfMissingVerbose verbosity True testAutogenDir - let buildSingletonsFile = testAutogenDir buildSingletonsModule <.> "hs" - withLibLBI pkg lbi $ \_ libCLBI -> do - let libDeps = map fst $ componentPackageDeps libCLBI - pidx = case dependencyClosure (installedPkgs lbi) libDeps of - Left p -> p - Right _ -> error "Broken dependency closure" - libTransDeps = map installedUnitId $ allPackages pidx - singletonsUnitId = componentUnitId libCLBI - deps = formatDeps (singletonsUnitId:libTransDeps) - allFlags = dbFlags ++ deps - writeFile buildSingletonsFile $ unlines - [ "module Build_singletons where" - , "" - , "ghcPath :: FilePath" - , "ghcPath = " ++ show ghc - , "" - , "ghcFlags :: [String]" - , "ghcFlags = " ++ show allFlags - , "" - , "rootDir :: FilePath" - , "rootDir = " ++ show rootDir - ] - where - formatDeps = map formatOne - formatOne installedPkgId = "-package-id=" ++ display installedPkgId - - -- GHC >= 7.6 uses the '-package-db' flag. See - -- https://ghc.haskell.org/trac/ghc/ticket/5977. - packageDbArgsDb :: [PackageDB] -> [String] - -- special cases to make arguments prettier in common scenarios - packageDbArgsDb dbstack = case dbstack of - (GlobalPackageDB:UserPackageDB:dbs) - | all isSpecific dbs -> concatMap single dbs - (GlobalPackageDB:dbs) - | all isSpecific dbs -> "-no-user-package-db" - : concatMap single dbs - dbs -> "-clear-package-db" - : concatMap single dbs - where - single (SpecificPackageDB db) = [ "-package-db=" ++ db ] - single GlobalPackageDB = [ "-global-package-db" ] - single UserPackageDB = [ "-user-package-db" ] - isSpecific (SpecificPackageDB _) = True - isSpecific _ = False - -buildSingletonsModule :: FilePath -buildSingletonsModule = "Build_singletons" - -testSuiteName :: String -testSuiteName = "singletons-test-suite" - -amendGPD :: GenericPackageDescription -> GenericPackageDescription -amendGPD gpd = gpd - { condTestSuites = map f (condTestSuites gpd) - } - where - f (name, condTree) - | name == fromString testSuiteName = (name, condTree') - | otherwise = (name, condTree) - where - -- I miss 'lens' - testSuite = condTreeData condTree - bi = testBuildInfo testSuite - om = otherModules bi - am = autogenModules bi - - -- Cons the module to both other-modules and autogen-modules. - -- At the moment, cabal-spec-2.0 and cabal-spec-2.2 don't have - -- "all autogen-modules are other-modules if they aren't exposed-modules" - -- rule. Hopefully cabal-spec-3.0 will have. - -- - -- Note: we `nub`, because it's unclear if that's ok to have duplicate - -- modules in the lists. - om' = nub $ mn : om - am' = nub $ mn : am - - mn = fromString buildSingletonsModule - - bi' = bi { otherModules = om', autogenModules = am' } - testSuite' = testSuite { testBuildInfo = bi' } - condTree' = condTree { condTreeData = testSuite' } +main = defaultMain diff --git a/singletons.cabal b/singletons.cabal --- a/singletons.cabal +++ b/singletons.cabal @@ -1,162 +1,82 @@ name: singletons -version: 2.6 - -- Remember to bump version in the Makefile as well -cabal-version: >= 1.10 -synopsis: A framework for generating singleton types +version: 3.0.4 +cabal-version: 1.24 +synopsis: Basic singleton types and definitions homepage: http://www.github.com/goldfirere/singletons category: Dependent Types author: Richard Eisenberg , Jan Stolarek maintainer: Ryan Scott bug-reports: https://github.com/goldfirere/singletons/issues stability: experimental -tested-with: GHC == 8.8.1 -extra-source-files: README.md, CHANGES.md, - tests/compile-and-dump/buildGoldenFiles.awk, - tests/compile-and-dump/GradingClient/*.hs, - tests/compile-and-dump/InsertionSort/*.hs, - tests/compile-and-dump/Promote/*.hs, - tests/compile-and-dump/Singletons/*.hs - tests/compile-and-dump/GradingClient/*.ghc88.template, - tests/compile-and-dump/InsertionSort/*.ghc88.template, - tests/compile-and-dump/Promote/*.ghc88.template, - tests/compile-and-dump/Singletons/*.ghc88.template +tested-with: GHC == 8.0.2 + , GHC == 8.2.2 + , GHC == 8.4.4 + , GHC == 8.6.5 + , GHC == 8.8.4 + , GHC == 8.10.7 + , GHC == 9.0.2 + , GHC == 9.2.7 + , GHC == 9.4.8 + , GHC == 9.6.6 + , GHC == 9.8.2 + , GHC == 9.10.1 + , GHC == 9.12.1 +extra-source-files: README.md, CHANGES.md license: BSD3 license-file: LICENSE -build-type: Custom +build-type: Simple description: - This library generates singleton types, promoted functions, and singleton - functions using Template Haskell. It is useful for programmers who wish - to use dependently typed programming techniques. The library was originally - presented in /Dependently Typed Programming with Singletons/, published - at the Haskell Symposium, 2012. - () - - Version 1.0 and onwards works a lot harder to promote functions. See the - paper published at Haskell Symposium, 2014: - . + @singletons@ contains the basic types and definitions needed to support + dependently typed programming techniques in Haskell. This library was + originally presented in /Dependently Typed Programming with Singletons/, + published at the Haskell Symposium, 2012. + () + . + @singletons@ is intended to be a small, foundational library on which other + projects can build. As such, @singletons@ has a minimal dependency + footprint and supports GHCs dating back to GHC 8.0. For more information, + consult the @singletons@ + @@. + . + You may also be interested in the following related libraries: + . + * The @singletons-th@ library defines Template Haskell functionality that + allows /promotion/ of term-level functions to type-level equivalents and + /singling/ functions to dependently typed equivalents. + . + * The @singletons-base@ library uses @singletons-th@ to define promoted and + singled functions from the @base@ library, including the "Prelude". source-repository this type: git location: https://github.com/goldfirere/singletons.git - tag: v2.6 + subdir: singletons + tag: v3.0.2 source-repository head type: git location: https://github.com/goldfirere/singletons.git + subdir: singletons branch: master -custom-setup - setup-depends: - base >= 4.13 && < 4.14, - Cabal >= 2.5 && < 3.1, - directory >= 1, - filepath >= 1.3 - library hs-source-dirs: src - build-depends: base >= 4.13 && < 4.14, - mtl >= 2.2.1, - ghc-boot-th, - template-haskell, - containers >= 0.5, - th-desugar >= 1.10 && < 1.11, - pretty, - syb >= 0.4, - text >= 1.2, - transformers >= 0.5.2 + build-depends: base >= 4.9 && < 4.22 default-language: Haskell2010 - other-extensions: TemplateHaskell - -- TemplateHaskell must be listed in cabal file to work with - -- ghc7.8+ - exposed-modules: Data.Singletons - Data.Singletons.CustomStar - Data.Singletons.TypeRepTYPE - Data.Singletons.TH - Data.Singletons.Prelude - Data.Singletons.Prelude.Applicative - Data.Singletons.Prelude.Base - Data.Singletons.Prelude.Bool - Data.Singletons.Prelude.Const - Data.Singletons.Prelude.Either - Data.Singletons.Prelude.Enum - Data.Singletons.Prelude.Eq - Data.Singletons.Prelude.Foldable - Data.Singletons.Prelude.Function - Data.Singletons.Prelude.Functor - Data.Singletons.Prelude.IsString - Data.Singletons.Prelude.Identity - Data.Singletons.Prelude.Ord - Data.Singletons.Prelude.List - Data.Singletons.Prelude.List.NonEmpty - Data.Singletons.Prelude.Maybe - Data.Singletons.Prelude.Monad - Data.Singletons.Prelude.Monad.Fail - Data.Singletons.Prelude.Monad.Zip - Data.Singletons.Prelude.Monoid - Data.Singletons.Prelude.Num - Data.Singletons.Prelude.Semigroup - Data.Singletons.Prelude.Show - Data.Singletons.Prelude.Traversable - Data.Singletons.Prelude.Tuple - Data.Singletons.Prelude.Void - Data.Singletons.TypeError - Data.Singletons.TypeLits Data.Singletons.Decide Data.Singletons.ShowSing Data.Singletons.Sigma - Data.Singletons.SuppressUnusedWarnings - - other-modules: Data.Singletons.Deriving.Infer - Data.Singletons.Deriving.Bounded - Data.Singletons.Deriving.Enum - Data.Singletons.Deriving.Foldable - Data.Singletons.Deriving.Functor - Data.Singletons.Deriving.Ord - Data.Singletons.Deriving.Show - Data.Singletons.Deriving.Traversable - Data.Singletons.Deriving.Util - Data.Singletons.Internal - Data.Singletons.Prelude.List.Internal - Data.Singletons.Prelude.List.Internal.Disambiguation - Data.Singletons.Prelude.Monad.Internal - Data.Singletons.Prelude.Semigroup.Internal - Data.Singletons.Promote - Data.Singletons.Promote.Monad - Data.Singletons.Promote.Eq - Data.Singletons.Promote.Type - Data.Singletons.Promote.Defun - Data.Singletons.Util - Data.Singletons.Partition - 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.Defun - Data.Singletons.Single.Fixity - Data.Singletons.Single - Data.Singletons.TypeLits.Internal - Data.Singletons.Syntax - - ghc-options: -Wall -Wcompat -Wno-redundant-constraints + ghc-options: -Wall test-suite singletons-test-suite type: exitcode-stdio-1.0 hs-source-dirs: tests - ghc-options: -Wall -Wcompat -threaded -with-rtsopts=-maxN16 + ghc-options: -Wall -threaded default-language: Haskell2010 main-is: SingletonsTestSuite.hs other-modules: ByHand ByHand2 - SingletonsTestSuiteUtils - build-depends: base >= 4.13 && < 4.14, - filepath >= 1.3, - process >= 1.1, - turtle >= 1.5, - text >= 1.2, - singletons, - tasty >= 1.2, - tasty-golden >= 2.2 + build-depends: base >= 4.9 && < 4.22, + singletons diff --git a/src/Data/Singletons.hs b/src/Data/Singletons.hs --- a/src/Data/Singletons.hs +++ b/src/Data/Singletons.hs @@ -1,268 +1,1339 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- This module exports the basic definitions to use singletons. For routine --- use, consider importing 'Data.Singletons.Prelude', which exports constructors --- for singletons based on types in the @Prelude@. --- --- You may also want to read --- the original papers presenting this library, available at --- --- and . --- ----------------------------------------------------------------------------- - -module Data.Singletons ( - -- * Main singleton definitions - - Sing, SLambda(..), (@@), - - SingI(..), SingKind(..), - - -- * Working with singletons - KindOf, SameKind, - SingInstance(..), SomeSing(..), - singInstance, pattern Sing, withSingI, - withSomeSing, pattern FromSing, - singByProxy, demote, - - singByProxy#, - withSing, singThat, - - -- ** @WrappedSing@ - WrappedSing(..), SWrappedSing(..), UnwrapSing, - -- $SingletonsOfSingletons - - -- ** Defunctionalization - TyFun, type (~>), - TyCon1, TyCon2, TyCon3, TyCon4, TyCon5, TyCon6, TyCon7, TyCon8, - TyCon, 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, - singFun8, - unSingFun1, unSingFun2, unSingFun3, unSingFun4, unSingFun5, - unSingFun6, unSingFun7, unSingFun8, - -- $SLambdaPatternSynonyms - pattern SLambda2, pattern SLambda3, pattern SLambda4, pattern SLambda5, - pattern SLambda6, pattern SLambda7, pattern SLambda8, - - -- | These type synonyms are exported only to improve error messages; users - -- should not have to mention them. - SingFunction1, SingFunction2, SingFunction3, SingFunction4, SingFunction5, - SingFunction6, SingFunction7, SingFunction8, - - -- * Auxiliary functions - Proxy(..), - - -- * Defunctionalization symbols - DemoteSym0, DemoteSym1, - SameKindSym0, SameKindSym1, SameKindSym2, - KindOfSym0, KindOfSym1, - type (~>@#@$), type (~>@#@$$), type (~>@#@$$$), - ApplySym0, ApplySym1, ApplySym2, - type (@@@#@$), type (@@@#@$$), type (@@@#@$$$) - ) where - -import Data.Singletons.Internal -import Data.Singletons.Prelude.Enum -import Data.Singletons.Prelude.Eq -import Data.Singletons.Prelude.Instances -import Data.Singletons.Prelude.IsString -import Data.Singletons.Prelude.Monoid -import Data.Singletons.Prelude.Num -import Data.Singletons.Prelude.Ord -import Data.Singletons.Prelude.Semigroup -import Data.Singletons.Promote -import Data.Singletons.ShowSing -import Data.Singletons.Single (singITyConInstances) -import Data.String -import qualified Data.Text as T (pack) - ----------------------------------------------------------------------- ----- SingI TyCon{N} instances ---------------------------------------- ----------------------------------------------------------------------- - -{- -Generates SingI instances for TyCon1 through TyCon8: - - instance (forall a. SingI a => SingI (f a), ...) => SingI (TyCon1 f) - instance (forall a b. (SingI a, SingI b) => SingI (f a b), ...) => SingI (TyCon2 f) - ... --} -$(singITyConInstances [1..8]) - ----------------------------------------------------------------------- ----- SomeSing instances ---------------------------------------------- ----------------------------------------------------------------------- - -instance SEq k => Eq (SomeSing k) where - SomeSing a == SomeSing b = fromSing (a %== b) - SomeSing a /= SomeSing b = fromSing (a %/= b) - -instance SOrd k => Ord (SomeSing k) where - SomeSing a `compare` SomeSing b = fromSing (a `sCompare` b) - SomeSing a < SomeSing b = fromSing (a %< b) - SomeSing a <= SomeSing b = fromSing (a %<= b) - SomeSing a > SomeSing b = fromSing (a %> b) - SomeSing a >= SomeSing b = fromSing (a %>= b) - -instance SBounded k => Bounded (SomeSing k) where - minBound = SomeSing sMinBound - maxBound = SomeSing sMaxBound - -instance SEnum k => Enum (SomeSing k) where - succ (SomeSing a) = SomeSing (sSucc a) - pred (SomeSing a) = SomeSing (sPred a) - toEnum n = withSomeSing (fromIntegral n) (SomeSing . sToEnum) - fromEnum (SomeSing a) = fromIntegral (fromSing (sFromEnum a)) - enumFromTo (SomeSing from) (SomeSing to) = - listFromSingShallow (sEnumFromTo from to) - enumFromThenTo (SomeSing from) (SomeSing then_) (SomeSing to) = - listFromSingShallow (sEnumFromThenTo from then_ to) - --- Like the 'fromSing' implementation for lists, but bottoms out at --- 'SomeSing' instead of recursively invoking 'fromSing'. -listFromSingShallow :: SList (x :: [a]) -> [SomeSing a] -listFromSingShallow SNil = [] -listFromSingShallow (SCons x xs) = SomeSing x : listFromSingShallow xs - -instance SNum k => Num (SomeSing k) where - SomeSing a + SomeSing b = SomeSing (a %+ b) - SomeSing a - SomeSing b = SomeSing (a %- b) - SomeSing a * SomeSing b = SomeSing (a %* b) - negate (SomeSing a) = SomeSing (sNegate a) - abs (SomeSing a) = SomeSing (sAbs a) - signum (SomeSing a) = SomeSing (sSignum a) - fromInteger n = withSomeSing (fromIntegral n) (SomeSing . sFromInteger) - -instance ShowSing k => Show (SomeSing k) where - showsPrec p (SomeSing (s :: Sing a)) = - showParen (p > 10) $ showString "SomeSing " . showsPrec 11 s - :: ShowSing' a => ShowS - -instance SSemigroup k => Semigroup (SomeSing k) where - SomeSing a <> SomeSing b = SomeSing (a %<> b) - -instance SMonoid k => Monoid (SomeSing k) where - mempty = SomeSing sMempty - -instance SIsString k => IsString (SomeSing k) where - fromString s = withSomeSing (T.pack s) (SomeSing . sFromString) - ----------------------------------------------------------------------- ----- Defunctionalization symbols ------------------------------------- ----------------------------------------------------------------------- - -$(genDefunSymbols [''Demote, ''SameKind, ''KindOf, ''(~>), ''Apply, ''(@@)]) --- WrapSing, UnwrapSing, and SingFunction1 et al. are not defunctionalizable --- at the moment due to Trac #9269 - -{- $SingletonsOfSingletons - -Aside from being a data type to hang instances off of, 'WrappedSing' has -another purpose as a general-purpose mechanism for allowing one to write -code that uses singletons of other singletons. For instance, suppose you -had the following data type: - -@ -data T :: Type -> Type where - MkT :: forall a (x :: a). 'Sing' x -> F a -> T a -@ - -A naïve attempt at defining a singleton for @T@ would look something like -this: - -@ -data ST :: forall a. T a -> Type where - SMkT :: forall a (x :: a) (sx :: 'Sing' x) (f :: F a). - 'Sing' sx -> 'Sing' f -> ST (MkT sx f) -@ - -But there is a problem here: what exactly /is/ @'Sing' sx@? If @x@ were 'True', -for instance, then @sx@ would be 'STrue', but it's not clear what -@'Sing' 'STrue'@ should be. One could define @SSBool@ to be the singleton of -'SBool's, but in order to be thorough, one would have to generate a singleton -for /every/ singleton type out there. Plus, it's not clear when to stop. Should -we also generate @SSSBool@, @SSSSBool@, etc.? - -Instead, 'WrappedSing' and its singleton 'SWrappedSing' provide a way to talk -about singletons of other arbitrary singletons without the need to generate a -bazillion instances. For reference, here is the definition of 'SWrappedSing': - -@ -newtype 'SWrappedSing' :: forall k (a :: k). 'WrappedSing' a -> Type where - 'SWrapSing' :: forall k (a :: k) (ws :: 'WrappedSing' a). - { 'sUnwrapSing' :: 'Sing' a } -> 'SWrappedSing' ws -type instance 'Sing' \@('WrappedSing' a) = 'SWrappedSing' -@ - -'SWrappedSing' is a bit of an unusual singleton in that its field is a -singleton for @'Sing' \@k@, not @'WrappedSing' \@k@. But that's exactly the -point—a singleton of a singleton contains as much type information as the -underlying singleton itself, so we can get away with just @'Sing' \@k@. - -As an example of this in action, here is how you would define the singleton -for the earlier @T@ type: - -@ -data ST :: forall a. T a -> Type where - SMkT :: forall a (x :: a) (sx :: 'Sing' x) (f :: F a). - 'Sing' ('WrapSing' sx) -> 'Sing' f -> ST (MkT sx f) -@ - -With this technique, we won't need anything like @SSBool@ in order to -instantiate @x@ with 'True'. Instead, the field of type -@'Sing' ('WrapSing' sx)@ will simply be a newtype around 'SBool'. In general, -you'll need /n/ layers of 'WrapSing' if you wish to single a singleton /n/ -times. - -Note that this is not the only possible way to define a singleton for @T@. -An alternative approach that does not make use of singletons-of-singletons is -discussed at some length -. -Due to the technical limitations of this approach, however, we do not use it -in @singletons@ at the moment, instead favoring the -slightly-clunkier-but-more-reliable 'WrappedSing' approach. --} - -{- $SLambdaPatternSynonyms - -@SLambda{2...8}@ are explicitly bidirectional pattern synonyms for -defunctionalized singletons (@'Sing' (f :: k '~>' k' '~>' k'')@). - -As __constructors__: Same as @singFun{2..8}@. For example, one can turn a -binary function on singletons @sTake :: 'SingFunction2' TakeSym0@ into a -defunctionalized singleton @'Sing' (TakeSym :: Nat '~>' [a] '~>' [a])@: - -@ ->>> import Data.Singletons.Prelude.List +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE QuantifiedConstraints #-} +#else +{-# LANGUAGE TypeInType #-} +#endif + +#if __GLASGOW_HASKELL__ >= 810 +{-# LANGUAGE StandaloneKindSignatures #-} +#endif + +#if __GLASGOW_HASKELL__ >= 910 +{-# LANGUAGE TypeAbstractions #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Singletons +-- Copyright : (C) 2013 Richard Eisenberg +-- License : BSD-style (see LICENSE) +-- Maintainer : Ryan Scott +-- Stability : experimental +-- Portability : non-portable +-- +-- This module exports the basic definitions to use singletons. See also +-- @Prelude.Singletons@ from the @singletons-base@ +-- library, which re-exports this module alongside many singled definitions +-- based on the "Prelude". +-- +-- You may also want to read +-- the original papers presenting this library, available at +-- +-- and . +-- +---------------------------------------------------------------------------- + +module Data.Singletons ( + -- * Main singleton definitions + + Sing, SLambda(..), (@@), + + SingI(..), + SingI1(..), sing1, + SingI2(..), sing2, + SingKind(..), + + -- * Working with singletons + KindOf, SameKind, + SingInstance(..), SomeSing(..), + singInstance, pattern Sing, withSingI, + withSomeSing, pattern FromSing, + usingSingI1, usingSingI2, + singByProxy, singByProxy1, singByProxy2, + demote, demote1, demote2, + + singByProxy#, singByProxy1#, singByProxy2#, + withSing, withSing1, withSing2, + singThat, singThat1, singThat2, + + -- ** @WrappedSing@ + WrappedSing(..), SWrappedSing(..), UnwrapSing, + -- $SingletonsOfSingletons + + -- ** Defunctionalization + TyFun, type (~>), + TyCon1, TyCon2, TyCon3, TyCon4, TyCon5, TyCon6, TyCon7, TyCon8, + Apply, type (@@), +#if __GLASGOW_HASKELL__ >= 806 + TyCon, ApplyTyCon, ApplyTyConAux1, ApplyTyConAux2, +#endif + + -- ** Defunctionalized singletons + -- | When calling a higher-order singleton function, you need to use a + -- @singFun...@ function to wrap it. See 'singFun1'. + singFun1, singFun2, singFun3, singFun4, singFun5, singFun6, singFun7, + singFun8, + unSingFun1, unSingFun2, unSingFun3, unSingFun4, unSingFun5, + unSingFun6, unSingFun7, unSingFun8, + -- $SLambdaPatternSynonyms + pattern SLambda2, applySing2, + pattern SLambda3, applySing3, + pattern SLambda4, applySing4, + pattern SLambda5, applySing5, + pattern SLambda6, applySing6, + pattern SLambda7, applySing7, + pattern SLambda8, applySing8, + + -- | These type synonyms are exported only to improve error messages; users + -- should not have to mention them. + SingFunction1, SingFunction2, SingFunction3, SingFunction4, SingFunction5, + SingFunction6, SingFunction7, SingFunction8, + + -- * Auxiliary functions + Proxy(..), + + -- * Defunctionalization symbols + DemoteSym0, DemoteSym1, + SameKindSym0, SameKindSym1, SameKindSym2, + KindOfSym0, KindOfSym1, + type (~>@#@$), type (~>@#@$$), type (~>@#@$$$), + ApplySym0, ApplySym1, ApplySym2, + type (@@@#@$), type (@@@#@$$), type (@@@#@$$$) + ) where + +import Data.Kind (Constraint, Type) +import Data.Proxy (Proxy(..)) +import GHC.Exts (Proxy#) +import Unsafe.Coerce (unsafeCoerce) + +#if MIN_VERSION_base(4,17,0) +import GHC.Exts (withDict) +#endif + +-- | Convenient synonym to refer to the kind of a type variable: +-- @type KindOf (a :: k) = k@ +#if __GLASGOW_HASKELL__ >= 810 +type KindOf :: k -> Type +#endif +type KindOf (a :: k) = k + +-- | Force GHC to unify the kinds of @a@ and @b@. Note that @SameKind a b@ is +-- different from @KindOf a ~ KindOf b@ in that the former makes the kinds +-- unify immediately, whereas the latter is a proposition that GHC considers +-- as possibly false. +#if __GLASGOW_HASKELL__ >= 810 +type SameKind :: k -> k -> Constraint +#endif +type SameKind (a :: k) (b :: k) = (() :: Constraint) + +---------------------------------------------------------------------- +---- Sing & friends -------------------------------------------------- +---------------------------------------------------------------------- + +-- | The singleton kind-indexed type family. +#if __GLASGOW_HASKELL__ >= 810 +type Sing :: k -> Type +#endif +#if __GLASGOW_HASKELL__ >= 910 +type family Sing @k :: k -> Type +#else +type family Sing :: k -> Type +#endif + +{- +Note [The kind of Sing] +~~~~~~~~~~~~~~~~~~~~~~~ +It is important to define Sing like this: + + type Sing :: k -> Type + type family Sing + +Or, equivalently, + + type family Sing :: k -> Type + +There are other conceivable ways to define Sing, but they all suffer from +various drawbacks: + +* type family Sing :: forall k. k -> Type + + Surprisingly, this is /not/ equivalent to `type family Sing :: k -> Type`. + The difference lies in their arity, i.e., the number of arguments that must + be supplied in order to apply Sing. The former declaration has arity 0, while + the latter has arity 1 (this is more obvious if you write the declaration as + GHCi would display it with -fprint-explicit-kinds enabled: + `type family Sing @k :: k -> Type`). + + The former declaration having arity 0 is actually what makes it useless. If + we were to adopt an arity-0 definition of `Sing`, then in order to write + `type instance Sing = SFoo`, GHC would require that `SFoo` must have the kind + `forall k. k -> Type`, and moreover, the kind /must/ be polymorphic in `k`. + This is undesirable, because in practice, every single `Sing` instance in the + wild must monomorphize `k` (e.g., `SBool` monomorphizes it to `Bool`), so an + arity-0 `Sing` simply won't work. In contrast, the current arity-1 definition + of `Sing` /does/ let you monomorphize `k` in type family instances. + +* type family Sing (a :: k) = (r :: Type) | r -> a + + Again, this is not equivalent to `type family Sing :: k -> Type`. This + version of `Sing` has arity 2, since one must supply both `k` and `a` in + order to apply it. While an arity-2 `Sing` is not suffer from the same + polymorphism issues as the arity-0 `Sing` in the previous bullet point, it + does suffer from another issue in that it cannot be partially applied. This + is because its `a` argument /must/ be supplied, whereas with the arity-1 + `Sing`, it is perfectly admissible to write `Sing` without an explicit `a` + argument. (Its invisible `k` argument is filled in automatically behind the + scenes.) + +* type family Sing = (r :: k -> Type) | r -> k + + This is the same as `type family Sing :: k -> Type`, but with an injectivity + annotation. Technically, this definition isn't /wrong/, but the injectivity + annotation is actually unnecessary. Because the return kind of `Sing` is + declared to be `k -> Type`, the `Sing` type constructor is automatically + injective, so `Sing a1 ~ Sing a2` implies `a1 ~~ a2`. + + Another way of phrasing this, using the terminology of Dependent Haskell, is + that the arrow in `Sing`'s return kind is /matchable/, which implies that + `Sing` is an injective type constructor as a consequence. +-} + +-- | A 'SingI' constraint is essentially an implicitly-passed singleton. +-- +-- In contrast to the 'SingKind' class, which is parameterized over data types +-- promoted to the kind level, the 'SingI' class is parameterized over values +-- promoted to the type level. To explain this distinction another way, consider +-- this code: +-- +-- @ +-- f = fromSing (sing @(T :: K)) +-- @ +-- +-- Here, @f@ uses methods from both 'SingI' and 'SingKind'. However, the shape +-- of each constraint is rather different: using 'sing' requires a @SingI T@ +-- constraint, whereas using 'fromSing' requires a @SingKind K@ constraint. +-- +-- If you need to satisfy this constraint with an explicit singleton, please +-- see 'withSingI' or the v'Sing' pattern synonym. +#if __GLASGOW_HASKELL__ >= 900 +type SingI :: forall {k}. k -> Constraint +#endif +class SingI a where + -- | Produce the singleton explicitly. You will likely need the @ScopedTypeVariables@ + -- extension to use this method the way you want. + sing :: Sing a + +-- | A version of the 'SingI' class lifted to unary type constructors. +#if __GLASGOW_HASKELL__ >= 900 +type SingI1 :: forall {k1} {k2}. (k1 -> k2) -> Constraint +#endif +class +#if __GLASGOW_HASKELL__ >= 806 + (forall x. SingI x => SingI (f x)) => +#endif + SingI1 f where + -- | Lift an explicit singleton through a unary type constructor. + -- You will likely need the @ScopedTypeVariables@ extension to use this + -- method the way you want. + liftSing :: Sing x -> Sing (f x) + +-- | Produce a singleton explicitly using implicit 'SingI1' and 'SingI' +-- constraints. You will likely need the @ScopedTypeVariables@ extension to use +-- this method the way you want. +sing1 :: (SingI1 f, SingI x) => Sing (f x) +sing1 = liftSing sing + +-- | A version of the 'SingI' class lifted to binary type constructors. +#if __GLASGOW_HASKELL__ >= 900 +type SingI2 :: forall {k1} {k2} {k3}. (k1 -> k2 -> k3) -> Constraint +#endif +class +#if __GLASGOW_HASKELL__ >= 806 + (forall x y. (SingI x, SingI y) => SingI (f x y)) => +#endif + SingI2 f where + -- | Lift explicit singletons through a binary type constructor. + -- You will likely need the @ScopedTypeVariables@ extension to use this + -- method the way you want. + liftSing2 :: Sing x -> Sing y -> Sing (f x y) + +-- | Produce a singleton explicitly using implicit 'SingI2' and 'SingI' +-- constraints. You will likely need the @ScopedTypeVariables@ extension to use +-- this method the way you want. +sing2 :: (SingI2 f, SingI x, SingI y) => Sing (f x y) +sing2 = liftSing2 sing sing + +-- | An explicitly bidirectional pattern synonym for implicit singletons. +-- +-- As an __expression__: Constructs a singleton @Sing a@ given a +-- implicit singleton constraint @SingI a@. +-- +-- As a __pattern__: Matches on an explicit @Sing a@ witness bringing +-- an implicit @SingI a@ constraint into scope. +#if __GLASGOW_HASKELL__ >= 802 +{-# COMPLETE Sing #-} +#endif +pattern Sing :: forall k (a :: k). () => SingI a => Sing a +pattern Sing <- (singInstance -> SingInstance) + where Sing = sing + +-- | The 'SingKind' class is a /kind/ class. It classifies all kinds +-- for which singletons are defined. The class supports converting between a singleton +-- type and the base (unrefined) type which it is built from. +-- +-- For a 'SingKind' instance to be well behaved, it should obey the following laws: +-- +-- @ +-- 'toSing' . 'fromSing' ≡ 'SomeSing' +-- (\\x -> 'withSomeSing' x 'fromSing') ≡ 'id' +-- @ +-- +-- The final law can also be expressed in terms of the 'FromSing' pattern +-- synonym: +-- +-- @ +-- (\\('FromSing' sing) -> 'FromSing' sing) ≡ 'id' +-- @ +#if __GLASGOW_HASKELL__ >= 810 +type SingKind :: Type -> Constraint +#endif +class SingKind k where + -- | Get a base type from the promoted kind. For example, + -- @Demote Bool@ will be the type @Bool@. Rarely, the type and kind do not + -- match. For example, @Demote Nat@ is @Natural@. + type Demote k = (r :: Type) | r -> k + + -- | Convert a singleton to its unrefined version. + fromSing :: Sing (a :: k) -> Demote k + + -- | Convert an unrefined type to an existentially-quantified singleton type. + toSing :: Demote k -> SomeSing k + +-- | An /existentially-quantified/ singleton. This type is useful when you want a +-- singleton type, but there is no way of knowing, at compile-time, what the type +-- index will be. To make use of this type, you will generally have to use a +-- pattern-match: +-- +-- > foo :: Bool -> ... +-- > foo b = case toSing b of +-- > SomeSing sb -> {- fancy dependently-typed code with sb -} +-- +-- An example like the one above may be easier to write using 'withSomeSing'. +#if __GLASGOW_HASKELL__ >= 810 +type SomeSing :: Type -> Type +#endif +data SomeSing k where + SomeSing :: Sing (a :: k) -> SomeSing k + +-- | An explicitly bidirectional pattern synonym for going between a +-- singleton and the corresponding demoted term. +-- +-- As an __expression__: this takes a singleton to its demoted (base) +-- type. +-- +-- >>> :t FromSing \@Bool +-- FromSing \@Bool :: Sing a -> Bool +-- >>> FromSing SFalse +-- False +-- +-- As a __pattern__: It extracts a singleton from its demoted (base) +-- type. +-- +-- @ +-- singAnd :: 'Bool' -> 'Bool' -> 'SomeSing' 'Bool' +-- singAnd ('FromSing' singBool1) ('FromSing' singBool2) = +-- 'SomeSing' (singBool1 %&& singBool2) +-- @ +-- +-- instead of writing it with 'withSomeSing': +-- +-- @ +-- singAnd bool1 bool2 = +-- 'withSomeSing' bool1 $ \singBool1 -> +-- 'withSomeSing' bool2 $ \singBool2 -> +-- 'SomeSing' (singBool1 %&& singBool2) +-- @ +#if __GLASGOW_HASKELL__ >= 802 +{-# COMPLETE FromSing #-} +#endif +pattern FromSing :: SingKind k => forall (a :: k). Sing a -> Demote k +pattern FromSing sng <- ((\demotedVal -> withSomeSing demotedVal SomeSing) -> SomeSing sng) + where FromSing sng = fromSing sng + +---------------------------------------------------------------------- +---- WrappedSing ----------------------------------------------------- +---------------------------------------------------------------------- + +-- | A newtype around 'Sing'. +-- +-- Since 'Sing' is a type family, it cannot be used directly in type class +-- instances. As one example, one cannot write a catch-all +-- @instance 'SDecide' k => 'TestEquality' ('Sing' k)@. On the other hand, +-- 'WrappedSing' is a perfectly ordinary data type, which means that it is +-- quite possible to define an +-- @instance 'SDecide' k => 'TestEquality' ('WrappedSing' k)@. +#if __GLASGOW_HASKELL__ >= 810 +type WrappedSing :: k -> Type +#endif +newtype WrappedSing :: forall k. k -> Type where + WrapSing :: forall k (a :: k). { unwrapSing :: Sing a } -> WrappedSing a + +-- | The singleton for 'WrappedSing's. Informally, this is the singleton type +-- for other singletons. +#if __GLASGOW_HASKELL__ >= 810 +type SWrappedSing :: forall k (a :: k). WrappedSing a -> Type +#endif +newtype SWrappedSing :: forall k (a :: k). WrappedSing a -> Type where + SWrapSing :: forall k (a :: k) (ws :: WrappedSing a). + { sUnwrapSing :: Sing a } -> SWrappedSing ws +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @(WrappedSing a) = +#else +type instance Sing = +#endif + SWrappedSing + +#if __GLASGOW_HASKELL__ >= 810 +type UnwrapSing :: forall k (a :: k). WrappedSing a -> Sing a +#endif +type family UnwrapSing (ws :: WrappedSing (a :: k)) :: Sing a where + UnwrapSing ('WrapSing s) = s + +instance SingKind (WrappedSing a) where + type Demote (WrappedSing a) = WrappedSing a + fromSing (SWrapSing s) = WrapSing s + toSing (WrapSing s) = SomeSing $ SWrapSing s + +instance forall a (s :: Sing a). SingI a => SingI ('WrapSing s) where + sing = SWrapSing sing + +---------------------------------------------------------------------- +---- SingInstance ---------------------------------------------------- +---------------------------------------------------------------------- + +-- | A 'SingInstance' wraps up a 'SingI' instance for explicit handling. +#if __GLASGOW_HASKELL__ >= 810 +type SingInstance :: k -> Type +#endif +data SingInstance (a :: k) where + SingInstance :: SingI a => SingInstance a + +-- | Get an implicit singleton (a 'SingI' instance) from an explicit one. +singInstance :: forall k (a :: k). Sing a -> SingInstance a +singInstance s = with_sing_i SingInstance + where + with_sing_i :: (SingI a => SingInstance a) -> SingInstance a +#if MIN_VERSION_base(4,17,0) + with_sing_i = withDict @(SingI a) @(Sing a) s +#else + with_sing_i si = unsafeCoerce (Don'tInstantiate si) s + +-- dirty implementation of explicit-to-implicit conversion +#if __GLASGOW_HASKELL__ >= 810 +type DI :: k -> Type +#endif +newtype DI a = Don'tInstantiate (SingI a => SingInstance a) +#endif + +---------------------------------------------------------------------- +---- Defunctionalization --------------------------------------------- +---------------------------------------------------------------------- + +-- | Representation of the kind of a type-level function. The difference +-- between term-level arrows and this type-level arrow is that at the term +-- level applications can be unsaturated, whereas at the type level all +-- applications have to be fully saturated. +#if __GLASGOW_HASKELL__ >= 810 +type TyFun :: Type -> Type -> Type +#endif +data TyFun :: Type -> Type -> Type + +-- | Something of kind @a '~>' b@ is a defunctionalized type function that is +-- not necessarily generative or injective. Defunctionalized type functions +-- (also called \"defunctionalization symbols\") can be partially applied, even +-- if the original type function cannot be. For more information on how this +-- works, see the "Promotion and partial application" section of the +-- @@. +-- +-- The singleton for things of kind @a '~>' b@ is 'SLambda'. 'SLambda' values +-- can be constructed in one of two ways: +-- +-- 1. With the @singFun*@ family of combinators (e.g., 'singFun1'). For +-- example, if you have: +-- +-- @ +-- type Id :: a -> a +-- sId :: Sing a -> Sing (Id a) +-- @ +-- +-- Then you can construct a value of type @'Sing' \@(a '~>' a)@ (that is, +-- @'SLambda' \@a \@a@ like so: +-- +-- @ +-- sIdFun :: 'Sing' \@(a '~>' a) IdSym0 +-- sIdFun = singFun1 @IdSym0 sId +-- @ +-- +-- Where @IdSym0 :: a '~>' a@ is the defunctionlized version of @Id@. +-- +-- 2. Using the 'SingI' class. For example, @'sing' \@IdSym0@ is another way of +-- defining @sIdFun@ above. The @singletons-th@ library automatically +-- generates 'SingI' instances for defunctionalization symbols such as +-- @IdSym0@. +-- +-- Normal type-level arrows @(->)@ can be converted into defunctionalization +-- arrows @('~>')@ by the use of the 'TyCon' family of types. (Refer to the +-- Haddocks for 'TyCon1' to see an example of this in practice.) For this +-- reason, we do not make an effort to define defunctionalization symbols for +-- most type constructors of kind @a -> b@, as they can be used in +-- defunctionalized settings by simply applying @TyCon{N}@ with an appropriate +-- @N@. +-- +-- This includes the @(->)@ type constructor itself, which is of kind +-- @'Type' -> 'Type' -> 'Type'@. One can turn it into something of kind +-- @'Type' '~>' 'Type' '~>' 'Type'@ by writing @'TyCon2' (->)@, or something of +-- kind @'Type' -> 'Type' '~>' 'Type'@ by writing @'TyCon1' ((->) t)@ +-- (where @t :: 'Type'@). +#if __GLASGOW_HASKELL__ >= 810 +type (~>) :: Type -> Type -> Type +#endif +type a ~> b = TyFun a b -> Type +infixr 0 ~> + +-- | Type level function application +#if __GLASGOW_HASKELL__ >= 810 +type Apply :: (k1 ~> k2) -> k1 -> k2 +#endif +type family Apply (f :: k1 ~> k2) (x :: k1) :: k2 + +-- | An infix synonym for `Apply` +#if __GLASGOW_HASKELL__ >= 810 +type (@@) :: (k1 ~> k2) -> k1 -> k2 +#endif +type a @@ b = Apply a b +infixl 9 @@ + +#if __GLASGOW_HASKELL__ >= 806 +-- | Workhorse for the 'TyCon1', etc., types. This can be used directly +-- in place of any of the @TyConN@ types, but it will work only with +-- /monomorphic/ types. When GHC#14645 is fixed, this should fully supersede +-- the @TyConN@ types. +-- +-- Note that this is only defined on GHC 8.6 or later. Prior to GHC 8.6, +-- 'TyCon1' /et al./ were defined as separate data types. +#if __GLASGOW_HASKELL__ >= 810 +type TyCon :: (k1 -> k2) -> unmatchable_fun +#endif +data family TyCon :: (k1 -> k2) -> unmatchable_fun +-- That unmatchable_fun should really be a function of k1 and k2, +-- but GHC 8.4 doesn't support type family calls in the result kind +-- of a data family. It should. See GHC#14645. + +-- The result kind of this is also a bit wrong; it should line +-- up with unmatchable_fun above. However, we can't do that +-- because GHC is too stupid to remember that f's kind can't +-- have more than one argument when kind-checking the RHS of +-- the second equation. Note that this infelicity is independent +-- of the problem in the kind of TyCon. There is no GHC ticket +-- here because dealing with inequality like this is hard, and +-- I (Richard) wasn't sure what concrete value the ticket would +-- have, given that we don't know how to begin fixing it. + +-- | An \"internal\" definition used primary in the 'Apply' instance for +-- 'TyCon'. +-- +-- Note that this only defined on GHC 8.6 or later. +#if __GLASGOW_HASKELL__ >= 810 +type ApplyTyCon :: (k1 -> k2) -> (k1 ~> unmatchable_fun) +#endif +#if __GLASGOW_HASKELL__ >= 910 +type family ApplyTyCon @k1 @k2 @unmatchable_fun :: (k1 -> k2) -> (k1 ~> unmatchable_fun) where +#else +type family ApplyTyCon :: (k1 -> k2) -> (k1 ~> unmatchable_fun) where +#endif +#if __GLASGOW_HASKELL__ >= 808 + ApplyTyCon @k1 @(k2 -> k3) @unmatchable_fun = ApplyTyConAux2 + ApplyTyCon @k1 @k2 @k2 = ApplyTyConAux1 +#else + ApplyTyCon = (ApplyTyConAux2 :: (k1 -> k2 -> k3) -> (k1 ~> unmatchable_fun)) + ApplyTyCon = (ApplyTyConAux1 :: (k1 -> k2) -> (k1 ~> k2)) +#endif +-- Upon first glance, the definition of ApplyTyCon (as well as the +-- corresponding Apply instance for TyCon) seems a little indirect. One might +-- wonder why these aren't defined like so: +-- +-- type family ApplyTyCon (f :: k1 -> k2) (x :: k1) :: k3 where +-- ApplyTyCon (f :: k1 -> k2 -> k3) x = TyCon (f x) +-- ApplyTyCon f x = f x +-- +-- type instance Apply (TyCon f) x = ApplyTyCon f x +-- +-- This also works, but it requires that ApplyTyCon always be applied to a +-- minimum of two arguments. In particular, this rules out a trick that we use +-- elsewhere in the library to write SingI instances for different TyCons, +-- which relies on partial applications of ApplyTyCon: +-- +-- instance forall k1 k2 (f :: k1 -> k2). +-- ( forall a. SingI a => SingI (f a) +-- , (ApplyTyCon :: (k1 -> k2) -> (k1 ~> k2)) ~ ApplyTyConAux1 +-- ) => SingI (TyCon1 f) where +#if __GLASGOW_HASKELL__ >= 808 +type instance Apply @k1 @k3 (TyCon @k1 @k2 @(k1 ~> k3) f) x = +#else +type instance Apply (TyCon f) x = +#endif + ApplyTyCon f @@ x + +-- | An \"internal\" defunctionalization symbol used primarily in the +-- definition of 'ApplyTyCon', as well as the 'SingI' instances for 'TyCon1', +-- 'TyCon2', etc. +-- +-- Note that this is only defined on GHC 8.6 or later. +#if __GLASGOW_HASKELL__ >= 810 +type ApplyTyConAux1 :: (k1 -> k2) -> (k1 ~> k2) +#endif +data ApplyTyConAux1 :: (k1 -> k2) -> (k1 ~> k2) + +-- | An \"internal\" defunctionalization symbol used primarily in the +-- definition of 'ApplyTyCon'. +-- +-- Note that this is only defined on GHC 8.6 or later. +#if __GLASGOW_HASKELL__ >= 810 +type ApplyTyConAux2 :: (k1 -> k2 -> k3) -> (k1 ~> unmatchable_fun) +#endif +data ApplyTyConAux2 :: (k1 -> k2 -> k3) -> (k1 ~> unmatchable_fun) + +type instance Apply (ApplyTyConAux1 f) x = f x +type instance Apply (ApplyTyConAux2 f) x = TyCon (f x) + +#if __GLASGOW_HASKELL__ >= 810 +type TyCon1 :: (k1 -> k2) -> (k1 ~> k2) +type TyCon2 :: (k1 -> k2 -> k3) -> (k1 ~> k2 ~> k3) +type TyCon3 :: (k1 -> k2 -> k3 -> k4) -> (k1 ~> k2 ~> k3 ~> k4) +type TyCon4 :: (k1 -> k2 -> k3 -> k4 -> k5) -> (k1 ~> k2 ~> k3 ~> k4 ~> k5) +type TyCon5 :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6) + -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6) +type TyCon6 :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7) + -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7) +type TyCon7 :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7 -> k8) + -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7 ~> k8) +type TyCon8 :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7 -> k8 -> k9) + -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7 ~> k8 ~> k9) +#endif + +-- | Wrapper for converting the normal type-level arrow into a '~>'. +-- For example, given: +-- +-- > data Nat = Zero | Succ Nat +-- > type family Map (a :: a ~> b) (a :: [a]) :: [b] +-- > Map f '[] = '[] +-- > Map f (x ': xs) = Apply f x ': Map f xs +-- +-- We can write: +-- +-- > Map (TyCon1 Succ) [Zero, Succ Zero] +#if __GLASGOW_HASKELL__ >= 910 +type TyCon1 @k1 @k2 = (TyCon :: (k1 -> k2) -> (k1 ~> k2)) + +-- | Similar to 'TyCon1', but for two-parameter type constructors. +type TyCon2 @k1 @k2 @k3 = + (TyCon :: (k1 -> k2 -> k3) -> (k1 ~> k2 ~> k3)) +type TyCon3 @k1 @k2 @k3 @k4 = + (TyCon :: (k1 -> k2 -> k3 -> k4) -> (k1 ~> k2 ~> k3 ~> k4)) +type TyCon4 @k1 @k2 @k3 @k4 @k5 = + (TyCon :: (k1 -> k2 -> k3 -> k4 -> k5) -> (k1 ~> k2 ~> k3 ~> k4 ~> k5)) +type TyCon5 @k1 @k2 @k3 @k4 @k5 @k6 = + (TyCon :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6) + -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6)) +type TyCon6 @k1 @k2 @k3 @k4 @k5 @k6 @k7 = + (TyCon :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7) + -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7)) +type TyCon7 @k1 @k2 @k3 @k4 @k5 @k6 @k7 @k8 = + (TyCon :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7 -> k8) + -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7 ~> k8)) +type TyCon8 @k1 @k2 @k3 @k4 @k5 @k6 @k7 @k8 @k9 = + (TyCon :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7 -> k8 -> k9) + -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7 ~> k8 ~> k9)) +#else +type TyCon1 = (TyCon :: (k1 -> k2) -> (k1 ~> k2)) + +-- | Similar to 'TyCon1', but for two-parameter type constructors. +type TyCon2 = (TyCon :: (k1 -> k2 -> k3) -> (k1 ~> k2 ~> k3)) +type TyCon3 = (TyCon :: (k1 -> k2 -> k3 -> k4) -> (k1 ~> k2 ~> k3 ~> k4)) +type TyCon4 = (TyCon :: (k1 -> k2 -> k3 -> k4 -> k5) -> (k1 ~> k2 ~> k3 ~> k4 ~> k5)) +type TyCon5 = (TyCon :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6) + -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6)) +type TyCon6 = (TyCon :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7) + -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7)) +type TyCon7 = (TyCon :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7 -> k8) + -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7 ~> k8)) +type TyCon8 = (TyCon :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7 -> k8 -> k9) + -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7 ~> k8 ~> k9)) +#endif +#else +-- | Wrapper for converting the normal type-level arrow into a '~>'. +-- For example, given: +-- +-- > data Nat = Zero | Succ Nat +-- > type family Map (a :: a ~> b) (a :: [a]) :: [b] +-- > Map f '[] = '[] +-- > Map f (x ': xs) = Apply f x ': Map f xs +-- +-- We can write: +-- +-- > Map (TyCon1 Succ) [Zero, Succ Zero] +data TyCon1 :: (k1 -> k2) -> (k1 ~> k2) + +-- | Similar to 'TyCon1', but for two-parameter type constructors. +data TyCon2 :: (k1 -> k2 -> k3) -> (k1 ~> k2 ~> k3) +data TyCon3 :: (k1 -> k2 -> k3 -> k4) -> (k1 ~> k2 ~> k3 ~> k4) +data TyCon4 :: (k1 -> k2 -> k3 -> k4 -> k5) -> (k1 ~> k2 ~> k3 ~> k4 ~> k5) +data TyCon5 :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6) + -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6) +data TyCon6 :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7) + -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7) +data TyCon7 :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7 -> k8) + -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7 ~> k8) +data TyCon8 :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7 -> k8 -> k9) + -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7 ~> k8 ~> k9) + +type instance Apply (TyCon1 f) x = f x +type instance Apply (TyCon2 f) x = TyCon1 (f x) +type instance Apply (TyCon3 f) x = TyCon2 (f x) +type instance Apply (TyCon4 f) x = TyCon3 (f x) +type instance Apply (TyCon5 f) x = TyCon4 (f x) +type instance Apply (TyCon6 f) x = TyCon5 (f x) +type instance Apply (TyCon7 f) x = TyCon6 (f x) +type instance Apply (TyCon8 f) x = TyCon7 (f x) +#endif + +---------------------------------------------------------------------- +---- Defunctionalized Sing instance and utilities -------------------- +---------------------------------------------------------------------- + +-- | The singleton type for functions. Functions have somewhat special +-- treatment in @singletons@ (see the Haddocks for @('~>')@ for more information +-- about this), and as a result, the 'Sing' instance for 'SLambda' is one of the +-- only such instances defined in the @singletons@ library rather than, say, +-- @singletons-base@. +#if __GLASGOW_HASKELL__ >= 810 +type SLambda :: (k1 ~> k2) -> Type +#endif +newtype SLambda (f :: k1 ~> k2) = + SLambda { applySing :: forall t. Sing t -> Sing (f @@ t) } +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @(k1 ~> k2) = +#else +type instance Sing = +#endif + SLambda + +-- | An infix synonym for `applySing` +(@@) :: forall k1 k2 (f :: k1 ~> k2) (t :: k1). Sing f -> Sing t -> Sing (f @@ t) +(@@) f = applySing f + +-- | Note that this instance's 'toSing' implementation crucially relies on the fact +-- that the 'SingKind' instances for 'k1' and 'k2' both satisfy the 'SingKind' laws. +-- If they don't, 'toSing' might produce strange results! +instance (SingKind k1, SingKind k2) => SingKind (k1 ~> k2) where + type Demote (k1 ~> k2) = Demote k1 -> Demote k2 + fromSing sFun x = withSomeSing x (fromSing . applySing sFun) + toSing f = SomeSing slam + where + -- Here, we are essentially "manufacturing" a type-level version of the + -- function f. As long as k1 and k2 obey the SingKind laws, this is a + -- perfectly fine thing to do, since the computational content of Sing f + -- will be isomorphic to that of the function f. + slam :: forall (f :: k1 ~> k2). Sing f + slam = singFun1 @f lam + where + -- Here's the tricky part. We need to demote the argument Sing, apply the + -- term-level function f to it, and promote it back to a Sing. However, + -- we don't have a way to convince the typechecker that for all argument + -- types t, f @@ t should be the same thing as res, which motivates the + -- use of unsafeCoerce. + lam :: forall (t :: k1). Sing t -> Sing (f @@ t) + lam x = withSomeSing (f (fromSing x)) (\(r :: Sing res) -> unsafeCoerce r) + +#if __GLASGOW_HASKELL__ >= 810 +type SingFunction1 :: (a1 ~> b) -> Type +type SingFunction2 :: (a1 ~> a2 ~> b) -> Type +type SingFunction3 :: (a1 ~> a2 ~> a3 ~> b) -> Type +type SingFunction4 :: (a1 ~> a2 ~> a3 ~> a4 ~> b) -> Type +type SingFunction5 :: (a1 ~> a2 ~> a3 ~> a4 ~> a5 ~> b) -> Type +type SingFunction6 :: (a1 ~> a2 ~> a3 ~> a4 ~> a5 ~> a6 ~> b) -> Type +type SingFunction7 :: (a1 ~> a2 ~> a3 ~> a4 ~> a5 ~> a6 ~> a7 ~> b) -> Type +type SingFunction8 :: (a1 ~> a2 ~> a3 ~> a4 ~> a5 ~> a6 ~> a7 ~> a8 ~> b) -> Type +#endif + +type SingFunction1 (f :: a1 ~> b) = + forall t. Sing t -> Sing (f @@ t) + +-- | Use this function when passing a function on singletons as +-- a higher-order function. You will need visible type application +-- to get this to work. For example: +-- +-- > falses = sMap (singFun1 @NotSym0 sNot) +-- > (STrue `SCons` STrue `SCons` SNil) +-- +-- There are a family of @singFun...@ functions, keyed by the number +-- of parameters of the function. +singFun1 :: forall f. SingFunction1 f -> Sing f +singFun1 f = SLambda f + +type SingFunction2 (f :: a1 ~> a2 ~> b) = + forall t1 t2. Sing t1 -> Sing t2 -> Sing (f @@ t1 @@ t2) +singFun2 :: forall f. SingFunction2 f -> Sing f +singFun2 f = SLambda (\x -> singFun1 (f x)) + +type SingFunction3 (f :: a1 ~> a2 ~> a3 ~> b) = + forall t1 t2 t3. + Sing t1 -> Sing t2 -> Sing t3 + -> Sing (f @@ t1 @@ t2 @@ t3) +singFun3 :: forall f. SingFunction3 f -> Sing f +singFun3 f = SLambda (\x -> singFun2 (f x)) + +type SingFunction4 (f :: a1 ~> a2 ~> a3 ~> a4 ~> b) = + forall t1 t2 t3 t4. + Sing t1 -> Sing t2 -> Sing t3 -> Sing t4 + -> Sing (f @@ t1 @@ t2 @@ t3 @@ t4) +singFun4 :: forall f. SingFunction4 f -> Sing f +singFun4 f = SLambda (\x -> singFun3 (f x)) + +type SingFunction5 (f :: a1 ~> a2 ~> a3 ~> a4 ~> a5 ~> b) = + forall t1 t2 t3 t4 t5. + Sing t1 -> Sing t2 -> Sing t3 -> Sing t4 -> Sing t5 + -> Sing (f @@ t1 @@ t2 @@ t3 @@ t4 @@ t5) +singFun5 :: forall f. SingFunction5 f -> Sing f +singFun5 f = SLambda (\x -> singFun4 (f x)) + +type SingFunction6 (f :: a1 ~> a2 ~> a3 ~> a4 ~> a5 ~> a6 ~> b) = + forall t1 t2 t3 t4 t5 t6. + Sing t1 -> Sing t2 -> Sing t3 -> Sing t4 -> Sing t5 -> Sing t6 + -> Sing (f @@ t1 @@ t2 @@ t3 @@ t4 @@ t5 @@ t6) +singFun6 :: forall f. SingFunction6 f -> Sing f +singFun6 f = SLambda (\x -> singFun5 (f x)) + +type SingFunction7 (f :: a1 ~> a2 ~> a3 ~> a4 ~> a5 ~> a6 ~> a7 ~> b) = + forall t1 t2 t3 t4 t5 t6 t7. + Sing t1 -> Sing t2 -> Sing t3 -> Sing t4 -> Sing t5 -> Sing t6 -> Sing t7 + -> Sing (f @@ t1 @@ t2 @@ t3 @@ t4 @@ t5 @@ t6 @@ t7) +singFun7 :: forall f. SingFunction7 f -> Sing f +singFun7 f = SLambda (\x -> singFun6 (f x)) + +type SingFunction8 (f :: a1 ~> a2 ~> a3 ~> a4 ~> a5 ~> a6 ~> a7 ~> a8 ~> b) = + forall t1 t2 t3 t4 t5 t6 t7 t8. + Sing t1 -> Sing t2 -> Sing t3 -> Sing t4 -> Sing t5 -> Sing t6 -> Sing t7 -> Sing t8 + -> Sing (f @@ t1 @@ t2 @@ t3 @@ t4 @@ t5 @@ t6 @@ t7 @@ t8) +singFun8 :: forall f. SingFunction8 f -> Sing f +singFun8 f = SLambda (\x -> singFun7 (f x)) + +-- | This is the inverse of 'singFun1', and likewise for the other +-- @unSingFun...@ functions. +unSingFun1 :: forall f. Sing f -> SingFunction1 f +unSingFun1 sf = applySing sf + +unSingFun2 :: forall f. Sing f -> SingFunction2 f +unSingFun2 sf x = unSingFun1 (sf @@ x) + +unSingFun3 :: forall f. Sing f -> SingFunction3 f +unSingFun3 sf x = unSingFun2 (sf @@ x) + +unSingFun4 :: forall f. Sing f -> SingFunction4 f +unSingFun4 sf x = unSingFun3 (sf @@ x) + +unSingFun5 :: forall f. Sing f -> SingFunction5 f +unSingFun5 sf x = unSingFun4 (sf @@ x) + +unSingFun6 :: forall f. Sing f -> SingFunction6 f +unSingFun6 sf x = unSingFun5 (sf @@ x) + +unSingFun7 :: forall f. Sing f -> SingFunction7 f +unSingFun7 sf x = unSingFun6 (sf @@ x) + +unSingFun8 :: forall f. Sing f -> SingFunction8 f +unSingFun8 sf x = unSingFun7 (sf @@ x) + +#if __GLASGOW_HASKELL__ >= 802 +{-# COMPLETE SLambda2 #-} +{-# COMPLETE SLambda3 #-} +{-# COMPLETE SLambda4 #-} +{-# COMPLETE SLambda5 #-} +{-# COMPLETE SLambda6 #-} +{-# COMPLETE SLambda7 #-} +{-# COMPLETE SLambda8 #-} +#endif + +pattern SLambda2 :: forall f. SingFunction2 f -> Sing f +pattern SLambda2 {applySing2} <- (unSingFun2 -> applySing2) + where SLambda2 lam2 = singFun2 lam2 + +pattern SLambda3 :: forall f. SingFunction3 f -> Sing f +pattern SLambda3 {applySing3} <- (unSingFun3 -> applySing3) + where SLambda3 lam3 = singFun3 lam3 + +pattern SLambda4 :: forall f. SingFunction4 f -> Sing f +pattern SLambda4 {applySing4} <- (unSingFun4 -> applySing4) + where SLambda4 lam4 = singFun4 lam4 + +pattern SLambda5 :: forall f. SingFunction5 f -> Sing f +pattern SLambda5 {applySing5} <- (unSingFun5 -> applySing5) + where SLambda5 lam5 = singFun5 lam5 + +pattern SLambda6 :: forall f. SingFunction6 f -> Sing f +pattern SLambda6 {applySing6} <- (unSingFun6 -> applySing6) + where SLambda6 lam6 = singFun6 lam6 + +pattern SLambda7 :: forall f. SingFunction7 f -> Sing f +pattern SLambda7 {applySing7} <- (unSingFun7 -> applySing7) + where SLambda7 lam7 = singFun7 lam7 + +pattern SLambda8 :: forall f. SingFunction8 f -> Sing f +pattern SLambda8 {applySing8} <- (unSingFun8 -> applySing8) + where SLambda8 lam8 = singFun8 lam8 + +---------------------------------------------------------------------- +---- Convenience ----------------------------------------------------- +---------------------------------------------------------------------- + +-- | Convenience function for creating a context with an implicit singleton +-- available. +withSingI :: Sing n -> (SingI n => r) -> r +withSingI sn r = + case singInstance sn of + SingInstance -> r + +-- | Convert a normal datatype (like 'Bool') to a singleton for that datatype, +-- passing it into a continuation. +withSomeSing :: forall k r + . SingKind k + => Demote k -- ^ The original datatype + -> (forall (a :: k). Sing a -> r) -- ^ Function expecting a singleton + -> r +withSomeSing x f = + case toSing x of + SomeSing x' -> f x' + +-- | Convert a group of 'SingI1' and 'SingI' constraints (representing a +-- function to apply and its argument, respectively) into a single 'SingI' +-- constraint representing the application. You will likely need the +-- @ScopedTypeVariables@ extension to use this method the way you want. +usingSingI1 :: forall f x r. (SingI1 f, SingI x) => (SingI (f x) => r) -> r +usingSingI1 k = withSingI (sing1 @f @x) k + +-- | Convert a group of 'SingI2' and 'SingI' constraints (representing a +-- function to apply and its arguments, respectively) into a single 'SingI' +-- constraint representing the application. You will likely need the +-- @ScopedTypeVariables@ extension to use this method the way you want. +usingSingI2 :: forall f x y r. (SingI2 f, SingI x, SingI y) => (SingI (f x y) => r) -> r +usingSingI2 k = withSingI (sing2 @f @x @y) k + +-- | A convenience function useful when we need to name a singleton value +-- multiple times. Without this function, each use of 'sing' could potentially +-- refer to a different singleton, and one has to use type signatures (often +-- with @ScopedTypeVariables@) to ensure that they are the same. +withSing :: SingI a => (Sing a -> b) -> b +withSing f = f sing + +-- | A convenience function useful when we need to name a singleton value for a +-- unary type constructor multiple times. Without this function, each use of +-- 'sing1' could potentially refer to a different singleton, and one has to use +-- type signatures (often with @ScopedTypeVariables@) to ensure that they are +-- the same. +withSing1 :: (SingI1 f, SingI x) => (Sing (f x) -> b) -> b +withSing1 f = f sing1 + +-- | A convenience function useful when we need to name a singleton value for a +-- binary type constructor multiple times. Without this function, each use of +-- 'sing1' could potentially refer to a different singleton, and one has to use +-- type signatures (often with @ScopedTypeVariables@) to ensure that they are +-- the same. +withSing2 :: (SingI2 f, SingI x, SingI y) => (Sing (f x y) -> b) -> b +withSing2 f = f sing2 + +-- | A convenience function that names a singleton satisfying a certain +-- property. If the singleton does not satisfy the property, then the function +-- returns 'Nothing'. The property is expressed in terms of the underlying +-- representation of the singleton. +singThat :: forall k (a :: k). (SingKind k, SingI a) + => (Demote k -> Bool) -> Maybe (Sing a) +singThat p = withSing $ \x -> if p (fromSing x) then Just x else Nothing + +-- | A convenience function that names a singleton for a unary type constructor +-- satisfying a certain property. If the singleton does not satisfy the +-- property, then the function returns 'Nothing'. The property is expressed in +-- terms of the underlying representation of the singleton. +singThat1 :: forall k1 k2 (f :: k1 -> k2) (x :: k1). + (SingKind k2, SingI1 f, SingI x) + => (Demote k2 -> Bool) -> Maybe (Sing (f x)) +singThat1 p = withSing1 $ \x -> if p (fromSing x) then Just x else Nothing + +-- | A convenience function that names a singleton for a binary type constructor +-- satisfying a certain property. If the singleton does not satisfy the +-- property, then the function returns 'Nothing'. The property is expressed in +-- terms of the underlying representation of the singleton. +singThat2 :: forall k1 k2 k3 (f :: k1 -> k2 -> k3) (x :: k1) (y :: k2). + (SingKind k3, SingI2 f, SingI x, SingI y) + => (Demote k3 -> Bool) -> Maybe (Sing (f x y)) +singThat2 p = withSing2 $ \x -> if p (fromSing x) then Just x else Nothing + +-- | Allows creation of a singleton when a proxy is at hand. +singByProxy :: SingI a => proxy a -> Sing a +singByProxy _ = sing + +-- | Allows creation of a singleton for a unary type constructor when a proxy +-- is at hand. +singByProxy1 :: (SingI1 f, SingI x) => proxy (f x) -> Sing (f x) +singByProxy1 _ = sing1 + +-- | Allows creation of a singleton for a binary type constructor when a proxy +-- is at hand. +singByProxy2 :: (SingI2 f, SingI x, SingI y) => proxy (f x y) -> Sing (f x y) +singByProxy2 _ = sing2 + +-- | Allows creation of a singleton when a @proxy#@ is at hand. +singByProxy# :: SingI a => Proxy# a -> Sing a +singByProxy# _ = sing + +-- | Allows creation of a singleton for a unary type constructor when a +-- @proxy#@ is at hand. +singByProxy1# :: (SingI1 f, SingI x) => Proxy# (f x) -> Sing (f x) +singByProxy1# _ = sing1 + +-- | Allows creation of a singleton for a binary type constructor when a +-- @proxy#@ is at hand. +singByProxy2# :: (SingI2 f, SingI x, SingI y) => Proxy# (f x y) -> Sing (f x y) +singByProxy2# _ = sing2 + +-- | A convenience function that takes a type as input and demotes it to its +-- value-level counterpart as output. This uses 'SingKind' and 'SingI' behind +-- the scenes, so @'demote' = 'fromSing' 'sing'@. +-- +-- This function is intended to be used with @TypeApplications@. For example: +-- +-- >>> demote @True +-- True +-- +-- >>> demote @(Nothing :: Maybe Ordering) +-- Nothing +-- +-- >>> demote @(Just EQ) +-- Just EQ +-- +-- >>> demote @'(True,EQ) +-- (True,EQ) +demote :: +#if __GLASGOW_HASKELL__ >= 900 + forall {k} (a :: k). (SingKind k, SingI a) => Demote k +#else + forall a. (SingKind (KindOf a), SingI a) => Demote (KindOf a) +#endif +demote = fromSing (sing @a) + +-- | A convenience function that takes a unary type constructor and its +-- argument as input, applies them, and demotes the result to its +-- value-level counterpart as output. This uses 'SingKind', 'SingI1', and +-- 'SingI' behind the scenes, so @'demote1' = 'fromSing' 'sing1'@. +-- +-- This function is intended to be used with @TypeApplications@. For example: +-- +-- >>> demote1 @Just @EQ +-- Just EQ +-- +-- >>> demote1 @('(,) True) @EQ +-- (True,EQ) +demote1 :: +#if __GLASGOW_HASKELL__ >= 900 + forall {k1} {k2} (f :: k1 -> k2) (x :: k1). + (SingKind k2, SingI1 f, SingI x) => + Demote k2 +#else + forall f x. + (SingKind (KindOf (f x)), SingI1 f, SingI x) => + Demote (KindOf (f x)) +#endif +demote1 = fromSing (sing1 @f @x) + +-- | A convenience function that takes a binary type constructor and its +-- arguments as input, applies them, and demotes the result to its +-- value-level counterpart as output. This uses 'SingKind', 'SingI2', and +-- 'SingI' behind the scenes, so @'demote2' = 'fromSing' 'sing2'@. +-- +-- This function is intended to be used with @TypeApplications@. For example: +-- +-- >>> demote2 @'(,) @True @EQ +-- (True,EQ) +demote2 :: +#if __GLASGOW_HASKELL__ >= 900 + forall {k1} {k2} {k3} (f :: k1 -> k2 -> k3) (x :: k1) (y :: k2). + (SingKind k3, SingI2 f, SingI x, SingI y) => + Demote k3 +#else + forall f x y. + (SingKind (KindOf (f x y)), SingI2 f, SingI x, SingI y) => + Demote (KindOf (f x y)) +#endif +demote2 = fromSing (sing2 @f @x @y) + +---------------------------------------------------------------------- +---- SingI TyCon{N} instances ---------------------------------------- +---------------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ >= 806 +instance forall k1 kr (f :: k1 -> kr). + ( forall a. SingI a => SingI (f a) + , (ApplyTyCon :: (k1 -> kr) -> (k1 ~> kr)) + ~ ApplyTyConAux1 + ) => SingI (TyCon1 f) where + sing = singFun1 (`withSingI` sing) +instance forall k1 k2 kr (f :: k1 -> k2 -> kr). + ( forall a b. (SingI a, SingI b) => SingI (f a b) + , (ApplyTyCon :: (k2 -> kr) -> (k2 ~> kr)) + ~ ApplyTyConAux1 + ) => SingI (TyCon2 f) where + sing = singFun1 (`withSingI` sing) +instance forall k1 k2 k3 kr (f :: k1 -> k2 -> k3 -> kr). + ( forall a b c. (SingI a, SingI b, SingI c) => SingI (f a b c) + , (ApplyTyCon :: (k3 -> kr) -> (k3 ~> kr)) + ~ ApplyTyConAux1 + ) => SingI (TyCon3 f) where + sing = singFun1 (`withSingI` sing) +instance forall k1 k2 k3 k4 kr (f :: k1 -> k2 -> k3 -> k4 -> kr). + ( forall a b c d. (SingI a, SingI b, SingI c, SingI d) => SingI (f a b c d) + , (ApplyTyCon :: (k4 -> kr) -> (k4 ~> kr)) + ~ ApplyTyConAux1 + ) => SingI (TyCon4 f) where + sing = singFun1 (`withSingI` sing) +instance forall k1 k2 k3 k4 k5 kr + (f :: k1 -> k2 -> k3 -> k4 -> k5 -> kr). + ( forall a b c d e. + (SingI a, SingI b, SingI c, SingI d, SingI e) + => SingI (f a b c d e) + , (ApplyTyCon :: (k5 -> kr) -> (k5 ~> kr)) + ~ ApplyTyConAux1 + ) => SingI (TyCon5 f) where + sing = singFun1 (`withSingI` sing) +instance forall k1 k2 k3 k4 k5 k6 kr + (f :: k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> kr). + ( forall a b c d e f'. + (SingI a, SingI b, SingI c, SingI d, SingI e, SingI f') + => SingI (f a b c d e f') + , (ApplyTyCon :: (k6 -> kr) -> (k6 ~> kr)) + ~ ApplyTyConAux1 + ) => SingI (TyCon6 f) where + sing = singFun1 (`withSingI` sing) +instance forall k1 k2 k3 k4 k5 k6 k7 kr + (f :: k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7 -> kr). + ( forall a b c d e f' g. + (SingI a, SingI b, SingI c, SingI d, SingI e, SingI f', SingI g) + => SingI (f a b c d e f' g) + , (ApplyTyCon :: (k7 -> kr) -> (k7 ~> kr)) + ~ ApplyTyConAux1 + ) => SingI (TyCon7 f) where + sing = singFun1 (`withSingI` sing) +instance forall k1 k2 k3 k4 k5 k6 k7 k8 kr + (f :: k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7 -> k8 -> kr). + ( forall a b c d e f' g h. + (SingI a, SingI b, SingI c, SingI d, SingI e, SingI f', SingI g, SingI h) + => SingI (f a b c d e f' g h) + , (ApplyTyCon :: (k8 -> kr) -> (k8 ~> kr)) + ~ ApplyTyConAux1 + ) => SingI (TyCon8 f) where + sing = singFun1 (`withSingI` sing) +#endif + +---------------------------------------------------------------------- +---- Defunctionalization symbols ------------------------------------- +---------------------------------------------------------------------- + +-- $(genDefunSymbols [''Demote, ''SameKind, ''KindOf, ''(~>), ''Apply, ''(@@)]) +-- WrapSing, UnwrapSing, and SingFunction1 et al. are not defunctionalizable +-- at the moment due to GHC#9269 + +#if __GLASGOW_HASKELL__ >= 810 +type DemoteSym0 :: Type ~> Type +type DemoteSym1 :: Type -> Type +#endif + +data DemoteSym0 :: Type ~> Type +type DemoteSym1 x = Demote x + +type instance Apply DemoteSym0 x = Demote x + +----- + +#if __GLASGOW_HASKELL__ >= 810 +type SameKindSym0 :: forall k. k ~> k ~> Constraint +type SameKindSym1 :: forall k. k -> k ~> Constraint +type SameKindSym2 :: forall k. k -> k -> Constraint +#endif + +data SameKindSym0 :: forall k. k ~> k ~> Constraint +data SameKindSym1 :: forall k. k -> k ~> Constraint +type SameKindSym2 (x :: k) (y :: k) = SameKind x y + +type instance Apply SameKindSym0 x = SameKindSym1 x +type instance Apply (SameKindSym1 x) y = SameKind x y + +----- + +#if __GLASGOW_HASKELL__ >= 810 +type KindOfSym0 :: forall k. k ~> Type +type KindOfSym1 :: forall k. k -> Type +#endif + +data KindOfSym0 :: forall k. k ~> Type +type KindOfSym1 (x :: k) = KindOf x + +type instance Apply KindOfSym0 x = KindOf x + +----- + +infixr 0 ~>@#@$, ~>@#@$$, ~>@#@$$$ + +#if __GLASGOW_HASKELL__ >= 810 +type (~>@#@$) :: Type ~> Type ~> Type +type (~>@#@$$) :: Type -> Type ~> Type +type (~>@#@$$$) :: Type -> Type -> Type +#endif + +data (~>@#@$) :: Type ~> Type ~> Type +data (~>@#@$$) :: Type -> Type ~> Type +type x ~>@#@$$$ y = x ~> y + +type instance Apply (~>@#@$) x = (~>@#@$$) x +type instance Apply ((~>@#@$$) x) y = x ~> y + +----- + +#if __GLASGOW_HASKELL__ >= 810 +type ApplySym0 :: forall a b. (a ~> b) ~> a ~> b +type ApplySym1 :: forall a b. (a ~> b) -> a ~> b +type ApplySym2 :: forall a b. (a ~> b) -> a -> b +#endif + +data ApplySym0 :: forall a b. (a ~> b) ~> a ~> b +data ApplySym1 :: forall a b. (a ~> b) -> a ~> b +type ApplySym2 (f :: a ~> b) (x :: a) = Apply f x + +type instance Apply ApplySym0 f = ApplySym1 f +type instance Apply (ApplySym1 f) x = Apply f x + +----- + +infixl 9 @@@#@$, @@@#@$$, @@@#@$$$ + +#if __GLASGOW_HASKELL__ >= 810 +type (@@@#@$) :: forall a b. (a ~> b) ~> a ~> b +type (@@@#@$$) :: forall a b. (a ~> b) -> a ~> b +type (@@@#@$$$) :: forall a b. (a ~> b) -> a -> b +#endif + +data (@@@#@$) :: forall a b. (a ~> b) ~> a ~> b +data (@@@#@$$) :: forall a b. (a ~> b) -> a ~> b +type (f :: a ~> b) @@@#@$$$ (x :: a) = f @@ x + +type instance Apply (@@@#@$) f = (@@@#@$$) f +type instance Apply ((@@@#@$$) f) x = f @@ x + +{- $SingletonsOfSingletons + +Aside from being a data type to hang instances off of, 'WrappedSing' has +another purpose as a general-purpose mechanism for allowing one to write +code that uses singletons of other singletons. For instance, suppose you +had the following data type: + +@ +data T :: Type -> Type where + MkT :: forall a (x :: a). 'Sing' x -> F a -> T a +@ + +A naïve attempt at defining a singleton for @T@ would look something like +this: + +@ +data ST :: forall a. T a -> Type where + SMkT :: forall a (x :: a) (sx :: 'Sing' x) (f :: F a). + 'Sing' sx -> 'Sing' f -> ST (MkT sx f) +@ + +But there is a problem here: what exactly /is/ @'Sing' sx@? If @x@ were 'True', +for instance, then @sx@ would be 'STrue', but it's not clear what +@'Sing' 'STrue'@ should be. One could define @SSBool@ to be the singleton of +'SBool's, but in order to be thorough, one would have to generate a singleton +for /every/ singleton type out there. Plus, it's not clear when to stop. Should +we also generate @SSSBool@, @SSSSBool@, etc.? + +Instead, 'WrappedSing' and its singleton 'SWrappedSing' provide a way to talk +about singletons of other arbitrary singletons without the need to generate a +bazillion instances. For reference, here is the definition of 'SWrappedSing': + +@ +newtype 'SWrappedSing' :: forall k (a :: k). 'WrappedSing' a -> Type where + 'SWrapSing' :: forall k (a :: k) (ws :: 'WrappedSing' a). + { 'sUnwrapSing' :: 'Sing' a } -> 'SWrappedSing' ws +type instance 'Sing' \@('WrappedSing' a) = 'SWrappedSing' +@ + +'SWrappedSing' is a bit of an unusual singleton in that its field is a +singleton for @'Sing' \@k@, not @'WrappedSing' \@k@. But that's exactly the +point—a singleton of a singleton contains as much type information as the +underlying singleton itself, so we can get away with just @'Sing' \@k@. + +As an example of this in action, here is how you would define the singleton +for the earlier @T@ type: + +@ +data ST :: forall a. T a -> Type where + SMkT :: forall a (x :: a) (sx :: 'Sing' x) (f :: F a). + 'Sing' ('WrapSing' sx) -> 'Sing' f -> ST (MkT sx f) +@ + +With this technique, we won't need anything like @SSBool@ in order to +instantiate @x@ with 'True'. Instead, the field of type +@'Sing' ('WrapSing' sx)@ will simply be a newtype around 'SBool'. In general, +you'll need /n/ layers of 'WrapSing' if you wish to single a singleton /n/ +times. + +Note that this is not the only possible way to define a singleton for @T@. +An alternative approach that does not make use of singletons-of-singletons is +discussed at some length +. +Due to the technical limitations of this approach, however, we do not use it +in @singletons@ at the moment, instead favoring the +slightly-clunkier-but-more-reliable 'WrappedSing' approach. +-} + +{- $SLambdaPatternSynonyms + +@SLambda{2...8}@ are explicitly bidirectional pattern synonyms for +defunctionalized singletons (@'Sing' (f :: k '~>' k' '~>' k'')@). + +As __constructors__: Same as @singFun{2..8}@. For example, one can turn a +binary function on singletons @sTake :: 'SingFunction2' TakeSym0@ into a +defunctionalized singleton @'Sing' (TakeSym :: Nat '~>' [a] '~>' [a])@: + +@ +>>> import Data.List.Singletons >>> :set -XTypeApplications >>> >>> :t 'SLambda2' diff --git a/src/Data/Singletons/CustomStar.hs b/src/Data/Singletons/CustomStar.hs deleted file mode 100644 --- a/src/Data/Singletons/CustomStar.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# LANGUAGE DataKinds, TypeFamilies, KindSignatures, TemplateHaskell, CPP #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.CustomStar --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- This file implements 'singletonStar', which generates a datatype @Rep@ and associated --- singleton from a list of types. The promoted version of @Rep@ is kind @*@ and the --- Haskell types themselves. This is still very experimental, so expect unusual --- results! --- ----------------------------------------------------------------------------- - -module Data.Singletons.CustomStar ( - singletonStar, - - module Data.Singletons.Prelude.Eq, - module Data.Singletons.Prelude.Bool, - module Data.Singletons.TH - ) where - -import Language.Haskell.TH -import Data.Singletons.Util -import Data.Singletons.Deriving.Infer -import Data.Singletons.Deriving.Ord -import Data.Singletons.Deriving.Show -import Data.Singletons.Promote -import Data.Singletons.Promote.Monad -import Data.Singletons.Single.Monad -import Data.Singletons.Single.Data -import Data.Singletons.Single -import Data.Singletons.Syntax -import Data.Singletons.Names -import Data.Singletons.TH -import Control.Monad -import Data.Maybe -import Language.Haskell.TH.Desugar -import Data.Singletons.Prelude.Eq -import Data.Singletons.Prelude.Bool - --- | Produce a representation and singleton for the collection of types given. --- --- A datatype @Rep@ is created, with one constructor per type in the declared --- universe. When this type is promoted by the singletons library, the --- constructors become full types in @*@, not just promoted data constructors. --- --- For example, --- --- > $(singletonStar [''Nat, ''Bool, ''Maybe]) --- --- generates the following: --- --- > data Rep = Nat | Bool | Maybe Rep deriving (Eq, Ord, Read, Show) --- --- and its singleton. However, because @Rep@ is promoted to @*@, the singleton --- is perhaps slightly unexpected: --- --- > data SRep (a :: *) where --- > SNat :: Sing Nat --- > SBool :: Sing Bool --- > SMaybe :: Sing a -> Sing (Maybe a) --- > type instance Sing = SRep --- --- The unexpected part is that @Nat@, @Bool@, and @Maybe@ above are the real @Nat@, --- @Bool@, and @Maybe@, not just promoted data constructors. --- --- Please note that this function is /very/ experimental. Use at your own risk. -singletonStar :: DsMonad q - => [Name] -- ^ A list of Template Haskell @Name@s for types - -> q [Dec] -singletonStar names = do - kinds <- mapM getKind names - ctors <- zipWithM (mkCtor True) names kinds - let repDecl = DDataD Data [] repName [] (Just (DConT typeKindName)) ctors - [DDerivClause Nothing (map DConT [''Eq, ''Ord, ''Read, ''Show])] - fakeCtors <- zipWithM (mkCtor False) names kinds - let dataDecl = DataDecl repName [] fakeCtors - -- Why do we need withLocalDeclarations here? It's because we end up - -- expanding type synonyms when deriving instances for Rep, which requires - -- reifying Rep itself. Since Rep hasn't been spliced in yet, we must put it - -- into the local declarations. - withLocalDeclarations (decToTH repDecl) $ do - -- We opt to infer the constraints for the Eq instance here so that when it's - -- promoted, Rep will be promoted to Type. - dataDeclEqCxt <- inferConstraints (DConT ''Eq) (DConT repName) fakeCtors - let dataDeclEqInst = DerivedDecl (Just dataDeclEqCxt) (DConT repName) repName dataDecl - ordInst <- mkOrdInstance Nothing (DConT repName) dataDecl - showInst <- mkShowInstance ForPromotion Nothing (DConT repName) dataDecl - (pInsts, promDecls) <- promoteM [] $ do promoteDataDec dataDecl - promoteDerivedEqDec dataDeclEqInst - traverse (promoteInstanceDec mempty) - [ordInst, showInst] - singletonDecls <- singDecsM [] $ do decs1 <- singDataD dataDecl - decs2 <- singDerivedEqDecs dataDeclEqInst - decs3 <- traverse singInstD pInsts - return (decs1 ++ decs2 ++ decs3) - return $ decsToTH $ repDecl : - promDecls ++ - singletonDecls - where -- get the kinds of the arguments to the tycon with the given name - getKind :: DsMonad q => Name -> q [DKind] - getKind name = do - info <- reifyWithLocals name - dinfo <- dsInfo info - case dinfo of - DTyConI (DDataD _ (_:_) _ _ _ _ _) _ -> - fail "Cannot make a representation of a constrained data type" - DTyConI (DDataD _ [] _ tvbs mk _ _) _ -> do - all_tvbs <- buildDataDTvbs tvbs mk - return $ map (fromMaybe (DConT typeKindName) . extractTvbKind) all_tvbs - DTyConI (DTySynD _ tvbs _) _ -> - return $ map (fromMaybe (DConT typeKindName) . extractTvbKind) tvbs - DPrimTyConI _ n _ -> - return $ replicate n $ DConT typeKindName - _ -> 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 :: DsMonad q => Bool -> Name -> [DKind] -> q DCon - mkCtor real name args = do - (types, vars) <- evalForPair $ mapM (kindToType []) args - dataName <- if real then mkDataName (nameBase name) else return name - return $ DCon (map DPlainTV vars) [] dataName - (DNormalC False (map (\ty -> (noBang, ty)) types)) - (DConT repName) - where - noBang = Bang NoSourceUnpackedness NoSourceStrictness - - -- demote a kind back to a type, accumulating any unbound parameters - kindToType :: DsMonad q => [DTypeArg] -> DKind -> QWithAux [Name] q DType - kindToType _ (DForallT _ _ _) = fail "Explicit forall encountered in kind" - kindToType args (DAppT f a) = do - a' <- kindToType [] a - kindToType (DTANormal a' : args) f - kindToType args (DAppKindT f a) = do - a' <- kindToType [] a - kindToType (DTyArg a' : args) f - kindToType args (DSigT t k) = do - t' <- kindToType [] t - k' <- kindToType [] k - return $ DSigT t' k' `applyDType` args - kindToType args (DVarT n) = do - addElement n - return $ DVarT n `applyDType` args - kindToType args (DConT n) = return $ DConT name `applyDType` args - where name | isTypeKindName n = repName - | otherwise = n - kindToType args DArrowT = return $ DArrowT `applyDType` args - kindToType args k@(DLitT {}) = return $ k `applyDType` args - kindToType args DWildCardT = return $ DWildCardT `applyDType` args diff --git a/src/Data/Singletons/Decide.hs b/src/Data/Singletons/Decide.hs --- a/src/Data/Singletons/Decide.hs +++ b/src/Data/Singletons/Decide.hs @@ -1,8 +1,16 @@ -{-# LANGUAGE RankNTypes, PolyKinds, DataKinds, TypeOperators, +{-# LANGUAGE CPP, RankNTypes, PolyKinds, DataKinds, TypeOperators, TypeFamilies, FlexibleContexts, UndecidableInstances, GADTs, TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} +#if __GLASGOW_HASKELL__ < 806 +{-# LANGUAGE TypeInType #-} +#endif + +#if __GLASGOW_HASKELL__ >= 810 +{-# LANGUAGE StandaloneKindSignatures #-} +#endif + ----------------------------------------------------------------------------- -- | -- Module : Data.Singletons.Decide @@ -25,7 +33,8 @@ decideEquality, decideCoercion ) where -import Data.Singletons.Internal +import Data.Kind +import Data.Singletons import Data.Type.Coercion import Data.Type.Equality import Data.Void @@ -37,16 +46,25 @@ -- | Because we can never create a value of type 'Void', a function that type-checks -- at @a -> Void@ shows that objects of type @a@ can never exist. Thus, we say that -- @a@ is 'Refuted' +#if __GLASGOW_HASKELL__ >= 810 +type Refuted :: Type -> Type +#endif type Refuted a = (a -> Void) -- | A 'Decision' about a type @a@ is either a proof of existence or a proof that @a@ -- cannot exist. +#if __GLASGOW_HASKELL__ >= 810 +type Decision :: Type -> Type +#endif data Decision a = Proved a -- ^ Witness for @a@ | Disproved (Refuted a) -- ^ Proof that no @a@ exists -- | Members of the 'SDecide' "kind" class support decidable equality. Instances -- of this class are generated alongside singleton definitions for datatypes that -- derive an 'Eq' instance. +#if __GLASGOW_HASKELL__ >= 810 +type SDecide :: Type -> Constraint +#endif class SDecide k where -- | Compute a proof or disproof of equality, given two singletons. (%~) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Decision (a :~: b) @@ -61,7 +79,7 @@ Proved Refl -> Just Refl Disproved _ -> Nothing -instance SDecide k => TestEquality (WrappedSing @k) where +instance SDecide k => TestEquality (WrappedSing :: k -> Type) where testEquality (WrapSing s1) (WrapSing s2) = decideEquality s1 s2 -- | A suitable default implementation for 'testCoercion' that leverages @@ -73,5 +91,5 @@ Proved Refl -> Just Coercion Disproved _ -> Nothing -instance SDecide k => TestCoercion (WrappedSing @k) where +instance SDecide k => TestCoercion (WrappedSing :: k -> Type) where testCoercion (WrapSing s1) (WrapSing s2) = decideCoercion s1 s2 diff --git a/src/Data/Singletons/Deriving/Bounded.hs b/src/Data/Singletons/Deriving/Bounded.hs deleted file mode 100644 --- a/src/Data/Singletons/Deriving/Bounded.hs +++ /dev/null @@ -1,59 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Deriving.Bounded --- Copyright : (C) 2015 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Implements deriving of Bounded instances --- ----------------------------------------------------------------------------- - -module Data.Singletons.Deriving.Bounded where - -import Language.Haskell.TH.Ppr -import Language.Haskell.TH.Desugar -import Data.Singletons.Names -import Data.Singletons.Util -import Data.Singletons.Syntax -import Data.Singletons.Deriving.Infer -import Data.Singletons.Deriving.Util -import Control.Monad - --- monadic only for failure and parallelism with other functions --- that make instances -mkBoundedInstance :: DsMonad q => DerivDesc q -mkBoundedInstance mb_ctxt ty (DataDecl _ _ 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 Bounded instance for " - ++ pprint (typeToTH ty) ++ ".") - -- 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 - fieldsCount = length $ tysOfConFields fields - (minRHS, maxRHS) = case fieldsCount of - 0 -> (DConE minName, DConE maxName) - _ -> - let minEqnRHS = foldExp (DConE minName) - (replicate fieldsCount (DVarE minBoundName)) - maxEqnRHS = foldExp (DConE maxName) - (replicate fieldsCount (DVarE maxBoundName)) - in (minEqnRHS, maxEqnRHS) - - mk_rhs rhs = UFunction [DClause [] rhs] - constraints <- inferConstraintsDef mb_ctxt (DConT boundedName) ty cons - return $ InstDecl { id_cxt = constraints - , id_name = boundedName - , id_arg_tys = [ty] - , id_sigs = mempty - , id_meths = [ (minBoundName, mk_rhs minRHS) - , (maxBoundName, mk_rhs maxRHS) ] } diff --git a/src/Data/Singletons/Deriving/Enum.hs b/src/Data/Singletons/Deriving/Enum.hs deleted file mode 100644 --- a/src/Data/Singletons/Deriving/Enum.hs +++ /dev/null @@ -1,55 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Deriving.Enum --- Copyright : (C) 2015 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Implements deriving of Enum instances --- ----------------------------------------------------------------------------- - -module Data.Singletons.Deriving.Enum ( mkEnumInstance ) where - -import Language.Haskell.TH.Syntax -import Language.Haskell.TH.Ppr -import Language.Haskell.TH.Desugar -import Data.Singletons.Deriving.Util -import Data.Singletons.Syntax -import Data.Singletons.Util -import Data.Singletons.Names -import Control.Monad -import Data.Maybe - --- monadic for failure only -mkEnumInstance :: DsMonad q => DerivDesc q -mkEnumInstance mb_ctxt ty (DataDecl data_name tvbs cons) = do - let data_ty = foldTypeTvbs (DConT data_name) tvbs - non_vanilla <- isNonVanillaDataType data_ty cons - when (null cons || - any (\(DCon _ _ _ f _) -> - non_vanilla || not (null $ tysOfConFields f)) cons) $ - fail ("Can't derive Enum instance for " ++ pprint (typeToTH ty) ++ ".") - n <- qNewName "n" - let to_enum = UFunction [DClause [DVarP n] (to_enum_rhs cons [0..])] - to_enum_rhs [] _ = DVarE errorName `DAppE` DLitE (StringL "toEnum: bad argument") - to_enum_rhs (DCon _ _ name _ _ : rest) (num:nums) = - DCaseE (DVarE equalsName `DAppE` DVarE n `DAppE` DLitE (IntegerL num)) - [ DMatch (DConP trueName []) (DConE name) - , DMatch (DConP falseName []) (to_enum_rhs rest nums) ] - to_enum_rhs _ _ = error "Internal error: exhausted infinite list in to_enum_rhs" - - from_enum = UFunction (zipWith (\i con -> DClause [DConP (extractName con) []] - (DLitE (IntegerL i))) - [0..] cons) - return (InstDecl { id_cxt = fromMaybe [] mb_ctxt - , id_name = singletonsEnumName - -- need to use singletons's Enum class to get the types - -- to use Nat instead of Int - - , id_arg_tys = [ty] - , id_sigs = mempty - , id_meths = [ (singletonsToEnumName, to_enum) - , (singletonsFromEnumName, from_enum) ] }) diff --git a/src/Data/Singletons/Deriving/Foldable.hs b/src/Data/Singletons/Deriving/Foldable.hs deleted file mode 100644 --- a/src/Data/Singletons/Deriving/Foldable.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Deriving.Foldable --- Copyright : (C) 2018 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Implements deriving of Foldable instances --- ----------------------------------------------------------------------------- - -module Data.Singletons.Deriving.Foldable where - -import Data.Singletons.Deriving.Infer -import Data.Singletons.Deriving.Util -import Data.Singletons.Names -import Data.Singletons.Syntax -import Language.Haskell.TH.Desugar - -mkFoldableInstance :: forall q. DsMonad q => DerivDesc q -mkFoldableInstance mb_ctxt ty dd@(DataDecl _ _ cons) = do - functorLikeValidityChecks False dd - f <- newUniqueName "_f" - z <- newUniqueName "_z" - let ft_foldMap :: FFoldType (q DExp) - ft_foldMap = FT { ft_triv = mkSimpleLam $ \_ -> pure $ DVarE memptyName - -- foldMap f = \x -> mempty - , ft_var = pure $ DVarE f - -- foldMap f = f - , ft_ty_app = \_ g -> DAppE (DVarE foldMapName) <$> g - -- foldMap f = foldMap g - , ft_forall = \_ g -> g - , ft_bad_app = error "in other argument in ft_foldMap" - } - - ft_foldr :: FFoldType (q DExp) - ft_foldr = FT { ft_triv = mkSimpleLam2 $ \_ z' -> pure z' - -- foldr f = \x z -> z - , ft_var = pure $ DVarE f - -- foldr f = f - , ft_ty_app = \_ g -> do - gg <- g - mkSimpleLam2 $ \x z' -> pure $ - DVarE foldrName `DAppE` gg `DAppE` z' `DAppE` x - -- foldr f = (\x z -> foldr g z x) - , ft_forall = \_ g -> g - , ft_bad_app = error "in other argument in ft_foldr" - } - - clause_for_foldMap :: [DPat] -> DCon -> [DExp] -> q DClause - clause_for_foldMap = mkSimpleConClause $ \_ -> mkFoldMap - where - -- mappend v1 (mappend v2 ..) - mkFoldMap :: [DExp] -> DExp - mkFoldMap [] = DVarE memptyName - mkFoldMap xs = foldr1 (\x y -> DVarE mappendName `DAppE` x `DAppE` y) xs - - clause_for_foldr :: [DPat] -> DCon -> [DExp] -> q DClause - clause_for_foldr = mkSimpleConClause $ \_ -> mkFoldr - where - -- g1 v1 (g2 v2 (.. z)) - mkFoldr :: [DExp] -> DExp - mkFoldr = foldr DAppE (DVarE z) - - mk_foldMap_clause :: DCon -> q DClause - mk_foldMap_clause con = do - parts <- foldDataConArgs ft_foldMap con - clause_for_foldMap [DVarP f] con =<< sequence parts - - mk_foldr_clause :: DCon -> q DClause - mk_foldr_clause con = do - parts <- foldDataConArgs ft_foldr con - clause_for_foldr [DVarP f, DVarP z] con =<< sequence parts - - mk_foldMap :: q [DClause] - mk_foldMap = - case cons of - [] -> pure [DClause [DWildP, DWildP] (DVarE memptyName)] - _ -> traverse mk_foldMap_clause cons - - mk_foldr :: q [DClause] - mk_foldr = traverse mk_foldr_clause cons - - foldMap_clauses <- mk_foldMap - foldr_clauses <- mk_foldr - let meths = (foldMapName, UFunction foldMap_clauses) - : case cons of - [] -> [] - _ -> [(foldrName, UFunction foldr_clauses)] - constraints <- inferConstraintsDef mb_ctxt (DConT foldableName) ty cons - return $ InstDecl { id_cxt = constraints - , id_name = foldableName - , id_arg_tys = [ty] - , id_sigs = mempty - , id_meths = meths } diff --git a/src/Data/Singletons/Deriving/Functor.hs b/src/Data/Singletons/Deriving/Functor.hs deleted file mode 100644 --- a/src/Data/Singletons/Deriving/Functor.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Deriving.Functor --- Copyright : (C) 2018 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Implements deriving of Functor instances --- ----------------------------------------------------------------------------- - -module Data.Singletons.Deriving.Functor where - -import Data.Singletons.Deriving.Infer -import Data.Singletons.Deriving.Util -import Data.Singletons.Names -import Data.Singletons.Syntax -import Data.Singletons.Util -import Language.Haskell.TH.Desugar - -mkFunctorInstance :: forall q. DsMonad q => DerivDesc q -mkFunctorInstance mb_ctxt ty dd@(DataDecl _ _ cons) = do - functorLikeValidityChecks False dd - f <- newUniqueName "_f" - z <- newUniqueName "_z" - let ft_fmap :: FFoldType (q DExp) - ft_fmap = FT { ft_triv = mkSimpleLam pure - -- fmap f = \x -> x - , ft_var = pure $ DVarE f - -- fmap f = f - , ft_ty_app = \_ g -> DAppE (DVarE fmapName) <$> g - -- fmap f = fmap g - , ft_forall = \_ g -> g - , ft_bad_app = error "in other argument in ft_fmap" - } - - ft_replace :: FFoldType (q Replacer) - ft_replace = FT { ft_triv = fmap Nested $ mkSimpleLam pure - -- (p <$) = \x -> x - , ft_var = fmap Immediate $ mkSimpleLam $ \_ -> pure $ DVarE z - -- (p <$) = const p - , ft_ty_app = \_ gm -> do - g <- gm - case g of - Nested g' -> pure . Nested $ DVarE fmapName `DAppE` g' - Immediate _ -> pure . Nested $ DVarE replaceName `DAppE` DVarE z - -- (p <$) = fmap (p <$) - , ft_forall = \_ g -> g - , ft_bad_app = error "in other argument in ft_replace" - } - - -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ... - clause_for_con :: [DPat] -> DCon -> [DExp] -> q DClause - clause_for_con = mkSimpleConClause $ \con_name -> - foldExp (DConE con_name) -- Con x1 x2 ... - - mk_fmap_clause :: DCon -> q DClause - mk_fmap_clause con = do - parts <- foldDataConArgs ft_fmap con - clause_for_con [DVarP f] con =<< sequence parts - - mk_replace_clause :: DCon -> q DClause - mk_replace_clause con = do - parts <- foldDataConArgs ft_replace con - clause_for_con [DVarP z] con =<< traverse (fmap replace) parts - - mk_fmap :: q [DClause] - mk_fmap = case cons of - [] -> do v <- newUniqueName "v" - pure [DClause [DWildP, DVarP v] (DCaseE (DVarE v) [])] - _ -> traverse mk_fmap_clause cons - - mk_replace :: q [DClause] - mk_replace = case cons of - [] -> do v <- newUniqueName "v" - pure [DClause [DWildP, DVarP v] (DCaseE (DVarE v) [])] - _ -> traverse mk_replace_clause cons - - fmap_clauses <- mk_fmap - replace_clauses <- mk_replace - constraints <- inferConstraintsDef mb_ctxt (DConT functorName) ty cons - return $ InstDecl { id_cxt = constraints - , id_name = functorName - , id_arg_tys = [ty] - , id_sigs = mempty - , id_meths = [ (fmapName, UFunction fmap_clauses) - , (replaceName, UFunction replace_clauses) - ] } - -data Replacer = Immediate { replace :: DExp } - | Nested { replace :: DExp } diff --git a/src/Data/Singletons/Deriving/Infer.hs b/src/Data/Singletons/Deriving/Infer.hs deleted file mode 100644 --- a/src/Data/Singletons/Deriving/Infer.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Deriving.Infer --- Copyright : (C) 2015 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Infers constraints for a `deriving` class --- ----------------------------------------------------------------------------- - -module Data.Singletons.Deriving.Infer ( inferConstraints, inferConstraintsDef ) where - -import Language.Haskell.TH.Desugar -import Language.Haskell.TH.Syntax -import Data.Singletons.Deriving.Util -import Data.Singletons.Util -import Data.List - --- @inferConstraints cls inst_ty cons@ infers the instance context for a --- derived type class instance of @cls@ for @inst_ty@, using the constructors --- @cons@. For instance, if @cls@ is 'Ord' and @inst_ty@ is @Either a b@, then --- that means we are attempting to derive the instance: --- --- @ --- instance ??? => Ord (Either a b) --- @ --- --- The role of 'inferConstraints' is to determine what @???@ should be in that --- derived instance. To accomplish this, the list of @cons@ (in this example, --- @cons@ would be @[Left a, Right b]@) is used as follows: --- --- 1. For each @con@ in @cons@, find the types of each of its fields --- (call these @field_tys@), perhaps after renaming the type variables of --- @field_tys@. --- 2. For each @field_ty@ in @field_tys@, apply @cls@ to @field_ty@ to obtain --- a constraint. --- 3. The final instance context is the set of all such constraints obtained --- in step 2. --- --- To complete the running example, this algorithm would produce the instance --- context @(Ord a, Ord b)@, since @Left a@ has one field of type @a@, and --- @Right b@ has one field of type @b@. --- --- This algorithm is a crude approximation of what GHC actually does when --- deriving instances. It is crude in the sense that one can end up with --- redundant constraints. For instance, if the data type for which an 'Ord' --- instance is being derived is @data Foo = MkFoo Bool Foo@, then the --- inferred constraints would be @(Ord Bool, Ord Foo)@. Technically, neither --- constraint is necessary, but it is not simple in general to eliminate --- redundant constraints like these, so we do not attept to do so. (This is --- one reason why @singletons@ requires the use of the @UndecidableInstances@ --- GHC extension.) --- --- Observant readers will notice that the phrase \"perhaps afer renaming the --- type variables\" was casually dropped in step 1 of the above algorithm. --- For more information on what this means, refer to the documentation for --- infer_ct below. -inferConstraints :: forall q. DsMonad q => DPred -> DType -> [DCon] -> q DCxt -inferConstraints pr inst_ty = fmap nub . concatMapM infer_ct - where - -- A thorny situation arises when attempting to infer an instance context - -- for a GADT. Consider the following example: - -- - -- newtype Bar a where - -- MkBar :: b -> Bar b - -- deriving Show - -- - -- If we blindly apply 'Show' to the field type of @MkBar@, we will end up - -- with a derived instance of: - -- - -- instance Show b => Show (Bar a) - -- - -- This is completely wrong, since the type variable @b@ is never used in - -- the instance head! This reveals that we need a slightly more nuanced - -- strategy for gathering constraints for GADT constructors. To account - -- for this, when gathering @field_tys@ (from step 1 in the above algorithm) - -- we perform the following extra steps: - -- - -- 1(a). Take the return type of @con@ and match it with @inst_ty@ (e.g., - -- match @Bar b@ with @Bar a@). Doing so will produce a substitution - -- that maps the universally quantified type variables in the GADT - -- (i.e., @b@) to the corresponding type variables in the data type - -- constructor (i.e., @a@). - -- 1(b). Use the resulting substitution to rename the universally - -- quantified type variables of @con@ as necessary. - -- - -- After this renaming, the algorithm will produce an instance context of - -- @Show a@ (since @b@ was renamed to @a@), as expected. - infer_ct :: DCon -> q DCxt - infer_ct (DCon _ _ _ fields res_ty) = do - let field_tys = tysOfConFields fields - -- We need to match the constructor's result type with the type given - -- in the generated instance. But if we have: - -- - -- data Foo a where - -- MkFoo :: a -> Foo a - -- deriving Functor - -- - -- Then the generated instance will be: - -- - -- instance Functor Foo where ... - -- - -- Which means that if we're not careful, we might try to match the - -- types (Foo a) and (Foo), which will fail. - -- - -- To avoid this, we employ a grimy hack where we pad the instance - -- type with an extra (dummy) type variable. It doesn't matter what - -- we name it, since none of the inferred constraints will mention - -- it anyway. - eta_expanded_inst_ty - | is_functor_like = inst_ty `DAppT` DVarT (mkName "dummy") - | otherwise = inst_ty - res_ty' <- expandType res_ty - inst_ty' <- expandType eta_expanded_inst_ty - field_tys' <- case matchTy YesIgnore res_ty' inst_ty' of - Nothing -> fail $ showString "Unable to match type " - . showsPrec 11 res_ty' - . showString " with " - . showsPrec 11 inst_ty' - $ "" - Just subst -> traverse (substTy subst) field_tys - if is_functor_like - then mk_functor_like_constraints field_tys' res_ty' - else pure $ map (pr `DAppT`) field_tys' - - -- If we derive a Functor-like class, e.g., - -- - -- data Foo f g h a = MkFoo (f a) (g (h a)) deriving Functor - -- - -- Then we infer constraints by sticking Functor on the subtypes of kind - -- (Type -> Type). In the example above, that would give us - -- (Functor f, Functor g, Functor h). - mk_functor_like_constraints :: [DType] -> DType -> q DCxt - mk_functor_like_constraints fields res_ty = do - -- This function is partial. But that's OK, because - -- functorLikeValidityChecks ensures that this is total by the time - -- we invoke this. - let (_, res_ty_args) = unfoldDType res_ty - (_, last_res_ty_arg) = snocView $ filterDTANormals res_ty_args - Just last_tv = getDVarTName_maybe last_res_ty_arg - deep_subtypes <- concatMapM (deepSubtypesContaining last_tv) fields - pure $ map (pr `DAppT`) deep_subtypes - - is_functor_like :: Bool - is_functor_like - | (DConT pr_class_name, _) <- unfoldDType pr - = isFunctorLikeClassName pr_class_name - | otherwise - = False - --- For @inferConstraintsDef mb_cxt@, if @mb_cxt@ is 'Just' a context, then it will --- simply return that context. Otherwise, if @mb_cxt@ is 'Nothing', then --- 'inferConstraintsDef' will infer an instance context (using 'inferConstraints'). -inferConstraintsDef :: DsMonad q => Maybe DCxt -> DPred -> DType -> [DCon] -> q DCxt -inferConstraintsDef mb_ctxt pr inst_ty cons = - maybe (inferConstraints pr inst_ty cons) pure mb_ctxt diff --git a/src/Data/Singletons/Deriving/Ord.hs b/src/Data/Singletons/Deriving/Ord.hs deleted file mode 100644 --- a/src/Data/Singletons/Deriving/Ord.hs +++ /dev/null @@ -1,71 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Deriving.Ord --- Copyright : (C) 2015 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Implements deriving of Ord instances --- ----------------------------------------------------------------------------- - -module Data.Singletons.Deriving.Ord ( mkOrdInstance ) where - -import Language.Haskell.TH.Desugar -import Data.Singletons.Names -import Data.Singletons.Util -import Language.Haskell.TH.Syntax -import Data.Singletons.Deriving.Infer -import Data.Singletons.Deriving.Util -import Data.Singletons.Syntax - --- | Make a *non-singleton* Ord instance -mkOrdInstance :: DsMonad q => DerivDesc q -mkOrdInstance mb_ctxt ty (DataDecl _ _ cons) = do - constraints <- inferConstraintsDef mb_ctxt (DConT ordName) ty cons - compare_eq_clauses <- mapM mk_equal_clause cons - let compare_noneq_clauses = map (uncurry mk_nonequal_clause) - [ (con1, con2) - | con1 <- zip cons [1..] - , con2 <- zip cons [1..] - , extractName (fst con1) /= - extractName (fst con2) ] - clauses | null cons = [mk_empty_clause] - | otherwise = compare_eq_clauses ++ compare_noneq_clauses - return (InstDecl { id_cxt = constraints - , id_name = ordName - , id_arg_tys = [ty] - , id_sigs = mempty - , id_meths = [(compareName, UFunction clauses)] }) - -mk_equal_clause :: Quasi q => DCon -> q DClause -mk_equal_clause (DCon _tvbs _cxt name fields _rty) = do - let tys = tysOfConFields fields - a_names <- mapM (const $ newUniqueName "a") tys - b_names <- mapM (const $ newUniqueName "b") tys - let pat1 = DConP name (map DVarP a_names) - pat2 = DConP name (map DVarP b_names) - return $ DClause [pat1, pat2] (DVarE foldlName `DAppE` - DVarE thenCmpName `DAppE` - DConE cmpEQName `DAppE` - mkListE (zipWith - (\a b -> DVarE compareName `DAppE` DVarE a - `DAppE` DVarE b) - a_names b_names)) - -mk_nonequal_clause :: (DCon, Int) -> (DCon, Int) -> DClause -mk_nonequal_clause (DCon _tvbs1 _cxt1 name1 fields1 _rty1, n1) - (DCon _tvbs2 _cxt2 name2 fields2 _rty2, n2) = - DClause [pat1, pat2] (case n1 `compare` n2 of - LT -> DConE cmpLTName - EQ -> DConE cmpEQName - GT -> DConE cmpGTName) - where - pat1 = DConP name1 (map (const DWildP) (tysOfConFields fields1)) - pat2 = DConP name2 (map (const DWildP) (tysOfConFields fields2)) - --- A variant of mk_equal_clause tailored to empty datatypes -mk_empty_clause :: DClause -mk_empty_clause = DClause [DWildP, DWildP] (DConE cmpEQName) diff --git a/src/Data/Singletons/Deriving/Show.hs b/src/Data/Singletons/Deriving/Show.hs deleted file mode 100644 --- a/src/Data/Singletons/Deriving/Show.hs +++ /dev/null @@ -1,245 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Deriving.Show --- Copyright : (C) 2017 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Implements deriving of Show instances --- ----------------------------------------------------------------------------- -{-# LANGUAGE ScopedTypeVariables #-} -module Data.Singletons.Deriving.Show ( - mkShowInstance - , ShowMode(..) - , mkShowSingContext - ) where - -import Language.Haskell.TH.Syntax hiding (showName) -import Language.Haskell.TH.Desugar -import Data.Singletons.Names -import Data.Singletons.Util -import Data.Singletons.Syntax -import Data.Singletons.Deriving.Infer -import Data.Singletons.Deriving.Util -import Data.Maybe (fromMaybe) -import GHC.Lexeme (startsConSym, startsVarSym) -import GHC.Show (appPrec, appPrec1) - -mkShowInstance :: DsMonad q => ShowMode -> DerivDesc q -mkShowInstance mode mb_ctxt ty (DataDecl _ _ cons) = do - clauses <- mk_showsPrec mode cons - constraints <- inferConstraintsDef (fmap (mkShowSingContext mode) mb_ctxt) - (DConT (mk_Show_name mode)) - ty cons - ty' <- mk_Show_inst_ty mode ty - return $ InstDecl { id_cxt = constraints - , id_name = showName - , id_arg_tys = [ty'] - , id_sigs = mempty - , id_meths = [ (showsPrecName, UFunction clauses) ] } - -mk_showsPrec :: DsMonad q => ShowMode -> [DCon] -> q [DClause] -mk_showsPrec mode cons = do - p <- newUniqueName "p" -- The precedence argument (not always used) - if null cons - then do v <- newUniqueName "v" - pure [DClause [DWildP, DVarP v] (DCaseE (DVarE v) [])] - else mapM (mk_showsPrec_clause mode p) cons - -mk_showsPrec_clause :: forall q. DsMonad q - => ShowMode -> Name -> DCon - -> q DClause -mk_showsPrec_clause mode p (DCon _ _ con_name con_fields _) = go con_fields - where - con_name' :: Name - con_name' = case mode of - ForPromotion -> con_name - ForShowSing{} -> singDataConName con_name - - go :: DConFields -> q DClause - - -- No fields: print just the constructor name, with no parentheses - go (DNormalC _ []) = return $ - DClause [DWildP, DConP con_name' []] $ - DVarE showStringName `DAppE` dStringE (parenInfixConName con_name' "") - - -- Infix constructors have special Show treatment. - go (DNormalC True tys@[_, _]) - -- Although the (:) constructor is infix, its singled counterpart SCons - -- is not, which matters if we're deriving a ShowSing instance. - -- Unless we remove this special case (see #234), we will simply - -- shunt it along as if we were dealing with a prefix constructor. - | ForShowSing{} <- mode - , con_name == consName - = go (DNormalC False tys) - - | otherwise - = do argL <- newUniqueName "argL" - argR <- newUniqueName "argR" - argTyL <- newUniqueName "argTyL" - argTyR <- newUniqueName "argTyR" - fi <- fromMaybe defaultFixity <$> reifyFixityWithLocals con_name' - let con_prec = case fi of Fixity prec _ -> prec - op_name = nameBase con_name' - infixOpE = DAppE (DVarE showStringName) . dStringE $ - if isInfixDataCon op_name - then " " ++ op_name ++ " " - -- Make sure to handle infix data constructors - -- like (Int `Foo` Int) - else " `" ++ op_name ++ "` " - return $ DClause [ DVarP p - , DConP con_name' $ - zipWith (mk_Show_arg_pat mode) [argL, argR] [argTyL, argTyR] - ] $ - mk_Show_rhs_sig mode [argTyL, argTyR] $ - (DVarE showParenName `DAppE` (DVarE gtName `DAppE` DVarE p - `DAppE` dIntegerE con_prec)) - `DAppE` (DVarE composeName - `DAppE` showsPrecE (con_prec + 1) argL - `DAppE` (DVarE composeName - `DAppE` infixOpE - `DAppE` showsPrecE (con_prec + 1) argR)) - - go (DNormalC _ tys) = do - args <- mapM (const $ newUniqueName "arg") tys - argTys <- mapM (const $ newUniqueName "argTy") tys - let show_args = map (showsPrecE appPrec1) args - composed_args = foldr1 (\v q -> DVarE composeName - `DAppE` v - `DAppE` (DVarE composeName - `DAppE` DVarE showSpaceName - `DAppE` q)) show_args - named_args = DVarE composeName - `DAppE` (DVarE showStringName - `DAppE` dStringE (parenInfixConName con_name' " ")) - `DAppE` composed_args - return $ DClause [ DVarP p - , DConP con_name' $ - zipWith (mk_Show_arg_pat mode) args argTys - ] $ - mk_Show_rhs_sig mode argTys $ - DVarE showParenName - `DAppE` (DVarE gtName `DAppE` DVarE p `DAppE` dIntegerE appPrec) - `DAppE` named_args - - -- We show a record constructor with no fields the same way we'd show a - -- normal constructor with no fields. - go (DRecC []) = go (DNormalC False []) - - go (DRecC tys) = do - args <- mapM (const $ newUniqueName "arg") tys - argTys <- mapM (const $ newUniqueName "argTy") tys - let show_args = - concatMap (\((arg_name, _, _), arg) -> - let arg_name' = case mode of - ForPromotion -> arg_name - ForShowSing{} -> singValName arg_name - arg_nameBase = nameBase arg_name' - infix_rec = showParen (isSym arg_nameBase) - (showString arg_nameBase) "" - in [ DVarE showStringName `DAppE` dStringE (infix_rec ++ " = ") - , showsPrecE 0 arg - , DVarE showCommaSpaceName - ]) - (zip tys args) - brace_comma_args = (DVarE showCharName `DAppE` dCharE mode '{') - : take (length show_args - 1) show_args - composed_args = foldr (\x y -> DVarE composeName `DAppE` x `DAppE` y) - (DVarE showCharName `DAppE` dCharE mode '}') - brace_comma_args - named_args = DVarE composeName - `DAppE` (DVarE showStringName - `DAppE` dStringE (parenInfixConName con_name' " ")) - `DAppE` composed_args - return $ DClause [ DVarP p - , DConP con_name' $ - zipWith (mk_Show_arg_pat mode) args argTys - ] $ - mk_Show_rhs_sig mode argTys $ - DVarE showParenName - `DAppE` (DVarE gtName `DAppE` DVarE p `DAppE` dIntegerE appPrec) - `DAppE` named_args - --- | Parenthesize an infix constructor name if it is being applied as a prefix --- function (e.g., data Amp a = (:&) a a) -parenInfixConName :: Name -> ShowS -parenInfixConName conName = - let conNameBase = nameBase conName - in showParen (isInfixDataCon conNameBase) $ showString conNameBase - -showsPrecE :: Int -> Name -> DExp -showsPrecE prec n = DVarE showsPrecName `DAppE` dIntegerE prec `DAppE` DVarE n - -dCharE :: ShowMode -> Char -> DExp -dCharE mode = DLitE . to_lit - where - to_lit :: Char -> Lit - to_lit c = case mode of - ForPromotion -> StringL [c] -- There aren't type-level characters yet, - -- so fake it with a string - ForShowSing{} -> CharL c - -dStringE :: String -> DExp -dStringE = DLitE . StringL - -dIntegerE :: Int -> DExp -dIntegerE = DLitE . IntegerL . fromIntegral - -isSym :: String -> Bool -isSym "" = False -isSym (c : _) = startsVarSym c || startsConSym c - ------ --- ShowMode ------ - --- | Is a 'Show' instance being generated to be promoted/singled, or is it --- being generated to create a 'Show' instance for a singleton type? -data ShowMode = ForPromotion -- ^ For promotion/singling - | ForShowSing Name -- ^ For a 'Show' instance. - -- Bundles the 'Name' of the data type. - --- | Turn a context like @('Show' a, 'Show' b)@ into @('ShowSing' a, 'ShowSing' b)@. --- This is necessary for 'Show' instances for singleton types. -mkShowSingContext :: ShowMode -> DCxt -> DCxt -mkShowSingContext ForPromotion = id -mkShowSingContext ForShowSing{} = map show_to_SingShow - where - show_to_SingShow :: DPred -> DPred - show_to_SingShow = modifyConNameDType $ \n -> - if n == showName - then showSingName - else n - -mk_Show_name :: ShowMode -> Name -mk_Show_name ForPromotion = showName -mk_Show_name ForShowSing{} = showSingName - --- If we're creating a 'Show' instance for a singleon type, decorate the type --- appropriately (e.g., turn @Maybe a@ into @SMaybe (z :: Maybe a)@). --- Otherwise, return the type (@Maybe a@) unchanged. -mk_Show_inst_ty :: Quasi q => ShowMode -> DType -> q DType -mk_Show_inst_ty ForPromotion ty = pure ty -mk_Show_inst_ty (ForShowSing ty_tycon) ty = do - z <- qNewName "z" - pure $ DConT (singTyConName ty_tycon) `DAppT` (DVarT z `DSigT` ty) - --- If we're creating a 'Show' instance for a singleton type, create a pattern --- of the form @(sx :: Sing x)@. Otherwise, simply return the pattern @sx@. -mk_Show_arg_pat :: ShowMode -> Name -> Name -> DPat -mk_Show_arg_pat ForPromotion arg _ = DVarP arg -mk_Show_arg_pat ForShowSing{} arg arg_ty = - DSigP (DVarP arg) (DConT singFamilyName `DAppT` DVarT arg_ty) - --- If we're creating a 'Show' instance for a singleton type, decorate the --- expression with an explicit signature of the form --- @e :: (ShowSing' a_1, ..., ShowSing' a_n) => ShowS@. Otherwise, return --- the expression (@e@) unchanged. -mk_Show_rhs_sig :: ShowMode -> [Name] -> DExp -> DExp -mk_Show_rhs_sig ForPromotion _ e = e -mk_Show_rhs_sig ForShowSing{} arg_ty_names e = - e `DSigE` DForallT [] (map (DAppT (DConT showSing'Name) . DVarT) arg_ty_names) - (DConT showSName) diff --git a/src/Data/Singletons/Deriving/Traversable.hs b/src/Data/Singletons/Deriving/Traversable.hs deleted file mode 100644 --- a/src/Data/Singletons/Deriving/Traversable.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Deriving.Traversable --- Copyright : (C) 2018 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Implements deriving of Traversable instances --- ----------------------------------------------------------------------------- - -module Data.Singletons.Deriving.Traversable where - -import Data.Singletons.Deriving.Infer -import Data.Singletons.Deriving.Util -import Data.Singletons.Names -import Data.Singletons.Syntax -import Language.Haskell.TH.Desugar - -mkTraversableInstance :: forall q. DsMonad q => DerivDesc q -mkTraversableInstance mb_ctxt ty dd@(DataDecl _ _ cons) = do - functorLikeValidityChecks False dd - f <- newUniqueName "_f" - let ft_trav :: FFoldType (q DExp) - ft_trav = FT { ft_triv = pure $ DVarE pureName - -- traverse f = pure x - , ft_var = pure $ DVarE f - -- traverse f = f x - , ft_ty_app = \_ g -> DAppE (DVarE traverseName) <$> g - -- traverse f = traverse g - , ft_forall = \_ g -> g - , ft_bad_app = error "in other argument in ft_trav" - } - - -- Con a1 a2 ... -> Con <$> g1 a1 <*> g2 a2 <*> ... - clause_for_con :: [DPat] -> DCon -> [DExp] -> q DClause - clause_for_con = mkSimpleConClause $ \con_name -> mkApCon (DConE con_name) - where - -- ((Con <$> x1) <*> x2) <*> ... - mkApCon :: DExp -> [DExp] -> DExp - mkApCon con [] = DVarE pureName `DAppE` con - mkApCon con [x] = DVarE fmapName `DAppE` con `DAppE` x - mkApCon con (x1:x2:xs) = - foldl appAp (DVarE liftA2Name `DAppE` con `DAppE` x1 `DAppE` x2) xs - where appAp x y = DVarE apName `DAppE` x `DAppE` y - - mk_trav_clause :: DCon -> q DClause - mk_trav_clause con = do - parts <- foldDataConArgs ft_trav con - clause_for_con [DVarP f] con =<< sequence parts - - mk_trav :: q [DClause] - mk_trav = case cons of - [] -> do v <- newUniqueName "v" - pure [DClause [DWildP, DVarP v] - (DVarE pureName `DAppE` DCaseE (DVarE v) [])] - _ -> traverse mk_trav_clause cons - - trav_clauses <- mk_trav - constraints <- inferConstraintsDef mb_ctxt (DConT traversableName) ty cons - return $ InstDecl { id_cxt = constraints - , id_name = traversableName - , id_arg_tys = [ty] - , id_sigs = mempty - , id_meths = [ (traverseName, UFunction trav_clauses) ] } diff --git a/src/Data/Singletons/Deriving/Util.hs b/src/Data/Singletons/Deriving/Util.hs deleted file mode 100644 --- a/src/Data/Singletons/Deriving/Util.hs +++ /dev/null @@ -1,318 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Deriving.Util --- Copyright : (C) 2018 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Utilities used by the `deriving` machinery in singletons. --- ----------------------------------------------------------------------------- -module Data.Singletons.Deriving.Util where - -import Control.Monad -import Data.List -import Data.Singletons.Names -import Data.Singletons.Syntax -import Data.Singletons.Util -import Language.Haskell.TH.Desugar -import qualified Language.Haskell.TH.Desugar.OSet as OSet -import Language.Haskell.TH.Syntax - --- A generic type signature for describing how to produce a derived instance. -type DerivDesc q - = Maybe DCxt -- (Just ctx) if ctx was provided via StandaloneDeriving. - -- Nothing if using a deriving clause. - -> DType -- The data type argument to the class. - -> DataDecl -- The original data type information. - -> q UInstDecl -- The derived instance. - --- | Is this data type a non-vanilla data type? Here, \"non-vanilla\" refers to --- any data type that cannot be expressed using Haskell98 syntax. For instance, --- this GADT: --- --- @ --- data Foo :: Type -> Type where --- MkFoo :: forall a. a -> Foo a --- @ --- --- Is equivalent to this Haskell98 data type: --- --- @ --- data Foo a = MkFoo a --- @ --- --- However, the following GADT is non-vanilla: --- --- @ --- data Bar :: Type -> Type where --- MkBar :: Int -> Bar Int --- @ --- --- Since there is no equivalent Haskell98 data type. The closest you could get --- is this: --- --- @ --- data Bar a = (a ~ Int) => MkBar Int --- @ --- --- Which requires language extensions to write. --- --- A data type is a non-vanilla if one of the following conditions are met: --- --- 1. A constructor has any existentially quantified type variables. --- --- 2. A constructor has a context. --- --- We care about this because some derivable stock classes, such as 'Enum', --- forbid derived instances for non-vanilla data types. -isNonVanillaDataType :: forall q. DsMonad q => DType -> [DCon] -> q Bool -isNonVanillaDataType data_ty = anyM $ \con@(DCon _ ctxt _ _ _) -> do - ex_tvbs <- conExistentialTvbs data_ty con - return $ not $ null ex_tvbs && null ctxt - where - anyM :: (a -> q Bool) -> [a] -> q Bool - anyM _ [] = return False - anyM p (x:xs) = do - b <- p x - if b then return True else anyM p xs - ------ --- Utilities for deriving Functor-like classes. --- Much of this was cargo-culted from the GHC source code. ------ - -data FFoldType a -- Describes how to fold over a DType in a functor like way - = FT { ft_triv :: a - -- ^ Does not contain variable - , ft_var :: a - -- ^ The variable itself - , ft_ty_app :: DType -> a -> a - -- ^ Type app, variable only in last argument - , ft_bad_app :: a - -- ^ Type app, variable other than in last argument - , ft_forall :: [DTyVarBndr] -> a -> a - -- ^ Forall type - } - --- Note that in GHC, this function is pure. It must be monadic here since we: --- --- (1) Expand type synonyms --- (2) Detect type family applications --- --- Which require reification in Template Haskell, but are pure in Core. -functorLikeTraverse :: forall q a. - DsMonad q - => Name -- ^ Variable to look for - -> FFoldType a -- ^ How to fold - -> DType -- ^ Type to process - -> q a -functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar - , ft_ty_app = caseTyApp, ft_bad_app = caseWrongArg - , ft_forall = caseForAll }) - ty - = do ty' <- expandType ty - (res, _) <- go ty' - pure res - where - go :: DType - -> q (a, Bool) -- (result of type a, does type contain var) - go (DAppT f x) = do - (_, fc) <- go f - if fc - then pure (caseWrongArg, True) - else do (xr, xc) <- go x - if xc - then let tyApp :: q (a, Bool) - tyApp = pure (caseTyApp f xr, True) - - inspect :: DType -> q (a, Bool) - inspect (DConT n) = do - itf <- isTyFamilyName n - if itf -- We can't decompose type families, so - -- error if we encounter one here. - then pure (caseWrongArg, True) - else tyApp - inspect (DForallT _ _ t) = inspect t - inspect (DSigT t _) = inspect t - inspect (DAppT t _) = inspect t - inspect (DAppKindT t _) = inspect t - inspect (DVarT {}) = tyApp - inspect DArrowT = tyApp - inspect (DLitT {}) = tyApp - inspect DWildCardT = tyApp - - in case unfoldDType f of - (f_head, _) -> inspect f_head - else trivial - go (DAppKindT t k) = do - (_, kc) <- go k - if kc - then pure (caseWrongArg, True) - else go t - go (DSigT t k) = do - (_, kc) <- go k - if kc - then pure (caseWrongArg, True) - else go t - go (DVarT v) - | v == var = pure (caseVar, True) - | otherwise = trivial - go (DForallT tvbs _ t) = do - (tr, tc) <- go t - if var `notElem` map extractTvbName tvbs && tc - then pure (caseForAll tvbs tr, True) - else trivial - go (DConT {}) = trivial - go DArrowT = trivial - go (DLitT {}) = trivial - go DWildCardT = trivial - - trivial :: q (a, Bool) - trivial = pure (caseTrivial, False) - -isTyFamilyName :: DsMonad q => Name -> q Bool -isTyFamilyName n = do - info <- dsReify n - pure $ case info of - Just (DTyConI dec _) - | DOpenTypeFamilyD{} <- dec -> True - | DClosedTypeFamilyD{} <- dec -> True - _ -> False - --- A crude approximation of cond_functorOK from GHC. This checks that: --- --- (1) There's at least one type variable in the data type. --- (2) It doesn't use the last type variable in the wrong place, e.g. data T a = MkT (X a a) --- (3) It doesn't constrain the last type variable, e.g., data T a = Eq a => MkT a -functorLikeValidityChecks :: forall q. DsMonad q => Bool -> DataDecl -> q () -functorLikeValidityChecks allowConstrainedLastTyVar (DataDecl n data_tvbs cons) - | null data_tvbs -- (1) - = fail $ "Data type " ++ nameBase n ++ " must have some type parameters" - | otherwise - = mapM_ check_con cons - where - check_con :: DCon -> q () - check_con con = do - check_universal con - checks <- foldDataConArgs (ft_check (extractName con)) con - sequence_ checks - - -- (2) - check_universal :: DCon -> q () - check_universal con@(DCon con_tvbs con_theta con_name _ res_ty) - | allowConstrainedLastTyVar - = pure () - | (_, res_ty_args) <- unfoldDType res_ty - , (_, last_res_ty_arg) <- snocView $ filterDTANormals res_ty_args - , Just last_tv <- getDVarTName_maybe last_res_ty_arg - = do ex_tvbs <- conExistentialTvbs (foldTypeTvbs (DConT n) data_tvbs) con - let univ_tvb_names = map extractTvbName con_tvbs \\ map extractTvbName ex_tvbs - if last_tv `elem` univ_tvb_names - && last_tv `OSet.notMember` foldMap fvDType con_theta - then pure () - else fail $ badCon con_name existential - | otherwise - = fail $ badCon con_name existential - - -- (3) - ft_check :: Name -> FFoldType (q ()) - ft_check con_name = - FT { ft_triv = pure () - , ft_var = pure () - , ft_ty_app = \_ x -> x - , ft_bad_app = fail $ badCon con_name wrong_arg - , ft_forall = \_ x -> x - } - - badCon :: Name -> String -> String - badCon con_name msg = "Constructor " ++ nameBase con_name ++ " " ++ msg - - existential, wrong_arg :: String - existential = "must be truly polymorphic in the last argument of the data type" - wrong_arg = "must use the type variable only as the last argument of a data type" - --- Return all syntactic subterms of a type that contain the given variable somewhere. --- These are the things that should appear in Functor-like instance constraints. -deepSubtypesContaining :: DsMonad q => Name -> DType -> q [DType] -deepSubtypesContaining tv - = functorLikeTraverse tv - (FT { ft_triv = [] - , ft_var = [] - , ft_ty_app = (:) - , ft_bad_app = error "in other argument in deepSubtypesContaining" - , ft_forall = \tvbs xs -> filter (\x -> all (not_in_ty x) tvbs) xs }) - where - not_in_ty :: DType -> DTyVarBndr -> Bool - not_in_ty ty tvb = extractTvbName tvb `OSet.notMember` fvDType ty - --- Fold over the arguments of a data constructor in a Functor-like way. -foldDataConArgs :: forall q a. DsMonad q => FFoldType a -> DCon -> q [a] -foldDataConArgs ft (DCon _ _ _ fields res_ty) = do - field_tys <- traverse expandType $ tysOfConFields fields - traverse foldArg field_tys - where - foldArg :: DType -> q a - foldArg - | (_, res_ty_args) <- unfoldDType res_ty - , (_, last_res_ty_arg) <- snocView $ filterDTANormals res_ty_args - , Just last_tv <- getDVarTName_maybe last_res_ty_arg - = functorLikeTraverse last_tv ft - | otherwise - = const (return (ft_triv ft)) - --- If a type is a type variable (or a variable with a kind signature), return --- 'Just' that. Otherwise, return 'Nothing'. -getDVarTName_maybe :: DType -> Maybe Name -getDVarTName_maybe (DSigT t _) = getDVarTName_maybe t -getDVarTName_maybe (DVarT n) = Just n -getDVarTName_maybe _ = Nothing - --- Make a 'DLamE' using a fresh variable. -mkSimpleLam :: Quasi q => (DExp -> q DExp) -> q DExp -mkSimpleLam lam = do - n <- newUniqueName "n" - body <- lam (DVarE n) - return $ DLamE [n] body - --- Make a 'DLamE' using two fresh variables. -mkSimpleLam2 :: Quasi q => (DExp -> DExp -> q DExp) -> q DExp -mkSimpleLam2 lam = do - n1 <- newUniqueName "n1" - n2 <- newUniqueName "n2" - body <- lam (DVarE n1) (DVarE n2) - return $ DLamE [n1, n2] body - --- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]" --- --- @mkSimpleConClause fold extra_pats con insides@ produces a match clause in --- which the LHS pattern-matches on @extra_pats@, followed by a match on the --- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@ --- and its arguments, applying an expression (from @insides@) to each of the --- respective arguments of @con@. -mkSimpleConClause :: Quasi q - => (Name -> [DExp] -> DExp) - -> [DPat] - -> DCon - -> [DExp] - -> q DClause -mkSimpleConClause fold extra_pats (DCon _ _ con_name _ _) insides = do - vars_needed <- replicateM (length insides) $ newUniqueName "a" - let pat = DConP con_name (map DVarP vars_needed) - rhs = fold con_name (zipWith (\i v -> i `DAppE` DVarE v) insides vars_needed) - pure $ DClause (extra_pats ++ [pat]) rhs - --- 'True' if the derived class's last argument is of kind (Type -> Type), --- and thus needs a different constraint inference approach. --- --- Really, we should be determining this information by inspecting the kind --- of the class being used. But that comes dangerously close to kind --- inference territory, so for now we simply hardcode which stock derivable --- classes are Functor-like. -isFunctorLikeClassName :: Name -> Bool -isFunctorLikeClassName class_name - = class_name `elem` [functorName, foldableName, traversableName] diff --git a/src/Data/Singletons/Internal.hs b/src/Data/Singletons/Internal.hs deleted file mode 100644 --- a/src/Data/Singletons/Internal.hs +++ /dev/null @@ -1,545 +0,0 @@ -{-# LANGUAGE MagicHash, RankNTypes, PolyKinds, GADTs, DataKinds, - FlexibleContexts, FlexibleInstances, - TypeFamilies, TypeOperators, TypeFamilyDependencies, - UndecidableInstances, ConstraintKinds, - ScopedTypeVariables, TypeApplications, AllowAmbiguousTypes, - PatternSynonyms, ViewPatterns #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Internal --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- This module exports the basic definitions to use singletons. This module --- exists since we need to define instances for 'SomeSing' in --- "Data.Singletons", as defining them elsewhere would almost inevitably lead --- to import cycles. --- ----------------------------------------------------------------------------- - -module Data.Singletons.Internal ( - module Data.Singletons.Internal - , Proxy(..) - ) where - -import Data.Kind (Type) -import Unsafe.Coerce -import Data.Proxy ( Proxy(..) ) -import GHC.Exts ( Proxy#, Constraint ) - --- | Convenient synonym to refer to the kind of a type variable: --- @type KindOf (a :: k) = k@ -type KindOf (a :: k) = k - --- | Force GHC to unify the kinds of @a@ and @b@. Note that @SameKind a b@ is --- different from @KindOf a ~ KindOf b@ in that the former makes the kinds --- unify immediately, whereas the latter is a proposition that GHC considers --- as possibly false. -type SameKind (a :: k) (b :: k) = (() :: Constraint) - ----------------------------------------------------------------------- ----- Sing & friends -------------------------------------------------- ----------------------------------------------------------------------- - --- | The singleton kind-indexed type family. -type family Sing :: k -> Type - -{- -Note [The kind of Sing] -~~~~~~~~~~~~~~~~~~~~~~~ -It is important to define Sing like this: - - type family Sing :: k -> Type - -There are other conceivable ways to define Sing, but they all suffer from -various drawbacks: - -* type family Sing :: forall k. k -> Type - - Surprisingly, this is /not/ equivalent to `type family Sing :: k -> Type`. - The difference lies in their arity, i.e., the number of arguments that must - be supplied in order to apply Sing. The former declaration has arity 0, while - the latter has arity 1 (this is more obvious if you write the declaration as - GHCi would display it with -fprint-explicit-kinds enabled: - `type family Sing @k :: k -> Type`). - - The former declaration having arity 0 is actually what makes it useless. If - we were to adopt an arity-0 definition of `Sing`, then in order to write - `type instance Sing = SFoo`, GHC would require that `SFoo` must have the kind - `forall k. k -> Type`, and moreover, the kind /must/ be polymorphic in `k`. - This is undesirable, because in practice, every single `Sing` instance in the - wild must monomorphize `k` (e.g., `SBool` monomorphizes it to `Bool`), so an - arity-0 `Sing` simply won't work. In contrast, the current arity-1 definition - of `Sing` /does/ let you monomorphize `k` in type family instances. - -* type family Sing (a :: k) = (r :: Type) | r -> a - - Again, this is not equivalent to `type family Sing :: k -> Type`. This - version of `Sing` has arity 2, since one must supply both `k` and `a` in - order to apply it. While an arity-2 `Sing` is not suffer from the same - polymorphism issues as the arity-0 `Sing` in the previous bullet point, it - does suffer from another issue in that it cannot be partially applied. This - is because its `a` argument /must/ be supplied, whereas with the arity-1 - `Sing`, it is perfectly admissible to write `Sing` without an explicit `a` - argument. (Its invisible `k` argument is filled in automatically behind the - scenes.) - -* type family Sing = (r :: k -> Type) | r -> k - - This is the same as `type family Sing :: k -> Type`, but with an injectivity - annotation. Technically, this definition isn't /wrong/, but the injectivity - annotation is actually unnecessary. Because the return kind of `Sing` is - declared to be `k -> Type`, the `Sing` type constructor is automatically - injective, so `Sing a1 ~ Sing a2` implies `a1 ~~ a2`. - - Another way of phrasing this, using the terminology of Dependent Haskell, is - that the arrow in `Sing`'s return kind is /matchable/, which implies that - `Sing` is an injective type constructor as a consequence. --} - --- | A 'SingI' constraint is essentially an implicitly-passed singleton. --- If you need to satisfy this constraint with an explicit singleton, please --- see 'withSingI' or the 'Sing' pattern synonym. -class SingI a where - -- | Produce the singleton explicitly. You will likely need the @ScopedTypeVariables@ - -- extension to use this method the way you want. - sing :: Sing a - --- | An explicitly bidirectional pattern synonym for implicit singletons. --- --- As an __expression__: Constructs a singleton @Sing a@ given a --- implicit singleton constraint @SingI a@. --- --- As a __pattern__: Matches on an explicit @Sing a@ witness bringing --- an implicit @SingI a@ constraint into scope. -{-# COMPLETE Sing #-} -pattern Sing :: forall k (a :: k). () => SingI a => Sing a -pattern Sing <- (singInstance -> SingInstance) - where Sing = sing - --- | The 'SingKind' class is a /kind/ class. It classifies all kinds --- for which singletons are defined. The class supports converting between a singleton --- type and the base (unrefined) type which it is built from. --- --- For a 'SingKind' instance to be well behaved, it should obey the following laws: --- --- @ --- 'toSing' . 'fromSing' ≡ 'SomeSing' --- (\\x -> 'withSomeSing' x 'fromSing') ≡ 'id' --- @ --- --- The final law can also be expressed in terms of the 'FromSing' pattern --- synonym: --- --- @ --- (\\('FromSing' sing) -> 'FromSing' sing) ≡ 'id' --- @ -class SingKind k where - -- | Get a base type from the promoted kind. For example, - -- @Demote Bool@ will be the type @Bool@. Rarely, the type and kind do not - -- match. For example, @Demote Nat@ is @Natural@. - type Demote k = (r :: Type) | r -> k - - -- | Convert a singleton to its unrefined version. - fromSing :: Sing (a :: k) -> Demote k - - -- | Convert an unrefined type to an existentially-quantified singleton type. - toSing :: Demote k -> SomeSing k - --- | An /existentially-quantified/ singleton. This type is useful when you want a --- singleton type, but there is no way of knowing, at compile-time, what the type --- index will be. To make use of this type, you will generally have to use a --- pattern-match: --- --- > foo :: Bool -> ... --- > foo b = case toSing b of --- > SomeSing sb -> {- fancy dependently-typed code with sb -} --- --- An example like the one above may be easier to write using 'withSomeSing'. -data SomeSing k where - SomeSing :: Sing (a :: k) -> SomeSing k - --- | An explicitly bidirectional pattern synonym for going between a --- singleton and the corresponding demoted term. --- --- As an __expression__: this takes a singleton to its demoted (base) --- type. --- --- >>> :t FromSing \@Bool --- FromSing \@Bool :: Sing a -> Bool --- >>> FromSing SFalse --- False --- --- As a __pattern__: It extracts a singleton from its demoted (base) --- type. --- --- @ --- singAnd :: 'Bool' -> 'Bool' -> 'SomeSing' 'Bool' --- singAnd ('FromSing' singBool1) ('FromSing' singBool2) = --- 'SomeSing' (singBool1 %&& singBool2) --- @ --- --- instead of writing it with 'withSomeSing': --- --- @ --- singAnd bool1 bool2 = --- 'withSomeSing' bool1 $ \singBool1 -> --- 'withSomeSing' bool2 $ \singBool2 -> --- 'SomeSing' (singBool1 %&& singBool2) --- @ -{-# COMPLETE FromSing #-} -pattern FromSing :: SingKind k => forall (a :: k). Sing a -> Demote k -pattern FromSing sng <- ((\demotedVal -> withSomeSing demotedVal SomeSing) -> SomeSing sng) - where FromSing sng = fromSing sng - ----------------------------------------------------------------------- ----- WrappedSing ----------------------------------------------------- ----------------------------------------------------------------------- - --- | A newtype around 'Sing'. --- --- Since 'Sing' is a type family, it cannot be used directly in type class --- instances. As one example, one cannot write a catch-all --- @instance 'SDecide' k => 'TestEquality' ('Sing' k)@. On the other hand, --- 'WrappedSing' is a perfectly ordinary data type, which means that it is --- quite possible to define an --- @instance 'SDecide' k => 'TestEquality' ('WrappedSing' k)@. -newtype WrappedSing :: forall k. k -> Type where - WrapSing :: forall k (a :: k). { unwrapSing :: Sing a } -> WrappedSing a - --- | The singleton for 'WrappedSing's. Informally, this is the singleton type --- for other singletons. -newtype SWrappedSing :: forall k (a :: k). WrappedSing a -> Type where - SWrapSing :: forall k (a :: k) (ws :: WrappedSing a). - { sUnwrapSing :: Sing a } -> SWrappedSing ws -type instance Sing = SWrappedSing - -type family UnwrapSing (ws :: WrappedSing a) :: Sing a where - UnwrapSing ('WrapSing s) = s - -instance SingKind (WrappedSing a) where - type Demote (WrappedSing a) = WrappedSing a - fromSing (SWrapSing s) = WrapSing s - toSing (WrapSing s) = SomeSing $ SWrapSing s - -instance forall a (s :: Sing a). SingI a => SingI ('WrapSing s) where - sing = SWrapSing sing - ----------------------------------------------------------------------- ----- SingInstance ---------------------------------------------------- ----------------------------------------------------------------------- - --- | A 'SingInstance' wraps up a 'SingI' instance for explicit handling. -data SingInstance (a :: k) where - SingInstance :: SingI a => SingInstance a - --- dirty implementation of explicit-to-implicit conversion -newtype DI a = Don'tInstantiate (SingI a => SingInstance a) - --- | Get an implicit singleton (a 'SingI' instance) from an explicit one. -singInstance :: forall k (a :: k). Sing a -> SingInstance a -singInstance s = with_sing_i SingInstance - where - with_sing_i :: (SingI a => SingInstance a) -> SingInstance a - with_sing_i si = unsafeCoerce (Don'tInstantiate si) s - ----------------------------------------------------------------------- ----- 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 :: Type -> Type -> Type - --- | Something of kind `a ~> b` is a defunctionalized type function that is --- not necessarily generative or injective. -type a ~> b = TyFun a b -> Type -infixr 0 ~> - --- | Type level function application -type family Apply (f :: k1 ~> k2) (x :: k1) :: k2 - --- | An infix synonym for `Apply` -type a @@ b = Apply a b -infixl 9 @@ - --- | Workhorse for the 'TyCon1', etc., types. This can be used directly --- in place of any of the @TyConN@ types, but it will work only with --- /monomorphic/ types. When GHC#14645 is fixed, this should fully supersede --- the @TyConN@ types. -data family TyCon :: (k1 -> k2) -> unmatchable_fun --- That unmatchable_fun should really be a function of k1 and k2, --- but GHC 8.4 doesn't support type family calls in the result kind --- of a data family. It should. See GHC#14645. - --- The result kind of this is also a bit wrong; it should line --- up with unmatchable_fun above. However, we can't do that --- because GHC is too stupid to remember that f's kind can't --- have more than one argument when kind-checking the RHS of --- the second equation. Note that this infelicity is independent --- of the problem in the kind of TyCon. There is no GHC ticket --- here because dealing with inequality like this is hard, and --- I (Richard) wasn't sure what concrete value the ticket would --- have, given that we don't know how to begin fixing it. -type family ApplyTyCon :: (k1 -> k2) -> (k1 ~> unmatchable_fun) where - ApplyTyCon @k1 @(k2 -> k3) @unmatchable_fun = ApplyTyConAux2 - ApplyTyCon @k1 @k2 @k2 = ApplyTyConAux1 --- Upon first glance, the definition of ApplyTyCon (as well as the --- corresponding Apply instance for TyCon) seems a little indirect. One might --- wonder why these aren't defined like so: --- --- type family ApplyTyCon (f :: k1 -> k2) (x :: k1) :: k3 where --- ApplyTyCon (f :: k1 -> k2 -> k3) x = TyCon (f x) --- ApplyTyCon f x = f x --- --- type instance Apply (TyCon f) x = ApplyTyCon f x --- --- This also works, but it requires that ApplyTyCon always be applied to a --- minimum of two arguments. In particular, this rules out a trick that we use --- elsewhere in the library to write SingI instances for different TyCons, --- which relies on partial applications of ApplyTyCon: --- --- instance forall k1 k2 (f :: k1 -> k2). --- ( forall a. SingI a => SingI (f a) --- , (ApplyTyCon :: (k1 -> k2) -> (k1 ~> k2)) ~ ApplyTyConAux1 --- ) => SingI (TyCon1 f) where -type instance Apply (TyCon f) x = ApplyTyCon f @@ x - --- | An \"internal\" defunctionalization symbol used primarily in the --- definition of 'ApplyTyCon', as well as the 'SingI' instances for 'TyCon1', --- 'TyCon2', etc. -data ApplyTyConAux1 :: (k1 -> k2) -> (k1 ~> k2) --- | An \"internal\" defunctionalization symbol used primarily in the --- definition of 'ApplyTyCon'. -data ApplyTyConAux2 :: (k1 -> k2 -> k3) -> (k1 ~> unmatchable_fun) -type instance Apply (ApplyTyConAux1 f) x = f x -type instance Apply (ApplyTyConAux2 f) x = TyCon (f x) - --- | Wrapper for converting the normal type-level arrow into a '~>'. --- For example, given: --- --- > data Nat = Zero | Succ Nat --- > type family Map (a :: a ~> b) (a :: [a]) :: [b] --- > Map f '[] = '[] --- > Map f (x ': xs) = Apply f x ': Map f xs --- --- We can write: --- --- > Map (TyCon1 Succ) [Zero, Succ Zero] -type TyCon1 = (TyCon :: (k1 -> k2) -> (k1 ~> k2)) - --- | Similar to 'TyCon1', but for two-parameter type constructors. -type TyCon2 = (TyCon :: (k1 -> k2 -> k3) -> (k1 ~> k2 ~> k3)) -type TyCon3 = (TyCon :: (k1 -> k2 -> k3 -> k4) -> (k1 ~> k2 ~> k3 ~> k4)) -type TyCon4 = (TyCon :: (k1 -> k2 -> k3 -> k4 -> k5) -> (k1 ~> k2 ~> k3 ~> k4 ~> k5)) -type TyCon5 = (TyCon :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6) - -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6)) -type TyCon6 = (TyCon :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7) - -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7)) -type TyCon7 = (TyCon :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7 -> k8) - -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7 ~> k8)) -type TyCon8 = (TyCon :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7 -> k8 -> k9) - -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7 ~> k8 ~> k9)) - ----------------------------------------------------------------------- ----- Defunctionalized Sing instance and utilities -------------------- ----------------------------------------------------------------------- - -newtype SLambda (f :: k1 ~> k2) = - SLambda { applySing :: forall t. Sing t -> Sing (f @@ t) } -type instance Sing = SLambda - --- | An infix synonym for `applySing` -(@@) :: forall k1 k2 (f :: k1 ~> k2) (t :: k1). Sing f -> Sing t -> Sing (f @@ t) -(@@) = applySing - --- | Note that this instance's 'toSing' implementation crucially relies on the fact --- that the 'SingKind' instances for 'k1' and 'k2' both satisfy the 'SingKind' laws. --- If they don't, 'toSing' might produce strange results! -instance (SingKind k1, SingKind k2) => SingKind (k1 ~> k2) where - type Demote (k1 ~> k2) = Demote k1 -> Demote k2 - fromSing sFun x = withSomeSing x (fromSing . applySing sFun) - toSing f = SomeSing slam - where - -- Here, we are essentially "manufacturing" a type-level version of the - -- function f. As long as k1 and k2 obey the SingKind laws, this is a - -- perfectly fine thing to do, since the computational content of Sing f - -- will be isomorphic to that of the function f. - slam :: forall (f :: k1 ~> k2). Sing f - slam = singFun1 @f lam - where - -- Here's the tricky part. We need to demote the argument Sing, apply the - -- term-level function f to it, and promote it back to a Sing. However, - -- we don't have a way to convince the typechecker that for all argument - -- types t, f @@ t should be the same thing as res, which motivates the - -- use of unsafeCoerce. - lam :: forall (t :: k1). Sing t -> Sing (f @@ t) - lam x = withSomeSing (f (fromSing x)) (\(r :: Sing res) -> unsafeCoerce r) - -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 need visible type application --- to get this to work. For example: --- --- > falses = sMap (singFun1 @NotSym0 sNot) --- > (STrue `SCons` STrue `SCons` SNil) --- --- There are a family of @singFun...@ functions, keyed by the number --- of parameters of the function. -singFun1 :: forall f. SingFunction1 f -> Sing f -singFun1 f = SLambda f - -type SingFunction2 f = forall t. Sing t -> SingFunction1 (f @@ t) -singFun2 :: forall f. SingFunction2 f -> Sing f -singFun2 f = SLambda (\x -> singFun1 (f x)) - -type SingFunction3 f = forall t. Sing t -> SingFunction2 (f @@ t) -singFun3 :: forall f. SingFunction3 f -> Sing f -singFun3 f = SLambda (\x -> singFun2 (f x)) - -type SingFunction4 f = forall t. Sing t -> SingFunction3 (f @@ t) -singFun4 :: forall f. SingFunction4 f -> Sing f -singFun4 f = SLambda (\x -> singFun3 (f x)) - -type SingFunction5 f = forall t. Sing t -> SingFunction4 (f @@ t) -singFun5 :: forall f. SingFunction5 f -> Sing f -singFun5 f = SLambda (\x -> singFun4 (f x)) - -type SingFunction6 f = forall t. Sing t -> SingFunction5 (f @@ t) -singFun6 :: forall f. SingFunction6 f -> Sing f -singFun6 f = SLambda (\x -> singFun5 (f x)) - -type SingFunction7 f = forall t. Sing t -> SingFunction6 (f @@ t) -singFun7 :: forall f. SingFunction7 f -> Sing f -singFun7 f = SLambda (\x -> singFun6 (f x)) - -type SingFunction8 f = forall t. Sing t -> SingFunction7 (f @@ t) -singFun8 :: forall f. SingFunction8 f -> Sing f -singFun8 f = SLambda (\x -> singFun7 (f x)) - --- | This is the inverse of 'singFun1', and likewise for the other --- @unSingFun...@ functions. -unSingFun1 :: forall f. Sing f -> SingFunction1 f -unSingFun1 sf = applySing sf - -unSingFun2 :: forall f. Sing f -> SingFunction2 f -unSingFun2 sf x = unSingFun1 (sf @@ x) - -unSingFun3 :: forall f. Sing f -> SingFunction3 f -unSingFun3 sf x = unSingFun2 (sf @@ x) - -unSingFun4 :: forall f. Sing f -> SingFunction4 f -unSingFun4 sf x = unSingFun3 (sf @@ x) - -unSingFun5 :: forall f. Sing f -> SingFunction5 f -unSingFun5 sf x = unSingFun4 (sf @@ x) - -unSingFun6 :: forall f. Sing f -> SingFunction6 f -unSingFun6 sf x = unSingFun5 (sf @@ x) - -unSingFun7 :: forall f. Sing f -> SingFunction7 f -unSingFun7 sf x = unSingFun6 (sf @@ x) - -unSingFun8 :: forall f. Sing f -> SingFunction8 f -unSingFun8 sf x = unSingFun7 (sf @@ x) - -{-# COMPLETE SLambda2 #-} -pattern SLambda2 :: forall f. SingFunction2 f -> Sing f -pattern SLambda2 {applySing2} <- (unSingFun2 -> applySing2) - where SLambda2 lam2 = singFun2 lam2 - -{-# COMPLETE SLambda3 #-} -pattern SLambda3 :: forall f. SingFunction3 f -> Sing f -pattern SLambda3 {applySing3} <- (unSingFun3 -> applySing3) - where SLambda3 lam3 = singFun3 lam3 - -{-# COMPLETE SLambda4 #-} -pattern SLambda4 :: forall f. SingFunction4 f -> Sing f -pattern SLambda4 {applySing4} <- (unSingFun4 -> applySing4) - where SLambda4 lam4 = singFun4 lam4 - -{-# COMPLETE SLambda5 #-} -pattern SLambda5 :: forall f. SingFunction5 f -> Sing f -pattern SLambda5 {applySing5} <- (unSingFun5 -> applySing5) - where SLambda5 lam5 = singFun5 lam5 - -{-# COMPLETE SLambda6 #-} -pattern SLambda6 :: forall f. SingFunction6 f -> Sing f -pattern SLambda6 {applySing6} <- (unSingFun6 -> applySing6) - where SLambda6 lam6 = singFun6 lam6 - -{-# COMPLETE SLambda7 #-} -pattern SLambda7 :: forall f. SingFunction7 f -> Sing f -pattern SLambda7 {applySing7} <- (unSingFun7 -> applySing7) - where SLambda7 lam7 = singFun7 lam7 - -{-# COMPLETE SLambda8 #-} -pattern SLambda8 :: forall f. SingFunction8 f -> Sing f -pattern SLambda8 {applySing8} <- (unSingFun8 -> applySing8) - where SLambda8 lam8 = singFun8 lam8 - ----------------------------------------------------------------------- ----- Convenience ----------------------------------------------------- ----------------------------------------------------------------------- - --- | Convenience function for creating a context with an implicit singleton --- available. -withSingI :: Sing n -> (SingI n => r) -> r -withSingI sn r = - case singInstance sn of - SingInstance -> r - --- | Convert a normal datatype (like 'Bool') to a singleton for that datatype, --- passing it into a continuation. -withSomeSing :: forall k r - . SingKind k - => Demote k -- ^ The original datatype - -> (forall (a :: k). Sing a -> r) -- ^ Function expecting a singleton - -> r -withSomeSing x f = - case toSing x of - SomeSing x' -> f x' - --- | A convenience function useful when we need to name a singleton value --- multiple times. Without this function, each use of 'sing' could potentially --- refer to a different singleton, and one has to use type signatures (often --- with @ScopedTypeVariables@) to ensure that they are the same. -withSing :: SingI a => (Sing a -> b) -> b -withSing f = f sing - --- | A convenience function that names a singleton satisfying a certain --- property. If the singleton does not satisfy the property, then the function --- returns 'Nothing'. The property is expressed in terms of the underlying --- representation of the singleton. -singThat :: forall k (a :: k). (SingKind k, SingI a) - => (Demote k -> Bool) -> Maybe (Sing a) -singThat p = withSing $ \x -> if p (fromSing x) then Just x else Nothing - --- | Allows creation of a singleton when a proxy is at hand. -singByProxy :: SingI a => proxy a -> Sing a -singByProxy _ = sing - --- | Allows creation of a singleton when a @proxy#@ is at hand. -singByProxy# :: SingI a => Proxy# a -> Sing a -singByProxy# _ = sing - --- | A convenience function that takes a type as input and demotes it to its --- value-level counterpart as output. This uses 'SingKind' and 'SingI' behind --- the scenes, so @'demote' = 'fromSing' 'sing'@. --- --- This function is intended to be used with @TypeApplications@. For example: --- --- >>> demote @True --- True --- --- >>> demote @(Nothing :: Maybe Ordering) --- Nothing -demote :: forall a. (SingKind (KindOf a), SingI a) => Demote (KindOf a) -demote = fromSing (sing @a) diff --git a/src/Data/Singletons/Names.hs b/src/Data/Singletons/Names.hs deleted file mode 100644 --- a/src/Data/Singletons/Names.hs +++ /dev/null @@ -1,358 +0,0 @@ -{- Data/Singletons/Names.hs - -(c) Richard Eisenberg 2014 -rae@cs.brynmawr.edu - -Defining names and manipulations on names for use in promotion and singling. --} - -{-# LANGUAGE TemplateHaskell #-} - -module Data.Singletons.Names where - -import Data.Singletons.Internal -import Data.Singletons.SuppressUnusedWarnings -import Data.Singletons.Decide -import Language.Haskell.TH.Syntax -import Language.Haskell.TH.Desugar -import GHC.TypeLits ( Nat, Symbol ) -import GHC.Exts ( Constraint ) -import GHC.Show ( showCommaSpace, showSpace ) -import Data.Type.Equality ( TestEquality(..) ) -import Data.Type.Coercion ( TestCoercion(..) ) -import Data.Typeable ( TypeRep ) -import Data.Singletons.Util -import Control.Applicative -import Control.Monad - -boolName, andName, tyEqName, compareName, minBoundName, - maxBoundName, repName, - nilName, consName, listName, tyFunArrowName, - applyName, applyTyConName, applyTyConAux1Name, - natName, symbolName, typeRepName, stringName, - eqName, ordName, boundedName, orderingName, - singFamilyName, singIName, singMethName, demoteName, withSingIName, - singKindClassName, sEqClassName, sEqMethName, sconsName, snilName, strueName, - sIfName, - someSingTypeName, someSingDataName, - sListName, sDecideClassName, sDecideMethName, - testEqualityClassName, testEqualityMethName, decideEqualityName, - testCoercionClassName, testCoercionMethName, decideCoercionName, - provedName, disprovedName, reflName, toSingName, fromSingName, - equalityName, applySingName, suppressClassName, suppressMethodName, - thenCmpName, - sameKindName, tyFromIntegerName, tyNegateName, sFromIntegerName, - sNegateName, errorName, foldlName, cmpEQName, cmpLTName, cmpGTName, - singletonsToEnumName, singletonsFromEnumName, enumName, singletonsEnumName, - equalsName, constraintName, - showName, showSName, showCharName, showCommaSpaceName, showParenName, showsPrecName, - showSpaceName, showStringName, showSingName, showSing'Name, - composeName, gtName, tyFromStringName, sFromStringName, - foldableName, foldMapName, memptyName, mappendName, foldrName, - functorName, fmapName, replaceName, - traversableName, traverseName, pureName, apName, liftA2Name :: Name -boolName = ''Bool -andName = '(&&) -compareName = 'compare -minBoundName = 'minBound -maxBoundName = 'maxBound -tyEqName = mk_name_tc "Data.Singletons.Prelude.Eq" "==" -repName = mkName "Rep" -- this is actually defined in client code! -nilName = '[] -consName = '(:) -listName = ''[] -tyFunArrowName = ''(~>) -applyName = ''Apply -applyTyConName = ''ApplyTyCon -applyTyConAux1Name = ''ApplyTyConAux1 -symbolName = ''Symbol -natName = ''Nat -typeRepName = ''TypeRep -stringName = ''String -eqName = ''Eq -ordName = ''Ord -boundedName = ''Bounded -orderingName = ''Ordering -singFamilyName = ''Sing -singIName = ''SingI -singMethName = 'sing -toSingName = 'toSing -fromSingName = 'fromSing -demoteName = ''Demote -withSingIName = 'withSingI -singKindClassName = ''SingKind -sEqClassName = mk_name_tc "Data.Singletons.Prelude.Eq" "SEq" -sEqMethName = mk_name_v "Data.Singletons.Prelude.Eq" "%==" -sIfName = mk_name_v "Data.Singletons.Prelude.Bool" "sIf" -sconsName = mk_name_d "Data.Singletons.Prelude.Instances" "SCons" -snilName = mk_name_d "Data.Singletons.Prelude.Instances" "SNil" -strueName = mk_name_d "Data.Singletons.Prelude.Instances" "STrue" -someSingTypeName = ''SomeSing -someSingDataName = 'SomeSing -sListName = mk_name_tc "Data.Singletons.Prelude.Instances" "SList" -sDecideClassName = ''SDecide -sDecideMethName = '(%~) -testEqualityClassName = ''TestEquality -testEqualityMethName = 'testEquality -decideEqualityName = 'decideEquality -testCoercionClassName = ''TestCoercion -testCoercionMethName = 'testCoercion -decideCoercionName = 'decideCoercion -provedName = 'Proved -disprovedName = 'Disproved -reflName = 'Refl -equalityName = ''(~) -applySingName = 'applySing -suppressClassName = ''SuppressUnusedWarnings -suppressMethodName = 'suppressUnusedWarnings -thenCmpName = mk_name_v "Data.Singletons.Prelude.Ord" "thenCmp" -sameKindName = ''SameKind -tyFromIntegerName = mk_name_tc "Data.Singletons.Prelude.Num" "FromInteger" -tyNegateName = mk_name_tc "Data.Singletons.Prelude.Num" "Negate" -sFromIntegerName = mk_name_v "Data.Singletons.Prelude.Num" "sFromInteger" -sNegateName = mk_name_v "Data.Singletons.Prelude.Num" "sNegate" -errorName = 'error -foldlName = 'foldl -cmpEQName = 'EQ -cmpLTName = 'LT -cmpGTName = 'GT -singletonsToEnumName = mk_name_v "Data.Singletons.Prelude.Enum" "toEnum" -singletonsFromEnumName = mk_name_v "Data.Singletons.Prelude.Enum" "fromEnum" -enumName = ''Enum -singletonsEnumName = mk_name_tc "Data.Singletons.Prelude.Enum" "Enum" -equalsName = '(==) -constraintName = ''Constraint -showName = ''Show -showSName = ''ShowS -showCharName = 'showChar -showParenName = 'showParen -showSpaceName = 'showSpace -showsPrecName = 'showsPrec -showStringName = 'showString -showSingName = mk_name_tc "Data.Singletons.ShowSing" "ShowSing" -showSing'Name = mk_name_tc "Data.Singletons.ShowSing" "ShowSing'" -composeName = '(.) -gtName = '(>) -showCommaSpaceName = 'showCommaSpace -tyFromStringName = mk_name_tc "Data.Singletons.Prelude.IsString" "FromString" -sFromStringName = mk_name_v "Data.Singletons.Prelude.IsString" "sFromString" -foldableName = ''Foldable -foldMapName = 'foldMap -memptyName = 'mempty -mappendName = 'mappend -foldrName = 'foldr -functorName = ''Functor -fmapName = 'fmap -replaceName = '(<$) -traversableName = ''Traversable -traverseName = 'traverse -pureName = 'pure -apName = '(<*>) -liftA2Name = 'liftA2 - -singPkg :: String -singPkg = $( (LitE . StringL . loc_package) `liftM` location ) - -mk_name_tc :: String -> String -> Name -mk_name_tc = mkNameG_tc singPkg - -mk_name_d :: String -> String -> Name -mk_name_d = mkNameG_d singPkg - -mk_name_v :: String -> String -> Name -mk_name_v = mkNameG_v singPkg - -mkTupleTypeName :: Int -> Name -mkTupleTypeName n = mk_name_tc "Data.Singletons.Prelude.Instances" $ - "STuple" ++ (show n) - -mkTupleDataName :: Int -> Name -mkTupleDataName n = mk_name_d "Data.Singletons.Prelude.Instances" $ - "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 = promoteValNameLhsPrefix noPrefix - --- like promoteValNameLhs, but adds a prefix to the promoted name -promoteValNameLhsPrefix :: (String, String) -> Name -> Name -promoteValNameLhsPrefix pres@(alpha, _) n - -- We can't promote promote idenitifers beginning with underscores to - -- type names, so we work around the issue by prepending "US" at the - -- front of the name (#229). - | Just (us, rest) <- splitUnderscores (nameBase n) - = mkName $ alpha ++ "US" ++ us ++ rest - - | otherwise - = mkName $ toUpcaseStr pres n - --- 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 - -- We can't promote promote idenitifers beginning with underscores to - -- type names, so we work around the issue by prepending "US" at the - -- front of the name (#229). - | Just (us, rest) <- splitUnderscores (nameBase name) - = default_case (mkName $ "US" ++ us ++ rest) - - | name == nilName - = mkName $ "NilSym" ++ (show sat) - - -- treat unboxed tuples like tuples - | Just degree <- tupleNameDegree_maybe name `mplus` - unboxedTupleNameDegree_maybe name - = mk_name_tc "Data.Singletons.Prelude.Instances" $ - "Tuple" ++ show degree ++ "Sym" ++ (show sat) - - | otherwise - = default_case name - where - default_case :: Name -> Name - default_case name' = - let capped = toUpcaseStr noPrefix name' in - if isHsLetter (head capped) - then mkName (capped ++ "Sym" ++ (show sat)) - else mkName (capped ++ "@#@" -- See Note [Defunctionalization symbol suffixes] - ++ (replicate (sat + 1) '$')) - -promoteClassName :: Name -> Name -promoteClassName = prefixName "P" "#" - -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) - -mkTyConName :: Int -> Name -mkTyConName i = mk_name_tc "Data.Singletons.Internal" $ "TyCon" ++ show i - -falseTySym :: DType -falseTySym = promoteValRhs falseName - -trueTySym :: DType -trueTySym = promoteValRhs trueName - -boolKi :: DKind -boolKi = DConT boolName - -andTySym :: DType -andTySym = promoteValRhs andName - --- Singletons - -singDataConName :: Name -> Name -singDataConName nm - | nm == nilName = snilName - | nm == consName = sconsName - | Just degree <- tupleNameDegree_maybe nm = mkTupleDataName degree - | Just degree <- unboxedTupleNameDegree_maybe nm = mkTupleDataName degree - | otherwise = prefixConName "S" "%" nm - -singTyConName :: Name -> Name -singTyConName name - | name == listName = sListName - | Just degree <- tupleNameDegree_maybe name = mkTupleTypeName degree - | Just degree <- unboxedTupleNameDegree_maybe name = mkTupleTypeName degree - | otherwise = prefixName "S" "%" name - -singClassName :: Name -> Name -singClassName = singTyConName - -singValName :: Name -> Name -singValName n - -- Push the 's' past the underscores, as this lets us avoid some unused - -- variable warnings (#229). - | Just (us, rest) <- splitUnderscores (nameBase n) - = prefixName (us ++ "s") "%" $ mkName rest - | otherwise - = prefixName "s" "%" $ upcase n - -singFamily :: DType -singFamily = DConT singFamilyName - -singKindConstraint :: DKind -> DPred -singKindConstraint = DAppT (DConT singKindClassName) - -demote :: DType -demote = DConT demoteName - -apply :: DType -> DType -> DType -apply t1 t2 = DAppT (DAppT (DConT applyName) t1) t2 - -mkListE :: [DExp] -> DExp -mkListE = - foldr (\h t -> DConE consName `DAppE` h `DAppE` t) (DConE nilName) - --- 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 - --- make an equality predicate -mkEqPred :: DType -> DType -> DPred -mkEqPred ty1 ty2 = foldType (DConT equalityName) [ty1, ty2] - --- | If a 'String' begins with one or more underscores, return --- @'Just' (us, rest)@, where @us@ contain all of the underscores at the --- beginning of the 'String' and @rest@ contains the remainder of the 'String'. --- Otherwise, return 'Nothing'. -splitUnderscores :: String -> Maybe (String, String) -splitUnderscores s = case span (== '_') s of - ([], _) -> Nothing - res -> Just res - --- Walk a DType, applying a function to all occurrences of constructor names. -modifyConNameDType :: (Name -> Name) -> DType -> DType -modifyConNameDType mod_con_name = go - where - go (DForallT tvbs cxt p) = DForallT tvbs (map go cxt) (go p) - go (DAppT p t) = DAppT (go p) t - go (DAppKindT p k) = DAppKindT (go p) k - go (DSigT p k) = DSigT (go p) k - go p@(DVarT _) = p - go (DConT n) = DConT (mod_con_name n) - go p@DWildCardT = p - go p@(DLitT {}) = p - go p@DArrowT = p - -{- -Note [Defunctionalization symbol suffixes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Before, we used to denote defunctionalization symbols by simply appending dollar -signs at the end (e.g., (+$) and (+$$)). But this can lead to ambiguity when you -have function names that consist of solely $ characters. For instance, if you -tried to promote ($) and ($$) simultaneously, you'd get these promoted types: - -$ -$$ - -And these defunctionalization symbols: - -$$ -$$$ - -But now there's a name clash between the promoted type for ($) and the -defunctionalization symbol for ($$)! The solution is to use a precede these -defunctionalization dollar signs with another string (we choose @#@). -So now the new defunctionalization symbols would be: - -$@#@$ -$@#@$$ - -And there is no conflict. --} diff --git a/src/Data/Singletons/Partition.hs b/src/Data/Singletons/Partition.hs deleted file mode 100644 --- a/src/Data/Singletons/Partition.hs +++ /dev/null @@ -1,315 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Partition --- Copyright : (C) 2015 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Partitions a list of declarations into its bits --- ----------------------------------------------------------------------------- - -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} - -module Data.Singletons.Partition where - -import Prelude hiding ( exp ) -import Data.Singletons.Syntax -import Data.Singletons.Deriving.Ord -import Data.Singletons.Deriving.Bounded -import Data.Singletons.Deriving.Enum -import Data.Singletons.Deriving.Foldable -import Data.Singletons.Deriving.Functor -import Data.Singletons.Deriving.Show -import Data.Singletons.Deriving.Traversable -import Data.Singletons.Deriving.Util -import Data.Singletons.Names -import Language.Haskell.TH.Syntax hiding (showName) -import Language.Haskell.TH.Ppr -import Language.Haskell.TH.Desugar -import qualified Language.Haskell.TH.Desugar.OMap.Strict as OMap -import Language.Haskell.TH.Desugar.OMap.Strict (OMap) -import Data.Singletons.Util - -import Control.Monad -import Data.Bifunctor (bimap) -import qualified Data.Map as Map -import Data.Map (Map) -import Data.Maybe - -data PartitionedDecs = - PDecs { pd_let_decs :: [DLetDec] - , pd_class_decs :: [UClassDecl] - , pd_instance_decs :: [UInstDecl] - , pd_data_decs :: [DataDecl] - , pd_ty_syn_decs :: [TySynDecl] - , pd_open_type_family_decs :: [OpenTypeFamilyDecl] - , pd_closed_type_family_decs :: [ClosedTypeFamilyDecl] - , pd_derived_eq_decs :: [DerivedEqDecl] - , pd_derived_show_decs :: [DerivedShowDecl] - } - -instance Semigroup PartitionedDecs where - PDecs a1 b1 c1 d1 e1 f1 g1 h1 i1 <> PDecs a2 b2 c2 d2 e2 f2 g2 h2 i2 = - PDecs (a1 <> a2) (b1 <> b2) (c1 <> c2) (d1 <> d2) (e1 <> e2) (f1 <> f2) - (g1 <> g2) (h1 <> h2) (i1 <> i2) - -instance Monoid PartitionedDecs where - mempty = PDecs [] [] [] [] [] [] [] [] [] - mappend = (<>) - --- | Split up a @[DDec]@ into its pieces, extracting 'Ord' instances --- from deriving clauses -partitionDecs :: DsMonad m => [DDec] -> m PartitionedDecs -partitionDecs = concatMapM partitionDec - -partitionDec :: DsMonad m => DDec -> m PartitionedDecs -partitionDec (DLetDec (DPragmaD {})) = return mempty -partitionDec (DLetDec letdec) = return $ mempty { pd_let_decs = [letdec] } - -partitionDec (DDataD _nd _cxt name tvbs mk cons derivings) = do - all_tvbs <- buildDataDTvbs tvbs mk - let data_decl = DataDecl name all_tvbs cons - derived_dec = mempty { pd_data_decs = [data_decl] } - derived_decs - <- mapM (\(strat, deriv_pred) -> - let etad_tvbs - | (DConT pred_name, _) <- unfoldDType deriv_pred - , isFunctorLikeClassName pred_name - -- If deriving Functor, Foldable, or Traversable, - -- we need to use one less type variable than we normally do. - = take (length all_tvbs - 1) all_tvbs - | otherwise - = all_tvbs - ty = foldTypeTvbs (DConT name) etad_tvbs - in partitionDeriving strat deriv_pred Nothing ty data_decl) - $ concatMap flatten_clause derivings - return $ mconcat $ derived_dec : derived_decs - where - flatten_clause :: DDerivClause -> [(Maybe DDerivStrategy, DPred)] - flatten_clause (DDerivClause strat preds) = - map (\p -> (strat, p)) preds - -partitionDec (DClassD cxt name tvbs fds decs) = do - (lde, otfs) <- concatMapM partitionClassDec decs - return $ mempty { pd_class_decs = [ClassDecl { cd_cxt = cxt - , cd_name = name - , cd_tvbs = tvbs - , cd_fds = fds - , cd_lde = lde }] - , pd_open_type_family_decs = otfs } -partitionDec (DInstanceD _ _ cxt ty decs) = do - (defns, sigs) <- liftM (bimap catMaybes mconcat) $ - mapAndUnzipM partitionInstanceDec decs - (name, tys) <- split_app_tys [] ty - return $ mempty { pd_instance_decs = [InstDecl { id_cxt = cxt - , id_name = name - , id_arg_tys = tys - , id_sigs = sigs - , id_meths = 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 (DTySynD name tvbs rhs) = - -- See Note [Partitioning, type synonyms, and type families] - pure $ mempty { pd_ty_syn_decs = [TySynDecl name tvbs rhs] } -partitionDec (DClosedTypeFamilyD tf_head _) = - -- See Note [Partitioning, type synonyms, and type families] - pure $ mempty { pd_closed_type_family_decs = [TypeFamilyDecl tf_head] } -partitionDec (DOpenTypeFamilyD tf_head) = - -- See Note [Partitioning, type synonyms, and type families] - pure $ mempty { pd_open_type_family_decs = [TypeFamilyDecl tf_head] } -partitionDec (DTySynInstD {}) = pure mempty - -- There's no need to track type family instances, since - -- we already record the type family itself separately. -partitionDec (DStandaloneDerivD mb_strat _ ctxt ty) = - case unfoldDType ty of - (cls_pred_ty, cls_tys) - | let cls_normal_tys = filterDTANormals cls_tys - , not (null cls_normal_tys) -- We can't handle zero-parameter type classes - , let cls_arg_tys = init cls_normal_tys - data_ty = last cls_normal_tys - data_ty_head = case unfoldDType data_ty of (ty_head, _) -> ty_head - , DConT data_tycon <- data_ty_head -- We can't handle deriving an instance for something - -- other than a type constructor application - -> do let cls_pred = foldType cls_pred_ty cls_arg_tys - dinfo <- dsReify data_tycon - case dinfo of - Just (DTyConI (DDataD _ _ dn dtvbs dk dcons _) _) -> do - all_tvbs <- buildDataDTvbs dtvbs dk - let data_decl = DataDecl dn all_tvbs dcons - partitionDeriving mb_strat cls_pred (Just ctxt) data_ty data_decl - Just _ -> - fail $ "Standalone derived instance for something other than a datatype: " - ++ show data_ty - _ -> fail $ "Cannot find " ++ show data_ty - _ -> return mempty -partitionDec dec = - fail $ "Declaration cannot be promoted: " ++ pprint (decToTH dec) - -partitionClassDec :: MonadFail m => DDec -> m (ULetDecEnv, [OpenTypeFamilyDecl]) -partitionClassDec (DLetDec (DSigD name ty)) = - pure (typeBinding name ty, mempty) -partitionClassDec (DLetDec (DValD (DVarP name) exp)) = - pure (valueBinding name (UValue exp), mempty) -partitionClassDec (DLetDec (DFunD name clauses)) = - pure (valueBinding name (UFunction clauses), mempty) -partitionClassDec (DLetDec (DInfixD fixity name)) = - pure (infixDecl fixity name, mempty) -partitionClassDec (DLetDec (DPragmaD {})) = - pure (mempty, mempty) -partitionClassDec (DOpenTypeFamilyD tf_head) = - -- See Note [Partitioning, type synonyms, and type families] - pure (mempty, [TypeFamilyDecl tf_head]) -partitionClassDec (DTySynInstD {}) = - -- There's no need to track associated type family default equations, since - -- we already record the type family itself separately. - pure (mempty, mempty) -partitionClassDec _ = - fail "Only method declarations can be promoted within a class." - -partitionInstanceDec :: MonadFail m => DDec - -> m ( Maybe (Name, ULetDecRHS) -- right-hand sides of methods - , OMap Name DType -- method type signatures - ) -partitionInstanceDec (DLetDec (DValD (DVarP name) exp)) = - pure (Just (name, UValue exp), mempty) -partitionInstanceDec (DLetDec (DFunD name clauses)) = - pure (Just (name, UFunction clauses), mempty) -partitionInstanceDec (DLetDec (DSigD name ty)) = - pure (Nothing, OMap.singleton name ty) -partitionInstanceDec (DLetDec (DPragmaD {})) = - pure (Nothing, mempty) -partitionInstanceDec (DTySynInstD {}) = - pure (Nothing, mempty) - -- There's no need to track associated type family instances, since - -- we already record the type family itself separately. -partitionInstanceDec _ = - fail "Only method bodies can be promoted within an instance." - -partitionDeriving - :: forall m. DsMonad m - => Maybe DDerivStrategy - -- ^ The deriving strategy, if present. - -> DPred -- ^ The class being derived (e.g., 'Eq'), possibly applied to - -- some number of arguments (e.g., @C Int Bool@). - -> Maybe DCxt -- ^ @'Just' ctx@ if @ctx@ was provided via @StandaloneDeriving@. - -- 'Nothing' if using a @deriving@ clause. - -> DType -- ^ The data type argument to the class. - -> DataDecl -- ^ The original data type information (e.g., its constructors). - -> m PartitionedDecs -partitionDeriving mb_strat deriv_pred mb_ctxt ty data_decl = - case unfoldDType deriv_pred of - (DConT deriv_name, arg_tys) - -- Here, we are more conservative than GHC: DeriveAnyClass only kicks - -- in if the user explicitly chooses to do so with the anyclass - -- deriving strategy - | Just DAnyclassStrategy <- mb_strat - -> return $ mk_derived_inst - InstDecl { id_cxt = fromMaybe [] mb_ctxt - -- For now at least, there's no point in attempting to - -- infer an instance context for DeriveAnyClass, since - -- the other language feature that requires it, - -- DefaultSignatures, can't be singled. Thus, inferring an - -- empty context will Just Work for all currently supported - -- default implementations. - -- - -- (Of course, if a user specifies a context with - -- StandaloneDeriving, use that.) - - , id_name = deriv_name - , id_arg_tys = filterDTANormals arg_tys ++ [ty] - , id_sigs = mempty - , id_meths = [] } - - | Just DNewtypeStrategy <- mb_strat - -> do qReportWarning "GeneralizedNewtypeDeriving is ignored by `singletons`." - return mempty - - | Just (DViaStrategy {}) <- mb_strat - -> do qReportWarning "DerivingVia is ignored by `singletons`." - return mempty - - -- Stock classes. These are derived only if `singletons` supports them - -- (and, optionally, if an explicit stock deriving strategy is used) - (DConT deriv_name, []) -- For now, all stock derivable class supported in - -- singletons take just one argument (the data - -- type itself) - | stock_or_default - , Just decs <- Map.lookup deriv_name stock_map - -> decs - - -- If we can't find a stock class, but the user bothered to use an - -- explicit stock keyword, we can at least warn them about it. - | Just DStockStrategy <- mb_strat - -> do qReportWarning $ "`singletons` doesn't recognize the stock class " - ++ nameBase deriv_name - return mempty - - _ -> return mempty -- singletons doesn't support deriving this instance - where - mk_instance :: DerivDesc m -> m UInstDecl - mk_instance maker = maker mb_ctxt ty data_decl - - mk_derived_inst dec = mempty { pd_instance_decs = [dec] } - mk_derived_eq_inst dec = mempty { pd_derived_eq_decs = [dec] } - - derived_decl :: DerivedDecl cls - derived_decl = DerivedDecl { ded_mb_cxt = mb_ctxt - , ded_type = ty - , ded_type_tycon = ty_tycon - , ded_decl = data_decl } - where - ty_tycon :: Name - ty_tycon = case unfoldDType ty of - (DConT tc, _) -> tc - (t, _) -> error $ "Not a data type: " ++ show t - stock_or_default = isStockOrDefault mb_strat - - -- A mapping from all stock derivable classes (that singletons supports) - -- to to derived code that they produce. - stock_map :: Map Name (m PartitionedDecs) - stock_map = Map.fromList - [ ( ordName, mk_derived_inst <$> mk_instance mkOrdInstance ) - , ( boundedName, mk_derived_inst <$> mk_instance mkBoundedInstance ) - , ( enumName, mk_derived_inst <$> mk_instance mkEnumInstance ) - , ( functorName, mk_derived_inst <$> mk_instance mkFunctorInstance ) - , ( foldableName, mk_derived_inst <$> mk_instance mkFoldableInstance ) - , ( traversableName, mk_derived_inst <$> mk_instance mkTraversableInstance ) - -- See Note [DerivedDecl] in Data.Singletons.Syntax - , ( eqName, return $ mk_derived_eq_inst derived_decl ) - -- See Note [DerivedDecl] in Data.Singletons.Syntax - , ( showName, do -- These will become PShow/SShow instances... - inst_for_promotion <- mk_instance $ mkShowInstance ForPromotion - -- ...and this will become a Show instance. - let inst_for_show = derived_decl - pure $ mempty { pd_instance_decs = [inst_for_promotion] - , pd_derived_show_decs = [inst_for_show] } ) - ] - --- Is this being used with an explicit stock strategy, or no strategy at all? -isStockOrDefault :: Maybe DDerivStrategy -> Bool -isStockOrDefault Nothing = True -isStockOrDefault (Just DStockStrategy) = True -isStockOrDefault (Just _) = False - -{- -Note [Partitioning, type synonyms, and type families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The process of singling does not produce any new declarations corresponding to -type synonyms or type families, so they are "ignored" in a sense. Nevertheless, -we explicitly track them during partitioning, since we want to create -defunctionalization symbols for them. - -Also note that: - -1. Other uses of type synonyms in singled code will be expanded away. -2. Other uses of type families in singled code are unlikely to work at present - due to Trac #12564. --} diff --git a/src/Data/Singletons/Prelude.hs b/src/Data/Singletons/Prelude.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude.hs +++ /dev/null @@ -1,277 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Mimics the Haskell Prelude, but with singleton types. Includes the basic --- singleton definitions. Note: This is currently very incomplete! --- --- Because many of these definitions are produced by Template Haskell, it is --- not possible to create proper Haddock documentation. Also, please excuse --- the apparent repeated variable names. This is due to an interaction between --- Template Haskell and Haddock. --- ----------------------------------------------------------------------------- - -{-# LANGUAGE ExplicitNamespaces #-} -module Data.Singletons.Prelude ( - -- * Basic singleton definitions - module Data.Singletons, - - -- * Singleton types - - SBool(..), SList(..), SMaybe(..), SEither(..), SOrdering(..), - STuple0(..), STuple2(..), STuple3(..), STuple4(..), - STuple5(..), STuple6(..), STuple7(..), - - -- * Functions working with 'Bool' - If, sIf, Not, sNot, type (&&), type (||), (%&&), (%||), Otherwise, sOtherwise, - - -- * Error reporting - Error, sError, - ErrorWithoutStackTrace, sErrorWithoutStackTrace, - Undefined, sUndefined, - - -- * Singleton equality - module Data.Singletons.Prelude.Eq, - - -- * Singleton comparisons - POrd(..), SOrd(..), - - -- * Singleton Enum and Bounded - -- | As a matter of convenience, the singletons Prelude does /not/ export - -- promoted/singletonized @succ@ and @pred@, due to likely conflicts with - -- unary numbers. Please import 'Data.Singletons.Prelude.Enum' directly if - -- you want these. - module Data.Singletons.Prelude.Enum, - - -- * Singletons numbers - module Data.Singletons.Prelude.Num, - type (^), (%^), - - -- * Singleton 'Show' - PShow(..), SShow(..), ShowS, SChar, - Shows, sShows, ShowChar, sShowChar, ShowString, sShowString, ShowParen, sShowParen, - - -- * Singleton 'Semigroup' and 'Monoid' - PSemigroup(type (<>)), SSemigroup((%<>)), - PMonoid(..), SMonoid(..), - - -- * Singleton 'Functor', 'Applicative', 'Monad', and 'MonadFail' - PFunctor(Fmap, type (<$)), SFunctor(sFmap, (%<$)), type (<$>), (%<$>), - PApplicative(Pure, type (<*>), type (*>), type (<*)), - SApplicative(sPure, (%<*>), (%*>), (%<*)), - PMonad(type (>>=), type (>>), Return), - SMonad((%>>=), (%>>), sReturn), - PMonadFail(Fail), SMonadFail(sFail), - - MapM_, sMapM_, - Sequence_, sSequence_, - type (=<<), (%=<<), - - -- * Singleton 'Foldable' and 'Traversable' - PFoldable(Elem, FoldMap, Foldr, Foldl, Foldr1, Foldl1, - Maximum, Minimum, Product, Sum), - SFoldable(sElem, sFoldMap, sFoldr, sFoldl, sFoldr1, sFoldl1, - sMaximum, sMinimum, sProduct, sSum), - PTraversable(Traverse, SequenceA, MapM, Sequence), - STraversable(sTraverse, sSequenceA, sMapM, sSequence), - - -- ** Miscellaneous functions - Id, sId, Const, sConst, type (.), (%.), type ($), (%$), type ($!), (%$!), - Flip, sFlip, AsTypeOf, sAsTypeOf, - Seq, sSeq, - - -- * List operations - Map, sMap, type (++), (%++), Filter, sFilter, - Head, sHead, Last, sLast, Tail, sTail, - Init, sInit, Null, sNull, Reverse, sReverse, - -- *** Special folds - And, sAnd, Or, sOr, Any, sAny, All, sAll, - Concat, sConcat, ConcatMap, sConcatMap, - -- *** Scans - Scanl, sScanl, Scanl1, sScanl1, Scanr, sScanr, Scanr1, sScanr1, - -- *** Infinite lists - Replicate, sReplicate, - -- ** Sublists - Take, sTake, Drop, sDrop, SplitAt, sSplitAt, TakeWhile, sTakeWhile, - Span, sSpan, Break, sBreak, - -- ** Searching lists - NotElem, sNotElem, Lookup, sLookup, - -- ** Zipping and unzipping lists - Zip, sZip, Zip3, sZip3, ZipWith, sZipWith, ZipWith3, sZipWith3, - Unzip, sUnzip, Unzip3, sUnzip3, - -- ** Functions on 'Symbol's - Unlines, sUnlines, Unwords, sUnwords, - - -- * Other datatypes - Maybe_, sMaybe_, - Either_, sEither_, - Fst, sFst, Snd, sSnd, Curry, sCurry, Uncurry, sUncurry, - Symbol, - - -- * Other functions - either_, -- reimplementation of either to be used with singletons library - maybe_, - bool_, - show_, - - -- * Defunctionalization symbols - FalseSym0, TrueSym0, - NotSym0, NotSym1, - type (&&@#@$), type (&&@#@$$), type (&&@#@$$$), - type (||@#@$), type (||@#@$$), type (||@#@$$$), - 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, - - ErrorSym0, ErrorSym1, - ErrorWithoutStackTraceSym0, ErrorWithoutStackTraceSym1, - UndefinedSym0, - - LTSym0, EQSym0, GTSym0, - CompareSym0, CompareSym1, CompareSym2, - type (<@#@$), type (<@#@$$), type (<@#@$$$), - type (<=@#@$), type (<=@#@$$), type (<=@#@$$$), - type (>@#@$), type (>@#@$$), type (>@#@$$$), - type (>=@#@$), type (>=@#@$$), type (>=@#@$$$), - MaxSym0, MaxSym1, MaxSym2, - MinSym0, MinSym1, MinSym2, - - type (^@#@$), type (^@#@$$), type (^@#@$$$), - - ShowsPrecSym0, ShowsPrecSym1, ShowsPrecSym2, ShowsPrecSym3, - Show_Sym0, Show_Sym1, - ShowListSym0, ShowListSym1, ShowListSym2, - ShowsSym0, ShowsSym1, ShowsSym2, - ShowCharSym0, ShowCharSym1, ShowCharSym2, - ShowStringSym0, ShowStringSym1, ShowStringSym2, - ShowParenSym0, ShowParenSym1, ShowParenSym2, - - type (<>@#@$), type (<>@#@$$), type (<>@#@$$$), - MemptySym0, - MappendSym0, MappendSym1, MappendSym2, - MconcatSym0, MconcatSym1, - - FmapSym0, FmapSym1, FmapSym2, - type (<$@#@$), type (<$@#@$$), type (<$@#@$$$), - type (<$>@#@$), type (<$>@#@$$), type (<$>@#@$$$), - PureSym0, PureSym1, - type (<*>@#@$), type (<*>@#@$$), type (<*>@#@$$$), - type (*>@#@$), type (*>@#@$$), type (*>@#@$$$), - type (<*@#@$), type (<*@#@$$), type (<*@#@$$$), - type (>>=@#@$), type (>>=@#@$$), type (>>=@#@$$$), - type (>>@#@$), type (>>@#@$$), type (>>@#@$$$), - ReturnSym0, ReturnSym1, FailSym0, FailSym1, - MapM_Sym0, MapM_Sym1, MapM_Sym2, - Sequence_Sym0, Sequence_Sym1, - type (=<<@#@$), type (=<<@#@$$), type (=<<@#@$$$), - - ElemSym0, ElemSym1, ElemSym2, - FoldMapSym0, FoldMapSym1, FoldMapSym2, - FoldrSym0, FoldrSym1, FoldrSym2, FoldrSym3, - FoldlSym0, FoldlSym1, FoldlSym2, FoldlSym3, - Foldr1Sym0, Foldr1Sym1, Foldr1Sym2, - Foldl1Sym0, Foldl1Sym1, Foldl1Sym2, - MaximumSym0, MaximumSym1, - MinimumSym0, MinimumSym1, - SumSym0, SumSym1, - ProductSym0, ProductSym1, - - TraverseSym0, TraverseSym1, TraverseSym2, - SequenceASym0, SequenceASym1, - MapMSym0, MapMSym1, MapMSym2, - SequenceSym0, SequenceSym1, - - IdSym0, IdSym1, ConstSym0, ConstSym1, ConstSym2, - type (.@#@$), type (.@#@$$), type (.@#@$$$), - type ($@#@$), type ($@#@$$), type ($@#@$$$), - type ($!@#@$), type ($!@#@$$), type ($!@#@$$$), - FlipSym0, FlipSym1, FlipSym2, - AsTypeOfSym0, AsTypeOfSym1, AsTypeOfSym2, SeqSym0, SeqSym1, SeqSym2, - - (:@#@$), (:@#@$$), (:@#@$$$), NilSym0, - MapSym0, MapSym1, MapSym2, ReverseSym0, ReverseSym1, - type (++@#@$$), type (++@#@$), FilterSym0, FilterSym1, FilterSym2, - HeadSym0, HeadSym1, LastSym0, LastSym1, - TailSym0, TailSym1, InitSym0, InitSym1, NullSym0, NullSym1, - - ConcatSym0, ConcatSym1, - ConcatMapSym0, ConcatMapSym1, ConcatMapSym2, - AndSym0, AndSym1, OrSym0, OrSym1, - AnySym0, AnySym1, AnySym2, - AllSym0, AllSym1, AllSym2, - - ScanlSym0, ScanlSym1, ScanlSym2, ScanlSym3, - Scanl1Sym0, Scanl1Sym1, Scanl1Sym2, - ScanrSym0, ScanrSym1, ScanrSym2, ScanrSym3, - Scanr1Sym0, Scanr1Sym1, Scanr1Sym2, - - ReplicateSym0, ReplicateSym1, ReplicateSym2, - - TakeSym0, TakeSym1, TakeSym2, - DropSym0, DropSym1, DropSym2, - SplitAtSym0, SplitAtSym1, SplitAtSym2, - TakeWhileSym0, TakeWhileSym1, TakeWhileSym2, - DropWhileSym0, DropWhileSym1, DropWhileSym2, - DropWhileEndSym0, DropWhileEndSym1, DropWhileEndSym2, - SpanSym0, SpanSym1, SpanSym2, - BreakSym0, BreakSym1, BreakSym2, - - NotElemSym0, NotElemSym1, NotElemSym2, - - ZipSym0, ZipSym1, ZipSym2, - Zip3Sym0, Zip3Sym1, Zip3Sym2, Zip3Sym3, - ZipWithSym0, ZipWithSym1, ZipWithSym2, ZipWithSym3, - ZipWith3Sym0, ZipWith3Sym1, ZipWith3Sym2, ZipWith3Sym3, - UnzipSym0, UnzipSym1, - - UnlinesSym0, UnlinesSym1, UnwordsSym0, UnwordsSym1 - ) where - -import Data.Singletons -import Data.Singletons.Prelude.Applicative - hiding (Const, ConstSym0, ConstSym1) -import Data.Singletons.Prelude.Base - hiding (Foldr, FoldrSym0, FoldrSym1, FoldrSym2, FoldrSym3, sFoldr) -import Data.Singletons.Prelude.Bool -import Data.Singletons.Prelude.Either -import Data.Singletons.Prelude.Foldable -import Data.Singletons.Prelude.Functor -import Data.Singletons.Prelude.List -import Data.Singletons.Prelude.Maybe -import Data.Singletons.Prelude.Monad -import Data.Singletons.Prelude.Tuple -import Data.Singletons.Prelude.Eq -import Data.Singletons.Prelude.Ord -import Data.Singletons.Prelude.Enum - hiding (Succ, Pred, SuccSym0, SuccSym1, PredSym0, PredSym1, sSucc, sPred) -import Data.Singletons.Prelude.Monoid - ( PMonoid(..), SMonoid(..), MemptySym0, MappendSym0 - , MappendSym1, MappendSym2, MconcatSym0, MconcatSym1 ) -import Data.Singletons.Prelude.Num -import Data.Singletons.Prelude.Semigroup - ( PSemigroup(..), SSemigroup(..) - , type (<>@#@$), type (<>@#@$$), type (<>@#@$$$) ) -import Data.Singletons.Prelude.Show -import Data.Singletons.Prelude.Traversable -import Data.Singletons.TypeLits diff --git a/src/Data/Singletons/Prelude/Applicative.hs b/src/Data/Singletons/Prelude/Applicative.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/Applicative.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Applicative --- Copyright : (C) 2018 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Defines the promoted and singled versions of the 'Applicative' type class. --- ----------------------------------------------------------------------------- - -module Data.Singletons.Prelude.Applicative ( - PApplicative(..), SApplicative(..), - PAlternative(..), SAlternative(..), - Sing, SConst(..), Const, GetConst, - type (<$>), (%<$>), type (<$), (%<$), type (<**>), (%<**>), - LiftA, sLiftA, LiftA3, sLiftA3, Optional, sOptional, - - -- * Defunctionalization symbols - PureSym0, PureSym1, - type (<*>@#@$), type (<*>@#@$$), type (<*>@#@$$$), - type (*>@#@$), type (*>@#@$$), type (*>@#@$$$), - type (<*@#@$), type (<*@#@$$), type (<*@#@$$$), - EmptySym0, type (<|>@#@$), type (<|>@#@$$), type (<|>@#@$$$), - ConstSym0, ConstSym1, GetConstSym0, GetConstSym1, - type (<$>@#@$), type (<$>@#@$$), type (<$>@#@$$$), - type (<$@#@$), type (<$@#@$$), type (<$@#@$$$), - type (<**>@#@$), type (<**>@#@$$), type (<**>@#@$$$), - LiftASym0, LiftASym1, LiftASym2, - LiftA2Sym0, LiftA2Sym1, LiftA2Sym2, LiftA2Sym3, - LiftA3Sym0, LiftA3Sym1, LiftA3Sym2, LiftA3Sym3, - OptionalSym0, OptionalSym1 - ) where - -import Control.Applicative -import Data.Ord (Down(..)) -import Data.Singletons.Prelude.Const -import Data.Singletons.Prelude.Functor -import Data.Singletons.Prelude.Instances -import Data.Singletons.Prelude.Monad.Internal -import Data.Singletons.Prelude.Monoid -import Data.Singletons.Prelude.Ord -import Data.Singletons.Single - -$(singletonsOnly [d| - -- -| One or none. - optional :: Alternative f => f a -> f (Maybe a) - optional v = Just <$> v <|> pure Nothing - - instance Monoid a => Applicative ((,) a) where - pure x = (mempty, x) - (u, f) <*> (v, x) = (u `mappend` v, f x) - liftA2 f (u, x) (v, y) = (u `mappend` v, f x y) - - instance Applicative Down where - pure = Down - Down f <*> Down x = Down (f x) - |]) diff --git a/src/Data/Singletons/Prelude/Base.hs b/src/Data/Singletons/Prelude/Base.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/Base.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-# LANGUAGE TemplateHaskell, TypeOperators, DataKinds, PolyKinds, - ScopedTypeVariables, TypeFamilies, GADTs, - UndecidableInstances, BangPatterns, TypeApplications #-} - ------------------------------------------------------------------------------ --- | --- 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, type (++), (%++), Otherwise, sOtherwise, - Id, sId, Const, sConst, type (.), (%.), type ($), type ($!), (%$), (%$!), - Until, sUntil, Flip, sFlip, AsTypeOf, sAsTypeOf, - Seq, sSeq, - - -- * Defunctionalization symbols - FoldrSym0, FoldrSym1, FoldrSym2, FoldrSym3, - MapSym0, MapSym1, MapSym2, - type (++@#@$), type (++@#@$$), type (++@#@$$$), - OtherwiseSym0, - IdSym0, IdSym1, - ConstSym0, ConstSym1, ConstSym2, - type (.@#@$), type (.@#@$$), type (.@#@$$$), type (.@#@$$$$), - type ($@#@$), type ($@#@$$), type ($@#@$$$), - type ($!@#@$), type ($!@#@$$), type ($!@#@$$$), - UntilSym0, UntilSym1, UntilSym2, UntilSym3, - FlipSym0, FlipSym1, FlipSym2, FlipSym3, - AsTypeOfSym0, AsTypeOfSym1, AsTypeOfSym2, - SeqSym0, SeqSym1, SeqSym2 - ) where - -import Data.Singletons.Prelude.Instances -import Data.Singletons.Single -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 - infixr 5 ++ - - 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) - infixr 9 . - - flip :: (a -> b -> c) -> b -> a -> c - flip f x y = f y x - - asTypeOf :: a -> a -> a - asTypeOf = const - - ($) :: (a -> b) -> a -> b - f $ x = f x - infixr 0 $ - - ($!) :: (a -> b) -> a -> b - f $! x = let {-!-}vx = x in f vx - infixr 0 $! - - until :: (a -> Bool) -> (a -> a) -> a -> a - until p f = go - where - -- Does not singletonize due to overlapping patterns. - {- - go x | p x = x - | otherwise = go (f x) - -} - go x = if p x then x else go (f x) - - -- 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 - infixr 0 `seq` - |]) - --- Workaround for #326 -infixr 5 ++ -infixr 9 . -infixr 0 $ -infixr 0 $! diff --git a/src/Data/Singletons/Prelude/Bool.hs b/src/Data/Singletons/Prelude/Bool.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/Bool.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE TemplateHaskell, TypeApplications, TypeFamilies, TypeOperators, - GADTs, ScopedTypeVariables, DeriveDataTypeable, UndecidableInstances, - DataKinds, PolyKinds #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Bool --- Copyright : (C) 2013-2014 Richard Eisenberg, Jan Stolarek --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- 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, SBool(..), - - -- * Conditionals - If, sIf, - - -- * Singletons from @Data.Bool@ - Not, sNot, type (&&), type (||), (%&&), (%||), - - -- | 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, - type (&&@#@$), type (&&@#@$$), type (&&@#@$$$), - type (||@#@$), type (||@#@$$), type (||@#@$$$), - Bool_Sym0, Bool_Sym1, Bool_Sym2, Bool_Sym3, - OtherwiseSym0 - ) where - -import Data.Singletons.Internal -import Data.Singletons.Prelude.Instances -import Data.Singletons.Promote -import Data.Singletons.Single -import Data.Type.Bool ( If, type (&&), type (||), Not ) - -$(singletons [d| - bool_ :: a -> a -> Bool -> a - bool_ fls _tru False = fls - bool_ _fls tru True = tru - |]) - -$(singletonsOnly [d| - otherwise :: Bool - otherwise = True - |]) - --- | Conjunction of singletons -(%&&) :: Sing a -> Sing b -> Sing (a && b) -SFalse %&& _ = SFalse -STrue %&& a = a -infixr 3 %&& -$(genDefunSymbols [''(&&)]) -instance SingI (&&@#@$) where - sing = singFun2 (%&&) -instance SingI x => SingI ((&&@#@$$) x) where - sing = singFun1 (sing @x %&&) - --- | Disjunction of singletons -(%||) :: Sing a -> Sing b -> Sing (a || b) -SFalse %|| a = a -STrue %|| _ = STrue -infixr 2 %|| -$(genDefunSymbols [''(||)]) -instance SingI (||@#@$) where - sing = singFun2 (%||) -instance SingI x => SingI ((||@#@$$) x) where - sing = singFun1 (sing @x %||) - --- | Negation of a singleton -sNot :: Sing a -> Sing (Not a) -sNot SFalse = STrue -sNot STrue = SFalse -$(genDefunSymbols [''Not]) -instance SingI NotSym0 where - sing = singFun1 sNot - --- | 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/Const.hs b/src/Data/Singletons/Prelude/Const.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/Const.hs +++ /dev/null @@ -1,138 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Const --- Copyright : (C) 2018 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) --- Stability : experimental --- Portability : non-portable --- --- Exports the promoted and singled versions of the 'Const' data type. --- ------------------------------------------------------------------------------ - -module Data.Singletons.Prelude.Const ( - -- * The 'Const' singleton - Sing, SConst(..), GetConst, - - -- * Defunctionalization symbols - ConstSym0, ConstSym1, - GetConstSym0, GetConstSym1 - ) where - -import Control.Applicative -import Data.Kind (Type) -import Data.Singletons.Internal -import Data.Singletons.Prelude.Base - hiding ( Const, ConstSym0, ConstSym1 - , Foldr, FoldrSym0, sFoldr ) -import Data.Singletons.Prelude.Enum -import Data.Singletons.Prelude.Eq -import Data.Singletons.Prelude.Foldable -import Data.Singletons.Prelude.Instances hiding (FoldlSym0, sFoldl) -import Data.Singletons.Prelude.Monad.Internal -import Data.Singletons.Prelude.Monoid -import Data.Singletons.Prelude.Num -import Data.Singletons.Prelude.Ord -import Data.Singletons.Prelude.Semigroup.Internal -import Data.Singletons.Prelude.Show -import Data.Singletons.Promote -import Data.Singletons.Single - -{- -Const's argument `b` is poly-kinded, and as a result, we have a choice as to -what Sing instance to give it. We could use either - -1. data instance Sing :: forall (k :: Type) (a :: Type) (b :: k). Const a b -> Type -2. data instance Sing :: forall (a :: Type) (b :: Type). Const a b -> Type - -Option (1) is the more permissive one, so we opt for that. However, singletons' -TH machinery does not jive with this option, since the SingKind instance it -tries to generate: - - instance (SingKind a, SingKind b) => SingKind (Const a b) where - type Demote (Const a b) = Const (Demote a) (Demote b) - -Assumes that `b` is of kind Type. Until we get a more reliable story for -poly-kinded Sing instances (see #150), we simply write the Sing instance by -hand. --} -data SConst :: forall (k :: Type) (a :: Type) (b :: k). Const a b -> Type where - SConst :: { sGetConst :: Sing a } -> SConst ('Const a) -type instance Sing = SConst -instance SingKind a => SingKind (Const a b) where - type Demote (Const a b) = Const (Demote a) b - fromSing (SConst sa) = Const (fromSing sa) - toSing (Const a) = withSomeSing a $ SomeSing . SConst -instance SingI a => SingI ('Const a) where - sing = SConst sing - -$(genDefunSymbols [''Const]) -instance SingI ConstSym0 where - sing = singFun1 SConst - -$(singletons [d| - type family GetConst (x :: Const a b) :: a where - GetConst ('Const x) = x - |]) - -$(singletonsOnly [d| - deriving instance Bounded a => Bounded (Const a b) - deriving instance Eq a => Eq (Const a b) - deriving instance Ord a => Ord (Const a b) - - -- deriving instance Enum a => Enum (Const a b) - instance Enum a => Enum (Const a b) where - succ (Const x) = Const (succ x) - pred (Const x) = Const (pred x) - toEnum i = Const (toEnum i) - fromEnum (Const x) = fromEnum x - enumFromTo (Const x) (Const y) = map Const (enumFromTo x y) - enumFromThenTo (Const x) (Const y) (Const z) = - map Const (enumFromThenTo x y z) - - -- deriving instance Monoid a => Monoid (Const a b) - instance Monoid a => Monoid (Const a b) where - mempty = Const mempty - - -- deriving instance Num a => Num (Const a b) - instance Num a => Num (Const a b) where - Const x + Const y = Const (x + y) - Const x - Const y = Const (x - y) - Const x * Const y = Const (x * y) - negate (Const x) = Const (negate x) - abs (Const x) = Const (abs x) - signum (Const x) = Const (signum x) - fromInteger n = Const (fromInteger n) - - -- deriving instance Semigroup a => Semigroup (Const a b) - instance Semigroup a => Semigroup (Const a b) where - Const x <> Const y = Const (x <> y) - - -- -| This instance would be equivalent to the derived instances of the - -- 'Const' newtype if the 'runConst' field were removed - instance Show a => Show (Const a b) where - showsPrec d (Const x) = showParen (d > 10) $ - showString "Const " . showsPrec 11 x - - deriving instance Functor (Const m) - deriving instance Foldable (Const m) - - instance Monoid m => Applicative (Const m) where - pure _ = Const mempty - liftA2 _ (Const x) (Const y) = Const (x `mappend` y) - Const x <*> Const y = Const (x `mappend` y) - |]) diff --git a/src/Data/Singletons/Prelude/Either.hs b/src/Data/Singletons/Prelude/Either.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/Either.hs +++ /dev/null @@ -1,104 +0,0 @@ -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TypeFamilies, GADTs, - RankNTypes, UndecidableInstances, DataKinds, PolyKinds, - TypeApplications #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Either --- Copyright : (C) 2013-2014 Richard Eisenberg, Jan Stolarek --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- 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, SEither(..), - - -- * 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.Prelude.Base -import Data.Singletons.Single - --- NB: The haddock comments are disabled because TH can't deal with them. - -$(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/Enum.hs b/src/Data/Singletons/Prelude/Enum.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/Enum.hs +++ /dev/null @@ -1,137 +0,0 @@ -{-# LANGUAGE TemplateHaskell, DataKinds, PolyKinds, ScopedTypeVariables, - TypeFamilies, TypeOperators, GADTs, UndecidableInstances, - FlexibleContexts, DefaultSignatures, BangPatterns, - InstanceSigs, TypeApplications #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Enum --- Copyright : (C) 2014 Jan Stolarek, Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Jan Stolarek (jan.stolarek@p.lodz.pl) --- Stability : experimental --- Portability : non-portable --- --- Defines the promoted and singleton version of Bounded, 'PBounded' --- and 'SBounded' --- ------------------------------------------------------------------------------ - -module Data.Singletons.Prelude.Enum ( - PBounded(..), SBounded(..), - PEnum(..), SEnum(..), - - -- ** Defunctionalization symbols - MinBoundSym0, - MaxBoundSym0, - SuccSym0, SuccSym1, - PredSym0, PredSym1, - ToEnumSym0, ToEnumSym1, - FromEnumSym0, FromEnumSym1, - EnumFromToSym0, EnumFromToSym1, EnumFromToSym2, - EnumFromThenToSym0, EnumFromThenToSym1, EnumFromThenToSym2, - EnumFromThenToSym3 - - ) where - -import Data.Singletons.Single -import Data.Singletons.Util -import Data.Singletons.Prelude.Num -import Data.Singletons.Prelude.Base -import Data.Singletons.Prelude.Ord -import Data.Singletons.Prelude.Eq -import Data.Singletons.Prelude.Instances -import Data.Singletons.TypeLits - -$(singletonsOnly [d| - class Bounded a where - minBound, maxBound :: a - |]) - -$(singBoundedInstances boundedBasicTypes) - -$(singletonsOnly [d| - class Enum a where - -- | the successor of a value. For numeric types, 'succ' adds 1. - succ :: a -> a - -- | the predecessor of a value. For numeric types, 'pred' subtracts 1. - pred :: a -> a - -- | Convert from a 'Nat'. - toEnum :: Nat -> a - -- | Convert to a 'Nat'. - fromEnum :: a -> Nat - - -- The following use infinite lists, and are not promotable: - -- -- | Used in Haskell's translation of @[n..]@. - -- enumFrom :: a -> [a] - -- -- | Used in Haskell's translation of @[n,n'..]@. - -- enumFromThen :: a -> a -> [a] - - -- | Used in Haskell's translation of @[n..m]@. - enumFromTo :: a -> a -> [a] - -- | Used in Haskell's translation of @[n,n'..m]@. - enumFromThenTo :: a -> a -> a -> [a] - - succ = toEnum . (+1) . fromEnum - pred = toEnum . (subtract 1) . fromEnum - -- enumFrom x = map toEnum [fromEnum x ..] - -- enumFromThen x y = map toEnum [fromEnum x, fromEnum y ..] - enumFromTo x y = map toEnum [fromEnum x .. fromEnum y] - enumFromThenTo x1 x2 y = map toEnum [fromEnum x1, fromEnum x2 .. fromEnum y] - - -- Nat instance for Enum - eftNat :: Nat -> Nat -> [Nat] - -- [x1..x2] - eftNat x0 y | (x0 > y) = [] - | otherwise = go x0 - where - go x = x : if (x == y) then [] else go (x + 1) - - efdtNat :: Nat -> Nat -> Nat -> [Nat] - -- [x1,x2..y] - efdtNat x1 x2 y - | x2 >= x1 = efdtNatUp x1 x2 y - | otherwise = efdtNatDn x1 x2 y - - -- Requires x2 >= x1 - efdtNatUp :: Nat -> Nat -> Nat -> [Nat] - efdtNatUp x1 x2 y -- Be careful about overflow! - | y < x2 = if y < x1 then [] else [x1] - | otherwise = -- Common case: x1 <= x2 <= y - let delta = x2 - x1 -- >= 0 - y' = y - delta -- x1 <= y' <= y; hence y' is representable - - -- Invariant: x <= y - -- Note that: z <= y' => z + delta won't overflow - -- so we are guaranteed not to overflow if/when we recurse - go_up x | x > y' = [x] - | otherwise = x : go_up (x + delta) - in x1 : go_up x2 - - -- Requires x2 <= x1 - efdtNatDn :: Nat -> Nat -> Nat -> [Nat] - efdtNatDn x1 x2 y -- Be careful about underflow! - | y > x2 = if y > x1 then [] else [x1] - | otherwise = -- Common case: x1 >= x2 >= y - let delta = x2 - x1 -- <= 0 - y' = y - delta -- y <= y' <= x1; hence y' is representable - - -- Invariant: x >= y - -- Note that: z >= y' => z + delta won't underflow - -- so we are guaranteed not to underflow if/when we recurse - go_dn x | x < y' = [x] - | otherwise = x : go_dn (x + delta) - in x1 : go_dn x2 - - instance Enum Nat where - succ x = x + 1 - pred x = x - 1 - - toEnum x = x - fromEnum x = x - - enumFromTo = eftNat - enumFromThenTo = efdtNat - |]) - -$(singEnumInstances enumBasicTypes) diff --git a/src/Data/Singletons/Prelude/Eq.hs b/src/Data/Singletons/Prelude/Eq.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/Eq.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE TypeOperators, DataKinds, PolyKinds, TypeFamilies, - RankNTypes, FlexibleContexts, TemplateHaskell, - UndecidableInstances, GADTs, DefaultSignatures, - ScopedTypeVariables, TypeApplications #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Eq --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Defines the SEq singleton version of the Eq type class. --- ------------------------------------------------------------------------------ - -module Data.Singletons.Prelude.Eq ( - PEq(..), SEq(..), - DefaultEq, - - -- * Defunctionalization symbols - type (==@#@$), type (==@#@$$), type (==@#@$$$), - type (/=@#@$), type (/=@#@$$), type (/=@#@$$$), - DefaultEqSym0, DefaultEqSym1, DefaultEqSym2 - ) where - -import Data.Singletons.Internal -import Data.Singletons.Prelude.Bool -import Data.Singletons.Single -import Data.Singletons.Prelude.Instances -import Data.Singletons.Util -import Data.Singletons.Promote -import qualified Data.Type.Equality as DTE () - --- NB: These must be defined by hand because of the custom handling of the --- default for (==) to use DefaultEq - --- | The promoted analogue of 'Eq'. If you supply no definition for '(==)', --- then it defaults to a use of 'DefaultEq'. -class PEq a where - type (==) (x :: a) (y :: a) :: Bool - type (/=) (x :: a) (y :: a) :: Bool - - type (x :: a) == (y :: a) = x `DefaultEq` y - type (x :: a) /= (y :: a) = Not (x == y) - - infix 4 == - infix 4 /= - --- | A sensible way to compute Boolean equality for types of any kind. Note --- that this definition is slightly different from the '(DTE.==)' type family --- from "Data.Type.Equality" in @base@, as '(DTE.==)' attempts to distinguish --- applications of type constructors from other types. As a result, --- @a == a@ does not reduce to 'True' for every @a@, but @'DefaultEq' a a@ --- /does/ reduce to 'True' for every @a@. The latter behavior is more desirable --- for @singletons@' purposes, so we use it instead of '(DTE.==)'. -type family DefaultEq (a :: k) (b :: k) :: Bool where - DefaultEq a a = 'True - DefaultEq a b = 'False - -$(genDefunSymbols [''(==), ''(/=), ''DefaultEq]) - --- | 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 SEq k where - -- | Boolean equality on singletons - (%==) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Sing (a == b) - infix 4 %== - - -- | 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) - infix 4 %/= - -$(singEqInstances basicTypes) - -instance SEq a => SingI ((==@#@$) :: a ~> a ~> Bool) where - sing = singFun2 (%==) -instance (SEq a, SingI x) => SingI ((==@#@$$) x :: a ~> Bool) where - sing = singFun1 (sing @x %==) - -instance SEq a => SingI ((/=@#@$) :: a ~> a ~> Bool) where - sing = singFun2 (%/=) -instance (SEq a, SingI x) => SingI ((/=@#@$$) x :: a ~> Bool) where - sing = singFun1 (sing @x %/=) diff --git a/src/Data/Singletons/Prelude/Foldable.hs b/src/Data/Singletons/Prelude/Foldable.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/Foldable.hs +++ /dev/null @@ -1,650 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Foldable --- Copyright : (C) 2018 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Defines the promoted and singled versions of the 'Foldable' type class. --- ----------------------------------------------------------------------------- - -module Data.Singletons.Prelude.Foldable ( - PFoldable(..), SFoldable(..), - - FoldrM, sFoldrM, - FoldlM, sFoldlM, - - Traverse_, sTraverse_, - For_, sFor_, - SequenceA_, sSequenceA_, - Asum, sAsum, - - MapM_, sMapM_, - ForM_, sForM_, - Sequence_, sSequence_, - Msum, sMsum, - - Concat, sConcat, - ConcatMap, sConcatMap, - And, sAnd, - Or, sOr, - Any, sAny, - All, sAll, - MaximumBy, sMaximumBy, - MinimumBy, sMinimumBy, - - NotElem, sNotElem, - Find, sFind, - - -- * Defunctionalization symbols - FoldSym0, FoldSym1, - FoldMapSym0, FoldMapSym1, FoldMapSym2, - FoldrSym0, FoldrSym1, FoldrSym2, FoldrSym3, - Foldr'Sym0, Foldr'Sym1, Foldr'Sym2, Foldr'Sym3, - FoldlSym0, FoldlSym1, FoldlSym2, FoldlSym3, - Foldl'Sym0, Foldl'Sym1, Foldl'Sym2, Foldl'Sym3, - Foldr1Sym0, Foldr1Sym1, Foldr1Sym2, - Foldl1Sym0, Foldl1Sym1, Foldl1Sym2, - ToListSym0, ToListSym1, - NullSym0, NullSym1, - LengthSym0, LengthSym1, - ElemSym0, ElemSym1, ElemSym2, - MaximumSym0, MaximumSym1, - MinimumSym0, MinimumSym1, - SumSym0, SumSym1, - ProductSym0, ProductSym1, - - FoldrMSym0, FoldrMSym1, FoldrMSym2, FoldrMSym3, - FoldlMSym0, FoldlMSym1, FoldlMSym2, FoldlMSym3, - - Traverse_Sym0, Traverse_Sym1, Traverse_Sym2, - For_Sym0, For_Sym1, For_Sym2, - SequenceA_Sym0, SequenceA_Sym1, - AsumSym0, AsumSym1, - - MapM_Sym0, MapM_Sym1, MapM_Sym2, - ForM_Sym0, ForM_Sym1, ForM_Sym2, - Sequence_Sym0, Sequence_Sym1, - MsumSym0, MsumSym1, - - ConcatSym0, ConcatSym1, - ConcatMapSym0, ConcatMapSym1, ConcatMapSym2, - AndSym0, AndSym1, - OrSym0, OrSym1, - AnySym0, AnySym1, AnySym2, - AllSym0, AllSym1, AllSym2, - MaximumBySym0, MaximumBySym1, MaximumBySym2, - MinimumBySym0, MinimumBySym1, MinimumBySym2, - - NotElemSym0, NotElemSym1, NotElemSym2, - FindSym0, FindSym1, FindSym2 - ) where - -import Control.Applicative -import Control.Monad -import Data.Kind -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Monoid hiding (All(..), Any(..), Endo(..), Product(..), Sum(..)) -import qualified Data.Monoid as Monoid (All(..), Any(..), Product(..), Sum(..)) -import Data.Singletons.Internal -import Data.Singletons.Prelude.Base - hiding (Foldr, FoldrSym0, FoldrSym1, FoldrSym2, FoldrSym3, sFoldr) -import Data.Singletons.Prelude.Bool -import Data.Singletons.Prelude.Either -import Data.Singletons.Prelude.Eq -import Data.Singletons.Prelude.Instances - hiding (Foldl, FoldlSym0(..), FoldlSym1(..), FoldlSym2(..), FoldlSym3, sFoldl) -import Data.Singletons.Prelude.List.Internal.Disambiguation -import Data.Singletons.Prelude.Maybe -import Data.Singletons.Prelude.Monad.Internal -import Data.Singletons.Prelude.Monoid - hiding ( AllSym0, AllSym1 - , AnySym0, AnySym1 - , ProductSym0, ProductSym1 - , SumSym0, SumSym1 ) -import Data.Singletons.Prelude.Num -import Data.Singletons.Prelude.Ord - hiding ( Max, MaxSym0, MaxSym1, MaxSym2, sMax - , Min, MinSym0, MinSym1, MinSym2, sMin ) -import Data.Singletons.Prelude.Semigroup.Internal - hiding ( AllSym0(..), AllSym1, SAll - , AnySym0(..), AnySym1, SAny - , FirstSym0, FirstSym1, SFirst - , LastSym0, LastSym1, SLast - , ProductSym0(..), ProductSym1, SProduct - , SumSym0(..), SumSym1, SSum ) -import Data.Singletons.Promote -import Data.Singletons.Single -import Data.Singletons.TypeLits.Internal - -newtype Endo a = Endo (a ~> a) -data SEndo :: forall a. Endo a -> Type where - SEndo :: Sing x -> SEndo ('Endo x) -type instance Sing = SEndo -data EndoSym0 :: forall a. (a ~> a) ~> Endo a -type instance Apply EndoSym0 x = 'Endo x - -$(singletonsOnly [d| - instance Semigroup (Endo a) where - Endo x <> Endo y = Endo (x . y) - - instance Monoid (Endo a) where - mempty = Endo id - |]) - -newtype MaxInternal a = MaxInternal (Maybe a) -data SMaxInternal :: forall a. MaxInternal a -> Type where - SMaxInternal :: Sing x -> SMaxInternal ('MaxInternal x) -type instance Sing = SMaxInternal -$(genDefunSymbols [''MaxInternal]) - -newtype MinInternal a = MinInternal (Maybe a) -data SMinInternal :: forall a. MinInternal a -> Type where - SMinInternal :: Sing x -> SMinInternal ('MinInternal x) -type instance Sing = SMinInternal -$(genDefunSymbols [''MinInternal]) - -$(singletonsOnly [d| - instance Ord a => Semigroup (MaxInternal a) where - m <> MaxInternal Nothing = m - MaxInternal Nothing <> n = n - (MaxInternal m@(Just x)) <> (MaxInternal n@(Just y)) - = if x >= y then MaxInternal m else MaxInternal n - - instance Ord a => Monoid (MaxInternal a) where - mempty = MaxInternal Nothing - - instance Ord a => Semigroup (MinInternal a) where - m <> MinInternal Nothing = m - MinInternal Nothing <> n = n - (MinInternal m@(Just x)) <> (MinInternal n@(Just y)) - = if x <= y then MinInternal m else MinInternal n - - instance Ord a => Monoid (MinInternal a) where - mempty = MinInternal Nothing - |]) - -$(singletonsOnly [d| - -- -| Data structures that can be folded. - -- - -- For example, given a data type - -- - -- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a) - -- - -- a suitable instance would be - -- - -- > instance Foldable Tree where - -- > foldMap f Empty = mempty - -- > foldMap f (Leaf x) = f x - -- > foldMap f (Node l k r) = foldMap f l `mappend` f k `mappend` foldMap f r - -- - -- This is suitable even for abstract types, as the monoid is assumed - -- to satisfy the monoid laws. Alternatively, one could define @foldr@: - -- - -- > instance Foldable Tree where - -- > foldr f z Empty = z - -- > foldr f z (Leaf x) = f x z - -- > foldr f z (Node l k r) = foldr f (f k (foldr f z r)) l - -- - -- @Foldable@ instances are expected to satisfy the following laws: - -- - -- > foldr f z t = appEndo (foldMap (Endo . f) t ) z - -- - -- > foldl f z t = appEndo (getDual (foldMap (Dual . Endo . flip f) t)) z - -- - -- > fold = foldMap id - -- - -- > length = getSum . foldMap (Sum . const 1) - -- - -- @sum@, @product@, @maximum@, and @minimum@ should all be essentially - -- equivalent to @foldMap@ forms, such as - -- - -- > sum = getSum . foldMap Sum - -- - -- but may be less defined. - -- - -- If the type is also a 'Functor' instance, it should satisfy - -- - -- > foldMap f = fold . fmap f - -- - -- which implies that - -- - -- > foldMap f . fmap g = foldMap (f . g) - - class Foldable (t :: Type -> Type) where - -- {-# MINIMAL foldMap | foldr #-} - - -- -| Combine the elements of a structure using a monoid. - fold :: Monoid m => t m -> m - fold = foldMap id - - -- -| Map each element of the structure to a monoid, - -- and combine the results. - foldMap :: Monoid m => (a -> m) -> t a -> m - foldMap f = foldr (mappend . f) mempty - - -- -| Right-associative fold of a structure. - -- - -- In the case of lists, 'foldr', when applied to a binary operator, a - -- starting value (typically the right-identity of the operator), and a - -- list, reduces the list using the binary operator, from right to left: - -- - -- > foldr f z [x1, x2, ..., xn] == x1 `f` (x2 `f` ... (xn `f` z)...) - -- - -- Note that, since the head of the resulting expression is produced by - -- an application of the operator to the first element of the list, - -- 'foldr' can produce a terminating expression from an infinite list. - -- - -- For a general 'Foldable' structure this should be semantically identical - -- to, - -- - -- @foldr f z = 'List.foldr' f z . 'toList'@ - -- - foldr :: (a -> b -> b) -> b -> t a -> b - foldr f z t = case foldMap (Endo . f) t of - Endo g -> g z - - -- -| Right-associative fold of a structure, but with strict application of - -- the operator. - -- - foldr' :: (a -> b -> b) -> b -> t a -> b - foldr' f z0 xs = foldl f' id xs z0 - where f' k x z = k $! f x z - - -- -| Left-associative fold of a structure. - -- - -- In the case of lists, 'foldl', when applied to a binary - -- operator, a starting value (typically the left-identity of the operator), - -- and a list, reduces the list using the binary operator, from left to - -- right: - -- - -- > foldl f z [x1, x2, ..., xn] == (...((z `f` x1) `f` x2) `f`...) `f` xn - -- - -- Note that to produce the outermost application of the operator the - -- entire input list must be traversed. This means that 'foldl'' will - -- diverge if given an infinite list. - -- - -- Also note that if you want an efficient left-fold, you probably want to - -- use 'foldl'' instead of 'foldl'. The reason for this is that latter does - -- not force the "inner" results (e.g. @z `f` x1@ in the above example) - -- before applying them to the operator (e.g. to @(`f` x2)@). This results - -- in a thunk chain @O(n)@ elements long, which then must be evaluated from - -- the outside-in. - -- - -- For a general 'Foldable' structure this should be semantically identical - -- to, - -- - -- @foldl f z = 'List.foldl' f z . 'toList'@ - -- - foldl :: (b -> a -> b) -> b -> t a -> b - foldl f z t = case foldMap (Dual . Endo . flip f) t of - Dual (Endo g) -> g z - -- There's no point mucking around with coercions here, - -- because flip forces us to build a new function anyway. - - -- -| Left-associative fold of a structure but with strict application of - -- the operator. - -- - -- This ensures that each step of the fold is forced to weak head normal - -- form before being applied, avoiding the collection of thunks that would - -- otherwise occur. This is often what you want to strictly reduce a finite - -- list to a single, monolithic result (e.g. 'length'). - -- - -- For a general 'Foldable' structure this should be semantically identical - -- to, - -- - -- @foldl f z = 'List.foldl'' f z . 'toList'@ - -- - foldl' :: (b -> a -> b) -> b -> t a -> b - foldl' f z0 xs = foldr f' id xs z0 - where f' x k z = k $! f z x - - -- -| A variant of 'foldr' that has no base case, - -- and thus may only be applied to non-empty structures. - -- - -- @'foldr1' f = 'List.foldr1' f . 'toList'@ - foldr1 :: (a -> a -> a) -> t a -> a - foldr1 f xs = fromMaybe (errorWithoutStackTrace "foldr1: empty structure") - (foldr mf Nothing xs) - where - mf x m = Just (case m of - Nothing -> x - Just y -> f x y) - - -- -| A variant of 'foldl' that has no base case, - -- and thus may only be applied to non-empty structures. - -- - -- @'foldl1' f = 'List.foldl1' f . 'toList'@ - foldl1 :: (a -> a -> a) -> t a -> a - foldl1 f xs = fromMaybe (errorWithoutStackTrace "foldl1: empty structure") - (foldl mf Nothing xs) - where - mf m y = Just (case m of - Nothing -> y - Just x -> f x y) - - -- -| List of elements of a structure, from left to right. - toList :: t a -> [a] - toList = foldr (:) [] - - -- -| Test whether the structure is empty. The default implementation is - -- optimized for structures that are similar to cons-lists, because there - -- is no general way to do better. - null :: t a -> Bool - null = foldr (\_ _ -> False) True - - -- -| Returns the size/length of a finite structure as an 'Int'. The - -- default implementation is optimized for structures that are similar to - -- cons-lists, because there is no general way to do better. - length :: t a -> Nat - length = foldl' (\c _ -> c+1) 0 - - -- -| Does the element occur in the structure? - elem :: Eq a => a -> t a -> Bool - elem = any . (==) - - -- -| The largest element of a non-empty structure. - maximum :: forall a . Ord a => t a -> a - maximum x = - case foldMap (MaxInternal . Just) x of - MaxInternal y -> fromMaybe (errorWithoutStackTrace "maximum: empty structure") y - - -- -| The least element of a non-empty structure. - minimum :: forall a . Ord a => t a -> a - minimum x = - case foldMap (MinInternal . Just) x of - MinInternal y -> fromMaybe (errorWithoutStackTrace "minimum: empty structure") y - - -- -| The 'sum' function computes the sum of the numbers of a structure. - sum :: Num a => t a -> a - sum x = case foldMap sum_ x of - Monoid.Sum y -> y - - -- -| The 'product' function computes the product of the numbers of a - -- structure. - product :: Num a => t a -> a - product x = case foldMap product_ x of - Monoid.Product y -> y - - -- instances for Prelude types - - instance Foldable Maybe where - foldMap = maybe_ mempty - - foldr _ z Nothing = z - foldr f z (Just x) = f x z - - foldl _ z Nothing = z - foldl f z (Just x) = f z x - - instance Foldable [] where - elem = listelem - foldl = listfoldl - foldl' = listfoldl' - foldl1 = listfoldl1 - foldr = listfoldr - foldr1 = listfoldr1 - length = listlength - maximum = listmaximum - minimum = listminimum - null = listnull - product = listproduct - sum = listsum - toList = id - - instance Foldable NonEmpty where - foldr f z (a :| as) = f a (listfoldr f z as) - foldl f z (a :| as) = listfoldl f (f z a) as - foldl1 f (a :| as) = listfoldl f a as - - -- GHC isn't clever enough to transform the default definition - -- into anything like this, so we'd end up shuffling a bunch of - -- Maybes around. - foldr1 f (p :| ps) = foldr go id ps p - where - go x r prev = f prev (r x) - - -- We used to say - -- - -- length (_ :| as) = 1 + length as - -- - -- but the default definition is better, counting from 1. - -- - -- The default definition also works great for null and foldl'. - -- As usual for cons lists, foldr' is basically hopeless. - - foldMap f (a :| as) = f a `mappend` foldMap f as - fold (m :| ms) = m `mappend` fold ms - toList (a :| as) = a : as - - instance Foldable (Either a) where - foldMap _ (Left _) = mempty - foldMap f (Right y) = f y - - foldr _ z (Left _) = z - foldr f z (Right y) = f y z - - length (Left _) = 0 - length (Right _) = 1 - - null = isLeft - - instance Foldable Dual where - foldMap f (Dual x) = f x - - elem x (Dual y) = x == y - foldl f z (Dual x) = f z x - foldl' f z (Dual x) = f z x - foldl1 _ (Dual x) = x - foldr f z (Dual x) = f x z - foldr' = foldr - foldr1 _ (Dual x) = x - length _ = 1 - maximum (Dual x) = x - minimum (Dual x) = x - null _ = False - product (Dual x) = x - sum (Dual x) = x - toList (Dual x) = [x] - - instance Foldable Monoid.Sum where - foldMap f (Monoid.Sum x) = f x - - elem x (Monoid.Sum y) = x == y - foldl f z (Monoid.Sum x) = f z x - foldl' f z (Monoid.Sum x) = f z x - foldl1 _ (Monoid.Sum x) = x - foldr f z (Monoid.Sum x) = f x z - foldr' = foldr - foldr1 _ (Monoid.Sum x) = x - length _ = 1 - maximum (Monoid.Sum x) = x - minimum (Monoid.Sum x) = x - null _ = False - product (Monoid.Sum x) = x - sum (Monoid.Sum x) = x - toList (Monoid.Sum x) = [x] - - instance Foldable Monoid.Product where - foldMap f (Monoid.Product x) = f x - - elem x (Monoid.Product y) = x == y - foldl f z (Monoid.Product x) = f z x - foldl' f z (Monoid.Product x) = f z x - foldl1 _ (Monoid.Product x) = x - foldr f z (Monoid.Product x) = f x z - foldr' = foldr - foldr1 _ (Monoid.Product x) = x - length _ = 1 - maximum (Monoid.Product x) = x - minimum (Monoid.Product x) = x - null _ = False - product (Monoid.Product x) = x - sum (Monoid.Product x) = x - toList (Monoid.Product x) = [x] - - -- -| Monadic fold over the elements of a structure, - -- associating to the right, i.e. from right to left. - foldrM :: (Foldable t, Monad m) => (a -> b -> m b) -> b -> t a -> m b - foldrM f z0 xs = foldl f' return xs z0 - where f' k x z = f x z >>= k - - -- -| Monadic fold over the elements of a structure, - -- associating to the left, i.e. from left to right. - foldlM :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b - foldlM f z0 xs = foldr f' return xs z0 - where f' x k z = f z x >>= k - - -- -| Map each element of a structure to an action, evaluate these - -- actions from left to right, and ignore the results. For a version - -- that doesn't ignore the results see 'Data.Traversable.traverse'. - traverse_ :: (Foldable t, Applicative f) => (a -> f b) -> t a -> f () - traverse_ f = foldr ((*>) . f) (pure ()) - - -- -| 'for_' is 'traverse_' with its arguments flipped. For a version - -- that doesn't ignore the results see 'Data.Traversable.for'. - -- - -- >>> for_ [1..4] print - -- 1 - -- 2 - -- 3 - -- 4 - for_ :: (Foldable t, Applicative f) => t a -> (a -> f b) -> f () - for_ = flip traverse_ - - -- -| Map each element of a structure to a monadic action, evaluate - -- these actions from left to right, and ignore the results. For a - -- version that doesn't ignore the results see - -- 'Data.Traversable.mapM'. - -- - -- As of base 4.8.0.0, 'mapM_' is just 'traverse_', specialized to - -- 'Monad'. - mapM_ :: (Foldable t, Monad m) => (a -> m b) -> t a -> m () - mapM_ f= foldr ((>>) . f) (return ()) - - -- -| 'forM_' is 'mapM_' with its arguments flipped. For a version that - -- doesn't ignore the results see 'Data.Traversable.forM'. - -- - -- As of base 4.8.0.0, 'forM_' is just 'for_', specialized to 'Monad'. - forM_ :: (Foldable t, Monad m) => t a -> (a -> m b) -> m () - forM_ = flip mapM_ - - -- -| Evaluate each action in the structure from left to right, and - -- ignore the results. For a version that doesn't ignore the results - -- see 'Data.Traversable.sequenceA'. - sequenceA_ :: (Foldable t, Applicative f) => t (f a) -> f () - sequenceA_ = foldr (*>) (pure ()) - - -- -| Evaluate each monadic action in the structure from left to right, - -- and ignore the results. For a version that doesn't ignore the - -- results see 'Data.Traversable.sequence'. - -- - -- As of base 4.8.0.0, 'sequence_' is just 'sequenceA_', specialized - -- to 'Monad'. - sequence_ :: (Foldable t, Monad m) => t (m a) -> m () - sequence_ = foldr (>>) (return ()) - - -- -| The sum of a collection of actions, generalizing 'concat'. - -- - -- asum [Just "Hello", Nothing, Just "World"] - -- Just "Hello" - asum :: (Foldable t, Alternative f) => t (f a) -> f a - asum = foldr (<|>) empty - - -- -| The sum of a collection of actions, generalizing 'concat'. - -- As of base 4.8.0.0, 'msum' is just 'asum', specialized to 'MonadPlus'. - msum :: (Foldable t, MonadPlus m) => t (m a) -> m a - msum = asum - - -- -| The concatenation of all the elements of a container of lists. - concat :: Foldable t => t [a] -> [a] - concat xs = foldr (\x y -> foldr (:) y x) [] xs - - -- -| Map a function over all the elements of a container and concatenate - -- the resulting lists. - concatMap :: Foldable t => (a -> [b]) -> t a -> [b] - concatMap f xs = foldr (\x b -> foldr (:) b (f x)) [] xs - - -- These use foldr rather than foldMap to avoid repeated concatenation. - - -- -| 'and' returns the conjunction of a container of Bools. For the - -- result to be 'True', the container must be finite; 'False', however, - -- results from a 'False' value finitely far from the left end. - and :: Foldable t => t Bool -> Bool - and x = case foldMap all_ x of - Monoid.All y -> y - - -- -| 'or' returns the disjunction of a container of Bools. For the - -- result to be 'False', the container must be finite; 'True', however, - -- results from a 'True' value finitely far from the left end. - or :: Foldable t => t Bool -> Bool - or x = case foldMap any_ x of - Monoid.Any y -> y - - -- -| Determines whether any element of the structure satisfies the predicate. - any :: Foldable t => (a -> Bool) -> t a -> Bool - any p x = case foldMap (any_ . p) x of - Monoid.Any y -> y - - -- -| Determines whether all elements of the structure satisfy the predicate. - all :: Foldable t => (a -> Bool) -> t a -> Bool - all p x = case foldMap (all_ . p) x of - Monoid.All y -> y - - -- -| The largest element of a non-empty structure with respect to the - -- given comparison function. - - -- See Note [maximumBy/minimumBy space usage] - maximumBy :: Foldable t => (a -> a -> Ordering) -> t a -> a - maximumBy cmp = foldl1 max' - where max' x y = case cmp x y of - GT -> x - LT -> y - EQ -> y - - -- -| The least element of a non-empty structure with respect to the - -- given comparison function. - - -- See Note [maximumBy/minimumBy space usage] - minimumBy :: Foldable t => (a -> a -> Ordering) -> t a -> a - minimumBy cmp = foldl1 min' - where min' x y = case cmp x y of - GT -> y - LT -> x - EQ -> x - - -- -| 'notElem' is the negation of 'elem'. - notElem :: (Foldable t, Eq a) => a -> t a -> Bool - notElem x = not . elem x - - -- -| The 'find' function takes a predicate and a structure and returns - -- the leftmost element of the structure matching the predicate, or - -- 'Nothing' if there is no such element. - find :: Foldable t => (a -> Bool) -> t a -> Maybe a - find p y = case foldMap (\ x -> First (if p x then Just x else Nothing)) y of - First z -> z - |]) - -$(singletonsOnly [d| - -- instances for Prelude types (part 2) - - deriving instance Foldable ((,) a) - deriving instance Foldable First - deriving instance Foldable Last - |]) diff --git a/src/Data/Singletons/Prelude/Function.hs b/src/Data/Singletons/Prelude/Function.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/Function.hs +++ /dev/null @@ -1,119 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Function --- Copyright : (C) 2016 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Defines singleton versions of the definitions in @Data.Function@. --- --- 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.Function@. Also, please excuse --- the apparent repeated variable names. This is due to an interaction --- between Template Haskell and Haddock. --- ----------------------------------------------------------------------------- - -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TypeFamilies, - TypeOperators, UndecidableInstances, GADTs, - DataKinds, PolyKinds, TypeApplications #-} - -module Data.Singletons.Prelude.Function ( - -- * "Prelude" re-exports - Id, sId, Const, sConst, type (.), (%.), Flip, sFlip, type ($), (%$) - -- * Other combinators - , type (&), (%&), On, sOn - - -- * Defunctionalization symbols - , IdSym0, IdSym1 - , ConstSym0, ConstSym1, ConstSym2 - , type (.@#@$), type (.@#@$$), type (.@#@$$$), type (.@#@$$$$) - , FlipSym0, FlipSym1, FlipSym2, FlipSym3 - , type ($@#@$), type ($@#@$$), type ($@#@$$$) - , type (&@#@$), type (&@#@$$), type (&@#@$$$) - , OnSym0, OnSym1, OnSym2, OnSym3, OnSym4 - ) where - -import Data.Singletons.Prelude.Base -import Data.Singletons.Single - -$(singletonsOnly [d| - {- GHC falls into a loop here. Not really a surprise. - - -- | @'fix' f@ is the least fixed point of the function @f@, - -- i.e. the least defined @x@ such that @f x = x@. - fix :: (a -> a) -> a - fix f = let x = f x in x - -} - - -- -| @(*) \`on\` f = \\x y -> f x * f y@. - -- - -- Typical usage: @'Data.List.sortBy' ('compare' \`on\` 'fst')@. - -- - -- Algebraic properties: - -- - -- -* @(*) \`on\` 'id' = (*)@ (if @(*) ∉ {⊥, 'const' ⊥}@) - -- - -- -* @((*) \`on\` f) \`on\` g = (*) \`on\` (f . g)@ - -- - -- -* @'flip' on f . 'flip' on g = 'flip' on (g . f)@ - - -- Proofs (so that I don't have to edit the test-suite): - - -- (*) `on` id - -- = - -- \x y -> id x * id y - -- = - -- \x y -> x * y - -- = { If (*) /= _|_ or const _|_. } - -- (*) - - -- (*) `on` f `on` g - -- = - -- ((*) `on` f) `on` g - -- = - -- \x y -> ((*) `on` f) (g x) (g y) - -- = - -- \x y -> (\x y -> f x * f y) (g x) (g y) - -- = - -- \x y -> f (g x) * f (g y) - -- = - -- \x y -> (f . g) x * (f . g) y - -- = - -- (*) `on` (f . g) - -- = - -- (*) `on` f . g - - -- flip on f . flip on g - -- = - -- (\h (*) -> (*) `on` h) f . (\h (*) -> (*) `on` h) g - -- = - -- (\(*) -> (*) `on` f) . (\(*) -> (*) `on` g) - -- = - -- \(*) -> (*) `on` g `on` f - -- = { See above. } - -- \(*) -> (*) `on` g . f - -- = - -- (\h (*) -> (*) `on` h) (g . f) - -- = - -- flip on (g . f) - - on :: (b -> b -> c) -> (a -> b) -> a -> a -> c - (.*.) `on` f = \x y -> f x .*. f y - infixl 0 `on` - - -- -| '&' is a reverse application operator. This provides notational - -- convenience. Its precedence is one higher than that of the forward - -- application operator '$', which allows '&' to be nested in '$'. - -- - -- @since 4.8.0.0 - (&) :: a -> (a -> b) -> b - x & f = f x - infixl 1 & - |]) - --- Workaround for #326 -infixl 1 & diff --git a/src/Data/Singletons/Prelude/Functor.hs b/src/Data/Singletons/Prelude/Functor.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/Functor.hs +++ /dev/null @@ -1,207 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Functor --- Copyright : (C) 2018 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Defines the promoted and singled versions of the 'Functor' type class. --- ----------------------------------------------------------------------------- - -module Data.Singletons.Prelude.Functor ( - PFunctor(..), SFunctor(..), - type ($>), (%$>), - type (<$>), (%<$>), - type (<&>), (%<&>), - Void, sVoid, - - -- * Defunctionalization symbols - FmapSym0, FmapSym1, FmapSym2, - type (<$@#@$), type (<$@#@$$), type (<$@#@$$$), - type ($>@#@$), type ($>@#@$$), type ($>@#@$$$), - type (<$>@#@$), type (<$>@#@$$), type (<$>@#@$$$), - type (<&>@#@$), type (<&>@#@$$), type (<&>@#@$$$), - VoidSym0, VoidSym1 - ) where - -import Data.Ord (Down(..)) -import Data.Singletons.Prelude.Base -import Data.Singletons.Prelude.Instances -import Data.Singletons.Prelude.Monad.Internal -import Data.Singletons.Prelude.Ord -import Data.Singletons.Single - -$(singletonsOnly [d| - infixl 4 <$> - - -- -| An infix synonym for 'fmap'. - -- - -- The name of this operator is an allusion to '$'. - -- Note the similarities between their types: - -- - -- > ($) :: (a -> b) -> a -> b - -- > (<$>) :: Functor f => (a -> b) -> f a -> f b - -- - -- Whereas '$' is function application, '<$>' is function - -- application lifted over a 'Functor'. - -- - -- ==== __Examples__ - -- - -- Convert from a @'Maybe' 'Int'@ to a @'Maybe' 'String'@ using 'show': - -- - -- >>> show <$> Nothing - -- Nothing - -- >>> show <$> Just 3 - -- Just "3" - -- - -- Convert from an @'Either' 'Int' 'Int'@ to an @'Either' 'Int'@ - -- 'String' using 'show': - -- - -- >>> show <$> Left 17 - -- Left 17 - -- >>> show <$> Right 17 - -- Right "17" - -- - -- Double each element of a list: - -- - -- >>> (*2) <$> [1,2,3] - -- [2,4,6] - -- - -- Apply 'even' to the second element of a pair: - -- - -- >>> even <$> (2,2) - -- (2,True) - -- - (<$>) :: Functor f => (a -> b) -> f a -> f b - (<$>) = fmap - - infixl 4 $> - - -- -| Flipped version of '<$>'. - -- - -- @ - -- ('<&>') = 'flip' 'fmap' - -- @ - -- - -- @since 4.11.0.0 - -- - -- ==== __Examples__ - -- Apply @(+1)@ to a list, a 'Data.Maybe.Just' and a 'Data.Either.Right': - -- - -- >>> Just 2 <&> (+1) - -- Just 3 - -- - -- >>> [1,2,3] <&> (+1) - -- [2,3,4] - -- - -- >>> Right 3 <&> (+1) - -- Right 4 - -- - (<&>) :: Functor f => f a -> (a -> b) -> f b - as <&> f = f <$> as - - infixl 1 <&> - - -- -| Flipped version of '<$'. - -- - -- @since 4.7.0.0 - -- - -- ==== __Examples__ - -- - -- Replace the contents of a @'Maybe' 'Int'@ with a constant 'String': - -- - -- >>> Nothing $> "foo" - -- Nothing - -- >>> Just 90210 $> "foo" - -- Just "foo" - -- - -- Replace the contents of an @'Either' 'Int' 'Int'@ with a constant - -- 'String', resulting in an @'Either' 'Int' 'String'@: - -- - -- >>> Left 8675309 $> "foo" - -- Left 8675309 - -- >>> Right 8675309 $> "foo" - -- Right "foo" - -- - -- Replace each element of a list with a constant 'String': - -- - -- >>> [1,2,3] $> "foo" - -- ["foo","foo","foo"] - -- - -- Replace the second element of a pair with a constant 'String': - -- - -- >>> (1,2) $> "foo" - -- (1,"foo") - -- - ($>) :: Functor f => f a -> b -> f b - ($>) = flip (<$) - - -- -| @'void' value@ discards or ignores the result of evaluation, such - -- as the return value of an 'System.IO.IO' action. - -- - -- ==== __Examples__ - -- - -- Replace the contents of a @'Maybe' 'Int'@ with unit: - -- - -- >>> void Nothing - -- Nothing - -- >>> void (Just 3) - -- Just () - -- - -- Replace the contents of an @'Either' 'Int' 'Int'@ with unit, - -- resulting in an @'Either' 'Int' '()'@: - -- - -- >>> void (Left 8675309) - -- Left 8675309 - -- >>> void (Right 8675309) - -- Right () - -- - -- Replace every element of a list with unit: - -- - -- >>> void [1,2,3] - -- [(),(),()] - -- - -- Replace the second element of a pair with unit: - -- - -- >>> void (1,2) - -- (1,()) - -- - -- Discard the result of an 'System.IO.IO' action: - -- - -- >>> mapM print [1,2] - -- 1 - -- 2 - -- [(),()] - -- >>> void $ mapM print [1,2] - -- 1 - -- 2 - -- - void :: Functor f => f a -> f () - void x = () <$ x - - deriving instance Functor ((,) a) - deriving instance Functor Down - |]) - --- Workaround for #326 -infixl 4 <$> -infixl 4 $> -infixl 1 <&> diff --git a/src/Data/Singletons/Prelude/Identity.hs b/src/Data/Singletons/Prelude/Identity.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/Identity.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Identity --- Copyright : (C) 2018 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) --- Stability : experimental --- Portability : non-portable --- --- Exports the promoted and singled versions of the 'Identity' data type. --- ------------------------------------------------------------------------------ - -module Data.Singletons.Prelude.Identity ( - -- * The 'Identity' singleton - Sing, SIdentity(..), RunIdentity, - - -- * Defunctionalization symbols - IdentitySym0, IdentitySym1, - RunIdentitySym0, RunIdentitySym1 - ) where - -import Control.Applicative -import Data.Foldable (Foldable(..)) -import Data.Functor.Identity -import Data.Singletons.Prelude.Base hiding (Foldr, FoldrSym0, sFoldr) -import Data.Singletons.Prelude.Enum -import Data.Singletons.Prelude.Eq -import Data.Singletons.Prelude.Foldable -import Data.Singletons.Prelude.Instances hiding (Foldl, sFoldl) -import Data.Singletons.Prelude.Monad.Internal -import Data.Singletons.Prelude.Monoid -import Data.Singletons.Prelude.Num -import Data.Singletons.Prelude.Ord -import Data.Singletons.Prelude.Semigroup.Internal -import Data.Singletons.Prelude.Show -import Data.Singletons.Single - -$(singletonsOnly [d| - -- deriving instance Enum a => Enum (Identity a) - instance Enum a => Enum (Identity a) where - succ (Identity x) = Identity (succ x) - pred (Identity x) = Identity (pred x) - toEnum i = Identity (toEnum i) - fromEnum (Identity x) = fromEnum x - enumFromTo (Identity x) (Identity y) = map Identity (enumFromTo x y) - enumFromThenTo (Identity x) (Identity y) (Identity z) = - map Identity (enumFromThenTo x y z) - - -- deriving instance Monoid a => Monoid (Identity a) - instance Monoid a => Monoid (Identity a) where - mempty = Identity mempty - - -- deriving instance Num a => Num (Identity a) - instance Num a => Num (Identity a) where - Identity x + Identity y = Identity (x + y) - Identity x - Identity y = Identity (x - y) - Identity x * Identity y = Identity (x * y) - negate (Identity x) = Identity (negate x) - abs (Identity x) = Identity (abs x) - signum (Identity x) = Identity (signum x) - fromInteger n = Identity (fromInteger n) - - -- deriving instance Semigroup a => Semigroup (Identity a) - instance Semigroup a => Semigroup (Identity a) where - Identity x <> Identity y = Identity (x <> y) - - -- -| This instance would be equivalent to the derived instances of the - -- 'Identity' newtype if the 'runIdentity' field were removed - instance Show a => Show (Identity a) where - showsPrec d (Identity x) = showParen (d > 10) $ - showString "Identity " . showsPrec 11 x - - deriving instance Functor Identity - - instance Foldable Identity where - foldMap f (Identity x) = f x - - elem x (Identity y) = x == y - foldl f z (Identity x) = f z x - foldl' f z (Identity x) = f z x - foldl1 _ (Identity x) = x - foldr f z (Identity x) = f x z - foldr' = foldr - foldr1 _ (Identity x) = x - length _ = 1 - maximum (Identity x) = x - minimum (Identity x) = x - null _ = False - product (Identity x) = x - sum (Identity x) = x - toList (Identity x) = [x] - - instance Applicative Identity where - pure = Identity - Identity f <*> Identity x = Identity (f x) - liftA2 f (Identity x) (Identity y) = Identity (f x y) - - instance Monad Identity where - Identity m >>= k = k m - |]) diff --git a/src/Data/Singletons/Prelude/Instances.hs b/src/Data/Singletons/Prelude/Instances.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/Instances.hs +++ /dev/null @@ -1,39 +0,0 @@ -{- Data/Singletons/Instances.hs - -(c) Richard Eisenberg 2013 -rae@cs.brynmawr.edu - -This (internal) module contains the main class definitions for singletons, -re-exported from various places. - --} - -{-# LANGUAGE DataKinds, PolyKinds, RankNTypes, GADTs, TypeFamilies, EmptyCase, - FlexibleContexts, TemplateHaskell, ScopedTypeVariables, - UndecidableInstances, TypeOperators, FlexibleInstances, - TypeApplications #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -module Data.Singletons.Prelude.Instances ( - module Data.Singletons.Prelude.Instances - , Sing - ) where - -import Data.Singletons.Internal -import Data.Singletons.Single -import Data.Singletons.Util - --- some useful singletons -$(genSingletons basicTypes) -$(singDecideInstances basicTypes) - --- basic definitions we need right away - -$(singletonsOnly [d| - 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) = lgo (f z x) xs - |]) diff --git a/src/Data/Singletons/Prelude/IsString.hs b/src/Data/Singletons/Prelude/IsString.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/IsString.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.IsString --- Copyright : (C) 2017 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Defines and exports a promoted and singled version of the 'IsString' --- type class from "Data.String". ----------------------------------------------------------------------------- - -module Data.Singletons.Prelude.IsString ( - PIsString(..), SIsString(..), - - -- ** Defunctionalization symbols - FromStringSym0, FromStringSym1 - ) where - -import Data.Functor.Const -import Data.Functor.Identity -import Data.Singletons.Prelude.Const -import Data.Singletons.Prelude.Identity -import Data.Singletons.Single -import Data.Singletons.TypeLits () -- for the IsString instance! -import GHC.TypeLits (Symbol) - -$(singletonsOnly [d| - -- -| Class for string-like datastructures; used by the overloaded string - -- extension (-XOverloadedStrings in GHC). - class IsString a where - fromString :: Symbol -> a - - -- deriving instance IsString a => IsString (Const a (b :: k)) - instance IsString a => IsString (Const a (b :: k)) where - fromString x = Const (fromString x) - - -- deriving instance IsString a => IsString (Identity a) - instance IsString a => IsString (Identity a) where - fromString x = Identity (fromString x) - |]) - --- PIsString instance -instance PIsString Symbol where - type FromString a = a - --- SIsString instance -instance SIsString Symbol where - sFromString x = x diff --git a/src/Data/Singletons/Prelude/List.hs b/src/Data/Singletons/Prelude/List.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/List.hs +++ /dev/null @@ -1,288 +0,0 @@ -{-# LANGUAGE ExplicitNamespaces #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.List --- Copyright : (C) 2013-2014 Richard Eisenberg, Jan Stolarek --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- 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, SList(..), - - -- * Basic functions - type (++), (%++), Head, sHead, Last, sLast, Tail, sTail, Init, sInit, - Null, sNull, Length, sLength, - - -- * List transformations - Map, sMap, Reverse, sReverse, Intersperse, sIntersperse, - Intercalate, sIntercalate, Transpose, sTranspose, - 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, - Sum, sSum, Product, sProduct, Maximum, sMaximum, - Minimum, sMinimum, - - -- * Building lists - - -- ** Scans - Scanl, sScanl, Scanl1, sScanl1, Scanr, sScanr, Scanr1, sScanr1, - - -- ** Accumulating maps - MapAccumL, sMapAccumL, MapAccumR, sMapAccumR, - - -- ** Cyclical lists - Replicate, sReplicate, - - -- ** Unfolding - Unfoldr, sUnfoldr, - - -- * Sublists - - -- ** Extracting sublists - Take, sTake, Drop, sDrop, SplitAt, sSplitAt, - TakeWhile, sTakeWhile, DropWhile, sDropWhile, DropWhileEnd, sDropWhileEnd, - Span, sSpan, Break, sBreak, - StripPrefix, - Group, sGroup, - Inits, sInits, Tails, sTails, - - -- ** Predicates - IsPrefixOf, sIsPrefixOf, IsSuffixOf, sIsSuffixOf, IsInfixOf, sIsInfixOf, - - -- * Searching lists - - -- ** Searching by equality - Elem, sElem, NotElem, sNotElem, Lookup, sLookup, - - -- ** Searching with a predicate - Find, sFind, Filter, sFilter, Partition, sPartition, - - -- * Indexing lists - type (!!), (%!!), - ElemIndex, sElemIndex, ElemIndices, sElemIndices, - FindIndex, sFindIndex, FindIndices, sFindIndices, - - -- * Zipping and unzipping lists - Zip, sZip, Zip3, sZip3, - Zip4, Zip5, Zip6, Zip7, - ZipWith, sZipWith, ZipWith3, sZipWith3, - ZipWith4, ZipWith5, ZipWith6, ZipWith7, - Unzip, sUnzip, Unzip3, sUnzip3, Unzip4, sUnzip4, - Unzip5, sUnzip5, Unzip6, sUnzip6, Unzip7, sUnzip7, - - -- * Special lists - - -- ** Functions on 'Symbol's - Unlines, sUnlines, - Unwords, sUnwords, - - -- ** \"Set\" operations - Nub, sNub, Delete, sDelete, type (\\), (%\\), - Union, sUnion, Intersect, sIntersect, - - -- ** Ordered lists - Insert, sInsert, Sort, sSort, - - -- * Generalized functions - - -- ** The \"@By@\" operations - - -- *** User-supplied equality (replacing an @Eq@ context) - -- | The predicate is assumed to define an equivalence. - NubBy, sNubBy, - DeleteBy, sDeleteBy, DeleteFirstsBy, sDeleteFirstsBy, - UnionBy, sUnionBy, IntersectBy, sIntersectBy, - GroupBy, sGroupBy, - - -- *** User-supplied comparison (replacing an @Ord@ context) - -- | The function is assumed to define a total ordering. - SortBy, sSortBy, InsertBy, sInsertBy, - MaximumBy, sMaximumBy, MinimumBy, sMinimumBy, - - -- ** The \"@generic@\" operations - -- | The prefix \`@generic@\' indicates an overloaded function that - -- is a generalized version of a "Prelude" function. - GenericLength, sGenericLength, - GenericTake, GenericDrop, - GenericSplitAt, GenericIndex, GenericReplicate, - - -- * Defunctionalization symbols - NilSym0, - (:@#@$), (:@#@$$), (:@#@$$$), - - type (++@#@$$$), type (++@#@$$), type (++@#@$), - HeadSym0, HeadSym1, LastSym0, LastSym1, - TailSym0, TailSym1, InitSym0, InitSym1, NullSym0, NullSym1, - LengthSym0, LengthSym1, - - MapSym0, MapSym1, MapSym2, ReverseSym0, ReverseSym1, - IntersperseSym0, IntersperseSym1, IntersperseSym2, - IntercalateSym0, IntercalateSym1, IntercalateSym2, - TransposeSym0, TransposeSym1, - 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, - AnySym0, AnySym1, AnySym2, - AllSym0, AllSym1, AllSym2, - SumSym0, SumSym1, - ProductSym0, ProductSym1, - MaximumSym0, MaximumSym1, - MinimumSym0, MinimumSym1, - - ScanlSym0, ScanlSym1, ScanlSym2, ScanlSym3, - Scanl1Sym0, Scanl1Sym1, Scanl1Sym2, - ScanrSym0, ScanrSym1, ScanrSym2, ScanrSym3, - Scanr1Sym0, Scanr1Sym1, Scanr1Sym2, - - MapAccumLSym0, MapAccumLSym1, MapAccumLSym2, MapAccumLSym3, - MapAccumRSym0, MapAccumRSym1, MapAccumRSym2, MapAccumRSym3, - - ReplicateSym0, ReplicateSym1, ReplicateSym2, - - UnfoldrSym0, UnfoldrSym1, UnfoldrSym2, - - 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, StripPrefixSym2, - GroupSym0, GroupSym1, - InitsSym0, InitsSym1, TailsSym0, TailsSym1, - - IsPrefixOfSym0, IsPrefixOfSym1, IsPrefixOfSym2, - IsSuffixOfSym0, IsSuffixOfSym1, IsSuffixOfSym2, - IsInfixOfSym0, IsInfixOfSym1, IsInfixOfSym2, - - ElemSym0, ElemSym1, ElemSym2, - NotElemSym0, NotElemSym1, NotElemSym2, - LookupSym0, LookupSym1, LookupSym2, - - FindSym0, FindSym1, FindSym2, - FilterSym0, FilterSym1, FilterSym2, - PartitionSym0, PartitionSym1, PartitionSym2, - - type (!!@#@$), type (!!@#@$$), type (!!@#@$$$), - ElemIndexSym0, ElemIndexSym1, ElemIndexSym2, - ElemIndicesSym0, ElemIndicesSym1, ElemIndicesSym2, - FindIndexSym0, FindIndexSym1, FindIndexSym2, - FindIndicesSym0, FindIndicesSym1, FindIndicesSym2, - - ZipSym0, ZipSym1, ZipSym2, - Zip3Sym0, Zip3Sym1, Zip3Sym2, Zip3Sym3, - 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, - ZipWithSym0, ZipWithSym1, ZipWithSym2, ZipWithSym3, - ZipWith3Sym0, ZipWith3Sym1, ZipWith3Sym2, ZipWith3Sym3, ZipWith3Sym4, - ZipWith4Sym0, ZipWith4Sym1, ZipWith4Sym2, ZipWith4Sym3, ZipWith4Sym4, ZipWith4Sym5, - ZipWith5Sym0, ZipWith5Sym1, ZipWith5Sym2, ZipWith5Sym3, ZipWith5Sym4, ZipWith5Sym5, ZipWith5Sym6, - ZipWith6Sym0, ZipWith6Sym1, ZipWith6Sym2, ZipWith6Sym3, ZipWith6Sym4, ZipWith6Sym5, ZipWith6Sym6, ZipWith6Sym7, - ZipWith7Sym0, ZipWith7Sym1, ZipWith7Sym2, ZipWith7Sym3, ZipWith7Sym4, ZipWith7Sym5, ZipWith7Sym6, ZipWith7Sym7, ZipWith7Sym8, - UnzipSym0, UnzipSym1, - Unzip3Sym0, Unzip3Sym1, - Unzip4Sym0, Unzip4Sym1, - Unzip5Sym0, Unzip5Sym1, - Unzip6Sym0, Unzip6Sym1, - Unzip7Sym0, Unzip7Sym1, - - UnlinesSym0, UnlinesSym1, - UnwordsSym0, UnwordsSym1, - - NubSym0, NubSym1, - DeleteSym0, DeleteSym1, DeleteSym2, - type (\\@#@$), type (\\@#@$$), type (\\@#@$$$), - UnionSym0, UnionSym1, UnionSym2, - IntersectSym0, IntersectSym1, IntersectSym2, - - InsertSym0, InsertSym1, InsertSym2, - SortSym0, SortSym1, - - NubBySym0, NubBySym1, NubBySym2, - DeleteBySym0, DeleteBySym1, DeleteBySym2, DeleteBySym3, - DeleteFirstsBySym0, DeleteFirstsBySym1, DeleteFirstsBySym2, DeleteFirstsBySym3, - UnionBySym0, UnionBySym1, UnionBySym2, UnionBySym3, - IntersectBySym0, IntersectBySym1, IntersectBySym2, IntersectBySym3, - GroupBySym0, GroupBySym1, GroupBySym2, - - SortBySym0, SortBySym1, SortBySym2, - InsertBySym0, InsertBySym1, InsertBySym2, InsertBySym3, - MaximumBySym0, MaximumBySym1, MaximumBySym2, - MinimumBySym0, MinimumBySym1, MinimumBySym2, - - GenericLengthSym0, GenericLengthSym1, - GenericTakeSym0, GenericTakeSym1, GenericTakeSym2, - GenericDropSym0, GenericDropSym1, GenericDropSym2, - GenericSplitAtSym0, GenericSplitAtSym1, GenericSplitAtSym2, - GenericIndexSym0, GenericIndexSym1, GenericIndexSym2, - GenericReplicateSym0, GenericReplicateSym1, GenericReplicateSym2, - ) where - -import Data.Singletons.Prelude.Base - ( Map, MapSym0, MapSym1, MapSym2, sMap - , type (++), type (++@#@$), type (++@#@$$), type (++@#@$$$), (%++) - ) -import Data.Singletons.Prelude.Foldable -import Data.Singletons.Prelude.Instances - (Sing, SList(..), NilSym0, type (:@#@$), type (:@#@$$), type (:@#@$$$)) -import Data.Singletons.Prelude.Traversable - -import Data.Singletons.Prelude.List.Internal - hiding ( All, AllSym0, AllSym1, AllSym2, sAll - , And, AndSym0, AndSym1, sAnd - , Any, AnySym0, AnySym1, AnySym2, sAny - , Concat, ConcatSym0, ConcatSym1, sConcat - , ConcatMap, ConcatMapSym0, ConcatMapSym1, ConcatMapSym2, sConcatMap - , Elem, ElemSym0, ElemSym1, ElemSym2, sElem - , Find, FindSym0, FindSym1, FindSym2, sFind - , Foldl1, Foldl1Sym0, Foldl1Sym1, Foldl1Sym2, sFoldl1 - , Foldl', Foldl'Sym0, Foldl'Sym1, Foldl'Sym2, Foldl'Sym3, sFoldl' - , Foldr1, Foldr1Sym0, Foldr1Sym1, Foldr1Sym2, sFoldr1 - , MapAccumL, MapAccumLSym0, MapAccumLSym1, MapAccumLSym2, MapAccumLSym3, sMapAccumL - , MapAccumR, MapAccumRSym0, MapAccumRSym1, MapAccumRSym2, MapAccumRSym3, sMapAccumR - , Maximum, MaximumSym0, MaximumSym1, sMaximum - , MaximumBy, MaximumBySym0, MaximumBySym1, MaximumBySym2, sMaximumBy - , Minimum, MinimumSym0, MinimumSym1, sMinimum - , MinimumBy, MinimumBySym0, MinimumBySym1, MinimumBySym2, sMinimumBy - , Length, LengthSym0, LengthSym1, sLength - , NotElem, NotElemSym0, NotElemSym1, NotElemSym2, sNotElem - , Null, NullSym0, NullSym1, sNull - , Or, OrSym0, OrSym1, sOr - , Product, ProductSym0, ProductSym1, sProduct - , Sum, SumSym0, SumSym1, sSum - ) diff --git a/src/Data/Singletons/Prelude/List/Internal.hs b/src/Data/Singletons/Prelude/List/Internal.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/List/Internal.hs +++ /dev/null @@ -1,666 +0,0 @@ -{-# LANGUAGE TypeOperators, DataKinds, PolyKinds, TypeFamilies, - TemplateHaskell, GADTs, UndecidableInstances, RankNTypes, - ScopedTypeVariables, FlexibleContexts, - TypeApplications #-} -{-# OPTIONS_GHC -O0 #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.List.Internal --- Copyright : (C) 2013-2014 Richard Eisenberg, Jan Stolarek --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- 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@. --- --- All of the functions defined in this module are specialized for lists, --- unlike "Data.Singletons.Prelude.List", which uses 'Foldable' and --- 'Traversable' contexts when available. --- ----------------------------------------------------------------------------- - -module Data.Singletons.Prelude.List.Internal where - -import Data.Singletons.Prelude.Instances -import Data.Singletons.Promote -import Data.Singletons.Single -import Data.Singletons.TypeLits -import Data.Singletons.Prelude.Base -import Data.Singletons.Prelude.Bool -import Data.Singletons.Prelude.Eq -import Data.Singletons.Prelude.Maybe -import Data.Singletons.Prelude.Monad.Internal -import Data.Singletons.Prelude.Semigroup.Internal (SSemigroup(..), type (<>@#@$)) -import Data.Singletons.Prelude.Tuple -import Data.Singletons.Prelude.Num -import Data.Singletons.Prelude.Ord -import Data.Maybe - -$(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] = x - last (_:x:xs) = last (x:xs) - - 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 :: forall a. [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' :: 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 - - any :: (a -> Bool) -> [a] -> Bool - any _ [] = False - any p (x:xs) = p x || any 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 - infix 4 `elem` - - notElem :: (Eq a) => a -> [a] -> Bool - notElem _ [] = True - notElem x (y:ys) = x /= y && notElem x ys - infix 4 `notElem` - - 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 --- --- words :: String -> [String] --- words s = case dropWhile isSpace s of --- "" -> [] --- s' -> w : words s'' --- where (w, s'') = --- break isSpace s' - - unlines :: [Symbol] -> Symbol - unlines [] = "" - unlines (l:ls) = l <> "\n" <> unlines ls - - unwords :: [Symbol] -> Symbol - unwords [] = "" - unwords (w:ws) = w <> go ws - where - go [] = "" - go (v:vs) = " " <> (v <> go vs) - - delete :: (Eq a) => a -> [a] -> [a] - delete = deleteBy (==) - - (\\) :: (Eq a) => [a] -> [a] -> [a] - (\\) = foldl (flip delete) - infix 5 \\ -- This comment is necessary so CPP doesn't treat the - -- trailing backslash as a line splice. Urgh. - - 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 - - filter :: (a -> Bool) -> [a] -> [a] - filter _p [] = [] - filter p (x:xs) = if p x then x : filter p xs else filter p xs - - find :: (a -> Bool) -> [a] -> Maybe a - find p = listToMaybe . filter p - --- 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 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 xs))) - where buildList :: Nat -> [b] -> [Nat] - buildList _ [] = [] - buildList a (_:rest) = a : buildList (a+1) rest - - intersect :: (Eq a) => [a] -> [a] -> [a] - intersect = intersectBy (==) - - intersectBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] - intersectBy _ [] [] = [] - intersectBy _ [] (_:_) = [] - intersectBy _ (_:_) [] = [] - intersectBy eq xs@(_:_) ys@(_:_) = [x | x <- xs, any (eq x) ys] - - takeWhile :: (a -> Bool) -> [a] -> [a] - takeWhile _ [] = [] - takeWhile p (x:xs) = if p x then x : takeWhile p xs else [] - - dropWhile :: (a -> Bool) -> [a] -> [a] - dropWhile _ [] = [] - dropWhile p xs@(x:xs') = if p x then dropWhile p xs' else 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') = if p x then let (ys,zs) = span p xs' in (x:ys,zs) - else ([], xs) - - break :: (a -> Bool) -> [a] -> ([a],[a]) - break _ xs@[] = (xs, xs) - break p xs@(x:xs') = if p x then ([],xs) - else let (ys,zs) = break p xs' in (x:ys,zs) - --- 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) - - take :: Nat -> [a] -> [a] - take _ [] = [] - take n (x:xs) = if n == 0 then [] else x : take (n-1) xs - - drop :: Nat -> [a] -> [a] - drop _ [] = [] - drop n (x:xs) = if n == 0 then x:xs else drop (n-1) xs - - splitAt :: Nat -> [a] -> ([a],[a]) - splitAt n xs = (take n xs, drop n xs) - - group :: Eq a => [a] -> [[a]] - group xs = groupBy (==) xs - - maximum :: (Ord a) => [a] -> a - maximum [] = error "Data.Singletons.List.maximum: empty list" - maximum xs@(_:_) = foldl1 max xs - - minimum :: (Ord a) => [a] -> a - minimum [] = error "Data.Singletons.List.minimum: empty list" - minimum xs@(_:_) = foldl1 min xs - - insert :: Ord a => a -> [a] -> [a] - insert e ls = insertBy (compare) e ls - - sort :: (Ord a) => [a] -> [a] - sort = sortBy compare - - 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) = if key == x then Just y else lookup key xys - - 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) = if p x then (x:ts,fs) else (ts, x:fs) - --- 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 :: forall a. Num a => [a] -> a - sum l = sum' l 0 - where - sum' :: [a] -> a -> a - sum' [] a = a - sum' (x:xs) a = sum' xs (a+x) - - product :: forall a. Num a => [a] -> a - product l = prod l 1 - where - prod :: [a] -> a -> a - prod [] a = a - prod (x:xs) a = prod xs (a*x) - - --- 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 - --- 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 n x = if n == 0 then [] else x : replicate (n-1) x - --- Uses partial pattern-matching in a list comprehension --- (see https://github.com/goldfirere/singletons/issues/340) --- 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 --- (!!) :: [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 then x else xs !! (n-1) - infixl 9 !! - - nub :: forall a. (Eq a) => [a] -> [a] - nub l = nub' l [] - where - nub' :: [a] -> [a] -> [a] - nub' [] _ = [] - nub' (x:xs) ls = if x `elem` ls then nub' xs ls else x : nub' xs (x:ls) - - nubBy :: (a -> a -> Bool) -> [a] -> [a] - nubBy eq l = nubBy' l [] - where - nubBy' [] _ = [] - nubBy' (y:ys) xs = if elem_by eq y xs then nubBy' ys xs else 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 - - unionBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] - unionBy eq xs ys = xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs - - union :: (Eq a) => [a] -> [a] -> [a] - union = unionBy (==) - - genericLength :: (Num i) => [a] -> i - genericLength [] = 0 - genericLength (_:xs) = 1 + genericLength xs - - |]) - --- Workaround for #326 -infix 5 \\ -- This comment is necessary so CPP doesn't treat the -infixl 9 !! - --- The following functions are supported for promotion only. -$(promoteOnly [d| - - -- 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 - - -- 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 _ _ _ _ _ _ _ _ = [] - --- These functions use Integral or Num typeclass instead of Int. --- --- genericLength, genericTake, genericDrop, genericSplitAt, genericIndex --- genericReplicate --- --- We provide aliases below to improve compatibility - - 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/Singletons/Prelude/List/Internal/Disambiguation.hs b/src/Data/Singletons/Prelude/List/Internal/Disambiguation.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/List/Internal/Disambiguation.hs +++ /dev/null @@ -1,170 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.List.Internal.Disambiguation --- Copyright : (C) 2016 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Renames a bunch of List functions because singletons can't support qualified --- names. :( --- ----------------------------------------------------------------------------- - -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TypeFamilies, - UndecidableInstances, GADTs, DataKinds, PolyKinds, - TypeApplications #-} -{-# OPTIONS_GHC -Wno-missing-signatures #-} - -module Data.Singletons.Prelude.List.Internal.Disambiguation where - -import Data.Singletons.Single -import Data.Singletons.Prelude.Base -import Data.Singletons.Prelude.Instances -import Data.Singletons.Prelude.List.Internal -import Data.Singletons.Prelude.Num -import Data.Singletons.Prelude.Ord -import Data.Singletons.Prelude.Eq -import Data.List -import GHC.TypeLits - --- singletons doesn't support qualified names :( -$(singletons [d| - listlast :: [a] -> a - listlast = last - - listinit :: [a] -> [a] - listinit = init - - listsort :: Ord a => [a] -> [a] - listsort = sort - - listinits :: [a] -> [[a]] - listinits = inits - - listtails :: [a] -> [[a]] - listtails = tails - - listinsert :: Ord a => a -> [a] -> [a] - listinsert = insert - - listscanl :: (b -> a -> b) -> b -> [a] -> [b] - listscanl = scanl - - listscanr :: (a -> b -> b) -> b -> [a] -> [b] - listscanr = scanr - - listscanr1 :: (a -> a -> a) -> [a] -> [a] - listscanr1 = scanr1 - - listintersperse :: a -> [a] -> [a] - listintersperse = intersperse - - listreverse :: [a] -> [a] - listreverse = reverse - - listtakeWhile :: (a -> Bool) -> [a] -> [a] - listtakeWhile = takeWhile - - listdropWhile :: (a -> Bool) -> [a] -> [a] - listdropWhile = dropWhile - - listspan :: (a -> Bool) -> [a] -> ([a], [a]) - listspan = span - - listfilter :: (a -> Bool) -> [a] -> [a] - listfilter = filter - - listpartition :: (a -> Bool) -> [a] -> ([a], [a]) - listpartition = partition - - listsortBy :: (a -> a -> Ordering) -> [a] -> [a] - listsortBy = sortBy - - listisPrefixOf :: Eq a => [a] -> [a] -> Bool - listisPrefixOf = isPrefixOf - - listzip :: [a] -> [b] -> [(a, b)] - listzip = zip - - listzipWith :: (a -> b -> c) -> [a] -> [b] -> [c] - listzipWith = zipWith - - listnubBy :: (a -> a -> Bool) -> [a] -> [a] - listnubBy = nubBy - - listtranspose :: [[a]] -> [[a]] - listtranspose = transpose - - listunzip :: [(a,b)] -> ([a],[b]) - listunzip = unzip - - listmap :: (a -> b) -> [a] -> [b] - listmap = map - - listelem :: Eq a => a -> [a] -> Bool - listelem = elem - - listfoldl :: (b -> a -> b) -> b -> [a] -> b - listfoldl = foldl - - listfoldl' :: (b -> a -> b) -> b -> [a] -> b - listfoldl' = foldl' - - listfoldl1 :: (a -> a -> a) -> [a] -> a - listfoldl1 = foldl1 - - listfoldr :: (a -> b -> b) -> b -> [a] -> b - listfoldr = foldr - - listfoldr1 :: (a -> a -> a) -> [a] -> a - listfoldr1 = foldr1 - - listmaximum :: Ord a => [a] -> a - listmaximum = maximum - - listminimum :: Ord a => [a] -> a - listminimum = minimum - - listnull :: [a] -> Bool - listnull = null - - listproduct :: Num a => [a] -> a - listproduct = product - - listsum :: Num a => [a] -> a - listsum = sum - |]) - -$(singletonsOnly [d| - listtake :: Nat -> [a] -> [a] - listtake = take - - listdrop :: Nat -> [a] -> [a] - listdrop = drop - - listsplitAt :: Nat -> [a] -> ([a], [a]) - listsplitAt = splitAt - - listindex :: [a] -> Nat -> a - listindex = (!!) - - listlength :: [a] -> Nat - listlength = length - |]) - -listtake :: Nat -> [a] -> [a] -listtake = undefined - -listdrop :: Nat -> [a] -> [a] -listdrop = undefined - -listsplitAt :: Nat -> [a] -> ([a], [a]) -listsplitAt = undefined - -listindex :: [a] -> Nat -> a -listindex = undefined - -listlength :: [a] -> Nat -listlength = undefined diff --git a/src/Data/Singletons/Prelude/List/NonEmpty.hs b/src/Data/Singletons/Prelude/List/NonEmpty.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/List/NonEmpty.hs +++ /dev/null @@ -1,548 +0,0 @@ -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TypeOperators, - TypeFamilies, GADTs, UndecidableInstances, InstanceSigs, - DataKinds, PolyKinds, TypeApplications #-} -{-# OPTIONS_GHC -Wno-orphans #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.List.NonEmpty --- Copyright : (C) 2016 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Defines functions and datatypes relating to the singleton for 'NonEmpty', --- including a singletons version of all the definitions in @Data.List.NonEmpty@. --- --- 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.NonEmpty@. Also, please excuse --- the apparent repeated variable names. This is due to an interaction --- between Template Haskell and Haddock. --- ----------------------------------------------------------------------------- - -module Data.Singletons.Prelude.List.NonEmpty ( - -- * The 'NonEmpty' singleton - Sing, SNonEmpty(..), - - -- * Non-empty stream transformations - Map, sMap, - Intersperse, sIntersperse, - Scanl, sScanl, - Scanr, sScanr, - Scanl1, sScanl1, - Scanr1, sScanr1, - Transpose, sTranspose, - SortBy, sSortBy, - SortWith, sSortWith, - Length, sLength, - Head, sHead, - Tail, sTail, - Last, sLast, - Init, sInit, - type (<|), (%<|), - Cons, sCons, - Uncons, sUncons, - Unfoldr, sUnfoldr, - Sort, sSort, - Reverse, sReverse, - Inits, sInits, - Tails, sTails, - Unfold, sUnfold, - Insert, sInsert, - Take, sTake, - Drop, sDrop, - SplitAt, sSplitAt, - TakeWhile, sTakeWhile, - DropWhile, sDropWhile, - Span, sSpan, - Break, sBreak, - Filter, sFilter, - Partition, sPartition, - Group, sGroup, - GroupBy, sGroupBy, - GroupWith, sGroupWith, - GroupAllWith, sGroupAllWith, - Group1, sGroup1, - GroupBy1, sGroupBy1, - GroupWith1, sGroupWith1, - GroupAllWith1, sGroupAllWith1, - IsPrefixOf, sIsPrefixOf, - Nub, sNub, - NubBy, sNubBy, - type (!!), (%!!), - Zip, sZip, - ZipWith, sZipWith, - Unzip, sUnzip, - FromList, sFromList, - ToList, sToList, - NonEmpty_, sNonEmpty_, - Xor, sXor, - - -- * Defunctionalization symbols - (:|@#@$), (:|@#@$$), (:|@#@$$$), - MapSym0, MapSym1, MapSym2, - IntersperseSym0, IntersperseSym1, IntersperseSym2, - ScanlSym0, ScanlSym1, ScanlSym2, ScanlSym3, - ScanrSym0, ScanrSym1, ScanrSym2, ScanrSym3, - Scanl1Sym0, Scanl1Sym1, Scanl1Sym2, - Scanr1Sym0, Scanr1Sym1, Scanr1Sym2, - TransposeSym0, TransposeSym1, - SortBySym0, SortBySym1, SortBySym2, - SortWithSym0, SortWithSym1, SortWithSym2, - LengthSym0, LengthSym1, - HeadSym0, HeadSym1, - TailSym0, TailSym1, - LastSym0, LastSym1, - InitSym0, InitSym1, - type (<|@#@$), type (<|@#@$$), type (<|@#@$$$), - ConsSym0, ConsSym1, ConsSym2, - UnconsSym0, UnconsSym1, - UnfoldrSym0, UnfoldrSym1, UnfoldrSym2, - SortSym0, SortSym1, - ReverseSym0, ReverseSym1, - InitsSym0, InitsSym1, - TailsSym0, TailsSym1, - UnfoldSym0, UnfoldSym1, - InsertSym0, InsertSym1, InsertSym2, - TakeSym0, TakeSym1, TakeSym2, - DropSym0, DropSym1, DropSym2, - SplitAtSym0, SplitAtSym1, SplitAtSym2, - TakeWhileSym0, TakeWhileSym1, TakeWhileSym2, - DropWhileSym0, DropWhileSym1, DropWhileSym2, - SpanSym0, SpanSym1, SpanSym2, - BreakSym0, BreakSym1, BreakSym2, - FilterSym0, FilterSym1, FilterSym2, - PartitionSym0, PartitionSym1, PartitionSym2, - GroupSym0, GroupSym1, - GroupBySym0, GroupBySym1, GroupBySym2, - GroupWithSym0, GroupWithSym1, GroupWithSym2, - GroupAllWithSym0, GroupAllWithSym1, GroupAllWithSym2, - Group1Sym0, Group1Sym1, - GroupBy1Sym0, GroupBy1Sym1, GroupBy1Sym2, - GroupWith1Sym0, GroupWith1Sym1, GroupWith1Sym2, - GroupAllWith1Sym0, GroupAllWith1Sym1, GroupAllWith1Sym2, - IsPrefixOfSym0, IsPrefixOfSym1, IsPrefixOfSym2, - NubSym0, NubSym1, - NubBySym0, NubBySym1, NubBySym2, - type (!!@#@$), type (!!@#@$$), type (!!@#@$$$), - ZipSym0, ZipSym1, ZipSym2, - ZipWithSym0, ZipWithSym1, ZipWithSym2, ZipWithSym3, - UnzipSym0, UnzipSym1, - FromListSym0, FromListSym1, - ToListSym0, ToListSym1, - NonEmpty_Sym0, NonEmpty_Sym1, - XorSym0, XorSym1 - ) where - -import Control.Monad.Zip -import Data.List.NonEmpty -import Data.Singletons.Prelude.List.Internal.Disambiguation -import Data.Singletons.Prelude.Instances -import Data.Singletons.Prelude.Base hiding ( MapSym0, MapSym1, MapSym2, Map, sMap ) -import Data.Singletons.Prelude.Maybe -import Data.Singletons.Prelude.Num -import Data.Singletons.Prelude.Bool -import Data.Singletons.Prelude.Eq -import Data.Singletons.Prelude.Monad.Zip -import Data.Singletons.Prelude.Ord -import Data.Singletons.Prelude.Function -import Data.Function -import Data.Ord -import Data.Singletons.TypeLits -import Data.Singletons.Single - -$(singletonsOnly [d| - {- - -- | @since 4.9.0.0 - instance Exts.IsList (NonEmpty a) where - type Item (NonEmpty a) = a - fromList = fromList - toList = toList - - -- | @since 4.9.0.0 - instance MonadFix NonEmpty where - mfix f = case fix (f . head) of - ~(x :| _) -> x :| mfix (tail . f) - -} - - instance MonadZip NonEmpty where - mzip = zip - mzipWith = zipWith - munzip = unzip - - -- needed to implement other functions - fmap :: (a -> b) -> NonEmpty a -> NonEmpty b - fmap f (x :| xs) = f x :| listmap f xs - - -- -| Number of elements in 'NonEmpty' list. - length :: NonEmpty a -> Nat - length (_ :| xs) = 1 + listlength xs - - -- -| Compute n-ary logic exclusive OR operation on 'NonEmpty' list. - xor :: NonEmpty Bool -> Bool - xor (x :| xs) = foldr xor' x xs - where xor' True y = not y - xor' False y = y - - -- -| 'unfold' produces a new stream by repeatedly applying the unfolding - -- function to the seed value to produce an element of type @b@ and a new - -- seed value. When the unfolding function returns 'Nothing' instead of - -- a new seed value, the stream ends. - unfold :: (a -> (b, Maybe a)) -> a -> NonEmpty b - unfold f a = case f a of - (b, Nothing) -> b :| [] - (b, Just c) -> b <| unfold f c - - -- -| 'nonEmpty' efficiently turns a normal list into a 'NonEmpty' stream, - -- producing 'Nothing' if the input is empty. - nonEmpty_ :: [a] -> Maybe (NonEmpty a) - nonEmpty_ [] = Nothing - nonEmpty_ (a:as) = Just (a :| as) - - -- -| 'uncons' produces the first element of the stream, and a stream of the - -- remaining elements, if any. - uncons :: NonEmpty a -> (a, Maybe (NonEmpty a)) - uncons (a :| as) = (a, nonEmpty_ as) - - -- -| The 'unfoldr' function is analogous to "Data.List"'s - -- 'Data.List.unfoldr' operation. - unfoldr :: (a -> (b, Maybe a)) -> a -> NonEmpty b - unfoldr f a = case f a of - (b, mc) -> b :| maybe_ [] go mc - where - go c = case f c of - (d, me) -> d : maybe_ [] go me - - {- - -- | @since 4.9.0.0 - instance Functor NonEmpty where - fmap f ~(a :| as) = f a :| fmap f as - b <$ ~(_ :| as) = b :| (b <$ as) - - -- | @since 4.9.0.0 - instance Applicative NonEmpty where - pure a = a :| [] - (<*>) = ap - - -- | @since 4.9.0.0 - instance Monad NonEmpty where - ~(a :| as) >>= f = b :| (bs ++ bs') - where b :| bs = f a - bs' = as >>= toList . f - - -- | @since 4.9.0.0 - instance Traversable NonEmpty where - traverse f ~(a :| as) = (:|) <$> f a <*> traverse f as - - -- | @since 4.9.0.0 - instance Foldable NonEmpty where - foldr f z ~(a :| as) = f a (foldr f z as) - foldl f z ~(a :| as) = foldl f (f z a) as - foldl1 f ~(a :| as) = foldl f a as - foldMap f ~(a :| as) = f a `mappend` foldMap f as - fold ~(m :| ms) = m `mappend` fold ms - -} - - -- -| Extract the first element of the stream. - head :: NonEmpty a -> a - head (a :| _) = a - - -- -| Extract the possibly-empty tail of the stream. - tail :: NonEmpty a -> [a] - tail (_ :| as) = as - - -- -| Extract the last element of the stream. - last :: NonEmpty a -> a - last (a :| as) = listlast (a : as) - - -- -| Extract everything except the last element of the stream. - init :: NonEmpty a -> [a] - init (a :| as) = listinit (a : as) - - -- -| Prepend an element to the stream. - (<|) :: a -> NonEmpty a -> NonEmpty a - a <| (b :| bs) = a :| b : bs - - -- -| Synonym for '<|'. - cons :: a -> NonEmpty a -> NonEmpty a - cons = (<|) - - -- -| Sort a stream. - sort :: Ord a => NonEmpty a -> NonEmpty a - sort = lift listsort - - -- -| Converts a normal list to a 'NonEmpty' stream. - -- - -- Raises an error if given an empty list. - fromList :: [a] -> NonEmpty a - fromList (a:as) = a :| as - fromList [] = error "NonEmpty.fromList: empty list" - - -- -| Convert a stream to a normal list efficiently. - toList :: NonEmpty a -> [a] - toList (a :| as) = a : as - - -- -| Lift list operations to work on a 'NonEmpty' stream. - -- - -- /Beware/: If the provided function returns an empty list, - -- this will raise an error. - lift :: ([a] -> [b]) -> NonEmpty a -> NonEmpty b - lift f = fromList . f . toList - - -- -| Map a function over a 'NonEmpty' stream. - map :: (a -> b) -> NonEmpty a -> NonEmpty b - map f (a :| as) = f a :| listmap f as - - -- -| The 'inits' function takes a stream @xs@ and returns all the - -- finite prefixes of @xs@. - inits :: [a] -> NonEmpty [a] - inits = fromList . listinits - - -- -| The 'tails' function takes a stream @xs@ and returns all the - -- suffixes of @xs@. - tails :: [a] -> NonEmpty [a] - tails = fromList . listtails - - -- -| @'insert' x xs@ inserts @x@ into the last position in @xs@ where it - -- is still less than or equal to the next element. In particular, if the - -- list is sorted beforehand, the result will also be sorted. - insert :: Ord a => a -> [a] -> NonEmpty a - insert a = fromList . listinsert a - - {- - -- | @'some1' x@ sequences @x@ one or more times. - some1 :: Alternative f => f a -> f (NonEmpty a) - some1 x = (:|) <$> x <*> many x - -} - - -- -| 'scanl' is similar to 'foldl', but returns a stream of successive - -- reduced values from the left: - -- - -- > scanl f z [x1, x2, ...] == z :| [z `f` x1, (z `f` x1) `f` x2, ...] - -- - -- Note that - -- - -- > last (scanl f z xs) == foldl f z xs. - scanl :: (b -> a -> b) -> b -> [a] -> NonEmpty b - scanl f z = fromList . listscanl f z - - -- -| 'scanr' is the right-to-left dual of 'scanl'. - -- Note that - -- - -- > head (scanr f z xs) == foldr f z xs. - scanr :: (a -> b -> b) -> b -> [a] -> NonEmpty b - scanr f z = fromList . listscanr f z - - -- -| 'scanl1' is a variant of 'scanl' that has no starting value argument: - -- - -- > scanl1 f [x1, x2, ...] == x1 :| [x1 `f` x2, x1 `f` (x2 `f` x3), ...] - scanl1 :: (a -> a -> a) -> NonEmpty a -> NonEmpty a - scanl1 f (a :| as) = fromList (listscanl f a as) - - -- -| 'scanr1' is a variant of 'scanr' that has no starting value argument. - scanr1 :: (a -> a -> a) -> NonEmpty a -> NonEmpty a - scanr1 f (a :| as) = fromList (listscanr1 f (a:as)) - - -- -| 'intersperse x xs' alternates elements of the list with copies of @x@. - -- - -- > intersperse 0 (1 :| [2,3]) == 1 :| [0,2,0,3] - intersperse :: a -> NonEmpty a -> NonEmpty a - intersperse a (b :| bs) = b :| case bs of - [] -> [] - _:_ -> a : listintersperse a bs - - {- - -- | @'iterate' f x@ produces the infinite sequence - -- of repeated applications of @f@ to @x@. - -- - -- > iterate f x = x :| [f x, f (f x), ..] - iterate :: (a -> a) -> a -> NonEmpty a - iterate f a = a :| listiterate f (f a) - - -- | @'cycle' xs@ returns the infinite repetition of @xs@: - -- - -- > cycle (1 :| [2,3]) = 1 :| [2,3,1,2,3,...] - cycle :: NonEmpty a -> NonEmpty a - cycle = fromList . listcycle . toList - -} - - -- -| 'reverse' a finite NonEmpty stream. - reverse :: NonEmpty a -> NonEmpty a - reverse = lift listreverse - - {- - -- | @'repeat' x@ returns a constant stream, where all elements are - -- equal to @x@. - repeat :: a -> NonEmpty a - repeat a = a :| listrepeat a - -} - - -- -| @'take' n xs@ returns the first @n@ elements of @xs@. - take :: Nat -> NonEmpty a -> [a] - take n = listtake n . toList - - -- -| @'drop' n xs@ drops the first @n@ elements off the front of - -- the sequence @xs@. - drop :: Nat -> NonEmpty a -> [a] - drop n = listdrop n . toList - - -- -| @'splitAt' n xs@ returns a pair consisting of the prefix of @xs@ - -- of length @n@ and the remaining stream immediately following this prefix. - -- - -- > 'splitAt' n xs == ('take' n xs, 'drop' n xs) - -- > xs == ys ++ zs where (ys, zs) = 'splitAt' n xs - splitAt :: Nat -> NonEmpty a -> ([a],[a]) - splitAt n = listsplitAt n . toList - - -- -| @'takeWhile' p xs@ returns the longest prefix of the stream - -- @xs@ for which the predicate @p@ holds. - takeWhile :: (a -> Bool) -> NonEmpty a -> [a] - takeWhile p = listtakeWhile p . toList - - -- -| @'dropWhile' p xs@ returns the suffix remaining after - -- @'takeWhile' p xs@. - dropWhile :: (a -> Bool) -> NonEmpty a -> [a] - dropWhile p = listdropWhile p . toList - - -- -| @'span' p xs@ returns the longest prefix of @xs@ that satisfies - -- @p@, together with the remainder of the stream. - -- - -- > 'span' p xs == ('takeWhile' p xs, 'dropWhile' p xs) - -- > xs == ys ++ zs where (ys, zs) = 'span' p xs - span :: (a -> Bool) -> NonEmpty a -> ([a], [a]) - span p = listspan p . toList - - -- -| The @'break' p@ function is equivalent to @'span' (not . p)@. - break :: (a -> Bool) -> NonEmpty a -> ([a], [a]) - break p = span (not . p) - - -- -| @'filter' p xs@ removes any elements from @xs@ that do not satisfy @p@. - filter :: (a -> Bool) -> NonEmpty a -> [a] - filter p = listfilter p . toList - - -- -| The 'partition' function takes a predicate @p@ and a stream - -- @xs@, and returns a pair of lists. The first list corresponds to the - -- elements of @xs@ for which @p@ holds; the second corresponds to the - -- elements of @xs@ for which @p@ does not hold. - -- - -- > 'partition' p xs = ('filter' p xs, 'filter' (not . p) xs) - partition :: (a -> Bool) -> NonEmpty a -> ([a], [a]) - partition p = listpartition p . toList - - -- -| The 'group' function takes a stream and returns a list of - -- streams such that flattening the resulting list is equal to the - -- argument. Moreover, each stream in the resulting list - -- contains only equal elements. For example, in list notation: - -- - -- > 'group' $ 'cycle' "Mississippi" - -- > = "M" : "i" : "ss" : "i" : "ss" : "i" : "pp" : "i" : "M" : "i" : ... - group :: Eq a => [a] -> [NonEmpty a] - group = groupBy (==) - - -- -| 'groupBy' operates like 'group', but uses the provided equality - -- predicate instead of `==`. - groupBy :: (a -> a -> Bool) -> [a] -> [NonEmpty a] - groupBy eq0 = go eq0 - where - go _ [] = [] - go eq (x : xs) = (x :| ys) : groupBy eq zs - where (ys, zs) = listspan (eq x) xs - - -- -| 'groupWith' operates like 'group', but uses the provided projection when - -- comparing for equality - groupWith :: Eq b => (a -> b) -> [a] -> [NonEmpty a] - groupWith f = groupBy ((==) `on` f) - - -- -| 'groupAllWith' operates like 'groupWith', but sorts the list - -- first so that each equivalence class has, at most, one list in the - -- output - groupAllWith :: (Ord b) => (a -> b) -> [a] -> [NonEmpty a] - groupAllWith f = groupWith f . listsortBy (compare `on` f) - - -- -| 'group1' operates like 'group', but uses the knowledge that its - -- input is non-empty to produce guaranteed non-empty output. - group1 :: Eq a => NonEmpty a -> NonEmpty (NonEmpty a) - group1 = groupBy1 (==) - - -- -| 'groupBy1' is to 'group1' as 'groupBy' is to 'group'. - groupBy1 :: (a -> a -> Bool) -> NonEmpty a -> NonEmpty (NonEmpty a) - groupBy1 eq (x :| xs) = (x :| ys) :| groupBy eq zs - where (ys, zs) = listspan (eq x) xs - - -- -| 'groupWith1' is to 'group1' as 'groupWith' is to 'group' - groupWith1 :: (Eq b) => (a -> b) -> NonEmpty a -> NonEmpty (NonEmpty a) - groupWith1 f = groupBy1 ((==) `on` f) - - -- -| 'groupAllWith1' is to 'groupWith1' as 'groupAllWith' is to 'groupWith' - groupAllWith1 :: (Ord b) => (a -> b) -> NonEmpty a -> NonEmpty (NonEmpty a) - groupAllWith1 f = groupWith1 f . sortWith f - - -- -| The 'isPrefix' function returns @True@ if the first argument is - -- a prefix of the second. - isPrefixOf :: Eq a => [a] -> NonEmpty a -> Bool - isPrefixOf [] _ = True - isPrefixOf (y:ys) (x :| xs) = (y == x) && listisPrefixOf ys xs - - -- -| @xs !! n@ returns the element of the stream @xs@ at index - -- @n@. Note that the head of the stream has index 0. - -- - -- /Beware/: a negative or out-of-bounds index will cause an error. - (!!) :: NonEmpty a -> Nat -> a - (!!) (x :| xs) n - | n == 0 = x - | n > 0 = xs `listindex` (n - 1) - | otherwise = error "NonEmpty.!! negative argument" - - -- -| The 'zip' function takes two streams and returns a stream of - -- corresponding pairs. - zip :: NonEmpty a -> NonEmpty b -> NonEmpty (a,b) - zip (x :| xs) (y :| ys) = (x, y) :| listzip xs ys - - -- -| The 'zipWith' function generalizes 'zip'. Rather than tupling - -- the elements, the elements are combined using the function - -- passed as the first argument. - zipWith :: (a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c - zipWith f (x :| xs) (y :| ys) = f x y :| listzipWith f xs ys - - -- -| The 'unzip' function is the inverse of the 'zip' function. - unzip :: NonEmpty (a,b) -> (NonEmpty a, NonEmpty b) - unzip ((a,b) :| asbs) = (a :| as, b :| bs) - where - (as, bs) = listunzip asbs - - -- -| The 'nub' function removes duplicate elements from a list. In - -- particular, it keeps only the first occurence of each element. - -- (The name 'nub' means \'essence\'.) - -- It is a special case of 'nubBy', which allows the programmer to - -- supply their own inequality test. - nub :: Eq a => NonEmpty a -> NonEmpty a - nub = nubBy (==) - - -- -| The 'nubBy' function behaves just like 'nub', except it uses a - -- user-supplied equality predicate instead of the overloaded '==' - -- function. - nubBy :: (a -> a -> Bool) -> NonEmpty a -> NonEmpty a - nubBy eq (a :| as) = a :| listnubBy eq (listfilter (\b -> not (eq a b)) as) - - -- -| 'transpose' for 'NonEmpty', behaves the same as 'Data.List.transpose' - -- The rows/columns need not be the same length, in which case - -- > transpose . transpose /= id - transpose :: NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a) - transpose = fmap fromList - . fromList . listtranspose . toList - . fmap toList - - -- -| 'sortBy' for 'NonEmpty', behaves the same as 'Data.List.sortBy' - sortBy :: (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a - sortBy f = lift (listsortBy f) - - -- -| 'sortWith' for 'NonEmpty', behaves the same as: - -- - -- > sortBy . comparing - sortWith :: Ord o => (a -> o) -> NonEmpty a -> NonEmpty a - sortWith = sortBy . comparing - - |]) diff --git a/src/Data/Singletons/Prelude/Maybe.hs b/src/Data/Singletons/Prelude/Maybe.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/Maybe.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TypeFamilies, - DataKinds, PolyKinds, UndecidableInstances, GADTs, RankNTypes, - TypeApplications #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Maybe --- Copyright : (C) 2013-2014 Richard Eisenberg, Jan Stolarek --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- 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, SMaybe(..), - - -- * 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.Single -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/Monad.hs b/src/Data/Singletons/Prelude/Monad.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/Monad.hs +++ /dev/null @@ -1,298 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Monad --- Copyright : (C) 2018 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Defines the promoted and singled versions of the 'Monad' type class. --- ----------------------------------------------------------------------------- - -module Data.Singletons.Prelude.Monad ( - PFunctor(Fmap), SFunctor(sFmap), - PMonad(..), SMonad(..), PMonadPlus(..), SMonadPlus(..), - PMonadFail(Fail), SMonadFail(sFail), - - MapM, sMapM, MapM_, sMapM_, ForM, sForM, - Sequence, sSequence, Sequence_, sSequence_, - type (=<<), (%=<<), type (>=>), (%>=>), type (<=<), (%<=<), - Void, sVoid, - - Join, sJoin, - Msum, sMsum, - Mfilter, sMfilter, FilterM, sFilterM, - MapAndUnzipM, sMapAndUnzipM, ZipWithM, sZipWithM, - ZipWithM_, sZipWithM_, FoldlM, sFoldlM, - ReplicateM, sReplicateM, ReplicateM_, sReplicateM_, - - Guard, sGuard, When, sWhen, Unless, sUnless, - - LiftM, sLiftM, LiftM2, sLiftM2, LiftM3, sLiftM3, - LiftM4, sLiftM4, LiftM5, sLiftM5, Ap, sAp, - - type (<$!>), (%<$!>), - - -- * Defunctionalization symbols - FmapSym0, FmapSym1, FmapSym2, - type (>>=@#@$), type (>>=@#@$$), type (>>=@#@$$$), - type (>>@#@$), type (>>@#@$$), type (>>@#@$$$), - ReturnSym0, ReturnSym1, FailSym0, FailSym1, - MzeroSym0, MplusSym0, MplusSym1, MplusSym2, - - MapMSym0, MapMSym1, MapMSym2, - MapM_Sym0, MapM_Sym1, MapM_Sym2, - ForMSym0, ForMSym1, ForMSym2, - SequenceSym0, SequenceSym1, - Sequence_Sym0, Sequence_Sym1, - type (=<<@#@$), type (=<<@#@$$), type (=<<@#@$$$), - type (>=>@#@$), type (>=>@#@$$), type (>=>@#@$$$), - type (<=<@#@$), type (<=<@#@$$), type (<=<@#@$$$), - VoidSym0, VoidSym1, - - JoinSym0, JoinSym1, - MsumSym0, MsumSym1, - MfilterSym0, MfilterSym1, MfilterSym2, - FilterMSym0, FilterMSym1, FilterMSym2, - MapAndUnzipMSym0, MapAndUnzipMSym1, MapAndUnzipMSym2, - ZipWithMSym0, ZipWithMSym1, ZipWithMSym2, ZipWithMSym3, - ZipWithM_Sym0, ZipWithM_Sym1, ZipWithM_Sym2, ZipWithM_Sym3, - FoldlMSym0, FoldlMSym1, FoldlMSym2, FoldlMSym3, - ReplicateMSym0, ReplicateMSym1, ReplicateMSym2, - ReplicateM_Sym0, ReplicateM_Sym1, ReplicateM_Sym2, - - GuardSym0, GuardSym1, - WhenSym0, WhenSym1, WhenSym2, - UnlessSym0, UnlessSym1, UnlessSym2, - - LiftMSym0, LiftMSym1, LiftMSym2, - LiftM2Sym0, LiftM2Sym1, LiftM2Sym2, LiftM2Sym3, - LiftM3Sym0, LiftM3Sym1, LiftM3Sym2, LiftM3Sym3, LiftM3Sym4, - LiftM4Sym0, LiftM4Sym1, LiftM4Sym2, LiftM4Sym3, LiftM4Sym4, LiftM4Sym5, - LiftM5Sym0, LiftM5Sym1, LiftM5Sym2, LiftM5Sym3, LiftM5Sym4, LiftM5Sym5, LiftM5Sym6, - ApSym0, ApSym1, ApSym2, - - type (<$!>@#@$), type (<$!>@#@$$), type (<$!>@#@$$$), - ) where - -import Control.Applicative -import Control.Monad -import Data.Ord (Down(..)) -import Data.Singletons.Prelude.Applicative () -import Data.Singletons.Prelude.Base hiding (Foldr, FoldrSym0, sFoldr) -import Data.Singletons.Prelude.Foldable -import Data.Singletons.Prelude.Functor -import Data.Singletons.Prelude.Instances -import Data.Singletons.Prelude.List (UnzipSym0, sUnzip, ZipWithSym0, sZipWith) -import Data.Singletons.Prelude.Monad.Fail -import Data.Singletons.Prelude.Monad.Internal -import Data.Singletons.Prelude.Monoid -import Data.Singletons.Prelude.Num -import Data.Singletons.Prelude.Ord -import Data.Singletons.Prelude.Traversable -import Data.Singletons.Single -import GHC.TypeNats - -$(singletonsOnly [d| - -- ----------------------------------------------------------------------------- - -- Functions mandated by the Prelude - - -- -| This generalizes the list-based 'filter' function. - - filterM :: (Applicative m) => (a -> m Bool) -> [a] -> m [a] - filterM p = foldr (\ x -> liftA2 (\ flg -> if flg then (x:) else id) (p x)) (pure []) - - infixr 1 <=<, >=> - - -- -| Left-to-right Kleisli composition of monads. - (>=>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c) - f >=> g = \x -> f x >>= g - - -- -| Right-to-left Kleisli composition of monads. @('>=>')@, with the arguments flipped. - -- - -- Note how this operator resembles function composition @('.')@: - -- - -- > (.) :: (b -> c) -> (a -> b) -> a -> c - -- > (<=<) :: Monad m => (b -> m c) -> (a -> m b) -> a -> m c - (<=<) :: Monad m => (b -> m c) -> (a -> m b) -> (a -> m c) - (<=<) = flip (>=>) - - {- - Relies on infinite lists - - -- -| @'forever' act@ repeats the action infinitely. - forever :: (Applicative f) => f a -> f b - forever a = let a' = a *> a' in a' - -- Use explicit sharing here, as it prevents a space leak regardless of - -- optimizations. - -} - - -- ----------------------------------------------------------------------------- - -- Other monad functions - - -- -| The 'mapAndUnzipM' function maps its first argument over a list, returning - -- the result as a pair of lists. This function is mainly used with complicated - -- data structures or a state-transforming monad. - mapAndUnzipM :: (Applicative m) => (a -> m (b,c)) -> [a] -> m ([b], [c]) - mapAndUnzipM f xs = unzip <$> traverse f xs - - -- -| The 'zipWithM' function generalizes 'zipWith' to arbitrary applicative functors. - zipWithM :: (Applicative m) => (a -> b -> m c) -> [a] -> [b] -> m [c] - zipWithM f xs ys = sequenceA (zipWith f xs ys) - - -- -| 'zipWithM_' is the extension of 'zipWithM' which ignores the final result. - zipWithM_ :: (Applicative m) => (a -> b -> m c) -> [a] -> [b] -> m () - zipWithM_ f xs ys = sequenceA_ (zipWith f xs ys) - - {- -| The 'foldM' function is analogous to 'foldl', except that its result is - encapsulated in a monad. Note that 'foldM' works from left-to-right over - the list arguments. This could be an issue where @('>>')@ and the `folded - function' are not commutative. - - - > foldM f a1 [x1, x2, ..., xm] - - == - - > do - > a2 <- f a1 x1 - > a3 <- f a2 x2 - > ... - > f am xm - - If right-to-left evaluation is required, the input list should be reversed. - - Note: 'foldM' is the same as 'foldlM' - -} - - foldM :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b - foldM = foldlM - - -- -| Like 'foldM', but discards the result. - foldM_ :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m () - foldM_ f a xs = foldlM f a xs >> return () - - {- - Note [Worker/wrapper transform on replicateM/replicateM_] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - The implementations of replicateM and replicateM_ both leverage the - worker/wrapper transform. The simpler implementation of replicateM_, as an - example, would be: - - replicateM_ 0 _ = pure () - replicateM_ n f = f *> replicateM_ (n - 1) f - - However, the self-recursive nature of this implementation inhibits inlining, - which means we never get to specialise to the action (`f` in the code above). - By contrast, the implementation below with a local loop makes it possible to - inline the entire definition (as happens for foldr, for example) thereby - specialising for the particular action. - - For further information, see this Trac comment, which includes side-by-side - Core: https://ghc.haskell.org/trac/ghc/ticket/11795#comment:6 - -} - - -- -| @'replicateM' n act@ performs the action @n@ times, - -- gathering the results. - replicateM :: forall m a. (Applicative m) => Nat -> m a -> m [a] - replicateM cnt0 f = - loop cnt0 - where - loop :: Nat -> m [a] - loop cnt - | cnt <= 0 = pure [] - | otherwise = liftA2 (:) f (loop (cnt - 1)) - - -- -| Like 'replicateM', but discards the result. - replicateM_ :: forall m a. (Applicative m) => Nat -> m a -> m () - replicateM_ cnt0 f = - loop cnt0 - where - loop :: Nat -> m () - loop cnt - | cnt <= 0 = pure () - | otherwise = f *> loop (cnt - 1) - - - -- -| The reverse of 'when'. - unless :: (Applicative f) => Bool -> f () -> f () - unless p s = if p then pure () else s - - infixl 4 <$!> - - -- -| Strict version of 'Data.Functor.<$>'. - -- - -- @since 4.8.0.0 - (<$!>) :: Monad m => (a -> b) -> m a -> m b - f <$!> m = do - x <- m - let z = f x - z `seq` return z - - - -- ----------------------------------------------------------------------------- - -- Other MonadPlus functions - - -- -| Direct 'MonadPlus' equivalent of 'filter' - -- @'filter'@ = @(mfilter:: (a -> Bool) -> [a] -> [a]@ - -- applicable to any 'MonadPlus', for example - -- @mfilter odd (Just 1) == Just 1@ - -- @mfilter odd (Just 2) == Nothing@ - - mfilter :: (MonadPlus m) => (a -> Bool) -> m a -> m a - mfilter p ma = do - a <- ma - if p a then return a else mzero - - {- -$naming - - The functions in this library use the following naming conventions: - - * A postfix \'@M@\' always stands for a function in the Kleisli category: - The monad type constructor @m@ is added to function results - (modulo currying) and nowhere else. So, for example, - - > filter :: (a -> Bool) -> [a] -> [a] - > filterM :: (Monad m) => (a -> m Bool) -> [a] -> m [a] - - * A postfix \'@_@\' changes the result type from @(m a)@ to @(m ())@. - Thus, for example: - - > sequence :: Monad m => [m a] -> m [a] - > sequence_ :: Monad m => [m a] -> m () - - * A prefix \'@m@\' generalizes an existing function to a monadic form. - Thus, for example: - - > sum :: Num a => [a] -> a - > msum :: MonadPlus m => [m a] -> m a - - -} - - instance Monoid a => Monad ((,) a) where - (u, a) >>= k = case k a of (v, b) -> (u `mappend` v, b) - - instance Monad Down where - Down a >>= k = k a - |]) - --- Workaround for #326 -infixr 1 <=<, >=> -infixl 4 <$!> diff --git a/src/Data/Singletons/Prelude/Monad/Fail.hs b/src/Data/Singletons/Prelude/Monad/Fail.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/Monad/Fail.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Monad.Fail --- Copyright : (C) 2019 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Defines the promoted and singled versions of the 'MonadFail' type class. --- ----------------------------------------------------------------------------- - -module Data.Singletons.Prelude.Monad.Fail ( - PMonadFail(..), SMonadFail(..), - - -- * Defunctionalization symbols - FailSym0, FailSym1 - ) where - -import Data.Kind -import Data.Singletons.Prelude.Instances -import Data.Singletons.Prelude.Monad.Internal -import Data.Singletons.Single - -$(singletonsOnly [d| - -- -| When a value is bound in @do@-notation, the pattern on the left - -- hand side of @<-@ might not match. In this case, this class - -- provides a function to recover. - -- - -- A 'Monad' without a 'MonadFail' instance may only be used in conjunction - -- with pattern that always match, such as newtypes, tuples, data types with - -- only a single data constructor, and irrefutable patterns (@~pat@). - -- - -- Instances of 'MonadFail' should satisfy the following law: @fail s@ should - -- be a left zero for 'Control.Monad.>>=', - -- - -- @ - -- fail s >>= f = fail s - -- @ - -- - -- If your 'Monad' is also 'Control.Monad.MonadPlus', a popular definition is - -- - -- @ - -- fail _ = mzero - -- @ - class Monad m => MonadFail (m :: Type -> Type) where - fail :: String -> m a - - instance MonadFail Maybe where - fail _ = Nothing - - instance MonadFail [] where - fail _ = [] - |]) diff --git a/src/Data/Singletons/Prelude/Monad/Internal.hs b/src/Data/Singletons/Prelude/Monad/Internal.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/Monad/Internal.hs +++ /dev/null @@ -1,505 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Monad.Internal --- Copyright : (C) 2018 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Defines the promoted and singled versions of: --- --- * Functor --- * Applicative --- * Alternative --- * Monad --- * MonadPlus --- --- As well as auxiliary definitions. --- --- This module exists to break up import cycles. --- ----------------------------------------------------------------------------- - -module Data.Singletons.Prelude.Monad.Internal where - -import Control.Applicative -import Control.Monad -import Data.Kind -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Singletons.Prelude.Base -import Data.Singletons.Prelude.Instances -import Data.Singletons.Single - -{- -Note [How to get the right kinds when promoting Functor and friends] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To avoid running afoul of a CUSK validity check (see Note [CUSKification]), -classes with type parameters that lack explicit kind signatures will be -defaulted to be of kind Type. This is not what you want for Functor, however, -since its argument is of kind (Type -> Type), so we must explicitly use this -kind when declaring the Functor class (and other classes in this module). --} - -$(singletonsOnly [d| - infixl 4 <$ - - {- -| The 'Functor' class is used for types that can be mapped over. - Instances of 'Functor' should satisfy the following laws: - - > fmap id == id - > fmap (f . g) == fmap f . fmap g - - The instances of 'Functor' for lists, 'Data.Maybe.Maybe' and 'System.IO.IO' - satisfy these laws. - -} - - class Functor (f :: Type -> Type) where - fmap :: (a -> b) -> f a -> f b - - -- -| Replace all locations in the input with the same value. - -- The default definition is @'fmap' . 'const'@, but this may be - -- overridden with a more efficient version. - (<$) :: a -> f b -> f a - (<$) = fmap . const - - infixl 4 <*>, <*, *>, <**> - - -- -| A functor with application, providing operations to - -- - -- -* embed pure expressions ('pure'), and - -- - -- -* sequence computations and combine their results ('<*>' and 'liftA2'). - -- - -- A minimal complete definition must include implementations of 'pure' - -- and of either '<*>' or 'liftA2'. If it defines both, then they must behave - -- the same as their default definitions: - -- - -- @('<*>') = 'liftA2' 'id'@ - -- - -- @'liftA2' f x y = f '<$>' x '<*>' y@ - -- - -- Further, any definition must satisfy the following: - -- - -- [/identity/] - -- - -- @'pure' 'id' '<*>' v = v@ - -- - -- [/composition/] - -- - -- @'pure' (.) '<*>' u '<*>' v '<*>' w = u '<*>' (v '<*>' w)@ - -- - -- [/homomorphism/] - -- - -- @'pure' f '<*>' 'pure' x = 'pure' (f x)@ - -- - -- [/interchange/] - -- - -- @u '<*>' 'pure' y = 'pure' ('$' y) '<*>' u@ - -- - -- - -- The other methods have the following default definitions, which may - -- be overridden with equivalent specialized implementations: - -- - -- * @u '*>' v = ('id' '<$' u) '<*>' v@ - -- - -- * @u '<*' v = 'liftA2' 'const' u v@ - -- - -- As a consequence of these laws, the 'Functor' instance for @f@ will satisfy - -- - -- * @'fmap' f x = 'pure' f '<*>' x@ - -- - -- - -- It may be useful to note that supposing - -- - -- @forall x y. p (q x y) = f x . g y@ - -- - -- it follows from the above that - -- - -- @'liftA2' p ('liftA2' q u v) = 'liftA2' f u . 'liftA2' g v@ - -- - -- - -- If @f@ is also a 'Monad', it should satisfy - -- - -- * @'pure' = 'return'@ - -- - -- * @('<*>') = 'ap'@ - -- - -- * @('*>') = ('>>')@ - -- - -- (which implies that 'pure' and '<*>' satisfy the applicative functor laws). - - class Functor f => Applicative (f :: Type -> Type) where - -- {-# MINIMAL pure, ((<*>) | liftA2) #-} - -- -| Lift a value. - pure :: a -> f a - - -- -| Sequential application. - -- - -- A few functors support an implementation of '<*>' that is more - -- efficient than the default one. - (<*>) :: f (a -> b) -> f a -> f b - (<*>) = liftA2 id - - -- -| Lift a binary function to actions. - -- - -- Some functors support an implementation of 'liftA2' that is more - -- efficient than the default one. In particular, if 'fmap' is an - -- expensive operation, it is likely better to use 'liftA2' than to - -- 'fmap' over the structure and then use '<*>'. - liftA2 :: (a -> b -> c) -> f a -> f b -> f c - liftA2 f x = (<*>) (fmap f x) - - -- -| Sequence actions, discarding the value of the first argument. - (*>) :: f a -> f b -> f b - a1 *> a2 = (id <$ a1) <*> a2 - -- This is essentially the same as liftA2 (flip const), but if the - -- Functor instance has an optimized (<$), it may be better to use - -- that instead. Before liftA2 became a method, this definition - -- was strictly better, but now it depends on the functor. For a - -- functor supporting a sharing-enhancing (<$), this definition - -- may reduce allocation by preventing a1 from ever being fully - -- realized. In an implementation with a boring (<$) but an optimizing - -- liftA2, it would likely be better to define (*>) using liftA2. - - -- -| Sequence actions, discarding the value of the second argument. - (<*) :: f a -> f b -> f a - (<*) = liftA2 const - - -- -| A variant of '<*>' with the arguments reversed. - (<**>) :: Applicative f => f a -> f (a -> b) -> f b - (<**>) = liftA2 (\a f -> f a) - -- Don't use $ here, see the note at the top of the page - - -- -| Lift a function to actions. - -- This function may be used as a value for `fmap` in a `Functor` instance. - liftA :: Applicative f => (a -> b) -> f a -> f b - liftA f a = pure f <*> a - -- Caution: since this may be used for `fmap`, we can't use the obvious - -- definition of liftA = fmap. - - -- -| Lift a ternary function to actions. - liftA3 :: Applicative f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d - liftA3 f a b c = liftA2 f a b <*> c - - infixl 1 >>, >>= - infixr 1 =<< - - -- -| The 'join' function is the conventional monad join operator. It - -- is used to remove one level of monadic structure, projecting its - -- bound argument into the outer level. - -- - -- ==== __Examples__ - -- - -- A common use of 'join' is to run an 'IO' computation returned from - -- an 'GHC.Conc.STM' transaction, since 'GHC.Conc.STM' transactions - -- can't perform 'IO' directly. Recall that - -- - -- @ - -- 'GHC.Conc.atomically' :: STM a -> IO a - -- @ - -- - -- is used to run 'GHC.Conc.STM' transactions atomically. So, by - -- specializing the types of 'GHC.Conc.atomically' and 'join' to - -- - -- @ - -- 'GHC.Conc.atomically' :: STM (IO b) -> IO (IO b) - -- 'join' :: IO (IO b) -> IO b - -- @ - -- - -- we can compose them as - -- - -- @ - -- 'join' . 'GHC.Conc.atomically' :: STM (IO b) -> IO b - -- @ - -- - -- to run an 'GHC.Conc.STM' transaction and the 'IO' action it - -- returns. - join :: (Monad m) => m (m a) -> m a - join x = x >>= id - - {- -| The 'Monad' class defines the basic operations over a /monad/, - a concept from a branch of mathematics known as /category theory/. - From the perspective of a Haskell programmer, however, it is best to - think of a monad as an /abstract datatype/ of actions. - Haskell's @do@ expressions provide a convenient syntax for writing - monadic expressions. - - Instances of 'Monad' should satisfy the following laws: - - * @'return' a '>>=' k = k a@ - * @m '>>=' 'return' = m@ - * @m '>>=' (\\x -> k x '>>=' h) = (m '>>=' k) '>>=' h@ - - Furthermore, the 'Monad' and 'Applicative' operations should relate as follows: - - * @'pure' = 'return'@ - * @('<*>') = 'ap'@ - - The above laws imply: - - * @'fmap' f xs = xs '>>=' 'return' . f@ - * @('>>') = ('*>')@ - - and that 'pure' and ('<*>') satisfy the applicative functor laws. - - The instances of 'Monad' for lists, 'Data.Maybe.Maybe' and 'System.IO.IO' - defined in the "Prelude" satisfy these laws. - -} - class Applicative m => Monad (m :: Type -> Type) where - -- -| Sequentially compose two actions, passing any value produced - -- by the first as an argument to the second. - (>>=) :: forall a b. m a -> (a -> m b) -> m b - - -- -| Sequentially compose two actions, discarding any value produced - -- by the first, like sequencing operators (such as the semicolon) - -- in imperative languages. - (>>) :: forall a b. m a -> m b -> m b - m >> k = m >>= \_ -> k -- See Note [Recursive bindings for Applicative/Monad] - - -- -| Inject a value into the monadic type. - return :: a -> m a - return = pure - - {- Note [Recursive bindings for Applicative/Monad] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - The original Applicative/Monad proposal stated that after - implementation, the designated implementation of (>>) would become - - (>>) :: forall a b. m a -> m b -> m b - (>>) = (*>) - - by default. You might be inclined to change this to reflect the stated - proposal, but you really shouldn't! Why? Because people tend to define - such instances the /other/ way around: in particular, it is perfectly - legitimate to define an instance of Applicative (*>) in terms of (>>), - which would lead to an infinite loop for the default implementation of - Monad! And people do this in the wild. - - This turned into a nasty bug that was tricky to track down, and rather - than eliminate it everywhere upstream, it's easier to just retain the - original default. - - -} - - -- -| Same as '>>=', but with the arguments interchanged. - (=<<) :: Monad m => (a -> m b) -> m a -> m b - f =<< x = x >>= f - - -- -| Conditional execution of 'Applicative' expressions. For example, - -- - -- > when debug (putStrLn "Debugging") - -- - -- will output the string @Debugging@ if the Boolean value @debug@ - -- is 'True', and otherwise do nothing. - when :: (Applicative f) => Bool -> f () -> f () - when p s = if p then s else pure () - - -- -| Promote a function to a monad. - liftM :: (Monad m) => (a1 -> r) -> m a1 -> m r - liftM f m1 = do { x1 <- m1; return (f x1) } - - -- -| Promote a function to a monad, scanning the monadic arguments from - -- left to right. For example, - -- - -- > liftM2 (+) [0,1] [0,2] = [0,2,1,3] - -- > liftM2 (+) (Just 1) Nothing = Nothing - -- - liftM2 :: (Monad m) => (a1 -> a2 -> r) -> m a1 -> m a2 -> m r - liftM2 f m1 m2 = do { x1 <- m1; x2 <- m2; return (f x1 x2) } - -- Caution: since this may be used for `liftA2`, we can't use the obvious - -- definition of liftM2 = liftA2. - - -- -| Promote a function to a monad, scanning the monadic arguments from - -- left to right (cf. 'liftM2'). - liftM3 :: (Monad m) => (a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r - liftM3 f m1 m2 m3 = do { x1 <- m1; x2 <- m2; x3 <- m3; return (f x1 x2 x3) } - - -- -| Promote a function to a monad, scanning the monadic arguments from - -- left to right (cf. 'liftM2'). - liftM4 :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r - liftM4 f m1 m2 m3 m4 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; return (f x1 x2 x3 x4) } - - -- -| Promote a function to a monad, scanning the monadic arguments from - -- left to right (cf. 'liftM2'). - liftM5 :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> a5 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m r - liftM5 f m1 m2 m3 m4 m5 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; return (f x1 x2 x3 x4 x5) } - - {- -| In many situations, the 'liftM' operations can be replaced by uses of - 'ap', which promotes function application. - - > return f `ap` x1 `ap` ... `ap` xn - - is equivalent to - - > liftMn f x1 x2 ... xn - - -} - - ap :: (Monad m) => m (a -> b) -> m a -> m b - ap m1 m2 = do { x1 <- m1; x2 <- m2; return (x1 x2) } - -- Since many Applicative instances define (<*>) = ap, we - -- cannot define ap = (<*>) - - -- ----------------------------------------------------------------------------- - -- The Alternative class definition - - infixl 3 <|> - - -- -| A monoid on applicative functors. - -- - -- If defined, 'some' and 'many' should be the least solutions - -- of the equations: - -- - -- -* @'some' v = (:) '<$>' v '<*>' 'many' v@ - -- - -- -* @'many' v = 'some' v '<|>' 'pure' []@ - class Applicative f => Alternative (f :: Type -> Type) where - -- -| The identity of '<|>' - empty :: f a - -- -| An associative binary operation - (<|>) :: f a -> f a -> f a - - {- - some and many rely on infinite lists - - -- -| One or more. - some :: f a -> f [a] - some v = some_v - where - many_v = some_v <|> pure [] - some_v = liftA2 (:) v many_v - - -- -| Zero or more. - many :: f a -> f [a] - many v = many_v - where - many_v = some_v <|> pure [] - some_v = liftA2 (:) v many_v - -} - - -- -| @'guard' b@ is @'pure' ()@ if @b@ is 'True', - -- and 'empty' if @b@ is 'False'. - guard :: (Alternative f) => Bool -> f () - guard True = pure () - guard False = empty - - -- ----------------------------------------------------------------------------- - -- The MonadPlus class definition - - -- -| Monads that also support choice and failure. - class (Alternative m, Monad m) => MonadPlus (m :: Type -> Type) where - -- -| The identity of 'mplus'. It should also satisfy the equations - -- - -- > mzero >>= f = mzero - -- > v >> mzero = mzero - -- - -- The default definition is - -- - -- @ - -- mzero = 'empty' - -- @ - mzero :: m a - mzero = empty - - -- -| An associative operation. The default definition is - -- - -- @ - -- mplus = ('<|>') - -- @ - mplus :: m a -> m a -> m a - mplus = (<|>) - |]) - --- Workaround for #326 -infixl 4 <$ -infixl 4 <*>, <*, *>, <**> -infixl 1 >>, >>= -infixr 1 =<< -infixl 3 <|> - -$(singletonsOnly [d| - ------------------------------------------------------------------------------- - -- Instances - - deriving instance Functor Maybe - deriving instance Functor NonEmpty - deriving instance Functor [] - deriving instance Functor (Either a) - - instance Applicative Maybe where - pure = Just - - Just f <*> m = fmap f m - Nothing <*> _m = Nothing - - liftA2 f (Just x) (Just y) = Just (f x y) - liftA2 _ Just{} Nothing = Nothing - liftA2 _ Nothing Just{} = Nothing - liftA2 _ Nothing Nothing = Nothing - - Just _m1 *> m2 = m2 - Nothing *> _m2 = Nothing - - instance Applicative NonEmpty where - pure a = a :| [] - (<*>) = ap - liftA2 = liftM2 - - instance Applicative [] where - pure x = [x] - (<*>) = ap - liftA2 = liftM2 - (*>) = (>>) - - instance Applicative (Either e) where - pure = Right - Left e <*> _ = Left e - Right f <*> r = fmap f r - - instance Monad Maybe where - (Just x) >>= k = k x - Nothing >>= _ = Nothing - - (>>) = (*>) - - instance Monad NonEmpty where - (a :| as) >>= f = b :| (bs ++ bs') - where b :| bs = f a - bs' = as >>= toList . f - toList (c :| cs) = c : cs - - instance Monad [] where - xs >>= f = foldr ((++) . f) [] xs - - instance Monad (Either e) where - Left l >>= _ = Left l - Right r >>= k = k r - - instance Alternative Maybe where - empty = Nothing - Nothing <|> r = r - l@(Just{}) <|> _ = l - - instance Alternative [] where - empty = [] - (<|>) = (++) - - instance MonadPlus Maybe - instance MonadPlus [] - |]) diff --git a/src/Data/Singletons/Prelude/Monad/Zip.hs b/src/Data/Singletons/Prelude/Monad/Zip.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/Monad/Zip.hs +++ /dev/null @@ -1,107 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Monad.Zip --- Copyright : (C) 2018 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Defines the promoted and singled versions of the 'MonadZip' type class. --- ----------------------------------------------------------------------------- - -module Data.Singletons.Prelude.Monad.Zip ( - PMonadZip(..), SMonadZip(..), - - -- * Defunctionalization symbols - MzipSym0, MzipSym1, MzipSym2, - MzipWithSym0, MzipWithSym1, MzipWithSym2, MzipWithSym3, - MunzipSym0, MunzipSym1, - ) where - -import Control.Monad.Zip -import Data.Functor.Identity -import Data.Kind -import Data.Monoid -import Data.Singletons.Prelude.Identity -import Data.Singletons.Prelude.Instances -import Data.Singletons.Prelude.List - ( ZipSym0, ZipWithSym0, UnzipSym0 - , sZip, sZipWith, sUnzip ) -import Data.Singletons.Prelude.Monad.Internal -import Data.Singletons.Prelude.Monoid () -import Data.Singletons.Prelude.Tuple -import Data.Singletons.Single - -$(singletonsOnly [d| - -- -| `MonadZip` type class. Minimal definition: `mzip` or `mzipWith` - -- - -- Instances should satisfy the laws: - -- - -- -* Naturality : - -- - -- > liftM (f *** g) (mzip ma mb) = mzip (liftM f ma) (liftM g mb) - -- - -- -* Information Preservation: - -- - -- > liftM (const ()) ma = liftM (const ()) mb - -- > ==> - -- > munzip (mzip ma mb) = (ma, mb) - -- - class Monad m => MonadZip (m :: Type -> Type) where - -- {-# MINIMAL mzip | mzipWith #-} - - mzip :: m a -> m b -> m (a,b) - mzip = mzipWith (,) - - mzipWith :: (a -> b -> c) -> m a -> m b -> m c - mzipWith f ma mb = liftM (uncurry f) (mzip ma mb) - - munzip :: m (a,b) -> (m a, m b) - munzip mab = (liftM fst mab, liftM snd mab) - -- munzip is a member of the class because sometimes - -- you can implement it more efficiently than the - -- above default code. See Trac #4370 comment by giorgidze - - instance MonadZip [] where - mzip = zip - mzipWith = zipWith - munzip = unzip - - instance MonadZip Identity where - mzipWith = liftM2 - munzip (Identity (a, b)) = (Identity a, Identity b) - - instance MonadZip Dual where - -- Cannot use coerce, it's unsafe - mzipWith = liftM2 - - instance MonadZip Sum where - mzipWith = liftM2 - - instance MonadZip Product where - mzipWith = liftM2 - - instance MonadZip Maybe where - mzipWith = liftM2 - - instance MonadZip First where - mzipWith = liftM2 - - instance MonadZip Last where - mzipWith = liftM2 - |]) diff --git a/src/Data/Singletons/Prelude/Monoid.hs b/src/Data/Singletons/Prelude/Monoid.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/Monoid.hs +++ /dev/null @@ -1,211 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Monoid --- Copyright : (C) 2018 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Defines the promoted version of 'Monoid', 'PMonoid', and the --- singleton version, 'SMonoid'. --- ----------------------------------------------------------------------------- - -module Data.Singletons.Prelude.Monoid ( - PMonoid(..), SMonoid(..), - - Sing, SDual(..), SAll(..), SAny(..), - SSum(..), SProduct(..), SFirst(..), SLast(..), - GetDual, GetAll, GetAny, GetSum, GetProduct, GetFirst, GetLast, - - -- ** Defunctionalization symbols - MemptySym0, - MappendSym0, MappendSym1, MappendSym2, - MconcatSym0, MconcatSym1, - DualSym0, DualSym1, GetDualSym0, GetDualSym1, - AllSym0, AllSym1, GetAllSym0, GetAllSym1, - AnySym0, AnySym1, GetAnySym0, GetAnySym1, - SumSym0, SumSym1, GetSumSym0, GetSumSym1, - ProductSym0, ProductSym1, GetProductSym0, GetProductSym1, - FirstSym0, FirstSym1, GetFirstSym0, GetFirstSym1, - LastSym0, LastSym1, GetLastSym0, GetLastSym1 - ) where - -import Data.Monoid (First(..), Last(..)) -import Data.Ord (Down(..)) -import Data.Semigroup hiding (First(..), Last(..)) -import Data.Singletons.Prelude.Base -import Data.Singletons.Prelude.Eq -import Data.Singletons.Prelude.Instances -import Data.Singletons.Prelude.Monad.Internal -import Data.Singletons.Prelude.Num -import Data.Singletons.Prelude.Ord -import Data.Singletons.Prelude.Semigroup.Internal hiding - (SFirst, SLast, - FirstSym0, FirstSym1, FirstSym0KindInference, - LastSym0, LastSym1, LastSym0KindInference, - GetFirst, GetFirstSym0, GetFirstSym1, GetFirstSym0KindInference, - GetLast, GetLastSym0, GetLastSym1, GetLastSym0KindInference) -import Data.Singletons.Prelude.Show -import Data.Singletons.Single -import Data.Singletons.Util - -import GHC.TypeLits (Symbol) - -$(singletonsOnly [d| - -- -| The class of monoids (types with an associative binary operation that - -- has an identity). Instances should satisfy the following laws: - -- - -- * @x '<>' 'mempty' = x@ - -- - -- * @'mempty' '<>' x = x@ - -- - -- * @x '<>' (y '<>' z) = (x '<>' y) '<>' z@ ('Semigroup' law) - -- - -- * @'mconcat' = 'foldr' '(<>)' 'mempty'@ - -- - -- The method names refer to the monoid of lists under concatenation, - -- but there are many other instances. - -- - -- Some types can be viewed as a monoid in more than one way, - -- e.g. both addition and multiplication on numbers. - -- In such cases we often define @newtype@s and make those instances - -- of 'Monoid', e.g. 'Sum' and 'Product'. - class Semigroup a => Monoid a where - -- -| Identity of 'mappend' - mempty :: a - - -- -| An associative operation - -- - -- __NOTE__: This method is redundant and has the default - -- implementation @'mappend' = '(<>)'@. - mappend :: a -> a -> a - mappend = (<>) - - -- -| Fold a list using the monoid. - -- - -- For most types, the default definition for 'mconcat' will be - -- used, but the function is included in the class definition so - -- that an optimized version can be provided for specific types. - mconcat :: [a] -> a - mconcat = foldr mappend mempty - - instance Monoid [a] where - mempty = [] - -- mconcat xss = [x | xs <- xss, x <- xs] - - instance Monoid b => Monoid (a -> b) where - mempty _ = mempty - - instance Monoid () where - -- Should it be strict? - mempty = () - mconcat _ = () - - instance (Monoid a, Monoid b) => Monoid (a,b) where - mempty = (mempty, mempty) - - instance (Monoid a, Monoid b, Monoid c) => Monoid (a,b,c) where - mempty = (mempty, mempty, mempty) - - instance (Monoid a, Monoid b, Monoid c, Monoid d) => Monoid (a,b,c,d) where - mempty = (mempty, mempty, mempty, mempty) - - instance (Monoid a, Monoid b, Monoid c, Monoid d, Monoid e) => - Monoid (a,b,c,d,e) where - mempty = (mempty, mempty, mempty, mempty, mempty) - - -- lexicographical ordering - instance Monoid Ordering where - mempty = EQ - - -- -| Lift a semigroup into 'Maybe' forming a 'Monoid' according to - -- : \"Any semigroup @S@ may be - -- turned into a monoid simply by adjoining an element @e@ not in @S@ - -- and defining @e*e = e@ and @e*s = s = s*e@ for all @s ∈ S@.\" - instance Semigroup a => Monoid (Maybe a) where - mempty = Nothing - - instance Monoid Symbol where - mempty = "" - |]) - -$(genSingletons monoidBasicTypes) -$(showSingInstances monoidBasicTypes) -$(singEqInstances monoidBasicTypes) -$(singDecideInstances monoidBasicTypes) -$(singOrdInstances monoidBasicTypes) -$(singShowInstances monoidBasicTypes) - -$(singletonsOnly [d| - instance Monoid a => Monoid (Dual a) where - mempty = Dual mempty - - instance Monoid All where - mempty = All True - - instance Monoid Any where - mempty = Any False - - instance Num a => Monoid (Sum a) where - mempty = Sum 0 - - instance Num a => Monoid (Product a) where - mempty = Product 1 - - -- deriving newtype instance Monoid a => Monoid (Down a) - instance Monoid a => Monoid (Down a) where - mempty = Down mempty - - -- deriving newtype instance Applicative First - instance Applicative First where - pure = First . pure - First f <*> First x = First (f <*> x) - - deriving instance Functor First - - -- deriving newtype instance Monad First - instance Monad First where - First a >>= k = First (a >>= \x -> case k x of First y -> y) - - instance Semigroup (First a) where - First Nothing <> b = b - a@(First Just{}) <> _ = a - - instance Monoid (First a) where - mempty = First Nothing - - -- deriving newtype instance Applicative Last - instance Applicative Last where - pure = Last . pure - Last f <*> Last x = Last (f <*> x) - - deriving instance Functor Last - - -- deriving newtype instance Monad Last - instance Monad Last where - Last a >>= k = Last (a >>= \x -> case k x of Last y -> y) - - instance Semigroup (Last a) where - a <> Last Nothing = a - _ <> b@(Last Just {}) = b - - instance Monoid (Last a) where - mempty = Last Nothing - |]) diff --git a/src/Data/Singletons/Prelude/Num.hs b/src/Data/Singletons/Prelude/Num.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/Num.hs +++ /dev/null @@ -1,146 +0,0 @@ -{-# LANGUAGE TemplateHaskell, PolyKinds, DataKinds, TypeFamilies, - TypeOperators, GADTs, ScopedTypeVariables, UndecidableInstances, - DefaultSignatures, FlexibleContexts, InstanceSigs, NoStarIsType, - TypeApplications - #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Num --- Copyright : (C) 2014 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Defines and exports promoted and singleton versions of definitions from --- GHC.Num. --- --- Be warned that some of the associated type families in the 'PNum' class --- (@(+)@, @(-)@, and @(*)@) clash with their counterparts for 'Nat' in the --- "GHC.TypeLits" module. ----------------------------------------------------------------------------- - -module Data.Singletons.Prelude.Num ( - PNum(..), SNum(..), Subtract, sSubtract, - - -- ** Defunctionalization symbols - type (+@#@$), type (+@#@$$), type (+@#@$$$), - type (-@#@$), type (-@#@$$), type (-@#@$$$), - type (*@#@$), type (*@#@$$), type (*@#@$$$), - NegateSym0, NegateSym1, - AbsSym0, AbsSym1, - SignumSym0, SignumSym1, - FromIntegerSym0, FromIntegerSym1, - SubtractSym0, SubtractSym1, SubtractSym2 - ) where - -import Data.Ord (Down(..)) -import Data.Singletons.Single -import Data.Singletons.Internal -import Data.Singletons.Prelude.Ord -import Data.Singletons.TypeLits.Internal -import Data.Singletons.Decide -import qualified GHC.TypeNats as TN -import GHC.TypeNats (SomeNat(..), someNatVal) -import Unsafe.Coerce - -$(singletonsOnly [d| - -- Basic numeric class. - -- - -- Minimal complete definition: all except 'negate' or @(-)@ - class Num a where - (+), (-), (*) :: a -> a -> a - infixl 6 + - infixl 6 - - infixl 7 * - -- Unary negation. - negate :: a -> a - -- Absolute value. - abs :: a -> a - -- Sign of a number. - -- The functions 'abs' and 'signum' should satisfy the law: - -- - -- > abs x * signum x == x - -- - -- For real numbers, the 'signum' is either @-1@ (negative), @0@ (zero) - -- or @1@ (positive). - signum :: a -> a - -- Conversion from a 'Nat'. - fromInteger :: Nat -> a - - x - y = x + negate y - - negate x = 0 - x - - -- deriving newtype instance Num a => Num (Down a) - instance Num a => Num (Down a) where - Down a + Down b = Down (a + b) - Down a - Down b = Down (a - b) - Down a * Down b = Down (a * b) - negate (Down a) = Down (negate a) - abs (Down a) = Down (abs a) - signum (Down a) = Down (signum a) - fromInteger n = Down (fromInteger n) - |]) - --- Workaround for #326 -infixl 6 + -infixl 6 - -infixl 7 * - --- PNum instance -type family SignumNat (a :: Nat) :: Nat where - SignumNat 0 = 0 - SignumNat x = 1 - -instance PNum Nat where - type a + b = a TN.+ b - type a - b = a TN.- b - type a * b = a TN.* b - type Negate (a :: Nat) = Error "Cannot negate a natural number" - type Abs (a :: Nat) = a - type Signum a = SignumNat a - type FromInteger a = a - --- SNum instance -instance SNum Nat where - sa %+ sb = - let a = fromSing sa - b = fromSing sb - ex = someNatVal (a + b) - in - case ex of - SomeNat (_ :: Proxy ab) -> unsafeCoerce (SNat :: Sing ab) - - sa %- sb = - let a = fromSing sa - b = fromSing sb - ex = someNatVal (a - b) - in - case ex of - SomeNat (_ :: Proxy ab) -> unsafeCoerce (SNat :: Sing ab) - - sa %* sb = - let a = fromSing sa - b = fromSing sb - ex = someNatVal (a * b) - in - case ex of - SomeNat (_ :: Proxy ab) -> unsafeCoerce (SNat :: Sing ab) - - sNegate _ = error "Cannot call sNegate on a natural number singleton." - - sAbs x = x - - sSignum sx = - case sx %~ (sing :: Sing 0) of - Proved Refl -> sing :: Sing 0 - Disproved _ -> unsafeCoerce (sing :: Sing 1) - - sFromInteger x = x - -$(singletonsOnly [d| - subtract :: Num a => a -> a -> a - subtract x y = y - x - |]) diff --git a/src/Data/Singletons/Prelude/Ord.hs b/src/Data/Singletons/Prelude/Ord.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/Ord.hs +++ /dev/null @@ -1,113 +0,0 @@ -{-# LANGUAGE TemplateHaskell, DataKinds, PolyKinds, ScopedTypeVariables, - TypeFamilies, TypeOperators, GADTs, UndecidableInstances, - FlexibleContexts, DefaultSignatures, InstanceSigs, - StandaloneDeriving, FlexibleInstances, TypeApplications #-} -{-# OPTIONS_GHC -Wno-orphans #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Ord --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Defines the promoted version of Ord, 'POrd', and the singleton version, --- 'SOrd'. --- ------------------------------------------------------------------------------ - -module Data.Singletons.Prelude.Ord ( - POrd(..), SOrd(..), - - Comparing, sComparing, - - -- | 'thenCmp' returns its second argument if its first is 'EQ'; otherwise, - -- it returns its first argument. - thenCmp, ThenCmp, sThenCmp, - - Sing, SOrdering(..), SDown(..), - - -- ** Defunctionalization symbols - ThenCmpSym0, ThenCmpSym1, ThenCmpSym2, - LTSym0, EQSym0, GTSym0, - CompareSym0, CompareSym1, CompareSym2, - type (<@#@$), type (<@#@$$), type (<@#@$$$), - type (<=@#@$), type (<=@#@$$), type (<=@#@$$$), - type (>@#@$), type (>@#@$$), type (>@#@$$$), - type (>=@#@$), type (>=@#@$$), type (>=@#@$$$), - MaxSym0, MaxSym1, MaxSym2, - MinSym0, MinSym1, MinSym2, - ComparingSym0, ComparingSym1, ComparingSym2, ComparingSym3, - DownSym0, DownSym1 - ) where - -import Data.Ord (Down(..)) -import Data.Singletons.Single -import Data.Singletons.Prelude.Eq -import Data.Singletons.Prelude.Instances -import Data.Singletons.Util - -$(singletonsOnly [d| - class (Eq a) => Ord a where - compare :: a -> a -> Ordering - (<), (<=), (>), (>=) :: a -> a -> Bool - infix 4 <= - infix 4 < - infix 4 > - infix 4 >= - 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; EQ -> False; GT -> False } - x <= y = case compare x y of { LT -> True; EQ -> True; GT -> False } - x > y = case compare x y of { LT -> False; EQ -> False; GT -> True } - x >= y = case compare x y of { LT -> False; EQ -> True; GT -> 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 - -- Not handled by TH: {-# MINIMAL compare | (<=) #-} - - -- -| - -- > comparing p x y = compare (p x) (p y) - -- - -- Useful combinator for use in conjunction with the @xxxBy@ family - -- of functions from "Data.List", for example: - -- - -- > ... sortBy (comparing fst) ... - comparing :: (Ord a) => (b -> a) -> b -> b -> Ordering - comparing p x y = compare (p x) (p y) - |]) - --- Workaround for #326 -infix 4 <= -infix 4 < -infix 4 > -infix 4 >= - -$(genSingletons [''Down]) - -$(singletonsOnly [d| - deriving instance Eq a => Eq (Down a) - - instance Ord a => Ord (Down a) where - compare (Down x) (Down y) = y `compare` x - |]) - -$(singletons [d| - thenCmp :: Ordering -> Ordering -> Ordering - thenCmp EQ x = x - thenCmp LT _ = LT - thenCmp GT _ = GT - |]) - -$(singOrdInstances basicTypes) diff --git a/src/Data/Singletons/Prelude/Semigroup.hs b/src/Data/Singletons/Prelude/Semigroup.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/Semigroup.hs +++ /dev/null @@ -1,302 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Semigroup --- Copyright : (C) 2018 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Defines the promoted version of 'Semigroup', 'PSemigroup', and the --- singleton version, 'SSemigroup'. --- ----------------------------------------------------------------------------- - -module Data.Singletons.Prelude.Semigroup ( - PSemigroup(..), SSemigroup(..), - - Sing, SMin(..), SMax(..), SFirst(..), SLast(..), - SWrappedMonoid(..), SDual(..), SAll(..), SAny(..), - SSum(..), SProduct(..), SOption(..), SArg(..), - GetMin, GetMax, GetFirst, GetLast, UnwrapMonoid, GetDual, - GetAll, GetAny, GetSum, GetProduct, GetOption, - - option_, sOption_, Option_, - - -- ** Defunctionalization symbols - type (<>@#@$), type (<>@#@$$), type (<>@#@$$$), - SconcatSym0, SconcatSym1, - MinSym0, MinSym1, GetMinSym0, GetMinSym1, - MaxSym0, MaxSym1, GetMaxSym0, GetMaxSym1, - FirstSym0, FirstSym1, GetFirstSym0, GetFirstSym1, - LastSym0, LastSym1, GetLastSym0, GetLastSym1, - WrapMonoidSym0, WrapMonoidSym1, UnwrapMonoidSym0, UnwrapMonoidSym1, - DualSym0, DualSym1, GetDualSym0, GetDualSym1, - AllSym0, AllSym1, GetAllSym0, GetAllSym1, - AnySym0, AnySym1, GetAnySym0, GetAnySym1, - SumSym0, SumSym1, GetSumSym0, GetSumSym1, - ProductSym0, ProductSym1, GetProductSym0, GetProductSym1, - OptionSym0, OptionSym1, GetOptionSym0, GetOptionSym1, - ArgSym0, ArgSym1, ArgSym2 - ) where - -import Control.Applicative -import Control.Monad -import qualified Data.Semigroup as Semi (Min(..), Max(..)) -import Data.Semigroup (First(..), Last(..), WrappedMonoid(..), Option(..), Arg(..)) -import Data.Singletons.Prelude.Base hiding - (Foldr, FoldrSym0, FoldrSym1, FoldrSym2, FoldrSym3, sFoldr) -import Data.Singletons.Prelude.Enum -import Data.Singletons.Prelude.Eq -import Data.Singletons.Prelude.Foldable hiding - ( All, AllSym0, AllSym1 - , Any, AnySym0, AnySym1 - , Product, ProductSym0, ProductSym1 - , Sum, SumSym0, SumSym1 ) -import Data.Singletons.Prelude.Functor -import Data.Singletons.Prelude.Instances -import Data.Singletons.Prelude.Maybe -import Data.Singletons.Prelude.Monad.Internal -import Data.Singletons.Prelude.Monoid hiding - (SFirst(..), SLast(..), - FirstSym0, FirstSym1, LastSym0, LastSym1, - GetFirst, GetFirstSym0, GetFirstSym1, - GetLast, GetLastSym0, GetLastSym1) -import Data.Singletons.Prelude.Num -import Data.Singletons.Prelude.Ord hiding - (MinSym0, MinSym1, MaxSym0, MaxSym1) -import Data.Singletons.Prelude.Semigroup.Internal -import Data.Singletons.Prelude.Show -import Data.Singletons.Prelude.Traversable -import Data.Singletons.Single -import Data.Singletons.Util - -$(genSingletons [''Arg]) -$(showSingInstances $ ''Option : semigroupBasicTypes) -$(singShowInstances $ ''Option : semigroupBasicTypes) - -$(singletonsOnly [d| - instance Applicative Semi.Min where - pure = Semi.Min - a <* _ = a - _ *> a = a - Semi.Min f <*> Semi.Min x = Semi.Min (f x) - liftA2 f (Semi.Min a) (Semi.Min b) = Semi.Min (f a b) - - instance Enum a => Enum (Semi.Min a) where - succ (Semi.Min a) = Semi.Min (succ a) - pred (Semi.Min a) = Semi.Min (pred a) - toEnum = Semi.Min . toEnum - fromEnum (Semi.Min a) = fromEnum a - enumFromTo (Semi.Min a) (Semi.Min b) = Semi.Min `map` enumFromTo a b - enumFromThenTo (Semi.Min a) (Semi.Min b) (Semi.Min c) = Semi.Min `map` enumFromThenTo a b c - - deriving instance Functor Semi.Min - - instance Monad Semi.Min where - (>>) = (*>) - Semi.Min a >>= f = f a - - instance Ord a => Semigroup (Semi.Min a) where - Semi.Min a <> Semi.Min b = Semi.Min (a `min_` b) - - instance (Ord a, Bounded a) => Monoid (Semi.Min a) where - mempty = maxBound - - instance Num a => Num (Semi.Min a) where - (Semi.Min a) + (Semi.Min b) = Semi.Min (a + b) - (Semi.Min a) * (Semi.Min b) = Semi.Min (a * b) - (Semi.Min a) - (Semi.Min b) = Semi.Min (a - b) - negate (Semi.Min a) = Semi.Min (negate a) - abs (Semi.Min a) = Semi.Min (abs a) - signum (Semi.Min a) = Semi.Min (signum a) - fromInteger = Semi.Min . fromInteger - - deriving instance Foldable Semi.Min - deriving instance Traversable Semi.Min - - instance Applicative Semi.Max where - pure = Semi.Max - a <* _ = a - _ *> a = a - Semi.Max f <*> Semi.Max x = Semi.Max (f x) - liftA2 f (Semi.Max a) (Semi.Max b) = Semi.Max (f a b) - - instance Enum a => Enum (Semi.Max a) where - succ (Semi.Max a) = Semi.Max (succ a) - pred (Semi.Max a) = Semi.Max (pred a) - toEnum = Semi.Max . toEnum - fromEnum (Semi.Max a) = fromEnum a - enumFromTo (Semi.Max a) (Semi.Max b) = Semi.Max `map` enumFromTo a b - enumFromThenTo (Semi.Max a) (Semi.Max b) (Semi.Max c) = Semi.Max `map` enumFromThenTo a b c - - deriving instance Functor Semi.Max - - instance Monad Semi.Max where - (>>) = (*>) - Semi.Max a >>= f = f a - - instance Ord a => Semigroup (Semi.Max a) where - Semi.Max a <> Semi.Max b = Semi.Max (a `max_` b) - - instance (Ord a, Bounded a) => Monoid (Semi.Max a) where - mempty = minBound - - instance Num a => Num (Semi.Max a) where - (Semi.Max a) + (Semi.Max b) = Semi.Max (a + b) - (Semi.Max a) * (Semi.Max b) = Semi.Max (a * b) - (Semi.Max a) - (Semi.Max b) = Semi.Max (a - b) - negate (Semi.Max a) = Semi.Max (negate a) - abs (Semi.Max a) = Semi.Max (abs a) - signum (Semi.Max a) = Semi.Max (signum a) - fromInteger = Semi.Max . fromInteger - - deriving instance Foldable Semi.Max - deriving instance Traversable Semi.Max - - instance Eq a => Eq (Arg a b) where - Arg a _ == Arg b _ = a == b - - deriving instance Functor (Arg a) - - instance Ord a => Ord (Arg a b) where - Arg a _ `compare` Arg b _ = compare a b - min x@(Arg a _) y@(Arg b _) - | a <= b = x - | otherwise = y - max x@(Arg a _) y@(Arg b _) - | a >= b = x - | otherwise = y - - deriving instance (Show a, Show b) => Show (Arg a b) - deriving instance Foldable (Arg a) - deriving instance Traversable (Arg a) - - instance Applicative First where - pure x = First x - a <* _ = a - _ *> a = a - First f <*> First x = First (f x) - liftA2 f (First a) (First b) = First (f a b) - - instance Enum a => Enum (First a) where - succ (First a) = First (succ a) - pred (First a) = First (pred a) - toEnum = First . toEnum - fromEnum (First a) = fromEnum a - enumFromTo (First a) (First b) = First `map` enumFromTo a b - enumFromThenTo (First a) (First b) (First c) = First `map` enumFromThenTo a b c - - deriving instance Functor First - - instance Monad First where - (>>) = (*>) - First a >>= f = f a - - instance Semigroup (First a) where - a <> _ = a - - deriving instance Foldable First - deriving instance Traversable First - - instance Applicative Last where - pure x = Last x - a <* _ = a - _ *> a = a - Last f <*> Last x = Last (f x) - liftA2 f (Last a) (Last b) = Last (f a b) - - instance Enum a => Enum (Last a) where - succ (Last a) = Last (succ a) - pred (Last a) = Last (pred a) - toEnum = Last . toEnum - fromEnum (Last a) = fromEnum a - enumFromTo (Last a) (Last b) = Last `map` enumFromTo a b - enumFromThenTo (Last a) (Last b) (Last c) = Last `map` enumFromThenTo a b c - - deriving instance Functor Last - - instance Monad Last where - (>>) = (*>) - Last a >>= f = f a - - instance Semigroup (Last a) where - _ <> b = b - - deriving instance Foldable Last - deriving instance Traversable Last - - instance Monoid m => Semigroup (WrappedMonoid m) where - WrapMonoid a <> WrapMonoid b = WrapMonoid (a `mappend` b) - - instance Monoid m => Monoid (WrappedMonoid m) where - mempty = WrapMonoid mempty - - instance Enum a => Enum (WrappedMonoid a) where - succ (WrapMonoid a) = WrapMonoid (succ a) - pred (WrapMonoid a) = WrapMonoid (pred a) - toEnum = WrapMonoid . toEnum - fromEnum (WrapMonoid a) = fromEnum a - enumFromTo (WrapMonoid a) (WrapMonoid b) = WrapMonoid `map` enumFromTo a b - enumFromThenTo (WrapMonoid a) (WrapMonoid b) (WrapMonoid c) = - WrapMonoid `map` enumFromThenTo a b c - - instance Alternative Option where - empty = Option Nothing - Option Nothing <|> b = b - a@(Option Just{}) <|> _ = a - - instance Applicative Option where - pure a = Option (Just a) - Option a <*> Option b = Option (a <*> b) - liftA2 f (Option x) (Option y) = Option (liftA2 f x y) - - Option Nothing *> _ = Option Nothing - Option Just{} *> b = b - - deriving instance Functor Option - - instance Monad Option where - Option (Just a) >>= k = k a - Option Nothing >>= _ = Option Nothing - (>>) = (*>) - - instance MonadPlus Option - - -- deriving newtype instance Semigroup a => Semigroup (Option a) - instance Semigroup a => Semigroup (Option a) where - Option a <> Option b = Option (a <> b) - - instance Semigroup a => Monoid (Option a) where - mempty = Option Nothing - - instance Foldable Option where - foldMap f (Option (Just m)) = f m - foldMap _ (Option Nothing) = mempty - - instance Traversable Option where - traverse f (Option (Just a)) = Option . Just <$> f a - traverse _ (Option Nothing) = pure (Option Nothing) - |]) - -$(singletons [d| - -- Renamed to avoid name clash - -- -| Fold an 'Option' case-wise, just like 'maybe'. - option_ :: b -> (a -> b) -> Option a -> b - option_ n j (Option m) = maybe_ n j m - |]) diff --git a/src/Data/Singletons/Prelude/Semigroup/Internal.hs b/src/Data/Singletons/Prelude/Semigroup/Internal.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/Semigroup/Internal.hs +++ /dev/null @@ -1,282 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Semigroup.Internal --- Copyright : (C) 2018 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Defines the promoted version of 'Semigroup', 'PSemigroup'; the --- singleton version, 'SSemigroup'; and some @newtype@ wrappers, all --- of which are reexported from the "Data.Semigroup" module or --- imported directly by some other modules. --- --- This module exists to avoid import cycles with --- "Data.Singletons.Prelude.Monoid". --- ----------------------------------------------------------------------------- - -module Data.Singletons.Prelude.Semigroup.Internal where - -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Ord (Down(..)) -import Data.Proxy -import Data.Semigroup (Dual(..), All(..), Any(..), Sum(..), Product(..), Option(..)) -import Data.Singletons.Internal -import Data.Singletons.Prelude.Base -import Data.Singletons.Prelude.Bool -import Data.Singletons.Prelude.Enum -import Data.Singletons.Prelude.Eq -import Data.Singletons.Prelude.Instances -import Data.Singletons.Prelude.Monad.Internal -import Data.Singletons.Prelude.Num -import Data.Singletons.Prelude.Ord hiding (MinSym0, MinSym1, MaxSym0, MaxSym1) -import Data.Singletons.Promote -import Data.Singletons.Single -import Data.Singletons.TypeLits.Internal -import Data.Singletons.Util -import qualified Data.Text as T -import Data.Void (Void) - -import GHC.TypeLits (AppendSymbol, SomeSymbol(..), someSymbolVal) - -import Unsafe.Coerce - -$(singletonsOnly [d| - -- -| The class of semigroups (types with an associative binary operation). - -- - -- Instances should satisfy the associativity law: - -- - -- * @x '<>' (y '<>' z) = (x '<>' y) '<>' z@ - class Semigroup a where - -- -| An associative operation. - (<>) :: a -> a -> a - infixr 6 <> - - -- -| Reduce a non-empty list with @\<\>@ - -- - -- The default definition should be sufficient, but this can be - -- overridden for efficiency. - -- - sconcat :: NonEmpty a -> a - sconcat (a :| as) = go a as where - go :: a -> [a] -> a - go b (c:cs) = b <> go c cs - go b [] = b - - {- - Can't single 'stimes', since there's no singled 'Integral' class. - - -- -| Repeat a value @n@ times. - -- - -- Given that this works on a 'Semigroup' it is allowed to fail if - -- you request 0 or fewer repetitions, and the default definition - -- will do so. - -- - -- By making this a member of the class, idempotent semigroups - -- and monoids can upgrade this to execute in /O(1)/ by - -- picking @stimes = 'stimesIdempotent'@ or @stimes = - -- 'stimesIdempotentMonoid'@ respectively. - stimes :: Integral b => b -> a -> a - stimes = stimesDefault - -} - - - instance Semigroup [a] where - (<>) = (++) - - instance Semigroup (NonEmpty a) where - (a :| as) <> (b :| bs) = a :| (as ++ b : bs) - - instance Semigroup b => Semigroup (a -> b) where - f <> g = \x -> f x <> g x - - instance Semigroup () where - _ <> _ = () - sconcat _ = () - - instance (Semigroup a, Semigroup b) => Semigroup (a, b) where - (a,b) <> (a',b') = (a<>a',b<>b') - - instance (Semigroup a, Semigroup b, Semigroup c) => Semigroup (a, b, c) where - (a,b,c) <> (a',b',c') = (a<>a',b<>b',c<>c') - - instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d) - => Semigroup (a, b, c, d) where - (a,b,c,d) <> (a',b',c',d') = (a<>a',b<>b',c<>c',d<>d') - - instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d, Semigroup e) - => Semigroup (a, b, c, d, e) where - (a,b,c,d,e) <> (a',b',c',d',e') = (a<>a',b<>b',c<>c',d<>d',e<>e') - - instance Semigroup Ordering where - LT <> _ = LT - EQ <> y = y - GT <> _ = GT - - instance Semigroup a => Semigroup (Maybe a) where - Nothing <> b = b - a <> Nothing = a - Just a <> Just b = Just (a <> b) - - instance Semigroup (Either a b) where - Left _ <> b = b - -- a <> _ = a - a@Right{} <> _ = a - - instance Semigroup Void where - a <> _ = a - - -- deriving newtype instance Semigroup a => Semigroup (Down a) - instance Semigroup a => Semigroup (Down a) where - Down a <> Down b = Down (a <> b) - |]) - --- Workaround for #326 -infixr 6 <> - -$(genSingletons $ ''Option : semigroupBasicTypes) -$(singBoundedInstances semigroupBasicTypes) -$(singEqInstances $ ''Option : semigroupBasicTypes) -$(singDecideInstances $ ''Option : semigroupBasicTypes) -$(singOrdInstances $ ''Option : semigroupBasicTypes) - -$(singletonsOnly [d| - instance Applicative Dual where - pure = Dual - Dual f <*> Dual x = Dual (f x) - - deriving instance Functor Dual - - instance Monad Dual where - Dual a >>= k = k a - - instance Semigroup a => Semigroup (Dual a) where - Dual a <> Dual b = Dual (b <> a) - - instance Semigroup All where - All a <> All b = All (a && b) - - instance Semigroup Any where - Any a <> Any b = Any (a || b) - - instance Applicative Sum where - pure = Sum - Sum f <*> Sum x = Sum (f x) - - deriving instance Functor Sum - - instance Monad Sum where - Sum a >>= k = k a - - instance Num a => Semigroup (Sum a) where - Sum a <> Sum b = Sum (a + b) - - -- deriving newtype instance Num a => Num (Sum a) - instance Num a => Num (Sum a) where - Sum a + Sum b = Sum (a + b) - Sum a - Sum b = Sum (a - b) - Sum a * Sum b = Sum (a * b) - negate (Sum a) = Sum (negate a) - abs (Sum a) = Sum (abs a) - signum (Sum a) = Sum (signum a) - fromInteger n = Sum (fromInteger n) - - instance Applicative Product where - pure = Product - Product f <*> Product x = Product (f x) - - deriving instance Functor Product - - instance Monad Product where - Product a >>= k = k a - - instance Num a => Semigroup (Product a) where - Product a <> Product b = Product (a * b) - - -- deriving newtype instance Num a => Num (Product a) - instance Num a => Num (Product a) where - Product a + Product b = Product (a + b) - Product a - Product b = Product (a - b) - Product a * Product b = Product (a * b) - negate (Product a) = Product (negate a) - abs (Product a) = Product (abs a) - signum (Product a) = Product (signum a) - fromInteger n = Product (fromInteger n) - |]) - -instance PSemigroup Symbol where - type a <> b = AppendSymbol a b - -instance SSemigroup Symbol where - sa %<> sb = - let a = fromSing sa - b = fromSing sb - ex = someSymbolVal $ T.unpack $ a <> b - in case ex of - SomeSymbol (_ :: Proxy ab) -> unsafeCoerce (SSym :: Sing ab) - --- We need these in Data.Singletons.Prelude.Semigroup, as we need to promote --- code that simultaneously uses the Min/Max constructors and the min/max --- functions, which have clashing defunctionalization symbol names. Our --- workaround is to simply define synonyms for min/max and use those instead. -min_, max_ :: Ord a => a -> a -> a -min_ = min -max_ = max - -type Min_ x y = Min x y -type Max_ x y = Max x y -$(genDefunSymbols [''Min_, ''Max_]) - -sMin_ :: forall a (x :: a) (y :: a). SOrd a => Sing x -> Sing y -> Sing (x `Min_` y) -sMin_ = sMin - -sMax_ :: forall a (x :: a) (y :: a). SOrd a => Sing x -> Sing y -> Sing (x `Max_` y) -sMax_ = sMax - --- We need these in Data.Singletons.Prelude.Foldable. -all_ :: Bool -> All -all_ = All - -any_ :: Bool -> Any -any_ = Any - -sum_ :: a -> Sum a -sum_ = Sum - -product_ :: a -> Product a -product_ = Product - -type All_ a = 'All a -type Any_ a = 'Any a -type Sum_ a = 'Sum a -type Product_ a = 'Product a -$(genDefunSymbols [''All_, ''Any_, ''Sum_, ''Product_]) - -sAll_ :: forall (x :: Bool). Sing x -> Sing (All_ x) -sAll_ = SAll - -sAny_ :: forall (x :: Bool). Sing x -> Sing (Any_ x) -sAny_ = SAny - -sSum_ :: forall a (x :: a). Sing x -> Sing (Sum_ x) -sSum_ = SSum - -sProduct_ :: forall a (x :: a). Sing x -> Sing (Product_ x) -sProduct_ = SProduct diff --git a/src/Data/Singletons/Prelude/Show.hs b/src/Data/Singletons/Prelude/Show.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/Show.hs +++ /dev/null @@ -1,195 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Show --- Copyright : (C) 2017 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Defines the SShow singleton version of the Show type class. --- ------------------------------------------------------------------------------ - -module Data.Singletons.Prelude.Show ( - PShow(..), SShow(..), SymbolS, SChar, show_, - Shows, sShows, - ShowListWith, sShowListWith, - ShowChar, sShowChar, - ShowString, sShowString, - ShowParen, sShowParen, - ShowSpace, sShowSpace, - ShowCommaSpace, sShowCommaSpace, - AppPrec, sAppPrec, - AppPrec1, sAppPrec1, - - -- * Defunctionalization symbols - ShowsPrecSym0, ShowsPrecSym1, ShowsPrecSym2, ShowsPrecSym3, - Show_Sym0, Show_Sym1, - ShowListSym0, ShowListSym1, ShowListSym2, - ShowsSym0, ShowsSym1, ShowsSym2, - ShowListWithSym0, ShowListWithSym1, ShowListWithSym2, ShowListWithSym3, - ShowCharSym0, ShowCharSym1, ShowCharSym2, - ShowStringSym0, ShowStringSym1, ShowStringSym2, - ShowParenSym0, ShowParenSym1, ShowParenSym2, - ShowSpaceSym0, ShowSpaceSym1, - ShowCommaSpaceSym0, ShowCommaSpaceSym1, - AppPrecSym0, AppPrec1Sym0 - ) where - -import Data.List.NonEmpty (NonEmpty) -import Data.Ord (Down) -import Data.Proxy -import Data.Singletons.Internal -import Data.Singletons.Prelude.Base -import Data.Singletons.Prelude.Instances -import Data.Singletons.Prelude.List.Internal -import Data.Singletons.Prelude.Ord -import Data.Singletons.Prelude.Semigroup.Internal -import Data.Singletons.Promote -import Data.Singletons.Single -import Data.Singletons.TypeLits -import qualified Data.Text as T -import Data.Void - -import GHC.TypeLits - -import qualified Prelude as P -import Prelude hiding (Show(..)) - -import Unsafe.Coerce (unsafeCoerce) - --- | The @shows@ functions return a function that prepends the --- output 'Symbol' to an existing 'Symbol'. This allows constant-time --- concatenation of results using function composition. -type SymbolS = Symbol -> Symbol - --- | GHC currently has no notion of type-level 'Char's, so we fake them with --- single-character 'Symbol's. -type SChar = Symbol - -$(singletonsOnly [d| - class Show a where - showsPrec :: Nat -> a -> SymbolS - show_ :: a -> Symbol - showList :: [a] -> SymbolS - - showsPrec _ x s = show_ x <> s - show_ x = shows x "" - showList ls s = showListWith shows ls s - - shows :: Show a => a -> SymbolS - shows s = showsPrec 0 s - - showListWith :: (a -> SymbolS) -> [a] -> SymbolS - showListWith _ [] s = "[]" <> s - showListWith showx (x:xs) s = "[" <> showx x (showl xs) - where - showl [] = "]" <> s - showl (y:ys) = "," <> showx y (showl ys) - - showChar :: SChar -> SymbolS - showChar = (<>) - - showString :: Symbol -> SymbolS - showString = (<>) - - showParen :: Bool -> SymbolS -> SymbolS - showParen b p = if b then showChar "(" . p . showChar ")" else p - - showSpace :: SymbolS - showSpace = \xs -> " " <> xs - - showCommaSpace :: SymbolS - showCommaSpace = showString ", " - - appPrec, appPrec1 :: Nat - appPrec = 10 - appPrec1 = 11 - - instance Show a => Show [a] where - showsPrec _ = showList - - -- -| This is not an ideal Show instance for Symbol, since the Show instance - -- for String escapes special characters. Unfortunately, GHC lacks the ability - -- to case on individual characters in a Symbol (at least, not without GHC - -- plugins), so this is the best we can do for the time being. - instance Show Symbol where - showsPrec _ = showString - - show_tuple :: [SymbolS] -> SymbolS - show_tuple ss = showChar "(" - . foldr1 (\s r -> s . showChar "," . r) ss - . showChar ")" - - instance (Show a, Show b) => Show (a,b) where - showsPrec _ (a,b) s = show_tuple [shows a, shows b] s - - instance (Show a, Show b, Show c) => Show (a, b, c) where - showsPrec _ (a,b,c) s = show_tuple [shows a, shows b, shows c] s - - instance (Show a, Show b, Show c, Show d) => Show (a, b, c, d) where - showsPrec _ (a,b,c,d) s = show_tuple [shows a, shows b, shows c, shows d] s - - instance (Show a, Show b, Show c, Show d, Show e) => Show (a, b, c, d, e) where - showsPrec _ (a,b,c,d,e) s = show_tuple [shows a, shows b, shows c, shows d, shows e] s - - instance (Show a, Show b, Show c, Show d, Show e, Show f) => Show (a,b,c,d,e,f) where - showsPrec _ (a,b,c,d,e,f) s = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f] s - - instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g) - => Show (a,b,c,d,e,f,g) where - showsPrec _ (a,b,c,d,e,f,g) s - = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g] s - - deriving instance Show a => Show (Down a) - |]) - -$(promoteOnly [d| - showsNat :: Nat -> SymbolS - showsNat 0 = showChar "0" - showsNat 1 = showChar "1" - showsNat 2 = showChar "2" - showsNat 3 = showChar "3" - showsNat 4 = showChar "4" - showsNat 5 = showChar "5" - showsNat 6 = showChar "6" - showsNat 7 = showChar "7" - showsNat 8 = showChar "8" - showsNat 9 = showChar "9" - showsNat n = showsNat (n `div` 10) . showsNat (n `mod` 10) - |]) - -instance PShow Nat where - type ShowsPrec _ n x = ShowsNat n x - -instance SShow Nat where - sShowsPrec _ sn sx = - let n = fromSing sn - x = fromSing sx - ex = someSymbolVal (P.show n ++ T.unpack x) - in - case ex of - SomeSymbol (_ :: Proxy s) -> unsafeCoerce (SSym :: Sing s) - --- | 'P.show', but with an extra underscore so that its promoted counterpart --- ('Show_') will not clash with the 'Show' class. -show_ :: P.Show a => a -> String -show_ = P.show - -$(singShowInstances [ ''(), ''Maybe, ''Either, ''NonEmpty, ''Bool, - ''Ordering, ''Void ]) diff --git a/src/Data/Singletons/Prelude/Traversable.hs b/src/Data/Singletons/Prelude/Traversable.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/Traversable.hs +++ /dev/null @@ -1,289 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Traversable --- Copyright : (C) 2018 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Defines the promoted and singled versions of the 'Traversable' type class. --- ----------------------------------------------------------------------------- - -module Data.Singletons.Prelude.Traversable ( - PTraversable(..), STraversable(..), - For, sFor, - ForM, sForM, - MapAccumL, sMapAccumL, - MapAccumR, sMapAccumR, - FmapDefault, sFmapDefault, - FoldMapDefault, sFoldMapDefault, - - -- * Defunctionalization symbols - TraverseSym0, TraverseSym1, TraverseSym2, - SequenceASym0, SequenceASym1, - MapMSym0, MapMSym1, MapMSym2, - SequenceSym0, SequenceSym1, - - ForSym0, ForSym1, ForSym2, - ForMSym0, ForMSym1, ForMSym2, - MapAccumLSym0, MapAccumLSym1, MapAccumLSym2, MapAccumLSym3, - MapAccumRSym0, MapAccumRSym1, MapAccumRSym2, MapAccumRSym3, - FmapDefaultSym0, FmapDefaultSym1, FmapDefaultSym2, - FoldMapDefaultSym0, FoldMapDefaultSym1, FoldMapDefaultSym2 - ) where - -import Control.Applicative -import Data.Functor.Identity -import Data.Kind -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Monoid -import Data.Singletons.Internal -import Data.Singletons.Prelude.Base hiding (Const, ConstSym0) -import Data.Singletons.Prelude.Const -import Data.Singletons.Prelude.Foldable (SFoldable) -import Data.Singletons.Prelude.Functor -import Data.Singletons.Prelude.Identity -import Data.Singletons.Prelude.Instances -import Data.Singletons.Prelude.Monad.Internal -import Data.Singletons.Prelude.Monoid -import Data.Singletons.Single - -newtype StateL s a = StateL (s ~> (s, a)) -data SStateL :: forall s a. StateL s a -> Type where - SStateL :: Sing x -> SStateL ('StateL x) -type instance Sing = SStateL -data StateLSym0 :: forall s a. (s ~> (s, a)) ~> StateL s a -type instance Apply StateLSym0 x = 'StateL x - -newtype StateR s a = StateR (s ~> (s, a)) -data SStateR :: forall s a. StateR s a -> Type where - SStateR :: Sing x -> SStateR ('StateR x) -type instance Sing = SStateR -data StateRSym0 :: forall s a. (s ~> (s, a)) ~> StateR s a -type instance Apply StateRSym0 x = 'StateR x - -$(singletonsOnly [d| - -- -| Functors representing data structures that can be traversed from - -- left to right. - -- - -- A definition of 'traverse' must satisfy the following laws: - -- - -- [/naturality/] - -- @t . 'traverse' f = 'traverse' (t . f)@ - -- for every applicative transformation @t@ - -- - -- [/identity/] - -- @'traverse' Identity = Identity@ - -- - -- [/composition/] - -- @'traverse' (Compose . 'fmap' g . f) = Compose . 'fmap' ('traverse' g) . 'traverse' f@ - -- - -- A definition of 'sequenceA' must satisfy the following laws: - -- - -- [/naturality/] - -- @t . 'sequenceA' = 'sequenceA' . 'fmap' t@ - -- for every applicative transformation @t@ - -- - -- [/identity/] - -- @'sequenceA' . 'fmap' Identity = Identity@ - -- - -- [/composition/] - -- @'sequenceA' . 'fmap' Compose = Compose . 'fmap' 'sequenceA' . 'sequenceA'@ - -- - -- where an /applicative transformation/ is a function - -- - -- @t :: (Applicative f, Applicative g) => f a -> g a@ - -- - -- preserving the 'Applicative' operations, i.e. - -- - -- * @t ('pure' x) = 'pure' x@ - -- - -- * @t (x '<*>' y) = t x '<*>' t y@ - -- - -- and the identity functor @Identity@ and composition of functors @Compose@ - -- are defined as - -- - -- > newtype Identity a = Identity a - -- > - -- > instance Functor Identity where - -- > fmap f (Identity x) = Identity (f x) - -- > - -- > instance Applicative Identity where - -- > pure x = Identity x - -- > Identity f <*> Identity x = Identity (f x) - -- > - -- > newtype Compose f g a = Compose (f (g a)) - -- > - -- > instance (Functor f, Functor g) => Functor (Compose f g) where - -- > fmap f (Compose x) = Compose (fmap (fmap f) x) - -- > - -- > instance (Applicative f, Applicative g) => Applicative (Compose f g) where - -- > pure x = Compose (pure (pure x)) - -- > Compose f <*> Compose x = Compose ((<*>) <$> f <*> x) - -- - -- (The naturality law is implied by parametricity.) - -- - -- Instances are similar to 'Functor', e.g. given a data type - -- - -- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a) - -- - -- a suitable instance would be - -- - -- > instance Traversable Tree where - -- > traverse f Empty = pure Empty - -- > traverse f (Leaf x) = Leaf <$> f x - -- > traverse f (Node l k r) = Node <$> traverse f l <*> f k <*> traverse f r - -- - -- This is suitable even for abstract types, as the laws for '<*>' - -- imply a form of associativity. - -- - -- The superclass instances should satisfy the following: - -- - -- * In the 'Functor' instance, 'fmap' should be equivalent to traversal - -- with the identity applicative functor ('fmapDefault'). - -- - -- * In the 'Foldable' instance, 'Data.Foldable.foldMap' should be - -- equivalent to traversal with a constant applicative functor - -- ('foldMapDefault'). - -- - class (Functor t, Foldable t) => Traversable (t :: Type -> Type) where - -- {-# MINIMAL traverse | sequenceA #-} - - -- -| Map each element of a structure to an action, evaluate these actions - -- from left to right, and collect the results. For a version that ignores - -- the results see 'Data.Foldable.traverse_'. - traverse :: Applicative f => (a -> f b) -> t a -> f (t b) - traverse f = sequenceA . fmap f - - -- -| Evaluate each action in the structure from left to right, and - -- and collect the results. For a version that ignores the results - -- see 'Data.Foldable.sequenceA_'. - sequenceA :: Applicative f => t (f a) -> f (t a) - sequenceA = traverse id - - -- -| Map each element of a structure to a monadic action, evaluate - -- these actions from left to right, and collect the results. For - -- a version that ignores the results see 'Data.Foldable.mapM_'. - mapM :: Monad m => (a -> m b) -> t a -> m (t b) - mapM = traverse - - -- -| Evaluate each monadic action in the structure from left to - -- right, and collect the results. For a version that ignores the - -- results see 'Data.Foldable.sequence_'. - sequence :: Monad m => t (m a) -> m (t a) - sequence = sequenceA - |]) - -$(singletonsOnly [d| - -- instances for Prelude types - - deriving instance Traversable Maybe - deriving instance Traversable [] - deriving instance Traversable NonEmpty - deriving instance Traversable (Either a) - deriving instance Traversable ((,) a) - deriving instance Traversable (Const m) - deriving instance Traversable Dual - deriving instance Traversable Sum - deriving instance Traversable Product - deriving instance Traversable First - deriving instance Traversable Last - deriving instance Traversable Identity - - -- general functions - - -- -| 'for' is 'traverse' with its arguments flipped. For a version - -- that ignores the results see 'Data.Foldable.for_'. - for :: (Traversable t, Applicative f) => t a -> (a -> f b) -> f (t b) - for = flip traverse - - -- -| 'forM' is 'mapM' with its arguments flipped. For a version that - -- ignores the results see 'Data.Foldable.forM_'. - forM :: (Traversable t, Monad m) => t a -> (a -> m b) -> m (t b) - forM = flip mapM - - instance Functor (StateL s) where - fmap f (StateL k) = StateL $ \ s -> let (s', v) = k s in (s', f v) - - instance Applicative (StateL s) where - pure x = StateL (\ s -> (s, x)) - StateL kf <*> StateL kv = StateL $ \ s -> - let (s', f) = kf s - (s'', v) = kv s' - in (s'', f v) - liftA2 f (StateL kx) (StateL ky) = StateL $ \s -> - let (s', x) = kx s - (s'', y) = ky s' - in (s'', f x y) - - instance Functor (StateR s) where - fmap f (StateR k) = StateR $ \ s -> let (s', v) = k s in (s', f v) - - instance Applicative (StateR s) where - pure x = StateR (\ s -> (s, x)) - StateR kf <*> StateR kv = StateR $ \ s -> - let (s', v) = kv s - (s'', f) = kf s' - in (s'', f v) - liftA2 f (StateR kx) (StateR ky) = StateR $ \ s -> - let (s', y) = ky s - (s'', x) = kx s' - in (s'', f x y) - - -- -|The 'mapAccumL' function behaves like a combination of 'fmap' - -- and 'foldl'; it applies a function to each element of a structure, - -- passing an accumulating parameter from left to right, and returning - -- a final value of this accumulator together with the new structure. - mapAccumL :: forall t a b c. Traversable t - => (a -> b -> (a, c)) -> a -> t b -> (a, t c) - mapAccumL f s t = case traverse (StateL . flip f) t of - StateL g -> g s - - -- -|The 'mapAccumR' function behaves like a combination of 'fmap' - -- and 'foldr'; it applies a function to each element of a structure, - -- passing an accumulating parameter from right to left, and returning - -- a final value of this accumulator together with the new structure. - mapAccumR :: Traversable t => (a -> b -> (a, c)) -> a -> t b -> (a, t c) - mapAccumR f s t = case traverse (StateR . flip f) t of - StateR g -> g s - - -- -| This function may be used as a value for `fmap` in a `Functor` - -- instance, provided that 'traverse' is defined. (Using - -- `fmapDefault` with a `Traversable` instance defined only by - -- 'sequenceA' will result in infinite recursion.) - -- - -- @ - -- 'fmapDefault' f ≡ 'runIdentity' . 'traverse' ('Identity' . f) - -- @ - fmapDefault :: forall t a b . Traversable t - => (a -> b) -> t a -> t b - fmapDefault f x = case traverse (Identity . f) x of Identity y -> y - - -- -| This function may be used as a value for `Data.Foldable.foldMap` - -- in a `Foldable` instance. - -- - -- @ - -- 'foldMapDefault' f ≡ 'getConst' . 'traverse' ('Const' . f) - -- @ - foldMapDefault :: forall t m a . (Traversable t, Monoid m) - => (a -> m) -> t a -> m - foldMapDefault f x = case traverse (mkConst . f) x of Const y -> y - where - mkConst :: m -> Const m () - mkConst = Const - |]) diff --git a/src/Data/Singletons/Prelude/Tuple.hs b/src/Data/Singletons/Prelude/Tuple.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/Tuple.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, DataKinds, PolyKinds, - RankNTypes, TypeFamilies, GADTs, UndecidableInstances, - TypeApplications #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Tuple --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- 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(..), - - -- * 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.Single - -$(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/Prelude/Void.hs b/src/Data/Singletons/Prelude/Void.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/Void.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Void --- Copyright : (C) 2017 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Defines functions and datatypes relating to the singleton for 'Void', --- including a singleton version of all the definitions in @Data.Void@. --- --- 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.Void@. Also, please excuse --- the apparent repeated variable names. This is due to an interaction --- between Template Haskell and Haddock. --- ----------------------------------------------------------------------------- -module Data.Singletons.Prelude.Void ( - -- * The 'Void' singleton - Sing, - -- | Just as 'Void' has no constructors, the 'Sing' instance above also has - -- no constructors. - - SVoid, - -- | 'SVoid' is a kind-restricted synonym for 'Sing': - -- @type SVoid (a :: Void) = Sing a@ - - -- * Singletons from @Data.Void@ - Absurd, sAbsurd, - - -- * Defunctionalization symbols - AbsurdSym0, AbsurdSym1 - ) where - -import Data.Singletons.Internal -import Data.Singletons.Prelude.Instances -import Data.Singletons.Single -import Data.Void - -$(singletonsOnly [d| - -- -| Since 'Void' values logically don't exist, this witnesses the - -- logical reasoning tool of \"ex falso quodlibet\". - absurd :: Void -> a - absurd a = case a of {} - |]) diff --git a/src/Data/Singletons/Promote.hs b/src/Data/Singletons/Promote.hs deleted file mode 100644 --- a/src/Data/Singletons/Promote.hs +++ /dev/null @@ -1,830 +0,0 @@ -{- Data/Singletons/Promote.hs - -(c) Richard Eisenberg 2013 -rae@cs.brynmawr.edu - -This file contains functions to promote term-level constructs to the -type level. It is an internal module to the singletons package. --} - -{-# LANGUAGE TemplateHaskell, 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 qualified Language.Haskell.TH.Desugar.OMap.Strict as OMap -import Language.Haskell.TH.Desugar.OMap.Strict (OMap) -import qualified Language.Haskell.TH.Desugar.OSet as OSet -import Language.Haskell.TH.Desugar.OSet (OSet) -import Data.Singletons.Names -import Data.Singletons.Promote.Monad -import Data.Singletons.Promote.Eq -import Data.Singletons.Promote.Defun -import Data.Singletons.Promote.Type -import Data.Singletons.Deriving.Ord -import Data.Singletons.Deriving.Bounded -import Data.Singletons.Deriving.Enum -import Data.Singletons.Deriving.Show -import Data.Singletons.Deriving.Util -import Data.Singletons.Partition -import Data.Singletons.Util -import Data.Singletons.Syntax -import Prelude hiding (exp) -import Control.Applicative (Alternative(..)) -import Control.Arrow (second) -import Control.Monad -import Control.Monad.Trans.Maybe -import Control.Monad.Writer -import qualified Data.Map.Strict as Map -import Data.Map.Strict ( Map ) -import Data.Maybe -import qualified GHC.LanguageExtensions.Type as LangExt - --- | Generate promoted definitions from a type that is already defined. --- This is generally only useful with classes. -genPromotions :: DsMonad q => [Name] -> q [Dec] -genPromotions names = do - checkForRep names - infos <- mapM reifyWithLocals 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 :: DsMonad q => q [Dec] -> q [Dec] -promote qdec = do - decls <- qdec - ddecls <- withLocalDeclarations decls $ dsDecs decls - promDecls <- promoteM_ decls $ promoteDecs ddecls - return $ decls ++ decsToTH promDecls - --- | Promote each declaration, discarding the originals. Note that a promoted --- datatype uses the same definition as an original datatype, so this will --- not work with datatypes. Classes, instances, and functions are all fine. -promoteOnly :: DsMonad q => q [Dec] -> q [Dec] -promoteOnly qdec = do - decls <- qdec - ddecls <- dsDecs decls - promDecls <- promoteM_ decls $ promoteDecs ddecls - return $ decsToTH promDecls - --- | Generate defunctionalization symbols for existing type families. --- --- 'genDefunSymbols' has reasonable support for type families that use --- dependent quantification. For instance, this: --- --- @ --- type family MyProxy k (a :: k) :: Type where --- MyProxy k (a :: k) = Proxy a --- --- $('genDefunSymbols' [''MyProxy]) --- @ --- --- Will generate the following defunctionalization symbols: --- --- @ --- data MyProxySym0 :: Type ~> k ~> Type --- data MyProxySym1 (k :: Type) :: k ~> Type --- @ --- --- Note that @MyProxySym0@ is a bit more general than it ought to be, since --- there is no dependency between the first kind (@Type@) and the second kind --- (@k@). But this would require the ability to write something like: --- --- @ --- data MyProxySym0 :: forall (k :: Type) ~> k ~> Type --- @ --- --- Which currently isn't possible. So for the time being, the kind of --- @MyProxySym0@ will be slightly more general, which means that under rare --- circumstances, you may have to provide extra type signatures if you write --- code which exploits the dependency in @MyProxy@'s kind. -genDefunSymbols :: DsMonad q => [Name] -> q [Dec] -genDefunSymbols names = do - checkForRep names - infos <- mapM (dsInfo <=< reifyWithLocals) names - decs <- promoteMDecs [] $ concatMapM defunInfo infos - return $ decsToTH decs - --- | Produce instances for @(==)@ (type-level equality) from the given types -promoteEqInstances :: DsMonad q => [Name] -> q [Dec] -promoteEqInstances = concatMapM promoteEqInstance - --- | Produce instances for 'POrd' from the given types -promoteOrdInstances :: DsMonad q => [Name] -> q [Dec] -promoteOrdInstances = concatMapM promoteOrdInstance - --- | Produce an instance for 'POrd' from the given type -promoteOrdInstance :: DsMonad q => Name -> q [Dec] -promoteOrdInstance = promoteInstance mkOrdInstance "Ord" - --- | Produce instances for 'PBounded' from the given types -promoteBoundedInstances :: DsMonad q => [Name] -> q [Dec] -promoteBoundedInstances = concatMapM promoteBoundedInstance - --- | Produce an instance for 'PBounded' from the given type -promoteBoundedInstance :: DsMonad q => Name -> q [Dec] -promoteBoundedInstance = promoteInstance mkBoundedInstance "Bounded" - --- | Produce instances for 'PEnum' from the given types -promoteEnumInstances :: DsMonad q => [Name] -> q [Dec] -promoteEnumInstances = concatMapM promoteEnumInstance - --- | Produce an instance for 'PEnum' from the given type -promoteEnumInstance :: DsMonad q => Name -> q [Dec] -promoteEnumInstance = promoteInstance mkEnumInstance "Enum" - --- | Produce instances for 'PShow' from the given types -promoteShowInstances :: DsMonad q => [Name] -> q [Dec] -promoteShowInstances = concatMapM promoteShowInstance - --- | Produce an instance for 'PShow' from the given type -promoteShowInstance :: DsMonad q => Name -> q [Dec] -promoteShowInstance = promoteInstance (mkShowInstance ForPromotion) "Show" - --- | Produce an instance for @(==)@ (type-level equality) from the given type -promoteEqInstance :: DsMonad q => Name -> q [Dec] -promoteEqInstance name = do - (tvbs, cons) <- getDataD "I cannot make an instance of (==) for it." name - tvbs' <- mapM dsTvb tvbs - let data_ty = foldTypeTvbs (DConT name) tvbs' - cons' <- concatMapM (dsCon tvbs' data_ty) cons - kind <- promoteType (foldTypeTvbs (DConT name) tvbs') - inst_decs <- mkEqTypeInstance kind cons' - return $ decsToTH inst_decs - -promoteInstance :: DsMonad q => DerivDesc q -> String -> Name -> q [Dec] -promoteInstance mk_inst class_name name = do - (tvbs, cons) <- getDataD ("I cannot make an instance of " ++ class_name - ++ " for it.") name - tvbs' <- mapM dsTvb tvbs - let data_ty = foldTypeTvbs (DConT name) tvbs' - cons' <- concatMapM (dsCon tvbs' data_ty) cons - let data_decl = DataDecl name tvbs' cons' - raw_inst <- mk_inst Nothing data_ty data_decl - decs <- promoteM_ [] $ void $ promoteInstanceDec OMap.empty raw_inst - return $ decsToTH decs - -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) = - fail "Promotion of individual values not supported" -promoteInfo (DTyVarI _name _ty) = - fail "Promotion of individual type variables not supported" -promoteInfo (DPatSynI {}) = - fail "Promotion of pattern synonyms 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) :: 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 raw_decls = do - decls <- expand raw_decls -- expand type synonyms - checkForRepInDecls decls - PDecs { pd_let_decs = let_decs - , pd_class_decs = classes - , pd_instance_decs = insts - , pd_data_decs = datas - , pd_ty_syn_decs = ty_syns - , pd_open_type_family_decs = o_tyfams - , pd_closed_type_family_decs = c_tyfams - , pd_derived_eq_decs = derived_eq_decs } <- partitionDecs decls - - defunTypeDecls ty_syns c_tyfams o_tyfams - -- promoteLetDecs returns LetBinds, which we don't need at top level - _ <- promoteLetDecs noPrefix let_decs - mapM_ promoteClassDec classes - let orig_meth_sigs = foldMap (lde_types . cd_lde) classes - mapM_ (promoteInstanceDec orig_meth_sigs) insts - mapM_ promoteDerivedEqDec derived_eq_decs - 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 data_name tvbs cons) = - let arg_ty = foldTypeTvbs (DConT data_name) tvbs - in - getRecordSelectors arg_ty cons - --- curious about ALetDecEnv? See the LetDecEnv module for an explanation. -promoteLetDecs :: (String, String) -- (alpha, symb) prefixes to use - -> [DLetDec] -> PrM ([LetBind], ALetDecEnv) - -- See Note [Promoting declarations in two stages] -promoteLetDecs prefixes decls = do - let_dec_env <- buildLetDecEnv decls - all_locals <- allLocals - let binds = [ (name, foldType (DConT sym) (map DVarT all_locals)) - | (name, _) <- OMap.assocs $ lde_defns let_dec_env - , let proName = promoteValNameLhsPrefix prefixes name - sym = promoteTySym proName (length all_locals) ] - (decs, let_dec_env') <- letBind binds $ promoteLetDecEnv prefixes let_dec_env - emitDecs decs - return (binds, let_dec_env' { lde_proms = OMap.fromList binds }) - --- Promotion of data types to kinds is automatic (see "Giving 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 _name _tvbs ctors) = do - ctorSyms <- buildDefunSymsDataD ctors - emitDecs ctorSyms - --- Note [CUSKification] --- ~~~~~~~~~~~~~~~~~~~~ --- GHC #12928 means that sometimes, this TH code will produce a declaration --- that has a kind signature even when we want kind inference to work. There --- seems to be no way to avoid this, so we embrace it: --- --- * If a class type variable has no explicit kind, we make no effort to --- guess it and default to *. This is OK because before GHC 8.0, we were --- limited by KProxy anyway. --- --- * If a class type variable has an explicit kind, it is preserved. --- --- This way, we always get proper CUSKs where we need them. - -promoteClassDec :: UClassDecl - -> PrM AClassDecl -promoteClassDec decl@(ClassDecl { cd_name = cls_name - , cd_tvbs = tvbs' - , cd_fds = fundeps - , cd_lde = lde@LetDecEnv - { lde_defns = defaults - , lde_types = meth_sigs - , lde_infix = infix_decls } }) = do - let - -- a workaround for GHC Trac #12928; see Note [CUSKification] - tvbs = map cuskify tvbs' - let pClsName = promoteClassName cls_name - forallBind cls_kvs_to_bind $ do - sig_decs <- mapM (uncurry promote_sig) (OMap.assocs meth_sigs) - let defaults_list = OMap.assocs defaults - defaults_names = map fst defaults_list - (default_decs, ann_rhss, prom_rhss) - <- mapAndUnzip3M (promoteMethod OMap.empty Nothing meth_sigs) defaults_list - - let infix_decls' = catMaybes $ map (uncurry promoteInfixDecl) - $ OMap.assocs infix_decls - - -- no need to do anything to the fundeps. They work as is! - emitDecs [DClassD [] pClsName tvbs fundeps - (sig_decs ++ default_decs ++ infix_decls')] - let defaults_list' = zip defaults_names ann_rhss - proms = zip defaults_names prom_rhss - cls_kvs_to_bind' = cls_kvs_to_bind <$ meth_sigs - return (decl { cd_lde = lde { lde_defns = OMap.fromList defaults_list' - , lde_proms = OMap.fromList proms - , lde_bound_kvs = cls_kvs_to_bind' } }) - where - cls_kvb_names, cls_tvb_names, cls_kvs_to_bind :: OSet Name - cls_kvb_names = foldMap (foldMap fvDType . extractTvbKind) tvbs' - cls_tvb_names = OSet.fromList $ map extractTvbName tvbs' - cls_kvs_to_bind = cls_kvb_names `OSet.union` cls_tvb_names - - promote_sig :: Name -> DType -> PrM DDec - promote_sig name ty = do - let proName = promoteValNameLhs name - (argKs, resK) <- promoteUnraveled ty - args <- mapM (const $ qNewName "arg") argKs - let tvbs = zipWith DKindedTV args argKs - emitDecsM $ defunReifyFixity proName tvbs (Just resK) - - return $ DOpenTypeFamilyD (DTypeFamilyHead proName - tvbs - (DKindSig resK) - Nothing) - --- returns (unpromoted method name, ALetDecRHS) pairs -promoteInstanceDec :: OMap Name DType -> UInstDecl -> PrM AInstDecl -promoteInstanceDec orig_meth_sigs - decl@(InstDecl { id_name = cls_name - , id_arg_tys = inst_tys - , id_sigs = inst_sigs - , id_meths = meths }) = do - cls_tvb_names <- lookup_cls_tvb_names - inst_kis <- mapM promoteType inst_tys - let kvs_to_bind = foldMap fvDType inst_kis - forallBind kvs_to_bind $ do - let subst = Map.fromList $ zip cls_tvb_names inst_kis - (meths', ann_rhss, _) <- mapAndUnzip3M (promoteMethod inst_sigs (Just subst) orig_meth_sigs) meths - emitDecs [DInstanceD Nothing Nothing [] (foldType (DConT pClsName) - inst_kis) meths'] - return (decl { id_meths = zip (map fst meths) ann_rhss }) - where - pClsName = promoteClassName cls_name - - lookup_cls_tvb_names :: PrM [Name] - lookup_cls_tvb_names = do - let mk_tvb_names = extract_tvb_names (dsReifyTypeNameInfo pClsName) - <|> extract_tvb_names (dsReifyTypeNameInfo cls_name) - -- See Note [Using dsReifyTypeNameInfo when promoting instances] - mb_tvb_names <- runMaybeT mk_tvb_names - case mb_tvb_names of - Just tvb_names -> pure tvb_names - Nothing -> fail $ "Cannot find class declaration annotation for " ++ show cls_name - - extract_tvb_names :: PrM (Maybe DInfo) -> MaybeT PrM [Name] - extract_tvb_names reify_info = do - mb_info <- lift reify_info - case mb_info of - Just (DTyConI (DClassD _ _ tvbs _ _) _) - -> pure $ map extractTvbName tvbs - _ -> empty - -{- -Note [Using dsReifyTypeNameInfo when promoting instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -During the promotion of a class instance, it becomes necessary to reify the -original promoted class's info to learn various things. It's tempting to think -that just calling dsReify on the class name will be sufficient, but it's not. -Consider this class and its promotion: - - class Eq a where - (==) :: a -> a -> Bool - - class PEq a where - type (==) (x :: a) (y :: a) :: Bool - -Notice how both of these classes have an identifier named (==), one at the -value level, and one at the type level. Now imagine what happens when you -attempt to promote this Template Haskell declaration: - - [d| f :: Bool - f = () == () |] - -When promoting ==, singletons will come up with its promoted equivalent (which also -happens to be ==). However, this promoted name is a raw Name, since it is created -with mkName. This becomes an issue when we call dsReify the raw "==" Name, as -Template Haskell has to arbitrarily choose between reifying the info for the -value-level (==) and the type-level (==), and in this case, it happens to pick the -value-level (==) info. We want the type-level (==) info, however, because we care -about the promoted version of (==). - -Fortunately, there's a serviceable workaround. Instead of dsReify, we can use -dsReifyTypeNameInfo, which first calls lookupTypeName (to ensure we can find a Name -that's in the type namespace) and _then_ reifies it. --} - -promoteMethod :: OMap Name DType -- InstanceSigs for methods - -> Maybe (Map Name DKind) - -- ^ instantiations for class tyvars (Nothing for default decls) - -- See Note [Promoted class method kinds] - -> OMap Name DType -- method types - -> (Name, ULetDecRHS) - -> PrM (DDec, ALetDecRHS, DType) - -- returns (type instance, ALetDecRHS, promoted RHS) -promoteMethod inst_sigs_map m_subst orig_sigs_map (meth_name, meth_rhs) = do - (meth_arg_kis, meth_res_ki) <- lookup_meth_ty - meth_arg_tvs <- mapM (const $ qNewName "a") meth_arg_kis - let helperNameBase = case nameBase proName of - first:_ | not (isHsLetter first) -> "TFHelper" - alpha -> alpha - - -- family_args are the type variables in a promoted class's - -- associated type family instance (or default implementation), e.g., - -- - -- class C k where - -- type T (a :: k) (b :: Bool) - -- type T a b = THelper1 a b -- family_args = [a, b] - -- - -- instance C Bool where - -- type T a b = THelper2 a b -- family_args = [a, b] - -- - -- We could annotate these variables with explicit kinds, but it's not - -- strictly necessary, as kind inference can figure them out just as well. - family_args = map DVarT meth_arg_tvs - helperName <- newUniqueName helperNameBase - let proHelperName = promoteValNameLhs helperName - ((_, _, _, eqns), _defuns, ann_rhs) - <- promoteLetDecRHS (Just (meth_arg_kis, meth_res_ki)) OMap.empty OMap.empty - noPrefix helperName meth_rhs - let tvbs = zipWith DKindedTV meth_arg_tvs meth_arg_kis - emitDecs [DClosedTypeFamilyD (DTypeFamilyHead - proHelperName - tvbs - (DKindSig meth_res_ki) - Nothing) - eqns] - emitDecsM (defunctionalize proHelperName Nothing tvbs (Just meth_res_ki)) - return ( DTySynInstD - (DTySynEqn Nothing - (foldType (DConT proName) family_args) - (foldApply (promoteValRhs helperName) (map DVarT meth_arg_tvs))) - , ann_rhs - , DConT (promoteTySym helperName 0) ) - where - proName = promoteValNameLhs meth_name - - lookup_meth_ty :: PrM ([DKind], DKind) - lookup_meth_ty = - case OMap.lookup meth_name inst_sigs_map of - Just ty -> - -- We have an InstanceSig. These are easy: no substitution for clas - -- variables is required at all! - promoteUnraveled ty - Nothing -> do - -- We don't have an InstanceSig, so we must compute the kind to use - -- ourselves (possibly substituting for class variables below). - (arg_kis, res_ki) <- - case OMap.lookup meth_name orig_sigs_map of - Nothing -> do - mb_info <- dsReifyTypeNameInfo proName - -- See Note [Using dsReifyTypeNameInfo when promoting instances] - case mb_info of - Just (DTyConI (DOpenTypeFamilyD (DTypeFamilyHead _ tvbs mb_res_ki _)) _) - -> let arg_kis = map (default_to_star . extractTvbKind) tvbs - res_ki = default_to_star (resultSigToMaybeKind mb_res_ki) - in return (arg_kis, res_ki) - _ -> fail $ "Cannot find type annotation for " ++ show proName - Just ty -> promoteUnraveled ty - let -- If we're dealing with an associated type family instance, substitute - -- in the kind of the instance for better kind information in the RHS - -- helper function. If we're dealing with a default family implementation - -- (m_subst = Nothing), there's no need for a substitution. - -- See Note [Promoted class method kinds] - do_subst = maybe id substKind m_subst - meth_arg_kis' = map do_subst arg_kis - meth_res_ki' = do_subst res_ki - pure (meth_arg_kis', meth_res_ki') - - default_to_star Nothing = DConT typeKindName - default_to_star (Just k) = k - -{- -Note [Promoted class method kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this example of a type class (and instance): - - class C a where - m :: a -> Bool -> Bool - m _ x = x - - instance C [a] where - m l _ = null l - -The promoted version of these declarations would be: - - class PC a where - type M (x :: a) (y :: Bool) (z :: Bool) - type M x y z = MHelper1 x y z - - instance PC [a] where - type M x y z = MHelper2 x y z - - type family MHelper1 (x :: a) (y :: Bool) (z :: Bool) where ... - type family MHelper2 (x :: [a]) (y :: Bool) (z :: Bool) where ... - -Getting the kind signature for MHelper1 (the promoted default implementation of -M) is quite simple, as it corresponds exactly to the kind of M. We might even -choose to make that the kind of MHelper2, but then it would be overly general -(and more difficult to find in -ddump-splices output). For this reason, we -substitute in the kinds of the instance itself to determine the kinds of -promoted method implementations like MHelper2. --} - -promoteLetDecEnv :: (String, String) -> ULetDecEnv -> PrM ([DDec], ALetDecEnv) -promoteLetDecEnv prefixes (LetDecEnv { lde_defns = value_env - , lde_types = type_env - , lde_infix = fix_env }) = do - let infix_decls = catMaybes $ map (uncurry promoteInfixDecl) - $ OMap.assocs fix_env - - -- promote all the declarations, producing annotated declarations - let (names, rhss) = unzip $ OMap.assocs value_env - (payloads, defun_decss, ann_rhss) - <- fmap unzip3 $ zipWithM (promoteLetDecRHS Nothing type_env fix_env prefixes) names rhss - - emitDecs $ concat defun_decss - bound_kvs <- allBoundKindVars - let decs = map payload_to_dec payloads ++ infix_decls - - -- build the ALetDecEnv - let let_dec_env' = LetDecEnv { lde_defns = OMap.fromList $ zip names ann_rhss - , lde_types = type_env - , lde_infix = fix_env - , lde_proms = OMap.empty -- filled in promoteLetDecs - , lde_bound_kvs = OMap.fromList $ map (, bound_kvs) names } - - return (decs, let_dec_env') - where - payload_to_dec (name, tvbs, m_ki, eqns) = DClosedTypeFamilyD - (DTypeFamilyHead name tvbs sig Nothing) - eqns - where - sig = maybe DNoSig DKindSig m_ki - -promoteInfixDecl :: Name -> Fixity -> Maybe DDec -promoteInfixDecl name fixity - | nameBase name == nameBase promoted_name - -- If a name and its promoted counterpart are the same (modulo module - -- prefixes), then there's no need to promote a fixity declaration for - -- that name, since the existing fixity declaration will cover both - -- the term- and type-level versions of that name. Names that fall into this - -- category include data constructor names and infix names. - = Nothing - | otherwise - = Just $ DLetDec $ DInfixD fixity promoted_name - where - promoted_name = 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 intermediate structure. Perhaps a better design is available. -promoteLetDecRHS :: Maybe ([DKind], DKind) -- the promoted type of the RHS (if known) - -- needed to fix #136 - -> OMap Name DType -- local type env't - -> OMap Name Fixity -- local fixity env't - -> (String, String) -- let-binding prefixes - -> Name -- name of the thing being promoted - -> ULetDecRHS -- body of the thing - -> PrM ( (Name, [DTyVarBndr], Maybe DKind, [DTySynEqn]) -- "type family" - , [DDec] -- defunctionalization - , ALetDecRHS ) -- annotated RHS -promoteLetDecRHS m_rhs_ki type_env fix_env prefixes name (UValue exp) = do - (res_kind, num_arrows) - <- case m_rhs_ki of - Just (arg_kis, res_ki) -> return ( Just (ravelTyFun (arg_kis ++ [res_ki])) - , length arg_kis ) - _ | Just ty <- OMap.lookup name type_env - -> do ki <- promoteType ty - return (Just ki, countArgs ty) - | otherwise - -> return (Nothing, 0) - case num_arrows of - 0 -> do - all_locals <- allLocals - let lde_kvs_to_bind = foldMap fvDType res_kind - (exp', ann_exp) <- forallBind lde_kvs_to_bind $ promoteExp exp - let proName = promoteValNameLhsPrefix prefixes name - m_fixity = OMap.lookup name fix_env - tvbs = map DPlainTV all_locals - defuns <- defunctionalize proName m_fixity tvbs res_kind - return ( ( proName, tvbs, res_kind - , [DTySynEqn Nothing (foldType (DConT proName) $ map DVarT all_locals) exp'] ) - , defuns - , AValue (foldType (DConT proName) (map DVarT all_locals)) - num_arrows ann_exp ) - _ -> do - names <- replicateM num_arrows (newUniqueName "a") - let pats = map DVarP names - newArgs = map DVarE names - promoteLetDecRHS m_rhs_ki type_env fix_env prefixes name - (UFunction [DClause pats (foldExp exp newArgs)]) - -promoteLetDecRHS m_rhs_ki type_env fix_env prefixes name (UFunction clauses) = do - numArgs <- count_args clauses - (m_argKs, m_resK, ty_num_args) <- case m_rhs_ki of - Just (arg_kis, res_ki) -> return (map Just arg_kis, Just res_ki, length arg_kis) - _ | Just ty <- OMap.lookup name type_env - -> 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 - (argKs, resultK) <- promoteUnraveled ty - -- invariant: countArgs ty == length argKs - return (map Just argKs, Just resultK, length argKs) - - | otherwise - -> return (replicate numArgs Nothing, Nothing, numArgs) - let proName = promoteValNameLhsPrefix prefixes name - m_fixity = OMap.lookup name fix_env - all_locals <- allLocals - let local_tvbs = map DPlainTV all_locals - tyvarNames <- mapM (const $ qNewName "a") m_argKs - let args = zipWith inferMaybeKindTV tyvarNames m_argKs - all_args = local_tvbs ++ args - defun_decs <- defunctionalize proName m_fixity all_args m_resK - expClauses <- mapM (etaContractOrExpand ty_num_args numArgs) clauses - let lde_kvs_to_bind = foldMap (foldMap fvDType) m_argKs <> foldMap fvDType m_resK - (eqns, ann_clauses) <- forallBind lde_kvs_to_bind $ - mapAndUnzipM (promoteClause proName) expClauses - prom_fun <- lookupVarE name - return ( (proName, all_args, m_resK, eqns) - , defun_decs - , AFunction prom_fun ty_num_args ann_clauses ) - - where - etaContractOrExpand :: Int -> Int -> DClause -> PrM DClause - etaContractOrExpand ty_num_args clause_num_args (DClause pats exp) - | n >= 0 = do -- Eta-expand - names <- replicateM n (newUniqueName "a") - let newPats = map DVarP names - newArgs = map DVarE names - return $ DClause (pats ++ newPats) (foldExp exp newArgs) - | otherwise = do -- Eta-contract - let (clausePats, lamPats) = splitAt ty_num_args pats - lamExp <- mkDLamEFromDPats lamPats exp - return $ DClause clausePats lamExp - where - n = ty_num_args - clause_num_args - - count_args (DClause pats _ : _) = return $ length pats - count_args _ = fail $ "Impossible! A function without clauses." - -promoteClause :: Name -> DClause -> PrM (DTySynEqn, ADClause) -promoteClause proName (DClause pats exp) = do - -- promoting the patterns creates variable bindings. These are passed - -- to the function promoted the RHS - ((types, pats'), prom_pat_infos) <- evalForPair $ mapAndUnzipM promotePat pats - let PromDPatInfos { prom_dpat_vars = new_vars - , prom_dpat_sig_kvs = sig_kvs } = prom_pat_infos - (ty, ann_exp) <- forallBind sig_kvs $ - lambdaBind new_vars $ - promoteExp exp - all_locals <- allLocals -- these are bound *outside* of this clause - return ( DTySynEqn Nothing (foldType (DConT proName) $ map DVarT all_locals ++ types) ty - , ADClause new_vars pats' ann_exp ) - -promoteMatch :: Name -> DMatch -> PrM (DTySynEqn, ADMatch) -promoteMatch caseTFName (DMatch pat exp) = do - -- promoting the patterns creates variable bindings. These are passed - -- to the function promoted the RHS - ((ty, pat'), prom_pat_infos) <- evalForPair $ promotePat pat - let PromDPatInfos { prom_dpat_vars = new_vars - , prom_dpat_sig_kvs = sig_kvs } = prom_pat_infos - (rhs, ann_exp) <- forallBind sig_kvs $ - lambdaBind new_vars $ - promoteExp exp - all_locals <- allLocals - return $ ( DTySynEqn Nothing - (foldType (DConT caseTFName) $ map DVarT all_locals ++ [ty]) - rhs - , ADMatch new_vars pat' ann_exp) - --- promotes a term pattern into a type pattern, accumulating bound variable names -promotePat :: DPat -> QWithAux PromDPatInfos PrM (DType, ADPat) -promotePat (DLitP lit) = (, ADLitP lit) <$> promoteLitPat lit -promotePat (DVarP name) = do - -- term vars can be symbols... type vars can't! - tyName <- mkTyName name - tell $ PromDPatInfos [(name, tyName)] OSet.empty - return (DVarT tyName, ADVarP name) -promotePat (DConP name pats) = do - (types, pats') <- mapAndUnzipM promotePat pats - let name' = unboxed_tuple_to_tuple name - return (foldType (DConT name') types, ADConP name pats') - where - unboxed_tuple_to_tuple n - | Just deg <- unboxedTupleNameDegree_maybe n = tupleDataName deg - | otherwise = n -promotePat (DTildeP pat) = do - qReportWarning "Lazy pattern converted into regular pattern in promotion" - second ADTildeP <$> promotePat pat -promotePat (DBangP pat) = do - qReportWarning "Strict pattern converted into regular pattern in promotion" - second ADBangP <$> promotePat pat -promotePat (DSigP pat ty) = do - -- We must maintain the invariant that any promoted pattern signature must - -- not have any wildcards in the underlying pattern. - -- See Note [Singling pattern signatures]. - wildless_pat <- removeWilds pat - (promoted, pat') <- promotePat wildless_pat - ki <- promoteType ty - tell $ PromDPatInfos [] (fvDType ki) - return (DSigT promoted ki, ADSigP promoted pat' ki) -promotePat DWildP = return (DWildCardT, ADWildP) - -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) $ promoteLitExp 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) --- Until we get visible kind applications, this is the best we can do. -promoteExp (DAppTypeE exp _) = do - qReportWarning "Visible type applications are ignored by `singletons`." - promoteExp exp -promoteExp (DLamE names exp) = do - lambdaName <- newUniqueName "Lambda" - 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 = map DPlainTV all_args - emitDecs [DClosedTypeFamilyD (DTypeFamilyHead - lambdaName - tvbs - DNoSig - Nothing) - [DTySynEqn Nothing - (foldType (DConT lambdaName) $ - map DVarT (all_locals ++ tyNames)) - rhs]] - emitDecsM $ defunctionalize lambdaName Nothing tvbs Nothing - let promLambda = foldl apply (DConT (promoteTySym lambdaName 0)) - (map DVarT all_locals) - return (promLambda, ADLamE tyNames 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 caseTFName) matches - tyvarName <- qNewName "t" - let all_args = all_locals ++ [tyvarName] - tvbs = map DPlainTV all_args - emitDecs [DClosedTypeFamilyD (DTypeFamilyHead caseTFName tvbs DNoSig Nothing) eqns] - -- See Note [Annotate case return type] in Single - let applied_case = prom_case `DAppT` exp' - return ( applied_case - , ADCaseE ann_exp ann_matches applied_case ) -promoteExp (DLetE decs exp) = do - unique <- qNewUnique - let letPrefixes = uniquePrefixes "Let" "<<<" unique - (binds, ann_env) <- promoteLetDecs letPrefixes 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 exp' ann_exp ty') -promoteExp e@(DStaticE _) = fail ("Static expressions cannot be promoted: " ++ show e) - -promoteLitExp :: Quasi q => Lit -> q DType -promoteLitExp (IntegerL n) - | n >= 0 = return $ (DConT tyFromIntegerName `DAppT` DLitT (NumTyLit n)) - | otherwise = return $ (DConT tyNegateName `DAppT` - (DConT tyFromIntegerName `DAppT` DLitT (NumTyLit (-n)))) -promoteLitExp (StringL str) = do - let prom_str_lit = DLitT (StrTyLit str) - os_enabled <- qIsExtEnabled LangExt.OverloadedStrings - pure $ if os_enabled - then DConT tyFromStringName `DAppT` prom_str_lit - else prom_str_lit -promoteLitExp lit = - fail ("Only string and natural number literals can be promoted: " ++ show lit) - -promoteLitPat :: MonadFail m => Lit -> m DType -promoteLitPat (IntegerL n) - | n >= 0 = return $ (DLitT (NumTyLit n)) - | otherwise = - fail $ "Negative literal patterns are not allowed,\n" ++ - "because literal patterns are promoted to natural numbers." -promoteLitPat (StringL str) = return $ DLitT (StrTyLit str) -promoteLitPat lit = - fail ("Only string and natural number literals can be promoted: " ++ show lit) - --- See Note [DerivedDecl] -promoteDerivedEqDec :: DerivedEqDecl -> PrM () -promoteDerivedEqDec (DerivedDecl { ded_type = ty - , ded_decl = DataDecl _ _ cons }) = do - kind <- promoteType ty - inst_decs <- mkEqTypeInstance kind cons - emitDecs inst_decs diff --git a/src/Data/Singletons/Promote/Defun.hs b/src/Data/Singletons/Promote/Defun.hs deleted file mode 100644 --- a/src/Data/Singletons/Promote/Defun.hs +++ /dev/null @@ -1,540 +0,0 @@ -{- Data/Singletons/Promote/Defun.hs - -(c) Richard Eisenberg, Jan Stolarek 2014 -rae@cs.brynmawr.edu - -This file creates defunctionalization symbols for types during promotion. --} - -{-# LANGUAGE TemplateHaskell #-} - -module Data.Singletons.Promote.Defun where - -import Language.Haskell.TH.Desugar -import qualified Language.Haskell.TH.Desugar.OSet as OSet -import Data.Singletons.Promote.Monad -import Data.Singletons.Promote.Type -import Data.Singletons.Names -import Language.Haskell.TH.Syntax -import Data.Singletons.Syntax -import Data.Singletons.Util -import Control.Monad -import Data.Foldable -import qualified Data.Map.Strict as Map -import Data.Map.Strict (Map) -import Data.Maybe - -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) = - fail "Building defunctionalization symbols of values not supported" -defunInfo (DTyVarI _name _ty) = - fail "Building defunctionalization symbols of type variables not supported" -defunInfo (DPatSynI {}) = - fail "Building defunctionalization symbols of pattern synonyms not supported" - -defunTypeDecls :: [TySynDecl] - -> [ClosedTypeFamilyDecl] - -> [OpenTypeFamilyDecl] - -> PrM () -defunTypeDecls ty_syns c_tyfams o_tyfams = do - defun_ty_syns <- - concatMapM (\(TySynDecl name tvbs rhs) -> buildDefunSymsTySynD name tvbs rhs) ty_syns - defun_c_tyfams <- - concatMapM (buildDefunSymsClosedTypeFamilyD . getTypeFamilyDecl) c_tyfams - defun_o_tyfams <- - concatMapM (buildDefunSymsOpenTypeFamilyD . getTypeFamilyDecl) o_tyfams - emitDecs $ defun_ty_syns ++ defun_c_tyfams ++ defun_o_tyfams - -buildDefunSyms :: DDec -> PrM [DDec] -buildDefunSyms (DDataD _new_or_data _cxt _tyName _tvbs _k ctors _derivings) = - buildDefunSymsDataD ctors -buildDefunSyms (DClosedTypeFamilyD tf_head _) = - buildDefunSymsClosedTypeFamilyD tf_head -buildDefunSyms (DOpenTypeFamilyD tf_head) = - buildDefunSymsOpenTypeFamilyD tf_head -buildDefunSyms (DTySynD name tvbs rhs) = - buildDefunSymsTySynD name tvbs rhs -buildDefunSyms (DClassD _cxt name tvbs _fundeps _members) = do - defunReifyFixity name tvbs (Just (DConT constraintName)) -buildDefunSyms _ = fail $ "Defunctionalization symbols can only be built for " ++ - "type families and data declarations" - -buildDefunSymsClosedTypeFamilyD :: DTypeFamilyHead -> PrM [DDec] -buildDefunSymsClosedTypeFamilyD = buildDefunSymsTypeFamilyHead id id - -buildDefunSymsOpenTypeFamilyD :: DTypeFamilyHead -> PrM [DDec] -buildDefunSymsOpenTypeFamilyD = buildDefunSymsTypeFamilyHead cuskify default_to_star - where - default_to_star :: Maybe DKind -> Maybe DKind - default_to_star Nothing = Just $ DConT typeKindName - default_to_star (Just k) = Just k - -buildDefunSymsTypeFamilyHead - :: (DTyVarBndr -> DTyVarBndr) - -> (Maybe DKind -> Maybe DKind) - -> DTypeFamilyHead -> PrM [DDec] -buildDefunSymsTypeFamilyHead default_tvb default_kind - (DTypeFamilyHead name tvbs result_sig _) = do - let arg_tvbs = map default_tvb tvbs - res_kind = default_kind (resultSigToMaybeKind result_sig) - defunReifyFixity name arg_tvbs res_kind - -buildDefunSymsTySynD :: Name -> [DTyVarBndr] -> DType -> PrM [DDec] -buildDefunSymsTySynD name tvbs rhs = - defunReifyFixity name tvbs mb_res_kind - where - -- In order to have a CUSK, a type synonym must annotate its right-hand - -- side with an explicit kind signature, so we can make use of this - -- property to determine the result kind when defunctionalizing the - -- type synonym. - mb_res_kind :: Maybe DKind - mb_res_kind = case rhs of - DSigT _ k -> Just k - _ -> Nothing - -buildDefunSymsDataD :: [DCon] -> PrM [DDec] -buildDefunSymsDataD ctors = - concatMapM promoteCtor ctors - where - promoteCtor :: DCon -> PrM [DDec] - promoteCtor ctor@(DCon _ _ _ _ res_ty) = do - let (name, arg_tys) = extractNameTypes ctor - tvb_names <- replicateM (length arg_tys) $ qNewName "t" - arg_kis <- mapM promoteType arg_tys - let arg_tvbs = zipWith DKindedTV tvb_names arg_kis - res_ki <- promoteType res_ty - defunReifyFixity name arg_tvbs (Just res_ki) - --- Generate defunctionalization symbols for a name, using reifyFixityWithLocals --- to determine what the fixity of each symbol should be. --- See Note [Fixity declarations for defunctionalization symbols] -defunReifyFixity :: Name -> [DTyVarBndr] -> Maybe DKind -> PrM [DDec] -defunReifyFixity name tvbs m_res_kind = do - m_fixity <- reifyFixityWithLocals name - defunctionalize name m_fixity tvbs m_res_kind - --- 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 :: SameKind (Apply (FooSym2 a b) arg) (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 :: SameKind (Apply (FooSym1 a) arg) (FooSym2 a arg) --- => FooSym1 a f --- type instance Apply (FooSym1 a) b = FooSym2 a b --- data FooSym0 f where --- FooSym0KindInference :: SameKind (Apply FooSym0 arg) (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.SuppressUnusedWarnings --- 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. --- --- See also Note [Defunctionalization and dependent quantification] -defunctionalize :: Name - -> Maybe Fixity -- The name's fixity, if one was declared. - -> [DTyVarBndr] -> Maybe DKind -> PrM [DDec] -defunctionalize name m_fixity m_arg_tvbs' m_res_kind' = do - (m_arg_tvbs, m_res_kind) <- eta_expand (noExactTyVars m_arg_tvbs') - (noExactTyVars m_res_kind') - - let -- Implements part (2)(i) from Note [Defunctionalization and dependent quantification] - tvb_to_type_map :: Map Name DType - tvb_to_type_map = Map.fromList $ -- (2)(i)(c) - map (\tvb -> (extractTvbName tvb, dTyVarBndrToDType tvb)) $ - toposortTyVarsOf $ -- (2)(i)(b) - map dTyVarBndrToDType m_arg_tvbs - ++ maybeToList m_res_kind -- (2)(i)(a) - - go :: Int -> [DTyVarBndr] -> Maybe DKind - -> ([DTyVarBndr] -> DType) -- given the argument tyvar binders, - -- produce the RHS of the Apply instance - -> PrM [DDec] - go _ [] _ _ = return [] - go n (m_arg : m_args) m_result mk_rhs = do - extra_name <- qNewName "arg" - let tyfun_name = extractTvbName m_arg - data_name = promoteTySym name n - next_name = promoteTySym name (n+1) - con_name = prefixName "" ":" $ suffixName "KindInference" "###" data_name - m_tyfun = buildTyFunArrow_maybe (extractTvbKind m_arg) m_result - arg_params = -- Implements part (2)(ii) from - -- Note [Defunctionalization and dependent quantification] - map (map_tvb_kind (substType tvb_to_type_map)) $ - reverse m_args - arg_names = map extractTvbName arg_params - params = arg_params ++ [DPlainTV tyfun_name] - con_eq_ct = DConT sameKindName `DAppT` lhs `DAppT` rhs - where - lhs = foldType (DConT data_name) (map DVarT arg_names) `apply` (DVarT extra_name) - rhs = foldType (DConT next_name) (map DVarT (arg_names ++ [extra_name])) - con_decl = DCon (map dropTvbKind params ++ [DPlainTV extra_name]) - [con_eq_ct] - con_name - (DNormalC False []) - (foldTypeTvbs (DConT data_name) params) - data_decl = DDataD Data [] data_name args res_ki [con_decl] [] - where - (args, res_ki) - = case m_tyfun of - Nothing -> (params, Nothing) - -- If we cannot infer the return type, don't bother - -- trying to construct an explicit return kind. - Just tyfun -> - let bound_tvs = OSet.fromList (map extractTvbName arg_params) - `OSet.union` foldMap (foldMap fvDType) - (map extractTvbKind arg_params) - not_bound tvb = not (extractTvbName tvb `OSet.member` bound_tvs) - tvb_to_type tvb_name = fromMaybe (DVarT tvb_name) $ - Map.lookup tvb_name tvb_to_type_map - -- Implements part (2)(iii) from - -- Note [Defunctionalization and dependent quantification] - tyfun_tvbs = filter not_bound $ -- (2)(iii)(d) - toposortTyVarsOf $ -- (2)(iii)(c) - map tvb_to_type $ -- (2)(iii)(b) - toList $ fvDType tyfun -- (2)(iii)(a) - in (arg_params, Just (DForallT tyfun_tvbs [] tyfun)) - app_data_ty = foldTypeTvbs (DConT data_name) m_args - app_eqn = DTySynEqn Nothing - (DConT applyName `DAppT` app_data_ty - `DAppT` DVarT tyfun_name) - (mk_rhs (m_args ++ [DPlainTV tyfun_name])) - app_decl = DTySynInstD app_eqn - suppress = DInstanceD Nothing Nothing [] - (DConT suppressClassName `DAppT` app_data_ty) - [DLetDec $ DFunD suppressMethodName - [DClause [] - ((DVarE 'snd) `DAppE` - mkTupleDExp [DConE con_name, - mkTupleDExp []])]] - - mk_rhs' = foldTypeTvbs (DConT data_name) - - -- See Note [Fixity declarations for defunctionalization symbols] - mk_fix_decl f = DLetDec $ DInfixD f data_name - fixity_decl = maybeToList $ fmap mk_fix_decl m_fixity - - decls <- go (n - 1) m_args m_tyfun mk_rhs' - return $ suppress : data_decl : app_decl : fixity_decl ++ decls - - let num_args = length m_arg_tvbs - sat_name = promoteTySym name num_args - mk_rhs = foldTypeTvbs (DConT name) - sat_dec = DTySynD sat_name m_arg_tvbs (mk_rhs m_arg_tvbs) - - other_decs <- go (num_args - 1) (reverse m_arg_tvbs) m_res_kind mk_rhs - return $ sat_dec : other_decs - where - eta_expand :: [DTyVarBndr] -> Maybe DKind -> PrM ([DTyVarBndr], Maybe DKind) - eta_expand m_arg_tvbs Nothing = pure (m_arg_tvbs, Nothing) - eta_expand m_arg_tvbs (Just res_kind) = do - let (_, _, argKs, resultK) = unravel res_kind - tvb_names <- replicateM (length argKs) $ qNewName "e" - let res_kind_arg_tvbs = zipWith DKindedTV tvb_names argKs - pure (m_arg_tvbs ++ res_kind_arg_tvbs, Just resultK) - - map_tvb_kind :: (DKind -> DKind) -> DTyVarBndr -> DTyVarBndr - map_tvb_kind _ tvb@DPlainTV{} = tvb - map_tvb_kind f (DKindedTV n k) = DKindedTV n (f k) - -{- -Note [Defunctionalization and dependent quantification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The machinery in this module supports defunctionalizing types that use -dependent quantification, such as in the following example: - - type family Symmetry (a :: Proxy t) (y :: Proxy t) - (e :: (a :: Proxy (t :: k)) :~: (y :: Proxy (t :: k))) :: Type where - Symmetry a y _ = y :~: a - -Here is what is involved in making this happen: - -1. When defunctionalizing, we must not only know the argument kinds, but rather - the argument *kind variable binders*. This is essential since, for instance, - Symmetry dependently quantifies `a` and `y` and uses them in the kind of - `e`. If we did not track the original kind variable names, then instead of - generating this defunctionalization symbol for Symmetry: - - data SymmetrySym2 (a :: Proxy t) (y :: Proxy t) :: (a :~: y) ~> Type - - We would generate something more general, like this: - - data SymmetrySym2 (abc1 :: Proxy t) (abc2 :: Proxy t) :: (a :~: y) ~> Type - - Alas, there are times where will have no choice but to write a slightly - more general kind than we should. For instance, consider this: - - data SymmetrySym0 :: Proxy t ~> Proxy t ~> (a :~: y) ~> Type - - This defunctionalization symbol doesn't capture the dependent quantification - in the first and second argument kinds. But in order to do that properly, - you'd need the ability to write something like: - - data SymmetrySym0 :: forall (a :: Proxy t) ~> forall (y :: Proxy t) - ~> (a :~: y) ~> Type - - It is my (RGS's) belief that it is not possible to achieve something like - this in today's GHC (see #304), so we'll just have to live with SymmetrySym0 - being slightly more general than it ought to be. In practice, this is - unlikely to bite unless you're writing code that specifically exploits this - dependency in just the right way. - -2. I pulled a fast one earlier by writing: - - data SymmetrySym0 :: Proxy t ~> Proxy t ~> (a :~: y) ~> Type - - GHC will actually reject this, because it does not have a CUSK. There are - two glaring problems here: - - (a) The kind of `t` is underdetermined. - (b) `a` and `y` should have kind `Proxy t`, but this is not currently the case. - - Ultimately, the fix is to use explicit kind signatures. A naïve attempt - would be something like this: - - data SymmetrySym0 :: Proxy (t :: (k :: Type)) ~> Proxy (t :: (k :: Type)) - ~> ((a :: Proxy (t :: (k :: Type))) :~: (y :: Proxy (t :: (k :: Type)))) - ~> Type - - While that works, it adds a nontrivial amount of clutter. Plus, it requires - figuring out (in Template Haskell) which variables have underdetermined - kinds and substituting for them. Blegh. A much cleaner approach is: - - data SymmetrySym0 :: forall (k :: Type) (t :: k) (a :: Proxy t) (y :: Proxy t). - Proxy t ~> Proxy t ~> (a :~: y) ~> Type - - This time, all we have to do is put an explicit `forall` in front, and we - achieve a CUSK without having to muck up the body of return kind. It also - has the benefit of looking much nicer in generated code. - - Let's talk about how to achieve this feat, using SymmetrySym1 as the - guiding example: - - (i) Before we begin defunctionalizing a type, we construct a mapping from - variable names to their corresponding types, complete with kinds. - For instance, in Symmetry, we would have the following map: - - { k :-> DVarT k -- k - , t :-> DSigT (DVarT t) (DVarT k) -- (t :: k) - , a :-> DSigT (DVarT a) (DConT ''Proxy `DAppT` DVarT t) -- (a :: Proxy t) - , y :-> DSigT (DVarT y) (DConT ''Proxy `DAppT` DVarT y) -- (y :: Proxy t) - , e :-> DSigT (DVarT e) (DConT ''(:~:) - `DAppT` DSigT (DVarT a) (DConT ''Proxy `DAppT` DSigT (DVarT t) (DVarT k)) - `DAppT` DSigT (DVarT y) (DConT ''Proxy `DAppT` DSigT (DVarT t) (DVarT k))) - -- (e :: (a :: Proxy (t :: k)) :~: (y :: Proxy (t :: k))) - } - - Why do this? Because when constructing the `forall` in the return kind - of a defunctionalization symbol, it's convenient to be able to know - the kinds of everything being bound at a glance. It's not always - possible to recover the kinds of every variable (for instance, if - we're just given `Proxy t ~> Proxy t ~> (a :~: y) ~> Type`), so having - this information is handy. - - To construct this map, we: - - (a) Grab the list of type variable binders (this is given as an input - to defunctionalize, as discussed in part (1)) and turn it into a list - of types. Also include the return kind (if there is one) in this - list, as it may also mention type variables with explicit kinds. - (b) Construct a flat list of all type variables mentioned in this list. - This may involve looking in the kinds of type variables binders. - (Note that this part is crucial—the the Singletons/PolyKinds test - will fail to compile without it!) - (c) Take the flat list and insert each variable into the map by - mapping its name to its type (as demonstrated above). - - To continue the Symmetry example: - - (a) We grab the list of type variable binders - - [ (a :: Proxy t) - , (y :: Proxy t) - , (e :: (a :: Proxy (t :: k)) :~: (y :: Proxy (t :: k))) - ] - - from the Symmetry declaration. Including the return kind (Type), - we get: - - [ (a :: Proxy t) - , (y :: Proxy t) - , (e :: (a :: Proxy (t :: k)) :~: (y :: Proxy (t :: k))) - , Type - ] - - (b) We flatten this into a list of well scoped type variables: - - [ k - , (t :: k) - , (a :: Proxy t) - , (y :: Proxy t) - , (e :: (a :: Proxy (t :: k)) :~: (y :~: Proxy (t :: k))) - ] - - (c) From this, we construct the map shown at the beginning of (i). - - (ii) Using the map, we will annotate any kind variables in the LHS of the - declaration with their respective kinds. In this example, the LHS is: - - data SymmetrySym1 (a :: Proxy t) :: ... - - Since `t` maps to simply `(t :: k)` in the map, the LHS becomes: - - data SymmetrySym1 (a :: Proxy (t :: k)) :: ... - - Why do this? Because we need to make it apparent that `k` is bound on - the LHS. If we don't, we might end up trying to quantify `k` in the - return kind (see #353 for an example of what goes wrong if you try to - do this). - - Having to explicitly annotate each occurrence of every kind variable on - the LHS like this is a bit tiresome, especially since we don't have to - do this in the return kind. If GHC had syntax for visible dependent - quantification, we could avoid this step entirely and simply write: - - data SymmetrySym1 :: forall k (t :: k). forall (a :: Proxy t) -> ... - - Until GHC gains this syntax, this is the best alternative. - - (iii) When constructing each defunctionalization symbol, we will end up with - some remaining type variable binders and a return kind. For instance: - - data SymmetrySym1 (a :: Proxy (t :: k)) - :: forall ???. Proxy t - ~> ((a :: Proxy (t :: k)) :~: (y :: Proxy (t :: k))) - ~> Type - - We must fill in the ??? part. Here is how we do so: - - (a) Collect all of the type variables mentioned in the return kind. - (b) Look up each type variable's corresponding type in the map (from - part (i)) to learn as much kind information as possible. - (c) Perform a reverse topological sort on these types to put the - types (and kind) variables in proper dependency order. - (d) Filter out any variables that are already bound by the type - variable binders that precede the return kind. - - After doing these steps, what remains goes in place of ???. Let's - explain this with the example above: - - data SymmetrySym1 (a :: Proxy (t :: k)) - :: forall ???. Proxy t - ~> ((a :: Proxy (t :: k)) :~: (y :: Proxy (t :: k))) - ~> Type - - (a) [t, a, k, y] - (b) [(t :: k), (a :: Proxy t), k, (y :: Proxy t)] - (c) [k, (t :: k), (a :: Proxy t), (y :: Proxy t)] - (d) [(y :: Proxy t)] (`k`, `t` and `a` were already bound) - - Therefore, we end up with: - - data SymmetrySym1 (a :: Proxy (t :: k)) - :: forall (y :: Proxy t). - Proxy t - ~> ((a :: Proxy (t :: k)) :~: (y :: Proxy (t :: k))) - ~> Type --} - --- This is a small function with large importance. When generating --- defunctionalization data types, we often need to fill in the blank in the --- sort of code exemplified below: --- --- @ --- data FooSym2 a (b :: x) (c :: TyFun y z) where --- FooSym2KindInference :: _ --- @ --- --- Where the kind of @a@ is not known. It's extremely tempting to just --- copy-and-paste the type variable binders from the data type itself to the --- constructor, like so: --- --- @ --- data FooSym2 a (b :: x) (c :: TyFun y z) where --- FooSym2KindInference :: forall a (b :: x) (c :: TyFun y z). --- SameKind (...) (...). --- FooSym2KindInference a b c --- @ --- --- But this ends up being an untenable approach. Because @a@ lacks a kind --- signature, @FooSym2@ does not have a complete, user-specified kind signature --- (or CUSK), so GHC will fail to typecheck @FooSym2KindInference@. --- --- Thankfully, there's a workaround—just don't give any of the constructor's --- type variable binders any kinds: --- --- @ --- data FooSym2 a (b :: x) (c :: TyFun y z) where --- FooSym2KindInference :: forall a b c --- SameKind (...) (...). --- FooSym2KindInference a b c --- @ --- --- GHC may be moody when it comes to CUSKs, but it's at least understanding --- enough to typecheck this without issue. The 'dropTvbKind' function is --- what removes the kinds used in the kind inference constructor. -dropTvbKind :: DTyVarBndr -> DTyVarBndr -dropTvbKind tvb@(DPlainTV {}) = tvb -dropTvbKind (DKindedTV n _) = DPlainTV n - --- Shorthand for building (k1 ~> k2) -buildTyFunArrow :: DKind -> DKind -> DKind -buildTyFunArrow k1 k2 = DConT tyFunArrowName `DAppT` k1 `DAppT` k2 - -buildTyFunArrow_maybe :: Maybe DKind -> Maybe DKind -> Maybe DKind -buildTyFunArrow_maybe m_k1 m_k2 = do - k1 <- m_k1 - k2 <- m_k2 - return $ DConT tyFunArrowName `DAppT` k1 `DAppT` k2 - --- Build (~>) kind from the list of kinds -ravelTyFun :: [DKind] -> DKind -ravelTyFun [] = error "Internal error: TyFun raveling nil" -ravelTyFun [k] = k -ravelTyFun kinds = go tailK (buildTyFunArrow k2 k1) - where (k1 : k2 : tailK) = reverse kinds - go [] acc = acc - go (k:ks) acc = go ks (buildTyFunArrow k acc) - -{- -Note [Fixity declarations for defunctionalization symbols] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Just like we promote fixity declarations, we should also generate fixity -declarations for defunctionaliztion symbols. A primary use case is the -following scenario: - - (.) :: (b -> c) -> (a -> b) -> (a -> c) - (f . g) x = f (g x) - infixr 9 . - -One often writes (f . g . h) at the value level, but because (.) is promoted -to a type family with three arguments, this doesn't directly translate to the -type level. Instead, one must write this: - - f .@#@$$$ g .@#@$$$ h - -But in order to ensure that this associates to the right as expected, one must -generate an `infixr 9 .@#@#$$$` declaration. This is why defunctionalize accepts -a Maybe Fixity argument. --} diff --git a/src/Data/Singletons/Promote/Eq.hs b/src/Data/Singletons/Promote/Eq.hs deleted file mode 100644 --- a/src/Data/Singletons/Promote/Eq.hs +++ /dev/null @@ -1,76 +0,0 @@ -{- Data/Singletons/Promote/Eq.hs - -(c) Richard Eisenberg 2014 -rae@cs.brynmawr.edu - -This module defines the functions that generate type-level equality type -family instances. --} - -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 - --- 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 helperName) cons - let null_branch = catch_all_case helperName trueName - false_branch = catch_all_case helperName falseName - branches | null cons = [null_branch] - | otherwise = true_branches ++ [false_branch] - closedFam = DClosedTypeFamilyD (DTypeFamilyHead helperName - -- We opt to give explicit kinds for the tyvars - -- in the helper type family. - -- See Note [Promoted class method kinds] - -- in Data.Singletons.Promote. - [ DKindedTV aName kind - , DKindedTV bName kind ] - (DKindSig boolKi) - Nothing) - branches - eqInst = DTySynInstD $ - DTySynEqn Nothing - (DConT tyEqName `DAppT` DVarT aName `DAppT` DVarT bName) - (foldType (DConT helperName) [DVarT aName, DVarT bName]) - inst = DInstanceD Nothing Nothing [] ((DConT $ promoteClassName eqName) `DAppT` - kind) [eqInst] - - return [closedFam, inst] - - where mk_branch :: Quasi q => Name -> DCon -> q DTySynEqn - mk_branch helper_name 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 Nothing - (DConT helper_name `DAppT` ltype `DAppT` rtype) - result - - catch_all_case :: Name -> Name -> DTySynEqn - catch_all_case helper_name returned_val_name = - DTySynEqn Nothing - (DConT helper_name - `DAppT` DSigT DWildCardT kind - `DAppT` DSigT DWildCardT kind) - (promoteValRhs returned_val_name) - - 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 diff --git a/src/Data/Singletons/Promote/Monad.hs b/src/Data/Singletons/Promote/Monad.hs deleted file mode 100644 --- a/src/Data/Singletons/Promote/Monad.hs +++ /dev/null @@ -1,187 +0,0 @@ -{- Data/Singletons/Promote/Monad.hs - -(c) Richard Eisenberg 2014 -rae@cs.brynmawr.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, FlexibleContexts, - TypeFamilies, KindSignatures #-} - -module Data.Singletons.Promote.Monad ( - PrM, promoteM, promoteM_, promoteMDecs, VarPromotions, - allLocals, emitDecs, emitDecsM, - lambdaBind, LetBind, letBind, lookupVarE, forallBind, allBoundKindVars - ) where - -import Control.Monad.Reader -import Control.Monad.Writer -import Language.Haskell.TH.Syntax hiding ( lift ) -import Language.Haskell.TH.Desugar -import qualified Language.Haskell.TH.Desugar.OMap.Strict as OMap -import Language.Haskell.TH.Desugar.OMap.Strict (OMap) -import qualified Language.Haskell.TH.Desugar.OSet as OSet -import Language.Haskell.TH.Desugar.OSet (OSet) -import Data.Singletons.Names -import Data.Singletons.Syntax - -type LetExpansions = OMap Name DType -- from **term-level** name - --- environment during promotion -data PrEnv = - PrEnv { pr_lambda_bound :: OMap Name Name - , pr_let_bound :: LetExpansions - , pr_forall_bound :: OSet Name -- See Note [Explicitly quantifying kinds variables] - , pr_local_decls :: [Dec] - } - -emptyPrEnv :: PrEnv -emptyPrEnv = PrEnv { pr_lambda_bound = OMap.empty - , pr_let_bound = OMap.empty - , pr_forall_bound = OSet.empty - , pr_local_decls = [] } - --- the promotion monad -newtype PrM a = PrM (ReaderT PrEnv (WriterT [DDec] Q) a) - deriving ( Functor, Applicative, Monad, Quasi - , MonadReader PrEnv, MonadWriter [DDec] - , MonadFail, MonadIO ) - -instance DsMonad PrM where - localDeclarations = asks pr_local_decls - --- return *type-level* names -allLocals :: MonadReader PrEnv m => m [Name] -allLocals = do - lambdas <- asks (OMap.assocs . pr_lambda_bound) - lets <- asks pr_let_bound - -- filter out shadowed variables! - return [ typeName - | (termName, typeName) <- lambdas - , case OMap.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 = OMap.fromList [ (tmN, DVarT tyN) | (tmN, tyN) <- binds ] in - env { pr_lambda_bound = OMap.fromList binds `OMap.union` lambdas - , pr_let_bound = new_lets `OMap.union` 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 = OMap.fromList binds `OMap.union` lets } - -lookupVarE :: Name -> PrM DType -lookupVarE n = do - lets <- asks pr_let_bound - case OMap.lookup n lets of - Just ty -> return ty - Nothing -> return $ promoteValRhs n - --- Add to the set of bound kind variables currently in scope. --- See Note [Explicitly binding kind variables] -forallBind :: OSet Name -> PrM a -> PrM a -forallBind kvs1 = - local (\env@(PrEnv { pr_forall_bound = kvs2 }) -> - env { pr_forall_bound = kvs1 `OSet.union` kvs2 }) - --- Look up the set of bound kind variables currently in scope. --- See Note [Explicitly binding kind variables] -allBoundKindVars :: PrM (OSet Name) -allBoundKindVars = asks pr_forall_bound - -promoteM :: DsMonad q => [Dec] -> PrM a -> q (a, [DDec]) -promoteM locals (PrM rdr) = do - other_locals <- localDeclarations - let wr = runReaderT rdr (emptyPrEnv { pr_local_decls = other_locals ++ locals }) - q = runWriterT wr - runQ q - -promoteM_ :: DsMonad q => [Dec] -> PrM () -> q [DDec] -promoteM_ locals thing = do - ((), decs) <- promoteM locals thing - return decs - --- promoteM specialized to [DDec] -promoteMDecs :: DsMonad q => [Dec] -> PrM [DDec] -> q [DDec] -promoteMDecs locals thing = do - (decs1, decs2) <- promoteM locals thing - return $ decs1 ++ decs2 - -{- -Note [Explicitly binding kind variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want to ensure that when we single type signatures for functions, we should -explicitly quantify every kind variable bound by a forall. For example, if we -were to single the identity function: - - identity :: forall a. a -> a - identity x = x - -We want the final result to be: - - sIdentity :: forall a (x :: a). Sing x -> Sing (Identity x) - sIdentity sX = sX - -Accomplishing this takes a bit of care during promotion. When promoting a -function, we determine what set of kind variables are currently bound at that -point and store them in an ALetDecEnv (as lde_bound_kvs), which in turn is -singled. Then, during singling, we extract every kind variable in a singled -type signature, subtract the lde_bound_kvs, and explicitly bind the variables -that remain. - -For a top-level function like identity, lde_bound_kvs is the empty set. But -consider this more complicated example: - - f :: forall a. a -> a - f = g - where - g :: a -> a - g x = x - -When singling, we would eventually end up in this spot: - - sF :: forall a (x :: a). Sing a -> Sing (F a) - sF = sG - where - sG :: _ - sG x = x - -We must make sure /not/ to fill in the following type for _: - - sF :: forall a (x :: a). Sing a -> Sing (F a) - sF = sG - where - sG :: forall a (y :: a). Sing a -> Sing (G a) - sG x = x - -This would be incorrect, as the `a` bound by sF /must/ be the same one used in -sG, as per the scoping of the original `f` function. Thus, we ensure that the -bound variables from `f` are put into lde_bound_kvs when promoting `g` so -that we subtract out `a` and are left with the correct result: - - sF :: forall a (x :: a). Sing a -> Sing (F a) - sF = sG - where - sG :: forall (y :: a). Sing a -> Sing (G a) - sG x = x --} diff --git a/src/Data/Singletons/Promote/Type.hs b/src/Data/Singletons/Promote/Type.hs deleted file mode 100644 --- a/src/Data/Singletons/Promote/Type.hs +++ /dev/null @@ -1,73 +0,0 @@ -{- Data/Singletons/Type.hs - -(c) Richard Eisenberg 2013 -rae@cs.brynmawr.edu - -This file implements promotion of types into kinds. --} - -module Data.Singletons.Promote.Type - ( promoteType, promoteTypeArg, promoteUnraveled - ) where - -import Language.Haskell.TH.Desugar -import Data.Singletons.Names -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 :: MonadFail m => DType -> m DKind -promoteType = go [] - where - go :: MonadFail m => [DTypeArg] -> 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 (DTANormal k2 : args) t1 - -- NB: This next case means that promoting something like - -- (((->) a) :: Type -> Type) b - -- will fail because the pattern below won't recognize the - -- arrow to turn it into a TyFun. But I'm not terribly - -- bothered by this, and it would be annoying to fix. Wait - -- for someone to report. - go args (DAppKindT ty ki) = do - ki' <- go [] ki - go (DTyArg ki' : args) ty - go args (DSigT ty ki) = do - ty' <- go [] ty - -- No need to promote 'ki' - it is already a kind. - return $ applyDType (DSigT ty' ki) args - go args (DVarT name) = return $ applyDType (DVarT name) args - go [] (DConT name) - | name == typeRepName = return $ DConT typeKindName - | nameBase name == nameBase repName = return $ DConT typeKindName - go args (DConT name) - | Just n <- unboxedTupleNameDegree_maybe name - = return $ applyDType (DConT (tupleTypeName n)) args - | otherwise - = return $ applyDType (DConT name) args - go [DTANormal k1, DTANormal k2] DArrowT - = return $ DConT tyFunArrowName `DAppT` k1 `DAppT` k2 - go _ ty@DLitT{} = pure ty - - go args hd = fail $ "Illegal Haskell construct encountered:\n" ++ - "headed by: " ++ show hd ++ "\n" ++ - "applied to: " ++ show args - -promoteTypeArg :: MonadFail m => DTypeArg -> m DTypeArg -promoteTypeArg (DTANormal t) = DTANormal <$> promoteType t -promoteTypeArg ta@(DTyArg _) = pure ta -- Kinds are already promoted - -promoteUnraveled :: MonadFail m => DType -> m ([DKind], DKind) -promoteUnraveled ty = do - arg_kis <- mapM promoteType arg_tys - res_ki <- promoteType res_ty - return (arg_kis, res_ki) - where - (_, _, arg_tys, res_ty) = unravel ty diff --git a/src/Data/Singletons/ShowSing.hs b/src/Data/Singletons/ShowSing.hs --- a/src/Data/Singletons/ShowSing.hs +++ b/src/Data/Singletons/ShowSing.hs @@ -1,16 +1,24 @@ +{-# LANGUAGE CPP #-} + +#if __GLASGOW_HASKELL__ >= 806 {-# LANGUAGE DataKinds #-} -{-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} +#if __GLASGOW_HASKELL__ >= 810 +{-# LANGUAGE StandaloneKindSignatures #-} +#endif +#endif + ----------------------------------------------------------------------------- -- | -- Module : Data.Singletons.ShowSing @@ -20,29 +28,30 @@ -- Stability : experimental -- Portability : non-portable -- --- Defines the class 'ShowSing' type synonym, which is useful for defining --- 'Show' instances for singleton types. +-- Defines the class 'ShowSing' which is useful for defining 'Show' instances +-- for singleton types. Because 'ShowSing' crucially relies on +-- @QuantifiedConstraints@, it is only defined if this library is built with +-- GHC 8.6 or later. -- ---------------------------------------------------------------------------- module Data.Singletons.ShowSing ( +#if __GLASGOW_HASKELL__ >= 806 -- * The 'ShowSing' type ShowSing, -- * Internal utilities ShowSing' +#endif ) where -import Data.Singletons.Internal -import Data.Singletons.Prelude.Instances -import Data.Singletons.Single -import Data.Singletons.TypeLits.Internal -import Data.Singletons.Util -import GHC.Show (appPrec, appPrec1) -import qualified GHC.TypeNats as TN +#if __GLASGOW_HASKELL__ >= 806 +import Data.Kind +import Data.Singletons +import Text.Show -- | In addition to the promoted and singled versions of the 'Show' class that --- @singletons@ provides, it is also useful to be able to directly define +-- @singletons-base@ provides, it is also useful to be able to directly define -- 'Show' instances for singleton types themselves. Doing so is almost entirely -- straightforward, as a derived 'Show' instance does 90 percent of the work. -- The last 10 percent—getting the right instance context—is a bit tricky, and @@ -81,23 +90,22 @@ -- declaration becomes this: -- -- @ --- instance 'ShowSing' k => 'Show' ('SList' (z :: [k])) where --- showsPrec p 'SNil' = showString \"SNil\" --- showsPrec p ('SCons' (sx :: 'Sing' x) (sxs :: 'Sing' xs)) = --- (showParen (p > 10) $ showString \"SCons \" . showsPrec 11 sx --- . showSpace . showsPrec 11 sxs) --- :: (ShowSing' x, ShowSing' xs) => ShowS +-- instance 'ShowSing' k => 'Show' ('SList' (z :: [k])) where ... -- @ -- +-- In fact, this instance can be derived: +-- +-- @ +-- deriving instance 'ShowSing' k => 'Show' ('SList' (z :: [k])) +-- @ +-- -- (Note that the actual definition of 'ShowSing' is slightly more complicated --- than what this documentation might suggest. For the full story, as well as --- an explanation of why we need an explicit --- @(ShowSing' x, ShowSing' xs) => ShowS@ signature at the end, +-- than what this documentation might suggest. For the full story, -- refer to the documentation for `ShowSing'`.) -- --- When singling a derived 'Show' instance, @singletons@ will also generate +-- When singling a derived 'Show' instance, @singletons-th@ will also generate -- a 'Show' instance for the corresponding singleton type using 'ShowSing'. --- In other words, if you give @singletons@ a derived 'Show' instance, then +-- In other words, if you give @singletons-th@ a derived 'Show' instance, then -- you'll receive the following in return: -- -- * A promoted (@PShow@) instance @@ -110,8 +118,11 @@ -- @type ShowSing k = (forall (z :: k). ShowSing' z)@ instead of going the -- extra mile to define it as a class. -- See Note [Define ShowSing as a class, not a type synonym] for an explanation. -class (forall (z :: k). ShowSing' z) => ShowSing k -instance (forall (z :: k). ShowSing' z) => ShowSing k +#if __GLASGOW_HASKELL__ >= 810 +type ShowSing :: Type -> Constraint +#endif +class (forall (z :: k). ShowSing' z) => ShowSing (k :: Type) +instance (forall (z :: k). ShowSing' z) => ShowSing (k :: Type) -- | The workhorse that powers 'ShowSing'. The only reason that `ShowSing'` -- exists is to work around GHC's inability to put type families in the head @@ -125,75 +136,95 @@ -- @ -- -- By replacing @'Show' ('Sing' z)@ with @ShowSing' z@, we are able to avoid --- this restriction for the most part. There is one major downside to using --- @ShowSing'@, however: deriving 'Show' instances for singleton types does --- not work out of the box. In other words, if you try to do this: +-- this restriction for the most part. -- +-- The superclass of `ShowSing'` is a bit peculiar: +-- -- @ --- deriving instance 'ShowSing' k => 'Show' ('SList' (z :: [k])) +-- class (forall (sing :: k -> Type). sing ~ 'Sing' => 'Show' (sing z)) => `ShowSing'` (z :: k) -- @ -- --- Then GHC will complain to the effect that it could not deduce a --- @'Show' ('Sing' x)@ constraint. This is due to --- --- that prevents GHC from realizing that @'ShowSing' k@ implies --- @'Show' ('Sing' (x :: k))@. The workaround is to force GHC to come to its --- senses by using an explicit type signature: +-- One might wonder why this superclass is used instead of this seemingly more +-- direct equivalent: -- -- @ --- instance 'ShowSing' k => 'Show' ('SList' (z :: [k])) where --- showsPrec p 'SNil' = showString \"SNil\" --- showsPrec p ('SCons' (sx :: 'Sing' x) (sxs :: 'Sing' xs)) = --- (showParen (p > 10) $ showString \"SCons \" . showsPrec 11 sx --- . showSpace . showsPrec 11 sxs) --- :: (ShowSing' x, ShowSing' xs) => ShowS +-- class 'Show' ('Sing' z) => `ShowSing'` (z :: k) -- @ -- --- The use of @ShowSing' x@ in the signature is sufficient to make the --- constraint solver connect the dots between @'ShowSing' k@ and --- @'Show' ('Sing' (x :: k))@. (The @ShowSing' xs@ constraint is not strictly --- necessary, but it is shown here since that is in fact the code that --- @singletons@ will generate for this instance.) --- --- Because @deriving 'Show'@ will not insert these explicit signatures for us, --- it is not possible to derive 'Show' instances for singleton types. --- Thankfully, @singletons@' Template Haskell machinery can do this manual --- gruntwork for us 99% of the time, but if you ever find yourself in a --- situation where you must define a 'Show' instance for a singleton type by --- hand, this is important to keep in mind. +-- Actually, these aren't equivalent! The latter's superclass mentions a type +-- family in its head, and this gives GHC's constraint solver trouble when +-- trying to match this superclass against other constraints. (See the +-- discussion beginning at +-- https://gitlab.haskell.org/ghc/ghc/-/issues/16365#note_189057 for more on +-- this point). The former's superclass, on the other hand, does /not/ mention +-- a type family in its head, which allows it to match other constraints more +-- easily. It may sound like a small difference, but it's the only reason that +-- 'ShowSing' is able to work at all without a significant amount of additional +-- workarounds. -- --- Note that there is one potential future direction that might alleviate this --- pain. We could define `ShowSing'` like this instead: +-- The quantified superclass has one major downside. Although the head of the +-- quantified superclass is more eager to match, which is usually a good thing, +-- it can bite under certain circumstances. Because @'Show' (sing z)@ will +-- match a 'Show' instance for /any/ types @sing :: k -> Type@ and @z :: k@, +-- (where @k@ is a kind variable), it is possible for GHC's constraint solver +-- to get into a situation where multiple instances match @'Show' (sing z)@, +-- and GHC will get confused as a result. Consider this example: -- -- @ --- class (forall sing. sing ~ 'Sing' => 'Show' (sing z)) => ShowSing' z --- instance 'Show' ('Sing' z) => ShowSing' z +-- -- As in "Data.Singletons" +-- newtype 'WrappedSing' :: forall k. k -> Type where +-- 'WrapSing' :: forall k (a :: k). { 'unwrapSing' :: 'Sing' a } -> 'WrappedSing' a +-- +-- instance 'ShowSing' k => 'Show' ('WrappedSing' (a :: k)) where +-- 'showsPrec' _ s = 'showString' "WrapSing {unwrapSing = " . showsPrec 0 s . showChar '}' -- @ -- --- For many examples, this lets you just derive 'Show' instances for singleton --- types like you would expect. Alas, this topples over on @Bar@ in the --- following example: +-- When typechecking the 'Show' instance for 'WrappedSing', GHC must fill in a +-- default definition @'show' = defaultShow@, where +-- @defaultShow :: 'Show' ('WrappedSing' a) => 'WrappedSing' a -> 'String'@. +-- GHC's constraint solver has two possible ways to satisfy the +-- @'Show' ('WrappedSing' a)@ constraint for @defaultShow@: -- --- @ --- newtype Foo a = MkFoo a --- data SFoo :: forall a. Foo a -> Type where --- SMkFoo :: Sing x -> SFoo (MkFoo x) --- type instance Sing = SFoo --- deriving instance ShowSing a => Show (SFoo (z :: Foo a)) +-- 1. The top-level instance declaration for @'Show' ('WrappedSing' (a :: k))@ +-- itself, and -- --- newtype Bar a = MkBar (Foo a) --- data SBar :: forall a. Bar a -> Type where --- SMkBar :: Sing x -> SBar (MkBar x) --- type instance Sing = SBar --- deriving instance ShowSing (Foo a) => Show (SBar (z :: Bar a)) +-- 2. @'Show' (sing (z :: k))@ from the head of the quantified constraint arising +-- from @'ShowSing' k@. +-- +-- In practice, GHC will choose (2), as local quantified constraints shadow +-- global constraints. This confuses GHC greatly, causing it to error out with +-- an error akin to @Couldn't match type Sing with WrappedSing@. See +-- https://gitlab.haskell.org/ghc/ghc/-/issues/17934 for a full diagnosis of +-- the issue. +-- +-- The bad news is that because of GHC#17934, we have to manually define 'show' +-- (and 'showList') in the 'Show' instance for 'WrappedSing' in order to avoid +-- confusing GHC's constraint solver. In other words, @deriving 'Show'@ is a +-- no-go for 'WrappedSing'. The good news is that situations like 'WrappedSing' +-- are quite rare in the world of @singletons@—most of the time, 'Show' +-- instances for singleton types do /not/ have the shape +-- @'Show' (sing (z :: k))@, where @k@ is a polymorphic kind variable. Rather, +-- most such instances instantiate @k@ to a specific kind (e.g., @Bool@, or +-- @[a]@), which means that they will not overlap the head of the quantified +-- superclass in `ShowSing'` as observed above. +-- +-- Note that we define the single instance for `ShowSing'` without the use of a +-- quantified constraint in the instance context: +-- -- @ +-- instance 'Show' ('Sing' z) => `ShowSing'` (z :: k) +-- @ -- --- This fails because --- of—you guessed it—. --- Bummer. Unless that bug were to be fixed, the current definition of --- `ShowSing'` is the best that we can do. -class Show (Sing z) => ShowSing' z -instance Show (Sing z) => ShowSing' z +-- We /could/ define this instance with a quantified constraint in the instance +-- context, and it would be equally as expressive. But it doesn't provide any +-- additional functionality that the non-quantified version gives, so we opt +-- for the non-quantified version, which is easier to read. +#if __GLASGOW_HASKELL__ >= 810 +type ShowSing' :: k -> Constraint +#endif +class (forall (sing :: k -> Type). sing ~ Sing => Show (sing z)) + => ShowSing' (z :: k) +instance Show (Sing z) => ShowSing' (z :: k) {- Note [Define ShowSing as a class, not a type synonym] @@ -255,7 +286,7 @@ 1. Make derived instances' type inference more clever. If you look closely, you'll notice that the `ShowSing (X a)`/`ShowSing (Y a)` constraints in the generated instances are entirely redundant and could safely be left - off. But determining this would require significantly improving singletons' + off. But determining this would require significantly improving singletons-th' Template Haskell capabilities for type inference, which is a path that we usually spurn in favor of keeping the generated code dumb but predictable. 2. Define `ShowSing` as a class (with a single instance) instead of a type @@ -271,42 +302,18 @@ -- (S)WrappedSing instances ------------------------------------------------------------ +-- Note that we cannot derive this Show instance due to +-- https://gitlab.haskell.org/ghc/ghc/-/issues/17934. The Haddocks for +-- ShowSing' contain a lengthier explanation of how GHC#17934 relates to +-- ShowSing. instance ShowSing k => Show (WrappedSing (a :: k)) where - showsPrec p (WrapSing s) = showParen (p >= 11) $ - showString "WrapSing {unwrapSing = " . showsPrec 0 s . showChar '}' - :: ShowSing' a => ShowS - -instance ShowSing k => Show (SWrappedSing (ws :: WrappedSing (a :: k))) where - showsPrec p (SWrapSing s) = showParen (p >= 11) $ - showString "SWrapSing {sUnwrapSing = " . showsPrec 0 s . showChar '}' - :: ShowSing' a => ShowS - ------------------------------------------------------------- --- TypeLits instances ------------------------------------------------------------- - --- These are a bit special because the singleton constructor does not uniquely --- determine the type being used in the constructor's return type (e.g., all Nats --- have the same singleton constructor, SNat). To compensate for this, we display --- the type being used using visible type application. (Thanks to @cumber on #179 --- for suggesting this implementation.) - -instance Show (SNat n) where - showsPrec p n@SNat - = showParen (p > appPrec) - ( showString "SNat @" - . showsPrec appPrec1 (TN.natVal n) - ) - -instance Show (SSymbol s) where - showsPrec p s@SSym - = showParen (p > appPrec) - ( showString "SSym @" - . showsPrec appPrec1 (symbolVal s) - ) + showsPrec = showsWrappedSingPrec + show x = showsWrappedSingPrec 0 x "" + showList = showListWith (showsWrappedSingPrec 0) ------------------------------------------------------------- --- Template Haskell-generated instances ------------------------------------------------------------- +showsWrappedSingPrec :: ShowSing k => Int -> WrappedSing (a :: k) -> ShowS +showsWrappedSingPrec p (WrapSing s) = showParen (p >= 11) $ + showString "WrapSing {unwrapSing = " . showsPrec 0 s . showChar '}' -$(showSingInstances basicTypes) +deriving instance ShowSing k => Show (SWrappedSing (ws :: WrappedSing (a :: k))) +#endif diff --git a/src/Data/Singletons/Sigma.hs b/src/Data/Singletons/Sigma.hs --- a/src/Data/Singletons/Sigma.hs +++ b/src/Data/Singletons/Sigma.hs @@ -1,12 +1,11 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE ImpredicativeTypes #-} -- See Note [Impredicative Σ?] {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} -{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -14,6 +13,18 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE QuantifiedConstraints #-} +#else +{-# LANGUAGE TypeInType #-} +#endif + +#if __GLASGOW_HASKELL__ >= 810 +{-# LANGUAGE StandaloneKindSignatures #-} +#else +{-# LANGUAGE ImpredicativeTypes #-} -- See Note [Impredicative Σ?] +#endif + ----------------------------------------------------------------------------- -- | -- Module : Data.Singletons.Sigma @@ -38,52 +49,62 @@ , mapSigma, zipSigma , currySigma, uncurrySigma +#if __GLASGOW_HASKELL__ >= 806 -- * Internal utilities -- $internalutilities , ShowApply, ShowSingApply , ShowApply', ShowSingApply' +#endif ) where -import Data.Kind (Type) -import Data.Singletons.Internal +import Data.Kind +import Data.Singletons +#if __GLASGOW_HASKELL__ >= 806 import Data.Singletons.ShowSing +#endif -- | A dependent pair. +#if __GLASGOW_HASKELL__ >= 810 +type Sigma :: forall s -> (s ~> Type) -> Type +#endif data Sigma (s :: Type) :: (s ~> Type) -> Type where (:&:) :: forall s t fst. Sing (fst :: s) -> t @@ fst -> Sigma s t infixr 4 :&: -instance (ShowSing s, ShowApply t) => Show (Sigma s t) where - showsPrec p ((a :: Sing (fst :: s)) :&: b) = showParen (p >= 5) $ - showsPrec 5 a . showString " :&: " . showsPrec 5 b - :: (ShowSing' fst, ShowApply' t fst) => ShowS -- | Unicode shorthand for 'Sigma'. +#if __GLASGOW_HASKELL__ >= 810 +type Σ :: forall s -> (s ~> Type) -> Type +#endif type Σ = Sigma {- Note [Impredicative Σ?] ~~~~~~~~~~~~~~~~~~~~~~~ -The definition of Σ currently will not typecheck without the use of -ImpredicativeTypes. There isn't a fundamental reason that this should be the -case, and the only reason that GHC currently requires this is due to Trac -#13408. If someone ever fixes that bug, we could remove the use of -ImpredicativeTypes. +The following definition alone: + + type Σ = Sigma + +will not typecheck without the use of ImpredicativeTypes. There isn't a +fundamental reason that this should be the case, and the only reason that GHC +currently requires this is due to GHC#13408. Thankfully, giving Σ a standalone +kind signature works around GHC#13408, so we only have to enable +ImpredicativeTypes on pre-8.10 versions of GHC. -} -- | The singleton type for 'Sigma'. -data SSigma :: forall s (t :: s ~> Type). Sigma s t -> Type where +#if __GLASGOW_HASKELL__ >= 810 +type SSigma :: Sigma s t -> Type +#endif +data SSigma :: forall s t. Sigma s t -> Type where (:%&:) :: forall s t (fst :: s) (sfst :: Sing fst) (snd :: t @@ fst). Sing ('WrapSing sfst) -> Sing snd -> SSigma (sfst ':&: snd :: Sigma s t) infixr 4 :%&: - -type instance Sing = SSigma -instance forall s (t :: s ~> Type) (sig :: Sigma s t). - (ShowSing s, ShowSingApply t) - => Show (SSigma sig) where - showsPrec p ((sa :: Sing ('WrapSing (sfst :: Sing fst))) :%&: (sb :: Sing snd)) = - showParen (p >= 5) $ - showsPrec 5 sa . showString " :&: " . showsPrec 5 sb - :: (ShowSing' fst, ShowSingApply' t fst snd) => ShowS +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @(Sigma s t) = +#else +type instance Sing = +#endif + SSigma instance forall s t (fst :: s) (a :: Sing fst) (b :: t @@ fst). (SingI fst, SingI b) @@ -91,6 +112,9 @@ sing = sing :%&: sing -- | Unicode shorthand for 'SSigma'. +#if __GLASGOW_HASKELL__ >= 810 +type SΣ :: Sigma s t -> Type +#endif type SΣ = SSigma -- | Project the first element out of a dependent pair. @@ -98,6 +122,9 @@ fstSigma (a :&: _) = fromSing a -- | Project the first element out of a dependent pair. +#if __GLASGOW_HASKELL__ >= 810 +type FstSigma :: Sigma s t -> s +#endif type family FstSigma (sig :: Sigma s t) :: s where FstSigma ((_ :: Sing fst) ':&: _) = fst @@ -108,6 +135,9 @@ sndSigma (_ :%&: b) = fromSing b -- | Project the second element out of a dependent pair. +#if __GLASGOW_HASKELL__ >= 810 +type SndSigma :: forall s t. forall (sig :: Sigma s t) -> t @@ FstSigma sig +#endif type family SndSigma (sig :: Sigma s t) :: t @@ FstSigma sig where SndSigma (_ ':&: b) = b @@ -165,6 +195,20 @@ -> (forall (p :: Sigma a b). SSigma p -> c @@ p) uncurrySigma f (x :%&: y) = f x y +#if __GLASGOW_HASKELL__ >= 806 +instance (ShowSing s, ShowApply t) => Show (Sigma s t) where + showsPrec p ((a :: Sing (fst :: s)) :&: b) = showParen (p >= 5) $ + showsPrec 5 a . showString " :&: " . showsPrec 5 b + :: ShowApply' t fst => ShowS + +instance forall s (t :: s ~> Type) (sig :: Sigma s t). + (ShowSing s, ShowSingApply t) + => Show (SSigma sig) where + showsPrec p ((sa :: Sing ('WrapSing (sfst :: Sing fst))) :%&: (sb :: Sing snd)) = + showParen (p >= 5) $ + showsPrec 5 sa . showString " :&: " . showsPrec 5 sb + :: ShowSingApply' t fst snd => ShowS + ------------------------------------------------------------ -- Internal utilities ------------------------------------------------------------ @@ -174,16 +218,31 @@ See the documentation in "Data.Singletons.ShowSing"—in particular, the Haddocks for 'ShowSing' and `ShowSing'`—for an explanation for why these classes exist. + +Note that these classes are only defined on GHC 8.6 or later. -} +#if __GLASGOW_HASKELL__ >= 810 +type ShowApply :: (a ~> Type) -> Constraint +#endif class (forall (x :: a). ShowApply' f x) => ShowApply (f :: a ~> Type) instance (forall (x :: a). ShowApply' f x) => ShowApply (f :: a ~> Type) +#if __GLASGOW_HASKELL__ >= 810 +type ShowApply' :: (a ~> Type) -> a -> Constraint +#endif class Show (Apply f x) => ShowApply' (f :: a ~> Type) (x :: a) instance Show (Apply f x) => ShowApply' (f :: a ~> Type) (x :: a) +#if __GLASGOW_HASKELL__ >= 810 +type ShowSingApply :: (a ~> Type) -> Constraint +#endif class (forall (x :: a) (z :: Apply f x). ShowSingApply' f x z) => ShowSingApply (f :: a ~> Type) instance (forall (x :: a) (z :: Apply f x). ShowSingApply' f x z) => ShowSingApply (f :: a ~> Type) +#if __GLASGOW_HASKELL__ >= 810 +type ShowSingApply' :: forall a. forall (f :: a ~> Type) (x :: a) -> Apply f x -> Constraint +#endif class Show (Sing z) => ShowSingApply' (f :: a ~> Type) (x :: a) (z :: Apply f x) instance Show (Sing z) => ShowSingApply' (f :: a ~> Type) (x :: a) (z :: Apply f x) +#endif diff --git a/src/Data/Singletons/Single.hs b/src/Data/Singletons/Single.hs deleted file mode 100644 --- a/src/Data/Singletons/Single.hs +++ /dev/null @@ -1,1039 +0,0 @@ -{- Data/Singletons/Single.hs - -(c) Richard Eisenberg 2013 -rae@cs.brynmawr.edu - -This file contains functions to refine constructs to work with singleton -types. It is an internal module to the singletons package. --} -{-# LANGUAGE TemplateHaskell, TupleSections, ParallelListComp, CPP #-} - -module Data.Singletons.Single where - -import Prelude hiding ( exp ) -import Language.Haskell.TH hiding ( cxt ) -import Language.Haskell.TH.Syntax (NameSpace(..), Quasi(..)) -import Data.Singletons.Deriving.Ord -import Data.Singletons.Deriving.Bounded -import Data.Singletons.Deriving.Enum -import Data.Singletons.Deriving.Show -import Data.Singletons.Deriving.Util -import Data.Singletons.Util -import Data.Singletons.Promote -import Data.Singletons.Promote.Defun -import Data.Singletons.Promote.Monad ( promoteM ) -import Data.Singletons.Promote.Type -import Data.Singletons.Names -import Data.Singletons.Single.Monad -import Data.Singletons.Single.Type -import Data.Singletons.Single.Data -import Data.Singletons.Single.Defun -import Data.Singletons.Single.Fixity -import Data.Singletons.Single.Eq -import Data.Singletons.Syntax -import Data.Singletons.Partition -import Language.Haskell.TH.Desugar -import qualified Language.Haskell.TH.Desugar.OMap.Strict as OMap -import Language.Haskell.TH.Desugar.OMap.Strict (OMap) -import qualified Language.Haskell.TH.Desugar.OSet as OSet -import Language.Haskell.TH.Desugar.OSet (OSet) -import qualified Data.Map.Strict as Map -import Data.Map.Strict ( Map ) -import Data.Maybe -import qualified Data.Set as Set -import Control.Monad -import Data.List -import qualified GHC.LanguageExtensions.Type as LangExt - -{- -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 and 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 buildDataLets. --} - --- | 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 :: DsMonad q => [Name] -> q [Dec] -genSingletons names = do - checkForRep names - ddecs <- concatMapM (singInfo <=< dsInfo <=< reifyWithLocals) names - return $ decsToTH ddecs - --- | Make promoted and singleton versions of all declarations given, retaining --- the original declarations. --- See for --- further explanation. -singletons :: DsMonad q => q [Dec] -> q [Dec] -singletons qdecs = do - decs <- qdecs - ddecs <- withLocalDeclarations decs $ dsDecs decs - singDecs <- singTopLevelDecs decs ddecs - return (decs ++ decsToTH singDecs) - --- | Make promoted and singleton versions of all declarations given, discarding --- the original declarations. Note that a singleton based on a datatype needs --- the original datatype, so this will fail if it sees any datatype declarations. --- Classes, instances, and functions are all fine. -singletonsOnly :: DsMonad q => q [Dec] -> q [Dec] -singletonsOnly = (>>= wrapDesugar singTopLevelDecs) - --- | Create instances of 'SEq' and type-level @(==)@ for each type in the list -singEqInstances :: DsMonad q => [Name] -> q [Dec] -singEqInstances = concatMapM singEqInstance - --- | Create instance of 'SEq' and type-level @(==)@ for the given type -singEqInstance :: DsMonad 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 :: DsMonad 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 :: DsMonad q => Name -> q [Dec] -singEqInstanceOnly name = singEqualityInstance sEqClassDesc name - --- | Create instances of 'SDecide', 'TestEquality', and 'TestCoercion' for each --- type in the list. -singDecideInstances :: DsMonad q => [Name] -> q [Dec] -singDecideInstances = concatMapM singDecideInstance - --- | Create instance of 'SDecide', 'TestEquality', and 'TestCoercion' for the --- given type. -singDecideInstance :: DsMonad q => Name -> q [Dec] -singDecideInstance name = singEqualityInstance sDecideClassDesc name - --- generalized function for creating equality instances -singEqualityInstance :: DsMonad 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 - let data_ty = foldTypeTvbs (DConT name) dtvbs - dcons <- concatMapM (dsCon dtvbs data_ty) cons - let tyvars = map (DVarT . extractTvbName) dtvbs - kind = foldType (DConT name) tyvars - (scons, _) <- singM [] $ mapM (singCtor name) dcons - eqInstance <- mkEqualityInstance Nothing kind dcons scons desc - testInstances <- - if className == sDecideClassName - then traverse (mkTestInstance Nothing kind name dcons) - [TestEquality, TestCoercion] - else pure [] - return $ decsToTH (eqInstance:testInstances) - --- | Create instances of 'SOrd' for the given types -singOrdInstances :: DsMonad q => [Name] -> q [Dec] -singOrdInstances = concatMapM singOrdInstance - --- | Create instance of 'SOrd' for the given type -singOrdInstance :: DsMonad q => Name -> q [Dec] -singOrdInstance = singInstance mkOrdInstance "Ord" - --- | Create instances of 'SBounded' for the given types -singBoundedInstances :: DsMonad q => [Name] -> q [Dec] -singBoundedInstances = concatMapM singBoundedInstance - --- | Create instance of 'SBounded' for the given type -singBoundedInstance :: DsMonad q => Name -> q [Dec] -singBoundedInstance = singInstance mkBoundedInstance "Bounded" - --- | Create instances of 'SEnum' for the given types -singEnumInstances :: DsMonad q => [Name] -> q [Dec] -singEnumInstances = concatMapM singEnumInstance - --- | Create instance of 'SEnum' for the given type -singEnumInstance :: DsMonad q => Name -> q [Dec] -singEnumInstance = singInstance mkEnumInstance "Enum" - --- | Create instance of 'SShow' for the given type --- --- (Not to be confused with 'showShowInstance'.) -singShowInstance :: DsMonad q => Name -> q [Dec] -singShowInstance = singInstance (mkShowInstance ForPromotion) "Show" - --- | Create instances of 'SShow' for the given types --- --- (Not to be confused with 'showSingInstances'.) -singShowInstances :: DsMonad q => [Name] -> q [Dec] -singShowInstances = concatMapM singShowInstance - --- | Create instance of 'Show' for the given singleton type --- --- (Not to be confused with 'singShowInstance'.) -showSingInstance :: DsMonad q => Name -> q [Dec] -showSingInstance name = do - (tvbs, cons) <- getDataD ("I cannot make an instance of Show for it.") name - dtvbs <- mapM dsTvb tvbs - let data_ty = foldTypeTvbs (DConT name) dtvbs - dcons <- concatMapM (dsCon dtvbs data_ty) cons - let tyvars = map (DVarT . extractTvbName) dtvbs - kind = foldType (DConT name) tyvars - data_decl = DataDecl name dtvbs dcons - deriv_show_decl = DerivedDecl { ded_mb_cxt = Nothing - , ded_type = kind - , ded_type_tycon = name - , ded_decl = data_decl } - (show_insts, _) <- singM [] $ singDerivedShowDecs deriv_show_decl - pure $ decsToTH show_insts - --- | Create instances of 'Show' for the given singleton types --- --- (Not to be confused with 'singShowInstances'.) -showSingInstances :: DsMonad q => [Name] -> q [Dec] -showSingInstances = concatMapM showSingInstance - --- | Create an instance for @'SingI' TyCon{N}@, where @N@ is the positive --- number provided as an argument. --- --- Note that the generated code requires the use of the @QuantifiedConstraints@ --- language extension. -singITyConInstances :: DsMonad q => [Int] -> q [Dec] -singITyConInstances = concatMapM singITyConInstance - --- | Create an instance for @'SingI' TyCon{N}@, where @N@ is the positive --- number provided as an argument. --- --- Note that the generated code requires the use of the @QuantifiedConstraints@ --- language extension. -singITyConInstance :: DsMonad q => Int -> q [Dec] -singITyConInstance n - | n <= 0 - = fail $ "Argument must be a positive number (given " ++ show n ++ ")" - | otherwise - = do as <- replicateM n (qNewName "a") - ks <- replicateM n (qNewName "k") - k_last <- qNewName "k_last" - f <- qNewName "f" - x <- qNewName "x" - let k_penult = last ks - k_fun = ravel (map DVarT ks) (DVarT k_last) - f_ty = DVarT f - a_tys = map DVarT as - mk_fun arrow t1 t2 = arrow `DAppT` t1 `DAppT` t2 - matchable_apply_fun = mk_fun DArrowT (DVarT k_penult) (DVarT k_last) - unmatchable_apply_fun = mk_fun (DConT tyFunArrowName) (DVarT k_penult) (DVarT k_last) - ctxt = [ DForallT (map DPlainTV as) - (map (DAppT (DConT singIName)) a_tys) - (DConT singIName `DAppT` foldType f_ty a_tys) - , DConT equalityName - `DAppT` (DConT applyTyConName `DSigT` - mk_fun DArrowT matchable_apply_fun unmatchable_apply_fun) - `DAppT` DConT applyTyConAux1Name - ] - pure $ decToTH - $ DInstanceD - Nothing Nothing ctxt - (DConT singIName `DAppT` (DConT (mkTyConName n) `DAppT` (f_ty `DSigT` k_fun))) - [DLetDec $ DFunD singMethName - [DClause [] $ - wrapSingFun 1 DWildCardT $ - DLamE [x] $ - DVarE withSingIName `DAppE` DVarE x - `DAppE` DVarE singMethName]] - -singInstance :: DsMonad q => DerivDesc q -> String -> Name -> q [Dec] -singInstance mk_inst inst_name name = do - (tvbs, cons) <- getDataD ("I cannot make an instance of " ++ inst_name - ++ " for it.") name - dtvbs <- mapM dsTvb tvbs - let data_ty = foldTypeTvbs (DConT name) dtvbs - dcons <- concatMapM (dsCon dtvbs data_ty) cons - let data_decl = DataDecl name dtvbs dcons - raw_inst <- mk_inst Nothing data_ty data_decl - (a_inst, decs) <- promoteM [] $ - promoteInstanceDec OMap.empty raw_inst - decs' <- singDecsM [] $ (:[]) <$> singInstD a_inst - return $ decsToTH (decs ++ decs') - -singInfo :: DsMonad q => DInfo -> q [DDec] -singInfo (DTyConI dec _) = - singTopLevelDecs [] [dec] -singInfo (DPrimTyConI _name _numArgs _unlifted) = - fail "Singling of primitive type constructors not supported" -singInfo (DVarI _name _ty _mdec) = - fail "Singling of value info not supported" -singInfo (DTyVarI _name _ty) = - fail "Singling of type variable info not supported" -singInfo (DPatSynI {}) = - fail "Singling of pattern synonym info not supported" - -singTopLevelDecs :: DsMonad q => [Dec] -> [DDec] -> q [DDec] -singTopLevelDecs locals raw_decls = withLocalDeclarations locals $ do - decls <- expand raw_decls -- expand type synonyms - PDecs { pd_let_decs = letDecls - , pd_class_decs = classes - , pd_instance_decs = insts - , pd_data_decs = datas - , pd_ty_syn_decs = ty_syns - , pd_open_type_family_decs = o_tyfams - , pd_closed_type_family_decs = c_tyfams - , pd_derived_eq_decs = derivedEqDecs - , pd_derived_show_decs = derivedShowDecs } <- partitionDecs decls - - ((letDecEnv, classes', insts'), promDecls) <- promoteM locals $ do - defunTypeDecls ty_syns c_tyfams o_tyfams - promoteDataDecs datas - (_, letDecEnv) <- promoteLetDecs noPrefix letDecls - classes' <- mapM promoteClassDec classes - let meth_sigs = foldMap (lde_types . cd_lde) classes - insts' <- mapM (promoteInstanceDec meth_sigs) insts - mapM_ promoteDerivedEqDec derivedEqDecs - return (letDecEnv, classes', insts') - - singDecsM locals $ do - let letBinds = concatMap buildDataLets datas - ++ concatMap buildMethLets classes - (newLetDecls, singIDefunDecls, newDecls) - <- bindLets letBinds $ - singLetDecEnv letDecEnv $ do - newDataDecls <- concatMapM singDataD datas - newClassDecls <- mapM singClassD classes' - newInstDecls <- mapM singInstD insts' - newDerivedEqDecs <- concatMapM singDerivedEqDecs derivedEqDecs - newDerivedShowDecs <- concatMapM singDerivedShowDecs derivedShowDecs - return $ newDataDecls ++ newClassDecls - ++ newInstDecls - ++ newDerivedEqDecs - ++ newDerivedShowDecs - return $ promDecls ++ (map DLetDec newLetDecls) ++ singIDefunDecls ++ newDecls - --- see comment at top of file -buildDataLets :: DataDecl -> [(Name, DExp)] -buildDataLets (DataDecl _name _tvbs cons) = - concatMap con_num_args cons - where - con_num_args :: DCon -> [(Name, DExp)] - con_num_args (DCon _tvbs _cxt name fields _rty) = - (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 ] - --- see comment at top of file -buildMethLets :: UClassDecl -> [(Name, DExp)] -buildMethLets (ClassDecl { cd_lde = LetDecEnv { lde_types = meth_sigs } }) = - map mk_bind (OMap.assocs meth_sigs) - where - mk_bind (meth_name, meth_ty) = - ( meth_name - , wrapSingFun (countArgs meth_ty) (promoteValRhs meth_name) - (DVarE $ singValName meth_name) ) - -singClassD :: AClassDecl -> SgM DDec -singClassD (ClassDecl { cd_cxt = cls_cxt - , cd_name = cls_name - , cd_tvbs = cls_tvbs - , cd_fds = cls_fundeps - , cd_lde = LetDecEnv { lde_defns = default_defns - , lde_types = meth_sigs - , lde_infix = fixities - , lde_proms = promoted_defaults - , lde_bound_kvs = meth_bound_kvs } }) = - bindContext [foldTypeTvbs (DConT cls_name) cls_tvbs] $ do - (sing_sigs, _, tyvar_names, cxts, res_kis, singIDefunss) - <- unzip6 <$> zipWithM (singTySig no_meth_defns meth_sigs meth_bound_kvs) - meth_names (map promoteValRhs meth_names) - emitDecs $ concat singIDefunss - let default_sigs = catMaybes $ - zipWith4 mk_default_sig meth_names sing_sigs tyvar_names res_kis - res_ki_map = Map.fromList (zip meth_names - (map (fromMaybe always_sig) res_kis)) - sing_meths <- mapM (uncurry (singLetDecRHS (Map.fromList tyvar_names) - (Map.fromList cxts) - res_ki_map)) - (OMap.assocs default_defns) - fixities' <- traverse (uncurry singInfixDecl) $ OMap.assocs fixities - cls_cxt' <- mapM singPred cls_cxt - return $ DClassD cls_cxt' - (singClassName cls_name) - cls_tvbs - cls_fundeps -- they are fine without modification - (map DLetDec (sing_sigs ++ sing_meths ++ fixities') ++ default_sigs) - where - no_meth_defns = error "Internal error: can't find declared method type" - always_sig = error "Internal error: no signature for default method" - meth_names = map fst $ OMap.assocs meth_sigs - - mk_default_sig meth_name (DSigD s_name sty) bound_kvs (Just res_ki) = - DDefaultSigD s_name <$> add_constraints meth_name sty bound_kvs res_ki - mk_default_sig _ _ _ _ = error "Internal error: a singled signature isn't a signature." - - add_constraints meth_name sty (_, bound_kvs) res_ki = do -- Maybe monad - prom_dflt <- OMap.lookup meth_name promoted_defaults - let default_pred = foldType (DConT equalityName) - -- NB: Need the res_ki here to prevent ambiguous - -- kinds in result-inferred default methods. - -- See #175 - [ foldApply (promoteValRhs meth_name) tvs `DSigT` res_ki - , foldApply prom_dflt tvs ] - return $ DForallT tvbs (default_pred : cxt) (ravel args res) - where - (tvbs, cxt, args, res) = unravel sty - bound_kv_set = Set.fromList bound_kvs - -- Filter out explicitly bound kind variables. Otherwise, if you had - -- the following class (#312): - -- - -- class Foo a where - -- bar :: a -> b -> b - -- bar _ x = x - -- - -- Then it would be singled to: - -- - -- class SFoo a where - -- sBar :: forall b (x :: a) (y :: b). Sing x -> Sing y -> Sing (sBar x y) - -- default :: forall b (x :: a) (y :: b). - -- (Bar b x y) ~ (BarDefault b x y) => ... - -- - -- Which applies Bar/BarDefault to b, which shouldn't happen. - tvs = map tvbToType $ - filter (\tvb -> extractTvbName tvb `Set.member` bound_kv_set) tvbs - - -singInstD :: AInstDecl -> SgM DDec -singInstD (InstDecl { id_cxt = cxt, id_name = inst_name, id_arg_tys = inst_tys - , id_sigs = inst_sigs, id_meths = ann_meths }) = do - bindContext cxt $ do - cxt' <- mapM singPred cxt - inst_kis <- mapM promoteType inst_tys - meths <- concatMapM (uncurry sing_meth) ann_meths - return (DInstanceD Nothing - Nothing - cxt' - (foldl DAppT (DConT s_inst_name) inst_kis) - meths) - - where - s_inst_name = singClassName inst_name - - sing_meth :: Name -> ALetDecRHS -> SgM [DDec] - sing_meth name rhs = do - mb_s_info <- dsReify (singValName name) - inst_kis <- mapM promoteType inst_tys - let mk_subst cls_tvbs = Map.fromList $ zip (map extractTvbName vis_cls_tvbs) inst_kis - where - -- This is a half-hearted attempt to address the underlying problem - -- in #358, where we can sometimes have more class type variables - -- (due to implicit kind arguments) than class arguments. This just - -- ensures that the explicit type variables are properly mapped - -- to the class arguments, leaving the implicit kind variables - -- unmapped. That could potentially cause *other* problems, but - -- those are perhaps best avoided by using InstanceSigs. At the - -- very least, this workaround will make error messages slightly - -- less confusing. - vis_cls_tvbs = drop (length cls_tvbs - length inst_kis) cls_tvbs - - sing_meth_ty :: OSet Name -> DType - -> SgM (DType, [Name], DCxt, DKind) - sing_meth_ty bound_kvs inner_ty = do - -- Make sure to expand through type synonyms here! Not doing so - -- resulted in #167. - raw_ty <- expand inner_ty - (s_ty, _num_args, tyvar_names, ctxt, _arg_kis, res_ki) - <- singType bound_kvs (promoteValRhs name) raw_ty - pure (s_ty, tyvar_names, ctxt, res_ki) - - (s_ty, tyvar_names, ctxt, m_res_ki) <- case OMap.lookup name inst_sigs of - Just inst_sig -> do - -- We have an InstanceSig, so just single that type. Take care to - -- avoid binding the variables bound by the instance head as well. - let inst_bound = foldMap fvDType (cxt ++ inst_kis) - (s_ty, tyvar_names, ctxt, res_ki) <- sing_meth_ty inst_bound inst_sig - pure (s_ty, tyvar_names, ctxt, Just res_ki) - Nothing -> case mb_s_info of - -- We don't have an InstanceSig, so we must compute the type to use - -- in the singled instance ourselves through reification. - Just (DVarI _ (DForallT cls_tvbs _cls_pred s_ty) _) -> do - let subst = mk_subst cls_tvbs - (sing_tvbs, ctxt, _args, res_ty) = unravel s_ty - m_res_ki = case res_ty of - _sing `DAppT` (_prom_func `DSigT` res_ki) -> Just (substKind subst res_ki) - _ -> Nothing - - pure ( substType subst s_ty - , map extractTvbName sing_tvbs - , map (substType subst) ctxt - , m_res_ki ) - _ -> do - mb_info <- dsReify name - case mb_info of - Just (DVarI _ (DForallT cls_tvbs _cls_pred inner_ty) _) -> do - let subst = mk_subst cls_tvbs - cls_kvb_names = foldMap (foldMap fvDType . extractTvbKind) cls_tvbs - cls_tvb_names = OSet.fromList $ map extractTvbName cls_tvbs - cls_bound = cls_kvb_names `OSet.union` cls_tvb_names - (s_ty, tyvar_names, ctxt, res_ki) <- sing_meth_ty cls_bound inner_ty - pure ( substType subst s_ty - , tyvar_names - , ctxt - , Just (substKind subst res_ki) ) - _ -> fail $ "Cannot find type of method " ++ show name - - let kind_map = maybe Map.empty (Map.singleton name) m_res_ki - meth' <- singLetDecRHS (Map.singleton name tyvar_names) - (Map.singleton name ctxt) - kind_map name rhs - return $ map DLetDec [DSigD (singValName name) s_ty, meth'] - -singLetDecEnv :: ALetDecEnv - -> SgM a - -> SgM ([DLetDec], [DDec], a) - -- Return: - -- - -- 1. The singled let-decs - -- 2. SingI instances for any defunctionalization symbols - -- (see Data.Singletons.Single.Defun) - -- 3. The result of running the `SgM a` action -singLetDecEnv (LetDecEnv { lde_defns = defns - , lde_types = types - , lde_infix = infix_decls - , lde_proms = proms - , lde_bound_kvs = bound_kvs }) - thing_inside = do - let prom_list = OMap.assocs proms - (typeSigs, letBinds, tyvarNames, cxts, res_kis, singIDefunss) - <- unzip6 <$> mapM (uncurry (singTySig defns types bound_kvs)) prom_list - infix_decls' <- traverse (uncurry singInfixDecl) $ OMap.assocs infix_decls - let res_ki_map = Map.fromList [ (name, res_ki) | ((name, _), Just res_ki) - <- zip prom_list res_kis ] - bindLets letBinds $ do - let_decs <- mapM (uncurry (singLetDecRHS (Map.fromList tyvarNames) - (Map.fromList cxts) - res_ki_map)) - (OMap.assocs defns) - thing <- thing_inside - return (infix_decls' ++ typeSigs ++ let_decs, concat singIDefunss, thing) - -singTySig :: OMap Name ALetDecRHS -- definitions - -> OMap Name DType -- type signatures - -> OMap Name (OSet Name) -- bound kind variables - -> 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 - , (Name, DCxt) -- the context of the type signature - , Maybe DKind -- the result kind in the tysig - , [DDec] -- SingI instances for defun symbols - ) -singTySig defns types bound_kvs name prom_ty = - let sName = singValName name in - case OMap.lookup name types of - Nothing -> do - num_args <- guess_num_args - (sty, tyvar_names) <- mk_sing_ty num_args - singIDefuns <- singDefuns name VarName [] - (map (const Nothing) tyvar_names) Nothing - return ( DSigD sName sty - , (name, wrapSingFun num_args prom_ty (DVarE sName)) - , (name, tyvar_names) - , (name, []) - , Nothing - , singIDefuns ) - Just ty -> do - all_bound_kvs <- lookup_bound_kvs - (sty, num_args, tyvar_names, ctxt, arg_kis, res_ki) - <- singType all_bound_kvs prom_ty ty - bound_cxt <- askContext - singIDefuns <- singDefuns name VarName (bound_cxt ++ ctxt) - (map Just arg_kis) (Just res_ki) - return ( DSigD sName sty - , (name, wrapSingFun num_args prom_ty (DVarE sName)) - , (name, tyvar_names) - , (name, ctxt) - , Just res_ki - , singIDefuns ) - where - guess_num_args :: SgM Int - guess_num_args = - case OMap.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 - - lookup_bound_kvs :: SgM (OSet Name) - lookup_bound_kvs = - case OMap.lookup name bound_kvs of - Nothing -> fail $ "Internal error: " ++ nameBase name ++ " has no type variable " - ++ "bindings, despite having a type signature" - Just kvs -> pure kvs - - -- create a Sing t1 -> Sing t2 -> ... type of a given arity and result type - mk_sing_ty :: Int -> SgM (DType, [Name]) - mk_sing_ty n = do - arg_names <- replicateM n (qNewName "arg") - return ( DForallT (map DPlainTV arg_names) [] - (ravel (map (\nm -> singFamily `DAppT` DVarT nm) arg_names) - (singFamily `DAppT` - (foldl apply prom_ty (map DVarT arg_names)))) - , arg_names ) - -singLetDecRHS :: Map Name [Name] - -> Map Name DCxt -- the context of the type signature - -- (might not be known) - -> Map Name DKind -- result kind (might not be known) - -> Name -> ALetDecRHS -> SgM DLetDec -singLetDecRHS bound_names cxts res_kis name ld_rhs = - bindContext (Map.findWithDefault [] name cxts) $ - case ld_rhs of - AValue prom num_arrows exp -> - DValD (DVarP (singValName name)) <$> - (wrapUnSingFun num_arrows prom <$> singExp exp (Map.lookup name res_kis)) - AFunction prom_fun num_arrows clauses -> - let tyvar_names = case Map.lookup name bound_names of - Nothing -> [] - Just ns -> ns - res_ki = Map.lookup name res_kis - in - DFunD (singValName name) <$> - mapM (singClause prom_fun num_arrows tyvar_names res_ki) 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 - -> Maybe DKind -- result kind, if known - -> ADClause -> SgM DClause -singClause prom_fun num_arrows bound_names res_ki - (ADClause var_proms pats exp) = do - - -- Fix #166: - when (num_arrows - length pats < 0) $ - fail $ "Function being promoted to " ++ (pprint (typeToTH prom_fun)) ++ - " has too many arguments." - - (sPats, sigPaExpsSigs) <- evalForPair $ mapM (singPat (Map.fromList var_proms)) pats - sBody <- singExp exp res_ki - -- when calling unSingFun, the promoted 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 $ mkSigPaCaseE sigPaExpsSigs sBody' - -singPat :: Map Name Name -- from term-level names to type-level names - -> ADPat - -> QWithAux SingDSigPaInfos SgM DPat -singPat var_proms = go - where - go :: ADPat -> QWithAux SingDSigPaInfos SgM DPat - go (ADLitP _lit) = - fail "Singling of literal patterns not yet supported" - go (ADVarP name) = do - tyname <- case Map.lookup name var_proms of - Nothing -> - fail "Internal error: unknown variable when singling pattern" - Just tyname -> return tyname - pure $ DVarP (singValName name) `DSigP` (singFamily `DAppT` DVarT tyname) - go (ADConP name pats) = DConP (singDataConName name) <$> mapM go pats - go (ADTildeP pat) = do - qReportWarning - "Lazy pattern converted into regular pattern during singleton generation." - go pat - go (ADBangP pat) = DBangP <$> go pat - go (ADSigP prom_pat pat ty) = do - pat' <- go pat - -- Normally, calling dPatToDExp would be dangerous, since it fails if the - -- supplied pattern contains any wildcard patterns. However, promotePat - -- (which produced the pattern we're passing into dPatToDExp) maintains - -- an invariant that any promoted pattern signatures will be free of - -- wildcard patterns in the underlying pattern. - -- See Note [Singling pattern signatures]. - addElement (dPatToDExp pat', DSigT prom_pat ty) - pure pat' - go ADWildP = pure DWildP - --- | If given a non-empty list of 'SingDSigPaInfos', construct a case expression --- that brings singleton equality constraints into scope via pattern-matching. --- See @Note [Singling pattern signatures]@. -mkSigPaCaseE :: SingDSigPaInfos -> DExp -> DExp -mkSigPaCaseE exps_with_sigs exp - | null exps_with_sigs = exp - | otherwise = - let (exps, sigs) = unzip exps_with_sigs - scrutinee = mkTupleDExp exps - pats = map (DSigP DWildP . DAppT (DConT singFamilyName)) sigs - in DCaseE scrutinee [DMatch (mkTupleDPat pats) exp] - --- Note [Annotate case return type] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- We're straining GHC's type inference here. One particular trouble area --- is determining the return type of a GADT pattern match. In general, GHC --- cannot infer return types of GADT pattern matches because the return type --- becomes "untouchable" in the case matches. See the OutsideIn paper. But, --- during singletonization, we *know* the return type. So, just add a type --- annotation. See #54. --- --- In particular, we add a type annotation in a somewhat unorthodox fashion. --- Instead of the usual `(x :: t)`, we use `id @t x`. See --- Note [The id hack; or, how singletons learned to stop worrying and avoid --- kind generalization] for an explanation of why we do this. - --- Note [Why error is so special] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Some of the transformations that happen before this point produce impossible --- case matches. We must be careful when processing these so as not to make --- an error GHC will complain about. When binding the case-match variables, we --- normally include an equality constraint saying that the scrutinee is equal --- to the matched pattern. But, we can't do this in inaccessible matches, because --- equality is bogus, and GHC (rightly) complains. However, we then have another --- problem, because GHC doesn't have enough information when type-checking the --- RHS of the inaccessible match to deem it type-safe. The solution: treat error --- as super-special, so that GHC doesn't look too hard at singletonized error --- calls. Specifically, DON'T do the applySing stuff. Just use sError, which --- has a custom type (Sing x -> a) anyway. - --- Note [Singling pattern signatures] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- We want to single a pattern signature, like so: --- --- f :: Maybe a -> a --- f (Just x :: Maybe a) = x --- --- Naïvely, one might expect this to single straightfowardly as: --- --- sF :: forall (z :: Maybe a). Sing z -> Sing (F z) --- sF (SJust sX :: Sing (Just x :: Maybe a)) = sX --- --- But the way GHC typechecks patterns prevents this from working, as GHC won't --- know that the type `z` is actually `Just x` until /after/ the entirety of --- the `SJust sX` pattern has been typechecked. (See Trac #12018 for an --- extended discussion on this topic.) --- --- To work around this design, we resort to a somewhat unsightly trick: --- immediately after matching on all the patterns, we perform a case on every --- pattern with a pattern signature, like so: --- --- sF :: forall (z :: Maybe a). Sing z -> Sing (F z) --- sF (SJust sX :: Sing z) --- = case (SJust sX :: Sing z) of --- (_ :: Sing (Just x :: Maybe a)) -> sX --- --- Now GHC accepts the fact that `z` is `Just x`, and all is well. In order --- to support this construction, the type of singPat is augmented with some --- extra information in the form of SingDSigPaInfos: --- --- type SingDSigPaInfos = [(DExp, DType)] --- --- Where the DExps corresponds to the expressions we case on just after the --- patterns (`SJust sX :: Sing x`, in the example above), and the DTypes --- correspond to the singled pattern signatures to use in the case alternative --- (`Sing (Just x :: Maybe a)` in the example above). singPat appends to the --- list of SingDSigPaInfos whenever it processes a DSigPa (pattern signature), --- and call sites can pass these SingDSigPaInfos to mkSigPaCaseE to construct a --- case expression like the one featured above. --- --- Some interesting consequences of this design: --- --- 1. We must promote DPats to ADPats, a variation of DPat where the annotated --- DSigPa counterpart, ADSigPa, stores the type that the original DPat was --- promoted to. This is necessary since promoting the type might have --- generated fresh variable names, so we need to be able to use the same --- names when singling. --- --- 2. Also when promoting a DSigPa to an ADSigPa, we remove any wildcards from --- the underlying pattern. To see why this is necessary, consider singling --- this example: --- --- g (Just _ :: Maybe a) = "hi" --- --- This must single to something like this: --- --- sG (SJust _ :: Sing z) --- = case (SJust _ :: Sing z) of --- (_ :: Sing (Just _ :: Maybe a)) -> "hi" --- --- But `SJust _` is not a valid expression, and since the minimal th-desugar --- AST lacks as-patterns, we can't replace it with something like --- `sG x@(SJust _ :: Sing z) = case x of ...`. But even if the th-desugar --- AST /did/ have as-patterns, we'd still be in trouble, as `Just _` isn't --- a valid type without the use of -XPartialTypeSignatures, which isn't a --- design we want to force upon others. --- --- We work around both issues by simply converting all wildcard patterns --- from the pattern that has a signature. That means our example becomes: --- --- sG (SJust sWild :: Sing z) --- = case (SJust sWild :: Sing z) of --- (_ :: Sing (Just wild :: Maybe a)) -> "hi" --- --- And now everything is hunky-dory. - -singExp :: ADExp -> Maybe DKind -- the kind of the expression, if known - -> SgM DExp - -- See Note [Why error is so special] -singExp (ADVarE err `ADAppE` arg) _res_ki - | err == errorName = DAppE (DVarE (singValName err)) <$> - singExp arg (Just (DConT symbolName)) -singExp (ADVarE name) _res_ki = lookupVarE name -singExp (ADConE name) _res_ki = lookupConE name -singExp (ADLitE lit) _res_ki = singLit lit -singExp (ADAppE e1 e2) _res_ki = do - e1' <- singExp e1 Nothing - e2' <- singExp e2 Nothing - -- `applySing undefined x` kills type inference, because GHC can't figure - -- out the type of `undefined`. So we don't emit `applySing` there. - if isException e1' - then return $ e1' `DAppE` e2' - else return $ (DVarE applySingName) `DAppE` e1' `DAppE` e2' -singExp (ADLamE ty_names prom_lam names exp) _res_ki = do - let sNames = map singValName names - exp' <- singExp exp Nothing - -- we need to bind the type variables... but DLamE doesn't allow SigT patterns. - -- So: build a case - let caseExp = DCaseE (mkTupleDExp (map DVarE sNames)) - [DMatch (mkTupleDPat - (map ((DWildP `DSigP`) . - (singFamily `DAppT`) . - DVarT) ty_names)) exp'] - return $ wrapSingFun (length names) prom_lam $ DLamE sNames caseExp -singExp (ADCaseE exp matches ret_ty) res_ki = - -- See Note [Annotate case return type] and - -- Note [The id hack; or, how singletons learned to stop worrying and - -- avoid kind generalization] - DAppE (DAppTypeE (DVarE 'id) - (singFamily `DAppT` (ret_ty `maybeSigT` res_ki))) - <$> (DCaseE <$> singExp exp Nothing <*> mapM (singMatch res_ki) matches) -singExp (ADLetE env exp) res_ki = do - -- We intentionally discard the SingI instances for exp's defunctionalization - -- symbols, as we also do not generate the declarations for the - -- defunctionalization symbols in the first place during promotion. - (let_decs, _, exp') <- singLetDecEnv env $ singExp exp res_ki - pure $ DLetE let_decs exp' -singExp (ADSigE prom_exp exp ty) _ = do - exp' <- singExp exp (Just ty) - pure $ DSigE exp' $ DConT singFamilyName `DAppT` DSigT prom_exp ty - --- See Note [DerivedDecl] in Data.Singletons.Syntax -singDerivedEqDecs :: DerivedEqDecl -> SgM [DDec] -singDerivedEqDecs (DerivedDecl { ded_mb_cxt = mb_ctxt - , ded_type = ty - , ded_type_tycon = ty_tycon - , ded_decl = DataDecl _ _ cons }) = do - (scons, _) <- singM [] $ mapM (singCtor ty_tycon) cons - mb_sctxt <- mapM (mapM singPred) mb_ctxt - kind <- promoteType ty - sEqInst <- mkEqualityInstance mb_sctxt kind cons scons sEqClassDesc - -- Beware! The user might have specified an instance context like this: - -- - -- deriving instance Eq a => Eq (T a Int) - -- - -- When we single the context, it will become (SEq a). But we do *not* want - -- this for the SDecide instance! The simplest solution is to simply replace - -- all occurrences of SEq with SDecide in the context. - let mb_sctxtDecide = fmap (map sEqToSDecide) mb_sctxt - sDecideInst <- mkEqualityInstance mb_sctxtDecide kind cons scons sDecideClassDesc - testInsts <- traverse (mkTestInstance mb_sctxtDecide kind ty_tycon cons) - [TestEquality, TestCoercion] - return (sEqInst:sDecideInst:testInsts) - --- Walk a DPred, replacing all occurrences of SEq with SDecide. -sEqToSDecide :: DPred -> DPred -sEqToSDecide = modifyConNameDType $ \n -> - -- Why don't we directly compare n to sEqClassName? Because n is almost certainly - -- produced from a call to singClassName, which uses unqualified Names. Ugh. - if nameBase n == nameBase sEqClassName - then sDecideClassName - else n - --- See Note [DerivedDecl] in Data.Singletons.Syntax -singDerivedShowDecs :: DerivedShowDecl -> SgM [DDec] -singDerivedShowDecs (DerivedDecl { ded_mb_cxt = mb_cxt - , ded_type = ty - , ded_type_tycon = ty_tycon - , ded_decl = data_decl }) = do - -- Generate a Show instance for a singleton type, like this: - -- - -- instance (ShowSing a, ShowSing b) => Show (SEither (z :: Either a b)) where - -- showsPrec p (SLeft (sl :: Sing l)) = - -- showParen (p > 10) $ showString "SLeft " . showsPrec 11 sl - -- :: ShowSing' l => ShowS - -- showsPrec p (SRight (sr :: Sing r)) = - -- showParen (p > 10) $ showString "SRight " . showsPrec 11 sr - -- :: ShowSing' r => ShowS - -- - -- Be careful: we want to generate an instance context that uses ShowSing, - -- not SShow. - show_sing_inst <- mkShowInstance (ForShowSing ty_tycon) mb_cxt ty data_decl - pure [toInstanceD show_sing_inst] - where - toInstanceD :: UInstDecl -> DDec - toInstanceD (InstDecl { id_cxt = cxt, id_name = inst_name - , id_arg_tys = inst_tys, id_meths = ann_meths }) = - DInstanceD Nothing Nothing cxt (foldType (DConT inst_name) inst_tys) - (map (DLetDec . toFunD) ann_meths) - - toFunD :: (Name, ULetDecRHS) -> DLetDec - toFunD (fun_name, UFunction clauses) = DFunD fun_name clauses - toFunD (val_name, UValue rhs) = DValD (DVarP val_name) rhs - -isException :: DExp -> Bool -isException (DVarE n) = nameBase n == "sUndefined" -isException (DConE {}) = False -isException (DLitE {}) = False -isException (DAppE (DVarE fun) _) | nameBase fun == "sError" = True -isException (DAppE fun _) = isException fun -isException (DAppTypeE e _) = isException e -isException (DLamE _ _) = False -isException (DCaseE e _) = isException e -isException (DLetE _ e) = isException e -isException (DSigE e _) = isException e -isException (DStaticE e) = isException e - -singMatch :: Maybe DKind -- ^ the result kind, if known - -> ADMatch -> SgM DMatch -singMatch res_ki (ADMatch var_proms pat exp) = do - (sPat, sigPaExpsSigs) <- evalForPair $ singPat (Map.fromList var_proms) pat - sExp <- singExp exp res_ki - return $ DMatch sPat $ mkSigPaCaseE sigPaExpsSigs sExp - -singLit :: Lit -> SgM DExp -singLit (IntegerL n) - | n >= 0 = return $ - DVarE sFromIntegerName `DAppE` - (DVarE singMethName `DSigE` - (singFamily `DAppT` DLitT (NumTyLit n))) - | otherwise = do sLit <- singLit (IntegerL (-n)) - return $ DVarE sNegateName `DAppE` sLit -singLit (StringL str) = do - let sing_str_lit = DVarE singMethName `DSigE` - (singFamily `DAppT` DLitT (StrTyLit str)) - os_enabled <- qIsExtEnabled LangExt.OverloadedStrings - pure $ if os_enabled - then DVarE sFromStringName `DAppE` sing_str_lit - else sing_str_lit -singLit lit = - fail ("Only string and natural number literals can be singled: " ++ show lit) - -maybeSigT :: DType -> Maybe DKind -> DType -maybeSigT ty Nothing = ty -maybeSigT ty (Just ki) = ty `DSigT` ki - -{- -Note [The id hack; or, how singletons learned to stop worrying and avoid kind generalization] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC 8.8 was a time of great change. In particular, 8.8 debuted a fix for -Trac #15141 (decideKindGeneralisationPlan is too complicated). To fix this, a -wily GHC developer—who shall remain unnamed, but whose username rhymes with -schmoldfire—decided to make decideKindGeneralisationPlan less complicated by, -well, removing the whole thing. One consequence of this is that local -definitions are now kind-generalized (whereas they would not have been -previously). - -While schmoldfire had the noblest of intentions when authoring his fix, he -unintentionally made life much harder for singletons. Why? Consider the -following program: - - class Foo a where - bar :: a -> (a -> b) -> b - baz :: a - - quux :: Foo a => a -> a - quux x = x `bar` \_ -> baz - -When singled, this program will turn into something like this: - - type family Quux (x :: a) :: a where - Quux x = Bar x (LambdaSym1 x) - - sQuux :: forall a (x :: a). SFoo a => Sing x -> Sing (Quux x :: a) - sQuux (sX :: Sing x) - = sBar sX - ((singFun1 @(LambdaSym1 x)) - (\ sArg - -> case sArg of { - (_ :: Sing arg) - -> (case sArg of { _ -> sBaz }) :: - Sing (Case x arg arg) })) - - type family Case x arg t where - Case x arg _ = Baz - type family Lambda x t where - Lambda x arg = Case x arg arg - data LambdaSym1 x t - type instance Apply (LambdaSym1 x) t = Lambda x t - -The high-level bit is the explicit `Sing (Case x arg arg)` signature. Question: -what is the kind of `Case x arg arg`? The answer depends on whether local -definitions are kind-generalized or not! - -1. If local definitions are *not* kind-generalized (i.e., the status quo before - GHC 8.8), then `Case x arg arg :: a`. -2. If local definitions *are* kind-generalized (i.e., the status quo in GHC 8.8 - and later), then `Case x arg arg :: k` for some fresh kind variable `k`. - -Unfortunately, the kind of `Case x arg arg` *must* be `a` in order for `sQuux` -to type-check. This means that the code above suddenly stopped working in GHC -8.8. What's more, we can't just remove these explicit signatures, as there is -code elsewhere in `singletons` that crucially relies on them to guide type -inference along (e.g., `sShowParen` in `Data.Singletons.Prelude.Show`). - -Luckily, there is an ingenious hack that lets us the benefits of explicit -signatures without the pain of kind generalization: our old friend, the `id` -function. The plan is as follows: instead of generating this code: - - (case sArg of ...) :: Sing (Case x arg arg) - -We instead generate this code: - - id @(Sing (Case x arg arg)) (case sArg of ...) - -That's it! This works because visible type arguments in terms do not get kind- -generalized, unlike top-level or local signatures. Now `Case x arg arg`'s kind -is not generalized, and all is well. We dub this: the `id` hack. - -One might wonder: will we need the `id` hack around forever? Perhaps not. While -GHC 8.8 removed the decideKindGeneralisationPlan function, there have been -rumblings that a future version of GHC may bring it back (in a limited form). -If this happens, it is possibly that GHC's attitude towards kind-generalizing -local definitons may change *again*, which could conceivably render the `id` -hack unnecessary. This is all speculation, of course, so all we can do now is -wait and revisit this design at a later date. --} diff --git a/src/Data/Singletons/Single/Data.hs b/src/Data/Singletons/Single/Data.hs deleted file mode 100644 --- a/src/Data/Singletons/Single/Data.hs +++ /dev/null @@ -1,183 +0,0 @@ -{- Data/Singletons/Single/Data.hs - -(c) Richard Eisenberg 2013 -rae@cs.brynmawr.edu - -Singletonizes constructors. --} - -{-# LANGUAGE ParallelListComp, TupleSections, LambdaCase #-} - -module Data.Singletons.Single.Data where - -import Language.Haskell.TH.Desugar -import Language.Haskell.TH.Desugar.OSet (OSet) -import Language.Haskell.TH.Syntax -import Data.Singletons.Single.Defun -import Data.Singletons.Single.Monad -import Data.Singletons.Single.Type -import Data.Singletons.Single.Fixity -import Data.Singletons.Promote.Type -import Data.Singletons.Util -import Data.Singletons.Names -import Data.Singletons.Syntax -import Control.Monad -import Data.Foldable - --- We wish to consider the promotion of "Rep" to be * --- not a promoted data constructor. -singDataD :: DataDecl -> SgM [DDec] -singDataD (DataDecl name tvbs ctors) = do - let tvbNames = map extractTvbName tvbs - k <- promoteType (foldType (DConT name) (map DVarT tvbNames)) - ctors' <- mapM (singCtor name) ctors - ctorFixities <- - -- try to reify the fixity declarations for the constructors and then - -- singletonize them. In case the reification fails, we default to an - -- empty list of singletonized fixity declarations. - -- why this works: - -- 1. if we're in a call to 'genSingletons', the data type was defined - -- earlier and its constructors are in scope, the reification succeeds. - -- 2. if we're in a call to 'singletons', the reification will fail, but - -- the fixity declaration will get singletonized by itself (not from - -- here, look for other invocations of 'singInfixDecl') - singFixityDeclarations [ n | DCon _ _ n _ _ <- ctors ] - -- instance for SingKind - fromSingClauses <- mapM mkFromSingClause ctors - emptyFromSingClause <- mkEmptyFromSingClause - toSingClauses <- mapM mkToSingClause ctors - emptyToSingClause <- mkEmptyToSingClause - let singKindInst = - DInstanceD Nothing Nothing - (map (singKindConstraint . DVarT) tvbNames) - (DAppT (DConT singKindClassName) k) - [ DTySynInstD $ DTySynEqn Nothing - (DConT demoteName `DAppT` k) - (foldType (DConT name) - (map (DAppT demote . DVarT) tvbNames)) - , DLetDec $ DFunD fromSingName - (fromSingClauses `orIfEmpty` [emptyFromSingClause]) - , DLetDec $ DFunD toSingName - (toSingClauses `orIfEmpty` [emptyToSingClause]) ] - - let singDataName = singTyConName name - -- e.g. type instance Sing @Nat = SNat - singSynInst = - DTySynInstD $ DTySynEqn Nothing - (DConT singFamilyName `DAppKindT` k) - (DConT singDataName) - kindedSingTy = DForallT (map DPlainTV tvbNames) [] $ - DArrowT `DAppT` k `DAppT` DConT typeKindName - - return $ (DDataD Data [] singDataName [] (Just kindedSingTy) ctors' []) : - singSynInst : - singKindInst : - ctorFixities - 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 [DConP (singDataConName cname) (map DVarP varNames)] - (foldExp - (DConE cname') - (map (DAppE (DVarE fromSingName) . DVarE) varNames)) - - mkToSingClause :: DCon -> SgM DClause - mkToSingClause (DCon _tvbs _cxt cname fields _rty) = 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 varPats = zipWith mkToSingVarPat varNames promoted - recursiveCalls = zipWith mkRecursiveCall varNames promoted - return $ - DClause [DConP cname' varPats] - (multiCase recursiveCalls - (map (DConP someSingDataName . listify . DVarP) - svarNames) - (DAppE (DConE someSingDataName) - (foldExp (DConE (singDataConName cname)) - (map DVarE svarNames)))) - - mkToSingVarPat :: Name -> DKind -> DPat - mkToSingVarPat varName ki = - DSigP (DVarP varName) (DAppT (DConT demoteName) ki) - - mkRecursiveCall :: Name -> DKind -> DExp - mkRecursiveCall var_name ki = - DSigE (DAppE (DVarE toSingName) (DVarE var_name)) - (DAppT (DConT someSingTypeName) ki) - - mkEmptyFromSingClause :: SgM DClause - mkEmptyFromSingClause = do - x <- qNewName "x" - pure $ DClause [DVarP x] - $ DCaseE (DVarE x) [] - - mkEmptyToSingClause :: SgM DClause - mkEmptyToSingClause = do - x <- qNewName "x" - pure $ DClause [DVarP x] - $ DConE someSingDataName `DAppE` DCaseE (DVarE x) [] - --- refine a constructor. -singCtor :: Name -> DCon -> SgM DCon - -- polymorphic constructors are handled just - -- like monomorphic ones -- the polymorphism in - -- the kind is automatic -singCtor dataName (DCon _tvbs cxt name fields rty) - | 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 - let bound_kvs = foldMap fvDType kinds - args <- zipWithM (buildArgType bound_kvs) types indices - rty' <- promoteType rty - let tvbs = map DPlainTV (toList bound_kvs) ++ zipWith DKindedTV indexNames kinds - kindedIndices = zipWith DSigT indices kinds - - -- SingI instance for data constructor - emitDecs - [DInstanceD Nothing Nothing - (map (DAppT (DConT singIName)) indices) - (DAppT (DConT singIName) - (foldType pCon kindedIndices)) - [DLetDec $ DValD (DVarP singMethName) - (foldExp sCon (map (const $ DVarE singMethName) types))]] - -- SingI instances for defunctionalization symbols. Note that we don't - -- support contexts in constructors at the moment, so it's fine for now to - -- just assume that the context is always (). - emitDecs =<< singDefuns name DataName [] (map Just kinds) (Just rty') - - let noBang = Bang NoSourceUnpackedness NoSourceStrictness - conFields = case fields of - DNormalC dInfix _ -> DNormalC dInfix $ map (noBang,) args - DRecC rec_fields -> - DRecC [ (singValName field_name, noBang, arg) - | (field_name, _, _) <- rec_fields - | arg <- args ] - return $ DCon tvbs - [] - sName - conFields - (DConT (singTyConName dataName) `DAppT` foldType pCon indices) - where buildArgType :: OSet Name -> DType -> DType -> SgM DType - buildArgType bound_kvs ty index = do - (ty', _, _, _, _, _) <- singType bound_kvs index ty - return ty' diff --git a/src/Data/Singletons/Single/Defun.hs b/src/Data/Singletons/Single/Defun.hs deleted file mode 100644 --- a/src/Data/Singletons/Single/Defun.hs +++ /dev/null @@ -1,165 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Single.Defun --- Copyright : (C) 2018 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Creates 'SingI' instances for promoted types' defunctionalization symbols. --- ------------------------------------------------------------------------------ - -module Data.Singletons.Single.Defun (singDefuns) where - -import Data.List -import Data.Singletons.Names -import Data.Singletons.Promote.Defun -import Data.Singletons.Single.Monad -import Data.Singletons.Single.Type -import Data.Singletons.Util -import Language.Haskell.TH.Desugar -import Language.Haskell.TH.Syntax - --- Given the Name of something, take the defunctionalization symbols for its --- promoted counterpart and create SingI instances for them. As a concrete --- example, if you have: --- --- foo :: Eq a => a -> a -> Bool --- --- Then foo's promoted counterpart, Foo, will have two defunctionalization --- symbols: --- --- FooSym0 :: a ~> a ~> Bool --- FooSym1 :: a -> a ~> Bool --- --- We can declare SingI instances for these two symbols like so: --- --- instance SEq a => SingI (FooSym0 :: a ~> a ~> Bool) where --- sing = singFun2 sFoo --- --- instance (SEq a, SingI x) => SingI (FooSym1 x :: a ~> Bool) where --- sing = singFun1 (sFoo (sing @_ @x)) --- --- Note that singDefuns takes Maybe DKinds for the promoted argument and result --- types, in case we have an entity whose type needs to be inferred. --- See Note [singDefuns and type inference]. -singDefuns :: Name -- The Name of the thing to promote. - -> NameSpace -- Whether the above Name is a value, data constructor, - -- or a type constructor. - -> DCxt -- The type's context. - -> [Maybe DKind] -- The promoted argument types (if known). - -> Maybe DKind -- The promoted result type (if known). - -> SgM [DDec] -singDefuns n ns ty_ctxt mb_ty_args mb_ty_res = - case mb_ty_args of - [] -> pure [] -- If a function has no arguments, then it has no - -- defunctionalization symbols, so there's nothing to be done. - _ -> do sty_ctxt <- mapM singPred ty_ctxt - go 0 sty_ctxt [] mb_ty_args - where - num_ty_args :: Int - num_ty_args = length mb_ty_args - - -- Sadly, this algorithm is quadratic, because in each iteration of the loop - -- we must: - -- - -- * Construct an arrow type of the form (a ~> ... ~> z), using a suffix of - -- the promoted argument types. - -- * Append a new type variable to the end of an ordered list. - -- - -- In practice, this is unlikely to be a bottleneck, as singletons does not - -- support functions with more than 7 or so arguments anyways. - go :: Int -> DCxt -> [DTyVarBndr] -> [Maybe DKind] -> SgM [DDec] - go sym_num sty_ctxt tvbs mb_tyss - | sym_num < num_ty_args - , mb_ty:mb_tys <- mb_tyss - = do new_tvb_name <- qNewName "d" - let new_tvb = inferMaybeKindTV new_tvb_name mb_ty - insts <- go (sym_num + 1) sty_ctxt (tvbs ++ [new_tvb]) mb_tys - pure $ new_insts ++ insts - | otherwise - = pure [] - where - sing_fun_num :: Int - sing_fun_num = num_ty_args - sym_num - - mk_sing_fun_expr :: DExp -> DExp - mk_sing_fun_expr sing_expr = - foldl' (\f tvb_n -> f `DAppE` (DVarE singMethName `DAppTypeE` DVarT tvb_n)) - sing_expr - (map extractTvbName tvbs) - - singI_ctxt :: DCxt - singI_ctxt = map (DAppT (DConT singIName) . tvbToType) tvbs - - mk_inst_ty :: DType -> DType - mk_inst_ty inst_head - = case mb_inst_kind of - Just inst_kind -> inst_head `DSigT` inst_kind - Nothing -> inst_head - - tvb_tys :: [DType] - tvb_tys = map dTyVarBndrToDType tvbs - - -- Construct the arrow kind used to annotate the defunctionalization - -- symbol (e.g., the `a ~> a ~> Bool` in - -- `SingI (FooSym0 :: a ~> a ~> Bool)`). - -- If any of the argument kinds or result kind isn't known (i.e., is - -- Nothing), then we opt not to construct this arrow kind altogether. - -- See Note [singDefuns and type inference] - mb_inst_kind :: Maybe DType - mb_inst_kind = foldr buildTyFunArrow_maybe mb_ty_res mb_tyss - - new_insts :: [DDec] - new_insts = [DInstanceD Nothing Nothing - (sty_ctxt ++ singI_ctxt) - (DConT singIName `DAppT` mk_inst_ty defun_inst_ty) - [DLetDec $ DValD (DVarP singMethName) - $ wrapSingFun sing_fun_num defun_inst_ty - $ mk_sing_fun_expr sing_exp ]] - where - defun_inst_ty :: DType - defun_inst_ty = foldType (DConT (promoteTySym n sym_num)) tvb_tys - - sing_exp :: DExp - sing_exp = case ns of - DataName -> DConE $ singDataConName n - _ -> DVarE $ singValName n - -{- -Note [singDefuns and type inference] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following function: - - foo :: a -> Bool - foo _ = True - -singDefuns would give the following SingI instance for FooSym0, with an -explicit kind signature: - - instance SingI (FooSym0 :: a ~> Bool) where ... - -What happens if we leave off the type signature for foo? - - foo _ = True - -Can singDefuns still do its job? Yes! It will simply generate: - - instance SingI FooSym0 where ... - -In general, if any of the promoted argument or result types given to singDefun -are Nothing, then we avoid crafting an explicit kind signature. You might worry -that this could lead to SingI instances being generated that GHC cannot infer -the type for, such as: - - bar x = x == x - ==> - instance SingI BarSym0 -- Missing an SEq constraint? - -This is true, but also not unprecedented, as the singled version of bar, sBar, -will /also/ fail to typecheck due to a missing SEq constraint. Therefore, this -design choice fits within the existing tradition of type inference in -singletons. --} diff --git a/src/Data/Singletons/Single/Eq.hs b/src/Data/Singletons/Single/Eq.hs deleted file mode 100644 --- a/src/Data/Singletons/Single/Eq.hs +++ /dev/null @@ -1,143 +0,0 @@ -{- Data/Singletons/Single/Eq.hs - -(c) Richard Eisenberg 2014 -rae@cs.brynmawr.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.Deriving.Infer -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, q DClause, Name, Name) -sEqClassDesc, sDecideClassDesc :: Quasi q => EqualityClassDesc q -sEqClassDesc = (mkEqMethClause, mkEmptyEqMethClause, sEqClassName, sEqMethName) -sDecideClassDesc = (mkDecideMethClause, mkEmptyDecideMethClause, sDecideClassName, sDecideMethName) - -mkEqualityInstance :: DsMonad q => Maybe DCxt -> DKind - -> [DCon] -- ^ The /original/ constructors (for inferring the instance context) - -> [DCon] -- ^ The /singletons/ constructors - -> EqualityClassDesc q -> q DDec -mkEqualityInstance mb_ctxt k ctors sctors (mkMeth, mkEmpty, className, methName) = do - let sctorPairs = [ (sc1, sc2) | sc1 <- sctors, sc2 <- sctors ] - methClauses <- if null sctors - then (:[]) <$> mkEmpty - else mapM mkMeth sctorPairs - constraints <- inferConstraintsDef mb_ctxt (DConT className) k ctors - return $ DInstanceD Nothing Nothing - constraints - (DAppT (DConT className) k) - [DLetDec $ DFunD methName methClauses] - -data TestInstance = TestEquality - | TestCoercion - --- Make an instance of TestEquality or TestCoercion by leveraging SDecide. -mkTestInstance :: DsMonad q => Maybe DCxt -> DKind - -> Name -- ^ The name of the data type - -> [DCon] -- ^ The /original/ constructors (for inferring the instance context) - -> TestInstance -> q DDec -mkTestInstance mb_ctxt k data_name ctors ti = do - constraints <- inferConstraintsDef mb_ctxt (DConT sDecideClassName) k ctors - pure $ DInstanceD Nothing Nothing - constraints - (DAppT (DConT tiClassName) - (DConT (singTyConName data_name) - `DSigT` (DArrowT `DAppT` k `DAppT` DConT typeKindName))) - [DLetDec $ DFunD tiMethName - [DClause [] (DVarE tiDefaultName)]] - where - (tiClassName, tiMethName, tiDefaultName) = - case ti of - TestEquality -> (testEqualityClassName, testEqualityMethName, decideEqualityName) - TestCoercion -> (testCoercionClassName, testCoercionMethName, decideCoercionName) - -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 DVarP lnames - rpats = map DVarP rnames - lvars = map DVarE lnames - rvars = map DVarE rnames - return $ DClause - [DConP lname lpats, DConP rname rpats] - (allExp (zipWith (\l r -> foldExp (DVarE sEqMethName) [l, r]) - lvars rvars)) - | otherwise = - return $ DClause - [DConP lname (replicate lNumArgs DWildP), - DConP rname (replicate rNumArgs DWildP)] - (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 - -mkEmptyEqMethClause :: Applicative q => q DClause -mkEmptyEqMethClause = - pure $ DClause [DWildP, DWildP] - $ DConE strueName - -mkDecideMethClause :: Quasi q => (DCon, DCon) -> q DClause -mkDecideMethClause (c1, c2) - | lname == rname = - if lNumArgs == 0 - then return $ DClause [DConP lname [], DConP rname []] - (DAppE (DConE provedName) (DConE reflName)) - else do - lnames <- replicateM lNumArgs (qNewName "a") - rnames <- replicateM lNumArgs (qNewName "b") - contra <- qNewName "contra" - let lpats = map DVarP lnames - rpats = map DVarP rnames - lvars = map DVarE lnames - rvars = map DVarE rnames - refl <- qNewName "refl" - return $ DClause - [DConP lname lpats, DConP rname rpats] - (DCaseE (mkTupleDExp $ - zipWith (\l r -> foldExp (DVarE sDecideMethName) [l, r]) - lvars rvars) - ((DMatch (mkTupleDPat (replicate lNumArgs - (DConP provedName [DConP reflName []]))) - (DAppE (DConE provedName) (DConE reflName))) : - [DMatch (mkTupleDPat (replicate i DWildP ++ - DConP disprovedName [DVarP contra] : - replicate (lNumArgs - i - 1) DWildP)) - (DAppE (DConE disprovedName) - (DLamE [refl] $ - DCaseE (DVarE refl) - [DMatch (DConP reflName []) $ - (DAppE (DVarE contra) - (DConE reflName))])) - | i <- [0..lNumArgs-1] ])) - - | otherwise = do - x <- qNewName "x" - return $ DClause - [DConP lname (replicate lNumArgs DWildP), - DConP rname (replicate rNumArgs DWildP)] - (DAppE (DConE disprovedName) (DLamE [x] (DCaseE (DVarE x) []))) - - where - (lname, lNumArgs) = extractNameArgs c1 - (rname, rNumArgs) = extractNameArgs c2 - -mkEmptyDecideMethClause :: Quasi q => q DClause -mkEmptyDecideMethClause = do - x <- qNewName "x" - pure $ DClause [DVarP x, DWildP] - $ DConE provedName `DAppE` DCaseE (DVarE x) [] diff --git a/src/Data/Singletons/Single/Fixity.hs b/src/Data/Singletons/Single/Fixity.hs deleted file mode 100644 --- a/src/Data/Singletons/Single/Fixity.hs +++ /dev/null @@ -1,33 +0,0 @@ -module Data.Singletons.Single.Fixity where - -import Prelude hiding ( exp ) -import Language.Haskell.TH hiding ( cxt ) -import Language.Haskell.TH.Syntax (NameSpace(..), Quasi(..)) -import Data.Singletons.Util -import Data.Singletons.Names -import Language.Haskell.TH.Desugar - -singInfixDecl :: DsMonad q => Name -> Fixity -> q DLetDec -singInfixDecl name fixity = do - mb_ns <- reifyNameSpace name - pure $ DInfixD fixity - $ case mb_ns of - Just TcClsName -> singTyConName name - Just DataName -> singDataConName name - Just VarName -> singValName name - -- If we can't find the Name for some odd reason, - -- fall back to singValName - Nothing -> singValName name - -singFixityDeclaration :: DsMonad q => Name -> q [DDec] -singFixityDeclaration name = do - mFixity <- qReifyFixity name - case mFixity of - Nothing -> pure [] - Just fixity -> sequenceA [DLetDec <$> singInfixDecl name fixity] - -singFixityDeclarations :: DsMonad q => [Name] -> q [DDec] -singFixityDeclarations = concatMapM trySingFixityDeclaration - where - trySingFixityDeclaration name = - qRecover (return []) (singFixityDeclaration name) diff --git a/src/Data/Singletons/Single/Monad.hs b/src/Data/Singletons/Single/Monad.hs deleted file mode 100644 --- a/src/Data/Singletons/Single/Monad.hs +++ /dev/null @@ -1,216 +0,0 @@ -{- Data/Singletons/Single/Monad.hs - -(c) Richard Eisenberg 2014 -rae@cs.brynmawr.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, bindContext, askContext, 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 ) -import Data.Singletons.Names -import Data.Singletons.Util -import Data.Singletons.Internal -import Language.Haskell.TH.Syntax hiding ( lift ) -import Language.Haskell.TH.Desugar -import Control.Monad.Reader -import Control.Monad.Writer -import Control.Applicative - --- environment during singling -data SgEnv = - SgEnv { sg_let_binds :: Map Name DExp -- from the *original* name - , sg_context :: DCxt -- See Note [Tracking the current type signature context] - , sg_local_decls :: [Dec] - } - -emptySgEnv :: SgEnv -emptySgEnv = SgEnv { sg_let_binds = Map.empty - , sg_context = [] - , sg_local_decls = [] - } - --- the singling monad -newtype SgM a = SgM (ReaderT SgEnv (WriterT [DDec] Q) a) - deriving ( Functor, Applicative, Monad - , MonadReader SgEnv, MonadWriter [DDec] - , MonadFail, MonadIO ) - -liftSgM :: Q a -> SgM a -liftSgM = SgM . lift . lift - -instance Quasi SgM where - qNewName = liftSgM `comp1` qNewName - qReport = liftSgM `comp2` qReport - qLookupName = liftSgM `comp2` qLookupName - qReify = liftSgM `comp1` qReify - qReifyInstances = liftSgM `comp2` qReifyInstances - qLocation = liftSgM qLocation - qRunIO = liftSgM `comp1` qRunIO - qAddDependentFile = liftSgM `comp1` qAddDependentFile - qReifyRoles = liftSgM `comp1` qReifyRoles - qReifyAnnotations = liftSgM `comp1` qReifyAnnotations - qReifyModule = liftSgM `comp1` qReifyModule - qAddTopDecls = liftSgM `comp1` qAddTopDecls - qAddModFinalizer = liftSgM `comp1` qAddModFinalizer - qGetQ = liftSgM qGetQ - qPutQ = liftSgM `comp1` qPutQ - - qReifyFixity = liftSgM `comp1` qReifyFixity - qReifyConStrictness = liftSgM `comp1` qReifyConStrictness - qIsExtEnabled = liftSgM `comp1` qIsExtEnabled - qExtsEnabled = liftSgM qExtsEnabled - qAddForeignFilePath = liftSgM `comp2` qAddForeignFilePath - qAddTempFile = liftSgM `comp1` qAddTempFile - qAddCorePlugin = liftSgM `comp1` qAddCorePlugin - - qRecover (SgM handler) (SgM body) = do - env <- ask - (result, aux) <- liftSgM $ - qRecover (runWriterT $ runReaderT handler env) - (runWriterT $ runReaderT body env) - tell aux - return result - -instance DsMonad SgM where - localDeclarations = asks sg_local_decls - -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 }) - --- Add some constraints to the current type signature context. --- See Note [Tracking the current type signature context] -bindContext :: DCxt -> SgM a -> SgM a -bindContext ctxt1 - = local (\env@(SgEnv { sg_context = ctxt2 }) -> - env { sg_context = ctxt1 ++ ctxt2 }) - --- Retrieve the current type signature context. --- See Note [Tracking the current type signature context] -askContext :: SgM DCxt -askContext = asks sg_context - -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 <- liftM2 (<|>) (dsReify sName) (dsReify name) - -- try the unrefined name too -- it's needed to bootstrap Enum - 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 `DAppTypeE` 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 `DAppTypeE` ty `DAppE`) - -singM :: DsMonad q => [Dec] -> SgM a -> q (a, [DDec]) -singM locals (SgM rdr) = do - other_locals <- localDeclarations - let wr = runReaderT rdr (emptySgEnv { sg_local_decls = other_locals ++ locals }) - q = runWriterT wr - runQ q - -singDecsM :: DsMonad q => [Dec] -> SgM [DDec] -> q [DDec] -singDecsM locals thing = do - (decs1, decs2) <- singM locals thing - return $ decs1 ++ decs2 - -{- -Note [Tracking the current type signature context] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Much like we track the let-bound names in scope, we also track the current -context. For instance, in the following program: - - -- (1) - f :: forall a. Show a => a -> String -> Bool - f x y = g (show x) y - where - -- (2) - g :: forall b. Eq b => b -> b -> Bool - g = h - where - -- (3) - h :: b -> b -> Bool - h = (==) - -Here is the context at various points: - -(1) () -(2) (Show a) -(3) (Show a, Eq b) - -We track this informating during singling instead of during promotion, as the -promoted versions of things are often type families, which do not have -contexts. - -Why do we bother tracking this at all? Ultimately, because singDefuns (from -Data.Singletons.Single.Defun) needs to know the current context in order to -generate a correctly typed SingI instance. For instance, if you called -singDefuns on the class method bar: - - class Foo a where - bar :: Eq a => a -> Bool - -Then if you only grabbed the context of `bar` itself, then you'd end up -generating the following SingI instance for BarSym0: - - instance SEq a => SingI (FooSym0 :: a ~> Bool) where ... - -Which is incorrect—there needs to be an (SFoo a) constraint as well! If we -track the current context when singling Foo, then we will correctly propagate -this information to singDefuns. --} diff --git a/src/Data/Singletons/Single/Type.hs b/src/Data/Singletons/Single/Type.hs deleted file mode 100644 --- a/src/Data/Singletons/Single/Type.hs +++ /dev/null @@ -1,75 +0,0 @@ -{- Data/Singletons/Single/Type.hs - -(c) Richard Eisenberg 2013 -rae@cs.brynmawr.edu - -Singletonizes types. --} - -module Data.Singletons.Single.Type where - -import Language.Haskell.TH.Desugar -import qualified Language.Haskell.TH.Desugar.OSet as OSet -import Language.Haskell.TH.Desugar.OSet (OSet) -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 -import Data.Foldable - -singType :: OSet Name -- the set of bound kind variables in this scope - -- see Note [Explicitly binding kind variables] - -- in Data.Singletons.Promote.Monad - -> 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 - , DCxt -- the context of the singletonized type - , [DKind] -- the kinds of the argument types - , DKind ) -- the kind of the result type -singType bound_kvs prom ty = do - let (_, cxt, args, res) = unravel ty - num_args = length args - cxt' <- mapM singPred cxt - arg_names <- replicateM num_args (qNewName "t") - prom_args <- mapM promoteType args - prom_res <- promoteType res - let args' = map (\n -> singFamily `DAppT` (DVarT n)) arg_names - res' = singFamily `DAppT` (foldl apply prom (map DVarT arg_names) `DSigT` prom_res) - tau = ravel args' res' - -- Make sure to subtract out the bound variables currently in scope, lest we - -- accidentally shadow them in this type signature. - kv_names_to_bind = foldMap fvDType (prom_args ++ cxt' ++ [prom_res]) - OSet.\\ bound_kvs - kvs_to_bind = toList kv_names_to_bind - let ty' = DForallT (map DPlainTV kvs_to_bind ++ zipWith DKindedTV arg_names prom_args) - cxt' tau - return (ty', num_args, arg_names, cxt, prom_args, prom_res) - -singPred :: DPred -> SgM DPred -singPred = singPredRec [] - -singPredRec :: [DTypeArg] -> DPred -> SgM DPred -singPredRec _cxt (DForallT {}) = - fail "Singling of quantified constraints not yet supported" -singPredRec ctx (DAppT pr ty) = singPredRec (DTANormal ty : ctx) pr -singPredRec ctx (DAppKindT pr ki) = singPredRec (DTyArg ki : ctx) pr -singPredRec _ctx (DSigT _pr _ki) = - fail "Singling of constraints with explicit kinds not yet supported" -singPredRec _ctx (DVarT _n) = - fail "Singling of contraint variables not yet supported" -singPredRec ctx (DConT n) - | n == equalityName - = fail "Singling of type equality constraints not yet supported" - | otherwise = do - kis <- mapM promoteTypeArg ctx - let sName = singClassName n - return $ applyDType (DConT sName) kis -singPredRec _ctx DWildCardT = return DWildCardT -- it just might work -singPredRec _ctx DArrowT = - fail "(->) spotted at head of a constraint" -singPredRec _ctx (DLitT {}) = - fail "Type-level literal spotted at head of a constraint" diff --git a/src/Data/Singletons/SuppressUnusedWarnings.hs b/src/Data/Singletons/SuppressUnusedWarnings.hs deleted file mode 100644 --- a/src/Data/Singletons/SuppressUnusedWarnings.hs +++ /dev/null @@ -1,18 +0,0 @@ --- Data/Singletons/SuppressUnusedWarnings.hs --- --- (c) Richard Eisenberg 2014 --- rae@cs.brynmawr.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 AllowAmbiguousTypes, PolyKinds #-} - -module Data.Singletons.SuppressUnusedWarnings where - --- | 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 :: () diff --git a/src/Data/Singletons/Syntax.hs b/src/Data/Singletons/Syntax.hs deleted file mode 100644 --- a/src/Data/Singletons/Syntax.hs +++ /dev/null @@ -1,238 +0,0 @@ -{- Data/Singletons/Syntax.hs - -(c) Richard Eisenberg 2014 -rae@cs.brynmawr.edu - -Converts a list of DLetDecs into a LetDecEnv for easier processing, -and contains various other AST definitions. --} - -{-# LANGUAGE DataKinds, TypeFamilies, PolyKinds, DeriveDataTypeable, - FlexibleInstances, ConstraintKinds #-} - -module Data.Singletons.Syntax where - -import Prelude hiding ( exp ) -import Data.Kind (Constraint, Type) -import Language.Haskell.TH.Syntax hiding (Type) -import Language.Haskell.TH.Desugar -import qualified Language.Haskell.TH.Desugar.OMap.Strict as OMap -import Language.Haskell.TH.Desugar.OMap.Strict (OMap) -import Language.Haskell.TH.Desugar.OSet (OSet) - -type VarPromotions = [(Name, Name)] -- from term-level name to type-level name - --- Information that is accumulated when promoting patterns. -data PromDPatInfos = PromDPatInfos - { prom_dpat_vars :: VarPromotions - -- Maps term-level pattern variables to their promoted, type-level counterparts. - , prom_dpat_sig_kvs :: OSet Name - -- Kind variables bound by DSigPas. - -- See Note [Explicitly binding kind variables] in Data.Singletons.Promote.Monad - } - -instance Semigroup PromDPatInfos where - PromDPatInfos vars1 sig_kvs1 <> PromDPatInfos vars2 sig_kvs2 - = PromDPatInfos (vars1 <> vars2) (sig_kvs1 <> sig_kvs2) - -instance Monoid PromDPatInfos where - mempty = PromDPatInfos mempty mempty - --- A list of 'SingDSigPaInfos' is produced when singling pattern signatures, as we --- must case on the 'DExp's and match on them using the supplied 'DType's to --- bring the necessary singleton equality constraints into scope. --- See @Note [Singling pattern signatures]@. -type SingDSigPaInfos = [(DExp, DType)] - --- The parts of data declarations that are relevant to singletons. -data DataDecl = DataDecl Name [DTyVarBndr] [DCon] - --- The parts of type synonyms that are relevant to singletons. -data TySynDecl = TySynDecl Name [DTyVarBndr] DType - --- The parts of open type families that are relevant to singletons. -type OpenTypeFamilyDecl = TypeFamilyDecl 'Open - --- The parts of closed type families that are relevant to singletons. -type ClosedTypeFamilyDecl = TypeFamilyDecl 'Closed - --- The parts of type families that are relevant to singletons. -newtype TypeFamilyDecl (info :: FamilyInfo) - = TypeFamilyDecl { getTypeFamilyDecl :: DTypeFamilyHead } --- Whether a type family is open or closed. -data FamilyInfo = Open | Closed - -data ClassDecl ann = ClassDecl { cd_cxt :: DCxt - , cd_name :: Name - , cd_tvbs :: [DTyVarBndr] - , cd_fds :: [FunDep] - , cd_lde :: LetDecEnv ann - } - -data InstDecl ann = InstDecl { id_cxt :: DCxt - , id_name :: Name - , id_arg_tys :: [DType] - , id_sigs :: OMap Name DType - , id_meths :: [(Name, LetDecRHS ann)] } - -type UClassDecl = ClassDecl Unannotated -type UInstDecl = InstDecl Unannotated - -type AClassDecl = ClassDecl Annotated -type AInstDecl = InstDecl Annotated - -{- -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, lambda, and type-signature nodes annotated with their --- type-level equivalents -data ADExp = ADVarE Name - | ADConE Name - | ADLitE Lit - | ADAppE ADExp ADExp - | ADLamE [Name] -- type-level names corresponding to term-level ones - DType -- the promoted lambda - [Name] ADExp - | ADCaseE ADExp [ADMatch] DType - -- the type is the return type - | ADLetE ALetDecEnv ADExp - | ADSigE DType -- the promoted expression - ADExp DType - --- A DPat with a pattern-signature node annotated with its type-level equivalent -data ADPat = ADLitP Lit - | ADVarP Name - | ADConP Name [ADPat] - | ADTildeP ADPat - | ADBangP ADPat - | ADSigP DType -- The promoted pattern. Will not contain any wildcards, - -- as per Note [Singling pattern signatures] - ADPat DType - | ADWildP - -data ADMatch = ADMatch VarPromotions ADPat ADExp -data ADClause = ADClause VarPromotions - [ADPat] ADExp - -data AnnotationFlag = Annotated | Unannotated - --- These are used at the type-level exclusively -type Annotated = 'Annotated -type Unannotated = 'Unannotated - -type family IfAnn (ann :: AnnotationFlag) (yes :: k) (no :: k) :: k where - IfAnn Annotated yes no = yes - IfAnn Unannotated yes no = no - -data family LetDecRHS :: AnnotationFlag -> Type -data instance LetDecRHS Annotated - = AFunction DType -- promote function (unapplied) - Int -- number of arrows in type - [ADClause] - | AValue DType -- promoted exp - Int -- number of arrows in type - ADExp -data instance LetDecRHS Unannotated = UFunction [DClause] - | UValue DExp - -type ALetDecRHS = LetDecRHS Annotated -type ULetDecRHS = LetDecRHS Unannotated - -data LetDecEnv ann = LetDecEnv - { lde_defns :: OMap Name (LetDecRHS ann) - , lde_types :: OMap Name DType -- type signatures - , lde_infix :: OMap Name Fixity -- infix declarations - , lde_proms :: IfAnn ann (OMap Name DType) () -- possibly, promotions - , lde_bound_kvs :: IfAnn ann (OMap Name (OSet Name)) () - -- The set of bound variables in scope. - -- See Note [Explicitly binding kind variables] - -- in Data.Singletons.Promote.Monad - } -type ALetDecEnv = LetDecEnv Annotated -type ULetDecEnv = LetDecEnv Unannotated - -instance Semigroup ULetDecEnv where - LetDecEnv defns1 types1 infx1 _ _ <> LetDecEnv defns2 types2 infx2 _ _ = - LetDecEnv (defns1 <> defns2) (types1 <> types2) (infx1 <> infx2) () () - -instance Monoid ULetDecEnv where - mempty = LetDecEnv OMap.empty OMap.empty OMap.empty () () - -valueBinding :: Name -> ULetDecRHS -> ULetDecEnv -valueBinding n v = emptyLetDecEnv { lde_defns = OMap.singleton n v } - -typeBinding :: Name -> DType -> ULetDecEnv -typeBinding n t = emptyLetDecEnv { lde_types = OMap.singleton n t } - -infixDecl :: Fixity -> Name -> ULetDecEnv -infixDecl f n = emptyLetDecEnv { lde_infix = OMap.singleton n f } - -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 (DVarP 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 - go acc (DPragmaD{} : rest) = go acc rest - --- See Note [DerivedDecl] -data DerivedDecl (cls :: Type -> Constraint) = DerivedDecl - { ded_mb_cxt :: Maybe DCxt - , ded_type :: DType - , ded_type_tycon :: Name - , ded_decl :: DataDecl - } - -type DerivedEqDecl = DerivedDecl Eq -type DerivedShowDecl = DerivedDecl Show - -{- Note [DerivedDecl] -~~~~~~~~~~~~~~~~~~~~~ -Most derived instances are wholly handled in -Data.Singletons.Partition.partitionDecs. There are two notable exceptions to -this rule, however: - -* Eq instances (which are handled entirely outside of partitionDecs) -* Show instances (which are partially handled outside of partitionDecs) - -For these instances, we use a DerivedDecl data type to encode just enough -information to recreate the derived instance: - -1. Just the instance context, if it's standalone-derived, or Nothing if it's in - a deriving clause (ded_mb_cxt) -2. The datatype, applied to some number of type arguments, as in the - instance declaration (ded_type) -3. The datatype name (ded_type_tycon), cached for convenience -4. The datatype's constructors (ded_cons) - -Why are these instances handled outside of partitionDecs? - -* Deriving Eq in singletons not only derives PEq/SEq instances, but it also - derives SDecide, TestEquality, and TestCoercion instances. This additional - complication makes Eq difficult to integrate with the other deriving - machinery, so we handle it specially in Data.Singletons.Promote and - Data.Singletons.Single (depending on the task at hand). -* Deriving Show in singletons not only derives PShow/SShow instances, but it - also derives Show instances for singletons types. To make this work, - we let partitionDecs handle the PShow/SShow instances, but we also stick the - relevant info into a DerivedDecl value for later use in - Data.Singletons.Single, where we additionally generate Show - instances. --} diff --git a/src/Data/Singletons/TH.hs b/src/Data/Singletons/TH.hs deleted file mode 100644 --- a/src/Data/Singletons/TH.hs +++ /dev/null @@ -1,194 +0,0 @@ -{-# LANGUAGE ExplicitNamespaces, CPP #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TH --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- This module contains everything you need to derive your own singletons via --- Template Haskell. --- --- TURN ON @-XScopedTypeVariables@ IN YOUR MODULE IF YOU WANT THIS TO WORK. --- ----------------------------------------------------------------------------- - -module Data.Singletons.TH ( - -- * Primary Template Haskell generation functions - singletons, singletonsOnly, genSingletons, - promote, promoteOnly, genDefunSymbols, genPromotions, - - -- ** Functions to generate equality instances - promoteEqInstances, promoteEqInstance, - singEqInstances, singEqInstance, - singEqInstancesOnly, singEqInstanceOnly, - singDecideInstances, singDecideInstance, - - -- ** Functions to generate 'Ord' instances - promoteOrdInstances, promoteOrdInstance, - singOrdInstances, singOrdInstance, - - -- ** Functions to generate 'Bounded' instances - promoteBoundedInstances, promoteBoundedInstance, - singBoundedInstances, singBoundedInstance, - - -- ** Functions to generate 'Enum' instances - promoteEnumInstances, promoteEnumInstance, - singEnumInstances, singEnumInstance, - - -- ** Functions to generate 'Show' instances - promoteShowInstances, promoteShowInstance, - singShowInstances, singShowInstance, - showSingInstances, showSingInstance, - - -- ** Utility functions - singITyConInstances, singITyConInstance, - cases, sCases, - - -- * Basic singleton definitions - SBool(..), STuple0(..), STuple2(..), STuple3(..), STuple4(..), - STuple5(..), STuple6(..), STuple7(..), SOrdering(..), - module Data.Singletons, - - -- * Auxiliary definitions - -- | These definitions might be mentioned in code generated by Template Haskell, - -- so they must be in scope. - - PEq(..), If, sIf, type (&&), (%&&), SEq(..), - POrd(..), SOrd(..), ThenCmp, sThenCmp, - SDecide(..), (:~:)(..), Void, Refuted, Decision(..), - PBounded(..), SBounded(..), - PEnum(FromEnum, ToEnum), SEnum(sFromEnum, sToEnum), - PShow(..), SShow(..), - ShowString, sShowString, ShowParen, sShowParen, ShowSpace, sShowSpace, - ShowChar, sShowChar, ShowCommaSpace, sShowCommaSpace, - PFunctor(..), SFunctor(..), - PFoldable(..), SFoldable(..), PMonoid(..), SMonoid(..), - PTraversable(..), STraversable(..), PApplicative(..), SApplicative(..), - type (.), (%.), - SomeSing(..), - - Error, sError, ErrorSym0, ErrorSym1, - Undefined, sUndefined, UndefinedSym0, - TrueSym0, FalseSym0, - type (==@#@$), type (==@#@$$), type (==@#@$$$), - type (>@#@$), type (>@#@$$), type (>@#@$$$), - 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, - CompareSym0, CompareSym1, CompareSym2, - ThenCmpSym0, ThenCmpSym1, ThenCmpSym2, - FoldlSym0, FoldlSym1, FoldlSym2, FoldlSym3, - MinBoundSym0, MaxBoundSym0, - ShowsPrecSym0, ShowsPrecSym1, ShowsPrecSym2, ShowsPrecSym3, - ShowStringSym0, ShowStringSym1, ShowStringSym2, - ShowParenSym0, ShowParenSym1, ShowParenSym2, - ShowSpaceSym0, ShowSpaceSym1, - ShowCharSym0, ShowCharSym1, ShowCharSym2, - ShowCommaSpaceSym0, ShowCommaSpaceSym1, - FmapSym0, FmapSym1, FmapSym2, - type (<$@#@$), type (<$@#@$$), type (<$@#@$$$), - FoldMapSym0, FoldMapSym1, FoldMapSym2, - MemptySym0, - MappendSym0, MappendSym1, MappendSym2, - FoldrSym0, FoldrSym1, FoldrSym2, FoldrSym3, - TraverseSym0, TraverseSym1, TraverseSym2, - PureSym0, PureSym1, - type (<*>@#@$), type (<*>@#@$$), type (<*>@#@$$$), - LiftA2Sym0, LiftA2Sym1, LiftA2Sym2, LiftA2Sym3, - type (.@#@$), type (.@#@$$), type (.@#@$$$), type (.@#@$$$$), - (:@#@$), (:@#@$$), (:@#@$$$), - - SuppressUnusedWarnings(..) - - ) where - -import Data.Singletons -import Data.Singletons.Single -import Data.Singletons.Promote -import Data.Singletons.Prelude.Applicative -import Data.Singletons.Prelude.Base - hiding (Foldr, FoldrSym0, FoldrSym1, FoldrSym2, FoldrSym3, sFoldr) -import Data.Singletons.Prelude.Instances - hiding (Foldl, FoldlSym0, FoldlSym1, FoldlSym2, FoldlSym3, sFoldl) -import Data.Singletons.Prelude.Bool -import Data.Singletons.Prelude.Enum -import Data.Singletons.Prelude.Eq -import Data.Singletons.Prelude.Foldable -import Data.Singletons.Prelude.Functor hiding (Void) -import Data.Singletons.Prelude.Monoid -import Data.Singletons.Prelude.Ord -import Data.Singletons.Prelude.Show -import Data.Singletons.Prelude.Traversable -import Data.Singletons.Decide -import Data.Singletons.TypeLits -import Data.Singletons.SuppressUnusedWarnings -import Data.Singletons.Names -import Language.Haskell.TH.Desugar - -import Language.Haskell.TH -import Data.Singletons.Util -import Control.Arrow ( first ) - --- | The function 'cases' generates a case expression where each right-hand side --- is identical. This may be useful if the type-checker requires knowledge of which --- constructor is used to satisfy equality or type-class constraints, but where --- each constructor is treated the same. -cases :: DsMonad q - => Name -- ^ The head of the type of the scrutinee. (Like @''Maybe@ or @''Bool@.) - -> q Exp -- ^ The scrutinee, in a Template Haskell quote - -> q Exp -- ^ The body, in a Template Haskell quote - -> q Exp -cases tyName expq bodyq = do - dinfo <- dsReify tyName - case dinfo of - Just (DTyConI (DDataD _ _ _ _ _ ctors _) _) -> - expToTH <$> buildCases (map extractNameArgs ctors) expq bodyq - Just _ -> - fail $ "Using <> with something other than a type constructor: " - ++ (show tyName) - _ -> fail $ "Cannot find " ++ show tyName - --- | The function 'sCases' generates a case expression where each right-hand side --- is identical. This may be useful if the type-checker requires knowledge of which --- constructor is used to satisfy equality or type-class constraints, but where --- each constructor is treated the same. For 'sCases', unlike 'cases', the --- scrutinee is a singleton. But make sure to pass in the name of the /original/ --- datatype, preferring @''Maybe@ over @''SMaybe@. -sCases :: DsMonad q - => Name -- ^ The head of the type the scrutinee's type is based on. - -- (Like @''Maybe@ or @''Bool@.) - -> q Exp -- ^ The scrutinee, in a Template Haskell quote - -> q Exp -- ^ The body, in a Template Haskell quote - -> q Exp -sCases tyName expq bodyq = do - dinfo <- dsReify tyName - case dinfo of - Just (DTyConI (DDataD _ _ _ _ _ ctors _) _) -> - let ctor_stuff = map (first singDataConName . extractNameArgs) ctors in - expToTH <$> buildCases ctor_stuff expq bodyq - Just _ -> - fail $ "Using <> with something other than a type constructor: " - ++ (show tyName) - _ -> fail $ "Cannot find " ++ show tyName - -buildCases :: DsMonad m - => [(Name, Int)] - -> m Exp -- scrutinee - -> m Exp -- body - -> m DExp -buildCases ctor_infos expq bodyq = - DCaseE <$> (dsExp =<< expq) <*> - mapM (\con -> DMatch (conToPat con) <$> (dsExp =<< bodyq)) ctor_infos - where - conToPat :: (Name, Int) -> DPat - conToPat (name, num_fields) = - DConP name (replicate num_fields DWildP) diff --git a/src/Data/Singletons/TypeError.hs b/src/Data/Singletons/TypeError.hs deleted file mode 100644 --- a/src/Data/Singletons/TypeError.hs +++ /dev/null @@ -1,172 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TypeError --- Copyright : (C) 2018 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Defines a drop-in replacement for 'TL.TypeError' (from "GHC.TypeLits") --- that can be used at the value level as well. Since this is a drop-in --- replacement, it is not recommended to import all of "GHC.TypeLits" --- and "Data.Singletons.TypeError" at the same time, as many of the definitons --- in the latter deliberately clash with the former. --- ----------------------------------------------------------------------------- -module Data.Singletons.TypeError ( - TypeError, sTypeError, typeError, - ErrorMessage'(..), ErrorMessage, PErrorMessage, - Sing, SErrorMessage(..), - ConvertPErrorMessage, showErrorMessage, - - -- * Defunctionalization symbols - TextSym0, TextSym1, - ShowTypeSym0, ShowTypeSym1, - type (:<>:@#@$), type (:<>:@#@$$), type (:<>:@#@$$$), - type (:$$:@#@$), type (:$$:@#@$$), type (:$$:@#@$$$), - TypeErrorSym0, TypeErrorSym1 - ) where - -import Data.Kind -import Data.Singletons.TH -import qualified Data.Text as Text -import qualified GHC.TypeLits as TL (ErrorMessage(..), TypeError) -import GHC.Stack (HasCallStack) -import GHC.TypeLits hiding (ErrorMessage(..), TypeError) -import Prelude hiding ((<>)) -import Text.PrettyPrint (Doc, text, (<>), ($$)) - --- | A description of a custom type error. --- --- This is a variation on 'TL.ErrorMessage' that is parameterized over what --- text type is used in the 'Text' constructor. Instantiating it with --- 'Text.Text' gives you 'ErrorMessage', and instantiating it with 'Symbol' --- gives you 'PErrorMessage'. -data ErrorMessage' s - = Text s - -- ^ Show the text as is. - | forall t. ShowType t - -- ^ Pretty print the type. - -- @ShowType :: k -> ErrorMessage@ - | ErrorMessage' s :<>: ErrorMessage' s - -- ^ Put two pieces of error message next - -- to each other. - | ErrorMessage' s :$$: ErrorMessage' s - -- ^ Stack two pieces of error message on top - -- of each other. -infixl 6 :<>: -infixl 5 :$$: - --- | A value-level `ErrorMessage'` which uses 'Text.Text' as its text type. -type ErrorMessage = ErrorMessage' Text.Text - --- | A type-level `ErrorMessage'` which uses 'Symbol' as its text kind. -type PErrorMessage = ErrorMessage' Symbol - -data SErrorMessage :: PErrorMessage -> Type where - SText :: Sing t -> SErrorMessage ('Text t) - SShowType :: Sing ty -> SErrorMessage ('ShowType ty) - (:%<>:) :: Sing e1 -> Sing e2 -> SErrorMessage (e1 ':<>: e2) - (:%$$:) :: Sing e1 -> Sing e2 -> SErrorMessage (e1 ':$$: e2) -infixl 6 :%<>: -infixl 5 :%$$: - -type instance Sing = SErrorMessage - -instance SingKind PErrorMessage where - type Demote PErrorMessage = ErrorMessage - fromSing (SText t) = Text (fromSing t) - fromSing (SShowType{}) = ShowType (error "Can't single ShowType") - fromSing (e1 :%<>: e2) = fromSing e1 :<>: fromSing e2 - fromSing (e1 :%$$: e2) = fromSing e1 :$$: fromSing e2 - toSing (Text t) = withSomeSing t $ SomeSing . SText - toSing (ShowType{}) = SomeSing $ SShowType (error "Can't single ShowType") - toSing (e1 :<>: e2) = withSomeSing e1 $ \sE1 -> - withSomeSing e2 $ \sE2 -> - SomeSing (sE1 :%<>: sE2) - toSing (e1 :$$: e2) = withSomeSing e1 $ \sE1 -> - withSomeSing e2 $ \sE2 -> - SomeSing (sE1 :%$$: sE2) - -instance SingI t => SingI ('Text t :: PErrorMessage) where - sing = SText sing - -instance SingI ty => SingI ('ShowType ty :: PErrorMessage) where - sing = SShowType sing - -instance (SingI e1, SingI e2) => SingI (e1 ':<>: e2 :: PErrorMessage) where - sing = sing :%<>: sing - -instance (SingI e1, SingI e2) => SingI (e1 ':$$: e2 :: PErrorMessage) where - sing = sing :%$$: sing - --- | Convert an 'ErrorMessage' into a human-readable 'String'. -showErrorMessage :: ErrorMessage -> String -showErrorMessage = show . go - where - go :: ErrorMessage -> Doc - go (Text t) = text (Text.unpack t) - go (ShowType _) = text "" -- Not much we can do here - go (e1 :<>: e2) = go e1 <> go e2 - go (e1 :$$: e2) = go e1 $$ go e2 - --- | The value-level counterpart to 'TypeError'. --- --- Note that this is not quite as expressive as 'TypeError', as it is unable --- to print the contents of 'ShowType' constructors (it will simply print --- @\"\\"@ in their place). -typeError :: HasCallStack => ErrorMessage -> a -typeError = error . showErrorMessage - --- | Convert a 'PErrorMessage' to a 'TL.ErrorMessage' from "GHC.TypeLits". -type family ConvertPErrorMessage (a :: PErrorMessage) :: TL.ErrorMessage where - ConvertPErrorMessage ('Text t) = 'TL.Text t - ConvertPErrorMessage ('ShowType ty) = 'TL.ShowType ty - ConvertPErrorMessage (e1 ':<>: e2) = ConvertPErrorMessage e1 'TL.:<>: ConvertPErrorMessage e2 - ConvertPErrorMessage (e1 ':$$: e2) = ConvertPErrorMessage e1 'TL.:$$: ConvertPErrorMessage e2 - --- | A drop-in replacement for 'TL.TypeError'. This also exists at the --- value-level as 'typeError'. -type family TypeError (a :: PErrorMessage) :: b where - -- We cannot define this as a type synonym due to Trac #12048. - TypeError a = TL.TypeError (ConvertPErrorMessage a) - --- | The singleton for 'typeError'. --- --- Note that this is not quite as expressive as 'TypeError', as it is unable --- to handle 'ShowType' constructors at all. -sTypeError :: HasCallStack => Sing err -> Sing (TypeError err) -sTypeError = typeError . fromSing - -$(genDefunSymbols [''ErrorMessage', ''TypeError]) - -instance SingI (TextSym0 :: Symbol ~> PErrorMessage) where - sing = singFun1 SText - -instance SingI (ShowTypeSym0 :: t ~> PErrorMessage) where - sing = singFun1 SShowType - -instance SingI ((:<>:@#@$) :: PErrorMessage ~> PErrorMessage ~> PErrorMessage) where - sing = singFun2 (:%<>:) -instance SingI x => SingI ((:<>:@#@$$) x :: PErrorMessage ~> PErrorMessage) where - sing = singFun1 (sing @x :%<>:) - -instance SingI ((:$$:@#@$) :: PErrorMessage ~> PErrorMessage ~> PErrorMessage) where - sing = singFun2 (:%$$:) -instance SingI x => SingI ((:$$:@#@$$) x :: PErrorMessage ~> PErrorMessage) where - sing = singFun1 (sing @x :%$$:) - -instance SingI TypeErrorSym0 where - sing = singFun1 sTypeError diff --git a/src/Data/Singletons/TypeLits.hs b/src/Data/Singletons/TypeLits.hs deleted file mode 100644 --- a/src/Data/Singletons/TypeLits.hs +++ /dev/null @@ -1,224 +0,0 @@ -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, ConstraintKinds, - GADTs, TypeApplications, TypeFamilies, UndecidableInstances, - DataKinds, PolyKinds #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TypeLits --- Copyright : (C) 2014 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Defines and exports singletons useful for the Nat and Symbol kinds. --- ----------------------------------------------------------------------------- - -{-# OPTIONS_GHC -Wno-orphans #-} - -module Data.Singletons.TypeLits ( - Nat, Symbol, - Sing, SNat(..), SSymbol(..), withKnownNat, withKnownSymbol, - Error, sError, - ErrorWithoutStackTrace, sErrorWithoutStackTrace, - Undefined, sUndefined, - KnownNat, natVal, - KnownSymbol, symbolVal, - - type (^), (%^), - type (<=?), (%<=?), - - TN.Log2, sLog2, - Div, sDiv, Mod, sMod, DivMod, sDivMod, - Quot, sQuot, Rem, sRem, QuotRem, sQuotRem, - - -- * Defunctionalization symbols - ErrorSym0, ErrorSym1, - ErrorWithoutStackTraceSym0, ErrorWithoutStackTraceSym1, - UndefinedSym0, - KnownNatSym0, KnownNatSym1, - KnownSymbolSym0, KnownSymbolSym1, - type (^@#@$), type (^@#@$$), type (^@#@$$$), - type (<=?@#@$), type (<=?@#@$$), type (<=?@#@$$$), - Log2Sym0, Log2Sym1, - DivSym0, DivSym1, DivSym2, - ModSym0, ModSym1, ModSym2, - DivModSym0, DivModSym1, DivModSym2, - QuotSym0, QuotSym1, QuotSym2, - RemSym0, RemSym1, RemSym2, - QuotRemSym0, QuotRemSym1, QuotRemSym2 - ) where - -import Data.Singletons.Internal -import Data.Singletons.Prelude.Tuple -import Data.Singletons.Promote -import Data.Singletons.ShowSing () -- for Show instances -import Data.Singletons.TypeLits.Internal - -import Data.String (IsString(..)) -import qualified GHC.TypeNats as TN -import GHC.TypeNats (Div, Mod, SomeNat(..)) -import Numeric.Natural (Natural) - -import Unsafe.Coerce - --- | This bogus 'Num' instance is helpful for people who want to define --- functions over Nats that will only be used at the type level or --- as singletons. A correct SNum instance for Nat singletons exists. -instance Num Nat where - (+) = no_term_level_nats - (-) = no_term_level_nats - (*) = no_term_level_nats - negate = no_term_level_nats - abs = no_term_level_nats - signum = no_term_level_nats - fromInteger = no_term_level_nats - -instance Eq Nat where - (==) = no_term_level_nats - -instance Ord Nat where - compare = no_term_level_nats - -instance Enum Nat where - toEnum = no_term_level_nats - fromEnum = no_term_level_nats - enumFromTo = no_term_level_nats - enumFromThenTo = no_term_level_nats - -instance Show Nat where - showsPrec = no_term_level_nats - --- | This bogus instance is helpful for people who want to define --- functions over Symbols that will only be used at the type level or --- as singletons. -instance Eq Symbol where - (==) = no_term_level_syms - -instance Ord Symbol where - compare = no_term_level_syms - -instance IsString Symbol where - fromString = no_term_level_syms - -instance Semigroup Symbol where - (<>) = no_term_level_syms - -instance Monoid Symbol where - mempty = no_term_level_syms - -instance Show Symbol where - showsPrec = no_term_level_syms - -no_term_level_nats :: a -no_term_level_nats = error "The kind `Nat` may not be used at the term level." - -no_term_level_syms :: a -no_term_level_syms = error "The kind `Symbol` may not be used at the term level." - --- These are often useful in TypeLits-heavy code -$(genDefunSymbols [''KnownNat, ''KnownSymbol]) - ------------------------------------------------------------- --- Log2, Div, Mod, DivMod, and friends ------------------------------------------------------------- - -{- | Adapted from GHC's source code. - -Compute the logarithm of a number in the given base, rounded down to the -closest integer. -} -genLog2 :: Natural -> Natural -genLog2 x = exactLoop 0 x - where - exactLoop s i - | i == 1 = s - | i < 2 = s - | otherwise = - let s1 = s + 1 - in s1 `seq` case divMod i 2 of - (j,r) - | r == 0 -> exactLoop s1 j - | otherwise -> underLoop s1 j - - underLoop s i - | i < 2 = s - | otherwise = let s1 = s + 1 in s1 `seq` underLoop s1 (div i 2) - - -sLog2 :: Sing x -> Sing (TN.Log2 x) -sLog2 sx = - let x = fromSing sx - in case x of - 0 -> error "log2 of 0" - _ -> case TN.someNatVal (genLog2 x) of - SomeNat (_ :: Proxy res) -> unsafeCoerce (SNat :: Sing res) -$(genDefunSymbols [''TN.Log2]) -instance SingI Log2Sym0 where - sing = singFun1 sLog2 - -sDiv :: Sing x -> Sing y -> Sing (Div x y) -sDiv sx sy = - let x = fromSing sx - y = fromSing sy - res = TN.someNatVal (x `div` y) - in case res of - SomeNat (_ :: Proxy res) -> unsafeCoerce (SNat :: Sing res) -infixl 7 `sDiv` -$(genDefunSymbols [''Div]) -instance SingI DivSym0 where - sing = singFun2 sDiv -instance SingI x => SingI (DivSym1 x) where - sing = singFun1 $ sDiv (sing @x) - -sMod :: Sing x -> Sing y -> Sing (Mod x y) -sMod sx sy = - let x = fromSing sx - y = fromSing sy - res = TN.someNatVal (x `mod` y) - in case res of - SomeNat (_ :: Proxy res) -> unsafeCoerce (SNat :: Sing res) -infixl 7 `sMod` -$(genDefunSymbols [''Mod]) -instance SingI ModSym0 where - sing = singFun2 sMod -instance SingI x => SingI (ModSym1 x) where - sing = singFun1 $ sMod $ sing @x - -$(promoteOnly [d| - divMod :: Nat -> Nat -> (Nat, Nat) - divMod x y = (div x y, mod x y) - - quotRem :: Nat -> Nat -> (Nat, Nat) - quotRem = divMod - - quot :: Nat -> Nat -> Nat - quot = div - infixl 7 `quot` - - rem :: Nat -> Nat -> Nat - rem = mod - infixl 7 `rem` - |]) - -sDivMod :: Sing x -> Sing y -> Sing (DivMod x y) -sDivMod sx sy = - let x = fromSing sx - y = fromSing sy - (q,r) = x `divMod` y - qRes = TN.someNatVal q - rRes = TN.someNatVal r - in case (qRes, rRes) of - (SomeNat (_ :: Proxy q), SomeNat (_ :: Proxy r)) - -> unsafeCoerce (STuple2 (SNat :: Sing q) (SNat :: Sing r)) - -sQuotRem :: Sing x -> Sing y -> Sing (QuotRem x y) -sQuotRem = sDivMod - -sQuot :: Sing x -> Sing y -> Sing (Quot x y) -sQuot = sDiv -infixl 7 `sQuot` - -sRem :: Sing x -> Sing y -> Sing (Rem x y) -sRem = sMod -infixl 7 `sRem` diff --git a/src/Data/Singletons/TypeLits/Internal.hs b/src/Data/Singletons/TypeLits/Internal.hs deleted file mode 100644 --- a/src/Data/Singletons/TypeLits/Internal.hs +++ /dev/null @@ -1,225 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TypeLits.Internal --- Copyright : (C) 2014 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Defines and exports singletons useful for the Nat and Symbol kinds. --- This exports the internal, unsafe constructors. Use Data.Singletons.TypeLits --- for a safe interface. --- ----------------------------------------------------------------------------- - -{-# LANGUAGE PolyKinds, DataKinds, TypeFamilies, FlexibleInstances, - UndecidableInstances, ScopedTypeVariables, RankNTypes, - GADTs, FlexibleContexts, TypeOperators, ConstraintKinds, - TemplateHaskell, TypeApplications #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -module Data.Singletons.TypeLits.Internal ( - Sing, - - Nat, Symbol, - SNat(..), SSymbol(..), withKnownNat, withKnownSymbol, - Error, sError, - ErrorWithoutStackTrace, sErrorWithoutStackTrace, - Undefined, sUndefined, - KnownNat, TN.natVal, KnownSymbol, symbolVal, - type (^), (%^), - type (<=?), (%<=?), - - -- * Defunctionalization symbols - ErrorSym0, ErrorSym1, - ErrorWithoutStackTraceSym0, ErrorWithoutStackTraceSym1, - UndefinedSym0, - type (^@#@$), type (^@#@$$), type (^@#@$$$), - type (<=?@#@$), type (<=?@#@$$), type (<=?@#@$$$) - ) where - -import Data.Singletons.Promote -import Data.Singletons.Internal -import Data.Singletons.Prelude.Eq -import Data.Singletons.Prelude.Ord as O -import Data.Singletons.Decide -import Data.Singletons.Prelude.Bool -import GHC.Stack (HasCallStack) -import GHC.TypeLits as TL -import qualified GHC.TypeNats as TN -import Numeric.Natural (Natural) -import Unsafe.Coerce - -import qualified Data.Text as T -import Data.Text ( Text ) - ----------------------------------------------------------------------- ----- TypeLits singletons --------------------------------------------- ----------------------------------------------------------------------- - -data SNat (n :: Nat) = KnownNat n => SNat -type instance Sing = SNat - -instance KnownNat n => SingI n where - sing = SNat - -instance SingKind Nat where - type Demote Nat = Natural - fromSing (SNat :: Sing n) = TN.natVal (Proxy :: Proxy n) - toSing n = case TN.someNatVal n of - SomeNat (_ :: Proxy n) -> SomeSing (SNat :: Sing n) - -data SSymbol (n :: Symbol) = KnownSymbol n => SSym -type instance Sing = SSymbol - -instance KnownSymbol n => SingI n where - sing = SSym - -instance SingKind Symbol where - type Demote Symbol = Text - fromSing (SSym :: Sing n) = T.pack (symbolVal (Proxy :: Proxy n)) - toSing s = case someSymbolVal (T.unpack s) of - SomeSymbol (_ :: Proxy n) -> SomeSing (SSym :: Sing n) - --- SDecide instances: -instance SDecide Nat where - (SNat :: Sing n) %~ (SNat :: Sing m) - | Just r <- TN.sameNat (Proxy :: Proxy n) (Proxy :: Proxy m) - = Proved r - | otherwise - = Disproved (\_ -> error errStr) - where errStr = "Broken Nat singletons" - -instance SDecide Symbol where - (SSym :: Sing n) %~ (SSym :: Sing m) - | Just r <- sameSymbol (Proxy :: Proxy n) (Proxy :: Proxy m) - = Proved r - | otherwise - = Disproved (\_ -> error errStr) - where errStr = "Broken Symbol singletons" - --- PEq instances -instance PEq Nat -instance PEq Symbol - --- need SEq instances for TypeLits kinds -instance SEq Nat where - (SNat :: Sing n) %== (SNat :: Sing m) - = case sameNat (Proxy :: Proxy n) (Proxy :: Proxy m) of - Just Refl -> STrue - Nothing -> unsafeCoerce SFalse - -instance SEq Symbol where - (SSym :: Sing n) %== (SSym :: Sing m) - = case sameSymbol (Proxy :: Proxy n) (Proxy :: Proxy m) of - Just Refl -> STrue - Nothing -> unsafeCoerce SFalse - --- POrd instances -instance POrd Nat where - type (a :: Nat) `Compare` (b :: Nat) = a `TN.CmpNat` b - -instance POrd Symbol where - type (a :: Symbol) `Compare` (b :: Symbol) = a `TL.CmpSymbol` b - --- SOrd instances -instance SOrd Nat where - a `sCompare` b = case fromSing a `compare` fromSing b of - LT -> unsafeCoerce SLT - EQ -> unsafeCoerce SEQ - GT -> unsafeCoerce SGT - -instance SOrd Symbol where - a `sCompare` b = case fromSing a `compare` fromSing b of - LT -> unsafeCoerce SLT - EQ -> unsafeCoerce SEQ - GT -> unsafeCoerce SGT - --- Convenience functions - --- | Given a singleton for @Nat@, call something requiring a --- @KnownNat@ instance. -withKnownNat :: Sing n -> (KnownNat n => r) -> r -withKnownNat SNat f = f - --- | Given a singleton for @Symbol@, call something requiring --- a @KnownSymbol@ instance. -withKnownSymbol :: Sing n -> (KnownSymbol n => r) -> r -withKnownSymbol SSym f = f - --- | The promotion of 'error'. This version is more poly-kinded for --- easier use. -type family Error (str :: k0) :: k where {} -$(genDefunSymbols [''Error]) -instance SingI (ErrorSym0 :: Symbol ~> a) where - sing = singFun1 sError - --- | The singleton for 'error' -sError :: HasCallStack => Sing (str :: Symbol) -> a -sError sstr = error (T.unpack (fromSing sstr)) - --- | The promotion of 'errorWithoutStackTrace'. This version is more --- poly-kinded for easier use. -type family ErrorWithoutStackTrace (str :: k0) :: k where {} -$(genDefunSymbols [''ErrorWithoutStackTrace]) -instance SingI (ErrorWithoutStackTraceSym0 :: Symbol ~> a) where - sing = singFun1 sErrorWithoutStackTrace - --- | The singleton for 'errorWithoutStackTrace'. -sErrorWithoutStackTrace :: Sing (str :: Symbol) -> a -sErrorWithoutStackTrace sstr = errorWithoutStackTrace (T.unpack (fromSing sstr)) - --- | The promotion of 'undefined'. -type family Undefined :: k where {} -$(genDefunSymbols [''Undefined]) - --- | The singleton for 'undefined'. -sUndefined :: HasCallStack => a -sUndefined = undefined - --- | The singleton analogue of '(TN.^)' for 'Nat's. -(%^) :: Sing a -> Sing b -> Sing (a ^ b) -sa %^ sb = - let a = fromSing sa - b = fromSing sb - ex = TN.someNatVal (a ^ b) - in - case ex of - SomeNat (_ :: Proxy ab) -> unsafeCoerce (SNat :: Sing ab) -infixr 8 %^ - --- Defunctionalization symbols for type-level (^) -$(genDefunSymbols [''(^)]) -instance SingI (^@#@$) where - sing = singFun2 (%^) -instance SingI x => SingI ((^@#@$$) x) where - sing = singFun1 (sing @x %^) - --- | The singleton analogue of 'TN.<=?' --- --- Note that, because of historical reasons in GHC's 'TN.Nat' API, 'TN.<=?' --- is incompatible (unification-wise) with 'O.<=' and the 'PEq', 'SEq', --- 'POrd', and 'SOrd' instances for 'Nat'. @(a '<=?' b) ~ 'True@ does not --- imply anything about @a 'O.<=' b@ or any other 'PEq' / 'POrd' --- relationships. --- --- (Be aware that 'O.<=' in the paragraph above refers to 'O.<=' from the --- 'POrd' typeclass, exported from "Data.Singletons.Prelude.Ord", and /not/ --- the 'TN.<=' from "GHC.TypeNats". The latter is simply a type alias for --- @(a 'TN.<=?' b) ~ 'True@.) --- --- This is provided here for the sake of completeness and for compatibility --- with libraries with APIs built around '<=?'. New code should use --- 'CmpNat', exposed through this library through the 'POrd' and 'SOrd' --- instances for 'Nat'. -(%<=?) :: Sing a -> Sing b -> Sing (a <=? b) -sa %<=? sb = unsafeCoerce (sa %<= sb) -infix 4 %<=? - --- Defunctionalization symbols for (<=?) -$(genDefunSymbols [''(<=?)]) -instance SingI (<=?@#@$) where - sing = singFun2 (%<=?) -instance SingI x => SingI ((<=?@#@$$) x) where - sing = singFun1 (sing @x %<=?) diff --git a/src/Data/Singletons/TypeRepTYPE.hs b/src/Data/Singletons/TypeRepTYPE.hs deleted file mode 100644 --- a/src/Data/Singletons/TypeRepTYPE.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE RankNTypes, TypeFamilies, FlexibleInstances, - GADTs, UndecidableInstances, ScopedTypeVariables, - MagicHash, TypeOperators, PolyKinds, TypeApplications #-} -{-# OPTIONS_GHC -Wno-orphans #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TypeRepTYPE --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- This module defines singleton instances making 'TypeRep' the singleton for --- the kind @'TYPE' rep@ (for some 'RuntimeRep' @rep@), an instantiation of --- which is the famous kind 'Type'. The definitions don't fully line up with --- what is expected within the singletons library, so expect unusual results! --- ----------------------------------------------------------------------------- - -module Data.Singletons.TypeRepTYPE ( - Sing, - -- | Here is the definition of the singleton for @'TYPE' rep@: - -- - -- > type instance Sing \@(TYPE rep) = TypeRep - -- - -- Instances for 'SingI', 'SingKind', 'SEq', 'SDecide', and - -- 'TestCoercion' are also supplied. - - SomeTypeRepTYPE(..) - ) where - -import Data.Kind (Type) -import Data.Singletons.Prelude.Instances -import Data.Singletons.Internal -import Data.Singletons.Prelude.Eq -import Data.Singletons.Decide -import GHC.Exts (RuntimeRep, TYPE) -import Type.Reflection -import Type.Reflection.Unsafe -import Unsafe.Coerce - --- | A choice of singleton for the kind @'TYPE' rep@ (for some 'RuntimeRep' --- @rep@), an instantiation of which is the famous kind 'Type'. --- --- Conceivably, one could generalize this instance to `Sing \@k` for --- /any/ kind @k@, and remove all other 'Sing' instances. We don't adopt this --- design, however, since it is far more convenient in practice to work with --- explicit singleton values than 'TypeRep's (for instance, 'TypeRep's are --- more difficult to pattern match on, and require extra runtime checks). --- --- We cannot produce explicit singleton values for everything in @'TYPE' rep@, --- however, since it is an open kind, so we reach for 'TypeRep' in this one --- particular case. -type instance Sing @(TYPE rep) = TypeRep - --- | A variant of 'SomeTypeRep' whose underlying 'TypeRep' is restricted to --- kind @'TYPE' rep@ (for some 'RuntimeRep' @rep@). -data SomeTypeRepTYPE :: RuntimeRep -> Type where - SomeTypeRepTYPE :: forall (rep :: RuntimeRep) (a :: TYPE rep). !(TypeRep a) -> SomeTypeRepTYPE rep - -instance Eq (SomeTypeRepTYPE rep) where - SomeTypeRepTYPE a == SomeTypeRepTYPE b = - case eqTypeRep a b of - Just HRefl -> True - Nothing -> False - -instance Ord (SomeTypeRepTYPE rep) where - SomeTypeRepTYPE a `compare` SomeTypeRepTYPE b = - typeRepFingerprint a `compare` typeRepFingerprint b - -instance Show (SomeTypeRepTYPE rep) where - showsPrec p (SomeTypeRepTYPE ty) = showsPrec p ty - -instance Typeable a => SingI (a :: TYPE rep) where - sing = typeRep -instance SingKind (TYPE rep) where - type Demote (TYPE rep) = SomeTypeRepTYPE rep - fromSing = SomeTypeRepTYPE - toSing (SomeTypeRepTYPE tr) = SomeSing tr - -instance PEq (TYPE rep) -instance SEq (TYPE rep) where - tra %== trb = - case eqTypeRep tra trb of - Just HRefl -> STrue - Nothing -> unsafeCoerce SFalse - -- the Data.Typeable interface isn't strong enough - -- to enable us to define this without unsafeCoerce - -instance SDecide (TYPE rep) where - tra %~ trb = - case eqTypeRep tra trb of - Just HRefl -> Proved Refl - Nothing -> Disproved (\Refl -> error "Type.Reflection.eqTypeRep failed") diff --git a/src/Data/Singletons/Util.hs b/src/Data/Singletons/Util.hs deleted file mode 100644 --- a/src/Data/Singletons/Util.hs +++ /dev/null @@ -1,495 +0,0 @@ -{- Data/Singletons/Util.hs - -(c) Richard Eisenberg 2013 -rae@cs.brynmawr.edu - -This file contains helper functions internal to the singletons package. -Users of the package should not need to consult this file. --} - -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, RankNTypes, - TemplateHaskell, GeneralizedNewtypeDeriving, - MultiParamTypeClasses, UndecidableInstances, MagicHash, - LambdaCase, NoMonomorphismRestriction #-} - -module Data.Singletons.Util where - -import Prelude hiding ( exp, foldl, concat, mapM, any, pred ) -import Language.Haskell.TH.Syntax hiding ( lift ) -import Language.Haskell.TH.Desugar -import Data.Char -import Control.Monad hiding ( mapM ) -import Control.Monad.Writer hiding ( mapM ) -import Control.Monad.Reader hiding ( mapM ) -import qualified Data.Map as Map -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Map ( Map ) -import qualified Data.Monoid as Monoid -import Data.Semigroup as Semigroup -import Data.Foldable -import Data.Functor.Identity -import Data.Traversable -import Data.Generics -import Data.Maybe -import Data.Void - --- The list of types that singletons processes by default -basicTypes :: [Name] -basicTypes = [ ''Maybe - , ''[] - , ''Either - , ''NonEmpty - , ''Void - ] ++ boundedBasicTypes - -boundedBasicTypes :: [Name] -boundedBasicTypes = - [ ''(,) - , ''(,,) - , ''(,,,) - , ''(,,,,) - , ''(,,,,,) - , ''(,,,,,,) - , ''Identity - ] ++ enumBasicTypes - -enumBasicTypes :: [Name] -enumBasicTypes = [ ''Bool, ''Ordering, ''() ] - -semigroupBasicTypes :: [Name] -semigroupBasicTypes - = [ ''Dual - , ''All - , ''Any - , ''Sum - , ''Product - -- , ''Endo see https://github.com/goldfirere/singletons/issues/82 - {- , ''Alt singletons doesn't support higher kinds :( - see https://github.com/goldfirere/singletons/issues/150 - -} - - , ''Min - , ''Max - , ''Semigroup.First - , ''Semigroup.Last - , ''WrappedMonoid - ] - -monoidBasicTypes :: [Name] -monoidBasicTypes - = [ ''Monoid.First - , ''Monoid.Last - ] - --- like reportWarning, but generalized to any Quasi -qReportWarning :: Quasi q => String -> q () -qReportWarning = qReport False - --- like reportError, but generalized to any Quasi -qReportError :: Quasi q => String -> q () -qReportError = qReport True - --- | Generate a new Unique -qNewUnique :: DsMonad q => q Uniq -qNewUnique = do - Name _ flav <- qNewName "x" - case flav of - NameU n -> return n - _ -> error "Internal error: `qNewName` didn't return a NameU" - -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) - -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 :: DCon -> (Name, Int) -extractNameArgs = liftSnd length . extractNameTypes - --- extract the name and types of constructor arguments -extractNameTypes :: DCon -> (Name, [DType]) -extractNameTypes (DCon _ _ n fields _) = (n, tysOfConFields fields) - -extractName :: DCon -> Name -extractName (DCon _ _ n _ _) = n - --- | is a valid Haskell infix data constructor (i.e., does it begin with a colon?) -isInfixDataCon :: String -> Bool -isInfixDataCon (':':_) = True -isInfixDataCon _ = False - --- | Is an identifier a legal data constructor name in Haskell? That is, is its --- first character an uppercase letter (prefix) or a colon (infix)? -isDataConName :: Name -> Bool -isDataConName n = let first = head (nameBase n) in isUpper first || first == ':' - --- | Is an identifier uppercase? --- --- Note that this will always return 'False' for infix names, since the concept --- of upper- and lower-case doesn't make sense for non-alphabetic characters. --- If you want to check if a name is legal as a data constructor, use the --- 'isDataConName' function. -isUpcase :: Name -> Bool -isUpcase n = let first = head (nameBase n) in isUpper first - --- Make an identifier uppercase. If the identifier is infix, this acts as the --- identity function. -upcase :: Name -> Name -upcase = mkName . toUpcaseStr noPrefix - --- make an identifier uppercase and return it as a String -toUpcaseStr :: (String, String) -- (alpha, symb) prefixes to prepend - -> Name -> String -toUpcaseStr (alpha, symb) n - | isHsLetter first - = upcase_alpha - - | otherwise - = upcase_symb - - where - str = nameBase n - first = head str - - upcase_alpha = alpha ++ (toUpper first) : tail str - upcase_symb = symb ++ str - -noPrefix :: (String, String) -noPrefix = ("", "") - --- Put an uppercase prefix on a constructor name. Takes two prefixes: --- one for identifiers and one for symbols. --- --- This is different from 'prefixName' in that infix constructor names always --- start with a colon, so we must insert the prefix after the colon in order --- for the new name to be syntactically valid. -prefixConName :: String -> String -> Name -> Name -prefixConName pre tyPre n = case (nameBase n) of - (':' : rest) -> mkName (':' : tyPre ++ rest) - alpha -> mkName (pre ++ alpha) - --- Put a prefix on a name. Takes two prefixes: one for identifiers --- and one for symbols. -prefixName :: String -> String -> Name -> Name -prefixName pre tyPre n = - let str = nameBase n - first = head str in - if isHsLetter first - then mkName (pre ++ str) - else mkName (tyPre ++ str) - --- Put a suffix on a name. Takes two suffixes: one for identifiers --- and one for symbols. -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) - --- convert a number into both alphanumeric and symoblic forms -uniquePrefixes :: String -- alphanumeric prefix - -> String -- symbolic prefix - -> Uniq - -> (String, String) -- (alphanum, symbolic) -uniquePrefixes alpha symb n = (alpha ++ n_str, symb ++ convert n_str) - where - n_str = show n - - convert [] = [] - convert (d : ds) = - let d' = case d of - '0' -> '!' - '1' -> '#' - '2' -> '$' - '3' -> '%' - '4' -> '&' - '5' -> '*' - '6' -> '+' - '7' -> '.' - '8' -> '/' - '9' -> '>' - _ -> error "non-digit in show #" - in d' : convert ds - --- extract the kind from a TyVarBndr -extractTvbKind :: DTyVarBndr -> Maybe DKind -extractTvbKind (DPlainTV _) = Nothing -extractTvbKind (DKindedTV _ k) = Just k - --- extract the name from a TyVarBndr. -extractTvbName :: DTyVarBndr -> Name -extractTvbName (DPlainTV n) = n -extractTvbName (DKindedTV n _) = n - -tvbToType :: DTyVarBndr -> DType -tvbToType = DVarT . extractTvbName - -inferMaybeKindTV :: Name -> Maybe DKind -> DTyVarBndr -inferMaybeKindTV n Nothing = DPlainTV n -inferMaybeKindTV n (Just k) = DKindedTV n k - -resultSigToMaybeKind :: DFamilyResultSig -> Maybe DKind -resultSigToMaybeKind DNoSig = Nothing -resultSigToMaybeKind (DKindSig k) = Just k -resultSigToMaybeKind (DTyVarSig (DPlainTV _)) = Nothing -resultSigToMaybeKind (DTyVarSig (DKindedTV _ k)) = Just k - --- Reconstruct arrow kind from the list of kinds -ravel :: [DType] -> DType -> DType -ravel [] res = res -ravel (h:t) res = DAppT (DAppT DArrowT h) (ravel t res) - --- count the number of arguments in a type -countArgs :: DType -> Int -countArgs ty = length args - where (_, _, args, _) = unravel ty - --- changes all TyVars not to be NameU's. Workaround for GHC#11812 -noExactTyVars :: Data a => a -> a -noExactTyVars = everywhere go - where - go :: Data a => a -> a - go = mkT fix_tvb `extT` fix_ty `extT` fix_inj_ann - - no_exact_name :: Name -> Name - no_exact_name (Name (OccName occ) (NameU unique)) = mkName (occ ++ show unique) - no_exact_name n = n - - fix_tvb (DPlainTV n) = DPlainTV (no_exact_name n) - fix_tvb (DKindedTV n k) = DKindedTV (no_exact_name n) k - - fix_ty (DVarT n) = DVarT (no_exact_name n) - fix_ty ty = ty - - fix_inj_ann (InjectivityAnn lhs rhs) - = InjectivityAnn (no_exact_name lhs) (map no_exact_name rhs) - -substKind :: Map Name DKind -> DKind -> DKind -substKind = substType - --- | Non–capture-avoiding substitution. (If you want capture-avoiding --- substitution, use @substTy@ from "Language.Haskell.TH.Desugar.Subst". -substType :: Map Name DType -> DType -> DType -substType subst ty | Map.null subst = ty -substType subst (DForallT tvbs cxt inner_ty) - = DForallT tvbs' cxt' inner_ty' - where - (subst', tvbs') = mapAccumL subst_tvb subst tvbs - cxt' = map (substType subst') cxt - inner_ty' = substType subst' inner_ty -substType subst (DAppT ty1 ty2) = substType subst ty1 `DAppT` substType subst ty2 -substType subst (DAppKindT ty ki) = substType subst ty `DAppKindT` substType subst ki -substType subst (DSigT ty ki) = substType subst ty `DSigT` substType subst ki -substType subst (DVarT n) = - case Map.lookup n subst of - Just ki -> ki - Nothing -> DVarT n -substType _ ty@(DConT {}) = ty -substType _ ty@(DArrowT) = ty -substType _ ty@(DLitT {}) = ty -substType _ ty@DWildCardT = ty - -subst_tvb :: Map Name DKind -> DTyVarBndr -> (Map Name DKind, DTyVarBndr) -subst_tvb s tvb@(DPlainTV n) = (Map.delete n s, tvb) -subst_tvb s (DKindedTV n k) = (Map.delete n s, DKindedTV n (substKind s k)) - -cuskify :: DTyVarBndr -> DTyVarBndr -cuskify (DPlainTV tvname) = DKindedTV tvname $ DConT typeKindName -cuskify tvb = tvb - --- apply a type to a list of types -foldType :: DType -> [DType] -> DType -foldType = foldl DAppT - --- apply a type to a list of type variable binders -foldTypeTvbs :: DType -> [DTyVarBndr] -> DType -foldTypeTvbs ty = foldType ty . map tvbToType - --- Construct a data type's variable binders, possibly using fresh variables --- from the data type's kind signature. -buildDataDTvbs :: DsMonad q => [DTyVarBndr] -> Maybe DKind -> q [DTyVarBndr] -buildDataDTvbs tvbs mk = do - extra_tvbs <- mkExtraDKindBinders $ fromMaybe (DConT typeKindName) mk - pure $ tvbs ++ extra_tvbs - --- apply an expression to a list of expressions -foldExp :: DExp -> [DExp] -> DExp -foldExp = foldl DAppE - --- 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] -orIfEmpty [] x = x -orIfEmpty x _ = x - --- build a pattern match over several expressions, each with only one pattern -multiCase :: [DExp] -> [DPat] -> DExp -> DExp -multiCase [] [] body = body -multiCase scruts pats body = - DCaseE (mkTupleDExp scruts) [DMatch (mkTupleDPat pats) body] - --- Make a desugar function into a TH function. -wrapDesugar :: (Desugar th ds, DsMonad q) => (th -> ds -> q ds) -> th -> q th -wrapDesugar f th = do - ds <- desugar th - fmap sweeten $ f th 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 - , MonadWriter m, MonadReader r - , MonadFail, MonadIO ) - --- make a Quasi instance for easy lifting -instance (Quasi q, Monoid m) => Quasi (QWithAux m q) where - qNewName = lift `comp1` qNewName - qReport = lift `comp2` qReport - qLookupName = lift `comp2` qLookupName - qReify = lift `comp1` qReify - qReifyInstances = lift `comp2` qReifyInstances - qLocation = lift qLocation - qRunIO = lift `comp1` qRunIO - qAddDependentFile = lift `comp1` qAddDependentFile - 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 - - qReifyFixity = lift `comp1` qReifyFixity - qReifyConStrictness = lift `comp1` qReifyConStrictness - qIsExtEnabled = lift `comp1` qIsExtEnabled - qExtsEnabled = lift qExtsEnabled - qAddForeignFilePath = lift `comp2` qAddForeignFilePath - qAddTempFile = lift `comp1` qAddTempFile - qAddCorePlugin = lift `comp1` qAddCorePlugin - - qRecover exp handler = do - (result, aux) <- lift $ qRecover (evalForPair exp) (evalForPair handler) - tell aux - return result - -instance (DsMonad q, Monoid m) => DsMonad (QWithAux m q) where - localDeclarations = lift localDeclarations - --- helper functions for composition -comp1 :: (b -> c) -> (a -> b) -> a -> c -comp1 = (.) - -comp2 :: (c -> d) -> (a -> b -> c) -> a -> b -> d -comp2 f g a b = f (g a b) - --- run a computation with an auxiliary monoid, discarding the monoid result -evalWithoutAux :: Quasi q => QWithAux m q a -> q a -evalWithoutAux = liftM fst . runWriterT . runQWA - --- run a computation with an auxiliary monoid, returning only the monoid result -evalForAux :: Quasi q => QWithAux m q a -> q m -evalForAux = execWriterT . runQWA - --- run a computation with an auxiliary monoid, return both the result --- of the computation and the monoid result -evalForPair :: QWithAux m q a -> q (a, m) -evalForPair = runWriterT . runQWA - --- in a computation with an auxiliary map, add a binding to the map -addBinding :: (Quasi q, Ord k) => k -> v -> QWithAux (Map.Map k v) q () -addBinding k v = tell (Map.singleton k v) - --- in a computation with an auxiliar list, add an element to the list -addElement :: Quasi q => elt -> QWithAux [elt] q () -addElement elt = tell [elt] - --- | Call 'lookupTypeNameWithLocals' first to ensure we have a 'Name' in the --- type namespace, then call 'dsReify'. - --- See also Note [Using dsReifyTypeNameInfo when promoting instances] --- in Data.Singletons.Promote. -dsReifyTypeNameInfo :: DsMonad q => Name -> q (Maybe DInfo) -dsReifyTypeNameInfo ty_name = do - mb_name <- lookupTypeNameWithLocals (nameBase ty_name) - case mb_name of - Just n -> dsReify n - Nothing -> pure Nothing - --- lift concatMap into a monad --- 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 $ fold bss - --- make a one-element list -listify :: a -> [a] -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) - -{-# INLINEABLE zipWith3M #-} -zipWith3M :: Monad m => (a -> b -> m c) -> [a] -> [b] -> m [c] -zipWith3M f (a:as) (b:bs) = (:) <$> f a b <*> zipWith3M f as bs -zipWith3M _ _ _ = return [] - -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/ByHand.hs b/tests/ByHand.hs --- a/tests/ByHand.hs +++ b/tests/ByHand.hs @@ -14,67 +14,71 @@ FlexibleInstances, FlexibleContexts, UndecidableInstances, RankNTypes, TypeOperators, MultiParamTypeClasses, FunctionalDependencies, ScopedTypeVariables, - LambdaCase, TemplateHaskell, EmptyCase, - TypeApplications, EmptyCase - #-} + LambdaCase, EmptyCase, + TypeApplications, EmptyCase, CPP #-} -module ByHand where +#if __GLASGOW_HASKELL__ < 806 +{-# LANGUAGE TypeInType #-} +#endif -import Data.Kind (Type) -import Prelude hiding (Bool, False, True, Maybe, Just, Nothing, Either, Left, Right, map, zipWith, - (&&), (||), (+), (-)) -import Unsafe.Coerce +#if __GLASGOW_HASKELL__ >= 810 +{-# LANGUAGE StandaloneKindSignatures #-} +#endif +module ByHand where +import Data.Kind import Data.Type.Equality hiding (type (==), apply) import Data.Proxy - import Data.Singletons import Data.Singletons.Decide +import Prelude hiding ((+), (-), map, zipWith) +import Unsafe.Coerce ----------------------------------- -- Original ADTs ------------------ ----------------------------------- -data Nat :: Type where +#if __GLASGOW_HASKELL__ >= 810 +type Nat :: Type +#endif +data Nat where Zero :: Nat Succ :: Nat -> Nat deriving Eq -data Bool :: Type where - False :: Bool - True :: Bool - -data Maybe :: Type -> Type where - Nothing :: Maybe a - Just :: a -> Maybe a - deriving Eq - -- Defined using names to avoid fighting with concrete syntax +#if __GLASGOW_HASKELL__ >= 810 +type List :: Type -> Type +#endif data List :: Type -> Type where Nil :: List a Cons :: a -> List a -> List a deriving Eq -data Either :: Type -> Type -> Type where - Left :: a -> Either a b - Right :: b -> Either a b - - ----------------------------------- -- One-time definitions ----------- ----------------------------------- -- Promoted equality type class +#if __GLASGOW_HASKELL__ >= 810 +type PEq :: Type -> Constraint +#endif class PEq k where type (==) (a :: k) (b :: k) :: Bool -- omitting definition of /= -- Singleton type equality type class +#if __GLASGOW_HASKELL__ >= 810 +type SEq :: Type -> Constraint +#endif class SEq k where (%==) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Sing (a == b) -- omitting definition of %/= -type family If cond tru fls where +#if __GLASGOW_HASKELL__ >= 810 +type If :: Bool -> a -> a -> a +#endif +type family If (cond :: Bool) (tru :: a) (fls :: a) :: a where If True tru fls = tru If False tru fls = fls @@ -88,15 +92,30 @@ -- Nat +#if __GLASGOW_HASKELL__ >= 810 +type SNat :: Nat -> Type +#endif data SNat :: Nat -> Type where SZero :: SNat Zero SSucc :: SNat n -> SNat (Succ n) -type instance Sing = SNat +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @Nat = +#else +type instance Sing = +#endif + SNat +#if _ +_GLASGOW_HASKELL__ >= 810 +type SuccSym0 :: Nat ~> Nat +#endif data SuccSym0 :: Nat ~> Nat type instance Apply SuccSym0 x = Succ x -type family EqualsNat (a :: Nat) (b :: Nat) where +#if __GLASGOW_HASKELL__ >= 810 +type EqualsNat :: Nat -> Nat -> Bool +#endif +type family EqualsNat (a :: Nat) (b :: Nat) :: Bool where EqualsNat Zero Zero = True EqualsNat (Succ a) (Succ b) = a == b EqualsNat (n1 :: Nat) (n2 :: Nat) = False @@ -122,6 +141,8 @@ sing = SZero instance SingI n => SingI (Succ n) where sing = SSucc sing +instance SingI1 Succ where + liftSing = SSucc instance SingKind Nat where type Demote Nat = Nat fromSing SZero = Zero @@ -131,15 +152,28 @@ -- Bool +#if __GLASGOW_HASKELL__ >= 810 +type SBool :: Bool -> Type +#endif data SBool :: Bool -> Type where SFalse :: SBool False STrue :: SBool True -type instance Sing = SBool +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @Bool = +#else +type instance Sing = +#endif + SBool +{- (&&) :: Bool -> Bool -> Bool False && _ = False True && x = x +-} +#if __GLASGOW_HASKELL__ >= 810 +type (&&) :: Bool -> Bool -> Bool +#endif type family (a :: Bool) && (b :: Bool) :: Bool where False && _ = False True && x = x @@ -163,12 +197,23 @@ -- Maybe +#if __GLASGOW_HASKELL__ >= 810 +type SMaybe :: forall k. Maybe k -> Type +#endif data SMaybe :: forall k. Maybe k -> Type where SNothing :: SMaybe Nothing SJust :: forall k (a :: k). Sing a -> SMaybe (Just a) -type instance Sing = SMaybe +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @(Maybe k) = +#else +type instance Sing = +#endif + SMaybe -type family EqualsMaybe (a :: Maybe k) (b :: Maybe k) where +#if __GLASGOW_HASKELL__ >= 810 +type EqualsMaybe :: Maybe k -> Maybe k -> Bool +#endif +type family EqualsMaybe (a :: Maybe k) (b :: Maybe k) :: Bool where EqualsMaybe Nothing Nothing = True EqualsMaybe (Just a) (Just a') = a == a' EqualsMaybe (x :: Maybe k) (y :: Maybe k) = False @@ -194,6 +239,8 @@ sing = SNothing instance SingI a => SingI (Just (a :: k)) where sing = SJust sing +instance SingI1 Just where + liftSing = SJust instance SingKind k => SingKind (Maybe k) where type Demote (Maybe k) = Maybe (Demote k) fromSing SNothing = Nothing @@ -205,22 +252,41 @@ -- List +#if __GLASGOW_HASKELL__ >= 810 +type SList :: forall k. List k -> Type +#endif data SList :: forall k. List k -> Type where SNil :: SList Nil SCons :: forall k (h :: k) (t :: List k). Sing h -> SList t -> SList (Cons h t) -type instance Sing = SList +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @(List k) = +#else +type instance Sing = +#endif + SList -type NilSym0 = Nil +#if __GLASGOW_HASKELL__ >= 810 +type NilSym0 :: List a +#endif +type family NilSym0 :: List a where + NilSym0 = Nil -data ConsSym0 :: a ~> List a ~> List a +#if __GLASGOW_HASKELL__ >= 810 +type ConsSym0 :: forall a. a ~> List a ~> List a +type ConsSym1 :: forall a. a -> List a ~> List a +type ConsSym2 :: forall a. a -> List a -> List a +#endif +data ConsSym0 :: forall a. a ~> List a ~> List a +data ConsSym1 :: forall a. a -> List a ~> List a +type family ConsSym2 (x :: a) (y :: List a) :: List a where + ConsSym2 x y = Cons x y type instance Apply ConsSym0 a = ConsSym1 a - -data ConsSym1 :: a -> List a ~> List a -type instance Apply (ConsSym1 a) b = ConsSym2 a b - -type ConsSym2 a b = Cons a b +type instance Apply (ConsSym1 a) b = Cons a b -type family EqualsList (a :: List k) (b :: List k) where +#if __GLASGOW_HASKELL__ >= 810 +type EqualsList :: List k -> List k -> Bool +#endif +type family EqualsList (a :: List k) (b :: List k) :: Bool where EqualsList Nil Nil = True EqualsList (Cons a b) (Cons a' b') = (a == a') && (b == b') EqualsList (x :: List k) (y :: List k) = False @@ -248,6 +314,10 @@ instance (SingI h, SingI t) => SingI (Cons (h :: k) (t :: List k)) where sing = SCons sing sing +instance SingI h => SingI1 (Cons (h :: k)) where + liftSing = SCons sing +instance SingI2 Cons where + liftSing2 = SCons instance SingKind k => SingKind (List k) where type Demote (List k) = List (Demote k) fromSing SNil = Nil @@ -260,15 +330,27 @@ -- Either +#if __GLASGOW_HASKELL__ >= 810 +type SEither :: forall k1 k2. Either k1 k2 -> Type +#endif data SEither :: forall k1 k2. Either k1 k2 -> Type where SLeft :: forall k1 (a :: k1). Sing a -> SEither (Left a) SRight :: forall k2 (b :: k2). Sing b -> SEither (Right b) -type instance Sing = SEither +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @(Either k1 k2) = +#else +type instance Sing = +#endif + SEither instance (SingI a) => SingI (Left (a :: k)) where sing = SLeft sing +instance SingI1 Left where + liftSing = SLeft instance (SingI b) => SingI (Right (b :: k)) where sing = SRight sing +instance SingI1 Right where + liftSing = SRight instance (SingKind k1, SingKind k2) => SingKind (Either k1 k2) where type Demote (Either k1 k2) = Either (Demote k1) (Demote k2) fromSing (SLeft x) = Left (fromSing x) @@ -294,15 +376,28 @@ -- Composite +#if __GLASGOW_HASKELL__ >= 810 +type Composite :: Type -> Type -> Type +#endif data Composite :: Type -> Type -> Type where MkComp :: Either (Maybe a) b -> Composite a b +#if __GLASGOW_HASKELL__ >= 810 +type SComposite :: forall k1 k2. Composite k1 k2 -> Type +#endif data SComposite :: forall k1 k2. Composite k1 k2 -> Type where SMkComp :: forall k1 k2 (a :: Either (Maybe k1) k2). SEither a -> SComposite (MkComp a) -type instance Sing = SComposite +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @(Composite k1 k2) = +#else +type instance Sing = +#endif + SComposite instance SingI a => SingI (MkComp (a :: Either (Maybe k1) k2)) where sing = SMkComp sing +instance SingI1 MkComp where + liftSing = SMkComp instance (SingKind k1, SingKind k2) => SingKind (Composite k1 k2) where type Demote (Composite k1 k2) = Composite (Demote k1) (Demote k2) @@ -319,9 +414,22 @@ -- Empty +#if __GLASGOW_HASKELL__ >= 810 +type Empty :: Type +#endif data Empty + +#if __GLASGOW_HASKELL__ >= 810 +type SEmpty :: Empty -> Type +#endif data SEmpty :: Empty -> Type -type instance Sing = SEmpty + +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @Empty = +#else +type instance Sing = +#endif + SEmpty instance SingKind Empty where type Demote Empty = Empty fromSing = \case @@ -329,24 +437,44 @@ -- Type +#if __GLASGOW_HASKELL__ >= 810 +type Vec :: Type -> Nat -> Type +#endif data Vec :: Type -> Nat -> Type where VNil :: Vec a Zero VCons :: a -> Vec a n -> Vec a (Succ n) +#if __GLASGOW_HASKELL__ >= 810 +type Rep :: Type +#endif data Rep = Nat | Maybe Rep | Vec Rep Nat +#if __GLASGOW_HASKELL__ >= 810 +type SRep :: Type -> Type +#endif data SRep :: Type -> Type where SNat :: SRep Nat SMaybe :: SRep a -> SRep (Maybe a) SVec :: SRep a -> SNat n -> SRep (Vec a n) -type instance Sing = SRep +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @Type = +#else +type instance Sing = +#endif + SRep instance SingI Nat where sing = SNat instance SingI a => SingI (Maybe a) where sing = SMaybe sing +instance SingI1 Maybe where + liftSing = SMaybe instance (SingI a, SingI n) => SingI (Vec a n) where sing = SVec sing sing +instance SingI a => SingI1 (Vec a) where + liftSing = SVec sing +instance SingI2 Vec where + liftSing2 = SVec instance SingKind Type where type Demote Type = Rep @@ -382,7 +510,10 @@ (Disproved contra, _) -> Disproved (\Refl -> contra Refl) (_, Disproved contra) -> Disproved (\Refl -> contra Refl) -type family EqualsType (a :: Type) (b :: Type) where +#if __GLASGOW_HASKELL__ >= 810 +type EqualsType :: Type -> Type -> Bool +#endif +type family EqualsType (a :: Type) (b :: Type) :: Bool where EqualsType a a = True EqualsType _ _ = False instance PEq Type where @@ -402,12 +533,18 @@ isJust Nothing = False isJust (Just _) = True +#if __GLASGOW_HASKELL__ >= 810 +type IsJust :: Maybe k -> Bool +#endif type family IsJust (a :: Maybe k) :: Bool where IsJust Nothing = False IsJust (Just a) = True -- defunctionalization symbols -data IsJustSym0 :: Maybe a ~> Bool +#if __GLASGOW_HASKELL__ >= 810 +type IsJustSym0 :: forall a. Maybe a ~> Bool +#endif +data IsJustSym0 :: forall a. Maybe a ~> Bool type instance Apply IsJustSym0 a = IsJust a sIsJust :: Sing a -> Sing (IsJust a) @@ -418,10 +555,16 @@ pred Zero = Zero pred (Succ n) = n +#if __GLASGOW_HASKELL__ >= 810 +type Pred :: Nat -> Nat +#endif type family Pred (a :: Nat) :: Nat where Pred Zero = Zero Pred (Succ n) = n +#if __GLASGOW_HASKELL__ >= 810 +type PredSym0 :: Nat ~> Nat +#endif data PredSym0 :: Nat ~> Nat type instance Apply PredSym0 a = Pred a @@ -433,15 +576,22 @@ map _ Nil = Nil map f (Cons h t) = Cons (f h) (map f t) +#if __GLASGOW_HASKELL__ >= 810 +type Map :: (k1 ~> k2) -> List k1 -> List k2 +#endif type family Map (f :: k1 ~> k2) (l :: List k1) :: List k2 where Map f Nil = Nil Map f (Cons h t) = Cons (Apply f h) (Map f t) -- defunctionalization symbols -data MapSym1 :: (a ~> b) -> List a ~> List b -data MapSym0 :: (a ~> b) ~> List a ~> List b -type instance Apply (MapSym1 f) xs = Map f xs +#if __GLASGOW_HASKELL__ >= 810 +type MapSym0 :: forall a b. (a ~> b) ~> List a ~> List b +type MapSym1 :: forall a b. (a ~> b) -> List a ~> List b +#endif +data MapSym0 :: forall a b. (a ~> b) ~> List a ~> List b +data MapSym1 :: forall a b. (a ~> b) -> List a ~> List b type instance Apply MapSym0 f = MapSym1 f +type instance Apply (MapSym1 f) xs = Map f xs sMap :: forall k1 k2 (a :: List k1) (f :: k1 ~> k2). (forall b. Proxy f -> Sing b -> Sing (Apply f b)) -> Sing a -> Sing (Map f a) @@ -466,26 +616,32 @@ baz :: Sing (Cons Zero (Cons Zero Nil)) baz = sMap2 (Proxy :: Proxy PredSym0) (sPred) (SCons (SSucc SZero) (SCons SZero SNil)) -zipWith :: (a -> b -> c) -> [a] -> [b] -> [c] -zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys -zipWith _ [] (_:_) = [] -zipWith _ (_:_) [] = [] -zipWith _ [] [] = [] +zipWith :: (a -> b -> c) -> List a -> List b -> List c +zipWith f (Cons x xs) (Cons y ys) = Cons (f x y) (zipWith f xs ys) +zipWith _ Nil (Cons _ _) = Nil +zipWith _ (Cons _ _) Nil = Nil +zipWith _ Nil Nil = Nil -type family ZipWith (k1 :: a ~> b ~> c) - (k2 :: List a) - (k3 :: List b) :: List c where +#if __GLASGOW_HASKELL__ >= 810 +type ZipWith :: (a ~> b ~> c) -> List a -> List b -> List c +#endif +type family ZipWith (k1 :: a ~> b ~> c) (k2 :: List a) (k3 :: List b) :: List c where ZipWith f (Cons x xs) (Cons y ys) = Cons (Apply (Apply f x) y) (ZipWith f xs ys) ZipWith f Nil (Cons z1 z2) = Nil ZipWith f (Cons z1 z2) Nil = Nil ZipWith f Nil Nil = Nil -data ZipWithSym2 :: (a ~> b ~> c) -> List a -> List b ~> List c -data ZipWithSym1 :: (a ~> b ~> c) -> List a ~> List b ~> List c -data ZipWithSym0 :: (a ~> b ~> c) ~> List a ~> List b ~> List c -type instance Apply (ZipWithSym2 f xs) ys = ZipWith f xs ys -type instance Apply (ZipWithSym1 f) xs = ZipWithSym2 f xs +#if __GLASGOW_HASKELL__ >= 810 +type ZipWithSym0 :: forall a b c. (a ~> b ~> c) ~> List a ~> List b ~> List c +type ZipWithSym1 :: forall a b c. (a ~> b ~> c) -> List a ~> List b ~> List c +type ZipWithSym2 :: forall a b c. (a ~> b ~> c) -> List a -> List b ~> List c +#endif +data ZipWithSym0 :: forall a b c. (a ~> b ~> c) ~> List a ~> List b ~> List c +data ZipWithSym1 :: forall a b c. (a ~> b ~> c) -> List a ~> List b ~> List c +data ZipWithSym2 :: forall a b c. (a ~> b ~> c) -> List a -> List b ~> List c type instance Apply ZipWithSym0 f = ZipWithSym1 f +type instance Apply (ZipWithSym1 f) xs = ZipWithSym2 f xs +type instance Apply (ZipWithSym2 f xs) ys = ZipWith f xs ys sZipWith :: forall a b c (k1 :: a ~> b ~> c) (k2 :: List a) (k3 :: List b). @@ -500,17 +656,25 @@ either l _ (Left x) = l x either _ r (Right x) = r x +#if __GLASGOW_HASKELL__ >= 810 +type Either_ :: (a ~> c) -> (b ~> c) -> Either a b -> c +#endif type family Either_ (l :: a ~> c) (r :: b ~> c) (e :: Either a b) :: c where Either_ l r (Left x) = Apply l x Either_ l r (Right x) = Apply r x -- defunctionalization symbols -data Either_Sym2 :: (a ~> c) -> (b ~> c) -> Either a b ~> c -data Either_Sym1 :: (a ~> c) -> (b ~> c) ~> Either a b ~> c -data Either_Sym0 :: (a ~> c) ~> (b ~> c) ~> Either a b ~> c -type instance Apply (Either_Sym2 k1 k2) k3 = Either_ k1 k2 k3 -type instance Apply (Either_Sym1 k1) k2 = Either_Sym2 k1 k2 +#if __GLASGOW_HASKELL__ >= 810 +type Either_Sym0 :: forall a c b. (a ~> c) ~> (b ~> c) ~> Either a b ~> c +type Either_Sym1 :: forall a c b. (a ~> c) -> (b ~> c) ~> Either a b ~> c +type Either_Sym2 :: forall a c b. (a ~> c) -> (b ~> c) -> Either a b ~> c +#endif +data Either_Sym0 :: forall a c b. (a ~> c) ~> (b ~> c) ~> Either a b ~> c +data Either_Sym1 :: forall a c b. (a ~> c) -> (b ~> c) ~> Either a b ~> c +data Either_Sym2 :: forall a c b. (a ~> c) -> (b ~> c) -> Either a b ~> c type instance Apply Either_Sym0 k1 = Either_Sym1 k1 +type instance Apply (Either_Sym1 k1) k2 = Either_Sym2 k1 k2 +type instance Apply (Either_Sym2 k1 k2) k3 = Either_ k1 k2 k3 sEither :: forall a b c (l :: a ~> c) @@ -549,6 +713,9 @@ eitherToNat (Left x) = x eitherToNat (Right x) = x +#if __GLASGOW_HASKELL__ >= 810 +type EitherToNat :: Either Nat Nat -> Nat +#endif type family EitherToNat (e :: Either Nat Nat) :: Nat where EitherToNat (Left x) = x EitherToNat (Right x) = x @@ -561,14 +728,21 @@ liftMaybe _ Nothing = Nothing liftMaybe f (Just a) = Just (f a) +#if __GLASGOW_HASKELL__ >= 810 +type LiftMaybe :: (a ~> b) -> Maybe a -> Maybe b +#endif type family LiftMaybe (f :: a ~> b) (x :: Maybe a) :: Maybe b where LiftMaybe f Nothing = Nothing LiftMaybe f (Just a) = Just (Apply f a) -data LiftMaybeSym1 :: (a ~> b) -> Maybe a ~> Maybe b -data LiftMaybeSym0 :: (a ~> b) ~> Maybe a ~> Maybe b -type instance Apply (LiftMaybeSym1 k1) k2 = LiftMaybe k1 k2 +#if __GLASGOW_HASKELL__ >= 810 +type LiftMaybeSym0 :: forall a b. (a ~> b) ~> Maybe a ~> Maybe b +type LiftMaybeSym1 :: forall a b. (a ~> b) -> Maybe a ~> Maybe b +#endif +data LiftMaybeSym0 :: forall a b. (a ~> b) ~> Maybe a ~> Maybe b +data LiftMaybeSym1 :: forall a b. (a ~> b) -> Maybe a ~> Maybe b type instance Apply LiftMaybeSym0 k1 = LiftMaybeSym1 k1 +type instance Apply (LiftMaybeSym1 k1) k2 = LiftMaybe k1 k2 sLiftMaybe :: forall a b (f :: a ~> b) (x :: Maybe a). (forall (y :: a). Proxy f -> Sing y -> Sing (Apply f y)) -> @@ -580,15 +754,22 @@ Zero + x = x (Succ x) + y = Succ (x + y) +#if __GLASGOW_HASKELL__ >= 810 +type (+) :: Nat -> Nat -> Nat +#endif type family (+) (m :: Nat) (n :: Nat) :: Nat where Zero + x = x (Succ x) + y = Succ (x + y) -- defunctionalization symbols -data (+$$) :: Nat -> Nat ~> Nat -data (+$) :: Nat ~> Nat ~> Nat -type instance Apply ((+$$) k1) k2 = (+) k1 k2 -type instance Apply (+$) k1 = (+$$) k1 +#if __GLASGOW_HASKELL__ >= 810 +type (+@#@$) :: Nat ~> Nat ~> Nat +type (+@#@$$) :: Nat -> Nat ~> Nat +#endif +data (+@#@$) :: Nat ~> Nat ~> Nat +data (+@#@$$) :: Nat -> Nat ~> Nat +type instance Apply (+@#@$) k1 = (+@#@$$) k1 +type instance Apply ((+@#@$$) k1) k2 = (+) k1 k2 (%+) :: Sing m -> Sing n -> Sing (m + n) SZero %+ x = x @@ -599,15 +780,22 @@ (Succ x) - Zero = Succ x (Succ x) - (Succ y) = x - y +#if __GLASGOW_HASKELL__ >= 810 +type (-) :: Nat -> Nat -> Nat +#endif type family (-) (m :: Nat) (n :: Nat) :: Nat where Zero - x = Zero (Succ x) - Zero = Succ x (Succ x) - (Succ y) = x - y -data (-$$) :: Nat -> Nat ~> Nat -data (-$) :: Nat ~> Nat ~> Nat -type instance Apply ((-$$) k1) k2 = (-) k1 k2 -type instance Apply (-$) k1 = (-$$) k1 +#if __GLASGOW_HASKELL__ >= 810 +type (-@#@$) :: Nat ~> Nat ~> Nat +type (-@#@$$) :: Nat -> Nat ~> Nat +#endif +data (-@#@$) :: Nat ~> Nat ~> Nat +data (-@#@$$) :: Nat -> Nat ~> Nat +type instance Apply (-@#@$) k1 = (-@#@$$) k1 +type instance Apply ((-@#@$$) k1) k2 = (-) k1 k2 (%-) :: Sing m -> Sing n -> Sing (m - n) SZero %- _ = SZero @@ -617,46 +805,66 @@ isZero :: Nat -> Bool isZero n = if n == Zero then True else False +#if __GLASGOW_HASKELL__ >= 810 +type IsZero :: Nat -> Bool +#endif type family IsZero (n :: Nat) :: Bool where IsZero n = If (n == Zero) True False +#if __GLASGOW_HASKELL__ >= 810 +type IsZeroSym0 :: Nat ~> Bool +#endif data IsZeroSym0 :: Nat ~> Bool type instance Apply IsZeroSym0 a = IsZero a sIsZero :: Sing n -> Sing (IsZero n) sIsZero n = sIf (n %== SZero) STrue SFalse +{- (||) :: Bool -> Bool -> Bool False || x = x True || _ = True +-} +#if __GLASGOW_HASKELL__ >= 810 +type (||) :: Bool -> Bool -> Bool +#endif type family (a :: Bool) || (b :: Bool) :: Bool where False || x = x True || x = True -data (||$$) :: Bool -> Bool ~> Bool -data (||$) :: Bool ~> Bool ~> Bool -type instance Apply ((||$$) a) b = (||) a b -type instance Apply (||$) a = (||$$) a +#if __GLASGOW_HASKELL__ >= 810 +type (||@#@$) :: Bool ~> Bool ~> Bool +type (||@#@$$) :: Bool -> Bool ~> Bool +#endif +data (||@#@$) :: Bool ~> Bool ~> Bool +data (||@#@$$) :: Bool -> Bool ~> Bool +type instance Apply (||@#@$) a = (||@#@$$) a +type instance Apply ((||@#@$$) a) b = (||) a b (%||) :: Sing a -> Sing b -> Sing (a || b) SFalse %|| x = x STrue %|| _ = STrue -{- contains :: Eq a => a -> List a -> Bool contains _ Nil = False contains elt (Cons h t) = (elt == h) || contains elt t --} +#if __GLASGOW_HASKELL__ >= 810 +type Contains :: k -> List k -> Bool +#endif type family Contains (a :: k) (b :: List k) :: Bool where Contains elt Nil = False Contains elt (Cons h t) = (elt == h) || (Contains elt t) -data ContainsSym1 :: a -> List a ~> Bool -data ContainsSym0 :: a ~> List a ~> Bool -type instance Apply (ContainsSym1 a) b = Contains a b +#if __GLASGOW_HASKELL__ >= 810 +type ContainsSym0 :: forall a. a ~> List a ~> Bool +type ContainsSym1 :: forall a. a -> List a ~> Bool +#endif +data ContainsSym0 :: forall a. a ~> List a ~> Bool +data ContainsSym1 :: forall a. a -> List a ~> Bool type instance Apply ContainsSym0 a = ContainsSym1 a +type instance Apply (ContainsSym1 a) b = Contains a b {- sContains :: forall k. SEq k => @@ -679,13 +887,14 @@ in lambda elt h t -{- cont :: Eq a => a -> List a -> Bool cont = \elt list -> case list of Nil -> False Cons h t -> (elt == h) || cont elt t --} +#if __GLASGOW_HASKELL__ >= 810 +type Cont :: a ~> List a ~> Bool +#endif type family Cont :: a ~> List a ~> Bool where Cont = Lambda10Sym0 @@ -708,21 +917,22 @@ type family Case10 a b scrut where Case10 elt list Nil = False - Case10 elt list (Cons h t) = (||$) @@ ((==$) @@ elt @@ h) @@ (Cont @@ elt @@ t) + Case10 elt list (Cons h t) = (||@#@$) @@ ((==@#@$) @@ elt @@ h) @@ (Cont @@ elt @@ t) -data (==$) f where - (:###==$) :: ((==$) @@ arg) ~ (==$$) arg - => Proxy arg - -> (==$) f -type instance (==$) `Apply` x = (==$$) x +data (==@#@$) f where + (:###==@#@$) :: ((==@#@$) @@ arg) ~ (==@#@$$) arg + => Proxy arg + -> (==@#@$) f +type instance (==@#@$) `Apply` x = (==@#@$$) x -data (==$$) a f where - (:###==$$) :: ((==$$) x @@ arg) ~ (==$$$) x arg - => Proxy arg - -> (==$$) x y -type instance (==$$) a `Apply` b = (==$$$) a b +data (==@#@$$) a f where + (:###==@#@$$) :: ((==@#@$$) x @@ arg) ~ (==@#@$$$) x arg + => Proxy arg + -> (==@#@$$) x y +type instance (==@#@$$) a `Apply` b = (==) a b -type (==$$$) a b = (==) a b +type family (==@#@$$$) a b where + (==@#@$$$) a b = (==) a b impNat :: forall m n. SingI n => Proxy n -> Sing m -> Sing (n + m) @@ -735,25 +945,16 @@ show SZero = "SZero" show (SSucc n) = "SSucc (" ++ (show n) ++ ")" -{- findIndices :: (a -> Bool) -> [a] -> [Nat] findIndices p ls = loop Zero ls where loop _ [] = [] loop n (x:xs) | p x = n : loop (Succ n) xs | otherwise = loop (Succ n) xs --} -findIndices' :: forall a. (a -> Bool) -> [a] -> [Nat] -findIndices' p ls = - let loop :: Nat -> [a] -> [Nat] - loop _ [] = [] - loop n (x:xs) = case p x of - True -> n : loop (Succ n) xs - False -> loop (Succ n) xs - in - loop Zero ls - +#if __GLASGOW_HASKELL__ >= 810 +type FindIndices :: (a ~> Bool) -> List a -> List Nat +#endif type family FindIndices (f :: a ~> Bool) (ls :: List a) :: List Nat where FindIndices p ls = (Let123LoopSym2 p ls) @@ Zero @@ ls @@ -775,9 +976,10 @@ KindInferenceLet123LoopSym3 :: ((Let123LoopSym3 a b c @@ z) ~ Let123LoopSym4 a b c z) => Proxy z -> Let123LoopSym3 a b c d -type instance Apply (Let123LoopSym3 a b c) d = Let123LoopSym4 a b c d +type instance Apply (Let123LoopSym3 a b c) d = Let123Loop a b c d -type Let123LoopSym4 a b c d = Let123Loop a b c d +type family Let123LoopSym4 a b c d where + Let123LoopSym4 a b c d = Let123Loop a b c d data FindIndicesSym0 a where KindInferenceFindIndicesSym0 :: (FindIndicesSym0 @@ z) ~ FindIndicesSym1 z @@ -789,17 +991,18 @@ KindInferenceFindIndicesSym1 :: (FindIndicesSym1 a @@ z) ~ FindIndicesSym2 a z => Proxy z -> FindIndicesSym1 a b -type instance Apply (FindIndicesSym1 a) b = FindIndicesSym2 a b +type instance Apply (FindIndicesSym1 a) b = FindIndices a b -type FindIndicesSym2 a b = FindIndices a b +type family FindIndicesSym2 a b where + FindIndicesSym2 a b = FindIndices a b sFindIndices :: forall a (t1 :: a ~> Bool) (t2 :: (List a)). Sing t1 -> Sing t2 -> Sing (FindIndicesSym0 @@ t1 @@ t2) sFindIndices sP sLs = - let sLoop :: forall (u1 :: Nat). Sing u1 - -> forall (u2 :: List a). Sing u2 + let sLoop :: forall (u1 :: Nat) (u2 :: List a). + Sing u1 -> Sing u2 -> Sing ((Let123LoopSym2 t1 t2) @@ u1 @@ u2) sLoop _ SNil = SNil sLoop sN (sX `SCons` sXs) = case sP @@ sX of @@ -837,9 +1040,10 @@ KindInferenceLambda22Sym1 :: (Lambda22Sym1 a @@ z) ~ Lambda22Sym2 a z => Proxy z -> Lambda22Sym1 a b -type instance Apply (Lambda22Sym1 a) b = Lambda22Sym2 a b +type instance Apply (Lambda22Sym1 a) b = Lambda22 a b -type Lambda22Sym2 a b = Lambda22 a b +type family Lambda22Sym2 a b where + Lambda22Sym2 a b = Lambda22 a b {- sFI :: forall a (t1 :: a ~> Bool) (t2 :: List a). Sing t1 @@ -865,9 +1069,20 @@ ------------------------------------------------------------ +#if __GLASGOW_HASKELL__ >= 810 +type G :: Type -> Type +#endif data G :: Type -> Type where MkG :: G Bool +#if __GLASGOW_HASKELL__ >= 810 +type SG :: forall a. G a -> Type +#endif data SG :: forall a. G a -> Type where SMkG :: SG MkG -type instance Sing = SG +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @(G a) = +#else +type instance Sing = +#endif + SG diff --git a/tests/ByHand2.hs b/tests/ByHand2.hs --- a/tests/ByHand2.hs +++ b/tests/ByHand2.hs @@ -1,46 +1,85 @@ {-# LANGUAGE DataKinds, PolyKinds, TypeFamilies, GADTs, TypeOperators, DefaultSignatures, ScopedTypeVariables, InstanceSigs, MultiParamTypeClasses, FunctionalDependencies, - UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-missing-signatures #-} + UndecidableInstances, CPP, TypeApplications #-} +{-# OPTIONS_GHC -Wno-missing-signatures -Wno-orphans #-} + +#if __GLASGOW_HASKELL__ < 806 +{-# LANGUAGE TypeInType #-} +#endif + +#if __GLASGOW_HASKELL__ >= 810 +{-# LANGUAGE StandaloneKindSignatures #-} +#endif module ByHand2 where -import Prelude hiding ( Eq(..), Ord(..), Bool(..), Ordering(..), not ) -import Data.Kind (Type) +import Data.Kind import Data.Singletons (Sing) +#if __GLASGOW_HASKELL__ >= 810 +type Nat :: Type +#endif data Nat = Zero | Succ Nat -data Bool = False | True -data Ordering = LT | EQ | GT -not :: Bool -> Bool -not False = True -not True = False - -class Eq a where - (==) :: a -> a -> Bool - (/=) :: a -> a -> Bool - infix 4 ==, /= - - x == y = not (x /= y) - x /= y = not (x == y) +#if __GLASGOW_HASKELL__ >= 810 +type SNat :: Nat -> Type +#endif +data SNat :: Nat -> Type where + SZero :: SNat 'Zero + SSucc :: SNat n -> SNat ('Succ n) +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @Nat = +#else +type instance Sing = +#endif + SNat -instance Eq Nat where - Zero == Zero = True - Zero == Succ _ = False - Succ _ == Zero = False - Succ x == Succ y = x == y +{- +type Bool :: Type +data Bool = False | True +-} +#if __GLASGOW_HASKELL__ >= 810 +type SBool :: Bool -> Type +#endif data SBool :: Bool -> Type where SFalse :: SBool 'False STrue :: SBool 'True -type instance Sing = SBool +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @Bool = +#else +type instance Sing = +#endif + SBool -data SNat :: Nat -> Type where - SZero :: SNat 'Zero - SSucc :: SNat n -> SNat ('Succ n) -type instance Sing = SNat +{- +type Ordering :: Type +data Ordering = LT | EQ | GT +-} +#if __GLASGOW_HASKELL__ >= 810 +type SOrdering :: Ordering -> Type +#endif +data SOrdering :: Ordering -> Type where + SLT :: SOrdering 'LT + SEQ :: SOrdering 'EQ + SGT :: SOrdering 'GT +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @Ordering = +#else +type instance Sing = +#endif + SOrdering + +{- +not :: Bool -> Bool +not True = False +not False = True +-} + +#if __GLASGOW_HASKELL__ >= 810 +type Not :: Bool -> Bool +#endif type family Not (x :: Bool) :: Bool where Not 'True = 'False Not 'False = 'True @@ -49,6 +88,20 @@ sNot STrue = SFalse sNot SFalse = STrue +{- +type Eq :: Type -> Constraint +class Eq a where + (==) :: a -> a -> Bool + (/=) :: a -> a -> Bool + infix 4 ==, /= + + x == y = not (x /= y) + x /= y = not (x == y) +-} + +#if __GLASGOW_HASKELL__ >= 810 +type PEq :: Type -> Constraint +#endif class PEq a where type (==) (x :: a) (y :: a) :: Bool type (/=) (x :: a) (y :: a) :: Bool @@ -56,12 +109,9 @@ type x == y = Not (x /= y) type x /= y = Not (x == y) -instance PEq Nat where - type 'Zero == 'Zero = 'True - type 'Succ x == 'Zero = 'False - type 'Zero == 'Succ x = 'False - type 'Succ x == 'Succ y = x == y - +#if __GLASGOW_HASKELL__ >= 810 +type SEq :: Type -> Constraint +#endif class SEq a where (%==) :: Sing (x :: a) -> Sing (y :: a) -> Sing (x == y) (%/=) :: Sing (x :: a) -> Sing (y :: a) -> Sing (x /= y) @@ -72,6 +122,18 @@ default (%/=) :: ((x /= y) ~ (Not (x == y))) => Sing (x :: a) -> Sing (y :: a) -> Sing (x /= y) x %/= y = sNot (x %== y) +instance Eq Nat where + Zero == Zero = True + Zero == Succ _ = False + Succ _ == Zero = False + Succ x == Succ y = x == y + +instance PEq Nat where + type 'Zero == 'Zero = 'True + type 'Succ x == 'Zero = 'False + type 'Zero == 'Succ x = 'False + type 'Succ x == 'Succ y = x == y + instance SEq Nat where (%==) :: forall (x :: Nat) (y :: Nat). Sing x -> Sing y -> Sing (x == y) SZero %== SZero = STrue @@ -79,6 +141,7 @@ SZero %== SSucc _ = SFalse SSucc x %== SSucc y = x %== y +{- instance Eq Ordering where LT == LT = True LT == EQ = False @@ -89,36 +152,7 @@ GT == LT = False GT == EQ = False GT == GT = True - -class Eq a => Ord a where - compare :: a -> a -> Ordering - (<) :: a -> a -> Bool - - x < y = compare x y == LT - -class PEq a => POrd a where - type Compare (x :: a) (y :: a) :: Ordering - type (<) (x :: a) (y :: a) :: Bool - - type x < y = Compare x y == 'LT - -instance Ord Nat where - compare Zero Zero = EQ - compare Zero (Succ _) = LT - compare (Succ _) Zero = GT - compare (Succ a) (Succ b) = compare a b - -instance POrd Nat where - type Compare 'Zero 'Zero = 'EQ - type Compare 'Zero ('Succ x) = 'LT - type Compare ('Succ x) 'Zero = 'GT - type Compare ('Succ x) ('Succ y) = Compare x y - -data SOrdering :: Ordering -> Type where - SLT :: SOrdering 'LT - SEQ :: SOrdering 'EQ - SGT :: SOrdering 'GT -type instance Sing = SOrdering +-} instance PEq Ordering where type 'LT == 'LT = 'True @@ -142,6 +176,27 @@ SGT %== SEQ = SFalse SGT %== SGT = STrue +{- +type Ord :: Type -> Constraint +class Eq a => Ord a where + compare :: a -> a -> Ordering + (<) :: a -> a -> Bool + + x < y = compare x y == LT +-} + +#if __GLASGOW_HASKELL__ >= 810 +type POrd :: Type -> Constraint +#endif +class PEq a => POrd a where + type Compare (x :: a) (y :: a) :: Ordering + type (<) (x :: a) (y :: a) :: Bool + + type x < y = Compare x y == 'LT + +#if __GLASGOW_HASKELL__ >= 810 +type SOrd :: Type -> Constraint +#endif class SEq a => SOrd a where sCompare :: Sing (x :: a) -> Sing (y :: a) -> Sing (Compare x y) (%<) :: Sing (x :: a) -> Sing (y :: a) -> Sing (x < y) @@ -149,18 +204,39 @@ default (%<) :: ((x < y) ~ (Compare x y == 'LT)) => Sing (x :: a) -> Sing (y :: a) -> Sing (x < y) x %< y = sCompare x y %== SLT +instance Ord Nat where + compare Zero Zero = EQ + compare Zero (Succ _) = LT + compare (Succ _) Zero = GT + compare (Succ a) (Succ b) = compare a b + +instance POrd Nat where + type Compare 'Zero 'Zero = 'EQ + type Compare 'Zero ('Succ x) = 'LT + type Compare ('Succ x) 'Zero = 'GT + type Compare ('Succ x) ('Succ y) = Compare x y + instance SOrd Nat where sCompare SZero SZero = SEQ sCompare SZero (SSucc _) = SLT sCompare (SSucc _) SZero = SGT sCompare (SSucc x) (SSucc y) = sCompare x y +#if __GLASGOW_HASKELL__ >= 810 +type Pointed :: Type -> Constraint +#endif class Pointed a where point :: a +#if __GLASGOW_HASKELL__ >= 810 +type PPointed :: Type -> Constraint +#endif class PPointed a where type Point :: a +#if __GLASGOW_HASKELL__ >= 810 +type SPointed :: Type -> Constraint +#endif class SPointed a where sPoint :: Sing (Point :: a) @@ -175,6 +251,9 @@ -------------------------------- +#if __GLASGOW_HASKELL__ >= 810 +type FD :: Type -> Type -> Constraint +#endif class FD a b | a -> b where meth :: a -> a l2r :: a -> b @@ -187,6 +266,9 @@ t1 = meth True t2 = l2r False +#if __GLASGOW_HASKELL__ >= 810 +type PFD :: Type -> Type -> Constraint +#endif class PFD a b | a -> b where type Meth (x :: a) :: a type L2r (x :: a) :: b @@ -197,8 +279,15 @@ type L2r 'True = 'Succ 'Zero type T1 = Meth 'True -type T2 = L2r 'False +#if __GLASGOW_HASKELL__ >= 810 +type T2 :: Nat +#endif +type T2 = (L2r 'False :: Nat) + +#if __GLASGOW_HASKELL__ >= 810 +type SFD :: Type -> Type -> Constraint +#endif class SFD a b | a -> b where sMeth :: forall (x :: a). Sing x -> Sing (Meth x :: a) sL2r :: forall (x :: a). Sing x -> Sing (L2r x :: b) @@ -209,5 +298,5 @@ sL2r STrue = SSucc SZero sT1 = sMeth STrue -sT2 :: Sing (T2 :: Nat) +sT2 :: Sing T2 sT2 = sL2r SFalse diff --git a/tests/SingletonsTestSuite.hs b/tests/SingletonsTestSuite.hs --- a/tests/SingletonsTestSuite.hs +++ b/tests/SingletonsTestSuite.hs @@ -1,143 +1,6 @@ -module Main ( - main - ) where - -import Test.Tasty ( DependencyType(..), TestTree - , after, defaultMain, testGroup ) -import SingletonsTestSuiteUtils ( compileAndDumpStdTest, compileAndDumpTest - , testCompileAndDumpGroup, ghcOpts ) +-- | Currently, there is code to execute at runtime as a part of this test +-- suite, as the only interesting part is making sure that the code typechecks. +module Main (main) where main :: IO () -main = defaultMain tests - -tests :: TestTree -tests = - testGroup "Testsuite" $ [ - testCompileAndDumpGroup "Singletons" - [ compileAndDumpStdTest "Nat" - , compileAndDumpStdTest "Empty" - , compileAndDumpStdTest "Maybe" - , compileAndDumpStdTest "BoxUnBox" - , afterSingletonsNat . - compileAndDumpStdTest "Operators" - , afterSingletonsNat . - compileAndDumpStdTest "HigherOrder" - , compileAndDumpStdTest "Contains" - , afterSingletonsNat . - compileAndDumpStdTest "AsPattern" - , afterSingletonsNat . - compileAndDumpStdTest "DataValues" - , after AllSucceed "$3 == \"Empty\"" . - after AllSucceed "$3 == \"Operators\"" . - compileAndDumpStdTest "EqInstances" - , compileAndDumpStdTest "CaseExpressions" - , afterSingletonsNat . - compileAndDumpStdTest "Star" - , afterSingletonsNat . - compileAndDumpStdTest "ReturnFunc" - , compileAndDumpStdTest "Lambdas" - , afterSingletonsNat . - compileAndDumpStdTest "LambdasComprehensive" - , compileAndDumpStdTest "Error" - , compileAndDumpStdTest "TopLevelPatterns" - , afterSingletonsNat . - compileAndDumpStdTest "LetStatements" - , compileAndDumpStdTest "LambdaCase" - , afterSingletonsNat . - compileAndDumpStdTest "Sections" - , afterSingletonsNat . - compileAndDumpStdTest "PatternMatching" - , compileAndDumpStdTest "Records" - , compileAndDumpStdTest "T29" - , compileAndDumpStdTest "T33" - , compileAndDumpStdTest "T54" - , afterSingletonsNat . - compileAndDumpStdTest "Classes" - , afterSingletonsNat . - after AllSucceed "$3 == \"Classes\"" . - compileAndDumpStdTest "Classes2" - , compileAndDumpStdTest "FunDeps" - , compileAndDumpStdTest "T78" - , compileAndDumpStdTest "OrdDeriving" - , compileAndDumpStdTest "BoundedDeriving" - , compileAndDumpStdTest "BadBoundedDeriving" - , compileAndDumpStdTest "EnumDeriving" - , compileAndDumpStdTest "BadEnumDeriving" - , compileAndDumpStdTest "Fixity" - , compileAndDumpStdTest "Undef" - , compileAndDumpStdTest "T124" - , compileAndDumpStdTest "T136" - , compileAndDumpStdTest "T136b" - , compileAndDumpStdTest "T153" - , compileAndDumpStdTest "T157" - , compileAndDumpStdTest "T159" - , compileAndDumpStdTest "T167" - , compileAndDumpStdTest "T145" - , compileAndDumpStdTest "PolyKinds" - , compileAndDumpStdTest "PolyKindsApp" - , compileAndDumpStdTest "T160" - , compileAndDumpStdTest "T163" - , compileAndDumpStdTest "T166" - , compileAndDumpStdTest "T172" - , compileAndDumpStdTest "T175" - , compileAndDumpStdTest "T176" - , compileAndDumpStdTest "T178" - , compileAndDumpStdTest "T183" - , compileAndDumpStdTest "T184" - , compileAndDumpStdTest "T187" - , compileAndDumpStdTest "T190" - , compileAndDumpStdTest "ShowDeriving" - , compileAndDumpStdTest "EmptyShowDeriving" - , compileAndDumpStdTest "StandaloneDeriving" - , compileAndDumpStdTest "T197" - , compileAndDumpStdTest "T197b" - , compileAndDumpStdTest "T200" - , compileAndDumpStdTest "T206" - , compileAndDumpStdTest "T209" - , compileAndDumpStdTest "T216" - , compileAndDumpStdTest "T226" - , compileAndDumpStdTest "T229" - , compileAndDumpStdTest "T249" - , compileAndDumpStdTest "OverloadedStrings" - , compileAndDumpStdTest "T271" - , compileAndDumpStdTest "T287" - , compileAndDumpStdTest "TypeRepTYPE" - , compileAndDumpStdTest "T297" - , compileAndDumpStdTest "T312" - , compileAndDumpStdTest "T313" - , compileAndDumpStdTest "T316" - , compileAndDumpStdTest "T322" - , compileAndDumpStdTest "NatSymbolReflexive" - , compileAndDumpStdTest "T323" - , compileAndDumpStdTest "T332" - , compileAndDumpStdTest "T342" - , compileAndDumpStdTest "FunctorLikeDeriving" - , compileAndDumpStdTest "T353" - , compileAndDumpStdTest "T358" - , compileAndDumpStdTest "T367" - , compileAndDumpStdTest "T371" - , compileAndDumpStdTest "T376" - , compileAndDumpStdTest "T402" - ], - testCompileAndDumpGroup "Promote" - [ compileAndDumpStdTest "Constructors" - , compileAndDumpStdTest "GenDefunSymbols" - , afterSingletonsNat . - compileAndDumpStdTest "Newtypes" - , compileAndDumpStdTest "Pragmas" - , compileAndDumpStdTest "Prelude" - , compileAndDumpStdTest "T180" - , compileAndDumpStdTest "T361" - ], - testGroup "Database client" - [ compileAndDumpTest "GradingClient/Database" ghcOpts - , after AllSucceed "$3 == \"Database\"" $ - compileAndDumpTest "GradingClient/Main" ghcOpts - ], - testCompileAndDumpGroup "InsertionSort" - [ compileAndDumpStdTest "InsertionSortImp" - ] - ] - -afterSingletonsNat :: TestTree -> TestTree -afterSingletonsNat = after AllSucceed "$3 == \"Nat\"" +main = pure () diff --git a/tests/SingletonsTestSuiteUtils.hs b/tests/SingletonsTestSuiteUtils.hs deleted file mode 100644 --- a/tests/SingletonsTestSuiteUtils.hs +++ /dev/null @@ -1,209 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -module SingletonsTestSuiteUtils ( - compileAndDumpTest - , compileAndDumpStdTest - , testCompileAndDumpGroup - , ghcOpts - , cleanFiles - ) where - -import Build_singletons ( ghcPath, ghcFlags, rootDir ) -import Control.Exception ( Exception, throw ) -import Data.Foldable ( asum ) -import Data.List ( intercalate ) -import Data.Text ( Text ) -import Data.String ( IsString(fromString) ) -import System.Exit ( ExitCode(..) ) -import System.FilePath ( takeBaseName, pathSeparator ) -import System.IO ( IOMode(..), hGetContents, openFile ) -import System.FilePath ( () ) -import System.Process ( CreateProcess(..), StdStream(..) - , createProcess, proc, waitForProcess - , callCommand ) -import Test.Tasty ( TestTree, testGroup ) -import Test.Tasty.Golden ( goldenVsFileDiff ) -import qualified Turtle - --- Some infractructure for handling external process errors -newtype ProcessException = ProcessException String - deriving newtype (Eq, Ord, Show) - deriving anyclass Exception - --- directory storing compile-and-run tests and golden files -goldenPath :: FilePath -goldenPath = rootDir "tests/compile-and-dump/" - -ghcVersion :: String -ghcVersion = ".ghc88" - --- GHC options used when running the tests -ghcOpts :: [String] -ghcOpts = ghcFlags ++ [ - "-v0" - , "-c" - , "-ddump-splices" - , "-dsuppress-uniques" - , "-fforce-recomp" - , "-fprint-explicit-kinds" - , "-O0" - , "-i" ++ goldenPath - , "-XTemplateHaskell" - , "-XDataKinds" - , "-XKindSignatures" - , "-XTypeFamilies" - , "-XTypeOperators" - , "-XMultiParamTypeClasses" - , "-XGADTs" - , "-XFlexibleInstances" - , "-XUndecidableInstances" - , "-XRankNTypes" - , "-XScopedTypeVariables" - , "-XPolyKinds" - , "-XFlexibleContexts" - , "-XIncoherentInstances" - , "-XLambdaCase" - , "-XUnboxedTuples" - , "-XInstanceSigs" - , "-XDefaultSignatures" - , "-XCPP" - , "-XStandaloneDeriving" - , "-XTypeApplications" - , "-XEmptyCase" - , "-XNoStarIsType" - ] - --- Compile a test using specified GHC options. Save output to file, normalize --- and compare it with golden file. This function also builds golden file --- from a template file. Putting it here is a bit of a hack but it's easy and it --- works. --- --- First parameter is a path to the test file relative to goldenPath directory --- with no ".hs". -compileAndDumpTest :: FilePath -> [String] -> TestTree -compileAndDumpTest testName opts = - goldenVsFileDiff - (takeBaseName testName) - (\ref new -> ["diff", "-w", "-B", ref, new]) -- see Note [Diff options] - goldenFilePath - actualFilePath - compileWithGHC - where - testPath = testName ++ ".hs" - templateFilePath = goldenPath ++ testName ++ ghcVersion ++ ".template" - goldenFilePath = goldenPath ++ testName ++ ".golden" - actualFilePath = goldenPath ++ testName ++ ".actual" - - compileWithGHC :: IO () - compileWithGHC = do - hActualFile <- openFile actualFilePath WriteMode - (_, _, _, pid) <- createProcess (proc ghcPath (testPath : opts)) - { std_out = UseHandle hActualFile - , std_err = UseHandle hActualFile - , cwd = Just goldenPath } - _ <- waitForProcess pid -- see Note [Ignore exit code] - normalizeOutput actualFilePath -- see Note [Output normalization] - buildGoldenFile templateFilePath goldenFilePath - return () - --- Compile-and-dump test using standard GHC options defined by the testsuite. --- It takes two parameters: name of a file containing a test (no ".hs" --- extension) and directory where the test is located (relative to --- goldenPath). Test name and path are passed separately so that this function --- can be used easily with testCompileAndDumpGroup. -compileAndDumpStdTest :: FilePath -> FilePath -> TestTree -compileAndDumpStdTest testName testPath = - compileAndDumpTest (testPath ++ (pathSeparator : testName)) ghcOpts - --- A convenience function for defining a group of compile-and-dump tests stored --- in the same subdirectory. It takes the name of subdirectory and list of --- functions that given the name of subdirectory create a TestTree. Designed for --- use with compileAndDumpStdTest. -testCompileAndDumpGroup :: FilePath -> [FilePath -> TestTree] -> TestTree -testCompileAndDumpGroup testDir tests = - testGroup testDir $ map ($ testDir) tests - --- Note [Ignore exit code] --- ~~~~~~~~~~~~~~~~~~~~~~~ ----- It may happen that compilation of a source file fails. We could find out --- whether that happened by inspecting the exit code of GHC process. But it --- would be tricky to get a helpful message from the failing test: we would need --- to display stderr which we just wrote into a file. Luckliy we don't have to --- do that - we can ignore the problem here and let the test fail when the --- actual file is compared with the golden file. - --- Note [Diff options] --- ~~~~~~~~~~~~~~~~~~~ --- --- We use following diff options: --- -w - Ignore all white space. --- -B - Ignore changes whose lines are all blank. - --- Note [Output normalization] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- Output file is normalized inplace. Line numbers generated in splices: --- --- Foo:(40,3)-(42,4) --- Foo.hs:7:3: --- Equals_1235967303 --- --- are turned into: --- --- Foo:(0,0)-(0,0) --- Foo.hs:0:0: --- Equals_0123456789 --- --- This allows to insert comments into test file without the need to modify the --- golden file to adjust line numbers. --- - -normalizeOutput :: FilePath -> IO () -normalizeOutput file = Turtle.inplace pat (fromString file) - where - pat :: Turtle.Pattern Text - pat = asum - [ "(0,0)-(0,0)" <$ numPair <* "-" <* numPair - , ":0:0:" <$ ":" <* d <* ":" <* d <* "-" <* d - , ":0:0" <$ ":" <* d <* ":" <* d - , fromString @Text . numPeriod <$> Turtle.lowerBounded 10 Turtle.digit - , fromString @Text . ('%' <$) <$> Turtle.lowerBounded 10 punctSym - -- Remove pretty-printed references to the singletons package - -- (e.g., turn `singletons-2.4.1:Sing` into `Sing`) to make the output - -- more stable. - , "" <$ "singletons-" <* verNum <* ":" - ] - verNum = d `Turtle.sepBy` Turtle.char '.' - numPair = () <$ "(" <* d <* "," <* d <* ")" - punctSym = Turtle.oneOf "!#$%&*+./>" - numPeriod = zipWith const (cycle "0123456789876543210") - d = Turtle.some Turtle.digit - -buildGoldenFile :: FilePath -> FilePath -> IO () -buildGoldenFile templateFilePath goldenFilePath = do - hGoldenFile <- openFile goldenFilePath WriteMode - runProcessWithOpts (UseHandle hGoldenFile) "awk" - [ "-f", goldenPath "buildGoldenFiles.awk" - , templateFilePath - ] - -runProcessWithOpts :: StdStream -> String -> [String] -> IO () -runProcessWithOpts stdout program opts = do - (_, _, Just serr, pid) <- - createProcess (proc "bash" ["-c", (intercalate " " (program : opts))]) - { std_out = stdout - , std_err = CreatePipe } - ecode <- waitForProcess pid - case ecode of - ExitSuccess -> return () - ExitFailure _ -> do - err <- hGetContents serr -- Text would be faster than String, but this is - -- a corner case so probably not worth it. - throw $ ProcessException ("Error when running " ++ program ++ ":\n" ++ err) - -cleanFiles :: IO () -cleanFiles = callCommand $ "rm -f " ++ rootDir "tests/compile-and-dump/*/*.{hi,o}" diff --git a/tests/compile-and-dump/GradingClient/Database.ghc88.template b/tests/compile-and-dump/GradingClient/Database.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/GradingClient/Database.ghc88.template +++ /dev/null @@ -1,2663 +0,0 @@ -GradingClient/Database.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| data Nat - = Zero | Succ Nat - deriving (Eq, Ord) |] - ======> - data Nat - = Zero | Succ Nat - deriving (Eq, Ord) - type ZeroSym0 = Zero - type SuccSym1 (t0123456789876543210 :: Nat) = - Succ t0123456789876543210 - instance SuppressUnusedWarnings SuccSym0 where - suppressUnusedWarnings = snd (((,) SuccSym0KindInference) ()) - data SuccSym0 :: (~>) Nat Nat - where - SuccSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply SuccSym0 arg) (SuccSym1 arg) => - SuccSym0 t0123456789876543210 - type instance Apply SuccSym0 t0123456789876543210 = Succ t0123456789876543210 - type family Compare_0123456789876543210 (a :: Nat) (a :: Nat) :: Ordering where - Compare_0123456789876543210 Zero Zero = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) '[] - Compare_0123456789876543210 (Succ a_0123456789876543210) (Succ b_0123456789876543210) = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) '[]) - Compare_0123456789876543210 Zero (Succ _) = LTSym0 - Compare_0123456789876543210 (Succ _) Zero = GTSym0 - type Compare_0123456789876543210Sym2 (a0123456789876543210 :: Nat) (a0123456789876543210 :: Nat) = - Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Compare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym1KindInference) ()) - data Compare_0123456789876543210Sym1 (a0123456789876543210 :: Nat) :: (~>) Nat Ordering - where - Compare_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Compare_0123456789876543210Sym1 a0123456789876543210) arg) (Compare_0123456789876543210Sym2 a0123456789876543210 arg) => - Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Compare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Compare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym0KindInference) ()) - data Compare_0123456789876543210Sym0 :: (~>) Nat ((~>) Nat Ordering) - where - Compare_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Compare_0123456789876543210Sym0 arg) (Compare_0123456789876543210Sym1 arg) => - Compare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Compare_0123456789876543210Sym0 a0123456789876543210 = Compare_0123456789876543210Sym1 a0123456789876543210 - instance POrd Nat where - type Compare a a = Apply (Apply Compare_0123456789876543210Sym0 a) a - type family Equals_0123456789876543210 (a :: Nat) (b :: Nat) :: Bool where - Equals_0123456789876543210 Zero Zero = TrueSym0 - Equals_0123456789876543210 (Succ a) (Succ b) = (==) a b - Equals_0123456789876543210 (_ :: Nat) (_ :: Nat) = FalseSym0 - instance PEq Nat where - type (==) a b = Equals_0123456789876543210 a b - data SNat :: Nat -> Type - where - SZero :: SNat Zero - SSucc :: forall (n :: Nat). (Sing (n :: Nat)) -> SNat (Succ n) - type instance Sing @Nat = SNat - instance SingKind Nat where - type Demote Nat = Nat - fromSing SZero = Zero - fromSing (SSucc b) = Succ (fromSing b) - toSing Zero = SomeSing SZero - toSing (Succ (b :: Demote Nat)) - = case toSing b :: SomeSing Nat of { - SomeSing c -> SomeSing (SSucc c) } - instance SOrd Nat => SOrd Nat where - sCompare :: - forall (t1 :: Nat) (t2 :: Nat). - Sing t1 - -> Sing t2 - -> Sing (Apply (Apply (CompareSym0 :: TyFun Nat ((~>) Nat Ordering) - -> Type) t1) t2) - sCompare SZero SZero - = (applySing - ((applySing - ((applySing ((singFun3 @FoldlSym0) sFoldl)) - ((singFun2 @ThenCmpSym0) sThenCmp))) - SEQ)) - SNil - sCompare - (SSucc (sA_0123456789876543210 :: Sing a_0123456789876543210)) - (SSucc (sB_0123456789876543210 :: Sing b_0123456789876543210)) - = (applySing - ((applySing - ((applySing ((singFun3 @FoldlSym0) sFoldl)) - ((singFun2 @ThenCmpSym0) sThenCmp))) - SEQ)) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing - ((applySing ((singFun2 @CompareSym0) sCompare)) - sA_0123456789876543210)) - sB_0123456789876543210))) - SNil) - sCompare SZero (SSucc _) = SLT - sCompare (SSucc _) SZero = SGT - instance SEq Nat => SEq Nat where - (%==) SZero SZero = STrue - (%==) SZero (SSucc _) = SFalse - (%==) (SSucc _) SZero = SFalse - (%==) (SSucc a) (SSucc b) = ((%==) a) b - instance SDecide Nat => SDecide Nat where - (%~) SZero SZero = Proved Refl - (%~) SZero (SSucc _) = Disproved (\ x -> case x of) - (%~) (SSucc _) SZero = Disproved (\ x -> case x of) - (%~) (SSucc a) (SSucc b) - = case ((%~) a) b of - Proved Refl -> Proved Refl - Disproved contra - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - instance SDecide Nat => - Data.Type.Equality.TestEquality (SNat :: Nat -> Type) where - Data.Type.Equality.testEquality - = Data.Singletons.Decide.decideEquality - instance SDecide Nat => - Data.Type.Coercion.TestCoercion (SNat :: Nat -> Type) where - Data.Type.Coercion.testCoercion - = Data.Singletons.Decide.decideCoercion - instance SingI Zero where - sing = SZero - instance SingI n => SingI (Succ (n :: Nat)) where - sing = SSucc sing - instance SingI (SuccSym0 :: (~>) Nat Nat) where - sing = (singFun1 @SuccSym0) SSucc -GradingClient/Database.hs:(0,0)-(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] |] - ======> - 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 []) = 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) - type BOOLSym0 = BOOL - type STRINGSym0 = STRING - type NATSym0 = NAT - type VECSym2 (t0123456789876543210 :: U) (t0123456789876543210 :: Nat) = - VEC t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (VECSym1 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) VECSym1KindInference) ()) - data VECSym1 (t0123456789876543210 :: U) :: (~>) Nat U - where - VECSym1KindInference :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (VECSym1 t0123456789876543210) arg) (VECSym2 t0123456789876543210 arg) => - VECSym1 t0123456789876543210 t0123456789876543210 - type instance Apply (VECSym1 t0123456789876543210) t0123456789876543210 = VEC t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings VECSym0 where - suppressUnusedWarnings = snd (((,) VECSym0KindInference) ()) - data VECSym0 :: (~>) U ((~>) Nat U) - where - VECSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply VECSym0 arg) (VECSym1 arg) => - VECSym0 t0123456789876543210 - type instance Apply VECSym0 t0123456789876543210 = VECSym1 t0123456789876543210 - 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 (t0123456789876543210 :: [AChar]) (t0123456789876543210 :: U) = - Attr t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (AttrSym1 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) AttrSym1KindInference) ()) - data AttrSym1 (t0123456789876543210 :: [AChar]) :: (~>) U Attribute - where - AttrSym1KindInference :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (AttrSym1 t0123456789876543210) arg) (AttrSym2 t0123456789876543210 arg) => - AttrSym1 t0123456789876543210 t0123456789876543210 - type instance Apply (AttrSym1 t0123456789876543210) t0123456789876543210 = Attr t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings AttrSym0 where - suppressUnusedWarnings = snd (((,) AttrSym0KindInference) ()) - data AttrSym0 :: (~>) [AChar] ((~>) U Attribute) - where - AttrSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply AttrSym0 arg) (AttrSym1 arg) => - AttrSym0 t0123456789876543210 - type instance Apply AttrSym0 t0123456789876543210 = AttrSym1 t0123456789876543210 - type SchSym1 (t0123456789876543210 :: [Attribute]) = - Sch t0123456789876543210 - instance SuppressUnusedWarnings SchSym0 where - suppressUnusedWarnings = snd (((,) SchSym0KindInference) ()) - data SchSym0 :: (~>) [Attribute] Schema - where - SchSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply SchSym0 arg) (SchSym1 arg) => - SchSym0 t0123456789876543210 - type instance Apply SchSym0 t0123456789876543210 = Sch t0123456789876543210 - type Let0123456789876543210Scrutinee_0123456789876543210Sym4 name0123456789876543210 name'0123456789876543210 u0123456789876543210 attrs0123456789876543210 = - Let0123456789876543210Scrutinee_0123456789876543210 name0123456789876543210 name'0123456789876543210 u0123456789876543210 attrs0123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210Scrutinee_0123456789876543210Sym3 u0123456789876543210 name'0123456789876543210 name0123456789876543210) where - suppressUnusedWarnings - = snd - (((,) - Let0123456789876543210Scrutinee_0123456789876543210Sym3KindInference) - ()) - data Let0123456789876543210Scrutinee_0123456789876543210Sym3 name0123456789876543210 name'0123456789876543210 u0123456789876543210 attrs0123456789876543210 - where - Let0123456789876543210Scrutinee_0123456789876543210Sym3KindInference :: forall name0123456789876543210 - name'0123456789876543210 - u0123456789876543210 - attrs0123456789876543210 - arg. SameKind (Apply (Let0123456789876543210Scrutinee_0123456789876543210Sym3 name0123456789876543210 name'0123456789876543210 u0123456789876543210) arg) (Let0123456789876543210Scrutinee_0123456789876543210Sym4 name0123456789876543210 name'0123456789876543210 u0123456789876543210 arg) => - Let0123456789876543210Scrutinee_0123456789876543210Sym3 name0123456789876543210 name'0123456789876543210 u0123456789876543210 attrs0123456789876543210 - type instance Apply (Let0123456789876543210Scrutinee_0123456789876543210Sym3 u0123456789876543210 name'0123456789876543210 name0123456789876543210) attrs0123456789876543210 = Let0123456789876543210Scrutinee_0123456789876543210 u0123456789876543210 name'0123456789876543210 name0123456789876543210 attrs0123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210Scrutinee_0123456789876543210Sym2 name'0123456789876543210 name0123456789876543210) where - suppressUnusedWarnings - = snd - (((,) - Let0123456789876543210Scrutinee_0123456789876543210Sym2KindInference) - ()) - data Let0123456789876543210Scrutinee_0123456789876543210Sym2 name0123456789876543210 name'0123456789876543210 u0123456789876543210 - where - Let0123456789876543210Scrutinee_0123456789876543210Sym2KindInference :: forall name0123456789876543210 - name'0123456789876543210 - u0123456789876543210 - arg. SameKind (Apply (Let0123456789876543210Scrutinee_0123456789876543210Sym2 name0123456789876543210 name'0123456789876543210) arg) (Let0123456789876543210Scrutinee_0123456789876543210Sym3 name0123456789876543210 name'0123456789876543210 arg) => - Let0123456789876543210Scrutinee_0123456789876543210Sym2 name0123456789876543210 name'0123456789876543210 u0123456789876543210 - type instance Apply (Let0123456789876543210Scrutinee_0123456789876543210Sym2 name'0123456789876543210 name0123456789876543210) u0123456789876543210 = Let0123456789876543210Scrutinee_0123456789876543210Sym3 name'0123456789876543210 name0123456789876543210 u0123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210Scrutinee_0123456789876543210Sym1 name0123456789876543210) where - suppressUnusedWarnings - = snd - (((,) - Let0123456789876543210Scrutinee_0123456789876543210Sym1KindInference) - ()) - data Let0123456789876543210Scrutinee_0123456789876543210Sym1 name0123456789876543210 name'0123456789876543210 - where - Let0123456789876543210Scrutinee_0123456789876543210Sym1KindInference :: forall name0123456789876543210 - name'0123456789876543210 - arg. SameKind (Apply (Let0123456789876543210Scrutinee_0123456789876543210Sym1 name0123456789876543210) arg) (Let0123456789876543210Scrutinee_0123456789876543210Sym2 name0123456789876543210 arg) => - Let0123456789876543210Scrutinee_0123456789876543210Sym1 name0123456789876543210 name'0123456789876543210 - type instance Apply (Let0123456789876543210Scrutinee_0123456789876543210Sym1 name0123456789876543210) name'0123456789876543210 = Let0123456789876543210Scrutinee_0123456789876543210Sym2 name0123456789876543210 name'0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210Scrutinee_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd - (((,) - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference) - ()) - data Let0123456789876543210Scrutinee_0123456789876543210Sym0 name0123456789876543210 - where - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference :: forall name0123456789876543210 - arg. SameKind (Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 arg) (Let0123456789876543210Scrutinee_0123456789876543210Sym1 arg) => - Let0123456789876543210Scrutinee_0123456789876543210Sym0 name0123456789876543210 - type instance Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 name0123456789876543210 = Let0123456789876543210Scrutinee_0123456789876543210Sym1 name0123456789876543210 - type family Let0123456789876543210Scrutinee_0123456789876543210 name name' u attrs where - Let0123456789876543210Scrutinee_0123456789876543210 name name' u attrs = Apply (Apply (==@#@$) name) name' - type family Case_0123456789876543210 name name' u attrs t where - Case_0123456789876543210 name name' u attrs 'True = u - Case_0123456789876543210 name name' u attrs 'False = Apply (Apply LookupSym0 name) (Apply SchSym0 attrs) - type LookupSym2 (a0123456789876543210 :: [AChar]) (a0123456789876543210 :: Schema) = - Lookup a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (LookupSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) LookupSym1KindInference) ()) - data LookupSym1 (a0123456789876543210 :: [AChar]) :: (~>) Schema U - where - LookupSym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (LookupSym1 a0123456789876543210) arg) (LookupSym2 a0123456789876543210 arg) => - LookupSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (LookupSym1 a0123456789876543210) a0123456789876543210 = Lookup a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings LookupSym0 where - suppressUnusedWarnings = snd (((,) LookupSym0KindInference) ()) - data LookupSym0 :: (~>) [AChar] ((~>) Schema U) - where - LookupSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply LookupSym0 arg) (LookupSym1 arg) => - LookupSym0 a0123456789876543210 - type instance Apply LookupSym0 a0123456789876543210 = LookupSym1 a0123456789876543210 - type OccursSym2 (a0123456789876543210 :: [AChar]) (a0123456789876543210 :: Schema) = - Occurs a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (OccursSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) OccursSym1KindInference) ()) - data OccursSym1 (a0123456789876543210 :: [AChar]) :: (~>) Schema Bool - where - OccursSym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (OccursSym1 a0123456789876543210) arg) (OccursSym2 a0123456789876543210 arg) => - OccursSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (OccursSym1 a0123456789876543210) a0123456789876543210 = Occurs a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings OccursSym0 where - suppressUnusedWarnings = snd (((,) OccursSym0KindInference) ()) - data OccursSym0 :: (~>) [AChar] ((~>) Schema Bool) - where - OccursSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply OccursSym0 arg) (OccursSym1 arg) => - OccursSym0 a0123456789876543210 - type instance Apply OccursSym0 a0123456789876543210 = OccursSym1 a0123456789876543210 - type DisjointSym2 (a0123456789876543210 :: Schema) (a0123456789876543210 :: Schema) = - Disjoint a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (DisjointSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) DisjointSym1KindInference) ()) - data DisjointSym1 (a0123456789876543210 :: Schema) :: (~>) Schema Bool - where - DisjointSym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (DisjointSym1 a0123456789876543210) arg) (DisjointSym2 a0123456789876543210 arg) => - DisjointSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (DisjointSym1 a0123456789876543210) a0123456789876543210 = Disjoint a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings DisjointSym0 where - suppressUnusedWarnings = snd (((,) DisjointSym0KindInference) ()) - data DisjointSym0 :: (~>) Schema ((~>) Schema Bool) - where - DisjointSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply DisjointSym0 arg) (DisjointSym1 arg) => - DisjointSym0 a0123456789876543210 - type instance Apply DisjointSym0 a0123456789876543210 = DisjointSym1 a0123456789876543210 - type AttrNotInSym2 (a0123456789876543210 :: Attribute) (a0123456789876543210 :: Schema) = - AttrNotIn a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (AttrNotInSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) AttrNotInSym1KindInference) ()) - data AttrNotInSym1 (a0123456789876543210 :: Attribute) :: (~>) Schema Bool - where - AttrNotInSym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (AttrNotInSym1 a0123456789876543210) arg) (AttrNotInSym2 a0123456789876543210 arg) => - AttrNotInSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (AttrNotInSym1 a0123456789876543210) a0123456789876543210 = AttrNotIn a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings AttrNotInSym0 where - suppressUnusedWarnings = snd (((,) AttrNotInSym0KindInference) ()) - data AttrNotInSym0 :: (~>) Attribute ((~>) Schema Bool) - where - AttrNotInSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply AttrNotInSym0 arg) (AttrNotInSym1 arg) => - AttrNotInSym0 a0123456789876543210 - type instance Apply AttrNotInSym0 a0123456789876543210 = AttrNotInSym1 a0123456789876543210 - type AppendSym2 (a0123456789876543210 :: Schema) (a0123456789876543210 :: Schema) = - Append a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (AppendSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) AppendSym1KindInference) ()) - data AppendSym1 (a0123456789876543210 :: Schema) :: (~>) Schema Schema - where - AppendSym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (AppendSym1 a0123456789876543210) arg) (AppendSym2 a0123456789876543210 arg) => - AppendSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (AppendSym1 a0123456789876543210) a0123456789876543210 = Append a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings AppendSym0 where - suppressUnusedWarnings = snd (((,) AppendSym0KindInference) ()) - data AppendSym0 :: (~>) Schema ((~>) Schema Schema) - where - AppendSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply AppendSym0 arg) (AppendSym1 arg) => - AppendSym0 a0123456789876543210 - type instance Apply AppendSym0 a0123456789876543210 = AppendSym1 a0123456789876543210 - type family Lookup (a :: [AChar]) (a :: Schema) :: U where - Lookup _ (Sch '[]) = UndefinedSym0 - Lookup name (Sch ('(:) (Attr name' u) attrs)) = Case_0123456789876543210 name name' u attrs (Let0123456789876543210Scrutinee_0123456789876543210Sym4 name name' u attrs) - type family Occurs (a :: [AChar]) (a :: Schema) :: Bool where - Occurs _ (Sch '[]) = FalseSym0 - Occurs name (Sch ('(:) (Attr name' _) attrs)) = Apply (Apply (||@#@$) (Apply (Apply (==@#@$) name) name')) (Apply (Apply OccursSym0 name) (Apply SchSym0 attrs)) - type family Disjoint (a :: Schema) (a :: Schema) :: Bool where - Disjoint (Sch '[]) _ = TrueSym0 - Disjoint (Sch ('(:) h t)) s = Apply (Apply (&&@#@$) (Apply (Apply AttrNotInSym0 h) s)) (Apply (Apply DisjointSym0 (Apply SchSym0 t)) s) - type family AttrNotIn (a :: Attribute) (a :: Schema) :: Bool where - AttrNotIn _ (Sch '[]) = TrueSym0 - AttrNotIn (Attr name u) (Sch ('(:) (Attr name' _) t)) = Apply (Apply (&&@#@$) (Apply (Apply (/=@#@$) name) name')) (Apply (Apply AttrNotInSym0 (Apply (Apply AttrSym0 name) u)) (Apply SchSym0 t)) - type family Append (a :: Schema) (a :: Schema) :: Schema where - Append (Sch s1) (Sch s2) = Apply SchSym0 (Apply (Apply (++@#@$) s1) s2) - type family ShowsPrec_0123456789876543210 (a :: GHC.Types.Nat) (a :: U) (a :: Symbol) :: Symbol where - ShowsPrec_0123456789876543210 _ BOOL a_0123456789876543210 = Apply (Apply ShowStringSym0 "BOOL") a_0123456789876543210 - ShowsPrec_0123456789876543210 _ STRING a_0123456789876543210 = Apply (Apply ShowStringSym0 "STRING") a_0123456789876543210 - ShowsPrec_0123456789876543210 _ NAT a_0123456789876543210 = Apply (Apply ShowStringSym0 "NAT") a_0123456789876543210 - ShowsPrec_0123456789876543210 p_0123456789876543210 (VEC arg_0123456789876543210 arg_0123456789876543210) a_0123456789876543210 = Apply (Apply (Apply ShowParenSym0 (Apply (Apply (>@#@$) p_0123456789876543210) (FromInteger 10))) (Apply (Apply (.@#@$) (Apply ShowStringSym0 "VEC ")) (Apply (Apply (.@#@$) (Apply (Apply ShowsPrecSym0 (FromInteger 11)) arg_0123456789876543210)) (Apply (Apply (.@#@$) ShowSpaceSym0) (Apply (Apply ShowsPrecSym0 (FromInteger 11)) arg_0123456789876543210))))) a_0123456789876543210 - type ShowsPrec_0123456789876543210Sym3 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: U) (a0123456789876543210 :: Symbol) = - ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym2KindInference) ()) - data ShowsPrec_0123456789876543210Sym2 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: U) :: (~>) Symbol Symbol - where - ShowsPrec_0123456789876543210Sym2KindInference :: forall a0123456789876543210 - a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) arg) (ShowsPrec_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 arg) => - ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym1KindInference) ()) - data ShowsPrec_0123456789876543210Sym1 (a0123456789876543210 :: GHC.Types.Nat) :: (~>) U ((~>) Symbol Symbol) - where - ShowsPrec_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) arg) (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 arg) => - ShowsPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ShowsPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym0KindInference) ()) - data ShowsPrec_0123456789876543210Sym0 :: (~>) GHC.Types.Nat ((~>) U ((~>) Symbol Symbol)) - where - ShowsPrec_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply ShowsPrec_0123456789876543210Sym0 arg) (ShowsPrec_0123456789876543210Sym1 arg) => - ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ShowsPrec_0123456789876543210Sym0 a0123456789876543210 = ShowsPrec_0123456789876543210Sym1 a0123456789876543210 - instance PShow U where - type ShowsPrec a a a = Apply (Apply (Apply ShowsPrec_0123456789876543210Sym0 a) a) a - type family ShowsPrec_0123456789876543210 (a :: GHC.Types.Nat) (a :: AChar) (a :: Symbol) :: Symbol where - ShowsPrec_0123456789876543210 _ CA a_0123456789876543210 = Apply (Apply ShowStringSym0 "CA") a_0123456789876543210 - ShowsPrec_0123456789876543210 _ CB a_0123456789876543210 = Apply (Apply ShowStringSym0 "CB") a_0123456789876543210 - ShowsPrec_0123456789876543210 _ CC a_0123456789876543210 = Apply (Apply ShowStringSym0 "CC") a_0123456789876543210 - ShowsPrec_0123456789876543210 _ CD a_0123456789876543210 = Apply (Apply ShowStringSym0 "CD") a_0123456789876543210 - ShowsPrec_0123456789876543210 _ CE a_0123456789876543210 = Apply (Apply ShowStringSym0 "CE") a_0123456789876543210 - ShowsPrec_0123456789876543210 _ CF a_0123456789876543210 = Apply (Apply ShowStringSym0 "CF") a_0123456789876543210 - ShowsPrec_0123456789876543210 _ CG a_0123456789876543210 = Apply (Apply ShowStringSym0 "CG") a_0123456789876543210 - ShowsPrec_0123456789876543210 _ CH a_0123456789876543210 = Apply (Apply ShowStringSym0 "CH") a_0123456789876543210 - ShowsPrec_0123456789876543210 _ CI a_0123456789876543210 = Apply (Apply ShowStringSym0 "CI") a_0123456789876543210 - ShowsPrec_0123456789876543210 _ CJ a_0123456789876543210 = Apply (Apply ShowStringSym0 "CJ") a_0123456789876543210 - ShowsPrec_0123456789876543210 _ CK a_0123456789876543210 = Apply (Apply ShowStringSym0 "CK") a_0123456789876543210 - ShowsPrec_0123456789876543210 _ CL a_0123456789876543210 = Apply (Apply ShowStringSym0 "CL") a_0123456789876543210 - ShowsPrec_0123456789876543210 _ CM a_0123456789876543210 = Apply (Apply ShowStringSym0 "CM") a_0123456789876543210 - ShowsPrec_0123456789876543210 _ CN a_0123456789876543210 = Apply (Apply ShowStringSym0 "CN") a_0123456789876543210 - ShowsPrec_0123456789876543210 _ CO a_0123456789876543210 = Apply (Apply ShowStringSym0 "CO") a_0123456789876543210 - ShowsPrec_0123456789876543210 _ CP a_0123456789876543210 = Apply (Apply ShowStringSym0 "CP") a_0123456789876543210 - ShowsPrec_0123456789876543210 _ CQ a_0123456789876543210 = Apply (Apply ShowStringSym0 "CQ") a_0123456789876543210 - ShowsPrec_0123456789876543210 _ CR a_0123456789876543210 = Apply (Apply ShowStringSym0 "CR") a_0123456789876543210 - ShowsPrec_0123456789876543210 _ CS a_0123456789876543210 = Apply (Apply ShowStringSym0 "CS") a_0123456789876543210 - ShowsPrec_0123456789876543210 _ CT a_0123456789876543210 = Apply (Apply ShowStringSym0 "CT") a_0123456789876543210 - ShowsPrec_0123456789876543210 _ CU a_0123456789876543210 = Apply (Apply ShowStringSym0 "CU") a_0123456789876543210 - ShowsPrec_0123456789876543210 _ CV a_0123456789876543210 = Apply (Apply ShowStringSym0 "CV") a_0123456789876543210 - ShowsPrec_0123456789876543210 _ CW a_0123456789876543210 = Apply (Apply ShowStringSym0 "CW") a_0123456789876543210 - ShowsPrec_0123456789876543210 _ CX a_0123456789876543210 = Apply (Apply ShowStringSym0 "CX") a_0123456789876543210 - ShowsPrec_0123456789876543210 _ CY a_0123456789876543210 = Apply (Apply ShowStringSym0 "CY") a_0123456789876543210 - ShowsPrec_0123456789876543210 _ CZ a_0123456789876543210 = Apply (Apply ShowStringSym0 "CZ") a_0123456789876543210 - type ShowsPrec_0123456789876543210Sym3 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: AChar) (a0123456789876543210 :: Symbol) = - ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym2KindInference) ()) - data ShowsPrec_0123456789876543210Sym2 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: AChar) :: (~>) Symbol Symbol - where - ShowsPrec_0123456789876543210Sym2KindInference :: forall a0123456789876543210 - a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) arg) (ShowsPrec_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 arg) => - ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym1KindInference) ()) - data ShowsPrec_0123456789876543210Sym1 (a0123456789876543210 :: GHC.Types.Nat) :: (~>) AChar ((~>) Symbol Symbol) - where - ShowsPrec_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) arg) (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 arg) => - ShowsPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ShowsPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym0KindInference) ()) - data ShowsPrec_0123456789876543210Sym0 :: (~>) GHC.Types.Nat ((~>) AChar ((~>) Symbol Symbol)) - where - ShowsPrec_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply ShowsPrec_0123456789876543210Sym0 arg) (ShowsPrec_0123456789876543210Sym1 arg) => - ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ShowsPrec_0123456789876543210Sym0 a0123456789876543210 = ShowsPrec_0123456789876543210Sym1 a0123456789876543210 - instance PShow AChar where - type ShowsPrec a a a = Apply (Apply (Apply ShowsPrec_0123456789876543210Sym0 a) a) a - type family Equals_0123456789876543210 (a :: U) (b :: U) :: Bool where - Equals_0123456789876543210 BOOL BOOL = TrueSym0 - Equals_0123456789876543210 STRING STRING = TrueSym0 - Equals_0123456789876543210 NAT NAT = TrueSym0 - Equals_0123456789876543210 (VEC a a) (VEC b b) = (&&) ((==) a b) ((==) a b) - Equals_0123456789876543210 (_ :: U) (_ :: U) = FalseSym0 - instance PEq U where - type (==) a b = Equals_0123456789876543210 a b - type family Equals_0123456789876543210 (a :: AChar) (b :: AChar) :: Bool where - Equals_0123456789876543210 CA CA = TrueSym0 - Equals_0123456789876543210 CB CB = TrueSym0 - Equals_0123456789876543210 CC CC = TrueSym0 - Equals_0123456789876543210 CD CD = TrueSym0 - Equals_0123456789876543210 CE CE = TrueSym0 - Equals_0123456789876543210 CF CF = TrueSym0 - Equals_0123456789876543210 CG CG = TrueSym0 - Equals_0123456789876543210 CH CH = TrueSym0 - Equals_0123456789876543210 CI CI = TrueSym0 - Equals_0123456789876543210 CJ CJ = TrueSym0 - Equals_0123456789876543210 CK CK = TrueSym0 - Equals_0123456789876543210 CL CL = TrueSym0 - Equals_0123456789876543210 CM CM = TrueSym0 - Equals_0123456789876543210 CN CN = TrueSym0 - Equals_0123456789876543210 CO CO = TrueSym0 - Equals_0123456789876543210 CP CP = TrueSym0 - Equals_0123456789876543210 CQ CQ = TrueSym0 - Equals_0123456789876543210 CR CR = TrueSym0 - Equals_0123456789876543210 CS CS = TrueSym0 - Equals_0123456789876543210 CT CT = TrueSym0 - Equals_0123456789876543210 CU CU = TrueSym0 - Equals_0123456789876543210 CV CV = TrueSym0 - Equals_0123456789876543210 CW CW = TrueSym0 - Equals_0123456789876543210 CX CX = TrueSym0 - Equals_0123456789876543210 CY CY = TrueSym0 - Equals_0123456789876543210 CZ CZ = TrueSym0 - Equals_0123456789876543210 (_ :: AChar) (_ :: AChar) = FalseSym0 - instance PEq AChar where - type (==) a b = Equals_0123456789876543210 a b - sLookup :: - forall (t :: [AChar]) (t :: Schema). - Sing t -> Sing t -> Sing (Apply (Apply LookupSym0 t) t :: U) - sOccurs :: - forall (t :: [AChar]) (t :: Schema). - Sing t -> Sing t -> Sing (Apply (Apply OccursSym0 t) t :: Bool) - sDisjoint :: - forall (t :: Schema) (t :: Schema). - Sing t -> Sing t -> Sing (Apply (Apply DisjointSym0 t) t :: Bool) - sAttrNotIn :: - forall (t :: Attribute) (t :: Schema). - Sing t -> Sing t -> Sing (Apply (Apply AttrNotInSym0 t) t :: Bool) - sAppend :: - forall (t :: Schema) (t :: Schema). - Sing t -> Sing t -> Sing (Apply (Apply AppendSym0 t) t :: Schema) - sLookup _ (SSch SNil) = sUndefined - sLookup - (sName :: Sing name) - (SSch (SCons (SAttr (sName' :: Sing name') (sU :: Sing u)) - (sAttrs :: Sing attrs))) - = let - sScrutinee_0123456789876543210 :: - Sing (Let0123456789876543210Scrutinee_0123456789876543210Sym4 name name' u attrs) - sScrutinee_0123456789876543210 - = (applySing ((applySing ((singFun2 @(==@#@$)) (%==))) sName)) - sName' - in - (GHC.Base.id - @(Sing (Case_0123456789876543210 name name' u attrs (Let0123456789876543210Scrutinee_0123456789876543210Sym4 name name' u attrs) :: U))) - (case sScrutinee_0123456789876543210 of - STrue -> sU - SFalse - -> (applySing ((applySing ((singFun2 @LookupSym0) sLookup)) sName)) - ((applySing ((singFun1 @SchSym0) SSch)) sAttrs)) - sOccurs _ (SSch SNil) = SFalse - sOccurs - (sName :: Sing name) - (SSch (SCons (SAttr (sName' :: Sing name') _) - (sAttrs :: Sing attrs))) - = (applySing - ((applySing ((singFun2 @(||@#@$)) (%||))) - ((applySing ((applySing ((singFun2 @(==@#@$)) (%==))) sName)) - sName'))) - ((applySing ((applySing ((singFun2 @OccursSym0) sOccurs)) sName)) - ((applySing ((singFun1 @SchSym0) SSch)) sAttrs)) - sDisjoint (SSch SNil) _ = STrue - sDisjoint - (SSch (SCons (sH :: Sing h) (sT :: Sing t))) - (sS :: Sing s) - = (applySing - ((applySing ((singFun2 @(&&@#@$)) (%&&))) - ((applySing - ((applySing ((singFun2 @AttrNotInSym0) sAttrNotIn)) sH)) - sS))) - ((applySing - ((applySing ((singFun2 @DisjointSym0) sDisjoint)) - ((applySing ((singFun1 @SchSym0) SSch)) sT))) - sS) - sAttrNotIn _ (SSch SNil) = STrue - sAttrNotIn - (SAttr (sName :: Sing name) (sU :: Sing u)) - (SSch (SCons (SAttr (sName' :: Sing name') _) (sT :: Sing t))) - = (applySing - ((applySing ((singFun2 @(&&@#@$)) (%&&))) - ((applySing ((applySing ((singFun2 @(/=@#@$)) (%/=))) sName)) - sName'))) - ((applySing - ((applySing ((singFun2 @AttrNotInSym0) sAttrNotIn)) - ((applySing ((applySing ((singFun2 @AttrSym0) SAttr)) sName)) sU))) - ((applySing ((singFun1 @SchSym0) SSch)) sT)) - sAppend (SSch (sS1 :: Sing s1)) (SSch (sS2 :: Sing s2)) - = (applySing ((singFun1 @SchSym0) SSch)) - ((applySing ((applySing ((singFun2 @(++@#@$)) (%++))) sS1)) sS2) - instance SingI (LookupSym0 :: (~>) [AChar] ((~>) Schema U)) where - sing = (singFun2 @LookupSym0) sLookup - instance SingI d => - SingI (LookupSym1 (d :: [AChar]) :: (~>) Schema U) where - sing = (singFun1 @(LookupSym1 (d :: [AChar]))) (sLookup (sing @d)) - instance SingI (OccursSym0 :: (~>) [AChar] ((~>) Schema Bool)) where - sing = (singFun2 @OccursSym0) sOccurs - instance SingI d => - SingI (OccursSym1 (d :: [AChar]) :: (~>) Schema Bool) where - sing = (singFun1 @(OccursSym1 (d :: [AChar]))) (sOccurs (sing @d)) - instance SingI (DisjointSym0 :: (~>) Schema ((~>) Schema Bool)) where - sing = (singFun2 @DisjointSym0) sDisjoint - instance SingI d => - SingI (DisjointSym1 (d :: Schema) :: (~>) Schema Bool) where - sing - = (singFun1 @(DisjointSym1 (d :: Schema))) (sDisjoint (sing @d)) - instance SingI (AttrNotInSym0 :: (~>) Attribute ((~>) Schema Bool)) where - sing = (singFun2 @AttrNotInSym0) sAttrNotIn - instance SingI d => - SingI (AttrNotInSym1 (d :: Attribute) :: (~>) Schema Bool) where - sing - = (singFun1 @(AttrNotInSym1 (d :: Attribute))) - (sAttrNotIn (sing @d)) - instance SingI (AppendSym0 :: (~>) Schema ((~>) Schema Schema)) where - sing = (singFun2 @AppendSym0) sAppend - instance SingI d => - SingI (AppendSym1 (d :: Schema) :: (~>) Schema Schema) where - sing = (singFun1 @(AppendSym1 (d :: Schema))) (sAppend (sing @d)) - data SU :: U -> Type - where - SBOOL :: SU BOOL - SSTRING :: SU STRING - SNAT :: SU NAT - SVEC :: forall (n :: U) (n :: Nat). - (Sing (n :: U)) -> (Sing (n :: Nat)) -> SU (VEC n n) - type instance Sing @U = SU - instance SingKind U where - type Demote 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 :: Demote U) (b :: Demote Nat)) - = case - ((,) (toSing b :: SomeSing U)) (toSing b :: SomeSing Nat) - of { - (,) (SomeSing c) (SomeSing c) -> SomeSing ((SVEC c) c) } - data SAChar :: AChar -> Type - where - SCA :: SAChar CA - SCB :: SAChar CB - SCC :: SAChar CC - SCD :: SAChar CD - SCE :: SAChar CE - SCF :: SAChar CF - SCG :: SAChar CG - SCH :: SAChar CH - SCI :: SAChar CI - SCJ :: SAChar CJ - SCK :: SAChar CK - SCL :: SAChar CL - SCM :: SAChar CM - SCN :: SAChar CN - SCO :: SAChar CO - SCP :: SAChar CP - SCQ :: SAChar CQ - SCR :: SAChar CR - SCS :: SAChar CS - SCT :: SAChar CT - SCU :: SAChar CU - SCV :: SAChar CV - SCW :: SAChar CW - SCX :: SAChar CX - SCY :: SAChar CY - SCZ :: SAChar CZ - type instance Sing @AChar = SAChar - instance SingKind AChar where - type Demote 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 - data SAttribute :: Attribute -> Type - where - SAttr :: forall (n :: [AChar]) (n :: U). - (Sing (n :: [AChar])) -> (Sing (n :: U)) -> SAttribute (Attr n n) - type instance Sing @Attribute = SAttribute - instance SingKind Attribute where - type Demote Attribute = Attribute - fromSing (SAttr b b) = (Attr (fromSing b)) (fromSing b) - toSing (Attr (b :: Demote [AChar]) (b :: Demote U)) - = case - ((,) (toSing b :: SomeSing [AChar])) (toSing b :: SomeSing U) - of { - (,) (SomeSing c) (SomeSing c) -> SomeSing ((SAttr c) c) } - data SSchema :: Schema -> Type - where - SSch :: forall (n :: [Attribute]). - (Sing (n :: [Attribute])) -> SSchema (Sch n) - type instance Sing @Schema = SSchema - instance SingKind Schema where - type Demote Schema = Schema - fromSing (SSch b) = Sch (fromSing b) - toSing (Sch (b :: Demote [Attribute])) - = case toSing b :: SomeSing [Attribute] of { - SomeSing c -> SomeSing (SSch c) } - instance (SShow U, SShow Nat) => SShow U where - sShowsPrec :: - forall (t1 :: GHC.Types.Nat) (t2 :: U) (t3 :: Symbol). - Sing t1 - -> Sing t2 - -> Sing t3 - -> Sing (Apply (Apply (Apply (ShowsPrecSym0 :: TyFun GHC.Types.Nat ((~>) U ((~>) Symbol Symbol)) - -> Type) t1) t2) t3) - sShowsPrec - _ - SBOOL - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "BOOL"))) - sA_0123456789876543210 - sShowsPrec - _ - SSTRING - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "STRING"))) - sA_0123456789876543210 - sShowsPrec - _ - SNAT - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "NAT"))) - sA_0123456789876543210 - sShowsPrec - (sP_0123456789876543210 :: Sing p_0123456789876543210) - (SVEC (sArg_0123456789876543210 :: Sing arg_0123456789876543210) - (sArg_0123456789876543210 :: Sing arg_0123456789876543210)) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing - ((applySing ((singFun3 @ShowParenSym0) sShowParen)) - ((applySing - ((applySing ((singFun2 @(>@#@$)) (%>))) sP_0123456789876543210)) - (sFromInteger (sing :: Sing 10))))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "VEC ")))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((applySing - ((applySing ((singFun3 @ShowsPrecSym0) sShowsPrec)) - (sFromInteger (sing :: Sing 11)))) - sArg_0123456789876543210))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((singFun1 @ShowSpaceSym0) sShowSpace))) - ((applySing - ((applySing ((singFun3 @ShowsPrecSym0) sShowsPrec)) - (sFromInteger (sing :: Sing 11)))) - sArg_0123456789876543210)))))) - sA_0123456789876543210 - instance SShow AChar where - sShowsPrec :: - forall (t1 :: GHC.Types.Nat) (t2 :: AChar) (t3 :: Symbol). - Sing t1 - -> Sing t2 - -> Sing t3 - -> Sing (Apply (Apply (Apply (ShowsPrecSym0 :: TyFun GHC.Types.Nat ((~>) AChar ((~>) Symbol Symbol)) - -> Type) t1) t2) t3) - sShowsPrec - _ - SCA - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "CA"))) - sA_0123456789876543210 - sShowsPrec - _ - SCB - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "CB"))) - sA_0123456789876543210 - sShowsPrec - _ - SCC - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "CC"))) - sA_0123456789876543210 - sShowsPrec - _ - SCD - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "CD"))) - sA_0123456789876543210 - sShowsPrec - _ - SCE - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "CE"))) - sA_0123456789876543210 - sShowsPrec - _ - SCF - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "CF"))) - sA_0123456789876543210 - sShowsPrec - _ - SCG - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "CG"))) - sA_0123456789876543210 - sShowsPrec - _ - SCH - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "CH"))) - sA_0123456789876543210 - sShowsPrec - _ - SCI - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "CI"))) - sA_0123456789876543210 - sShowsPrec - _ - SCJ - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "CJ"))) - sA_0123456789876543210 - sShowsPrec - _ - SCK - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "CK"))) - sA_0123456789876543210 - sShowsPrec - _ - SCL - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "CL"))) - sA_0123456789876543210 - sShowsPrec - _ - SCM - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "CM"))) - sA_0123456789876543210 - sShowsPrec - _ - SCN - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "CN"))) - sA_0123456789876543210 - sShowsPrec - _ - SCO - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "CO"))) - sA_0123456789876543210 - sShowsPrec - _ - SCP - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "CP"))) - sA_0123456789876543210 - sShowsPrec - _ - SCQ - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "CQ"))) - sA_0123456789876543210 - sShowsPrec - _ - SCR - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "CR"))) - sA_0123456789876543210 - sShowsPrec - _ - SCS - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "CS"))) - sA_0123456789876543210 - sShowsPrec - _ - SCT - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "CT"))) - sA_0123456789876543210 - sShowsPrec - _ - SCU - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "CU"))) - sA_0123456789876543210 - sShowsPrec - _ - SCV - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "CV"))) - sA_0123456789876543210 - sShowsPrec - _ - SCW - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "CW"))) - sA_0123456789876543210 - sShowsPrec - _ - SCX - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "CX"))) - sA_0123456789876543210 - sShowsPrec - _ - SCY - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "CY"))) - sA_0123456789876543210 - sShowsPrec - _ - SCZ - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "CZ"))) - sA_0123456789876543210 - instance (SEq U, SEq Nat) => SEq 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 U, SDecide Nat) => SDecide U where - (%~) SBOOL SBOOL = Proved Refl - (%~) SBOOL SSTRING = Disproved (\ x -> case x of) - (%~) SBOOL SNAT = Disproved (\ x -> case x of) - (%~) SBOOL (SVEC _ _) = Disproved (\ x -> case x of) - (%~) SSTRING SBOOL = Disproved (\ x -> case x of) - (%~) SSTRING SSTRING = Proved Refl - (%~) SSTRING SNAT = Disproved (\ x -> case x of) - (%~) SSTRING (SVEC _ _) = Disproved (\ x -> case x of) - (%~) SNAT SBOOL = Disproved (\ x -> case x of) - (%~) SNAT SSTRING = Disproved (\ x -> case x of) - (%~) SNAT SNAT = Proved Refl - (%~) SNAT (SVEC _ _) = Disproved (\ x -> case x of) - (%~) (SVEC _ _) SBOOL = Disproved (\ x -> case x of) - (%~) (SVEC _ _) SSTRING = Disproved (\ x -> case x of) - (%~) (SVEC _ _) SNAT = Disproved (\ x -> case x of) - (%~) (SVEC a a) (SVEC b b) - = case ((,) (((%~) a) b)) (((%~) a) b) of - (,) (Proved Refl) (Proved Refl) -> Proved Refl - (,) (Disproved contra) _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - (,) _ (Disproved contra) - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - instance (SDecide U, SDecide Nat) => - Data.Type.Equality.TestEquality (SU :: U -> Type) where - Data.Type.Equality.testEquality - = Data.Singletons.Decide.decideEquality - instance (SDecide U, SDecide Nat) => - Data.Type.Coercion.TestCoercion (SU :: U -> Type) where - Data.Type.Coercion.testCoercion - = Data.Singletons.Decide.decideCoercion - instance SEq 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 AChar where - (%~) SCA SCA = Proved Refl - (%~) SCA SCB = Disproved (\ x -> case x of) - (%~) SCA SCC = Disproved (\ x -> case x of) - (%~) SCA SCD = Disproved (\ x -> case x of) - (%~) SCA SCE = Disproved (\ x -> case x of) - (%~) SCA SCF = Disproved (\ x -> case x of) - (%~) SCA SCG = Disproved (\ x -> case x of) - (%~) SCA SCH = Disproved (\ x -> case x of) - (%~) SCA SCI = Disproved (\ x -> case x of) - (%~) SCA SCJ = Disproved (\ x -> case x of) - (%~) SCA SCK = Disproved (\ x -> case x of) - (%~) SCA SCL = Disproved (\ x -> case x of) - (%~) SCA SCM = Disproved (\ x -> case x of) - (%~) SCA SCN = Disproved (\ x -> case x of) - (%~) SCA SCO = Disproved (\ x -> case x of) - (%~) SCA SCP = Disproved (\ x -> case x of) - (%~) SCA SCQ = Disproved (\ x -> case x of) - (%~) SCA SCR = Disproved (\ x -> case x of) - (%~) SCA SCS = Disproved (\ x -> case x of) - (%~) SCA SCT = Disproved (\ x -> case x of) - (%~) SCA SCU = Disproved (\ x -> case x of) - (%~) SCA SCV = Disproved (\ x -> case x of) - (%~) SCA SCW = Disproved (\ x -> case x of) - (%~) SCA SCX = Disproved (\ x -> case x of) - (%~) SCA SCY = Disproved (\ x -> case x of) - (%~) SCA SCZ = Disproved (\ x -> case x of) - (%~) SCB SCA = Disproved (\ x -> case x of) - (%~) SCB SCB = Proved Refl - (%~) SCB SCC = Disproved (\ x -> case x of) - (%~) SCB SCD = Disproved (\ x -> case x of) - (%~) SCB SCE = Disproved (\ x -> case x of) - (%~) SCB SCF = Disproved (\ x -> case x of) - (%~) SCB SCG = Disproved (\ x -> case x of) - (%~) SCB SCH = Disproved (\ x -> case x of) - (%~) SCB SCI = Disproved (\ x -> case x of) - (%~) SCB SCJ = Disproved (\ x -> case x of) - (%~) SCB SCK = Disproved (\ x -> case x of) - (%~) SCB SCL = Disproved (\ x -> case x of) - (%~) SCB SCM = Disproved (\ x -> case x of) - (%~) SCB SCN = Disproved (\ x -> case x of) - (%~) SCB SCO = Disproved (\ x -> case x of) - (%~) SCB SCP = Disproved (\ x -> case x of) - (%~) SCB SCQ = Disproved (\ x -> case x of) - (%~) SCB SCR = Disproved (\ x -> case x of) - (%~) SCB SCS = Disproved (\ x -> case x of) - (%~) SCB SCT = Disproved (\ x -> case x of) - (%~) SCB SCU = Disproved (\ x -> case x of) - (%~) SCB SCV = Disproved (\ x -> case x of) - (%~) SCB SCW = Disproved (\ x -> case x of) - (%~) SCB SCX = Disproved (\ x -> case x of) - (%~) SCB SCY = Disproved (\ x -> case x of) - (%~) SCB SCZ = Disproved (\ x -> case x of) - (%~) SCC SCA = Disproved (\ x -> case x of) - (%~) SCC SCB = Disproved (\ x -> case x of) - (%~) SCC SCC = Proved Refl - (%~) SCC SCD = Disproved (\ x -> case x of) - (%~) SCC SCE = Disproved (\ x -> case x of) - (%~) SCC SCF = Disproved (\ x -> case x of) - (%~) SCC SCG = Disproved (\ x -> case x of) - (%~) SCC SCH = Disproved (\ x -> case x of) - (%~) SCC SCI = Disproved (\ x -> case x of) - (%~) SCC SCJ = Disproved (\ x -> case x of) - (%~) SCC SCK = Disproved (\ x -> case x of) - (%~) SCC SCL = Disproved (\ x -> case x of) - (%~) SCC SCM = Disproved (\ x -> case x of) - (%~) SCC SCN = Disproved (\ x -> case x of) - (%~) SCC SCO = Disproved (\ x -> case x of) - (%~) SCC SCP = Disproved (\ x -> case x of) - (%~) SCC SCQ = Disproved (\ x -> case x of) - (%~) SCC SCR = Disproved (\ x -> case x of) - (%~) SCC SCS = Disproved (\ x -> case x of) - (%~) SCC SCT = Disproved (\ x -> case x of) - (%~) SCC SCU = Disproved (\ x -> case x of) - (%~) SCC SCV = Disproved (\ x -> case x of) - (%~) SCC SCW = Disproved (\ x -> case x of) - (%~) SCC SCX = Disproved (\ x -> case x of) - (%~) SCC SCY = Disproved (\ x -> case x of) - (%~) SCC SCZ = Disproved (\ x -> case x of) - (%~) SCD SCA = Disproved (\ x -> case x of) - (%~) SCD SCB = Disproved (\ x -> case x of) - (%~) SCD SCC = Disproved (\ x -> case x of) - (%~) SCD SCD = Proved Refl - (%~) SCD SCE = Disproved (\ x -> case x of) - (%~) SCD SCF = Disproved (\ x -> case x of) - (%~) SCD SCG = Disproved (\ x -> case x of) - (%~) SCD SCH = Disproved (\ x -> case x of) - (%~) SCD SCI = Disproved (\ x -> case x of) - (%~) SCD SCJ = Disproved (\ x -> case x of) - (%~) SCD SCK = Disproved (\ x -> case x of) - (%~) SCD SCL = Disproved (\ x -> case x of) - (%~) SCD SCM = Disproved (\ x -> case x of) - (%~) SCD SCN = Disproved (\ x -> case x of) - (%~) SCD SCO = Disproved (\ x -> case x of) - (%~) SCD SCP = Disproved (\ x -> case x of) - (%~) SCD SCQ = Disproved (\ x -> case x of) - (%~) SCD SCR = Disproved (\ x -> case x of) - (%~) SCD SCS = Disproved (\ x -> case x of) - (%~) SCD SCT = Disproved (\ x -> case x of) - (%~) SCD SCU = Disproved (\ x -> case x of) - (%~) SCD SCV = Disproved (\ x -> case x of) - (%~) SCD SCW = Disproved (\ x -> case x of) - (%~) SCD SCX = Disproved (\ x -> case x of) - (%~) SCD SCY = Disproved (\ x -> case x of) - (%~) SCD SCZ = Disproved (\ x -> case x of) - (%~) SCE SCA = Disproved (\ x -> case x of) - (%~) SCE SCB = Disproved (\ x -> case x of) - (%~) SCE SCC = Disproved (\ x -> case x of) - (%~) SCE SCD = Disproved (\ x -> case x of) - (%~) SCE SCE = Proved Refl - (%~) SCE SCF = Disproved (\ x -> case x of) - (%~) SCE SCG = Disproved (\ x -> case x of) - (%~) SCE SCH = Disproved (\ x -> case x of) - (%~) SCE SCI = Disproved (\ x -> case x of) - (%~) SCE SCJ = Disproved (\ x -> case x of) - (%~) SCE SCK = Disproved (\ x -> case x of) - (%~) SCE SCL = Disproved (\ x -> case x of) - (%~) SCE SCM = Disproved (\ x -> case x of) - (%~) SCE SCN = Disproved (\ x -> case x of) - (%~) SCE SCO = Disproved (\ x -> case x of) - (%~) SCE SCP = Disproved (\ x -> case x of) - (%~) SCE SCQ = Disproved (\ x -> case x of) - (%~) SCE SCR = Disproved (\ x -> case x of) - (%~) SCE SCS = Disproved (\ x -> case x of) - (%~) SCE SCT = Disproved (\ x -> case x of) - (%~) SCE SCU = Disproved (\ x -> case x of) - (%~) SCE SCV = Disproved (\ x -> case x of) - (%~) SCE SCW = Disproved (\ x -> case x of) - (%~) SCE SCX = Disproved (\ x -> case x of) - (%~) SCE SCY = Disproved (\ x -> case x of) - (%~) SCE SCZ = Disproved (\ x -> case x of) - (%~) SCF SCA = Disproved (\ x -> case x of) - (%~) SCF SCB = Disproved (\ x -> case x of) - (%~) SCF SCC = Disproved (\ x -> case x of) - (%~) SCF SCD = Disproved (\ x -> case x of) - (%~) SCF SCE = Disproved (\ x -> case x of) - (%~) SCF SCF = Proved Refl - (%~) SCF SCG = Disproved (\ x -> case x of) - (%~) SCF SCH = Disproved (\ x -> case x of) - (%~) SCF SCI = Disproved (\ x -> case x of) - (%~) SCF SCJ = Disproved (\ x -> case x of) - (%~) SCF SCK = Disproved (\ x -> case x of) - (%~) SCF SCL = Disproved (\ x -> case x of) - (%~) SCF SCM = Disproved (\ x -> case x of) - (%~) SCF SCN = Disproved (\ x -> case x of) - (%~) SCF SCO = Disproved (\ x -> case x of) - (%~) SCF SCP = Disproved (\ x -> case x of) - (%~) SCF SCQ = Disproved (\ x -> case x of) - (%~) SCF SCR = Disproved (\ x -> case x of) - (%~) SCF SCS = Disproved (\ x -> case x of) - (%~) SCF SCT = Disproved (\ x -> case x of) - (%~) SCF SCU = Disproved (\ x -> case x of) - (%~) SCF SCV = Disproved (\ x -> case x of) - (%~) SCF SCW = Disproved (\ x -> case x of) - (%~) SCF SCX = Disproved (\ x -> case x of) - (%~) SCF SCY = Disproved (\ x -> case x of) - (%~) SCF SCZ = Disproved (\ x -> case x of) - (%~) SCG SCA = Disproved (\ x -> case x of) - (%~) SCG SCB = Disproved (\ x -> case x of) - (%~) SCG SCC = Disproved (\ x -> case x of) - (%~) SCG SCD = Disproved (\ x -> case x of) - (%~) SCG SCE = Disproved (\ x -> case x of) - (%~) SCG SCF = Disproved (\ x -> case x of) - (%~) SCG SCG = Proved Refl - (%~) SCG SCH = Disproved (\ x -> case x of) - (%~) SCG SCI = Disproved (\ x -> case x of) - (%~) SCG SCJ = Disproved (\ x -> case x of) - (%~) SCG SCK = Disproved (\ x -> case x of) - (%~) SCG SCL = Disproved (\ x -> case x of) - (%~) SCG SCM = Disproved (\ x -> case x of) - (%~) SCG SCN = Disproved (\ x -> case x of) - (%~) SCG SCO = Disproved (\ x -> case x of) - (%~) SCG SCP = Disproved (\ x -> case x of) - (%~) SCG SCQ = Disproved (\ x -> case x of) - (%~) SCG SCR = Disproved (\ x -> case x of) - (%~) SCG SCS = Disproved (\ x -> case x of) - (%~) SCG SCT = Disproved (\ x -> case x of) - (%~) SCG SCU = Disproved (\ x -> case x of) - (%~) SCG SCV = Disproved (\ x -> case x of) - (%~) SCG SCW = Disproved (\ x -> case x of) - (%~) SCG SCX = Disproved (\ x -> case x of) - (%~) SCG SCY = Disproved (\ x -> case x of) - (%~) SCG SCZ = Disproved (\ x -> case x of) - (%~) SCH SCA = Disproved (\ x -> case x of) - (%~) SCH SCB = Disproved (\ x -> case x of) - (%~) SCH SCC = Disproved (\ x -> case x of) - (%~) SCH SCD = Disproved (\ x -> case x of) - (%~) SCH SCE = Disproved (\ x -> case x of) - (%~) SCH SCF = Disproved (\ x -> case x of) - (%~) SCH SCG = Disproved (\ x -> case x of) - (%~) SCH SCH = Proved Refl - (%~) SCH SCI = Disproved (\ x -> case x of) - (%~) SCH SCJ = Disproved (\ x -> case x of) - (%~) SCH SCK = Disproved (\ x -> case x of) - (%~) SCH SCL = Disproved (\ x -> case x of) - (%~) SCH SCM = Disproved (\ x -> case x of) - (%~) SCH SCN = Disproved (\ x -> case x of) - (%~) SCH SCO = Disproved (\ x -> case x of) - (%~) SCH SCP = Disproved (\ x -> case x of) - (%~) SCH SCQ = Disproved (\ x -> case x of) - (%~) SCH SCR = Disproved (\ x -> case x of) - (%~) SCH SCS = Disproved (\ x -> case x of) - (%~) SCH SCT = Disproved (\ x -> case x of) - (%~) SCH SCU = Disproved (\ x -> case x of) - (%~) SCH SCV = Disproved (\ x -> case x of) - (%~) SCH SCW = Disproved (\ x -> case x of) - (%~) SCH SCX = Disproved (\ x -> case x of) - (%~) SCH SCY = Disproved (\ x -> case x of) - (%~) SCH SCZ = Disproved (\ x -> case x of) - (%~) SCI SCA = Disproved (\ x -> case x of) - (%~) SCI SCB = Disproved (\ x -> case x of) - (%~) SCI SCC = Disproved (\ x -> case x of) - (%~) SCI SCD = Disproved (\ x -> case x of) - (%~) SCI SCE = Disproved (\ x -> case x of) - (%~) SCI SCF = Disproved (\ x -> case x of) - (%~) SCI SCG = Disproved (\ x -> case x of) - (%~) SCI SCH = Disproved (\ x -> case x of) - (%~) SCI SCI = Proved Refl - (%~) SCI SCJ = Disproved (\ x -> case x of) - (%~) SCI SCK = Disproved (\ x -> case x of) - (%~) SCI SCL = Disproved (\ x -> case x of) - (%~) SCI SCM = Disproved (\ x -> case x of) - (%~) SCI SCN = Disproved (\ x -> case x of) - (%~) SCI SCO = Disproved (\ x -> case x of) - (%~) SCI SCP = Disproved (\ x -> case x of) - (%~) SCI SCQ = Disproved (\ x -> case x of) - (%~) SCI SCR = Disproved (\ x -> case x of) - (%~) SCI SCS = Disproved (\ x -> case x of) - (%~) SCI SCT = Disproved (\ x -> case x of) - (%~) SCI SCU = Disproved (\ x -> case x of) - (%~) SCI SCV = Disproved (\ x -> case x of) - (%~) SCI SCW = Disproved (\ x -> case x of) - (%~) SCI SCX = Disproved (\ x -> case x of) - (%~) SCI SCY = Disproved (\ x -> case x of) - (%~) SCI SCZ = Disproved (\ x -> case x of) - (%~) SCJ SCA = Disproved (\ x -> case x of) - (%~) SCJ SCB = Disproved (\ x -> case x of) - (%~) SCJ SCC = Disproved (\ x -> case x of) - (%~) SCJ SCD = Disproved (\ x -> case x of) - (%~) SCJ SCE = Disproved (\ x -> case x of) - (%~) SCJ SCF = Disproved (\ x -> case x of) - (%~) SCJ SCG = Disproved (\ x -> case x of) - (%~) SCJ SCH = Disproved (\ x -> case x of) - (%~) SCJ SCI = Disproved (\ x -> case x of) - (%~) SCJ SCJ = Proved Refl - (%~) SCJ SCK = Disproved (\ x -> case x of) - (%~) SCJ SCL = Disproved (\ x -> case x of) - (%~) SCJ SCM = Disproved (\ x -> case x of) - (%~) SCJ SCN = Disproved (\ x -> case x of) - (%~) SCJ SCO = Disproved (\ x -> case x of) - (%~) SCJ SCP = Disproved (\ x -> case x of) - (%~) SCJ SCQ = Disproved (\ x -> case x of) - (%~) SCJ SCR = Disproved (\ x -> case x of) - (%~) SCJ SCS = Disproved (\ x -> case x of) - (%~) SCJ SCT = Disproved (\ x -> case x of) - (%~) SCJ SCU = Disproved (\ x -> case x of) - (%~) SCJ SCV = Disproved (\ x -> case x of) - (%~) SCJ SCW = Disproved (\ x -> case x of) - (%~) SCJ SCX = Disproved (\ x -> case x of) - (%~) SCJ SCY = Disproved (\ x -> case x of) - (%~) SCJ SCZ = Disproved (\ x -> case x of) - (%~) SCK SCA = Disproved (\ x -> case x of) - (%~) SCK SCB = Disproved (\ x -> case x of) - (%~) SCK SCC = Disproved (\ x -> case x of) - (%~) SCK SCD = Disproved (\ x -> case x of) - (%~) SCK SCE = Disproved (\ x -> case x of) - (%~) SCK SCF = Disproved (\ x -> case x of) - (%~) SCK SCG = Disproved (\ x -> case x of) - (%~) SCK SCH = Disproved (\ x -> case x of) - (%~) SCK SCI = Disproved (\ x -> case x of) - (%~) SCK SCJ = Disproved (\ x -> case x of) - (%~) SCK SCK = Proved Refl - (%~) SCK SCL = Disproved (\ x -> case x of) - (%~) SCK SCM = Disproved (\ x -> case x of) - (%~) SCK SCN = Disproved (\ x -> case x of) - (%~) SCK SCO = Disproved (\ x -> case x of) - (%~) SCK SCP = Disproved (\ x -> case x of) - (%~) SCK SCQ = Disproved (\ x -> case x of) - (%~) SCK SCR = Disproved (\ x -> case x of) - (%~) SCK SCS = Disproved (\ x -> case x of) - (%~) SCK SCT = Disproved (\ x -> case x of) - (%~) SCK SCU = Disproved (\ x -> case x of) - (%~) SCK SCV = Disproved (\ x -> case x of) - (%~) SCK SCW = Disproved (\ x -> case x of) - (%~) SCK SCX = Disproved (\ x -> case x of) - (%~) SCK SCY = Disproved (\ x -> case x of) - (%~) SCK SCZ = Disproved (\ x -> case x of) - (%~) SCL SCA = Disproved (\ x -> case x of) - (%~) SCL SCB = Disproved (\ x -> case x of) - (%~) SCL SCC = Disproved (\ x -> case x of) - (%~) SCL SCD = Disproved (\ x -> case x of) - (%~) SCL SCE = Disproved (\ x -> case x of) - (%~) SCL SCF = Disproved (\ x -> case x of) - (%~) SCL SCG = Disproved (\ x -> case x of) - (%~) SCL SCH = Disproved (\ x -> case x of) - (%~) SCL SCI = Disproved (\ x -> case x of) - (%~) SCL SCJ = Disproved (\ x -> case x of) - (%~) SCL SCK = Disproved (\ x -> case x of) - (%~) SCL SCL = Proved Refl - (%~) SCL SCM = Disproved (\ x -> case x of) - (%~) SCL SCN = Disproved (\ x -> case x of) - (%~) SCL SCO = Disproved (\ x -> case x of) - (%~) SCL SCP = Disproved (\ x -> case x of) - (%~) SCL SCQ = Disproved (\ x -> case x of) - (%~) SCL SCR = Disproved (\ x -> case x of) - (%~) SCL SCS = Disproved (\ x -> case x of) - (%~) SCL SCT = Disproved (\ x -> case x of) - (%~) SCL SCU = Disproved (\ x -> case x of) - (%~) SCL SCV = Disproved (\ x -> case x of) - (%~) SCL SCW = Disproved (\ x -> case x of) - (%~) SCL SCX = Disproved (\ x -> case x of) - (%~) SCL SCY = Disproved (\ x -> case x of) - (%~) SCL SCZ = Disproved (\ x -> case x of) - (%~) SCM SCA = Disproved (\ x -> case x of) - (%~) SCM SCB = Disproved (\ x -> case x of) - (%~) SCM SCC = Disproved (\ x -> case x of) - (%~) SCM SCD = Disproved (\ x -> case x of) - (%~) SCM SCE = Disproved (\ x -> case x of) - (%~) SCM SCF = Disproved (\ x -> case x of) - (%~) SCM SCG = Disproved (\ x -> case x of) - (%~) SCM SCH = Disproved (\ x -> case x of) - (%~) SCM SCI = Disproved (\ x -> case x of) - (%~) SCM SCJ = Disproved (\ x -> case x of) - (%~) SCM SCK = Disproved (\ x -> case x of) - (%~) SCM SCL = Disproved (\ x -> case x of) - (%~) SCM SCM = Proved Refl - (%~) SCM SCN = Disproved (\ x -> case x of) - (%~) SCM SCO = Disproved (\ x -> case x of) - (%~) SCM SCP = Disproved (\ x -> case x of) - (%~) SCM SCQ = Disproved (\ x -> case x of) - (%~) SCM SCR = Disproved (\ x -> case x of) - (%~) SCM SCS = Disproved (\ x -> case x of) - (%~) SCM SCT = Disproved (\ x -> case x of) - (%~) SCM SCU = Disproved (\ x -> case x of) - (%~) SCM SCV = Disproved (\ x -> case x of) - (%~) SCM SCW = Disproved (\ x -> case x of) - (%~) SCM SCX = Disproved (\ x -> case x of) - (%~) SCM SCY = Disproved (\ x -> case x of) - (%~) SCM SCZ = Disproved (\ x -> case x of) - (%~) SCN SCA = Disproved (\ x -> case x of) - (%~) SCN SCB = Disproved (\ x -> case x of) - (%~) SCN SCC = Disproved (\ x -> case x of) - (%~) SCN SCD = Disproved (\ x -> case x of) - (%~) SCN SCE = Disproved (\ x -> case x of) - (%~) SCN SCF = Disproved (\ x -> case x of) - (%~) SCN SCG = Disproved (\ x -> case x of) - (%~) SCN SCH = Disproved (\ x -> case x of) - (%~) SCN SCI = Disproved (\ x -> case x of) - (%~) SCN SCJ = Disproved (\ x -> case x of) - (%~) SCN SCK = Disproved (\ x -> case x of) - (%~) SCN SCL = Disproved (\ x -> case x of) - (%~) SCN SCM = Disproved (\ x -> case x of) - (%~) SCN SCN = Proved Refl - (%~) SCN SCO = Disproved (\ x -> case x of) - (%~) SCN SCP = Disproved (\ x -> case x of) - (%~) SCN SCQ = Disproved (\ x -> case x of) - (%~) SCN SCR = Disproved (\ x -> case x of) - (%~) SCN SCS = Disproved (\ x -> case x of) - (%~) SCN SCT = Disproved (\ x -> case x of) - (%~) SCN SCU = Disproved (\ x -> case x of) - (%~) SCN SCV = Disproved (\ x -> case x of) - (%~) SCN SCW = Disproved (\ x -> case x of) - (%~) SCN SCX = Disproved (\ x -> case x of) - (%~) SCN SCY = Disproved (\ x -> case x of) - (%~) SCN SCZ = Disproved (\ x -> case x of) - (%~) SCO SCA = Disproved (\ x -> case x of) - (%~) SCO SCB = Disproved (\ x -> case x of) - (%~) SCO SCC = Disproved (\ x -> case x of) - (%~) SCO SCD = Disproved (\ x -> case x of) - (%~) SCO SCE = Disproved (\ x -> case x of) - (%~) SCO SCF = Disproved (\ x -> case x of) - (%~) SCO SCG = Disproved (\ x -> case x of) - (%~) SCO SCH = Disproved (\ x -> case x of) - (%~) SCO SCI = Disproved (\ x -> case x of) - (%~) SCO SCJ = Disproved (\ x -> case x of) - (%~) SCO SCK = Disproved (\ x -> case x of) - (%~) SCO SCL = Disproved (\ x -> case x of) - (%~) SCO SCM = Disproved (\ x -> case x of) - (%~) SCO SCN = Disproved (\ x -> case x of) - (%~) SCO SCO = Proved Refl - (%~) SCO SCP = Disproved (\ x -> case x of) - (%~) SCO SCQ = Disproved (\ x -> case x of) - (%~) SCO SCR = Disproved (\ x -> case x of) - (%~) SCO SCS = Disproved (\ x -> case x of) - (%~) SCO SCT = Disproved (\ x -> case x of) - (%~) SCO SCU = Disproved (\ x -> case x of) - (%~) SCO SCV = Disproved (\ x -> case x of) - (%~) SCO SCW = Disproved (\ x -> case x of) - (%~) SCO SCX = Disproved (\ x -> case x of) - (%~) SCO SCY = Disproved (\ x -> case x of) - (%~) SCO SCZ = Disproved (\ x -> case x of) - (%~) SCP SCA = Disproved (\ x -> case x of) - (%~) SCP SCB = Disproved (\ x -> case x of) - (%~) SCP SCC = Disproved (\ x -> case x of) - (%~) SCP SCD = Disproved (\ x -> case x of) - (%~) SCP SCE = Disproved (\ x -> case x of) - (%~) SCP SCF = Disproved (\ x -> case x of) - (%~) SCP SCG = Disproved (\ x -> case x of) - (%~) SCP SCH = Disproved (\ x -> case x of) - (%~) SCP SCI = Disproved (\ x -> case x of) - (%~) SCP SCJ = Disproved (\ x -> case x of) - (%~) SCP SCK = Disproved (\ x -> case x of) - (%~) SCP SCL = Disproved (\ x -> case x of) - (%~) SCP SCM = Disproved (\ x -> case x of) - (%~) SCP SCN = Disproved (\ x -> case x of) - (%~) SCP SCO = Disproved (\ x -> case x of) - (%~) SCP SCP = Proved Refl - (%~) SCP SCQ = Disproved (\ x -> case x of) - (%~) SCP SCR = Disproved (\ x -> case x of) - (%~) SCP SCS = Disproved (\ x -> case x of) - (%~) SCP SCT = Disproved (\ x -> case x of) - (%~) SCP SCU = Disproved (\ x -> case x of) - (%~) SCP SCV = Disproved (\ x -> case x of) - (%~) SCP SCW = Disproved (\ x -> case x of) - (%~) SCP SCX = Disproved (\ x -> case x of) - (%~) SCP SCY = Disproved (\ x -> case x of) - (%~) SCP SCZ = Disproved (\ x -> case x of) - (%~) SCQ SCA = Disproved (\ x -> case x of) - (%~) SCQ SCB = Disproved (\ x -> case x of) - (%~) SCQ SCC = Disproved (\ x -> case x of) - (%~) SCQ SCD = Disproved (\ x -> case x of) - (%~) SCQ SCE = Disproved (\ x -> case x of) - (%~) SCQ SCF = Disproved (\ x -> case x of) - (%~) SCQ SCG = Disproved (\ x -> case x of) - (%~) SCQ SCH = Disproved (\ x -> case x of) - (%~) SCQ SCI = Disproved (\ x -> case x of) - (%~) SCQ SCJ = Disproved (\ x -> case x of) - (%~) SCQ SCK = Disproved (\ x -> case x of) - (%~) SCQ SCL = Disproved (\ x -> case x of) - (%~) SCQ SCM = Disproved (\ x -> case x of) - (%~) SCQ SCN = Disproved (\ x -> case x of) - (%~) SCQ SCO = Disproved (\ x -> case x of) - (%~) SCQ SCP = Disproved (\ x -> case x of) - (%~) SCQ SCQ = Proved Refl - (%~) SCQ SCR = Disproved (\ x -> case x of) - (%~) SCQ SCS = Disproved (\ x -> case x of) - (%~) SCQ SCT = Disproved (\ x -> case x of) - (%~) SCQ SCU = Disproved (\ x -> case x of) - (%~) SCQ SCV = Disproved (\ x -> case x of) - (%~) SCQ SCW = Disproved (\ x -> case x of) - (%~) SCQ SCX = Disproved (\ x -> case x of) - (%~) SCQ SCY = Disproved (\ x -> case x of) - (%~) SCQ SCZ = Disproved (\ x -> case x of) - (%~) SCR SCA = Disproved (\ x -> case x of) - (%~) SCR SCB = Disproved (\ x -> case x of) - (%~) SCR SCC = Disproved (\ x -> case x of) - (%~) SCR SCD = Disproved (\ x -> case x of) - (%~) SCR SCE = Disproved (\ x -> case x of) - (%~) SCR SCF = Disproved (\ x -> case x of) - (%~) SCR SCG = Disproved (\ x -> case x of) - (%~) SCR SCH = Disproved (\ x -> case x of) - (%~) SCR SCI = Disproved (\ x -> case x of) - (%~) SCR SCJ = Disproved (\ x -> case x of) - (%~) SCR SCK = Disproved (\ x -> case x of) - (%~) SCR SCL = Disproved (\ x -> case x of) - (%~) SCR SCM = Disproved (\ x -> case x of) - (%~) SCR SCN = Disproved (\ x -> case x of) - (%~) SCR SCO = Disproved (\ x -> case x of) - (%~) SCR SCP = Disproved (\ x -> case x of) - (%~) SCR SCQ = Disproved (\ x -> case x of) - (%~) SCR SCR = Proved Refl - (%~) SCR SCS = Disproved (\ x -> case x of) - (%~) SCR SCT = Disproved (\ x -> case x of) - (%~) SCR SCU = Disproved (\ x -> case x of) - (%~) SCR SCV = Disproved (\ x -> case x of) - (%~) SCR SCW = Disproved (\ x -> case x of) - (%~) SCR SCX = Disproved (\ x -> case x of) - (%~) SCR SCY = Disproved (\ x -> case x of) - (%~) SCR SCZ = Disproved (\ x -> case x of) - (%~) SCS SCA = Disproved (\ x -> case x of) - (%~) SCS SCB = Disproved (\ x -> case x of) - (%~) SCS SCC = Disproved (\ x -> case x of) - (%~) SCS SCD = Disproved (\ x -> case x of) - (%~) SCS SCE = Disproved (\ x -> case x of) - (%~) SCS SCF = Disproved (\ x -> case x of) - (%~) SCS SCG = Disproved (\ x -> case x of) - (%~) SCS SCH = Disproved (\ x -> case x of) - (%~) SCS SCI = Disproved (\ x -> case x of) - (%~) SCS SCJ = Disproved (\ x -> case x of) - (%~) SCS SCK = Disproved (\ x -> case x of) - (%~) SCS SCL = Disproved (\ x -> case x of) - (%~) SCS SCM = Disproved (\ x -> case x of) - (%~) SCS SCN = Disproved (\ x -> case x of) - (%~) SCS SCO = Disproved (\ x -> case x of) - (%~) SCS SCP = Disproved (\ x -> case x of) - (%~) SCS SCQ = Disproved (\ x -> case x of) - (%~) SCS SCR = Disproved (\ x -> case x of) - (%~) SCS SCS = Proved Refl - (%~) SCS SCT = Disproved (\ x -> case x of) - (%~) SCS SCU = Disproved (\ x -> case x of) - (%~) SCS SCV = Disproved (\ x -> case x of) - (%~) SCS SCW = Disproved (\ x -> case x of) - (%~) SCS SCX = Disproved (\ x -> case x of) - (%~) SCS SCY = Disproved (\ x -> case x of) - (%~) SCS SCZ = Disproved (\ x -> case x of) - (%~) SCT SCA = Disproved (\ x -> case x of) - (%~) SCT SCB = Disproved (\ x -> case x of) - (%~) SCT SCC = Disproved (\ x -> case x of) - (%~) SCT SCD = Disproved (\ x -> case x of) - (%~) SCT SCE = Disproved (\ x -> case x of) - (%~) SCT SCF = Disproved (\ x -> case x of) - (%~) SCT SCG = Disproved (\ x -> case x of) - (%~) SCT SCH = Disproved (\ x -> case x of) - (%~) SCT SCI = Disproved (\ x -> case x of) - (%~) SCT SCJ = Disproved (\ x -> case x of) - (%~) SCT SCK = Disproved (\ x -> case x of) - (%~) SCT SCL = Disproved (\ x -> case x of) - (%~) SCT SCM = Disproved (\ x -> case x of) - (%~) SCT SCN = Disproved (\ x -> case x of) - (%~) SCT SCO = Disproved (\ x -> case x of) - (%~) SCT SCP = Disproved (\ x -> case x of) - (%~) SCT SCQ = Disproved (\ x -> case x of) - (%~) SCT SCR = Disproved (\ x -> case x of) - (%~) SCT SCS = Disproved (\ x -> case x of) - (%~) SCT SCT = Proved Refl - (%~) SCT SCU = Disproved (\ x -> case x of) - (%~) SCT SCV = Disproved (\ x -> case x of) - (%~) SCT SCW = Disproved (\ x -> case x of) - (%~) SCT SCX = Disproved (\ x -> case x of) - (%~) SCT SCY = Disproved (\ x -> case x of) - (%~) SCT SCZ = Disproved (\ x -> case x of) - (%~) SCU SCA = Disproved (\ x -> case x of) - (%~) SCU SCB = Disproved (\ x -> case x of) - (%~) SCU SCC = Disproved (\ x -> case x of) - (%~) SCU SCD = Disproved (\ x -> case x of) - (%~) SCU SCE = Disproved (\ x -> case x of) - (%~) SCU SCF = Disproved (\ x -> case x of) - (%~) SCU SCG = Disproved (\ x -> case x of) - (%~) SCU SCH = Disproved (\ x -> case x of) - (%~) SCU SCI = Disproved (\ x -> case x of) - (%~) SCU SCJ = Disproved (\ x -> case x of) - (%~) SCU SCK = Disproved (\ x -> case x of) - (%~) SCU SCL = Disproved (\ x -> case x of) - (%~) SCU SCM = Disproved (\ x -> case x of) - (%~) SCU SCN = Disproved (\ x -> case x of) - (%~) SCU SCO = Disproved (\ x -> case x of) - (%~) SCU SCP = Disproved (\ x -> case x of) - (%~) SCU SCQ = Disproved (\ x -> case x of) - (%~) SCU SCR = Disproved (\ x -> case x of) - (%~) SCU SCS = Disproved (\ x -> case x of) - (%~) SCU SCT = Disproved (\ x -> case x of) - (%~) SCU SCU = Proved Refl - (%~) SCU SCV = Disproved (\ x -> case x of) - (%~) SCU SCW = Disproved (\ x -> case x of) - (%~) SCU SCX = Disproved (\ x -> case x of) - (%~) SCU SCY = Disproved (\ x -> case x of) - (%~) SCU SCZ = Disproved (\ x -> case x of) - (%~) SCV SCA = Disproved (\ x -> case x of) - (%~) SCV SCB = Disproved (\ x -> case x of) - (%~) SCV SCC = Disproved (\ x -> case x of) - (%~) SCV SCD = Disproved (\ x -> case x of) - (%~) SCV SCE = Disproved (\ x -> case x of) - (%~) SCV SCF = Disproved (\ x -> case x of) - (%~) SCV SCG = Disproved (\ x -> case x of) - (%~) SCV SCH = Disproved (\ x -> case x of) - (%~) SCV SCI = Disproved (\ x -> case x of) - (%~) SCV SCJ = Disproved (\ x -> case x of) - (%~) SCV SCK = Disproved (\ x -> case x of) - (%~) SCV SCL = Disproved (\ x -> case x of) - (%~) SCV SCM = Disproved (\ x -> case x of) - (%~) SCV SCN = Disproved (\ x -> case x of) - (%~) SCV SCO = Disproved (\ x -> case x of) - (%~) SCV SCP = Disproved (\ x -> case x of) - (%~) SCV SCQ = Disproved (\ x -> case x of) - (%~) SCV SCR = Disproved (\ x -> case x of) - (%~) SCV SCS = Disproved (\ x -> case x of) - (%~) SCV SCT = Disproved (\ x -> case x of) - (%~) SCV SCU = Disproved (\ x -> case x of) - (%~) SCV SCV = Proved Refl - (%~) SCV SCW = Disproved (\ x -> case x of) - (%~) SCV SCX = Disproved (\ x -> case x of) - (%~) SCV SCY = Disproved (\ x -> case x of) - (%~) SCV SCZ = Disproved (\ x -> case x of) - (%~) SCW SCA = Disproved (\ x -> case x of) - (%~) SCW SCB = Disproved (\ x -> case x of) - (%~) SCW SCC = Disproved (\ x -> case x of) - (%~) SCW SCD = Disproved (\ x -> case x of) - (%~) SCW SCE = Disproved (\ x -> case x of) - (%~) SCW SCF = Disproved (\ x -> case x of) - (%~) SCW SCG = Disproved (\ x -> case x of) - (%~) SCW SCH = Disproved (\ x -> case x of) - (%~) SCW SCI = Disproved (\ x -> case x of) - (%~) SCW SCJ = Disproved (\ x -> case x of) - (%~) SCW SCK = Disproved (\ x -> case x of) - (%~) SCW SCL = Disproved (\ x -> case x of) - (%~) SCW SCM = Disproved (\ x -> case x of) - (%~) SCW SCN = Disproved (\ x -> case x of) - (%~) SCW SCO = Disproved (\ x -> case x of) - (%~) SCW SCP = Disproved (\ x -> case x of) - (%~) SCW SCQ = Disproved (\ x -> case x of) - (%~) SCW SCR = Disproved (\ x -> case x of) - (%~) SCW SCS = Disproved (\ x -> case x of) - (%~) SCW SCT = Disproved (\ x -> case x of) - (%~) SCW SCU = Disproved (\ x -> case x of) - (%~) SCW SCV = Disproved (\ x -> case x of) - (%~) SCW SCW = Proved Refl - (%~) SCW SCX = Disproved (\ x -> case x of) - (%~) SCW SCY = Disproved (\ x -> case x of) - (%~) SCW SCZ = Disproved (\ x -> case x of) - (%~) SCX SCA = Disproved (\ x -> case x of) - (%~) SCX SCB = Disproved (\ x -> case x of) - (%~) SCX SCC = Disproved (\ x -> case x of) - (%~) SCX SCD = Disproved (\ x -> case x of) - (%~) SCX SCE = Disproved (\ x -> case x of) - (%~) SCX SCF = Disproved (\ x -> case x of) - (%~) SCX SCG = Disproved (\ x -> case x of) - (%~) SCX SCH = Disproved (\ x -> case x of) - (%~) SCX SCI = Disproved (\ x -> case x of) - (%~) SCX SCJ = Disproved (\ x -> case x of) - (%~) SCX SCK = Disproved (\ x -> case x of) - (%~) SCX SCL = Disproved (\ x -> case x of) - (%~) SCX SCM = Disproved (\ x -> case x of) - (%~) SCX SCN = Disproved (\ x -> case x of) - (%~) SCX SCO = Disproved (\ x -> case x of) - (%~) SCX SCP = Disproved (\ x -> case x of) - (%~) SCX SCQ = Disproved (\ x -> case x of) - (%~) SCX SCR = Disproved (\ x -> case x of) - (%~) SCX SCS = Disproved (\ x -> case x of) - (%~) SCX SCT = Disproved (\ x -> case x of) - (%~) SCX SCU = Disproved (\ x -> case x of) - (%~) SCX SCV = Disproved (\ x -> case x of) - (%~) SCX SCW = Disproved (\ x -> case x of) - (%~) SCX SCX = Proved Refl - (%~) SCX SCY = Disproved (\ x -> case x of) - (%~) SCX SCZ = Disproved (\ x -> case x of) - (%~) SCY SCA = Disproved (\ x -> case x of) - (%~) SCY SCB = Disproved (\ x -> case x of) - (%~) SCY SCC = Disproved (\ x -> case x of) - (%~) SCY SCD = Disproved (\ x -> case x of) - (%~) SCY SCE = Disproved (\ x -> case x of) - (%~) SCY SCF = Disproved (\ x -> case x of) - (%~) SCY SCG = Disproved (\ x -> case x of) - (%~) SCY SCH = Disproved (\ x -> case x of) - (%~) SCY SCI = Disproved (\ x -> case x of) - (%~) SCY SCJ = Disproved (\ x -> case x of) - (%~) SCY SCK = Disproved (\ x -> case x of) - (%~) SCY SCL = Disproved (\ x -> case x of) - (%~) SCY SCM = Disproved (\ x -> case x of) - (%~) SCY SCN = Disproved (\ x -> case x of) - (%~) SCY SCO = Disproved (\ x -> case x of) - (%~) SCY SCP = Disproved (\ x -> case x of) - (%~) SCY SCQ = Disproved (\ x -> case x of) - (%~) SCY SCR = Disproved (\ x -> case x of) - (%~) SCY SCS = Disproved (\ x -> case x of) - (%~) SCY SCT = Disproved (\ x -> case x of) - (%~) SCY SCU = Disproved (\ x -> case x of) - (%~) SCY SCV = Disproved (\ x -> case x of) - (%~) SCY SCW = Disproved (\ x -> case x of) - (%~) SCY SCX = Disproved (\ x -> case x of) - (%~) SCY SCY = Proved Refl - (%~) SCY SCZ = Disproved (\ x -> case x of) - (%~) SCZ SCA = Disproved (\ x -> case x of) - (%~) SCZ SCB = Disproved (\ x -> case x of) - (%~) SCZ SCC = Disproved (\ x -> case x of) - (%~) SCZ SCD = Disproved (\ x -> case x of) - (%~) SCZ SCE = Disproved (\ x -> case x of) - (%~) SCZ SCF = Disproved (\ x -> case x of) - (%~) SCZ SCG = Disproved (\ x -> case x of) - (%~) SCZ SCH = Disproved (\ x -> case x of) - (%~) SCZ SCI = Disproved (\ x -> case x of) - (%~) SCZ SCJ = Disproved (\ x -> case x of) - (%~) SCZ SCK = Disproved (\ x -> case x of) - (%~) SCZ SCL = Disproved (\ x -> case x of) - (%~) SCZ SCM = Disproved (\ x -> case x of) - (%~) SCZ SCN = Disproved (\ x -> case x of) - (%~) SCZ SCO = Disproved (\ x -> case x of) - (%~) SCZ SCP = Disproved (\ x -> case x of) - (%~) SCZ SCQ = Disproved (\ x -> case x of) - (%~) SCZ SCR = Disproved (\ x -> case x of) - (%~) SCZ SCS = Disproved (\ x -> case x of) - (%~) SCZ SCT = Disproved (\ x -> case x of) - (%~) SCZ SCU = Disproved (\ x -> case x of) - (%~) SCZ SCV = Disproved (\ x -> case x of) - (%~) SCZ SCW = Disproved (\ x -> case x of) - (%~) SCZ SCX = Disproved (\ x -> case x of) - (%~) SCZ SCY = Disproved (\ x -> case x of) - (%~) SCZ SCZ = Proved Refl - instance Data.Type.Equality.TestEquality (SAChar :: AChar - -> Type) where - Data.Type.Equality.testEquality - = Data.Singletons.Decide.decideEquality - instance Data.Type.Coercion.TestCoercion (SAChar :: AChar - -> Type) where - Data.Type.Coercion.testCoercion - = Data.Singletons.Decide.decideCoercion - instance (Data.Singletons.ShowSing.ShowSing U, - Data.Singletons.ShowSing.ShowSing Nat) => - Show (SU (z :: U)) where - showsPrec _ SBOOL = showString "SBOOL" - showsPrec _ SSTRING = showString "SSTRING" - showsPrec _ SNAT = showString "SNAT" - showsPrec - p_0123456789876543210 - (SVEC (arg_0123456789876543210 :: Sing argTy_0123456789876543210) - (arg_0123456789876543210 :: Sing argTy_0123456789876543210)) - = (showParen (((>) p_0123456789876543210) 10)) - (((.) (showString "SVEC ")) - (((.) ((showsPrec 11) arg_0123456789876543210)) - (((.) GHC.Show.showSpace) - ((showsPrec 11) arg_0123456789876543210)))) :: - (Data.Singletons.ShowSing.ShowSing' argTy_0123456789876543210, - Data.Singletons.ShowSing.ShowSing' argTy_0123456789876543210) => - ShowS - instance Show (SAChar (z :: AChar)) where - showsPrec _ SCA = showString "SCA" - showsPrec _ SCB = showString "SCB" - showsPrec _ SCC = showString "SCC" - showsPrec _ SCD = showString "SCD" - showsPrec _ SCE = showString "SCE" - showsPrec _ SCF = showString "SCF" - showsPrec _ SCG = showString "SCG" - showsPrec _ SCH = showString "SCH" - showsPrec _ SCI = showString "SCI" - showsPrec _ SCJ = showString "SCJ" - showsPrec _ SCK = showString "SCK" - showsPrec _ SCL = showString "SCL" - showsPrec _ SCM = showString "SCM" - showsPrec _ SCN = showString "SCN" - showsPrec _ SCO = showString "SCO" - showsPrec _ SCP = showString "SCP" - showsPrec _ SCQ = showString "SCQ" - showsPrec _ SCR = showString "SCR" - showsPrec _ SCS = showString "SCS" - showsPrec _ SCT = showString "SCT" - showsPrec _ SCU = showString "SCU" - showsPrec _ SCV = showString "SCV" - showsPrec _ SCW = showString "SCW" - showsPrec _ SCX = showString "SCX" - showsPrec _ SCY = showString "SCY" - showsPrec _ SCZ = showString "SCZ" - 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 (VECSym0 :: (~>) U ((~>) Nat U)) where - sing = (singFun2 @VECSym0) SVEC - instance SingI d => SingI (VECSym1 (d :: U) :: (~>) Nat U) where - sing = (singFun1 @(VECSym1 (d :: U))) (SVEC (sing @d)) - 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 :: [AChar]) (n :: U)) where - sing = (SAttr sing) sing - instance SingI (AttrSym0 :: (~>) [AChar] ((~>) U Attribute)) where - sing = (singFun2 @AttrSym0) SAttr - instance SingI d => - SingI (AttrSym1 (d :: [AChar]) :: (~>) U Attribute) where - sing = (singFun1 @(AttrSym1 (d :: [AChar]))) (SAttr (sing @d)) - instance SingI n => SingI (Sch (n :: [Attribute])) where - sing = SSch sing - instance SingI (SchSym0 :: (~>) [Attribute] Schema) where - sing = (singFun1 @SchSym0) SSch -GradingClient/Database.hs:0:0:: Splicing declarations - return [] ======> -GradingClient/Database.hs:(0,0)-(0,0): Splicing expression - cases ''Row [| r |] [| changeId (n ++ (getId r)) r |] - ======> - case r of - EmptyRow _ -> (changeId (((++) n) (getId r))) r - ConsRow _ _ -> (changeId (((++) n) (getId r))) r diff --git a/tests/compile-and-dump/GradingClient/Database.hs b/tests/compile-and-dump/GradingClient/Database.hs deleted file mode 100644 --- a/tests/compile-and-dump/GradingClient/Database.hs +++ /dev/null @@ -1,552 +0,0 @@ -{- Database.hs - -(c) Richard Eisenberg 2012 -rae@cs.brynmawr.edu - -This file contains the full code for the database interface example -presented in /Dependently typed programming with singletons/ - --} - -{-# LANGUAGE PolyKinds, DataKinds, TemplateHaskell, TypeFamilies, - GADTs, TypeOperators, RankNTypes, FlexibleContexts, UndecidableInstances, - FlexibleInstances, ScopedTypeVariables, MultiParamTypeClasses, - ConstraintKinds, InstanceSigs #-} -{-# OPTIONS_GHC -Wno-warnings-deprecations #-} - --- The OverlappingInstances is needed only to allow the InC and SubsetC classes. --- This is simply a convenience so that GHC can infer the necessary proofs of --- schema inclusion. The library could easily be designed without this flag, --- but it would require a client to explicity build proof terms from --- InProof and Subset. - -module GradingClient.Database where - -import Prelude hiding ( tail, id ) -import Data.Singletons.Prelude hiding ( Lookup, sLookup ) -import Data.Singletons.Prelude.Show -import Data.Singletons.SuppressUnusedWarnings -import Data.Singletons.TH -import Control.Monad -import Control.Monad.Except ( throwError ) -import Data.List hiding ( tail ) -import Data.Kind (Type) - -$(singletons [d| - -- Basic Nat type - data Nat = Zero | Succ Nat deriving (Eq, Ord) - |]) - --- Conversions to any from Integers -fromNat :: Nat -> Integer -fromNat Zero = 0 -fromNat (Succ n) = (fromNat n) + 1 - -toNat :: Integer -> Nat -toNat 0 = Zero -toNat n | n > 0 = Succ (toNat (n - 1)) -toNat _ = error "Converting negative to Nat" - --- Display and read Nats using decimal digits -instance Show Nat where - show = show . fromNat -instance Read Nat where - readsPrec n s = map (\(a,rest) -> (toNat a,rest)) $ readsPrec n s - -$(singletons [d| - -- Our "U"niverse of types. These types can be stored in our database. - data U = BOOL - | STRING - | NAT - | VEC U Nat deriving (Read, Eq, Show) - - -- A re-definition of Char as an algebraic data type. - -- This is necessary to allow for promotion and type-level Strings. - data AChar = CA | CB | CC | CD | CE | CF | CG | CH | CI - | CJ | CK | CL | CM | CN | CO | CP | CQ | CR - | CS | CT | CU | CV | CW | CX | CY | CZ - deriving (Read, Show, Eq) - - -- A named attribute in our database - data Attribute = Attr [AChar] U - - -- A schema is an ordered list of named attributes - data Schema = Sch [Attribute] - - -- append two schemas - append :: Schema -> Schema -> Schema - append (Sch s1) (Sch s2) = Sch (s1 ++ s2) - - -- predicate to check that a schema is free of a certain attribute - attrNotIn :: Attribute -> Schema -> Bool - attrNotIn _ (Sch []) = True - attrNotIn (Attr name u) (Sch ((Attr name' _) : t)) = - (name /= name') && (attrNotIn (Attr name u) (Sch t)) - - -- predicate to check that two schemas are disjoint - disjoint :: Schema -> Schema -> Bool - disjoint (Sch []) _ = True - disjoint (Sch (h : t)) s = (attrNotIn h s) && (disjoint (Sch t) s) - - -- predicate to check if a name occurs in a schema - occurs :: [AChar] -> Schema -> Bool - occurs _ (Sch []) = False - occurs name (Sch ((Attr name' _) : attrs)) = - name == name' || occurs name (Sch attrs) - - -- looks up an element type from a schema - lookup :: [AChar] -> Schema -> U - lookup _ (Sch []) = undefined - lookup name (Sch ((Attr name' u) : attrs)) = - if name == name' then u else lookup name (Sch attrs) - |]) - --- The El type family gives us the type associated with a constructor --- of U: -type family El (u :: U) :: Type -type instance El BOOL = Bool -type instance El STRING = String -type instance El NAT = Nat -type instance El (VEC u n) = Vec (El u) n - --- Length-indexed vectors -data Vec :: Type -> Nat -> Type where - VNil :: Vec a Zero - VCons :: a -> Vec a n -> Vec a (Succ n) - --- Read instances are keyed by the index of the vector to aid in parsing -instance Read (Vec a Zero) where - readsPrec _ s = [(VNil, s)] -instance (Read a, Read (Vec a n)) => Read (Vec a (Succ n)) where - readsPrec n s = do - (a, rest) <- readsPrec n s - (tail, restrest) <- readsPrec n rest - return (VCons a tail, restrest) - --- Because the Read instances are keyed by the length of the vector, --- it is not obvious to the compiler that all Vecs have a Read instance. --- We must make a short inductive proof of this fact. - --- First, we define a datatype to store the resulting instance, keyed --- by the parameters to Vec: -data VecReadInstance a n where - VecReadInstance :: Read (Vec a n) => VecReadInstance a n - --- Then, we make a function that produces an instance of Read for a --- Vec, given the datatype it is over and its length, both encoded --- using singleton types: -vecReadInstance :: Read (El u) => SU u -> SNat n -> VecReadInstance (El u) n -vecReadInstance _ SZero = VecReadInstance -vecReadInstance u (SSucc n) = case vecReadInstance u n of - VecReadInstance -> VecReadInstance - --- The Show instance can be straightforwardly defined: -instance Show a => Show (Vec a n) where - show VNil = "" - show (VCons h t) = (show h) ++ " " ++ (show t) - --- We need to be able to Read and Show elements of our database, so --- we must know that any type of the form (El u) for some (u :: U) --- has a Read and Show instance. Because we can't declare this instance --- directly (as, in general, declaring an instance of a type family --- would be unsound), we provide inductive proofs that these instances --- exist: -data ElUReadInstance u where - ElUReadInstance :: Read (El u) => ElUReadInstance u - -elUReadInstance :: Sing u -> ElUReadInstance u -elUReadInstance SBOOL = ElUReadInstance -elUReadInstance SSTRING = ElUReadInstance -elUReadInstance SNAT = ElUReadInstance -elUReadInstance (SVEC u n) = case elUReadInstance u of - ElUReadInstance -> case vecReadInstance u n of - VecReadInstance -> ElUReadInstance - -data ElUShowInstance u where - ElUShowInstance :: Show (El u) => ElUShowInstance u - -elUShowInstance :: Sing u -> ElUShowInstance u -elUShowInstance SBOOL = ElUShowInstance -elUShowInstance SSTRING = ElUShowInstance -elUShowInstance SNAT = ElUShowInstance -elUShowInstance (SVEC u _) = case elUShowInstance u of - ElUShowInstance -> ElUShowInstance - -showAttrProof :: Sing (Attr nm u) -> ElUShowInstance u -showAttrProof (SAttr _ u) = elUShowInstance u - --- A Row is one row of our database table, keyed by its schema. -data Row :: Schema -> Type where - EmptyRow :: [Int] -> Row (Sch '[]) -- the Ints are the unique id of the row - ConsRow :: El u -> Row (Sch s) -> Row (Sch ((Attr name u) ': s)) - --- We build Show instances for a Row element by element: -instance Show (Row (Sch '[])) where - show (EmptyRow n) = "(id=" ++ (show n) ++ ")" -instance (Show (El u), Show (Row (Sch attrs))) => - Show (Row (Sch ((Attr name u) ': attrs))) where - show (ConsRow h t) = case t of - EmptyRow n -> (show h) ++ " (id=" ++ (show n) ++ ")" - _ -> (show h) ++ ", " ++ (show t) - --- A Handle in our system is an abstract handle to a loaded table. --- The constructor is not exported. In our simplistic case, we --- just store the list of rows. A more sophisticated implementation --- could store some identifier to the connection to an external database. -data Handle :: Schema -> Type where - Handle :: [Row s] -> Handle s - --- The following functions parse our very simple flat file database format. - --- The file, with a name ending in ".dat", consists of a sequence of lines, --- where each line contains one entry in the table. There is no row separator; --- if a row contains n pieces of data, that row is represented in n lines in --- the file. - --- A schema is stored in a file of the same name, except ending in ".schema". --- Each line in the file is a constructor of U indicating the type of the --- corresponding row element. - --- Use Either for error handling in parsing functions -type ErrorM = Either String - --- This function is relatively uninteresting except for its use of --- pattern matching to introduce the instances of Read and Show for --- elements -readRow :: Int -> SSchema s -> [String] -> ErrorM (Row s, [String]) -readRow id (SSch SNil) strs = - return (EmptyRow [id], strs) -readRow _ (SSch (SCons _ _)) [] = - throwError "Ran out of data while processing row" -readRow id (SSch (SCons (SAttr _ u) at)) (sh:st) = do - (rowTail, strTail) <- readRow id (SSch at) st - case elUReadInstance u of - ElUReadInstance -> - let results = readsPrec 0 sh in - if null results - then throwError $ "No parse of " ++ sh ++ " as a " ++ - (show (fromSing u)) - else - let item = fst $ head results in - case elUShowInstance u of - ElUShowInstance -> return (ConsRow item rowTail, strTail) - -readRows :: SSchema s -> [String] -> [Row s] -> ErrorM [Row s] -readRows _ [] soFar = return soFar -readRows sch lst soFar = do - (row, rest) <- readRow (length soFar) sch lst - readRows sch rest (row : soFar) - --- Given the name of a database and its schema, return a handle to the --- database. -connect :: String -> SSchema s -> IO (Handle s) -connect name schema = do - schString <- readFile (name ++ ".schema") - let schEntries = lines schString - usFound = map read schEntries -- load schema just using "read" - (Sch attrs) = fromSing schema - usExpected = map (\(Attr _ u) -> u) attrs - unless (usFound == usExpected) -- compare found schema with expected - (fail "Expected schema does not match found schema") - dataString <- readFile (name ++ ".dat") - let dataEntries = lines dataString - result = readRows schema dataEntries [] -- read actual data - case result of - Left errorMsg -> fail errorMsg - Right rows -> return $ Handle rows - --- In order to define strongly-typed projection from a row, we need to have a notion --- that one schema is a subset of another. We permit the schemas to have their columns --- in different orders. We define this subset relation via two inductively defined --- propositions. In Haskell, these inductively defined propositions take the form of --- GADTs. In their original form, they would look like this: -{- -data InProof :: Attribute -> Schema -> Type where - InElt :: InProof attr (Sch (attr ': schTail)) - InTail :: InProof attr (Sch attrs) -> InProof attr (Sch (a ': attrs)) - -data SubsetProof :: Schema -> Schema -> Type where - SubsetEmpty :: SubsetProof (Sch '[]) s' - SubsetCons :: InProof attr s' -> SubsetProof (Sch attrs) s' -> - SubsetProof (Sch (attr ': attrs)) s' --} --- However, it would be convenient to users of the database library not to require --- building these proofs manually. So, we define type classes so that the compiler --- builds the proofs automatically. To make everything work well together, we also --- make the parameters to the proof GADT constructors implicit -- i.e. in the form --- of type class constraints. - -data InProof :: Attribute -> Schema -> Type where - InElt :: InProof attr (Sch (attr ': schTail)) - InTail :: InC name u (Sch attrs) => InProof (Attr name u) (Sch (a ': attrs)) - -class InC (name :: [AChar]) (u :: U) (sch :: Schema) where - inProof :: InProof (Attr name u) sch -instance InC name u (Sch ((Attr name u) ': schTail)) where - inProof = InElt -instance InC name u (Sch attrs) => InC name u (Sch (a ': attrs)) where - inProof = InTail - -data SubsetProof :: Schema -> Schema -> Type where - SubsetEmpty :: SubsetProof (Sch '[]) s' - SubsetCons :: (InC name u s', SubsetC (Sch attrs) s') => - SubsetProof (Sch ((Attr name u) ': attrs)) s' - -class SubsetC (s :: Schema) (s' :: Schema) where - subset :: SubsetProof s s' - -instance SubsetC (Sch '[]) s' where - subset = SubsetEmpty -instance (InC name u s', SubsetC (Sch attrs) s') => - SubsetC (Sch ((Attr name u) ': attrs)) s' where - subset = SubsetCons - --- To access the data in a structured (and well-typed!) way, we use --- an RA (short for Relational Algebra). An RA is indexed by the schema --- of the data it produces. -data RA :: Schema -> Type where - -- The RA includes all data represented by the handle. - Read :: Handle s -> RA s - - -- The RA is a union of the rows represented by the two RAs provided. - -- Note that the schemas of the two RAs must be the same for this - -- constructor use to type-check. - Union :: RA s -> RA s -> RA s - - -- The RA is the list of rows in the first RA, omitting those in the - -- second. Once again, the schemas must match. - Diff :: RA s -> RA s -> RA s - - -- The RA is a Cartesian product of the two RAs provided. Note that - -- the schemas of the two provided RAs must be disjoint. - Product :: (Disjoint s s' ~ True, SingI s, SingI s') => - RA s -> RA s' -> RA (Append s s') - - -- The RA is a projection conforming to the schema provided. The - -- type-checker ensures that this schema is a subset of the data - -- included in the provided RA. - Project :: (SubsetC s' s, SingI s) => - SSchema s' -> RA s -> RA s' - - -- The RA contains only those rows of the provided RA for which - -- the provided expression evaluates to True. Note that the - -- schema of the provided RA and the resultant RA are the same - -- because the columns of data are the same. Also note that - -- the expression must return a Bool for this to type-check. - Select :: Expr s BOOL -> RA s -> RA s - --- Other constructors would be added in a more robust database --- implementation. - --- An Expr is used with the Select constructor to choose some --- subset of rows from a table. Expressions are indexed by the --- schema over which they operate and the return value they --- produce. -data Expr :: Schema -> U -> Type where - -- Equality among two elements - Equal :: Eq (El u) => Expr s u -> Expr s u -> Expr s BOOL - - -- A less-than comparison among two Nats - LessThan :: Expr s NAT -> Expr s NAT -> Expr s BOOL - - -- A literal number - LiteralNat :: Integer -> Expr s NAT - - -- Projection in an expression -- evaluates to the value - -- of the named attribute. - Element :: (Occurs nm s ~ True) => - SSchema s -> Sing nm -> Expr s (Lookup nm s) - - -- A more robust implementation would include more constructors - --- Retrieves the id from a row. Ids are used when computing unions and --- differences. -getId :: Row s -> [Int] -getId (EmptyRow n) = n -getId (ConsRow _ t) = getId t - --- Changes the id of a row to a new value -changeId :: [Int] -> Row s -> Row s -changeId n (EmptyRow _) = EmptyRow n -changeId n (ConsRow h t) = ConsRow h (changeId n t) - --- Equality for rows based on ids. -eqRow :: Row s -> Row s -> Bool -eqRow r1 r2 = getId r1 == getId r2 - --- Equality for attributes based on names -eqAttr :: Attribute -> Attribute -> Bool -eqAttr (Attr nm _) (Attr nm' _) = nm == nm' - --- Appends two rows. There are three suspicious case statements -- they are --- suspicious in that the different branches are all exactly identical. Here --- is why they are needed: - --- The two case statements on r are necessary to deconstruct the index in the --- type of r; GHC does not use the fact that s' must be (Sch a') for some a'. --- By doing a case analysis on r, GHC uses the types given in the different --- constructors for Row, both of which give the form of s' as (Sch a'). This --- deconstruction is necessary for the type family Append to compute, because --- Append is defined only when its second argument is of the form (Sch a'). - --- The case statement on rowAppend t r is necessary to avoid potential --- overlapping instances for the SingRep class; the instances are needed for --- the call to ConsRow. The potential for overlapping instances comes from --- ambiguity in the component types of (Append s s'). By doing case analysis --- on rowAppend t r, these variables become fixed, and the potential for --- overlapping instances disappears. - --- We use the "cases" Singletons library operation to produce the case --- analysis in the first clause. This "cases" operation produces a case --- statement where each branch is identical and each constructor parameter --- is ignored. The "cases" operation does not work for the second clause --- because the code in the clause depends on definitions generated earlier. --- Template Haskell restricts certain dependencies between auto-generated --- code blocks to prevent the possibility of circular dependencies. --- In this case, if the $(singletons ...) blocks above were in a different --- module, the "cases" operation would be applicable here. - -$( return [] ) - -rowAppend :: Row s -> Row s' -> Row (Append s s') -rowAppend (EmptyRow n) r = $(cases ''Row [| r |] - [| changeId (n ++ (getId r)) r |]) -rowAppend (ConsRow h t) r = case r of - EmptyRow _ -> - case rowAppend t r of - EmptyRow _ -> ConsRow h (rowAppend t r) - ConsRow _ _ -> ConsRow h (rowAppend t r) - ConsRow _ _ -> - case rowAppend t r of - EmptyRow _ -> ConsRow h (rowAppend t r) - ConsRow _ _ -> ConsRow h (rowAppend t r) - --- Choose the elements of one list based on truth values in another -choose :: [Bool] -> [a] -> [a] -choose [] _ = [] -choose (False : btail) (_ : t) = choose btail t -choose (True : btail) (h : t) = h : (choose btail t) -choose _ [] = [] - --- The query function is the eliminator for an RA. It returns a list of --- rows containing the data produced by the RA. -query :: forall s. SingI s => RA s -> IO [Row s] -query (Read (Handle rows)) = return rows -query (Union ra rb) = do - rowsa <- query ra - rowsb <- query rb - return $ unionBy eqRow rowsa rowsb -query (Diff ra rb) = do - rowsa <- query ra - rowsb <- query rb - return $ deleteFirstsBy eqRow rowsa rowsb -query (Product ra rb) = do - rowsa <- query ra - rowsb <- query rb - return $ do -- entering the [] Monad - rowa <- rowsa - rowb <- rowsb - return $ rowAppend rowa rowb -query (Project sch ra) = do - rows <- query ra - return $ map (projectRow sch) rows - where -- The projectRow function uses the relationship encoded in the Subset - -- relation to project the requested columns of data in a type-safe manner. - - -- It recurs on the structure of the provided schema, creating the output - -- row to be in the same order as the input schema. This is necessary for - -- the output to type-check, as it is indexed by the input schema. - - -- We use explicit quantification to get access to scoped type variables. - projectRow :: forall (sch :: Schema) (s' :: Schema). - SubsetC sch s' => SSchema sch -> Row s' -> Row sch - - -- Base case: empty schema - projectRow (SSch SNil) r = EmptyRow (getId r) - - -- In the recursive case, we need to pattern-match on the proof that - -- the provided schema is a subset of the provided RA. We extract this - -- proof (of type SubsetProof s s') from the SubsetC instance using the - -- subset method. - projectRow (SSch (SCons attr tail)) r = - case subset :: SubsetProof sch s' of - - -- Because we know that the schema is non-empty, the only possibility - -- here is SubsetCons: - SubsetCons -> - let rtail = projectRow (SSch tail) r in - case attr of - SAttr _ u -> case elUShowInstance u of - ElUShowInstance -> ConsRow (extractElt attr r) rtail - - -- GHC correctly determines that this case is impossible if it is - -- not commented. - -- SubsetEmpty -> undefined <== IMPOSSIBLE - - -- However, the current version of GHC (7.5) does not suppress warnings - -- for incomplete pattern matches when the remaining cases are impossible. - -- So, we include this case (impossible to reach for any terminated value) - -- to suppress the warning. - - -- Retrieves the element, looked up by the name of the provided attribute, - -- from a row. The explicit quantification is necessary to create the scoped - -- type variables to use in the return type of <> - extractElt :: forall nm u sch. InC nm u sch => - Sing (Attr nm u) -> Row sch -> El u - extractElt attr r = case inProof :: InProof (Attr nm u) sch of - InElt -> case r of - ConsRow h _ -> h - -- EmptyRow _ -> undefined <== IMPOSSIBLE - InTail -> case r of - ConsRow _ t -> extractElt attr t - -- EmptyRow _ -> undefined <== IMPOSSBLE - -query (Select expr r) = do - rows <- query r - let vals = map (eval expr) rows - return $ choose vals rows - where -- Evaluates an expression - eval :: forall s' u. SingI s' => Expr s' u -> Row s' -> El u - eval (Element _ (name :: Sing name)) row = - case row of - -- EmptyRow _ -> undefined <== IMPOSSIBLE - ConsRow h t -> case row of - (ConsRow _ _ :: Row (Sch ((Attr name' u') ': attrs))) -> - case sing :: Sing s' of - -- SSch SNil -> undefined <== IMPOSSIBLE - SSch (SCons (SAttr name' _) stail) -> - case name %== name' of - STrue -> h - SFalse -> withSingI stail (eval (Element (SSch stail) name) t) - - eval (Equal (e1 :: Expr s' u') e2) row = - let v1 = eval e1 row - v2 = eval e2 row in - v1 == v2 - - -- Note that the types really help us here: the LessThan constructor is - -- defined only over Expr s NAT, so we know that evaluating e1 and e2 will - -- yield Nats, which are a member of the Ord type class. - eval (LessThan e1 e2) row = - let v1 = eval e1 row - v2 = eval e2 row in - v1 < v2 - - eval (LiteralNat x) _ = toNat x - -data G a where - GCons :: G ('Sch (a ': b)) - -data H a where - HCons :: H ('Sch (a ': b)) - HNil :: H ('Sch '[]) - -data J a where - JCons :: J (a ': b) - JNil :: J '[] - -eval :: G s -> Sing s -> () -eval GCons s = - case s of - -- SSch SNil -> undefined -- <== IMPOSSIBLE - SSch (SCons _ _) -> undefined diff --git a/tests/compile-and-dump/GradingClient/Main.ghc88.template b/tests/compile-and-dump/GradingClient/Main.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/GradingClient/Main.ghc88.template +++ /dev/null @@ -1,123 +0,0 @@ -GradingClient/Main.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| lastName, firstName, yearName, gradeName, majorName :: [AChar] - lastName = [CL, CA, CS, CT] - firstName = [CF, CI, CR, CS, CT] - yearName = [CY, CE, CA, CR] - gradeName = [CG, CR, CA, CD, CE] - majorName = [CM, CA, CJ, CO, CR] - gradingSchema :: Schema - gradingSchema - = Sch - [Attr lastName STRING, Attr firstName STRING, Attr yearName NAT, - Attr gradeName NAT, Attr majorName BOOL] - names :: Schema - names = Sch [Attr firstName STRING, Attr lastName STRING] |] - ======> - lastName :: [AChar] - firstName :: [AChar] - yearName :: [AChar] - gradeName :: [AChar] - majorName :: [AChar] - lastName = [CL, CA, CS, CT] - firstName = [CF, CI, CR, CS, CT] - yearName = [CY, CE, CA, CR] - gradeName = [CG, CR, CA, CD, CE] - majorName = [CM, CA, CJ, CO, CR] - gradingSchema :: Schema - gradingSchema - = Sch - [(Attr lastName) STRING, (Attr firstName) STRING, - (Attr yearName) NAT, (Attr gradeName) NAT, (Attr majorName) BOOL] - names :: Schema - names = Sch [(Attr firstName) STRING, (Attr lastName) STRING] - type NamesSym0 = Names - type GradingSchemaSym0 = GradingSchema - type MajorNameSym0 = MajorName - type GradeNameSym0 = GradeName - type YearNameSym0 = YearName - type FirstNameSym0 = FirstName - type LastNameSym0 = LastName - type family Names :: Schema where - Names = Apply SchSym0 (Apply (Apply (:@#@$) (Apply (Apply AttrSym0 FirstNameSym0) STRINGSym0)) (Apply (Apply (:@#@$) (Apply (Apply AttrSym0 LastNameSym0) STRINGSym0)) '[])) - type family GradingSchema :: Schema where - GradingSchema = 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)) '[]))))) - type family MajorName :: [AChar] where - MajorName = Apply (Apply (:@#@$) CMSym0) (Apply (Apply (:@#@$) CASym0) (Apply (Apply (:@#@$) CJSym0) (Apply (Apply (:@#@$) COSym0) (Apply (Apply (:@#@$) CRSym0) '[])))) - type family GradeName :: [AChar] where - GradeName = Apply (Apply (:@#@$) CGSym0) (Apply (Apply (:@#@$) CRSym0) (Apply (Apply (:@#@$) CASym0) (Apply (Apply (:@#@$) CDSym0) (Apply (Apply (:@#@$) CESym0) '[])))) - type family YearName :: [AChar] where - YearName = Apply (Apply (:@#@$) CYSym0) (Apply (Apply (:@#@$) CESym0) (Apply (Apply (:@#@$) CASym0) (Apply (Apply (:@#@$) CRSym0) '[]))) - type family FirstName :: [AChar] where - FirstName = Apply (Apply (:@#@$) CFSym0) (Apply (Apply (:@#@$) CISym0) (Apply (Apply (:@#@$) CRSym0) (Apply (Apply (:@#@$) CSSym0) (Apply (Apply (:@#@$) CTSym0) '[])))) - type family LastName :: [AChar] where - LastName = Apply (Apply (:@#@$) CLSym0) (Apply (Apply (:@#@$) CASym0) (Apply (Apply (:@#@$) CSSym0) (Apply (Apply (:@#@$) CTSym0) '[]))) - sNames :: Sing (NamesSym0 :: Schema) - sGradingSchema :: Sing (GradingSchemaSym0 :: Schema) - sMajorName :: Sing (MajorNameSym0 :: [AChar]) - sGradeName :: Sing (GradeNameSym0 :: [AChar]) - sYearName :: Sing (YearNameSym0 :: [AChar]) - sFirstName :: Sing (FirstNameSym0 :: [AChar]) - sLastName :: Sing (LastNameSym0 :: [AChar]) - sNames - = (applySing ((singFun1 @SchSym0) SSch)) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing ((applySing ((singFun2 @AttrSym0) SAttr)) sFirstName)) - SSTRING))) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing ((applySing ((singFun2 @AttrSym0) SAttr)) sLastName)) - SSTRING))) - SNil)) - sGradingSchema - = (applySing ((singFun1 @SchSym0) SSch)) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing ((applySing ((singFun2 @AttrSym0) SAttr)) sLastName)) - SSTRING))) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing ((applySing ((singFun2 @AttrSym0) SAttr)) sFirstName)) - SSTRING))) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing ((applySing ((singFun2 @AttrSym0) SAttr)) sYearName)) - SNAT))) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing ((applySing ((singFun2 @AttrSym0) SAttr)) sGradeName)) - SNAT))) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing ((applySing ((singFun2 @AttrSym0) SAttr)) sMajorName)) - SBOOL))) - SNil))))) - sMajorName - = (applySing ((applySing ((singFun2 @(:@#@$)) SCons)) SCM)) - ((applySing ((applySing ((singFun2 @(:@#@$)) SCons)) SCA)) - ((applySing ((applySing ((singFun2 @(:@#@$)) SCons)) SCJ)) - ((applySing ((applySing ((singFun2 @(:@#@$)) SCons)) SCO)) - ((applySing ((applySing ((singFun2 @(:@#@$)) SCons)) SCR)) SNil)))) - sGradeName - = (applySing ((applySing ((singFun2 @(:@#@$)) SCons)) SCG)) - ((applySing ((applySing ((singFun2 @(:@#@$)) SCons)) SCR)) - ((applySing ((applySing ((singFun2 @(:@#@$)) SCons)) SCA)) - ((applySing ((applySing ((singFun2 @(:@#@$)) SCons)) SCD)) - ((applySing ((applySing ((singFun2 @(:@#@$)) SCons)) SCE)) SNil)))) - sYearName - = (applySing ((applySing ((singFun2 @(:@#@$)) SCons)) SCY)) - ((applySing ((applySing ((singFun2 @(:@#@$)) SCons)) SCE)) - ((applySing ((applySing ((singFun2 @(:@#@$)) SCons)) SCA)) - ((applySing ((applySing ((singFun2 @(:@#@$)) SCons)) SCR)) SNil))) - sFirstName - = (applySing ((applySing ((singFun2 @(:@#@$)) SCons)) SCF)) - ((applySing ((applySing ((singFun2 @(:@#@$)) SCons)) SCI)) - ((applySing ((applySing ((singFun2 @(:@#@$)) SCons)) SCR)) - ((applySing ((applySing ((singFun2 @(:@#@$)) SCons)) SCS)) - ((applySing ((applySing ((singFun2 @(:@#@$)) SCons)) SCT)) SNil)))) - sLastName - = (applySing ((applySing ((singFun2 @(:@#@$)) SCons)) SCL)) - ((applySing ((applySing ((singFun2 @(:@#@$)) SCons)) SCA)) - ((applySing ((applySing ((singFun2 @(:@#@$)) SCons)) SCS)) - ((applySing ((applySing ((singFun2 @(:@#@$)) SCons)) SCT)) SNil))) diff --git a/tests/compile-and-dump/GradingClient/Main.hs b/tests/compile-and-dump/GradingClient/Main.hs deleted file mode 100644 --- a/tests/compile-and-dump/GradingClient/Main.hs +++ /dev/null @@ -1,54 +0,0 @@ -{- GradingClient.hs - -(c) Richard Eisenberg 2012 -rae@cs.brynmawr.edu - -This file accesses the database described in Database.hs and performs -some basic queries on it. - --} - -{-# LANGUAGE TemplateHaskell, DataKinds #-} - -module Main where - -import Data.Singletons -import Data.Singletons.TH -import Data.Singletons.Prelude.List -import GradingClient.Database - -$(singletons [d| - lastName, firstName, yearName, gradeName, majorName :: [AChar] - lastName = [CL, CA, CS, CT] - firstName = [CF, CI, CR, CS, CT] - yearName = [CY, CE, CA, CR] - gradeName = [CG, CR, CA, CD, CE] - majorName = [CM, CA, CJ, CO, CR] - - gradingSchema :: Schema - gradingSchema = Sch [Attr lastName STRING, - Attr firstName STRING, - Attr yearName NAT, - Attr gradeName NAT, - Attr majorName BOOL] - - names :: Schema - names = Sch [Attr firstName STRING, - Attr lastName STRING] - |]) - -main :: IO () -main = do - h <- connect "grades" sGradingSchema - let ra = Read h - - allStudents <- query $ Project sNames ra - putStrLn $ "Names of all students: " ++ (show allStudents) ++ "\n" - - majors <- query $ Select (Element sGradingSchema sMajorName) ra - putStrLn $ "Students in major: " ++ (show majors) ++ "\n" - - b_students <- - query $ Project sNames $ - Select (LessThan (Element sGradingSchema sGradeName) (LiteralNat 90)) ra - putStrLn $ "Names of students with grade < 90: " ++ (show b_students) ++ "\n" diff --git a/tests/compile-and-dump/InsertionSort/InsertionSortImp.ghc88.template b/tests/compile-and-dump/InsertionSort/InsertionSortImp.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/InsertionSort/InsertionSortImp.ghc88.template +++ /dev/null @@ -1,211 +0,0 @@ -InsertionSort/InsertionSortImp.hs:(0,0)-(0,0): Splicing declarations - singletons [d| data Nat = Zero | Succ Nat |] - ======> - data Nat = Zero | Succ Nat - type ZeroSym0 = Zero - type SuccSym1 (t0123456789876543210 :: Nat) = - Succ t0123456789876543210 - instance SuppressUnusedWarnings SuccSym0 where - suppressUnusedWarnings = snd (((,) SuccSym0KindInference) ()) - data SuccSym0 :: (~>) Nat Nat - where - SuccSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply SuccSym0 arg) (SuccSym1 arg) => - SuccSym0 t0123456789876543210 - type instance Apply SuccSym0 t0123456789876543210 = Succ t0123456789876543210 - data SNat :: Nat -> Type - where - SZero :: SNat Zero - SSucc :: forall (n :: Nat). (Sing (n :: Nat)) -> SNat (Succ n) - type instance Sing @Nat = SNat - instance SingKind Nat where - type Demote Nat = Nat - fromSing SZero = Zero - fromSing (SSucc b) = Succ (fromSing b) - toSing Zero = SomeSing SZero - toSing (Succ (b :: Demote Nat)) - = case toSing b :: SomeSing Nat of { - SomeSing c -> SomeSing (SSucc c) } - instance SingI Zero where - sing = SZero - instance SingI n => SingI (Succ (n :: Nat)) where - sing = SSucc sing - instance SingI (SuccSym0 :: (~>) Nat Nat) where - sing = (singFun1 @SuccSym0) SSucc -InsertionSort/InsertionSortImp.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| leq :: Nat -> Nat -> Bool - leq Zero _ = True - leq (Succ _) Zero = False - leq (Succ a) (Succ b) = leq a b - insert :: Nat -> [Nat] -> [Nat] - insert n [] = [n] - insert n (h : t) - = if leq n h then (n : h : t) else h : (insert n t) - insertionSort :: [Nat] -> [Nat] - insertionSort [] = [] - insertionSort (h : t) = insert h (insertionSort t) |] - ======> - leq :: Nat -> Nat -> Bool - leq Zero _ = True - leq (Succ _) Zero = False - leq (Succ a) (Succ b) = (leq a) b - insert :: Nat -> [Nat] -> [Nat] - insert n [] = [n] - insert n (h : t) - = if (leq n) h then (n : (h : t)) else (h : (insert n) t) - insertionSort :: [Nat] -> [Nat] - insertionSort [] = [] - insertionSort (h : t) = (insert h) (insertionSort t) - type Let0123456789876543210Scrutinee_0123456789876543210Sym3 n0123456789876543210 h0123456789876543210 t0123456789876543210 = - Let0123456789876543210Scrutinee_0123456789876543210 n0123456789876543210 h0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210Scrutinee_0123456789876543210Sym2 h0123456789876543210 n0123456789876543210) where - suppressUnusedWarnings - = snd - (((,) - Let0123456789876543210Scrutinee_0123456789876543210Sym2KindInference) - ()) - data Let0123456789876543210Scrutinee_0123456789876543210Sym2 n0123456789876543210 h0123456789876543210 t0123456789876543210 - where - Let0123456789876543210Scrutinee_0123456789876543210Sym2KindInference :: forall n0123456789876543210 - h0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Let0123456789876543210Scrutinee_0123456789876543210Sym2 n0123456789876543210 h0123456789876543210) arg) (Let0123456789876543210Scrutinee_0123456789876543210Sym3 n0123456789876543210 h0123456789876543210 arg) => - Let0123456789876543210Scrutinee_0123456789876543210Sym2 n0123456789876543210 h0123456789876543210 t0123456789876543210 - type instance Apply (Let0123456789876543210Scrutinee_0123456789876543210Sym2 h0123456789876543210 n0123456789876543210) t0123456789876543210 = Let0123456789876543210Scrutinee_0123456789876543210 h0123456789876543210 n0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210Scrutinee_0123456789876543210Sym1 n0123456789876543210) where - suppressUnusedWarnings - = snd - (((,) - Let0123456789876543210Scrutinee_0123456789876543210Sym1KindInference) - ()) - data Let0123456789876543210Scrutinee_0123456789876543210Sym1 n0123456789876543210 h0123456789876543210 - where - Let0123456789876543210Scrutinee_0123456789876543210Sym1KindInference :: forall n0123456789876543210 - h0123456789876543210 - arg. SameKind (Apply (Let0123456789876543210Scrutinee_0123456789876543210Sym1 n0123456789876543210) arg) (Let0123456789876543210Scrutinee_0123456789876543210Sym2 n0123456789876543210 arg) => - Let0123456789876543210Scrutinee_0123456789876543210Sym1 n0123456789876543210 h0123456789876543210 - type instance Apply (Let0123456789876543210Scrutinee_0123456789876543210Sym1 n0123456789876543210) h0123456789876543210 = Let0123456789876543210Scrutinee_0123456789876543210Sym2 n0123456789876543210 h0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210Scrutinee_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd - (((,) - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference) - ()) - data Let0123456789876543210Scrutinee_0123456789876543210Sym0 n0123456789876543210 - where - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference :: forall n0123456789876543210 - arg. SameKind (Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 arg) (Let0123456789876543210Scrutinee_0123456789876543210Sym1 arg) => - Let0123456789876543210Scrutinee_0123456789876543210Sym0 n0123456789876543210 - type instance Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 n0123456789876543210 = Let0123456789876543210Scrutinee_0123456789876543210Sym1 n0123456789876543210 - type family Let0123456789876543210Scrutinee_0123456789876543210 n h t where - Let0123456789876543210Scrutinee_0123456789876543210 n h t = Apply (Apply LeqSym0 n) h - type family Case_0123456789876543210 n h t t where - Case_0123456789876543210 n h t 'True = Apply (Apply (:@#@$) n) (Apply (Apply (:@#@$) h) t) - Case_0123456789876543210 n h t 'False = Apply (Apply (:@#@$) h) (Apply (Apply InsertSym0 n) t) - type InsertionSortSym1 (a0123456789876543210 :: [Nat]) = - InsertionSort a0123456789876543210 - instance SuppressUnusedWarnings InsertionSortSym0 where - suppressUnusedWarnings - = snd (((,) InsertionSortSym0KindInference) ()) - data InsertionSortSym0 :: (~>) [Nat] [Nat] - where - InsertionSortSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply InsertionSortSym0 arg) (InsertionSortSym1 arg) => - InsertionSortSym0 a0123456789876543210 - type instance Apply InsertionSortSym0 a0123456789876543210 = InsertionSort a0123456789876543210 - type InsertSym2 (a0123456789876543210 :: Nat) (a0123456789876543210 :: [Nat]) = - Insert a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (InsertSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) InsertSym1KindInference) ()) - data InsertSym1 (a0123456789876543210 :: Nat) :: (~>) [Nat] [Nat] - where - InsertSym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (InsertSym1 a0123456789876543210) arg) (InsertSym2 a0123456789876543210 arg) => - InsertSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (InsertSym1 a0123456789876543210) a0123456789876543210 = Insert a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings InsertSym0 where - suppressUnusedWarnings = snd (((,) InsertSym0KindInference) ()) - data InsertSym0 :: (~>) Nat ((~>) [Nat] [Nat]) - where - InsertSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply InsertSym0 arg) (InsertSym1 arg) => - InsertSym0 a0123456789876543210 - type instance Apply InsertSym0 a0123456789876543210 = InsertSym1 a0123456789876543210 - type LeqSym2 (a0123456789876543210 :: Nat) (a0123456789876543210 :: Nat) = - Leq a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (LeqSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) LeqSym1KindInference) ()) - data LeqSym1 (a0123456789876543210 :: Nat) :: (~>) Nat Bool - where - LeqSym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (LeqSym1 a0123456789876543210) arg) (LeqSym2 a0123456789876543210 arg) => - LeqSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (LeqSym1 a0123456789876543210) a0123456789876543210 = Leq a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings LeqSym0 where - suppressUnusedWarnings = snd (((,) LeqSym0KindInference) ()) - data LeqSym0 :: (~>) Nat ((~>) Nat Bool) - where - LeqSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply LeqSym0 arg) (LeqSym1 arg) => - LeqSym0 a0123456789876543210 - type instance Apply LeqSym0 a0123456789876543210 = LeqSym1 a0123456789876543210 - type family InsertionSort (a :: [Nat]) :: [Nat] where - InsertionSort '[] = '[] - InsertionSort ('(:) h t) = Apply (Apply InsertSym0 h) (Apply InsertionSortSym0 t) - type family Insert (a :: Nat) (a :: [Nat]) :: [Nat] where - Insert n '[] = Apply (Apply (:@#@$) n) '[] - Insert n ('(:) h t) = Case_0123456789876543210 n h t (Let0123456789876543210Scrutinee_0123456789876543210Sym3 n h t) - type family Leq (a :: Nat) (a :: Nat) :: Bool where - Leq 'Zero _ = TrueSym0 - Leq ('Succ _) 'Zero = FalseSym0 - Leq ('Succ a) ('Succ b) = Apply (Apply LeqSym0 a) b - sInsertionSort :: - forall (t :: [Nat]). - Sing t -> Sing (Apply InsertionSortSym0 t :: [Nat]) - sInsert :: - forall (t :: Nat) (t :: [Nat]). - Sing t -> Sing t -> Sing (Apply (Apply InsertSym0 t) t :: [Nat]) - sLeq :: - forall (t :: Nat) (t :: Nat). - Sing t -> Sing t -> Sing (Apply (Apply LeqSym0 t) t :: Bool) - sInsertionSort SNil = SNil - sInsertionSort (SCons (sH :: Sing h) (sT :: Sing t)) - = (applySing ((applySing ((singFun2 @InsertSym0) sInsert)) sH)) - ((applySing ((singFun1 @InsertionSortSym0) sInsertionSort)) sT) - sInsert (sN :: Sing n) SNil - = (applySing ((applySing ((singFun2 @(:@#@$)) SCons)) sN)) SNil - sInsert (sN :: Sing n) (SCons (sH :: Sing h) (sT :: Sing t)) - = let - sScrutinee_0123456789876543210 :: - Sing (Let0123456789876543210Scrutinee_0123456789876543210Sym3 n h t) - sScrutinee_0123456789876543210 - = (applySing ((applySing ((singFun2 @LeqSym0) sLeq)) sN)) sH - in - (id - @(Sing (Case_0123456789876543210 n h t (Let0123456789876543210Scrutinee_0123456789876543210Sym3 n h t) :: [Nat]))) - (case sScrutinee_0123456789876543210 of - STrue - -> (applySing ((applySing ((singFun2 @(:@#@$)) SCons)) sN)) - ((applySing ((applySing ((singFun2 @(:@#@$)) SCons)) sH)) sT) - SFalse - -> (applySing ((applySing ((singFun2 @(:@#@$)) SCons)) sH)) - ((applySing ((applySing ((singFun2 @InsertSym0) sInsert)) sN)) sT)) - sLeq SZero _ = STrue - sLeq (SSucc _) SZero = SFalse - sLeq (SSucc (sA :: Sing a)) (SSucc (sB :: Sing b)) - = (applySing ((applySing ((singFun2 @LeqSym0) sLeq)) sA)) sB - instance SingI (InsertionSortSym0 :: (~>) [Nat] [Nat]) where - sing = (singFun1 @InsertionSortSym0) sInsertionSort - instance SingI (InsertSym0 :: (~>) Nat ((~>) [Nat] [Nat])) where - sing = (singFun2 @InsertSym0) sInsert - instance SingI d => - SingI (InsertSym1 (d :: Nat) :: (~>) [Nat] [Nat]) where - sing = (singFun1 @(InsertSym1 (d :: Nat))) (sInsert (sing @d)) - instance SingI (LeqSym0 :: (~>) Nat ((~>) Nat Bool)) where - sing = (singFun2 @LeqSym0) sLeq - instance SingI d => - SingI (LeqSym1 (d :: Nat) :: (~>) Nat Bool) where - sing = (singFun1 @(LeqSym1 (d :: Nat))) (sLeq (sing @d)) diff --git a/tests/compile-and-dump/InsertionSort/InsertionSortImp.hs b/tests/compile-and-dump/InsertionSort/InsertionSortImp.hs deleted file mode 100644 --- a/tests/compile-and-dump/InsertionSort/InsertionSortImp.hs +++ /dev/null @@ -1,205 +0,0 @@ -{- InsertionSortImp.hs - -(c) Richard Eisenberg 2012 -rae@cs.brynmawr.edu - -This file contains an implementation of insertion sort over natural numbers, -along with a Haskell proof that the sort algorithm is correct. The code below -uses a combination of GADTs and class instances to record the progress and -result of the proof. - -Ideally, the GADTs would be defined so that the constructors take no explicit -parameters --- the information would all be encoded in the constraints to the -constructors. However, due to the nature of the permutation relation, a class -instance definition corresponding to the constructor PermIns would require -existentially-quantified type variables (the l2 variable in the declaration of -PermIns). Type variables in an instance constraint but not mentioned in the -instance head are inherently ambiguous. The compiler would never be able to -infer the value of the variables. Thus, it is not possible to make a class -PermutationC analogous to PermutationProof in the way that AscendingC is -analogous to AscendingProof. (Note that it may be possible to fundamentally -rewrite the inductive definition of the permutation relation to avoid -existentially-quantified variables. We have not attempted that here.) - -If there were a way to offer an explicit dictionary when satisfying a constraint, -this problem could be avoided, as the variable in question could be made -unambiguous. - --} - -{-# LANGUAGE IncoherentInstances, ConstraintKinds, TypeFamilies, - TemplateHaskell, RankNTypes, ScopedTypeVariables, GADTs, - TypeOperators, DataKinds, PolyKinds, MultiParamTypeClasses, - FlexibleContexts, FlexibleInstances, UndecidableInstances #-} - -module InsertionSort.InsertionSortImp where - -import Data.Kind (Type) -import Data.Singletons.Prelude -import Data.Singletons.SuppressUnusedWarnings -import Data.Singletons.TH - -data Dict c where - Dict :: c => Dict c - --- Natural numbers, defined with singleton counterparts -$(singletons [d| - data Nat = Zero | Succ Nat - |]) - --- convenience functions for testing purposes -toNat :: Int -> Nat -toNat 0 = Zero -toNat n | n > 0 = Succ (toNat (n - 1)) -toNat _ = error "Converting negative to Nat" - -fromNat :: Nat -> Int -fromNat Zero = 0 -fromNat (Succ n) = 1 + (fromNat n) - --- A less-than-or-equal relation among naturals -class (a :: Nat) :<=: (b :: Nat) -instance Zero :<=: a -instance (a :<=: b) => (Succ a) :<=: (Succ b) - --- A proof term asserting that a list of naturals is in ascending order -data AscendingProof :: [Nat] -> Type where - AscEmpty :: AscendingProof '[] - AscOne :: AscendingProof '[n] - AscCons :: (a :<=: b, AscendingC (b ': rest)) => AscendingProof (a ': b ': rest) - --- The class constraint (implicit parameter definition) corresponding to --- AscendingProof -class AscendingC (lst :: [Nat]) where - ascendingProof :: AscendingProof lst - --- The instances correspond to the constructors of AscendingProof -instance AscendingC '[] where - ascendingProof = AscEmpty -instance AscendingC '[n] where - ascendingProof = AscOne -instance (a :<=: b, AscendingC (b ': rest)) => AscendingC (a ': b ': rest) where - ascendingProof = AscCons - --- A proof term asserting that l2 is the list produced when x is inserted --- (anywhere) into list l1 -data InsertionProof (x :: k) (l1 :: [k]) (l2 :: [k]) where - InsHere :: InsertionProof x l (x ': l) - InsLater :: InsertionC x l1 l2 => InsertionProof x (y ': l1) (y ': l2) - --- The class constraint corresponding to InsertionProof -class InsertionC (x :: k) (l1 :: [k]) (l2 :: [k]) where - insertionProof :: InsertionProof x l1 l2 - -instance InsertionC x l (x ': l) where - insertionProof = InsHere -instance InsertionC x l1 l2 => InsertionC x (y ': l1) (y ': l2) where - insertionProof = InsLater - --- A proof term asserting that l1 and l2 are permutations of each other -data PermutationProof (l1 :: [k]) (l2 :: [k]) where - PermId :: PermutationProof l l - PermIns :: InsertionC x l2 l2' => PermutationProof l1 l2 -> - PermutationProof (x ': l1) l2' - --- Here is the definition of insertion sort about which we will be reasoning: -$(singletons [d| - leq :: Nat -> Nat -> Bool - leq Zero _ = True - leq (Succ _) Zero = False - leq (Succ a) (Succ b) = leq a b - - insert :: Nat -> [Nat] -> [Nat] - insert n [] = [n] - insert n (h:t) = if leq n h then (n:h:t) else h:(insert n t) - - insertionSort :: [Nat] -> [Nat] - insertionSort [] = [] - insertionSort (h:t) = insert h (insertionSort t) - |]) - --- A lemma that states if sLeq a b is STrue, then (a :<=: b) --- This is necessary to convert from the boolean definition of <= to the --- corresponding constraint -sLeq_true__le :: (Leq a b ~ True) => SNat a -> SNat b -> Dict (a :<=: b) -sLeq_true__le a b = case (a, b) of - (SZero, SZero) -> Dict - (SZero, SSucc _) -> Dict - -- (SSucc _, SZero) -> undefined <== IMPOSSIBLE - (SSucc a', SSucc b') -> case sLeq_true__le a' b' of - Dict -> Dict - --- A lemma that states if sLeq a b is SFalse, then (b :<=: a) -sLeq_false__nle :: (Leq a b ~ False) => SNat a -> SNat b -> Dict (b :<=: a) -sLeq_false__nle a b = case (a, b) of - -- (SZero, SZero) -> undefined <== IMPOSSIBLE - -- (SZero, SSucc _) -> undefined <== IMPOSSIBLE - (SSucc _, SZero) -> Dict - (SSucc a', SSucc b') -> case sLeq_false__nle a' b' of - Dict -> Dict - --- A lemma that states that inserting into an ascending list produces an --- ascending list -insert_ascending :: forall n lst. - AscendingC lst => SNat n -> SList lst -> Dict (AscendingC (Insert n lst)) -insert_ascending n lst = - case ascendingProof :: AscendingProof lst of - AscEmpty -> Dict -- If lst is empty, then we're done - AscOne -> case lst of -- If lst has one element... - -- SNil -> undefined <== IMPOSSIBLE - SCons h _ -> case sLeq n h of -- then check if n is <= h - STrue -> case sLeq_true__le n h of Dict -> Dict -- if so, we're done - SFalse -> case sLeq_false__nle n h of Dict -> Dict -- if not, we're done - AscCons -> case lst of -- Otherwise, if lst is more than one element... - -- SNil -> undefined <== IMPOSSIBLE - SCons h t -> case sLeq n h of -- then check if n is <= h - STrue -> case sLeq_true__le n h of Dict -> Dict -- if so, we're done - SFalse -> case sLeq_false__nle n h of -- if not, things are harder... - Dict -> case t of -- destruct t: lst is (h : h2 : t2) - -- SNil -> undefined <== IMPOSSIBLE - SCons h2 _ -> case sLeq n h2 of -- is n <= h2? - STrue -> -- if so, we're done - case sLeq_true__le n h2 of Dict -> Dict - SFalse -> -- otherwise, show that (Insert n t) is sorted - case insert_ascending n t of Dict -> Dict -- and we're done - --- A lemma that states that inserting n into lst produces a new list with n --- inserted into lst. -insert_insertion :: SNat n -> SList lst -> Dict (InsertionC n lst (Insert n lst)) -insert_insertion n lst = - case lst of - SNil -> Dict -- if lst is empty, we're done - SCons h t -> case sLeq n h of -- otherwise, is n <= h? - STrue -> Dict -- if so, we're done - SFalse -> case insert_insertion n t of Dict -> Dict -- otherwise, recur - --- A lemma that states that the result of an insertion sort is in ascending order -insertionSort_ascending :: SList lst -> Dict (AscendingC (InsertionSort lst)) -insertionSort_ascending lst = case lst of - SNil -> Dict -- if the list is empty, we're done - - -- otherwise, we recur to find that insertionSort on t produces an ascending list, - -- and then we use the fact that inserting into an ascending list produces an - -- ascending list - SCons h t -> case insertionSort_ascending t of - Dict -> case insert_ascending h (sInsertionSort t) of Dict -> Dict - --- A lemma that states that the result of an insertion sort is a permutation --- of its input -insertionSort_permutes :: SList lst -> PermutationProof lst (InsertionSort lst) -insertionSort_permutes lst = case lst of - SNil -> PermId -- if the list is empty, we're done - - -- otherwise, we wish to use PermIns. We must know that t is a permutation of - -- the insertion sort of t and that inserting h into the insertion sort of t - -- works correctly: - SCons h t -> - case insert_insertion h (sInsertionSort t) of - Dict -> PermIns (insertionSort_permutes t) - --- A theorem that states that the insertion sort of a list is both ascending --- and a permutation of the original -insertionSort_correct :: SList lst -> (Dict (AscendingC (InsertionSort lst)), - PermutationProof lst (InsertionSort lst)) -insertionSort_correct lst = (insertionSort_ascending lst, - insertionSort_permutes lst) diff --git a/tests/compile-and-dump/Promote/Constructors.ghc88.template b/tests/compile-and-dump/Promote/Constructors.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Promote/Constructors.ghc88.template +++ /dev/null @@ -1,79 +0,0 @@ -Promote/Constructors.hs:(0,0)-(0,0): Splicing declarations - promote - [d| data Foo = Foo | Foo :+ Foo - data Bar = Bar Bar Bar Bar Bar Foo |] - ======> - data Foo = Foo | Foo :+ Foo - data Bar = Bar Bar Bar Bar Bar Foo - type FooSym0 = Foo - type (:+@#@$$$) (t0123456789876543210 :: Foo) (t0123456789876543210 :: Foo) = - (:+) t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings ((:+@#@$$) t0123456789876543210) where - suppressUnusedWarnings = snd (((,) (::+@#@$$###)) ()) - data (:+@#@$$) (t0123456789876543210 :: Foo) :: (~>) Foo Foo - where - (::+@#@$$###) :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply ((:+@#@$$) t0123456789876543210) arg) ((:+@#@$$$) t0123456789876543210 arg) => - (:+@#@$$) t0123456789876543210 t0123456789876543210 - type instance Apply ((:+@#@$$) t0123456789876543210) t0123456789876543210 = (:+) t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (:+@#@$) where - suppressUnusedWarnings = snd (((,) (::+@#@$###)) ()) - data (:+@#@$) :: (~>) Foo ((~>) Foo Foo) - where - (::+@#@$###) :: forall t0123456789876543210 - arg. SameKind (Apply (:+@#@$) arg) ((:+@#@$$) arg) => - (:+@#@$) t0123456789876543210 - type instance Apply (:+@#@$) t0123456789876543210 = (:+@#@$$) t0123456789876543210 - type BarSym5 (t0123456789876543210 :: Bar) (t0123456789876543210 :: Bar) (t0123456789876543210 :: Bar) (t0123456789876543210 :: Bar) (t0123456789876543210 :: Foo) = - Bar t0123456789876543210 t0123456789876543210 t0123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (BarSym4 t0123456789876543210 t0123456789876543210 t0123456789876543210 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) BarSym4KindInference) ()) - data BarSym4 (t0123456789876543210 :: Bar) (t0123456789876543210 :: Bar) (t0123456789876543210 :: Bar) (t0123456789876543210 :: Bar) :: (~>) Foo Bar - where - BarSym4KindInference :: forall t0123456789876543210 - t0123456789876543210 - t0123456789876543210 - t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (BarSym4 t0123456789876543210 t0123456789876543210 t0123456789876543210 t0123456789876543210) arg) (BarSym5 t0123456789876543210 t0123456789876543210 t0123456789876543210 t0123456789876543210 arg) => - BarSym4 t0123456789876543210 t0123456789876543210 t0123456789876543210 t0123456789876543210 t0123456789876543210 - type instance Apply (BarSym4 t0123456789876543210 t0123456789876543210 t0123456789876543210 t0123456789876543210) t0123456789876543210 = Bar t0123456789876543210 t0123456789876543210 t0123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (BarSym3 t0123456789876543210 t0123456789876543210 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) BarSym3KindInference) ()) - data BarSym3 (t0123456789876543210 :: Bar) (t0123456789876543210 :: Bar) (t0123456789876543210 :: Bar) :: (~>) Bar ((~>) Foo Bar) - where - BarSym3KindInference :: forall t0123456789876543210 - t0123456789876543210 - t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (BarSym3 t0123456789876543210 t0123456789876543210 t0123456789876543210) arg) (BarSym4 t0123456789876543210 t0123456789876543210 t0123456789876543210 arg) => - BarSym3 t0123456789876543210 t0123456789876543210 t0123456789876543210 t0123456789876543210 - type instance Apply (BarSym3 t0123456789876543210 t0123456789876543210 t0123456789876543210) t0123456789876543210 = BarSym4 t0123456789876543210 t0123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (BarSym2 t0123456789876543210 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) BarSym2KindInference) ()) - data BarSym2 (t0123456789876543210 :: Bar) (t0123456789876543210 :: Bar) :: (~>) Bar ((~>) Bar ((~>) Foo Bar)) - where - BarSym2KindInference :: forall t0123456789876543210 - t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (BarSym2 t0123456789876543210 t0123456789876543210) arg) (BarSym3 t0123456789876543210 t0123456789876543210 arg) => - BarSym2 t0123456789876543210 t0123456789876543210 t0123456789876543210 - type instance Apply (BarSym2 t0123456789876543210 t0123456789876543210) t0123456789876543210 = BarSym3 t0123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (BarSym1 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) BarSym1KindInference) ()) - data BarSym1 (t0123456789876543210 :: Bar) :: (~>) Bar ((~>) Bar ((~>) Bar ((~>) Foo Bar))) - where - BarSym1KindInference :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (BarSym1 t0123456789876543210) arg) (BarSym2 t0123456789876543210 arg) => - BarSym1 t0123456789876543210 t0123456789876543210 - type instance Apply (BarSym1 t0123456789876543210) t0123456789876543210 = BarSym2 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings BarSym0 where - suppressUnusedWarnings = snd (((,) BarSym0KindInference) ()) - data BarSym0 :: (~>) Bar ((~>) Bar ((~>) Bar ((~>) Bar ((~>) Foo Bar)))) - where - BarSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply BarSym0 arg) (BarSym1 arg) => - BarSym0 t0123456789876543210 - type instance Apply BarSym0 t0123456789876543210 = BarSym1 t0123456789876543210 diff --git a/tests/compile-and-dump/Promote/Constructors.hs b/tests/compile-and-dump/Promote/Constructors.hs deleted file mode 100644 --- a/tests/compile-and-dump/Promote/Constructors.hs +++ /dev/null @@ -1,13 +0,0 @@ -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.ghc88.template b/tests/compile-and-dump/Promote/GenDefunSymbols.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Promote/GenDefunSymbols.ghc88.template +++ /dev/null @@ -1,54 +0,0 @@ -Promote/GenDefunSymbols.hs:0:0:: Splicing declarations - genDefunSymbols [''LiftMaybe, ''NatT, ''(:+)] - ======> - type LiftMaybeSym2 (f0123456789876543210 :: (~>) a0123456789876543210 b0123456789876543210) (x0123456789876543210 :: Maybe a0123456789876543210) = - LiftMaybe f0123456789876543210 x0123456789876543210 - instance SuppressUnusedWarnings (LiftMaybeSym1 f0123456789876543210) where - suppressUnusedWarnings = snd (((,) LiftMaybeSym1KindInference) ()) - data LiftMaybeSym1 (f0123456789876543210 :: (~>) a0123456789876543210 b0123456789876543210) :: (~>) (Maybe a0123456789876543210) (Maybe b0123456789876543210) - where - LiftMaybeSym1KindInference :: forall f0123456789876543210 - x0123456789876543210 - arg. Data.Singletons.Internal.SameKind (Apply (LiftMaybeSym1 f0123456789876543210) arg) (LiftMaybeSym2 f0123456789876543210 arg) => - LiftMaybeSym1 f0123456789876543210 x0123456789876543210 - type instance Apply (LiftMaybeSym1 f0123456789876543210) x0123456789876543210 = LiftMaybe f0123456789876543210 x0123456789876543210 - instance SuppressUnusedWarnings LiftMaybeSym0 where - suppressUnusedWarnings = snd (((,) LiftMaybeSym0KindInference) ()) - data LiftMaybeSym0 :: forall a0123456789876543210 - b0123456789876543210. - (~>) ((~>) a0123456789876543210 b0123456789876543210) ((~>) (Maybe a0123456789876543210) (Maybe b0123456789876543210)) - where - LiftMaybeSym0KindInference :: forall f0123456789876543210 - arg. Data.Singletons.Internal.SameKind (Apply LiftMaybeSym0 arg) (LiftMaybeSym1 arg) => - LiftMaybeSym0 f0123456789876543210 - type instance Apply LiftMaybeSym0 f0123456789876543210 = LiftMaybeSym1 f0123456789876543210 - type ZeroSym0 = 'Zero - type SuccSym1 (t0123456789876543210 :: NatT) = - 'Succ t0123456789876543210 - instance SuppressUnusedWarnings SuccSym0 where - suppressUnusedWarnings = snd (((,) SuccSym0KindInference) ()) - data SuccSym0 :: (~>) NatT NatT - where - SuccSym0KindInference :: forall t0123456789876543210 - arg. Data.Singletons.Internal.SameKind (Apply SuccSym0 arg) (SuccSym1 arg) => - SuccSym0 t0123456789876543210 - type instance Apply SuccSym0 t0123456789876543210 = 'Succ t0123456789876543210 - type (:+@#@$$$) (a0123456789876543210 :: Nat) (b0123456789876543210 :: Nat) = - (:+) a0123456789876543210 b0123456789876543210 - instance SuppressUnusedWarnings ((:+@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (::+@#@$$###)) ()) - data (:+@#@$$) (a0123456789876543210 :: Nat) b0123456789876543210 - where - (::+@#@$$###) :: forall a0123456789876543210 - b0123456789876543210 - arg. Data.Singletons.Internal.SameKind (Apply ((:+@#@$$) a0123456789876543210) arg) ((:+@#@$$$) a0123456789876543210 arg) => - (:+@#@$$) a0123456789876543210 b0123456789876543210 - type instance Apply ((:+@#@$$) a0123456789876543210) b0123456789876543210 = (:+) a0123456789876543210 b0123456789876543210 - instance SuppressUnusedWarnings (:+@#@$) where - suppressUnusedWarnings = snd (((,) (::+@#@$###)) ()) - data (:+@#@$) a0123456789876543210 - where - (::+@#@$###) :: forall a0123456789876543210 - arg. Data.Singletons.Internal.SameKind (Apply (:+@#@$) arg) ((:+@#@$$) arg) => - (:+@#@$) a0123456789876543210 - type instance Apply (:+@#@$) a0123456789876543210 = (:+@#@$$) a0123456789876543210 diff --git a/tests/compile-and-dump/Promote/GenDefunSymbols.hs b/tests/compile-and-dump/Promote/GenDefunSymbols.hs deleted file mode 100644 --- a/tests/compile-and-dump/Promote/GenDefunSymbols.hs +++ /dev/null @@ -1,17 +0,0 @@ -module Promote.GenDefunSymbols where - -import Data.Singletons (Apply, type (~>)) -import Data.Singletons.SuppressUnusedWarnings -import Data.Singletons.TH (genDefunSymbols) -import GHC.TypeLits hiding (type (*)) -import Data.Kind (Type) - -type family LiftMaybe (f :: a ~> b) (x :: Maybe a) :: Maybe b where - LiftMaybe f Nothing = Nothing - LiftMaybe f (Just a) = Just (Apply f a) - -data NatT = Zero | Succ NatT - -type a :+ b = a + b - -$(genDefunSymbols [ ''LiftMaybe, ''NatT, ''(:+) ]) diff --git a/tests/compile-and-dump/Promote/Newtypes.ghc88.template b/tests/compile-and-dump/Promote/Newtypes.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Promote/Newtypes.ghc88.template +++ /dev/null @@ -1,48 +0,0 @@ -Promote/Newtypes.hs:(0,0)-(0,0): Splicing declarations - promote - [d| newtype Foo - = Foo Nat - deriving Eq - newtype Bar = Bar {unBar :: Nat} |] - ======> - newtype Foo - = Foo Nat - deriving Eq - newtype Bar = Bar {unBar :: Nat} - type family Equals_0123456789876543210 (a :: Foo) (b :: Foo) :: Bool where - Equals_0123456789876543210 (Foo a) (Foo b) = (==) a b - Equals_0123456789876543210 (_ :: Foo) (_ :: Foo) = FalseSym0 - instance PEq Foo where - type (==) a b = Equals_0123456789876543210 a b - type UnBarSym1 (a0123456789876543210 :: Bar) = - UnBar a0123456789876543210 - instance SuppressUnusedWarnings UnBarSym0 where - suppressUnusedWarnings = snd (((,) UnBarSym0KindInference) ()) - data UnBarSym0 :: (~>) Bar Nat - where - UnBarSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply UnBarSym0 arg) (UnBarSym1 arg) => - UnBarSym0 a0123456789876543210 - type instance Apply UnBarSym0 a0123456789876543210 = UnBar a0123456789876543210 - type family UnBar (a :: Bar) :: Nat where - UnBar (Bar field) = field - type FooSym1 (t0123456789876543210 :: Nat) = - Foo t0123456789876543210 - instance SuppressUnusedWarnings FooSym0 where - suppressUnusedWarnings = snd (((,) FooSym0KindInference) ()) - data FooSym0 :: (~>) Nat Foo - where - FooSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply FooSym0 arg) (FooSym1 arg) => - FooSym0 t0123456789876543210 - type instance Apply FooSym0 t0123456789876543210 = Foo t0123456789876543210 - type BarSym1 (t0123456789876543210 :: Nat) = - Bar t0123456789876543210 - instance SuppressUnusedWarnings BarSym0 where - suppressUnusedWarnings = snd (((,) BarSym0KindInference) ()) - data BarSym0 :: (~>) Nat Bar - where - BarSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply BarSym0 arg) (BarSym1 arg) => - BarSym0 t0123456789876543210 - type instance Apply BarSym0 t0123456789876543210 = Bar t0123456789876543210 diff --git a/tests/compile-and-dump/Promote/Newtypes.hs b/tests/compile-and-dump/Promote/Newtypes.hs deleted file mode 100644 --- a/tests/compile-and-dump/Promote/Newtypes.hs +++ /dev/null @@ -1,10 +0,0 @@ -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/Pragmas.ghc88.template b/tests/compile-and-dump/Promote/Pragmas.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Promote/Pragmas.ghc88.template +++ /dev/null @@ -1,12 +0,0 @@ -Promote/Pragmas.hs:(0,0)-(0,0): Splicing declarations - promote - [d| {-# INLINE foo #-} - foo :: Bool - foo = True |] - ======> - {-# INLINE foo #-} - foo :: Bool - foo = True - type FooSym0 = Foo - type family Foo :: Bool where - Foo = TrueSym0 diff --git a/tests/compile-and-dump/Promote/Pragmas.hs b/tests/compile-and-dump/Promote/Pragmas.hs deleted file mode 100644 --- a/tests/compile-and-dump/Promote/Pragmas.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Promote.Pragmas where - -import Data.Singletons.TH -import Data.Singletons.Prelude - -$(promote [d| - {-# INLINE foo #-} - foo :: Bool - foo = True - |]) diff --git a/tests/compile-and-dump/Promote/Prelude.ghc88.template b/tests/compile-and-dump/Promote/Prelude.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Promote/Prelude.ghc88.template +++ /dev/null @@ -1,19 +0,0 @@ -Promote/Prelude.hs:(0,0)-(0,0): Splicing declarations - promoteOnly - [d| odd :: Nat -> Bool - odd 0 = False - odd n = not . odd $ n - 1 |] - ======> - type OddSym1 (a0123456789876543210 :: Nat) = - Odd a0123456789876543210 - instance SuppressUnusedWarnings OddSym0 where - suppressUnusedWarnings = snd (((,) OddSym0KindInference) ()) - data OddSym0 :: (~>) Nat Bool - where - OddSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply OddSym0 arg) (OddSym1 arg) => - OddSym0 a0123456789876543210 - type instance Apply OddSym0 a0123456789876543210 = Odd a0123456789876543210 - type family Odd (a :: Nat) :: Bool where - Odd 0 = FalseSym0 - Odd n = Apply (Apply ($@#@$) (Apply (Apply (.@#@$) NotSym0) OddSym0)) (Apply (Apply (-@#@$) n) (FromInteger 1)) diff --git a/tests/compile-and-dump/Promote/Prelude.hs b/tests/compile-and-dump/Promote/Prelude.hs deleted file mode 100644 --- a/tests/compile-and-dump/Promote/Prelude.hs +++ /dev/null @@ -1,132 +0,0 @@ -module Promote.Prelude where - -import Data.Singletons.TH -import Data.Singletons.Prelude -import Data.Singletons.Prelude.List -import GHC.TypeLits - -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/T180.ghc88.template b/tests/compile-and-dump/Promote/T180.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Promote/T180.ghc88.template +++ /dev/null @@ -1,54 +0,0 @@ -Promote/T180.hs:(0,0)-(0,0): Splicing declarations - promote - [d| z (X1 x) = x - z (X2 x) = x - - data X = X1 {y :: Symbol} | X2 {y :: Symbol} |] - ======> - data X = X1 {y :: Symbol} | X2 {y :: Symbol} - z (X1 x) = x - z (X2 x) = x - type ZSym1 a0123456789876543210 = Z a0123456789876543210 - instance SuppressUnusedWarnings ZSym0 where - suppressUnusedWarnings = snd (((,) ZSym0KindInference) ()) - data ZSym0 a0123456789876543210 - where - ZSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply ZSym0 arg) (ZSym1 arg) => - ZSym0 a0123456789876543210 - type instance Apply ZSym0 a0123456789876543210 = Z a0123456789876543210 - type family Z a where - Z (X1 x) = x - Z (X2 x) = x - type YSym1 (a0123456789876543210 :: X) = Y a0123456789876543210 - instance SuppressUnusedWarnings YSym0 where - suppressUnusedWarnings = snd (((,) YSym0KindInference) ()) - data YSym0 :: (~>) X Symbol - where - YSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply YSym0 arg) (YSym1 arg) => - YSym0 a0123456789876543210 - type instance Apply YSym0 a0123456789876543210 = Y a0123456789876543210 - type family Y (a :: X) :: Symbol where - Y (X1 field) = field - Y (X2 field) = field - type X1Sym1 (t0123456789876543210 :: Symbol) = - X1 t0123456789876543210 - instance SuppressUnusedWarnings X1Sym0 where - suppressUnusedWarnings = snd (((,) X1Sym0KindInference) ()) - data X1Sym0 :: (~>) Symbol X - where - X1Sym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply X1Sym0 arg) (X1Sym1 arg) => - X1Sym0 t0123456789876543210 - type instance Apply X1Sym0 t0123456789876543210 = X1 t0123456789876543210 - type X2Sym1 (t0123456789876543210 :: Symbol) = - X2 t0123456789876543210 - instance SuppressUnusedWarnings X2Sym0 where - suppressUnusedWarnings = snd (((,) X2Sym0KindInference) ()) - data X2Sym0 :: (~>) Symbol X - where - X2Sym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply X2Sym0 arg) (X2Sym1 arg) => - X2Sym0 t0123456789876543210 - type instance Apply X2Sym0 t0123456789876543210 = X2 t0123456789876543210 diff --git a/tests/compile-and-dump/Promote/T180.hs b/tests/compile-and-dump/Promote/T180.hs deleted file mode 100644 --- a/tests/compile-and-dump/Promote/T180.hs +++ /dev/null @@ -1,10 +0,0 @@ -module T180 where - -import Data.Singletons.TH -import Data.Singletons.Prelude - -promote [d| - data X = X1 {y :: Symbol} | X2 {y :: Symbol} - z (X1 x) = x - z (X2 x) = x - |] diff --git a/tests/compile-and-dump/Promote/T361.ghc88.template b/tests/compile-and-dump/Promote/T361.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Promote/T361.ghc88.template +++ /dev/null @@ -1,21 +0,0 @@ -Promote/T361.hs:0:0:: Splicing declarations - genDefunSymbols [''Proxy] ======> type ProxySym0 = 'Proxy -Promote/T361.hs:(0,0)-(0,0): Splicing declarations - promote - [d| f :: Proxy 1 -> Proxy 2 - f Proxy = Proxy |] - ======> - f :: Proxy 1 -> Proxy 2 - f Proxy = Proxy - type FSym1 (a0123456789876543210 :: Proxy 1) = - F a0123456789876543210 - instance SuppressUnusedWarnings FSym0 where - suppressUnusedWarnings = snd (((,) FSym0KindInference) ()) - data FSym0 :: (~>) (Proxy 1) (Proxy 2) - where - FSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply FSym0 arg) (FSym1 arg) => - FSym0 a0123456789876543210 - type instance Apply FSym0 a0123456789876543210 = F a0123456789876543210 - type family F (a :: Proxy 1) :: Proxy 2 where - F 'Proxy = ProxySym0 diff --git a/tests/compile-and-dump/Promote/T361.hs b/tests/compile-and-dump/Promote/T361.hs deleted file mode 100644 --- a/tests/compile-and-dump/Promote/T361.hs +++ /dev/null @@ -1,11 +0,0 @@ -module T361 where - -import Data.Proxy -import Data.Singletons.TH - -$(genDefunSymbols [''Proxy]) - -$(promote [d| - f :: Proxy 1 -> Proxy 2 - f Proxy = Proxy - |]) diff --git a/tests/compile-and-dump/Singletons/AsPattern.ghc88.template b/tests/compile-and-dump/Singletons/AsPattern.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/AsPattern.ghc88.template +++ /dev/null @@ -1,395 +0,0 @@ -Singletons/AsPattern.hs:(0,0)-(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 |] - ======> - 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 - type BazSym3 (t0123456789876543210 :: Nat) (t0123456789876543210 :: Nat) (t0123456789876543210 :: Nat) = - Baz t0123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (BazSym2 t0123456789876543210 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) BazSym2KindInference) ()) - data BazSym2 (t0123456789876543210 :: Nat) (t0123456789876543210 :: Nat) :: (~>) Nat Baz - where - BazSym2KindInference :: forall t0123456789876543210 - t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (BazSym2 t0123456789876543210 t0123456789876543210) arg) (BazSym3 t0123456789876543210 t0123456789876543210 arg) => - BazSym2 t0123456789876543210 t0123456789876543210 t0123456789876543210 - type instance Apply (BazSym2 t0123456789876543210 t0123456789876543210) t0123456789876543210 = Baz t0123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (BazSym1 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) BazSym1KindInference) ()) - data BazSym1 (t0123456789876543210 :: Nat) :: (~>) Nat ((~>) Nat Baz) - where - BazSym1KindInference :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (BazSym1 t0123456789876543210) arg) (BazSym2 t0123456789876543210 arg) => - BazSym1 t0123456789876543210 t0123456789876543210 - type instance Apply (BazSym1 t0123456789876543210) t0123456789876543210 = BazSym2 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings BazSym0 where - suppressUnusedWarnings = snd (((,) BazSym0KindInference) ()) - data BazSym0 :: (~>) Nat ((~>) Nat ((~>) Nat Baz)) - where - BazSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply BazSym0 arg) (BazSym1 arg) => - BazSym0 t0123456789876543210 - type instance Apply BazSym0 t0123456789876543210 = BazSym1 t0123456789876543210 - type Let0123456789876543210PSym0 = Let0123456789876543210P - type family Let0123456789876543210P where - Let0123456789876543210P = '[] - type Let0123456789876543210PSym1 wild_01234567898765432100123456789876543210 = - Let0123456789876543210P wild_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210PSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210PSym0KindInference) ()) - data Let0123456789876543210PSym0 wild_01234567898765432100123456789876543210 - where - Let0123456789876543210PSym0KindInference :: forall wild_01234567898765432100123456789876543210 - arg. SameKind (Apply Let0123456789876543210PSym0 arg) (Let0123456789876543210PSym1 arg) => - Let0123456789876543210PSym0 wild_01234567898765432100123456789876543210 - type instance Apply Let0123456789876543210PSym0 wild_01234567898765432100123456789876543210 = Let0123456789876543210P wild_01234567898765432100123456789876543210 - type family Let0123456789876543210P wild_0123456789876543210 where - Let0123456789876543210P wild_0123456789876543210 = Apply (Apply (:@#@$) wild_0123456789876543210) '[] - type Let0123456789876543210PSym3 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 = - Let0123456789876543210P wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210PSym2 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210PSym2KindInference) ()) - data Let0123456789876543210PSym2 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 - where - Let0123456789876543210PSym2KindInference :: forall wild_01234567898765432100123456789876543210 - wild_01234567898765432100123456789876543210 - wild_01234567898765432100123456789876543210 - arg. SameKind (Apply (Let0123456789876543210PSym2 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210) arg) (Let0123456789876543210PSym3 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 arg) => - Let0123456789876543210PSym2 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 - type instance Apply (Let0123456789876543210PSym2 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210) wild_01234567898765432100123456789876543210 = Let0123456789876543210P wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210PSym1 wild_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210PSym1KindInference) ()) - data Let0123456789876543210PSym1 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 - where - Let0123456789876543210PSym1KindInference :: forall wild_01234567898765432100123456789876543210 - wild_01234567898765432100123456789876543210 - arg. SameKind (Apply (Let0123456789876543210PSym1 wild_01234567898765432100123456789876543210) arg) (Let0123456789876543210PSym2 wild_01234567898765432100123456789876543210 arg) => - Let0123456789876543210PSym1 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 - type instance Apply (Let0123456789876543210PSym1 wild_01234567898765432100123456789876543210) wild_01234567898765432100123456789876543210 = Let0123456789876543210PSym2 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210PSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210PSym0KindInference) ()) - data Let0123456789876543210PSym0 wild_01234567898765432100123456789876543210 - where - Let0123456789876543210PSym0KindInference :: forall wild_01234567898765432100123456789876543210 - arg. SameKind (Apply Let0123456789876543210PSym0 arg) (Let0123456789876543210PSym1 arg) => - Let0123456789876543210PSym0 wild_01234567898765432100123456789876543210 - type instance Apply Let0123456789876543210PSym0 wild_01234567898765432100123456789876543210 = Let0123456789876543210PSym1 wild_01234567898765432100123456789876543210 - type family Let0123456789876543210P wild_0123456789876543210 wild_0123456789876543210 wild_0123456789876543210 where - Let0123456789876543210P wild_0123456789876543210 wild_0123456789876543210 wild_0123456789876543210 = Apply (Apply (:@#@$) wild_0123456789876543210) (Apply (Apply (:@#@$) wild_0123456789876543210) wild_0123456789876543210) - type Let0123456789876543210PSym2 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 = - Let0123456789876543210P wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210PSym1 wild_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210PSym1KindInference) ()) - data Let0123456789876543210PSym1 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 - where - Let0123456789876543210PSym1KindInference :: forall wild_01234567898765432100123456789876543210 - wild_01234567898765432100123456789876543210 - arg. SameKind (Apply (Let0123456789876543210PSym1 wild_01234567898765432100123456789876543210) arg) (Let0123456789876543210PSym2 wild_01234567898765432100123456789876543210 arg) => - Let0123456789876543210PSym1 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 - type instance Apply (Let0123456789876543210PSym1 wild_01234567898765432100123456789876543210) wild_01234567898765432100123456789876543210 = Let0123456789876543210P wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210PSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210PSym0KindInference) ()) - data Let0123456789876543210PSym0 wild_01234567898765432100123456789876543210 - where - Let0123456789876543210PSym0KindInference :: forall wild_01234567898765432100123456789876543210 - arg. SameKind (Apply Let0123456789876543210PSym0 arg) (Let0123456789876543210PSym1 arg) => - Let0123456789876543210PSym0 wild_01234567898765432100123456789876543210 - type instance Apply Let0123456789876543210PSym0 wild_01234567898765432100123456789876543210 = Let0123456789876543210PSym1 wild_01234567898765432100123456789876543210 - type family Let0123456789876543210P wild_0123456789876543210 wild_0123456789876543210 where - Let0123456789876543210P wild_0123456789876543210 wild_0123456789876543210 = Apply (Apply Tuple2Sym0 wild_0123456789876543210) wild_0123456789876543210 - type Let0123456789876543210PSym0 = Let0123456789876543210P - type family Let0123456789876543210P where - Let0123456789876543210P = NothingSym0 - type Let0123456789876543210PSym3 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 = - Let0123456789876543210P wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210PSym2 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210PSym2KindInference) ()) - data Let0123456789876543210PSym2 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 - where - Let0123456789876543210PSym2KindInference :: forall wild_01234567898765432100123456789876543210 - wild_01234567898765432100123456789876543210 - wild_01234567898765432100123456789876543210 - arg. SameKind (Apply (Let0123456789876543210PSym2 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210) arg) (Let0123456789876543210PSym3 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 arg) => - Let0123456789876543210PSym2 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 - type instance Apply (Let0123456789876543210PSym2 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210) wild_01234567898765432100123456789876543210 = Let0123456789876543210P wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210PSym1 wild_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210PSym1KindInference) ()) - data Let0123456789876543210PSym1 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 - where - Let0123456789876543210PSym1KindInference :: forall wild_01234567898765432100123456789876543210 - wild_01234567898765432100123456789876543210 - arg. SameKind (Apply (Let0123456789876543210PSym1 wild_01234567898765432100123456789876543210) arg) (Let0123456789876543210PSym2 wild_01234567898765432100123456789876543210 arg) => - Let0123456789876543210PSym1 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 - type instance Apply (Let0123456789876543210PSym1 wild_01234567898765432100123456789876543210) wild_01234567898765432100123456789876543210 = Let0123456789876543210PSym2 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210PSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210PSym0KindInference) ()) - data Let0123456789876543210PSym0 wild_01234567898765432100123456789876543210 - where - Let0123456789876543210PSym0KindInference :: forall wild_01234567898765432100123456789876543210 - arg. SameKind (Apply Let0123456789876543210PSym0 arg) (Let0123456789876543210PSym1 arg) => - Let0123456789876543210PSym0 wild_01234567898765432100123456789876543210 - type instance Apply Let0123456789876543210PSym0 wild_01234567898765432100123456789876543210 = Let0123456789876543210PSym1 wild_01234567898765432100123456789876543210 - type family Let0123456789876543210P wild_0123456789876543210 wild_0123456789876543210 wild_0123456789876543210 where - Let0123456789876543210P wild_0123456789876543210 wild_0123456789876543210 wild_0123456789876543210 = Apply JustSym0 (Apply (Apply (Apply BazSym0 wild_0123456789876543210) wild_0123456789876543210) wild_0123456789876543210) - type Let0123456789876543210XSym1 wild_01234567898765432100123456789876543210 = - Let0123456789876543210X wild_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210XSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210XSym0KindInference) ()) - data Let0123456789876543210XSym0 wild_01234567898765432100123456789876543210 - where - Let0123456789876543210XSym0KindInference :: forall wild_01234567898765432100123456789876543210 - arg. SameKind (Apply Let0123456789876543210XSym0 arg) (Let0123456789876543210XSym1 arg) => - Let0123456789876543210XSym0 wild_01234567898765432100123456789876543210 - type instance Apply Let0123456789876543210XSym0 wild_01234567898765432100123456789876543210 = Let0123456789876543210X wild_01234567898765432100123456789876543210 - type family Let0123456789876543210X wild_0123456789876543210 where - Let0123456789876543210X wild_0123456789876543210 = Apply JustSym0 wild_0123456789876543210 - type Let0123456789876543210PSym0 = Let0123456789876543210P - type family Let0123456789876543210P where - Let0123456789876543210P = NothingSym0 - type FooSym1 (a0123456789876543210 :: [Nat]) = - Foo a0123456789876543210 - instance SuppressUnusedWarnings FooSym0 where - suppressUnusedWarnings = snd (((,) FooSym0KindInference) ()) - data FooSym0 :: (~>) [Nat] [Nat] - where - FooSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply FooSym0 arg) (FooSym1 arg) => - FooSym0 a0123456789876543210 - type instance Apply FooSym0 a0123456789876543210 = Foo a0123456789876543210 - type TupSym1 (a0123456789876543210 :: (Nat, Nat)) = - Tup a0123456789876543210 - instance SuppressUnusedWarnings TupSym0 where - suppressUnusedWarnings = snd (((,) TupSym0KindInference) ()) - data TupSym0 :: (~>) (Nat, Nat) (Nat, Nat) - where - TupSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply TupSym0 arg) (TupSym1 arg) => - TupSym0 a0123456789876543210 - type instance Apply TupSym0 a0123456789876543210 = Tup a0123456789876543210 - type Baz_Sym1 (a0123456789876543210 :: Maybe Baz) = - Baz_ a0123456789876543210 - instance SuppressUnusedWarnings Baz_Sym0 where - suppressUnusedWarnings = snd (((,) Baz_Sym0KindInference) ()) - data Baz_Sym0 :: (~>) (Maybe Baz) (Maybe Baz) - where - Baz_Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Baz_Sym0 arg) (Baz_Sym1 arg) => - Baz_Sym0 a0123456789876543210 - type instance Apply Baz_Sym0 a0123456789876543210 = Baz_ a0123456789876543210 - type BarSym1 (a0123456789876543210 :: Maybe Nat) = - Bar a0123456789876543210 - instance SuppressUnusedWarnings BarSym0 where - suppressUnusedWarnings = snd (((,) BarSym0KindInference) ()) - data BarSym0 :: (~>) (Maybe Nat) (Maybe Nat) - where - BarSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply BarSym0 arg) (BarSym1 arg) => - BarSym0 a0123456789876543210 - type instance Apply BarSym0 a0123456789876543210 = Bar a0123456789876543210 - type MaybePlusSym1 (a0123456789876543210 :: Maybe Nat) = - MaybePlus a0123456789876543210 - instance SuppressUnusedWarnings MaybePlusSym0 where - suppressUnusedWarnings = snd (((,) MaybePlusSym0KindInference) ()) - data MaybePlusSym0 :: (~>) (Maybe Nat) (Maybe Nat) - where - MaybePlusSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply MaybePlusSym0 arg) (MaybePlusSym1 arg) => - MaybePlusSym0 a0123456789876543210 - type instance Apply MaybePlusSym0 a0123456789876543210 = MaybePlus a0123456789876543210 - type family Foo (a :: [Nat]) :: [Nat] where - Foo '[] = Let0123456789876543210PSym0 - Foo '[wild_0123456789876543210] = Let0123456789876543210PSym1 wild_0123456789876543210 - Foo ('(:) wild_0123456789876543210 ('(:) wild_0123456789876543210 wild_0123456789876543210)) = Let0123456789876543210PSym3 wild_0123456789876543210 wild_0123456789876543210 wild_0123456789876543210 - type family Tup (a :: (Nat, Nat)) :: (Nat, Nat) where - Tup '(wild_0123456789876543210, - wild_0123456789876543210) = Let0123456789876543210PSym2 wild_0123456789876543210 wild_0123456789876543210 - type family Baz_ (a :: Maybe Baz) :: Maybe Baz where - Baz_ 'Nothing = Let0123456789876543210PSym0 - Baz_ ('Just (Baz wild_0123456789876543210 wild_0123456789876543210 wild_0123456789876543210)) = Let0123456789876543210PSym3 wild_0123456789876543210 wild_0123456789876543210 wild_0123456789876543210 - type family Bar (a :: Maybe Nat) :: Maybe Nat where - Bar ('Just wild_0123456789876543210) = Let0123456789876543210XSym1 wild_0123456789876543210 - 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 = Let0123456789876543210PSym0 - sFoo :: - forall (t :: [Nat]). Sing t -> Sing (Apply FooSym0 t :: [Nat]) - sTup :: - forall (t :: (Nat, Nat)). - Sing t -> Sing (Apply TupSym0 t :: (Nat, Nat)) - sBaz_ :: - forall (t :: Maybe Baz). - Sing t -> Sing (Apply Baz_Sym0 t :: Maybe Baz) - sBar :: - forall (t :: Maybe Nat). - Sing t -> Sing (Apply BarSym0 t :: Maybe Nat) - sMaybePlus :: - forall (t :: Maybe Nat). - Sing t -> Sing (Apply MaybePlusSym0 t :: Maybe Nat) - sFoo SNil - = let - sP :: Sing Let0123456789876543210PSym0 - sP = SNil - in sP - sFoo - (SCons (sWild_0123456789876543210 :: Sing wild_0123456789876543210) - SNil) - = let - sP :: Sing (Let0123456789876543210PSym1 wild_0123456789876543210) - sP - = (applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - sWild_0123456789876543210)) - SNil - in sP - sFoo - (SCons (sWild_0123456789876543210 :: Sing wild_0123456789876543210) - (SCons (sWild_0123456789876543210 :: Sing wild_0123456789876543210) - (sWild_0123456789876543210 :: Sing wild_0123456789876543210))) - = let - sP :: - Sing (Let0123456789876543210PSym3 wild_0123456789876543210 wild_0123456789876543210 wild_0123456789876543210) - sP - = (applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - sWild_0123456789876543210)) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - sWild_0123456789876543210)) - sWild_0123456789876543210) - in sP - sTup - (STuple2 (sWild_0123456789876543210 :: Sing wild_0123456789876543210) - (sWild_0123456789876543210 :: Sing wild_0123456789876543210)) - = let - sP :: - Sing (Let0123456789876543210PSym2 wild_0123456789876543210 wild_0123456789876543210) - sP - = (applySing - ((applySing ((singFun2 @Tuple2Sym0) STuple2)) - sWild_0123456789876543210)) - sWild_0123456789876543210 - in sP - sBaz_ SNothing - = let - sP :: Sing Let0123456789876543210PSym0 - sP = SNothing - in sP - sBaz_ - (SJust (SBaz (sWild_0123456789876543210 :: Sing wild_0123456789876543210) - (sWild_0123456789876543210 :: Sing wild_0123456789876543210) - (sWild_0123456789876543210 :: Sing wild_0123456789876543210))) - = let - sP :: - Sing (Let0123456789876543210PSym3 wild_0123456789876543210 wild_0123456789876543210 wild_0123456789876543210) - sP - = (applySing ((singFun1 @JustSym0) SJust)) - ((applySing - ((applySing - ((applySing ((singFun3 @BazSym0) SBaz)) sWild_0123456789876543210)) - sWild_0123456789876543210)) - sWild_0123456789876543210) - in sP - sBar - (SJust (sWild_0123456789876543210 :: Sing wild_0123456789876543210)) - = let - sX :: Sing (Let0123456789876543210XSym1 wild_0123456789876543210) - sX - = (applySing ((singFun1 @JustSym0) SJust)) - sWild_0123456789876543210 - in sX - sBar SNothing = SNothing - sMaybePlus (SJust (sN :: Sing n)) - = (applySing ((singFun1 @JustSym0) SJust)) - ((applySing - ((applySing ((singFun2 @PlusSym0) sPlus)) - ((applySing ((singFun1 @SuccSym0) SSucc)) SZero))) - sN) - sMaybePlus SNothing - = let - sP :: Sing Let0123456789876543210PSym0 - sP = SNothing - in sP - instance SingI (FooSym0 :: (~>) [Nat] [Nat]) where - sing = (singFun1 @FooSym0) sFoo - instance SingI (TupSym0 :: (~>) (Nat, Nat) (Nat, Nat)) where - sing = (singFun1 @TupSym0) sTup - instance SingI (Baz_Sym0 :: (~>) (Maybe Baz) (Maybe Baz)) where - sing = (singFun1 @Baz_Sym0) sBaz_ - instance SingI (BarSym0 :: (~>) (Maybe Nat) (Maybe Nat)) where - sing = (singFun1 @BarSym0) sBar - instance SingI (MaybePlusSym0 :: (~>) (Maybe Nat) (Maybe Nat)) where - sing = (singFun1 @MaybePlusSym0) sMaybePlus - data SBaz :: Baz -> GHC.Types.Type - where - SBaz :: forall (n :: Nat) (n :: Nat) (n :: Nat). - (Sing (n :: Nat)) - -> (Sing (n :: Nat)) -> (Sing (n :: Nat)) -> SBaz (Baz n n n) - type instance Sing @Baz = SBaz - instance SingKind Baz where - type Demote Baz = Baz - fromSing (SBaz b b b) - = ((Baz (fromSing b)) (fromSing b)) (fromSing b) - toSing (Baz (b :: Demote Nat) (b :: Demote Nat) (b :: Demote Nat)) - = case - (((,,) (toSing b :: SomeSing Nat)) (toSing b :: SomeSing Nat)) - (toSing b :: SomeSing 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 - instance SingI (BazSym0 :: (~>) Nat ((~>) Nat ((~>) Nat Baz))) where - sing = (singFun3 @BazSym0) SBaz - instance SingI d => - SingI (BazSym1 (d :: Nat) :: (~>) Nat ((~>) Nat Baz)) where - sing = (singFun2 @(BazSym1 (d :: Nat))) (SBaz (sing @d)) - instance (SingI d, SingI d) => - SingI (BazSym2 (d :: Nat) (d :: Nat) :: (~>) Nat Baz) where - sing - = (singFun1 @(BazSym2 (d :: Nat) (d :: Nat))) - ((SBaz (sing @d)) (sing @d)) diff --git a/tests/compile-and-dump/Singletons/AsPattern.hs b/tests/compile-and-dump/Singletons/AsPattern.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/AsPattern.hs +++ /dev/null @@ -1,32 +0,0 @@ -module Singletons.AsPattern where - -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/BadBoundedDeriving.ghc88.template b/tests/compile-and-dump/Singletons/BadBoundedDeriving.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/BadBoundedDeriving.ghc88.template +++ /dev/null @@ -1,6 +0,0 @@ - -Singletons/BadBoundedDeriving.hs:0:0: error: - Can't derive Bounded instance for Foo_0 a_1. - | -5 | $(singletons [d| - | ^^^^^^^^^^^^^^... diff --git a/tests/compile-and-dump/Singletons/BadBoundedDeriving.hs b/tests/compile-and-dump/Singletons/BadBoundedDeriving.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/BadBoundedDeriving.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Singletons.BadBoundedDeriving where - -import Data.Singletons.TH - -$(singletons [d| - data Foo a = Foo | Bar a deriving (Bounded) - |]) diff --git a/tests/compile-and-dump/Singletons/BadEnumDeriving.ghc88.template b/tests/compile-and-dump/Singletons/BadEnumDeriving.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/BadEnumDeriving.ghc88.template +++ /dev/null @@ -1,6 +0,0 @@ - -Singletons/BadEnumDeriving.hs:0:0: error: - Can't derive Enum instance for Foo_0 a_1. - | -5 | $(singletons [d| - | ^^^^^^^^^^^^^^... diff --git a/tests/compile-and-dump/Singletons/BadEnumDeriving.hs b/tests/compile-and-dump/Singletons/BadEnumDeriving.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/BadEnumDeriving.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Singletons.BadEnumDeriving where - -import Data.Singletons.TH - -$(singletons [d| - data Foo a = Foo a - deriving Enum - |]) diff --git a/tests/compile-and-dump/Singletons/BoundedDeriving.ghc88.template b/tests/compile-and-dump/Singletons/BoundedDeriving.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/BoundedDeriving.ghc88.template +++ /dev/null @@ -1,242 +0,0 @@ -Singletons/BoundedDeriving.hs:(0,0)-(0,0): Splicing declarations - singletons - [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 :: Type) (b :: Type) - = Foo41 | Foo42 - deriving Bounded - data Pair - = Pair Bool Bool - deriving Bounded |] - ======> - data Foo1 - = Foo1 - deriving Bounded - data Foo2 - = A | B | C | D | E - deriving Bounded - data Foo3 a - = Foo3 a - deriving Bounded - data Foo4 (a :: Type) (b :: Type) - = Foo41 | Foo42 - deriving Bounded - data Pair - = Pair Bool Bool - deriving Bounded - type Foo1Sym0 = Foo1 - type ASym0 = A - type BSym0 = B - type CSym0 = C - type DSym0 = D - type ESym0 = E - type Foo3Sym1 (t0123456789876543210 :: a0123456789876543210) = - Foo3 t0123456789876543210 - instance SuppressUnusedWarnings Foo3Sym0 where - suppressUnusedWarnings = snd (((,) Foo3Sym0KindInference) ()) - data Foo3Sym0 :: forall a0123456789876543210. - (~>) a0123456789876543210 (Foo3 a0123456789876543210) - where - Foo3Sym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply Foo3Sym0 arg) (Foo3Sym1 arg) => - Foo3Sym0 t0123456789876543210 - type instance Apply Foo3Sym0 t0123456789876543210 = Foo3 t0123456789876543210 - type Foo41Sym0 = Foo41 - type Foo42Sym0 = Foo42 - type PairSym2 (t0123456789876543210 :: Bool) (t0123456789876543210 :: Bool) = - Pair t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (PairSym1 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) PairSym1KindInference) ()) - data PairSym1 (t0123456789876543210 :: Bool) :: (~>) Bool Pair - where - PairSym1KindInference :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (PairSym1 t0123456789876543210) arg) (PairSym2 t0123456789876543210 arg) => - PairSym1 t0123456789876543210 t0123456789876543210 - type instance Apply (PairSym1 t0123456789876543210) t0123456789876543210 = Pair t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings PairSym0 where - suppressUnusedWarnings = snd (((,) PairSym0KindInference) ()) - data PairSym0 :: (~>) Bool ((~>) Bool Pair) - where - PairSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply PairSym0 arg) (PairSym1 arg) => - PairSym0 t0123456789876543210 - type instance Apply PairSym0 t0123456789876543210 = PairSym1 t0123456789876543210 - type family MinBound_0123456789876543210 :: Foo1 where - MinBound_0123456789876543210 = Foo1Sym0 - type MinBound_0123456789876543210Sym0 = - MinBound_0123456789876543210 - type family MaxBound_0123456789876543210 :: Foo1 where - MaxBound_0123456789876543210 = Foo1Sym0 - type MaxBound_0123456789876543210Sym0 = - MaxBound_0123456789876543210 - instance PBounded Foo1 where - type MinBound = MinBound_0123456789876543210Sym0 - type MaxBound = MaxBound_0123456789876543210Sym0 - type family MinBound_0123456789876543210 :: Foo2 where - MinBound_0123456789876543210 = ASym0 - type MinBound_0123456789876543210Sym0 = - MinBound_0123456789876543210 - type family MaxBound_0123456789876543210 :: Foo2 where - MaxBound_0123456789876543210 = ESym0 - type MaxBound_0123456789876543210Sym0 = - MaxBound_0123456789876543210 - instance PBounded Foo2 where - type MinBound = MinBound_0123456789876543210Sym0 - type MaxBound = MaxBound_0123456789876543210Sym0 - type family MinBound_0123456789876543210 :: Foo3 a where - MinBound_0123456789876543210 = Apply Foo3Sym0 MinBoundSym0 - type MinBound_0123456789876543210Sym0 = - MinBound_0123456789876543210 - type family MaxBound_0123456789876543210 :: Foo3 a where - MaxBound_0123456789876543210 = Apply Foo3Sym0 MaxBoundSym0 - type MaxBound_0123456789876543210Sym0 = - MaxBound_0123456789876543210 - instance PBounded (Foo3 a) where - type MinBound = MinBound_0123456789876543210Sym0 - type MaxBound = MaxBound_0123456789876543210Sym0 - type family MinBound_0123456789876543210 :: Foo4 a b where - MinBound_0123456789876543210 = Foo41Sym0 - type MinBound_0123456789876543210Sym0 = - MinBound_0123456789876543210 - type family MaxBound_0123456789876543210 :: Foo4 a b where - MaxBound_0123456789876543210 = Foo42Sym0 - type MaxBound_0123456789876543210Sym0 = - MaxBound_0123456789876543210 - instance PBounded (Foo4 a b) where - type MinBound = MinBound_0123456789876543210Sym0 - type MaxBound = MaxBound_0123456789876543210Sym0 - type family MinBound_0123456789876543210 :: Pair where - MinBound_0123456789876543210 = Apply (Apply PairSym0 MinBoundSym0) MinBoundSym0 - type MinBound_0123456789876543210Sym0 = - MinBound_0123456789876543210 - type family MaxBound_0123456789876543210 :: Pair where - MaxBound_0123456789876543210 = Apply (Apply PairSym0 MaxBoundSym0) MaxBoundSym0 - type MaxBound_0123456789876543210Sym0 = - MaxBound_0123456789876543210 - instance PBounded Pair where - type MinBound = MinBound_0123456789876543210Sym0 - type MaxBound = MaxBound_0123456789876543210Sym0 - data SFoo1 :: Foo1 -> Type where SFoo1 :: SFoo1 Foo1 - type instance Sing @Foo1 = SFoo1 - instance SingKind Foo1 where - type Demote Foo1 = Foo1 - fromSing SFoo1 = Foo1 - toSing Foo1 = SomeSing SFoo1 - data SFoo2 :: Foo2 -> Type - where - SA :: SFoo2 A - SB :: SFoo2 B - SC :: SFoo2 C - SD :: SFoo2 D - SE :: SFoo2 E - type instance Sing @Foo2 = SFoo2 - instance SingKind Foo2 where - type Demote Foo2 = Foo2 - fromSing SA = A - fromSing SB = B - fromSing SC = C - fromSing SD = D - fromSing SE = E - toSing A = SomeSing SA - toSing B = SomeSing SB - toSing C = SomeSing SC - toSing D = SomeSing SD - toSing E = SomeSing SE - data SFoo3 :: forall a. Foo3 a -> Type - where SFoo3 :: forall a (n :: a). (Sing (n :: a)) -> SFoo3 (Foo3 n) - type instance Sing @(Foo3 a) = SFoo3 - instance SingKind a => SingKind (Foo3 a) where - type Demote (Foo3 a) = Foo3 (Demote a) - fromSing (SFoo3 b) = Foo3 (fromSing b) - toSing (Foo3 (b :: Demote a)) - = case toSing b :: SomeSing a of { - SomeSing c -> SomeSing (SFoo3 c) } - data SFoo4 :: forall a b. Foo4 a b -> Type - where - SFoo41 :: SFoo4 Foo41 - SFoo42 :: SFoo4 Foo42 - type instance Sing @(Foo4 a b) = SFoo4 - instance (SingKind a, SingKind b) => SingKind (Foo4 a b) where - type Demote (Foo4 a b) = Foo4 (Demote a) (Demote b) - fromSing SFoo41 = Foo41 - fromSing SFoo42 = Foo42 - toSing Foo41 = SomeSing SFoo41 - toSing Foo42 = SomeSing SFoo42 - data SPair :: Pair -> Type - where - SPair :: forall (n :: Bool) (n :: Bool). - (Sing (n :: Bool)) -> (Sing (n :: Bool)) -> SPair (Pair n n) - type instance Sing @Pair = SPair - instance SingKind Pair where - type Demote Pair = Pair - fromSing (SPair b b) = (Pair (fromSing b)) (fromSing b) - toSing (Pair (b :: Demote Bool) (b :: Demote Bool)) - = case - ((,) (toSing b :: SomeSing Bool)) (toSing b :: SomeSing Bool) - of { - (,) (SomeSing c) (SomeSing c) -> SomeSing ((SPair c) c) } - instance SBounded Foo1 where - sMinBound :: Sing (MinBoundSym0 :: Foo1) - sMaxBound :: Sing (MaxBoundSym0 :: Foo1) - sMinBound = SFoo1 - sMaxBound = SFoo1 - instance SBounded Foo2 where - sMinBound :: Sing (MinBoundSym0 :: Foo2) - sMaxBound :: Sing (MaxBoundSym0 :: Foo2) - sMinBound = SA - sMaxBound = SE - instance SBounded a => SBounded (Foo3 a) where - sMinBound :: Sing (MinBoundSym0 :: Foo3 a) - sMaxBound :: Sing (MaxBoundSym0 :: Foo3 a) - sMinBound = (applySing ((singFun1 @Foo3Sym0) SFoo3)) sMinBound - sMaxBound = (applySing ((singFun1 @Foo3Sym0) SFoo3)) sMaxBound - instance SBounded (Foo4 a b) where - sMinBound :: Sing (MinBoundSym0 :: Foo4 a b) - sMaxBound :: Sing (MaxBoundSym0 :: Foo4 a b) - sMinBound = SFoo41 - sMaxBound = SFoo42 - instance SBounded Bool => SBounded Pair where - sMinBound :: Sing (MinBoundSym0 :: Pair) - sMaxBound :: Sing (MaxBoundSym0 :: Pair) - sMinBound - = (applySing ((applySing ((singFun2 @PairSym0) SPair)) sMinBound)) - sMinBound - sMaxBound - = (applySing ((applySing ((singFun2 @PairSym0) SPair)) sMaxBound)) - sMaxBound - instance SingI Foo1 where - sing = SFoo1 - instance SingI A where - sing = SA - instance SingI B where - sing = SB - instance SingI C where - sing = SC - instance SingI D where - sing = SD - instance SingI E where - sing = SE - instance SingI n => SingI (Foo3 (n :: a)) where - sing = SFoo3 sing - instance SingI (Foo3Sym0 :: (~>) a (Foo3 a)) where - sing = (singFun1 @Foo3Sym0) SFoo3 - instance SingI Foo41 where - sing = SFoo41 - instance SingI Foo42 where - sing = SFoo42 - instance (SingI n, SingI n) => - SingI (Pair (n :: Bool) (n :: Bool)) where - sing = (SPair sing) sing - instance SingI (PairSym0 :: (~>) Bool ((~>) Bool Pair)) where - sing = (singFun2 @PairSym0) SPair - instance SingI d => - SingI (PairSym1 (d :: Bool) :: (~>) Bool Pair) where - sing = (singFun1 @(PairSym1 (d :: Bool))) (SPair (sing @d)) diff --git a/tests/compile-and-dump/Singletons/BoundedDeriving.hs b/tests/compile-and-dump/Singletons/BoundedDeriving.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/BoundedDeriving.hs +++ /dev/null @@ -1,52 +0,0 @@ -module Singletons.BoundedDeriving where - -import Data.Singletons.Prelude -import Data.Singletons.TH -import Data.Kind (Type) - -$(singletons [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 :: Type) (b :: Type) = 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/Singletons/BoxUnBox.ghc88.template b/tests/compile-and-dump/Singletons/BoxUnBox.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/BoxUnBox.ghc88.template +++ /dev/null @@ -1,52 +0,0 @@ -Singletons/BoxUnBox.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| unBox :: Box a -> a - unBox (FBox a) = a - - data Box a = FBox a |] - ======> - data Box a = FBox a - unBox :: Box a -> a - unBox (FBox a) = a - type FBoxSym1 (t0123456789876543210 :: a0123456789876543210) = - FBox t0123456789876543210 - instance SuppressUnusedWarnings FBoxSym0 where - suppressUnusedWarnings = snd (((,) FBoxSym0KindInference) ()) - data FBoxSym0 :: forall a0123456789876543210. - (~>) a0123456789876543210 (Box a0123456789876543210) - where - FBoxSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply FBoxSym0 arg) (FBoxSym1 arg) => - FBoxSym0 t0123456789876543210 - type instance Apply FBoxSym0 t0123456789876543210 = FBox t0123456789876543210 - type UnBoxSym1 (a0123456789876543210 :: Box a0123456789876543210) = - UnBox a0123456789876543210 - instance SuppressUnusedWarnings UnBoxSym0 where - suppressUnusedWarnings = snd (((,) UnBoxSym0KindInference) ()) - data UnBoxSym0 :: forall a0123456789876543210. - (~>) (Box a0123456789876543210) a0123456789876543210 - where - UnBoxSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply UnBoxSym0 arg) (UnBoxSym1 arg) => - UnBoxSym0 a0123456789876543210 - type instance Apply UnBoxSym0 a0123456789876543210 = UnBox a0123456789876543210 - type family UnBox (a :: Box a) :: a where - UnBox (FBox a) = a - sUnBox :: - forall a (t :: Box a). Sing t -> Sing (Apply UnBoxSym0 t :: a) - sUnBox (SFBox (sA :: Sing a)) = sA - instance SingI (UnBoxSym0 :: (~>) (Box a) a) where - sing = (singFun1 @UnBoxSym0) sUnBox - data SBox :: forall a. Box a -> GHC.Types.Type - where SFBox :: forall a (n :: a). (Sing (n :: a)) -> SBox (FBox n) - type instance Sing @(Box a) = SBox - instance SingKind a => SingKind (Box a) where - type Demote (Box a) = Box (Demote a) - fromSing (SFBox b) = FBox (fromSing b) - toSing (FBox (b :: Demote a)) - = case toSing b :: SomeSing a of { - SomeSing c -> SomeSing (SFBox c) } - instance SingI n => SingI (FBox (n :: a)) where - sing = SFBox sing - instance SingI (FBoxSym0 :: (~>) a (Box a)) where - sing = (singFun1 @FBoxSym0) SFBox diff --git a/tests/compile-and-dump/Singletons/BoxUnBox.hs b/tests/compile-and-dump/Singletons/BoxUnBox.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/BoxUnBox.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Singletons.BoxUnBox where - -import Data.Singletons.TH -import Data.Singletons.SuppressUnusedWarnings - -$(singletons [d| - data Box a = FBox a - unBox :: Box a -> a - unBox (FBox a) = a - |]) diff --git a/tests/compile-and-dump/Singletons/CaseExpressions.ghc88.template b/tests/compile-and-dump/Singletons/CaseExpressions.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/CaseExpressions.ghc88.template +++ /dev/null @@ -1,324 +0,0 @@ -Singletons/CaseExpressions.hs:(0,0)-(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 } |] - ======> - 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 } - type family Case_0123456789876543210 arg_0123456789876543210 y x t where - Case_0123456789876543210 arg_0123456789876543210 y x _ = x - type family Lambda_0123456789876543210 y x t where - Lambda_0123456789876543210 y x arg_0123456789876543210 = Case_0123456789876543210 arg_0123456789876543210 y x arg_0123456789876543210 - type Lambda_0123456789876543210Sym3 y0123456789876543210 x0123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 y0123456789876543210 x0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 y0123456789876543210 x0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall y0123456789876543210 - x0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 y0123456789876543210 x0123456789876543210) arg) (Lambda_0123456789876543210Sym3 y0123456789876543210 x0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 y0123456789876543210 x0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 x0123456789876543210 y0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 y0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 y0123456789876543210 x0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall y0123456789876543210 - x0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 y0123456789876543210) arg) (Lambda_0123456789876543210Sym2 y0123456789876543210 arg) => - Lambda_0123456789876543210Sym1 y0123456789876543210 x0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 y0123456789876543210) x0123456789876543210 = Lambda_0123456789876543210Sym2 y0123456789876543210 x0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 y0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall y0123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 y0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 y0123456789876543210 = Lambda_0123456789876543210Sym1 y0123456789876543210 - type family Case_0123456789876543210 x t where - Case_0123456789876543210 x y = Apply (Apply (Apply Lambda_0123456789876543210Sym0 y) x) y - type Let0123456789876543210ZSym2 y0123456789876543210 x0123456789876543210 = - Let0123456789876543210Z y0123456789876543210 x0123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210ZSym1 y0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210ZSym1KindInference) ()) - data Let0123456789876543210ZSym1 y0123456789876543210 x0123456789876543210 - where - Let0123456789876543210ZSym1KindInference :: forall y0123456789876543210 - x0123456789876543210 - arg. SameKind (Apply (Let0123456789876543210ZSym1 y0123456789876543210) arg) (Let0123456789876543210ZSym2 y0123456789876543210 arg) => - Let0123456789876543210ZSym1 y0123456789876543210 x0123456789876543210 - type instance Apply (Let0123456789876543210ZSym1 y0123456789876543210) x0123456789876543210 = Let0123456789876543210Z y0123456789876543210 x0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210ZSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210ZSym0KindInference) ()) - data Let0123456789876543210ZSym0 y0123456789876543210 - where - Let0123456789876543210ZSym0KindInference :: forall y0123456789876543210 - arg. SameKind (Apply Let0123456789876543210ZSym0 arg) (Let0123456789876543210ZSym1 arg) => - Let0123456789876543210ZSym0 y0123456789876543210 - type instance Apply Let0123456789876543210ZSym0 y0123456789876543210 = Let0123456789876543210ZSym1 y0123456789876543210 - type family Let0123456789876543210Z y x :: a where - Let0123456789876543210Z y x = y - type family Case_0123456789876543210 x t where - Case_0123456789876543210 x y = Let0123456789876543210ZSym2 y x - type Let0123456789876543210Scrutinee_0123456789876543210Sym2 a0123456789876543210 b0123456789876543210 = - Let0123456789876543210Scrutinee_0123456789876543210 a0123456789876543210 b0123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210Scrutinee_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd - (((,) - Let0123456789876543210Scrutinee_0123456789876543210Sym1KindInference) - ()) - data Let0123456789876543210Scrutinee_0123456789876543210Sym1 a0123456789876543210 b0123456789876543210 - where - Let0123456789876543210Scrutinee_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - b0123456789876543210 - arg. SameKind (Apply (Let0123456789876543210Scrutinee_0123456789876543210Sym1 a0123456789876543210) arg) (Let0123456789876543210Scrutinee_0123456789876543210Sym2 a0123456789876543210 arg) => - Let0123456789876543210Scrutinee_0123456789876543210Sym1 a0123456789876543210 b0123456789876543210 - type instance Apply (Let0123456789876543210Scrutinee_0123456789876543210Sym1 a0123456789876543210) b0123456789876543210 = Let0123456789876543210Scrutinee_0123456789876543210 a0123456789876543210 b0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210Scrutinee_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd - (((,) - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference) - ()) - data Let0123456789876543210Scrutinee_0123456789876543210Sym0 a0123456789876543210 - where - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 arg) (Let0123456789876543210Scrutinee_0123456789876543210Sym1 arg) => - Let0123456789876543210Scrutinee_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 a0123456789876543210 = Let0123456789876543210Scrutinee_0123456789876543210Sym1 a0123456789876543210 - type family Let0123456789876543210Scrutinee_0123456789876543210 a b where - Let0123456789876543210Scrutinee_0123456789876543210 a b = Apply (Apply Tuple2Sym0 a) b - type family Case_0123456789876543210 a b t where - Case_0123456789876543210 a b '(p, _) = p - type Let0123456789876543210Scrutinee_0123456789876543210Sym1 d0123456789876543210 = - Let0123456789876543210Scrutinee_0123456789876543210 d0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210Scrutinee_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd - (((,) - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference) - ()) - data Let0123456789876543210Scrutinee_0123456789876543210Sym0 d0123456789876543210 - where - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference :: forall d0123456789876543210 - arg. SameKind (Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 arg) (Let0123456789876543210Scrutinee_0123456789876543210Sym1 arg) => - Let0123456789876543210Scrutinee_0123456789876543210Sym0 d0123456789876543210 - type instance Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 d0123456789876543210 = Let0123456789876543210Scrutinee_0123456789876543210 d0123456789876543210 - type family Let0123456789876543210Scrutinee_0123456789876543210 d where - Let0123456789876543210Scrutinee_0123456789876543210 d = Apply JustSym0 d - type family Case_0123456789876543210 d t where - Case_0123456789876543210 d ('Just y) = y - type family Case_0123456789876543210 d x t where - Case_0123456789876543210 d x ('Just y) = y - Case_0123456789876543210 d x 'Nothing = d - type Foo5Sym1 (a0123456789876543210 :: a0123456789876543210) = - Foo5 a0123456789876543210 - instance SuppressUnusedWarnings Foo5Sym0 where - suppressUnusedWarnings = snd (((,) Foo5Sym0KindInference) ()) - data Foo5Sym0 :: forall a0123456789876543210. - (~>) a0123456789876543210 a0123456789876543210 - where - Foo5Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo5Sym0 arg) (Foo5Sym1 arg) => - Foo5Sym0 a0123456789876543210 - type instance Apply Foo5Sym0 a0123456789876543210 = Foo5 a0123456789876543210 - type Foo4Sym1 (a0123456789876543210 :: a0123456789876543210) = - Foo4 a0123456789876543210 - instance SuppressUnusedWarnings Foo4Sym0 where - suppressUnusedWarnings = snd (((,) Foo4Sym0KindInference) ()) - data Foo4Sym0 :: forall a0123456789876543210. - (~>) a0123456789876543210 a0123456789876543210 - where - Foo4Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo4Sym0 arg) (Foo4Sym1 arg) => - Foo4Sym0 a0123456789876543210 - type instance Apply Foo4Sym0 a0123456789876543210 = Foo4 a0123456789876543210 - type Foo3Sym2 (a0123456789876543210 :: a0123456789876543210) (a0123456789876543210 :: b0123456789876543210) = - Foo3 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Foo3Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) Foo3Sym1KindInference) ()) - data Foo3Sym1 (a0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210. - (~>) b0123456789876543210 a0123456789876543210 - where - Foo3Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Foo3Sym1 a0123456789876543210) arg) (Foo3Sym2 a0123456789876543210 arg) => - Foo3Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Foo3Sym1 a0123456789876543210) a0123456789876543210 = Foo3 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Foo3Sym0 where - suppressUnusedWarnings = snd (((,) Foo3Sym0KindInference) ()) - data Foo3Sym0 :: forall a0123456789876543210 b0123456789876543210. - (~>) a0123456789876543210 ((~>) b0123456789876543210 a0123456789876543210) - where - Foo3Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo3Sym0 arg) (Foo3Sym1 arg) => - Foo3Sym0 a0123456789876543210 - type instance Apply Foo3Sym0 a0123456789876543210 = Foo3Sym1 a0123456789876543210 - type Foo2Sym2 (a0123456789876543210 :: a0123456789876543210) (a0123456789876543210 :: Maybe a0123456789876543210) = - Foo2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Foo2Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) Foo2Sym1KindInference) ()) - data Foo2Sym1 (a0123456789876543210 :: a0123456789876543210) :: (~>) (Maybe a0123456789876543210) a0123456789876543210 - where - Foo2Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Foo2Sym1 a0123456789876543210) arg) (Foo2Sym2 a0123456789876543210 arg) => - Foo2Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Foo2Sym1 a0123456789876543210) a0123456789876543210 = Foo2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Foo2Sym0 where - suppressUnusedWarnings = snd (((,) Foo2Sym0KindInference) ()) - data Foo2Sym0 :: forall a0123456789876543210. - (~>) a0123456789876543210 ((~>) (Maybe a0123456789876543210) a0123456789876543210) - where - Foo2Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo2Sym0 arg) (Foo2Sym1 arg) => - Foo2Sym0 a0123456789876543210 - type instance Apply Foo2Sym0 a0123456789876543210 = Foo2Sym1 a0123456789876543210 - type Foo1Sym2 (a0123456789876543210 :: a0123456789876543210) (a0123456789876543210 :: Maybe a0123456789876543210) = - Foo1 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Foo1Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) Foo1Sym1KindInference) ()) - data Foo1Sym1 (a0123456789876543210 :: a0123456789876543210) :: (~>) (Maybe a0123456789876543210) a0123456789876543210 - where - Foo1Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Foo1Sym1 a0123456789876543210) arg) (Foo1Sym2 a0123456789876543210 arg) => - Foo1Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Foo1Sym1 a0123456789876543210) a0123456789876543210 = Foo1 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Foo1Sym0 where - suppressUnusedWarnings = snd (((,) Foo1Sym0KindInference) ()) - data Foo1Sym0 :: forall a0123456789876543210. - (~>) a0123456789876543210 ((~>) (Maybe a0123456789876543210) a0123456789876543210) - where - Foo1Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo1Sym0 arg) (Foo1Sym1 arg) => - Foo1Sym0 a0123456789876543210 - type instance Apply Foo1Sym0 a0123456789876543210 = Foo1Sym1 a0123456789876543210 - type family Foo5 (a :: a) :: a where - Foo5 x = Case_0123456789876543210 x x - type family Foo4 (a :: a) :: a where - Foo4 x = Case_0123456789876543210 x x - type family Foo3 (a :: a) (a :: b) :: a where - Foo3 a b = Case_0123456789876543210 a b (Let0123456789876543210Scrutinee_0123456789876543210Sym2 a b) - type family Foo2 (a :: a) (a :: Maybe a) :: a where - Foo2 d _ = Case_0123456789876543210 d (Let0123456789876543210Scrutinee_0123456789876543210Sym1 d) - type family Foo1 (a :: a) (a :: Maybe a) :: a where - Foo1 d x = Case_0123456789876543210 d x x - sFoo5 :: forall a (t :: a). Sing t -> Sing (Apply Foo5Sym0 t :: a) - sFoo4 :: forall a (t :: a). Sing t -> Sing (Apply Foo4Sym0 t :: a) - sFoo3 :: - forall a b (t :: a) (t :: b). - Sing t -> Sing t -> Sing (Apply (Apply Foo3Sym0 t) t :: a) - sFoo2 :: - forall a (t :: a) (t :: Maybe a). - Sing t -> Sing t -> Sing (Apply (Apply Foo2Sym0 t) t :: a) - sFoo1 :: - forall a (t :: a) (t :: Maybe a). - Sing t -> Sing t -> Sing (Apply (Apply Foo1Sym0 t) t :: a) - sFoo5 (sX :: Sing x) - = (id @(Sing (Case_0123456789876543210 x x :: a))) - (case sX of { - (sY :: Sing y) - -> (applySing - ((singFun1 @(Apply (Apply Lambda_0123456789876543210Sym0 y) x)) - (\ sArg_0123456789876543210 - -> case sArg_0123456789876543210 of { - (_ :: Sing arg_0123456789876543210) - -> (id - @(Sing (Case_0123456789876543210 arg_0123456789876543210 y x arg_0123456789876543210))) - (case sArg_0123456789876543210 of { _ -> sX }) }))) - sY }) - sFoo4 (sX :: Sing x) - = (id @(Sing (Case_0123456789876543210 x x :: a))) - (case sX of { - (sY :: Sing y) - -> let - sZ :: Sing (Let0123456789876543210ZSym2 y x :: a) - sZ = sY - in sZ }) - sFoo3 (sA :: Sing a) (sB :: Sing b) - = let - sScrutinee_0123456789876543210 :: - Sing (Let0123456789876543210Scrutinee_0123456789876543210Sym2 a b) - sScrutinee_0123456789876543210 - = (applySing ((applySing ((singFun2 @Tuple2Sym0) STuple2)) sA)) sB - in - (id - @(Sing (Case_0123456789876543210 a b (Let0123456789876543210Scrutinee_0123456789876543210Sym2 a b) :: a))) - (case sScrutinee_0123456789876543210 of { - STuple2 (sP :: Sing p) _ -> sP }) - sFoo2 (sD :: Sing d) _ - = let - sScrutinee_0123456789876543210 :: - Sing (Let0123456789876543210Scrutinee_0123456789876543210Sym1 d) - sScrutinee_0123456789876543210 - = (applySing ((singFun1 @JustSym0) SJust)) sD - in - (id - @(Sing (Case_0123456789876543210 d (Let0123456789876543210Scrutinee_0123456789876543210Sym1 d) :: a))) - (case sScrutinee_0123456789876543210 of { - SJust (sY :: Sing y) -> sY }) - sFoo1 (sD :: Sing d) (sX :: Sing x) - = (id @(Sing (Case_0123456789876543210 d x x :: a))) - (case sX of - SJust (sY :: Sing y) -> sY - SNothing -> sD) - instance SingI (Foo5Sym0 :: (~>) a a) where - sing = (singFun1 @Foo5Sym0) sFoo5 - instance SingI (Foo4Sym0 :: (~>) a a) where - sing = (singFun1 @Foo4Sym0) sFoo4 - instance SingI (Foo3Sym0 :: (~>) a ((~>) b a)) where - sing = (singFun2 @Foo3Sym0) sFoo3 - instance SingI d => SingI (Foo3Sym1 (d :: a) :: (~>) b a) where - sing = (singFun1 @(Foo3Sym1 (d :: a))) (sFoo3 (sing @d)) - instance SingI (Foo2Sym0 :: (~>) a ((~>) (Maybe a) a)) where - sing = (singFun2 @Foo2Sym0) sFoo2 - instance SingI d => - SingI (Foo2Sym1 (d :: a) :: (~>) (Maybe a) a) where - sing = (singFun1 @(Foo2Sym1 (d :: a))) (sFoo2 (sing @d)) - instance SingI (Foo1Sym0 :: (~>) a ((~>) (Maybe a) a)) where - sing = (singFun2 @Foo1Sym0) sFoo1 - instance SingI d => - SingI (Foo1Sym1 (d :: a) :: (~>) (Maybe a) a) where - sing = (singFun1 @(Foo1Sym1 (d :: a))) (sFoo1 (sing @d)) diff --git a/tests/compile-and-dump/Singletons/CaseExpressions.hs b/tests/compile-and-dump/Singletons/CaseExpressions.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/CaseExpressions.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# OPTIONS_GHC -Wno-incomplete-patterns #-} - -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/Classes.ghc88.template b/tests/compile-and-dump/Singletons/Classes.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Classes.ghc88.template +++ /dev/null @@ -1,575 +0,0 @@ -Singletons/Classes.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| infix 4 <=> - - const :: a -> b -> a - const x _ = x - fooCompare :: Foo -> Foo -> Ordering - fooCompare A A = EQ - fooCompare A B = LT - fooCompare B B = GT - fooCompare B A = EQ - - class MyOrd a where - mycompare :: a -> a -> Ordering - (<=>) :: a -> a -> Ordering - (<=>) = mycompare - infix 4 <=> - data Foo = A | B - data Foo2 = F | G - - 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 - instance MyOrd Foo where - mycompare = fooCompare - instance Eq Foo2 where - F == F = True - G == G = True - F == G = False - G == F = False |] - ======> - const :: a -> b -> a - const x _ = x - class MyOrd a where - mycompare :: a -> a -> Ordering - (<=>) :: a -> a -> Ordering - (<=>) = mycompare - infix 4 <=> - 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 B = LT - fooCompare B B = GT - fooCompare B A = EQ - instance MyOrd Foo where - mycompare = fooCompare - data Foo2 = F | G - instance Eq Foo2 where - (==) F F = True - (==) G G = True - (==) F G = False - (==) G F = False - type ASym0 = A - type BSym0 = B - type FSym0 = F - type GSym0 = G - type FooCompareSym2 (a0123456789876543210 :: Foo) (a0123456789876543210 :: Foo) = - FooCompare a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (FooCompareSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) FooCompareSym1KindInference) ()) - data FooCompareSym1 (a0123456789876543210 :: Foo) :: (~>) Foo Ordering - where - FooCompareSym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (FooCompareSym1 a0123456789876543210) arg) (FooCompareSym2 a0123456789876543210 arg) => - FooCompareSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (FooCompareSym1 a0123456789876543210) a0123456789876543210 = FooCompare a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings FooCompareSym0 where - suppressUnusedWarnings = snd (((,) FooCompareSym0KindInference) ()) - data FooCompareSym0 :: (~>) Foo ((~>) Foo Ordering) - where - FooCompareSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply FooCompareSym0 arg) (FooCompareSym1 arg) => - FooCompareSym0 a0123456789876543210 - type instance Apply FooCompareSym0 a0123456789876543210 = FooCompareSym1 a0123456789876543210 - type ConstSym2 (a0123456789876543210 :: a0123456789876543210) (a0123456789876543210 :: b0123456789876543210) = - Const a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ConstSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) ConstSym1KindInference) ()) - data ConstSym1 (a0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210. - (~>) b0123456789876543210 a0123456789876543210 - where - ConstSym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ConstSym1 a0123456789876543210) arg) (ConstSym2 a0123456789876543210 arg) => - ConstSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (ConstSym1 a0123456789876543210) a0123456789876543210 = Const a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ConstSym0 where - suppressUnusedWarnings = snd (((,) ConstSym0KindInference) ()) - data ConstSym0 :: forall a0123456789876543210 b0123456789876543210. - (~>) a0123456789876543210 ((~>) b0123456789876543210 a0123456789876543210) - where - ConstSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply ConstSym0 arg) (ConstSym1 arg) => - ConstSym0 a0123456789876543210 - type instance Apply ConstSym0 a0123456789876543210 = ConstSym1 a0123456789876543210 - type family FooCompare (a :: Foo) (a :: Foo) :: Ordering where - FooCompare A A = EQSym0 - FooCompare A B = LTSym0 - FooCompare B B = GTSym0 - FooCompare B A = EQSym0 - type family Const (a :: a) (a :: b) :: a where - Const x _ = x - type MycompareSym2 (arg0123456789876543210 :: a0123456789876543210) (arg0123456789876543210 :: a0123456789876543210) = - Mycompare arg0123456789876543210 arg0123456789876543210 - instance SuppressUnusedWarnings (MycompareSym1 arg0123456789876543210) where - suppressUnusedWarnings = snd (((,) MycompareSym1KindInference) ()) - data MycompareSym1 (arg0123456789876543210 :: a0123456789876543210) :: (~>) a0123456789876543210 Ordering - where - MycompareSym1KindInference :: forall arg0123456789876543210 - arg0123456789876543210 - arg. SameKind (Apply (MycompareSym1 arg0123456789876543210) arg) (MycompareSym2 arg0123456789876543210 arg) => - MycompareSym1 arg0123456789876543210 arg0123456789876543210 - type instance Apply (MycompareSym1 arg0123456789876543210) arg0123456789876543210 = Mycompare arg0123456789876543210 arg0123456789876543210 - instance SuppressUnusedWarnings MycompareSym0 where - suppressUnusedWarnings = snd (((,) MycompareSym0KindInference) ()) - data MycompareSym0 :: forall a0123456789876543210. - (~>) a0123456789876543210 ((~>) a0123456789876543210 Ordering) - where - MycompareSym0KindInference :: forall arg0123456789876543210 - arg. SameKind (Apply MycompareSym0 arg) (MycompareSym1 arg) => - MycompareSym0 arg0123456789876543210 - type instance Apply MycompareSym0 arg0123456789876543210 = MycompareSym1 arg0123456789876543210 - type (<=>@#@$$$) (arg0123456789876543210 :: a0123456789876543210) (arg0123456789876543210 :: a0123456789876543210) = - (<=>) arg0123456789876543210 arg0123456789876543210 - instance SuppressUnusedWarnings ((<=>@#@$$) arg0123456789876543210) where - suppressUnusedWarnings = snd (((,) (:<=>@#@$$###)) ()) - data (<=>@#@$$) (arg0123456789876543210 :: a0123456789876543210) :: (~>) a0123456789876543210 Ordering - where - (:<=>@#@$$###) :: forall arg0123456789876543210 - arg0123456789876543210 - arg. SameKind (Apply ((<=>@#@$$) arg0123456789876543210) arg) ((<=>@#@$$$) arg0123456789876543210 arg) => - (<=>@#@$$) arg0123456789876543210 arg0123456789876543210 - type instance Apply ((<=>@#@$$) arg0123456789876543210) arg0123456789876543210 = (<=>) arg0123456789876543210 arg0123456789876543210 - infix 4 <=>@#@$$ - instance SuppressUnusedWarnings (<=>@#@$) where - suppressUnusedWarnings = snd (((,) (:<=>@#@$###)) ()) - data (<=>@#@$) :: forall a0123456789876543210. - (~>) a0123456789876543210 ((~>) a0123456789876543210 Ordering) - where - (:<=>@#@$###) :: forall arg0123456789876543210 - arg. SameKind (Apply (<=>@#@$) arg) ((<=>@#@$$) arg) => - (<=>@#@$) arg0123456789876543210 - type instance Apply (<=>@#@$) arg0123456789876543210 = (<=>@#@$$) arg0123456789876543210 - infix 4 <=>@#@$ - type family TFHelper_0123456789876543210 (a :: a) (a :: a) :: Ordering where - TFHelper_0123456789876543210 a_0123456789876543210 a_0123456789876543210 = Apply (Apply MycompareSym0 a_0123456789876543210) a_0123456789876543210 - type TFHelper_0123456789876543210Sym2 (a0123456789876543210 :: a0123456789876543210) (a0123456789876543210 :: a0123456789876543210) = - TFHelper_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (TFHelper_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) TFHelper_0123456789876543210Sym1KindInference) ()) - data TFHelper_0123456789876543210Sym1 (a0123456789876543210 :: a0123456789876543210) :: (~>) a0123456789876543210 Ordering - where - TFHelper_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (TFHelper_0123456789876543210Sym1 a0123456789876543210) arg) (TFHelper_0123456789876543210Sym2 a0123456789876543210 arg) => - TFHelper_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (TFHelper_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = TFHelper_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings TFHelper_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) TFHelper_0123456789876543210Sym0KindInference) ()) - data TFHelper_0123456789876543210Sym0 :: forall a0123456789876543210. - (~>) a0123456789876543210 ((~>) a0123456789876543210 Ordering) - where - TFHelper_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply TFHelper_0123456789876543210Sym0 arg) (TFHelper_0123456789876543210Sym1 arg) => - TFHelper_0123456789876543210Sym0 a0123456789876543210 - type instance Apply TFHelper_0123456789876543210Sym0 a0123456789876543210 = TFHelper_0123456789876543210Sym1 a0123456789876543210 - class PMyOrd (a :: GHC.Types.Type) where - type Mycompare (arg :: a) (arg :: a) :: Ordering - type (<=>) (arg :: a) (arg :: a) :: Ordering - type (<=>) a a = Apply (Apply TFHelper_0123456789876543210Sym0 a) a - type family Mycompare_0123456789876543210 (a :: Nat) (a :: Nat) :: Ordering where - Mycompare_0123456789876543210 'Zero 'Zero = EQSym0 - Mycompare_0123456789876543210 'Zero ('Succ _) = LTSym0 - Mycompare_0123456789876543210 ('Succ _) 'Zero = GTSym0 - Mycompare_0123456789876543210 ('Succ n) ('Succ m) = Apply (Apply MycompareSym0 m) n - type Mycompare_0123456789876543210Sym2 (a0123456789876543210 :: Nat) (a0123456789876543210 :: Nat) = - Mycompare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Mycompare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Mycompare_0123456789876543210Sym1KindInference) ()) - data Mycompare_0123456789876543210Sym1 (a0123456789876543210 :: Nat) :: (~>) Nat Ordering - where - Mycompare_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Mycompare_0123456789876543210Sym1 a0123456789876543210) arg) (Mycompare_0123456789876543210Sym2 a0123456789876543210 arg) => - Mycompare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Mycompare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Mycompare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Mycompare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Mycompare_0123456789876543210Sym0KindInference) ()) - data Mycompare_0123456789876543210Sym0 :: (~>) Nat ((~>) Nat Ordering) - where - Mycompare_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Mycompare_0123456789876543210Sym0 arg) (Mycompare_0123456789876543210Sym1 arg) => - Mycompare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Mycompare_0123456789876543210Sym0 a0123456789876543210 = Mycompare_0123456789876543210Sym1 a0123456789876543210 - instance PMyOrd Nat where - type Mycompare a a = Apply (Apply Mycompare_0123456789876543210Sym0 a) a - type family Mycompare_0123456789876543210 (a :: ()) (a :: ()) :: Ordering where - Mycompare_0123456789876543210 _ a_0123456789876543210 = Apply (Apply ConstSym0 EQSym0) a_0123456789876543210 - type Mycompare_0123456789876543210Sym2 (a0123456789876543210 :: ()) (a0123456789876543210 :: ()) = - Mycompare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Mycompare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Mycompare_0123456789876543210Sym1KindInference) ()) - data Mycompare_0123456789876543210Sym1 (a0123456789876543210 :: ()) :: (~>) () Ordering - where - Mycompare_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Mycompare_0123456789876543210Sym1 a0123456789876543210) arg) (Mycompare_0123456789876543210Sym2 a0123456789876543210 arg) => - Mycompare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Mycompare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Mycompare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Mycompare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Mycompare_0123456789876543210Sym0KindInference) ()) - data Mycompare_0123456789876543210Sym0 :: (~>) () ((~>) () Ordering) - where - Mycompare_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Mycompare_0123456789876543210Sym0 arg) (Mycompare_0123456789876543210Sym1 arg) => - Mycompare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Mycompare_0123456789876543210Sym0 a0123456789876543210 = Mycompare_0123456789876543210Sym1 a0123456789876543210 - instance PMyOrd () where - type Mycompare a a = Apply (Apply Mycompare_0123456789876543210Sym0 a) a - type family Mycompare_0123456789876543210 (a :: Foo) (a :: Foo) :: Ordering where - Mycompare_0123456789876543210 a_0123456789876543210 a_0123456789876543210 = Apply (Apply FooCompareSym0 a_0123456789876543210) a_0123456789876543210 - type Mycompare_0123456789876543210Sym2 (a0123456789876543210 :: Foo) (a0123456789876543210 :: Foo) = - Mycompare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Mycompare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Mycompare_0123456789876543210Sym1KindInference) ()) - data Mycompare_0123456789876543210Sym1 (a0123456789876543210 :: Foo) :: (~>) Foo Ordering - where - Mycompare_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Mycompare_0123456789876543210Sym1 a0123456789876543210) arg) (Mycompare_0123456789876543210Sym2 a0123456789876543210 arg) => - Mycompare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Mycompare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Mycompare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Mycompare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Mycompare_0123456789876543210Sym0KindInference) ()) - data Mycompare_0123456789876543210Sym0 :: (~>) Foo ((~>) Foo Ordering) - where - Mycompare_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Mycompare_0123456789876543210Sym0 arg) (Mycompare_0123456789876543210Sym1 arg) => - Mycompare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Mycompare_0123456789876543210Sym0 a0123456789876543210 = Mycompare_0123456789876543210Sym1 a0123456789876543210 - instance PMyOrd Foo where - type Mycompare a a = Apply (Apply Mycompare_0123456789876543210Sym0 a) a - type family TFHelper_0123456789876543210 (a :: Foo2) (a :: Foo2) :: Bool where - TFHelper_0123456789876543210 F F = TrueSym0 - TFHelper_0123456789876543210 G G = TrueSym0 - TFHelper_0123456789876543210 F G = FalseSym0 - TFHelper_0123456789876543210 G F = FalseSym0 - type TFHelper_0123456789876543210Sym2 (a0123456789876543210 :: Foo2) (a0123456789876543210 :: Foo2) = - TFHelper_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (TFHelper_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) TFHelper_0123456789876543210Sym1KindInference) ()) - data TFHelper_0123456789876543210Sym1 (a0123456789876543210 :: Foo2) :: (~>) Foo2 Bool - where - TFHelper_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (TFHelper_0123456789876543210Sym1 a0123456789876543210) arg) (TFHelper_0123456789876543210Sym2 a0123456789876543210 arg) => - TFHelper_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (TFHelper_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = TFHelper_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings TFHelper_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) TFHelper_0123456789876543210Sym0KindInference) ()) - data TFHelper_0123456789876543210Sym0 :: (~>) Foo2 ((~>) Foo2 Bool) - where - TFHelper_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply TFHelper_0123456789876543210Sym0 arg) (TFHelper_0123456789876543210Sym1 arg) => - TFHelper_0123456789876543210Sym0 a0123456789876543210 - type instance Apply TFHelper_0123456789876543210Sym0 a0123456789876543210 = TFHelper_0123456789876543210Sym1 a0123456789876543210 - instance PEq Foo2 where - type (==) a a = Apply (Apply TFHelper_0123456789876543210Sym0 a) a - infix 4 %<=> - sFooCompare :: - forall (t :: Foo) (t :: Foo). - Sing t - -> Sing t -> Sing (Apply (Apply FooCompareSym0 t) t :: Ordering) - sConst :: - forall a b (t :: a) (t :: b). - Sing t -> Sing t -> Sing (Apply (Apply ConstSym0 t) t :: a) - sFooCompare SA SA = SEQ - sFooCompare SA SB = SLT - sFooCompare SB SB = SGT - sFooCompare SB SA = SEQ - sConst (sX :: Sing x) _ = sX - instance SingI (FooCompareSym0 :: (~>) Foo ((~>) Foo Ordering)) where - sing = (singFun2 @FooCompareSym0) sFooCompare - instance SingI d => - SingI (FooCompareSym1 (d :: Foo) :: (~>) Foo Ordering) where - sing - = (singFun1 @(FooCompareSym1 (d :: Foo))) (sFooCompare (sing @d)) - instance SingI (ConstSym0 :: (~>) a ((~>) b a)) where - sing = (singFun2 @ConstSym0) sConst - instance SingI d => SingI (ConstSym1 (d :: a) :: (~>) b a) where - sing = (singFun1 @(ConstSym1 (d :: a))) (sConst (sing @d)) - data SFoo :: Foo -> GHC.Types.Type - where - SA :: SFoo A - SB :: SFoo B - type instance Sing @Foo = SFoo - instance SingKind Foo where - type Demote Foo = Foo - fromSing SA = A - fromSing SB = B - toSing A = SomeSing SA - toSing B = SomeSing SB - data SFoo2 :: Foo2 -> GHC.Types.Type - where - SF :: SFoo2 F - SG :: SFoo2 G - type instance Sing @Foo2 = SFoo2 - instance SingKind Foo2 where - type Demote Foo2 = Foo2 - fromSing SF = F - fromSing SG = G - toSing F = SomeSing SF - toSing G = SomeSing SG - class SMyOrd a where - sMycompare :: - forall (t :: a) (t :: a). - Sing t - -> Sing t -> Sing (Apply (Apply MycompareSym0 t) t :: Ordering) - (%<=>) :: - forall (t :: a) (t :: a). - Sing t -> Sing t -> Sing (Apply (Apply (<=>@#@$) t) t :: Ordering) - default (%<=>) :: - forall (t :: a) (t :: a). - ((Apply (Apply (<=>@#@$) t) t :: Ordering) - ~ Apply (Apply TFHelper_0123456789876543210Sym0 t) t) => - Sing t -> Sing t -> Sing (Apply (Apply (<=>@#@$) t) t :: Ordering) - (%<=>) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @MycompareSym0) sMycompare)) - sA_0123456789876543210)) - sA_0123456789876543210 - instance SMyOrd Nat where - sMycompare :: - forall (t :: Nat) (t :: Nat). - Sing t - -> Sing t -> Sing (Apply (Apply MycompareSym0 t) t :: Ordering) - sMycompare SZero SZero = SEQ - sMycompare SZero (SSucc _) = SLT - sMycompare (SSucc _) SZero = SGT - sMycompare (SSucc (sN :: Sing n)) (SSucc (sM :: Sing m)) - = (applySing - ((applySing ((singFun2 @MycompareSym0) sMycompare)) sM)) - sN - instance SMyOrd () where - sMycompare :: - forall (t :: ()) (t :: ()). - Sing t - -> Sing t -> Sing (Apply (Apply MycompareSym0 t) t :: Ordering) - sMycompare _ (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing ((applySing ((singFun2 @ConstSym0) sConst)) SEQ)) - sA_0123456789876543210 - instance SMyOrd Foo where - sMycompare :: - forall (t :: Foo) (t :: Foo). - Sing t - -> Sing t -> Sing (Apply (Apply MycompareSym0 t) t :: Ordering) - sMycompare - (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @FooCompareSym0) sFooCompare)) - sA_0123456789876543210)) - sA_0123456789876543210 - instance SEq Foo2 where - (%==) :: - forall (a :: Foo2) (b :: Foo2). Sing a -> Sing b -> Sing ((==) a b) - (%==) SF SF = STrue - (%==) SG SG = STrue - (%==) SF SG = SFalse - (%==) SG SF = SFalse - instance SingI A where - sing = SA - instance SingI B where - sing = SB - instance SingI F where - sing = SF - instance SingI G where - sing = SG - instance SMyOrd a => - SingI (MycompareSym0 :: (~>) a ((~>) a Ordering)) where - sing = (singFun2 @MycompareSym0) sMycompare - instance (SMyOrd a, SingI d) => - SingI (MycompareSym1 (d :: a) :: (~>) a Ordering) where - sing = (singFun1 @(MycompareSym1 (d :: a))) (sMycompare (sing @d)) - instance SMyOrd a => - SingI ((<=>@#@$) :: (~>) a ((~>) a Ordering)) where - sing = (singFun2 @(<=>@#@$)) (%<=>) - instance (SMyOrd a, SingI d) => - SingI ((<=>@#@$$) (d :: a) :: (~>) a Ordering) where - sing = (singFun1 @((<=>@#@$$) (d :: a))) ((%<=>) (sing @d)) -Singletons/Classes.hs:(0,0)-(0,0): Splicing declarations - promote - [d| instance Ord Foo2 where - F `compare` F = EQ - F `compare` _ = LT - _ `compare` _ = GT - instance MyOrd Foo2 where - F `mycompare` F = EQ - F `mycompare` _ = LT - _ `mycompare` _ = GT |] - ======> - instance MyOrd Foo2 where - mycompare F F = EQ - mycompare F _ = LT - mycompare _ _ = GT - instance Ord Foo2 where - compare F F = EQ - compare F _ = LT - compare _ _ = GT - type family Mycompare_0123456789876543210 (a :: Foo2) (a :: Foo2) :: Ordering where - Mycompare_0123456789876543210 'F 'F = EQSym0 - Mycompare_0123456789876543210 'F _ = LTSym0 - Mycompare_0123456789876543210 _ _ = GTSym0 - type Mycompare_0123456789876543210Sym2 (a0123456789876543210 :: Foo2) (a0123456789876543210 :: Foo2) = - Mycompare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Mycompare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Mycompare_0123456789876543210Sym1KindInference) ()) - data Mycompare_0123456789876543210Sym1 (a0123456789876543210 :: Foo2) :: (~>) Foo2 Ordering - where - Mycompare_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Mycompare_0123456789876543210Sym1 a0123456789876543210) arg) (Mycompare_0123456789876543210Sym2 a0123456789876543210 arg) => - Mycompare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Mycompare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Mycompare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Mycompare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Mycompare_0123456789876543210Sym0KindInference) ()) - data Mycompare_0123456789876543210Sym0 :: (~>) Foo2 ((~>) Foo2 Ordering) - where - Mycompare_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Mycompare_0123456789876543210Sym0 arg) (Mycompare_0123456789876543210Sym1 arg) => - Mycompare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Mycompare_0123456789876543210Sym0 a0123456789876543210 = Mycompare_0123456789876543210Sym1 a0123456789876543210 - instance PMyOrd Foo2 where - type Mycompare a a = Apply (Apply Mycompare_0123456789876543210Sym0 a) a - type family Compare_0123456789876543210 (a :: Foo2) (a :: Foo2) :: Ordering where - Compare_0123456789876543210 'F 'F = EQSym0 - Compare_0123456789876543210 'F _ = LTSym0 - Compare_0123456789876543210 _ _ = GTSym0 - type Compare_0123456789876543210Sym2 (a0123456789876543210 :: Foo2) (a0123456789876543210 :: Foo2) = - Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Compare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym1KindInference) ()) - data Compare_0123456789876543210Sym1 (a0123456789876543210 :: Foo2) :: (~>) Foo2 Ordering - where - Compare_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Compare_0123456789876543210Sym1 a0123456789876543210) arg) (Compare_0123456789876543210Sym2 a0123456789876543210 arg) => - Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Compare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Compare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym0KindInference) ()) - data Compare_0123456789876543210Sym0 :: (~>) Foo2 ((~>) Foo2 Ordering) - where - Compare_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Compare_0123456789876543210Sym0 arg) (Compare_0123456789876543210Sym1 arg) => - Compare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Compare_0123456789876543210Sym0 a0123456789876543210 = Compare_0123456789876543210Sym1 a0123456789876543210 - instance POrd Foo2 where - type Compare a a = Apply (Apply Compare_0123456789876543210Sym0 a) a -Singletons/Classes.hs:(0,0)-(0,0): Splicing declarations - singletons - [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 |] - ======> - 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) - type Zero'Sym0 = Zero' - type Succ'Sym1 (t0123456789876543210 :: Nat') = - Succ' t0123456789876543210 - instance SuppressUnusedWarnings Succ'Sym0 where - suppressUnusedWarnings = snd (((,) Succ'Sym0KindInference) ()) - data Succ'Sym0 :: (~>) Nat' Nat' - where - Succ'Sym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply Succ'Sym0 arg) (Succ'Sym1 arg) => - Succ'Sym0 t0123456789876543210 - type instance Apply Succ'Sym0 t0123456789876543210 = Succ' t0123456789876543210 - type family Mycompare_0123456789876543210 (a :: Nat') (a :: Nat') :: Ordering where - Mycompare_0123456789876543210 Zero' Zero' = EQSym0 - Mycompare_0123456789876543210 Zero' (Succ' _) = LTSym0 - Mycompare_0123456789876543210 (Succ' _) Zero' = GTSym0 - Mycompare_0123456789876543210 (Succ' n) (Succ' m) = Apply (Apply MycompareSym0 m) n - type Mycompare_0123456789876543210Sym2 (a0123456789876543210 :: Nat') (a0123456789876543210 :: Nat') = - Mycompare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Mycompare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Mycompare_0123456789876543210Sym1KindInference) ()) - data Mycompare_0123456789876543210Sym1 (a0123456789876543210 :: Nat') :: (~>) Nat' Ordering - where - Mycompare_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Mycompare_0123456789876543210Sym1 a0123456789876543210) arg) (Mycompare_0123456789876543210Sym2 a0123456789876543210 arg) => - Mycompare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Mycompare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Mycompare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Mycompare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Mycompare_0123456789876543210Sym0KindInference) ()) - data Mycompare_0123456789876543210Sym0 :: (~>) Nat' ((~>) Nat' Ordering) - where - Mycompare_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Mycompare_0123456789876543210Sym0 arg) (Mycompare_0123456789876543210Sym1 arg) => - Mycompare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Mycompare_0123456789876543210Sym0 a0123456789876543210 = Mycompare_0123456789876543210Sym1 a0123456789876543210 - instance PMyOrd Nat' where - type Mycompare a a = Apply (Apply Mycompare_0123456789876543210Sym0 a) a - data SNat' :: Nat' -> GHC.Types.Type - where - SZero' :: SNat' Zero' - SSucc' :: forall (n :: Nat'). (Sing (n :: Nat')) -> SNat' (Succ' n) - type instance Sing @Nat' = SNat' - instance SingKind Nat' where - type Demote Nat' = Nat' - fromSing SZero' = Zero' - fromSing (SSucc' b) = Succ' (fromSing b) - toSing Zero' = SomeSing SZero' - toSing (Succ' (b :: Demote Nat')) - = case toSing b :: SomeSing Nat' of { - SomeSing c -> SomeSing (SSucc' c) } - instance SMyOrd Nat' where - sMycompare :: - forall (t :: Nat') (t :: Nat'). - Sing t - -> Sing t - -> Sing (Apply (Apply (MycompareSym0 :: TyFun Nat' ((~>) Nat' Ordering) - -> GHC.Types.Type) t) t) - sMycompare SZero' SZero' = SEQ - sMycompare SZero' (SSucc' _) = SLT - sMycompare (SSucc' _) SZero' = SGT - sMycompare (SSucc' (sN :: Sing n)) (SSucc' (sM :: Sing m)) - = (applySing - ((applySing ((singFun2 @MycompareSym0) sMycompare)) sM)) - sN - instance SingI Zero' where - sing = SZero' - instance SingI n => SingI (Succ' (n :: Nat')) where - sing = SSucc' sing - instance SingI (Succ'Sym0 :: (~>) Nat' Nat') where - sing = (singFun1 @Succ'Sym0) SSucc' diff --git a/tests/compile-and-dump/Singletons/Classes.hs b/tests/compile-and-dump/Singletons/Classes.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Classes.hs +++ /dev/null @@ -1,98 +0,0 @@ -module Singletons.Classes where - -import Prelude hiding (const) -import Singletons.Nat -import Data.Singletons -import Data.Singletons.TH -import Language.Haskell.TH.Desugar -import Data.Singletons.Prelude.Ord -import Data.Singletons.Prelude.Eq - -$(singletons [d| - const :: a -> b -> a - const x _ = x - - class MyOrd a where - mycompare :: a -> a -> Ordering - (<=>) :: a -> a -> Ordering - (<=>) = mycompare - infix 4 <=> - - 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 B = LT - fooCompare B B = GT - fooCompare B A = EQ - - instance MyOrd Foo where - -- test that values in instance definitions are eta-expanded - mycompare = fooCompare - - data Foo2 = F | G - - instance Eq Foo2 where - F == F = True - G == G = True - F == G = False - G == F = False - |]) - -$(promote [d| - -- instance with overlaping equations. Tests #56 - instance MyOrd Foo2 where - F `mycompare` F = EQ - F `mycompare` _ = LT - _ `mycompare` _ = GT - - instance Ord Foo2 where - F `compare` F = EQ - F `compare` _ = LT - _ `compare` _ = GT - - |]) - --- check promotion across different splices (#55) -$(singletons [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/Singletons/Classes2.ghc88.template b/tests/compile-and-dump/Singletons/Classes2.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Classes2.ghc88.template +++ /dev/null @@ -1,89 +0,0 @@ -Singletons/Classes2.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| data NatFoo = ZeroFoo | SuccFoo NatFoo - - instance MyOrd NatFoo where - ZeroFoo `mycompare` ZeroFoo = EQ - ZeroFoo `mycompare` (SuccFoo _) = LT - (SuccFoo _) `mycompare` ZeroFoo = GT - (SuccFoo n) `mycompare` (SuccFoo m) = m `mycompare` n |] - ======> - data NatFoo = ZeroFoo | SuccFoo NatFoo - instance MyOrd NatFoo where - mycompare ZeroFoo ZeroFoo = EQ - mycompare ZeroFoo (SuccFoo _) = LT - mycompare (SuccFoo _) ZeroFoo = GT - mycompare (SuccFoo n) (SuccFoo m) = (m `mycompare` n) - type ZeroFooSym0 = ZeroFoo - type SuccFooSym1 (t0123456789876543210 :: NatFoo) = - SuccFoo t0123456789876543210 - instance SuppressUnusedWarnings SuccFooSym0 where - suppressUnusedWarnings = snd (((,) SuccFooSym0KindInference) ()) - data SuccFooSym0 :: (~>) NatFoo NatFoo - where - SuccFooSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply SuccFooSym0 arg) (SuccFooSym1 arg) => - SuccFooSym0 t0123456789876543210 - type instance Apply SuccFooSym0 t0123456789876543210 = SuccFoo t0123456789876543210 - type family Mycompare_0123456789876543210 (a :: NatFoo) (a :: NatFoo) :: Ordering where - Mycompare_0123456789876543210 ZeroFoo ZeroFoo = EQSym0 - Mycompare_0123456789876543210 ZeroFoo (SuccFoo _) = LTSym0 - Mycompare_0123456789876543210 (SuccFoo _) ZeroFoo = GTSym0 - Mycompare_0123456789876543210 (SuccFoo n) (SuccFoo m) = Apply (Apply MycompareSym0 m) n - type Mycompare_0123456789876543210Sym2 (a0123456789876543210 :: NatFoo) (a0123456789876543210 :: NatFoo) = - Mycompare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Mycompare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Mycompare_0123456789876543210Sym1KindInference) ()) - data Mycompare_0123456789876543210Sym1 (a0123456789876543210 :: NatFoo) :: (~>) NatFoo Ordering - where - Mycompare_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Mycompare_0123456789876543210Sym1 a0123456789876543210) arg) (Mycompare_0123456789876543210Sym2 a0123456789876543210 arg) => - Mycompare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Mycompare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Mycompare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Mycompare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Mycompare_0123456789876543210Sym0KindInference) ()) - data Mycompare_0123456789876543210Sym0 :: (~>) NatFoo ((~>) NatFoo Ordering) - where - Mycompare_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Mycompare_0123456789876543210Sym0 arg) (Mycompare_0123456789876543210Sym1 arg) => - Mycompare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Mycompare_0123456789876543210Sym0 a0123456789876543210 = Mycompare_0123456789876543210Sym1 a0123456789876543210 - instance PMyOrd NatFoo where - type Mycompare a a = Apply (Apply Mycompare_0123456789876543210Sym0 a) a - data SNatFoo :: NatFoo -> GHC.Types.Type - where - SZeroFoo :: SNatFoo ZeroFoo - SSuccFoo :: forall (n :: NatFoo). - (Sing (n :: NatFoo)) -> SNatFoo (SuccFoo n) - type instance Sing @NatFoo = SNatFoo - instance SingKind NatFoo where - type Demote NatFoo = NatFoo - fromSing SZeroFoo = ZeroFoo - fromSing (SSuccFoo b) = SuccFoo (fromSing b) - toSing ZeroFoo = SomeSing SZeroFoo - toSing (SuccFoo (b :: Demote NatFoo)) - = case toSing b :: SomeSing NatFoo of { - SomeSing c -> SomeSing (SSuccFoo c) } - instance SMyOrd NatFoo where - sMycompare :: - forall (t1 :: NatFoo) (t2 :: NatFoo). - Sing t1 - -> Sing t2 - -> Sing (Apply (Apply (MycompareSym0 :: TyFun NatFoo ((~>) NatFoo Ordering) - -> GHC.Types.Type) t1) t2) - sMycompare SZeroFoo SZeroFoo = SEQ - sMycompare SZeroFoo (SSuccFoo _) = SLT - sMycompare (SSuccFoo _) SZeroFoo = SGT - sMycompare (SSuccFoo (sN :: Sing n)) (SSuccFoo (sM :: Sing m)) - = (applySing - ((applySing ((singFun2 @MycompareSym0) sMycompare)) sM)) - sN - instance SingI ZeroFoo where - sing = SZeroFoo - instance SingI n => SingI (SuccFoo (n :: NatFoo)) where - sing = SSuccFoo sing - instance SingI (SuccFooSym0 :: (~>) NatFoo NatFoo) where - sing = (singFun1 @SuccFooSym0) SSuccFoo diff --git a/tests/compile-and-dump/Singletons/Classes2.hs b/tests/compile-and-dump/Singletons/Classes2.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Classes2.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Singletons.Classes2 where - -import Prelude hiding (const) -import Singletons.Nat -import Singletons.Classes -import Data.Singletons -import Data.Singletons.TH -import Data.Singletons.Prelude.Ord (EQSym0, LTSym0, GTSym0, Sing(..)) -import Language.Haskell.TH.Desugar - - -$(singletons [d| - -- tests promotion of class instances when the class was declared - -- in a different source file than the instance. - data NatFoo = ZeroFoo | SuccFoo NatFoo - - instance MyOrd NatFoo where - ZeroFoo `mycompare` ZeroFoo = EQ - ZeroFoo `mycompare` (SuccFoo _) = LT - (SuccFoo _) `mycompare` ZeroFoo = GT - (SuccFoo n) `mycompare` (SuccFoo m) = m `mycompare` n - |]) diff --git a/tests/compile-and-dump/Singletons/Contains.ghc88.template b/tests/compile-and-dump/Singletons/Contains.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Contains.ghc88.template +++ /dev/null @@ -1,50 +0,0 @@ -Singletons/Contains.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| contains :: Eq a => a -> [a] -> Bool - contains _ [] = False - contains elt (h : t) = (elt == h) || (contains elt t) |] - ======> - contains :: Eq a => a -> [a] -> Bool - contains _ [] = False - contains elt (h : t) = ((elt == h) || (contains elt) t) - type ContainsSym2 (a0123456789876543210 :: a0123456789876543210) (a0123456789876543210 :: [a0123456789876543210]) = - Contains a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ContainsSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) ContainsSym1KindInference) ()) - data ContainsSym1 (a0123456789876543210 :: a0123456789876543210) :: (~>) [a0123456789876543210] Bool - where - ContainsSym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ContainsSym1 a0123456789876543210) arg) (ContainsSym2 a0123456789876543210 arg) => - ContainsSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (ContainsSym1 a0123456789876543210) a0123456789876543210 = Contains a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ContainsSym0 where - suppressUnusedWarnings = snd (((,) ContainsSym0KindInference) ()) - data ContainsSym0 :: forall a0123456789876543210. - (~>) a0123456789876543210 ((~>) [a0123456789876543210] Bool) - where - ContainsSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply ContainsSym0 arg) (ContainsSym1 arg) => - ContainsSym0 a0123456789876543210 - type instance Apply ContainsSym0 a0123456789876543210 = ContainsSym1 a0123456789876543210 - type family Contains (a :: a) (a :: [a]) :: Bool where - Contains _ '[] = FalseSym0 - Contains elt ('(:) h t) = Apply (Apply (||@#@$) (Apply (Apply (==@#@$) elt) h)) (Apply (Apply ContainsSym0 elt) t) - sContains :: - forall a (t :: a) (t :: [a]). - SEq a => - Sing t -> Sing t -> Sing (Apply (Apply ContainsSym0 t) t :: Bool) - sContains _ SNil = SFalse - sContains (sElt :: Sing elt) (SCons (sH :: Sing h) (sT :: Sing t)) - = (applySing - ((applySing ((singFun2 @(||@#@$)) (%||))) - ((applySing ((applySing ((singFun2 @(==@#@$)) (%==))) sElt)) sH))) - ((applySing - ((applySing ((singFun2 @ContainsSym0) sContains)) sElt)) - sT) - instance SEq a => - SingI (ContainsSym0 :: (~>) a ((~>) [a] Bool)) where - sing = (singFun2 @ContainsSym0) sContains - instance (SEq a, SingI d) => - SingI (ContainsSym1 (d :: a) :: (~>) [a] Bool) where - sing = (singFun1 @(ContainsSym1 (d :: a))) (sContains (sing @d)) diff --git a/tests/compile-and-dump/Singletons/Contains.hs b/tests/compile-and-dump/Singletons/Contains.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Contains.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Singletons.Contains where - -import Data.Singletons.TH -import Data.Singletons.Prelude -import Data.Singletons.SuppressUnusedWarnings - --- polymorphic function with context - -$(singletons [d| - contains :: Eq a => a -> [a] -> Bool - contains _ [] = False - contains elt (h:t) = (elt == h) || (contains elt t) - |]) diff --git a/tests/compile-and-dump/Singletons/DataValues.ghc88.template b/tests/compile-and-dump/Singletons/DataValues.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/DataValues.ghc88.template +++ /dev/null @@ -1,193 +0,0 @@ -Singletons/DataValues.hs:(0,0)-(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 |] - ======> - 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 (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: b0123456789876543210) = - Pair t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (PairSym1 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) PairSym1KindInference) ()) - data PairSym1 (t0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210. - (~>) b0123456789876543210 (Pair a0123456789876543210 b0123456789876543210) - where - PairSym1KindInference :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (PairSym1 t0123456789876543210) arg) (PairSym2 t0123456789876543210 arg) => - PairSym1 t0123456789876543210 t0123456789876543210 - type instance Apply (PairSym1 t0123456789876543210) t0123456789876543210 = Pair t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings PairSym0 where - suppressUnusedWarnings = snd (((,) PairSym0KindInference) ()) - data PairSym0 :: forall a0123456789876543210 b0123456789876543210. - (~>) a0123456789876543210 ((~>) b0123456789876543210 (Pair a0123456789876543210 b0123456789876543210)) - where - PairSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply PairSym0 arg) (PairSym1 arg) => - PairSym0 t0123456789876543210 - type instance Apply PairSym0 t0123456789876543210 = PairSym1 t0123456789876543210 - type AListSym0 = AList - type TupleSym0 = Tuple - type ComplexSym0 = Complex - type PrSym0 = Pr - type family AList where - AList = Apply (Apply (:@#@$) ZeroSym0) (Apply (Apply (:@#@$) (Apply SuccSym0 ZeroSym0)) (Apply (Apply (:@#@$) (Apply SuccSym0 (Apply SuccSym0 ZeroSym0))) '[])) - type family Tuple where - Tuple = Apply (Apply (Apply Tuple3Sym0 FalseSym0) (Apply JustSym0 ZeroSym0)) TrueSym0 - type family Complex where - Complex = Apply (Apply PairSym0 (Apply (Apply PairSym0 (Apply JustSym0 ZeroSym0)) ZeroSym0)) FalseSym0 - type family Pr where - Pr = Apply (Apply PairSym0 (Apply SuccSym0 ZeroSym0)) (Apply (Apply (:@#@$) ZeroSym0) '[]) - type family ShowsPrec_0123456789876543210 (a :: GHC.Types.Nat) (a :: Pair a b) (a :: Symbol) :: Symbol where - ShowsPrec_0123456789876543210 p_0123456789876543210 (Pair arg_0123456789876543210 arg_0123456789876543210) a_0123456789876543210 = Apply (Apply (Apply ShowParenSym0 (Apply (Apply (>@#@$) p_0123456789876543210) (FromInteger 10))) (Apply (Apply (.@#@$) (Apply ShowStringSym0 "Pair ")) (Apply (Apply (.@#@$) (Apply (Apply ShowsPrecSym0 (FromInteger 11)) arg_0123456789876543210)) (Apply (Apply (.@#@$) ShowSpaceSym0) (Apply (Apply ShowsPrecSym0 (FromInteger 11)) arg_0123456789876543210))))) a_0123456789876543210 - type ShowsPrec_0123456789876543210Sym3 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: Pair a0123456789876543210 b0123456789876543210) (a0123456789876543210 :: Symbol) = - ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym2KindInference) ()) - data ShowsPrec_0123456789876543210Sym2 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: Pair a0123456789876543210 b0123456789876543210) :: (~>) Symbol Symbol - where - ShowsPrec_0123456789876543210Sym2KindInference :: forall a0123456789876543210 - a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) arg) (ShowsPrec_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 arg) => - ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym1KindInference) ()) - data ShowsPrec_0123456789876543210Sym1 (a0123456789876543210 :: GHC.Types.Nat) :: forall a0123456789876543210 - b0123456789876543210. - (~>) (Pair a0123456789876543210 b0123456789876543210) ((~>) Symbol Symbol) - where - ShowsPrec_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) arg) (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 arg) => - ShowsPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ShowsPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym0KindInference) ()) - data ShowsPrec_0123456789876543210Sym0 :: forall a0123456789876543210 - b0123456789876543210. - (~>) GHC.Types.Nat ((~>) (Pair a0123456789876543210 b0123456789876543210) ((~>) Symbol Symbol)) - where - ShowsPrec_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply ShowsPrec_0123456789876543210Sym0 arg) (ShowsPrec_0123456789876543210Sym1 arg) => - ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ShowsPrec_0123456789876543210Sym0 a0123456789876543210 = ShowsPrec_0123456789876543210Sym1 a0123456789876543210 - instance PShow (Pair a b) where - type ShowsPrec a a a = Apply (Apply (Apply ShowsPrec_0123456789876543210Sym0 a) a) a - sAList :: Sing AListSym0 - sTuple :: Sing TupleSym0 - sComplex :: Sing ComplexSym0 - sPr :: Sing PrSym0 - sAList - = (applySing ((applySing ((singFun2 @(:@#@$)) SCons)) SZero)) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing ((singFun1 @SuccSym0) SSucc)) SZero))) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing ((singFun1 @SuccSym0) SSucc)) - ((applySing ((singFun1 @SuccSym0) SSucc)) SZero)))) - SNil)) - sTuple - = (applySing - ((applySing ((applySing ((singFun3 @Tuple3Sym0) STuple3)) SFalse)) - ((applySing ((singFun1 @JustSym0) SJust)) SZero))) - STrue - sComplex - = (applySing - ((applySing ((singFun2 @PairSym0) SPair)) - ((applySing - ((applySing ((singFun2 @PairSym0) SPair)) - ((applySing ((singFun1 @JustSym0) SJust)) SZero))) - SZero))) - SFalse - sPr - = (applySing - ((applySing ((singFun2 @PairSym0) SPair)) - ((applySing ((singFun1 @SuccSym0) SSucc)) SZero))) - ((applySing ((applySing ((singFun2 @(:@#@$)) SCons)) SZero)) SNil) - data SPair :: forall a b. Pair a b -> GHC.Types.Type - where - SPair :: forall a b (n :: a) (n :: b). - (Sing (n :: a)) -> (Sing (n :: b)) -> SPair (Pair n n) - type instance Sing @(Pair a b) = SPair - instance (SingKind a, SingKind b) => SingKind (Pair a b) where - type Demote (Pair a b) = Pair (Demote a) (Demote b) - fromSing (SPair b b) = (Pair (fromSing b)) (fromSing b) - toSing (Pair (b :: Demote a) (b :: Demote b)) - = case ((,) (toSing b :: SomeSing a)) (toSing b :: SomeSing b) of { - (,) (SomeSing c) (SomeSing c) -> SomeSing ((SPair c) c) } - instance (SShow a, SShow b) => SShow (Pair a b) where - sShowsPrec :: - forall (t1 :: GHC.Types.Nat) (t2 :: Pair a b) (t3 :: Symbol). - Sing t1 - -> Sing t2 - -> Sing t3 - -> Sing (Apply (Apply (Apply (ShowsPrecSym0 :: TyFun GHC.Types.Nat ((~>) (Pair a b) ((~>) Symbol Symbol)) - -> GHC.Types.Type) t1) t2) t3) - sShowsPrec - (sP_0123456789876543210 :: Sing p_0123456789876543210) - (SPair (sArg_0123456789876543210 :: Sing arg_0123456789876543210) - (sArg_0123456789876543210 :: Sing arg_0123456789876543210)) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing - ((applySing ((singFun3 @ShowParenSym0) sShowParen)) - ((applySing - ((applySing ((singFun2 @(>@#@$)) (%>))) sP_0123456789876543210)) - (sFromInteger (sing :: Sing 10))))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "Pair ")))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((applySing - ((applySing ((singFun3 @ShowsPrecSym0) sShowsPrec)) - (sFromInteger (sing :: Sing 11)))) - sArg_0123456789876543210))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((singFun1 @ShowSpaceSym0) sShowSpace))) - ((applySing - ((applySing ((singFun3 @ShowsPrecSym0) sShowsPrec)) - (sFromInteger (sing :: Sing 11)))) - sArg_0123456789876543210)))))) - sA_0123456789876543210 - instance (Data.Singletons.ShowSing.ShowSing a, - Data.Singletons.ShowSing.ShowSing b) => - Show (SPair (z :: Pair a b)) where - showsPrec - p_0123456789876543210 - (SPair (arg_0123456789876543210 :: Sing argTy_0123456789876543210) - (arg_0123456789876543210 :: Sing argTy_0123456789876543210)) - = (showParen (((>) p_0123456789876543210) 10)) - (((.) (showString "SPair ")) - (((.) ((showsPrec 11) arg_0123456789876543210)) - (((.) GHC.Show.showSpace) - ((showsPrec 11) arg_0123456789876543210)))) :: - (Data.Singletons.ShowSing.ShowSing' argTy_0123456789876543210, - Data.Singletons.ShowSing.ShowSing' argTy_0123456789876543210) => - ShowS - instance (SingI n, SingI n) => SingI (Pair (n :: a) (n :: b)) where - sing = (SPair sing) sing - instance SingI (PairSym0 :: (~>) a ((~>) b (Pair a b))) where - sing = (singFun2 @PairSym0) SPair - instance SingI d => - SingI (PairSym1 (d :: a) :: (~>) b (Pair a b)) where - sing = (singFun1 @(PairSym1 (d :: a))) (SPair (sing @d)) diff --git a/tests/compile-and-dump/Singletons/DataValues.hs b/tests/compile-and-dump/Singletons/DataValues.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/DataValues.hs +++ /dev/null @@ -1,20 +0,0 @@ -module Singletons.DataValues where - -import Data.Singletons.TH -import Data.Singletons.Prelude -import Data.Singletons.Prelude.Show -import Singletons.Nat -import Data.Singletons.SuppressUnusedWarnings - -$(singletons [d| - data Pair a b = Pair a b deriving Show - - pr = Pair (Succ Zero) ([Zero]) - - complex = Pair (Pair (Just Zero) Zero) False - - tuple = (False, Just Zero, True) - - aList = [Zero, Succ Zero, Succ (Succ Zero)] - - |]) diff --git a/tests/compile-and-dump/Singletons/Empty.ghc88.template b/tests/compile-and-dump/Singletons/Empty.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Empty.ghc88.template +++ /dev/null @@ -1,10 +0,0 @@ -Singletons/Empty.hs:(0,0)-(0,0): Splicing declarations - singletons [d| data Empty |] - ======> - data Empty - data SEmpty :: Empty -> GHC.Types.Type - type instance Sing @Empty = SEmpty - instance SingKind Empty where - type Demote Empty = Empty - fromSing x = case x of - toSing x = SomeSing (case x of) diff --git a/tests/compile-and-dump/Singletons/Empty.hs b/tests/compile-and-dump/Singletons/Empty.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Empty.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Singletons.Empty where - -import Data.Singletons.TH - -$(singletons [d| - data Empty - |]) diff --git a/tests/compile-and-dump/Singletons/EmptyShowDeriving.ghc88.template b/tests/compile-and-dump/Singletons/EmptyShowDeriving.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/EmptyShowDeriving.ghc88.template +++ /dev/null @@ -1,70 +0,0 @@ -Singletons/EmptyShowDeriving.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| data Foo - - deriving instance Show Foo |] - ======> - data Foo - deriving instance Show Foo - type family Case_0123456789876543210 v_0123456789876543210 a_0123456789876543210 t where - type family ShowsPrec_0123456789876543210 (a :: GHC.Types.Nat) (a :: Foo) (a :: GHC.Types.Symbol) :: GHC.Types.Symbol where - ShowsPrec_0123456789876543210 _ v_0123456789876543210 a_0123456789876543210 = Apply (Case_0123456789876543210 v_0123456789876543210 a_0123456789876543210 v_0123456789876543210) a_0123456789876543210 - type ShowsPrec_0123456789876543210Sym3 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: Foo) (a0123456789876543210 :: GHC.Types.Symbol) = - ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym2KindInference) ()) - data ShowsPrec_0123456789876543210Sym2 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: Foo) :: (~>) GHC.Types.Symbol GHC.Types.Symbol - where - ShowsPrec_0123456789876543210Sym2KindInference :: forall a0123456789876543210 - a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) arg) (ShowsPrec_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 arg) => - ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym1KindInference) ()) - data ShowsPrec_0123456789876543210Sym1 (a0123456789876543210 :: GHC.Types.Nat) :: (~>) Foo ((~>) GHC.Types.Symbol GHC.Types.Symbol) - where - ShowsPrec_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) arg) (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 arg) => - ShowsPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ShowsPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym0KindInference) ()) - data ShowsPrec_0123456789876543210Sym0 :: (~>) GHC.Types.Nat ((~>) Foo ((~>) GHC.Types.Symbol GHC.Types.Symbol)) - where - ShowsPrec_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply ShowsPrec_0123456789876543210Sym0 arg) (ShowsPrec_0123456789876543210Sym1 arg) => - ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ShowsPrec_0123456789876543210Sym0 a0123456789876543210 = ShowsPrec_0123456789876543210Sym1 a0123456789876543210 - instance PShow Foo where - type ShowsPrec a a a = Apply (Apply (Apply ShowsPrec_0123456789876543210Sym0 a) a) a - data SFoo :: Foo -> GHC.Types.Type - type instance Sing @Foo = SFoo - instance SingKind Foo where - type Demote Foo = Foo - fromSing x = case x of - toSing x = SomeSing (case x of) - instance SShow Foo where - sShowsPrec :: - forall (t1 :: GHC.Types.Nat) (t2 :: Foo) (t3 :: GHC.Types.Symbol). - Sing t1 - -> Sing t2 - -> Sing t3 - -> Sing (Apply (Apply (Apply (ShowsPrecSym0 :: TyFun GHC.Types.Nat ((~>) Foo ((~>) GHC.Types.Symbol GHC.Types.Symbol)) - -> GHC.Types.Type) t1) t2) t3) - sShowsPrec - _ - (sV_0123456789876543210 :: Sing v_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((id - @(Sing (Case_0123456789876543210 v_0123456789876543210 a_0123456789876543210 v_0123456789876543210))) - (case sV_0123456789876543210 of))) - sA_0123456789876543210 - instance Show (SFoo (z :: Foo)) where - showsPrec _ v_0123456789876543210 = case v_0123456789876543210 of diff --git a/tests/compile-and-dump/Singletons/EmptyShowDeriving.hs b/tests/compile-and-dump/Singletons/EmptyShowDeriving.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/EmptyShowDeriving.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Singletons.EmptyShowDeriving where - -import Data.Singletons.TH - -$(singletons [d| data Foo - deriving instance Show Foo - |]) diff --git a/tests/compile-and-dump/Singletons/EnumDeriving.ghc88.template b/tests/compile-and-dump/Singletons/EnumDeriving.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/EnumDeriving.ghc88.template +++ /dev/null @@ -1,204 +0,0 @@ -Singletons/EnumDeriving.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| data Foo - = Bar | Baz | Bum - deriving Enum - data Quux = Q1 | Q2 |] - ======> - data Foo - = Bar | Baz | Bum - deriving Enum - data Quux = Q1 | Q2 - type BarSym0 = Bar - type BazSym0 = Baz - type BumSym0 = Bum - type Q1Sym0 = Q1 - type Q2Sym0 = Q2 - type family Case_0123456789876543210 n t where - Case_0123456789876543210 n 'True = BumSym0 - Case_0123456789876543210 n 'False = Apply ErrorSym0 "toEnum: bad argument" - type family Case_0123456789876543210 n t where - Case_0123456789876543210 n 'True = BazSym0 - Case_0123456789876543210 n 'False = Case_0123456789876543210 n (Apply (Apply (==@#@$) n) (Data.Singletons.Prelude.Num.FromInteger 2)) - type family Case_0123456789876543210 n t where - Case_0123456789876543210 n 'True = BarSym0 - Case_0123456789876543210 n 'False = Case_0123456789876543210 n (Apply (Apply (==@#@$) n) (Data.Singletons.Prelude.Num.FromInteger 1)) - type family ToEnum_0123456789876543210 (a :: GHC.Types.Nat) :: Foo where - ToEnum_0123456789876543210 n = Case_0123456789876543210 n (Apply (Apply (==@#@$) n) (Data.Singletons.Prelude.Num.FromInteger 0)) - type ToEnum_0123456789876543210Sym1 (a0123456789876543210 :: GHC.Types.Nat) = - ToEnum_0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ToEnum_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ToEnum_0123456789876543210Sym0KindInference) ()) - data ToEnum_0123456789876543210Sym0 :: (~>) GHC.Types.Nat Foo - where - ToEnum_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply ToEnum_0123456789876543210Sym0 arg) (ToEnum_0123456789876543210Sym1 arg) => - ToEnum_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ToEnum_0123456789876543210Sym0 a0123456789876543210 = ToEnum_0123456789876543210 a0123456789876543210 - type family FromEnum_0123456789876543210 (a :: Foo) :: GHC.Types.Nat where - FromEnum_0123456789876543210 Bar = Data.Singletons.Prelude.Num.FromInteger 0 - FromEnum_0123456789876543210 Baz = Data.Singletons.Prelude.Num.FromInteger 1 - FromEnum_0123456789876543210 Bum = Data.Singletons.Prelude.Num.FromInteger 2 - type FromEnum_0123456789876543210Sym1 (a0123456789876543210 :: Foo) = - FromEnum_0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings FromEnum_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) FromEnum_0123456789876543210Sym0KindInference) ()) - data FromEnum_0123456789876543210Sym0 :: (~>) Foo GHC.Types.Nat - where - FromEnum_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply FromEnum_0123456789876543210Sym0 arg) (FromEnum_0123456789876543210Sym1 arg) => - FromEnum_0123456789876543210Sym0 a0123456789876543210 - type instance Apply FromEnum_0123456789876543210Sym0 a0123456789876543210 = FromEnum_0123456789876543210 a0123456789876543210 - instance PEnum Foo where - type ToEnum a = Apply ToEnum_0123456789876543210Sym0 a - type FromEnum a = Apply FromEnum_0123456789876543210Sym0 a - data SFoo :: Foo -> GHC.Types.Type - where - SBar :: SFoo Bar - SBaz :: SFoo Baz - SBum :: SFoo Bum - type instance Sing @Foo = SFoo - instance SingKind Foo where - type Demote Foo = Foo - fromSing SBar = Bar - fromSing SBaz = Baz - fromSing SBum = Bum - toSing Bar = SomeSing SBar - toSing Baz = SomeSing SBaz - toSing Bum = SomeSing SBum - data SQuux :: Quux -> GHC.Types.Type - where - SQ1 :: SQuux Q1 - SQ2 :: SQuux Q2 - type instance Sing @Quux = SQuux - instance SingKind Quux where - type Demote Quux = Quux - fromSing SQ1 = Q1 - fromSing SQ2 = Q2 - toSing Q1 = SomeSing SQ1 - toSing Q2 = SomeSing SQ2 - instance SEnum Foo where - sToEnum :: - forall (t :: GHC.Types.Nat). - Sing t - -> Sing (Apply (Data.Singletons.Prelude.Enum.ToEnumSym0 :: TyFun GHC.Types.Nat Foo - -> GHC.Types.Type) t) - sFromEnum :: - forall (t :: Foo). - Sing t - -> Sing (Apply (Data.Singletons.Prelude.Enum.FromEnumSym0 :: TyFun Foo GHC.Types.Nat - -> GHC.Types.Type) t) - sToEnum (sN :: Sing n) - = (id - @(Sing (Case_0123456789876543210 n (Apply (Apply (==@#@$) n) (Data.Singletons.Prelude.Num.FromInteger 0))))) - (case - (applySing ((applySing ((singFun2 @(==@#@$)) (%==))) sN)) - (Data.Singletons.Prelude.Num.sFromInteger (sing :: Sing 0)) - of - STrue -> SBar - SFalse - -> (id - @(Sing (Case_0123456789876543210 n (Apply (Apply (==@#@$) n) (Data.Singletons.Prelude.Num.FromInteger 1))))) - (case - (applySing ((applySing ((singFun2 @(==@#@$)) (%==))) sN)) - (Data.Singletons.Prelude.Num.sFromInteger (sing :: Sing 1)) - of - STrue -> SBaz - SFalse - -> (id - @(Sing (Case_0123456789876543210 n (Apply (Apply (==@#@$) n) (Data.Singletons.Prelude.Num.FromInteger 2))))) - (case - (applySing ((applySing ((singFun2 @(==@#@$)) (%==))) sN)) - (Data.Singletons.Prelude.Num.sFromInteger (sing :: Sing 2)) - of - STrue -> SBum - SFalse -> sError (sing :: Sing "toEnum: bad argument")))) - sFromEnum SBar - = Data.Singletons.Prelude.Num.sFromInteger (sing :: Sing 0) - sFromEnum SBaz - = Data.Singletons.Prelude.Num.sFromInteger (sing :: Sing 1) - sFromEnum SBum - = Data.Singletons.Prelude.Num.sFromInteger (sing :: Sing 2) - instance SingI Bar where - sing = SBar - instance SingI Baz where - sing = SBaz - instance SingI Bum where - sing = SBum - instance SingI Q1 where - sing = SQ1 - instance SingI Q2 where - sing = SQ2 -Singletons/EnumDeriving.hs:0:0:: Splicing declarations - singEnumInstance ''Quux - ======> - type family Case_0123456789876543210 n t where - Case_0123456789876543210 n 'True = Q2Sym0 - Case_0123456789876543210 n 'False = Apply ErrorSym0 "toEnum: bad argument" - type family Case_0123456789876543210 n t where - Case_0123456789876543210 n 'True = Q1Sym0 - Case_0123456789876543210 n 'False = Case_0123456789876543210 n (Apply (Apply (==@#@$) n) (Data.Singletons.Prelude.Num.FromInteger 1)) - type family ToEnum_0123456789876543210 (a :: GHC.Types.Nat) :: Quux where - ToEnum_0123456789876543210 n = Case_0123456789876543210 n (Apply (Apply (==@#@$) n) (Data.Singletons.Prelude.Num.FromInteger 0)) - type ToEnum_0123456789876543210Sym1 (a0123456789876543210 :: GHC.Types.Nat) = - ToEnum_0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ToEnum_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ToEnum_0123456789876543210Sym0KindInference) ()) - data ToEnum_0123456789876543210Sym0 :: (~>) GHC.Types.Nat Quux - where - ToEnum_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply ToEnum_0123456789876543210Sym0 arg) (ToEnum_0123456789876543210Sym1 arg) => - ToEnum_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ToEnum_0123456789876543210Sym0 a0123456789876543210 = ToEnum_0123456789876543210 a0123456789876543210 - type family FromEnum_0123456789876543210 (a :: Quux) :: GHC.Types.Nat where - FromEnum_0123456789876543210 'Q1 = Data.Singletons.Prelude.Num.FromInteger 0 - FromEnum_0123456789876543210 'Q2 = Data.Singletons.Prelude.Num.FromInteger 1 - type FromEnum_0123456789876543210Sym1 (a0123456789876543210 :: Quux) = - FromEnum_0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings FromEnum_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) FromEnum_0123456789876543210Sym0KindInference) ()) - data FromEnum_0123456789876543210Sym0 :: (~>) Quux GHC.Types.Nat - where - FromEnum_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply FromEnum_0123456789876543210Sym0 arg) (FromEnum_0123456789876543210Sym1 arg) => - FromEnum_0123456789876543210Sym0 a0123456789876543210 - type instance Apply FromEnum_0123456789876543210Sym0 a0123456789876543210 = FromEnum_0123456789876543210 a0123456789876543210 - instance PEnum Quux where - type ToEnum a = Apply ToEnum_0123456789876543210Sym0 a - type FromEnum a = Apply FromEnum_0123456789876543210Sym0 a - instance SEnum Quux where - sToEnum :: - forall (t :: GHC.Types.Nat). - Sing t - -> Sing (Apply (Data.Singletons.Prelude.Enum.ToEnumSym0 :: TyFun GHC.Types.Nat Quux - -> GHC.Types.Type) t) - sFromEnum :: - forall (t :: Quux). - Sing t - -> Sing (Apply (Data.Singletons.Prelude.Enum.FromEnumSym0 :: TyFun Quux GHC.Types.Nat - -> GHC.Types.Type) t) - sToEnum (sN :: Sing n) - = (id - @(Sing (Case_0123456789876543210 n (Apply (Apply (==@#@$) n) (Data.Singletons.Prelude.Num.FromInteger 0))))) - (case - (applySing ((applySing ((singFun2 @(==@#@$)) (%==))) sN)) - (Data.Singletons.Prelude.Num.sFromInteger (sing :: Sing 0)) - of - STrue -> SQ1 - SFalse - -> (id - @(Sing (Case_0123456789876543210 n (Apply (Apply (==@#@$) n) (Data.Singletons.Prelude.Num.FromInteger 1))))) - (case - (applySing ((applySing ((singFun2 @(==@#@$)) (%==))) sN)) - (Data.Singletons.Prelude.Num.sFromInteger (sing :: Sing 1)) - of - STrue -> SQ2 - SFalse -> sError (sing :: Sing "toEnum: bad argument"))) - sFromEnum SQ1 - = Data.Singletons.Prelude.Num.sFromInteger (sing :: Sing 0) - sFromEnum SQ2 - = Data.Singletons.Prelude.Num.sFromInteger (sing :: Sing 1) diff --git a/tests/compile-and-dump/Singletons/EnumDeriving.hs b/tests/compile-and-dump/Singletons/EnumDeriving.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/EnumDeriving.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Singletons.EnumDeriving where - -import Data.Singletons.TH - -$(singletons [d| - data Foo = Bar | Baz | Bum - deriving Enum - data Quux = Q1 | Q2 - |]) - -$(singEnumInstance ''Quux) diff --git a/tests/compile-and-dump/Singletons/EqInstances.ghc88.template b/tests/compile-and-dump/Singletons/EqInstances.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/EqInstances.ghc88.template +++ /dev/null @@ -1,21 +0,0 @@ -Singletons/EqInstances.hs:0:0:: Splicing declarations - singEqInstances [''Foo, ''Empty] - ======> - instance SEq Foo => SEq Foo where - (%==) SFLeaf SFLeaf = STrue - (%==) SFLeaf ((:%+:) _ _) = SFalse - (%==) ((:%+:) _ _) SFLeaf = SFalse - (%==) ((:%+:) a a) ((:%+:) b b) - = ((%&&) (((%==) a) b)) (((%==) a) b) - type family Equals_0123456789876543210 (a :: Foo) (b :: Foo) :: Bool where - Equals_0123456789876543210 'FLeaf 'FLeaf = TrueSym0 - Equals_0123456789876543210 ('(:+:) a a) ('(:+:) b b) = (&&) ((==) a b) ((==) a b) - Equals_0123456789876543210 (_ :: Foo) (_ :: Foo) = FalseSym0 - instance PEq Foo where - type (==) a b = Equals_0123456789876543210 a b - instance SEq Empty where - (%==) _ _ = STrue - type family Equals_0123456789876543210 (a :: Empty) (b :: Empty) :: Bool where - Equals_0123456789876543210 (_ :: Empty) (_ :: Empty) = TrueSym0 - instance PEq Empty where - type (==) a b = Equals_0123456789876543210 a b diff --git a/tests/compile-and-dump/Singletons/EqInstances.hs b/tests/compile-and-dump/Singletons/EqInstances.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/EqInstances.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Singletons.EqInstances where - -import Data.Singletons.TH -import Data.Singletons.Prelude.Bool -import Singletons.Empty -import Singletons.Operators - -$(singEqInstances [''Foo, ''Empty]) diff --git a/tests/compile-and-dump/Singletons/Error.ghc88.template b/tests/compile-and-dump/Singletons/Error.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Error.ghc88.template +++ /dev/null @@ -1,30 +0,0 @@ -Singletons/Error.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| head :: [a] -> a - head (a : _) = a - head [] = error "Data.Singletons.List.head: empty list" |] - ======> - head :: [a] -> a - head (a : _) = a - head [] = error "Data.Singletons.List.head: empty list" - type HeadSym1 (a0123456789876543210 :: [a0123456789876543210]) = - Head a0123456789876543210 - instance SuppressUnusedWarnings HeadSym0 where - suppressUnusedWarnings = snd (((,) HeadSym0KindInference) ()) - data HeadSym0 :: forall a0123456789876543210. - (~>) [a0123456789876543210] a0123456789876543210 - where - HeadSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply HeadSym0 arg) (HeadSym1 arg) => - HeadSym0 a0123456789876543210 - type instance Apply HeadSym0 a0123456789876543210 = Head a0123456789876543210 - type family Head (a :: [a]) :: a where - Head ('(:) a _) = a - Head '[] = Apply ErrorSym0 "Data.Singletons.List.head: empty list" - sHead :: - forall a (t :: [a]). Sing t -> Sing (Apply HeadSym0 t :: a) - sHead (SCons (sA :: Sing a) _) = sA - sHead SNil - = sError (sing :: Sing "Data.Singletons.List.head: empty list") - instance SingI (HeadSym0 :: (~>) [a] a) where - sing = (singFun1 @HeadSym0) sHead diff --git a/tests/compile-and-dump/Singletons/Error.hs b/tests/compile-and-dump/Singletons/Error.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Error.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Singletons.Error where - -import Data.Singletons -import Data.Singletons.Prelude hiding (Head, HeadSym0, HeadSym1, sHead) -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/Fixity.ghc88.template b/tests/compile-and-dump/Singletons/Fixity.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Fixity.ghc88.template +++ /dev/null @@ -1,86 +0,0 @@ -Singletons/Fixity.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| infix 4 ==== - infix 4 <=> - - (====) :: a -> a -> a - a ==== _ = a - - class MyOrd a where - (<=>) :: a -> a -> Ordering - infix 4 <=> |] - ======> - class MyOrd a where - (<=>) :: a -> a -> Ordering - infix 4 <=> - (====) :: a -> a -> a - (====) a _ = a - infix 4 ==== - type (====@#@$$$) (a0123456789876543210 :: a0123456789876543210) (a0123456789876543210 :: a0123456789876543210) = - (====) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((====@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (:====@#@$$###)) ()) - data (====@#@$$) (a0123456789876543210 :: a0123456789876543210) :: (~>) a0123456789876543210 a0123456789876543210 - where - (:====@#@$$###) :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply ((====@#@$$) a0123456789876543210) arg) ((====@#@$$$) a0123456789876543210 arg) => - (====@#@$$) a0123456789876543210 a0123456789876543210 - type instance Apply ((====@#@$$) a0123456789876543210) a0123456789876543210 = (====) a0123456789876543210 a0123456789876543210 - infix 4 ====@#@$$ - instance SuppressUnusedWarnings (====@#@$) where - suppressUnusedWarnings = snd (((,) (:====@#@$###)) ()) - data (====@#@$) :: forall a0123456789876543210. - (~>) a0123456789876543210 ((~>) a0123456789876543210 a0123456789876543210) - where - (:====@#@$###) :: forall a0123456789876543210 - arg. SameKind (Apply (====@#@$) arg) ((====@#@$$) arg) => - (====@#@$) a0123456789876543210 - type instance Apply (====@#@$) a0123456789876543210 = (====@#@$$) a0123456789876543210 - infix 4 ====@#@$ - type family (====) (a :: a) (a :: a) :: a where - (====) a _ = a - type (<=>@#@$$$) (arg0123456789876543210 :: a0123456789876543210) (arg0123456789876543210 :: a0123456789876543210) = - (<=>) arg0123456789876543210 arg0123456789876543210 - instance SuppressUnusedWarnings ((<=>@#@$$) arg0123456789876543210) where - suppressUnusedWarnings = snd (((,) (:<=>@#@$$###)) ()) - data (<=>@#@$$) (arg0123456789876543210 :: a0123456789876543210) :: (~>) a0123456789876543210 Ordering - where - (:<=>@#@$$###) :: forall arg0123456789876543210 - arg0123456789876543210 - arg. SameKind (Apply ((<=>@#@$$) arg0123456789876543210) arg) ((<=>@#@$$$) arg0123456789876543210 arg) => - (<=>@#@$$) arg0123456789876543210 arg0123456789876543210 - type instance Apply ((<=>@#@$$) arg0123456789876543210) arg0123456789876543210 = (<=>) arg0123456789876543210 arg0123456789876543210 - infix 4 <=>@#@$$ - instance SuppressUnusedWarnings (<=>@#@$) where - suppressUnusedWarnings = snd (((,) (:<=>@#@$###)) ()) - data (<=>@#@$) :: forall a0123456789876543210. - (~>) a0123456789876543210 ((~>) a0123456789876543210 Ordering) - where - (:<=>@#@$###) :: forall arg0123456789876543210 - arg. SameKind (Apply (<=>@#@$) arg) ((<=>@#@$$) arg) => - (<=>@#@$) arg0123456789876543210 - type instance Apply (<=>@#@$) arg0123456789876543210 = (<=>@#@$$) arg0123456789876543210 - infix 4 <=>@#@$ - class PMyOrd (a :: GHC.Types.Type) where - type (<=>) (arg :: a) (arg :: a) :: Ordering - infix 4 %==== - infix 4 %<=> - (%====) :: - forall a (t :: a) (t :: a). - Sing t -> Sing t -> Sing (Apply (Apply (====@#@$) t) t :: a) - (%====) (sA :: Sing a) _ = sA - instance SingI ((====@#@$) :: (~>) a ((~>) a a)) where - sing = (singFun2 @(====@#@$)) (%====) - instance SingI d => SingI ((====@#@$$) (d :: a) :: (~>) a a) where - sing = (singFun1 @((====@#@$$) (d :: a))) ((%====) (sing @d)) - class SMyOrd a where - (%<=>) :: - forall (t :: a) (t :: a). - Sing t -> Sing t -> Sing (Apply (Apply (<=>@#@$) t) t :: Ordering) - instance SMyOrd a => - SingI ((<=>@#@$) :: (~>) a ((~>) a Ordering)) where - sing = (singFun2 @(<=>@#@$)) (%<=>) - instance (SMyOrd a, SingI d) => - SingI ((<=>@#@$$) (d :: a) :: (~>) a Ordering) where - sing = (singFun1 @((<=>@#@$$) (d :: a))) ((%<=>) (sing @d)) diff --git a/tests/compile-and-dump/Singletons/Fixity.hs b/tests/compile-and-dump/Singletons/Fixity.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Fixity.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Singletons.Fixity where - -import Data.Singletons -import Data.Singletons.TH -import Data.Singletons.Prelude -import Language.Haskell.TH.Desugar - -$(singletons [d| - class MyOrd a where - (<=>) :: a -> a -> Ordering - infix 4 <=> - - (====) :: a -> a -> a - a ==== _ = a - infix 4 ==== - |]) diff --git a/tests/compile-and-dump/Singletons/FunDeps.ghc88.template b/tests/compile-and-dump/Singletons/FunDeps.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/FunDeps.ghc88.template +++ /dev/null @@ -1,96 +0,0 @@ -Singletons/FunDeps.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| t1 = meth True - - class FD a b | a -> b where - meth :: a -> a - l2r :: a -> b - - instance FD Bool Nat where - meth = not - l2r False = 0 - l2r True = 1 |] - ======> - class FD a b | a -> b where - meth :: a -> a - l2r :: a -> b - instance FD Bool Nat where - meth = not - l2r False = 0 - l2r True = 1 - t1 = meth True - type T1Sym0 = T1 - type family T1 where - T1 = Apply MethSym0 TrueSym0 - type MethSym1 (arg0123456789876543210 :: a0123456789876543210) = - Meth arg0123456789876543210 - instance SuppressUnusedWarnings MethSym0 where - suppressUnusedWarnings = snd (((,) MethSym0KindInference) ()) - data MethSym0 :: forall a0123456789876543210. - (~>) a0123456789876543210 a0123456789876543210 - where - MethSym0KindInference :: forall arg0123456789876543210 - arg. SameKind (Apply MethSym0 arg) (MethSym1 arg) => - MethSym0 arg0123456789876543210 - type instance Apply MethSym0 arg0123456789876543210 = Meth arg0123456789876543210 - type L2rSym1 (arg0123456789876543210 :: a0123456789876543210) = - L2r arg0123456789876543210 - instance SuppressUnusedWarnings L2rSym0 where - suppressUnusedWarnings = snd (((,) L2rSym0KindInference) ()) - data L2rSym0 :: forall a0123456789876543210 b0123456789876543210. - (~>) a0123456789876543210 b0123456789876543210 - where - L2rSym0KindInference :: forall arg0123456789876543210 - arg. SameKind (Apply L2rSym0 arg) (L2rSym1 arg) => - L2rSym0 arg0123456789876543210 - type instance Apply L2rSym0 arg0123456789876543210 = L2r arg0123456789876543210 - class PFD (a :: GHC.Types.Type) (b :: GHC.Types.Type) | a -> b where - type Meth (arg :: a) :: a - type L2r (arg :: a) :: b - type family Meth_0123456789876543210 (a :: Bool) :: Bool where - Meth_0123456789876543210 a_0123456789876543210 = Apply NotSym0 a_0123456789876543210 - type Meth_0123456789876543210Sym1 (a0123456789876543210 :: Bool) = - Meth_0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Meth_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Meth_0123456789876543210Sym0KindInference) ()) - data Meth_0123456789876543210Sym0 :: (~>) Bool Bool - where - Meth_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Meth_0123456789876543210Sym0 arg) (Meth_0123456789876543210Sym1 arg) => - Meth_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Meth_0123456789876543210Sym0 a0123456789876543210 = Meth_0123456789876543210 a0123456789876543210 - type family L2r_0123456789876543210 (a :: Bool) :: Nat where - L2r_0123456789876543210 'False = FromInteger 0 - L2r_0123456789876543210 'True = FromInteger 1 - type L2r_0123456789876543210Sym1 (a0123456789876543210 :: Bool) = - L2r_0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings L2r_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) L2r_0123456789876543210Sym0KindInference) ()) - data L2r_0123456789876543210Sym0 :: (~>) Bool Nat - where - L2r_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply L2r_0123456789876543210Sym0 arg) (L2r_0123456789876543210Sym1 arg) => - L2r_0123456789876543210Sym0 a0123456789876543210 - type instance Apply L2r_0123456789876543210Sym0 a0123456789876543210 = L2r_0123456789876543210 a0123456789876543210 - instance PFD Bool Nat where - type Meth a = Apply Meth_0123456789876543210Sym0 a - type L2r a = Apply L2r_0123456789876543210Sym0 a - sT1 :: Sing T1Sym0 - sT1 = (applySing ((singFun1 @MethSym0) sMeth)) STrue - class SFD a b | a -> b where - sMeth :: forall (t :: a). Sing t -> Sing (Apply MethSym0 t :: a) - sL2r :: forall (t :: a). Sing t -> Sing (Apply L2rSym0 t :: b) - instance SFD Bool Nat where - sMeth :: - forall (t :: Bool). Sing t -> Sing (Apply MethSym0 t :: Bool) - sL2r :: forall (t :: Bool). Sing t -> Sing (Apply L2rSym0 t :: Nat) - sMeth (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing ((singFun1 @NotSym0) sNot)) sA_0123456789876543210 - sL2r SFalse = sFromInteger (sing :: Sing 0) - sL2r STrue = sFromInteger (sing :: Sing 1) - instance SFD a b => SingI (MethSym0 :: (~>) a a) where - sing = (singFun1 @MethSym0) sMeth - instance SFD a b => SingI (L2rSym0 :: (~>) a b) where - sing = (singFun1 @L2rSym0) sL2r diff --git a/tests/compile-and-dump/Singletons/FunDeps.hs b/tests/compile-and-dump/Singletons/FunDeps.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/FunDeps.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE FunctionalDependencies #-} - -module Singletons.FunDeps where - -import Data.Singletons.TH -import Data.Singletons.Prelude -import Data.Singletons.TypeLits - -$( singletons [d| - class FD a b | a -> b where - meth :: a -> a - l2r :: a -> b - - instance FD Bool Nat where - meth = not - l2r False = 0 - l2r True = 1 - - t1 = meth True --- t2 = l2r False -- This fails because no FDs in type families - |]) diff --git a/tests/compile-and-dump/Singletons/FunctorLikeDeriving.ghc88.template b/tests/compile-and-dump/Singletons/FunctorLikeDeriving.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/FunctorLikeDeriving.ghc88.template +++ /dev/null @@ -1,1632 +0,0 @@ -Singletons/FunctorLikeDeriving.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| data T x a - = MkT1 x a (Maybe a) (Maybe (Maybe a)) | MkT2 (Maybe x) - deriving (Functor, Foldable, Traversable) - data Empty (a :: Type) deriving (Functor, Foldable, Traversable) |] - ======> - data T x a - = MkT1 x a (Maybe a) (Maybe (Maybe a)) | MkT2 (Maybe x) - deriving (Functor, Foldable, Traversable) - data Empty (a :: Type) deriving (Functor, Foldable, Traversable) - type MkT1Sym4 (t0123456789876543210 :: x0123456789876543210) (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: Maybe a0123456789876543210) (t0123456789876543210 :: Maybe (Maybe a0123456789876543210)) = - MkT1 t0123456789876543210 t0123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (MkT1Sym3 t0123456789876543210 t0123456789876543210 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) MkT1Sym3KindInference) ()) - data MkT1Sym3 (t0123456789876543210 :: x0123456789876543210) (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: Maybe a0123456789876543210) :: (~>) (Maybe (Maybe a0123456789876543210)) (T x0123456789876543210 a0123456789876543210) - where - MkT1Sym3KindInference :: forall t0123456789876543210 - t0123456789876543210 - t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (MkT1Sym3 t0123456789876543210 t0123456789876543210 t0123456789876543210) arg) (MkT1Sym4 t0123456789876543210 t0123456789876543210 t0123456789876543210 arg) => - MkT1Sym3 t0123456789876543210 t0123456789876543210 t0123456789876543210 t0123456789876543210 - type instance Apply (MkT1Sym3 t0123456789876543210 t0123456789876543210 t0123456789876543210) t0123456789876543210 = MkT1 t0123456789876543210 t0123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (MkT1Sym2 t0123456789876543210 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) MkT1Sym2KindInference) ()) - data MkT1Sym2 (t0123456789876543210 :: x0123456789876543210) (t0123456789876543210 :: a0123456789876543210) :: (~>) (Maybe a0123456789876543210) ((~>) (Maybe (Maybe a0123456789876543210)) (T x0123456789876543210 a0123456789876543210)) - where - MkT1Sym2KindInference :: forall t0123456789876543210 - t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (MkT1Sym2 t0123456789876543210 t0123456789876543210) arg) (MkT1Sym3 t0123456789876543210 t0123456789876543210 arg) => - MkT1Sym2 t0123456789876543210 t0123456789876543210 t0123456789876543210 - type instance Apply (MkT1Sym2 t0123456789876543210 t0123456789876543210) t0123456789876543210 = MkT1Sym3 t0123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (MkT1Sym1 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) MkT1Sym1KindInference) ()) - data MkT1Sym1 (t0123456789876543210 :: x0123456789876543210) :: forall a0123456789876543210. - (~>) a0123456789876543210 ((~>) (Maybe a0123456789876543210) ((~>) (Maybe (Maybe a0123456789876543210)) (T x0123456789876543210 a0123456789876543210))) - where - MkT1Sym1KindInference :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (MkT1Sym1 t0123456789876543210) arg) (MkT1Sym2 t0123456789876543210 arg) => - MkT1Sym1 t0123456789876543210 t0123456789876543210 - type instance Apply (MkT1Sym1 t0123456789876543210) t0123456789876543210 = MkT1Sym2 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings MkT1Sym0 where - suppressUnusedWarnings = snd (((,) MkT1Sym0KindInference) ()) - data MkT1Sym0 :: forall x0123456789876543210 a0123456789876543210. - (~>) x0123456789876543210 ((~>) a0123456789876543210 ((~>) (Maybe a0123456789876543210) ((~>) (Maybe (Maybe a0123456789876543210)) (T x0123456789876543210 a0123456789876543210)))) - where - MkT1Sym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply MkT1Sym0 arg) (MkT1Sym1 arg) => - MkT1Sym0 t0123456789876543210 - type instance Apply MkT1Sym0 t0123456789876543210 = MkT1Sym1 t0123456789876543210 - type MkT2Sym1 (t0123456789876543210 :: Maybe x0123456789876543210) = - MkT2 t0123456789876543210 - instance SuppressUnusedWarnings MkT2Sym0 where - suppressUnusedWarnings = snd (((,) MkT2Sym0KindInference) ()) - data MkT2Sym0 :: forall x0123456789876543210 a0123456789876543210. - (~>) (Maybe x0123456789876543210) (T x0123456789876543210 a0123456789876543210) - where - MkT2Sym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply MkT2Sym0 arg) (MkT2Sym1 arg) => - MkT2Sym0 t0123456789876543210 - type instance Apply MkT2Sym0 t0123456789876543210 = MkT2 t0123456789876543210 - type family Lambda_0123456789876543210 _f_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 t where - Lambda_0123456789876543210 _f_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 n_0123456789876543210 = n_0123456789876543210 - type Lambda_0123456789876543210Sym6 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym5 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym5KindInference) ()) - data Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym5KindInference :: forall _f_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym6 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym5 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym4 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym4KindInference) ()) - data Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym4KindInference :: forall _f_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym4 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym5 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym3KindInference) ()) - data Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym3KindInference :: forall _f_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym4 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall _f_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall _f_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall _f_01234567898765432100123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 - type family Lambda_0123456789876543210 _f_0123456789876543210 a_0123456789876543210 t where - Lambda_0123456789876543210 _f_0123456789876543210 a_0123456789876543210 n_0123456789876543210 = n_0123456789876543210 - type Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall _f_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 a_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall _f_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall _f_01234567898765432100123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 - type family Fmap_0123456789876543210 (a :: (~>) a0 b0) (a :: T x a0) :: T x b0 where - Fmap_0123456789876543210 _f_0123456789876543210 (MkT1 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210) = Apply (Apply (Apply (Apply MkT1Sym0 (Apply (Apply (Apply (Apply (Apply (Apply Lambda_0123456789876543210Sym0 _f_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210)) (Apply _f_0123456789876543210 a_0123456789876543210)) (Apply (Apply FmapSym0 _f_0123456789876543210) a_0123456789876543210)) (Apply (Apply FmapSym0 (Apply FmapSym0 _f_0123456789876543210)) a_0123456789876543210) - Fmap_0123456789876543210 _f_0123456789876543210 (MkT2 a_0123456789876543210) = Apply MkT2Sym0 (Apply (Apply (Apply Lambda_0123456789876543210Sym0 _f_0123456789876543210) a_0123456789876543210) a_0123456789876543210) - type Fmap_0123456789876543210Sym2 (a0123456789876543210 :: (~>) a01234567898765432100 b01234567898765432100) (a0123456789876543210 :: T x0123456789876543210 a01234567898765432100) = - Fmap_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Fmap_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Fmap_0123456789876543210Sym1KindInference) ()) - data Fmap_0123456789876543210Sym1 (a0123456789876543210 :: (~>) a01234567898765432100 b01234567898765432100) :: forall x0123456789876543210. - (~>) (T x0123456789876543210 a01234567898765432100) (T x0123456789876543210 b01234567898765432100) - where - Fmap_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Fmap_0123456789876543210Sym1 a0123456789876543210) arg) (Fmap_0123456789876543210Sym2 a0123456789876543210 arg) => - Fmap_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Fmap_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Fmap_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Fmap_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Fmap_0123456789876543210Sym0KindInference) ()) - data Fmap_0123456789876543210Sym0 :: forall a01234567898765432100 - b01234567898765432100 - x0123456789876543210. - (~>) ((~>) a01234567898765432100 b01234567898765432100) ((~>) (T x0123456789876543210 a01234567898765432100) (T x0123456789876543210 b01234567898765432100)) - where - Fmap_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Fmap_0123456789876543210Sym0 arg) (Fmap_0123456789876543210Sym1 arg) => - Fmap_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Fmap_0123456789876543210Sym0 a0123456789876543210 = Fmap_0123456789876543210Sym1 a0123456789876543210 - type family Lambda_0123456789876543210 _z_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 t where - Lambda_0123456789876543210 _z_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 n_0123456789876543210 = n_0123456789876543210 - type Lambda_0123456789876543210Sym6 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym5 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym5KindInference) ()) - data Lambda_0123456789876543210Sym5 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym5KindInference :: forall _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym5 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym6 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym5 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym5 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym4 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym4KindInference) ()) - data Lambda_0123456789876543210Sym4 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym4KindInference :: forall _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym4 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym5 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym4 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym4 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym5 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym3KindInference) ()) - data Lambda_0123456789876543210Sym3 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym3KindInference :: forall _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym3 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym4 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym3 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym4 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym3 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym2 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 _z_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 _z_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym2 _z_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym1 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 _z_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym2 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 _z_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall _z_01234567898765432100123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 _z_01234567898765432100123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 _z_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym1 _z_01234567898765432100123456789876543210 - type family Lambda_0123456789876543210 _z_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 t where - Lambda_0123456789876543210 _z_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 n_0123456789876543210 = _z_0123456789876543210 - type Lambda_0123456789876543210Sym6 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym5 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym5KindInference) ()) - data Lambda_0123456789876543210Sym5 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym5KindInference :: forall _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym5 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym6 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym5 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym5 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym4 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym4KindInference) ()) - data Lambda_0123456789876543210Sym4 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym4KindInference :: forall _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym4 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym5 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym4 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym4 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym5 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym3KindInference) ()) - data Lambda_0123456789876543210Sym3 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym3KindInference :: forall _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym3 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym4 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym3 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym4 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym3 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym2 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 _z_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 _z_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym2 _z_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym1 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 _z_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym2 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 _z_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall _z_01234567898765432100123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 _z_01234567898765432100123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 _z_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym1 _z_01234567898765432100123456789876543210 - type family Lambda_0123456789876543210 _z_0123456789876543210 a_0123456789876543210 t where - Lambda_0123456789876543210 _z_0123456789876543210 a_0123456789876543210 n_0123456789876543210 = n_0123456789876543210 - type Lambda_0123456789876543210Sym3 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym3 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym2 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 _z_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 _z_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym2 _z_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym1 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 _z_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym2 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 _z_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall _z_01234567898765432100123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 _z_01234567898765432100123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 _z_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym1 _z_01234567898765432100123456789876543210 - type family TFHelper_0123456789876543210 (a :: a0) (a :: T x b0) :: T x a0 where - TFHelper_0123456789876543210 _z_0123456789876543210 (MkT1 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210) = Apply (Apply (Apply (Apply MkT1Sym0 (Apply (Apply (Apply (Apply (Apply (Apply Lambda_0123456789876543210Sym0 _z_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210)) (Apply (Apply (Apply (Apply (Apply (Apply Lambda_0123456789876543210Sym0 _z_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210)) (Apply (Apply (<$@#@$) _z_0123456789876543210) a_0123456789876543210)) (Apply (Apply FmapSym0 (Apply (<$@#@$) _z_0123456789876543210)) a_0123456789876543210) - TFHelper_0123456789876543210 _z_0123456789876543210 (MkT2 a_0123456789876543210) = Apply MkT2Sym0 (Apply (Apply (Apply Lambda_0123456789876543210Sym0 _z_0123456789876543210) a_0123456789876543210) a_0123456789876543210) - type TFHelper_0123456789876543210Sym2 (a0123456789876543210 :: a01234567898765432100) (a0123456789876543210 :: T x0123456789876543210 b01234567898765432100) = - TFHelper_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (TFHelper_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) TFHelper_0123456789876543210Sym1KindInference) ()) - data TFHelper_0123456789876543210Sym1 (a0123456789876543210 :: a01234567898765432100) :: forall x0123456789876543210 - b01234567898765432100. - (~>) (T x0123456789876543210 b01234567898765432100) (T x0123456789876543210 a01234567898765432100) - where - TFHelper_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (TFHelper_0123456789876543210Sym1 a0123456789876543210) arg) (TFHelper_0123456789876543210Sym2 a0123456789876543210 arg) => - TFHelper_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (TFHelper_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = TFHelper_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings TFHelper_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) TFHelper_0123456789876543210Sym0KindInference) ()) - data TFHelper_0123456789876543210Sym0 :: forall a01234567898765432100 - x0123456789876543210 - b01234567898765432100. - (~>) a01234567898765432100 ((~>) (T x0123456789876543210 b01234567898765432100) (T x0123456789876543210 a01234567898765432100)) - where - TFHelper_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply TFHelper_0123456789876543210Sym0 arg) (TFHelper_0123456789876543210Sym1 arg) => - TFHelper_0123456789876543210Sym0 a0123456789876543210 - type instance Apply TFHelper_0123456789876543210Sym0 a0123456789876543210 = TFHelper_0123456789876543210Sym1 a0123456789876543210 - instance PFunctor (T x) where - type Fmap a a = Apply (Apply Fmap_0123456789876543210Sym0 a) a - type (<$) a a = Apply (Apply TFHelper_0123456789876543210Sym0 a) a - type family Lambda_0123456789876543210 _f_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 t where - Lambda_0123456789876543210 _f_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 n_0123456789876543210 = MemptySym0 - type Lambda_0123456789876543210Sym6 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym5 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym5KindInference) ()) - data Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym5KindInference :: forall _f_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym6 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym5 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym4 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym4KindInference) ()) - data Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym4KindInference :: forall _f_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym4 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym5 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym3KindInference) ()) - data Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym3KindInference :: forall _f_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym4 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall _f_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall _f_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall _f_01234567898765432100123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 - type family Lambda_0123456789876543210 _f_0123456789876543210 a_0123456789876543210 t where - Lambda_0123456789876543210 _f_0123456789876543210 a_0123456789876543210 n_0123456789876543210 = MemptySym0 - type Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall _f_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 a_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall _f_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall _f_01234567898765432100123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 - type family FoldMap_0123456789876543210 (a :: (~>) a0 m0) (a :: T x a0) :: m0 where - FoldMap_0123456789876543210 _f_0123456789876543210 (MkT1 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210) = Apply (Apply MappendSym0 (Apply (Apply (Apply (Apply (Apply (Apply Lambda_0123456789876543210Sym0 _f_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210)) (Apply (Apply MappendSym0 (Apply _f_0123456789876543210 a_0123456789876543210)) (Apply (Apply MappendSym0 (Apply (Apply FoldMapSym0 _f_0123456789876543210) a_0123456789876543210)) (Apply (Apply FoldMapSym0 (Apply FoldMapSym0 _f_0123456789876543210)) a_0123456789876543210))) - FoldMap_0123456789876543210 _f_0123456789876543210 (MkT2 a_0123456789876543210) = Apply (Apply (Apply Lambda_0123456789876543210Sym0 _f_0123456789876543210) a_0123456789876543210) a_0123456789876543210 - type FoldMap_0123456789876543210Sym2 (a0123456789876543210 :: (~>) a01234567898765432100 m01234567898765432100) (a0123456789876543210 :: T x0123456789876543210 a01234567898765432100) = - FoldMap_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (FoldMap_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) FoldMap_0123456789876543210Sym1KindInference) ()) - data FoldMap_0123456789876543210Sym1 (a0123456789876543210 :: (~>) a01234567898765432100 m01234567898765432100) :: forall x0123456789876543210. - (~>) (T x0123456789876543210 a01234567898765432100) m01234567898765432100 - where - FoldMap_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (FoldMap_0123456789876543210Sym1 a0123456789876543210) arg) (FoldMap_0123456789876543210Sym2 a0123456789876543210 arg) => - FoldMap_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (FoldMap_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = FoldMap_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings FoldMap_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) FoldMap_0123456789876543210Sym0KindInference) ()) - data FoldMap_0123456789876543210Sym0 :: forall a01234567898765432100 - m01234567898765432100 - x0123456789876543210. - (~>) ((~>) a01234567898765432100 m01234567898765432100) ((~>) (T x0123456789876543210 a01234567898765432100) m01234567898765432100) - where - FoldMap_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply FoldMap_0123456789876543210Sym0 arg) (FoldMap_0123456789876543210Sym1 arg) => - FoldMap_0123456789876543210Sym0 a0123456789876543210 - type instance Apply FoldMap_0123456789876543210Sym0 a0123456789876543210 = FoldMap_0123456789876543210Sym1 a0123456789876543210 - type family Lambda_0123456789876543210 _f_0123456789876543210 _z_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 t t where - Lambda_0123456789876543210 _f_0123456789876543210 _z_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 n1_0123456789876543210 n2_0123456789876543210 = n2_0123456789876543210 - type Lambda_0123456789876543210Sym8 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym7 t0123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym7KindInference) ()) - data Lambda_0123456789876543210Sym7 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym7KindInference :: forall _f_01234567898765432100123456789876543210 - _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym7 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210) arg) (Lambda_0123456789876543210Sym8 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 arg) => - Lambda_0123456789876543210Sym7 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym7 t0123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 t0123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym6 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym6KindInference) ()) - data Lambda_0123456789876543210Sym6 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym6KindInference :: forall _f_01234567898765432100123456789876543210 - _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym6 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym7 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym6 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym6 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) t0123456789876543210 = Lambda_0123456789876543210Sym7 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym5 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym5KindInference) ()) - data Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym5KindInference :: forall _f_01234567898765432100123456789876543210 - _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym6 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym5 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym6 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym4 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym4KindInference) ()) - data Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym4KindInference :: forall _f_01234567898765432100123456789876543210 - _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym4 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym5 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym3KindInference) ()) - data Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym3KindInference :: forall _f_01234567898765432100123456789876543210 - _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym4 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall _f_01234567898765432100123456789876543210 - _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym3 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall _f_01234567898765432100123456789876543210 - _z_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210) _z_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall _f_01234567898765432100123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 - type family Lambda_0123456789876543210 _f_0123456789876543210 _z_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 t t where - Lambda_0123456789876543210 _f_0123456789876543210 _z_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 n1_0123456789876543210 n2_0123456789876543210 = Apply (Apply (Apply FoldrSym0 _f_0123456789876543210) n2_0123456789876543210) n1_0123456789876543210 - type Lambda_0123456789876543210Sym8 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym7 t0123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym7KindInference) ()) - data Lambda_0123456789876543210Sym7 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym7KindInference :: forall _f_01234567898765432100123456789876543210 - _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym7 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210) arg) (Lambda_0123456789876543210Sym8 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 arg) => - Lambda_0123456789876543210Sym7 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym7 t0123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 t0123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym6 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym6KindInference) ()) - data Lambda_0123456789876543210Sym6 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym6KindInference :: forall _f_01234567898765432100123456789876543210 - _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym6 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym7 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym6 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym6 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) t0123456789876543210 = Lambda_0123456789876543210Sym7 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym5 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym5KindInference) ()) - data Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym5KindInference :: forall _f_01234567898765432100123456789876543210 - _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym6 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym5 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym6 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym4 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym4KindInference) ()) - data Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym4KindInference :: forall _f_01234567898765432100123456789876543210 - _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym4 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym5 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym3KindInference) ()) - data Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym3KindInference :: forall _f_01234567898765432100123456789876543210 - _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym4 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall _f_01234567898765432100123456789876543210 - _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym3 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall _f_01234567898765432100123456789876543210 - _z_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210) _z_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall _f_01234567898765432100123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 - type family Lambda_0123456789876543210 n1_0123456789876543210 n2_0123456789876543210 _f_0123456789876543210 _z_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 t t where - Lambda_0123456789876543210 n1_0123456789876543210 n2_0123456789876543210 _f_0123456789876543210 _z_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 n1_0123456789876543210 n2_0123456789876543210 = Apply (Apply (Apply FoldrSym0 _f_0123456789876543210) n2_0123456789876543210) n1_0123456789876543210 - type Lambda_0123456789876543210Sym10 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym9 t0123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym9KindInference) ()) - data Lambda_0123456789876543210Sym9 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym9KindInference :: forall n1_01234567898765432100123456789876543210 - n2_01234567898765432100123456789876543210 - _f_01234567898765432100123456789876543210 - _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym9 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210) arg) (Lambda_0123456789876543210Sym10 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 arg) => - Lambda_0123456789876543210Sym9 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym9 t0123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 t0123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym8 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym8KindInference) ()) - data Lambda_0123456789876543210Sym8 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym8KindInference :: forall n1_01234567898765432100123456789876543210 - n2_01234567898765432100123456789876543210 - _f_01234567898765432100123456789876543210 - _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym8 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym9 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym8 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym8 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210) t0123456789876543210 = Lambda_0123456789876543210Sym9 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym7 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym7KindInference) ()) - data Lambda_0123456789876543210Sym7 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym7KindInference :: forall n1_01234567898765432100123456789876543210 - n2_01234567898765432100123456789876543210 - _f_01234567898765432100123456789876543210 - _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym7 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym8 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym7 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym7 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym8 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym6 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym6KindInference) ()) - data Lambda_0123456789876543210Sym6 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym6KindInference :: forall n1_01234567898765432100123456789876543210 - n2_01234567898765432100123456789876543210 - _f_01234567898765432100123456789876543210 - _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym6 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym7 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym6 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym6 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym7 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym5 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym5KindInference) ()) - data Lambda_0123456789876543210Sym5 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym5KindInference :: forall n1_01234567898765432100123456789876543210 - n2_01234567898765432100123456789876543210 - _f_01234567898765432100123456789876543210 - _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym5 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym6 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym5 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym5 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym6 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym4 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym4KindInference) ()) - data Lambda_0123456789876543210Sym4 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym4KindInference :: forall n1_01234567898765432100123456789876543210 - n2_01234567898765432100123456789876543210 - _f_01234567898765432100123456789876543210 - _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym4 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym5 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym4 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym4 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym5 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym3KindInference) ()) - data Lambda_0123456789876543210Sym3 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym3KindInference :: forall n1_01234567898765432100123456789876543210 - n2_01234567898765432100123456789876543210 - _f_01234567898765432100123456789876543210 - _z_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym3 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym4 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym3 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210) _z_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 n2_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall n1_01234567898765432100123456789876543210 - n2_01234567898765432100123456789876543210 - _f_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym3 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym2 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 n2_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210) _f_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym3 n2_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 n1_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall n1_01234567898765432100123456789876543210 - n2_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 n1_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym2 n1_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym1 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 n1_01234567898765432100123456789876543210) n2_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym2 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 n1_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall n1_01234567898765432100123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 n1_01234567898765432100123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 n1_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym1 n1_01234567898765432100123456789876543210 - type family Lambda_0123456789876543210 _f_0123456789876543210 _z_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 t t where - Lambda_0123456789876543210 _f_0123456789876543210 _z_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 n1_0123456789876543210 n2_0123456789876543210 = Apply (Apply (Apply FoldrSym0 (Apply (Apply (Apply (Apply (Apply (Apply (Apply (Apply Lambda_0123456789876543210Sym0 n1_0123456789876543210) n2_0123456789876543210) _f_0123456789876543210) _z_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210)) n2_0123456789876543210) n1_0123456789876543210 - type Lambda_0123456789876543210Sym8 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym7 t0123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym7KindInference) ()) - data Lambda_0123456789876543210Sym7 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym7KindInference :: forall _f_01234567898765432100123456789876543210 - _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym7 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210) arg) (Lambda_0123456789876543210Sym8 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 arg) => - Lambda_0123456789876543210Sym7 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym7 t0123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 t0123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym6 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym6KindInference) ()) - data Lambda_0123456789876543210Sym6 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym6KindInference :: forall _f_01234567898765432100123456789876543210 - _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym6 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym7 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym6 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym6 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) t0123456789876543210 = Lambda_0123456789876543210Sym7 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym5 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym5KindInference) ()) - data Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym5KindInference :: forall _f_01234567898765432100123456789876543210 - _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym6 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym5 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym6 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym4 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym4KindInference) ()) - data Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym4KindInference :: forall _f_01234567898765432100123456789876543210 - _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym4 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym5 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym3KindInference) ()) - data Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym3KindInference :: forall _f_01234567898765432100123456789876543210 - _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym4 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall _f_01234567898765432100123456789876543210 - _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym3 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall _f_01234567898765432100123456789876543210 - _z_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210) _z_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall _f_01234567898765432100123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 - type family Lambda_0123456789876543210 _f_0123456789876543210 _z_0123456789876543210 a_0123456789876543210 t t where - Lambda_0123456789876543210 _f_0123456789876543210 _z_0123456789876543210 a_0123456789876543210 n1_0123456789876543210 n2_0123456789876543210 = n2_0123456789876543210 - type Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym4 t0123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym4KindInference) ()) - data Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym4KindInference :: forall _f_01234567898765432100123456789876543210 - _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210) arg) (Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 arg) => - Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym4 t0123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 t0123456789876543210 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym3KindInference) ()) - data Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym3KindInference :: forall _f_01234567898765432100123456789876543210 - _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) t0123456789876543210 = Lambda_0123456789876543210Sym4 a_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall _f_01234567898765432100123456789876543210 - _z_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym3 _z_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall _f_01234567898765432100123456789876543210 - _z_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210) _z_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall _f_01234567898765432100123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 - type family Foldr_0123456789876543210 (a :: (~>) a0 ((~>) b0 b0)) (a :: b0) (a :: T x a0) :: b0 where - Foldr_0123456789876543210 _f_0123456789876543210 _z_0123456789876543210 (MkT1 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210) = Apply (Apply (Apply (Apply (Apply (Apply (Apply (Apply Lambda_0123456789876543210Sym0 _f_0123456789876543210) _z_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210) (Apply (Apply _f_0123456789876543210 a_0123456789876543210) (Apply (Apply (Apply (Apply (Apply (Apply (Apply (Apply Lambda_0123456789876543210Sym0 _f_0123456789876543210) _z_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210) (Apply (Apply (Apply (Apply (Apply (Apply (Apply (Apply Lambda_0123456789876543210Sym0 _f_0123456789876543210) _z_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210) _z_0123456789876543210))) - Foldr_0123456789876543210 _f_0123456789876543210 _z_0123456789876543210 (MkT2 a_0123456789876543210) = Apply (Apply (Apply (Apply (Apply Lambda_0123456789876543210Sym0 _f_0123456789876543210) _z_0123456789876543210) a_0123456789876543210) a_0123456789876543210) _z_0123456789876543210 - type Foldr_0123456789876543210Sym3 (a0123456789876543210 :: (~>) a01234567898765432100 ((~>) b01234567898765432100 b01234567898765432100)) (a0123456789876543210 :: b01234567898765432100) (a0123456789876543210 :: T x0123456789876543210 a01234567898765432100) = - Foldr_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Foldr_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Foldr_0123456789876543210Sym2KindInference) ()) - data Foldr_0123456789876543210Sym2 (a0123456789876543210 :: (~>) a01234567898765432100 ((~>) b01234567898765432100 b01234567898765432100)) (a0123456789876543210 :: b01234567898765432100) :: forall x0123456789876543210. - (~>) (T x0123456789876543210 a01234567898765432100) b01234567898765432100 - where - Foldr_0123456789876543210Sym2KindInference :: forall a0123456789876543210 - a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Foldr_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) arg) (Foldr_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 arg) => - Foldr_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (Foldr_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = Foldr_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Foldr_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Foldr_0123456789876543210Sym1KindInference) ()) - data Foldr_0123456789876543210Sym1 (a0123456789876543210 :: (~>) a01234567898765432100 ((~>) b01234567898765432100 b01234567898765432100)) :: forall x0123456789876543210. - (~>) b01234567898765432100 ((~>) (T x0123456789876543210 a01234567898765432100) b01234567898765432100) - where - Foldr_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Foldr_0123456789876543210Sym1 a0123456789876543210) arg) (Foldr_0123456789876543210Sym2 a0123456789876543210 arg) => - Foldr_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Foldr_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Foldr_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Foldr_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Foldr_0123456789876543210Sym0KindInference) ()) - data Foldr_0123456789876543210Sym0 :: forall a01234567898765432100 - b01234567898765432100 - x0123456789876543210. - (~>) ((~>) a01234567898765432100 ((~>) b01234567898765432100 b01234567898765432100)) ((~>) b01234567898765432100 ((~>) (T x0123456789876543210 a01234567898765432100) b01234567898765432100)) - where - Foldr_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foldr_0123456789876543210Sym0 arg) (Foldr_0123456789876543210Sym1 arg) => - Foldr_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Foldr_0123456789876543210Sym0 a0123456789876543210 = Foldr_0123456789876543210Sym1 a0123456789876543210 - instance PFoldable (T x) where - type FoldMap a a = Apply (Apply FoldMap_0123456789876543210Sym0 a) a - type Foldr a a a = Apply (Apply (Apply Foldr_0123456789876543210Sym0 a) a) a - type family Traverse_0123456789876543210 (a :: (~>) a0 (f0 b0)) (a :: T x a0) :: f0 (T x b0) where - Traverse_0123456789876543210 _f_0123456789876543210 (MkT1 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210) = Apply (Apply (<*>@#@$) (Apply (Apply (<*>@#@$) (Apply (Apply (Apply LiftA2Sym0 MkT1Sym0) (Apply PureSym0 a_0123456789876543210)) (Apply _f_0123456789876543210 a_0123456789876543210))) (Apply (Apply TraverseSym0 _f_0123456789876543210) a_0123456789876543210))) (Apply (Apply TraverseSym0 (Apply TraverseSym0 _f_0123456789876543210)) a_0123456789876543210) - Traverse_0123456789876543210 _f_0123456789876543210 (MkT2 a_0123456789876543210) = Apply (Apply FmapSym0 MkT2Sym0) (Apply PureSym0 a_0123456789876543210) - type Traverse_0123456789876543210Sym2 (a0123456789876543210 :: (~>) a01234567898765432100 (f01234567898765432100 b01234567898765432100)) (a0123456789876543210 :: T x0123456789876543210 a01234567898765432100) = - Traverse_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Traverse_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Traverse_0123456789876543210Sym1KindInference) ()) - data Traverse_0123456789876543210Sym1 (a0123456789876543210 :: (~>) a01234567898765432100 (f01234567898765432100 b01234567898765432100)) :: forall x0123456789876543210. - (~>) (T x0123456789876543210 a01234567898765432100) (f01234567898765432100 (T x0123456789876543210 b01234567898765432100)) - where - Traverse_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Traverse_0123456789876543210Sym1 a0123456789876543210) arg) (Traverse_0123456789876543210Sym2 a0123456789876543210 arg) => - Traverse_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Traverse_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Traverse_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Traverse_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Traverse_0123456789876543210Sym0KindInference) ()) - data Traverse_0123456789876543210Sym0 :: forall a01234567898765432100 - f01234567898765432100 - b01234567898765432100 - x0123456789876543210. - (~>) ((~>) a01234567898765432100 (f01234567898765432100 b01234567898765432100)) ((~>) (T x0123456789876543210 a01234567898765432100) (f01234567898765432100 (T x0123456789876543210 b01234567898765432100))) - where - Traverse_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Traverse_0123456789876543210Sym0 arg) (Traverse_0123456789876543210Sym1 arg) => - Traverse_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Traverse_0123456789876543210Sym0 a0123456789876543210 = Traverse_0123456789876543210Sym1 a0123456789876543210 - instance PTraversable (T x) where - type Traverse a a = Apply (Apply Traverse_0123456789876543210Sym0 a) a - type family Case_0123456789876543210 v_0123456789876543210 t where - type family Fmap_0123456789876543210 (a :: (~>) a0 b0) (a :: Empty a0) :: Empty b0 where - Fmap_0123456789876543210 _ v_0123456789876543210 = Case_0123456789876543210 v_0123456789876543210 v_0123456789876543210 - type Fmap_0123456789876543210Sym2 (a0123456789876543210 :: (~>) a01234567898765432100 b01234567898765432100) (a0123456789876543210 :: Empty a01234567898765432100) = - Fmap_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Fmap_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Fmap_0123456789876543210Sym1KindInference) ()) - data Fmap_0123456789876543210Sym1 (a0123456789876543210 :: (~>) a01234567898765432100 b01234567898765432100) :: (~>) (Empty a01234567898765432100) (Empty b01234567898765432100) - where - Fmap_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Fmap_0123456789876543210Sym1 a0123456789876543210) arg) (Fmap_0123456789876543210Sym2 a0123456789876543210 arg) => - Fmap_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Fmap_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Fmap_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Fmap_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Fmap_0123456789876543210Sym0KindInference) ()) - data Fmap_0123456789876543210Sym0 :: forall a01234567898765432100 - b01234567898765432100. - (~>) ((~>) a01234567898765432100 b01234567898765432100) ((~>) (Empty a01234567898765432100) (Empty b01234567898765432100)) - where - Fmap_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Fmap_0123456789876543210Sym0 arg) (Fmap_0123456789876543210Sym1 arg) => - Fmap_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Fmap_0123456789876543210Sym0 a0123456789876543210 = Fmap_0123456789876543210Sym1 a0123456789876543210 - type family Case_0123456789876543210 v_0123456789876543210 t where - type family TFHelper_0123456789876543210 (a :: a0) (a :: Empty b0) :: Empty a0 where - TFHelper_0123456789876543210 _ v_0123456789876543210 = Case_0123456789876543210 v_0123456789876543210 v_0123456789876543210 - type TFHelper_0123456789876543210Sym2 (a0123456789876543210 :: a01234567898765432100) (a0123456789876543210 :: Empty b01234567898765432100) = - TFHelper_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (TFHelper_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) TFHelper_0123456789876543210Sym1KindInference) ()) - data TFHelper_0123456789876543210Sym1 (a0123456789876543210 :: a01234567898765432100) :: forall b01234567898765432100. - (~>) (Empty b01234567898765432100) (Empty a01234567898765432100) - where - TFHelper_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (TFHelper_0123456789876543210Sym1 a0123456789876543210) arg) (TFHelper_0123456789876543210Sym2 a0123456789876543210 arg) => - TFHelper_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (TFHelper_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = TFHelper_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings TFHelper_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) TFHelper_0123456789876543210Sym0KindInference) ()) - data TFHelper_0123456789876543210Sym0 :: forall a01234567898765432100 - b01234567898765432100. - (~>) a01234567898765432100 ((~>) (Empty b01234567898765432100) (Empty a01234567898765432100)) - where - TFHelper_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply TFHelper_0123456789876543210Sym0 arg) (TFHelper_0123456789876543210Sym1 arg) => - TFHelper_0123456789876543210Sym0 a0123456789876543210 - type instance Apply TFHelper_0123456789876543210Sym0 a0123456789876543210 = TFHelper_0123456789876543210Sym1 a0123456789876543210 - instance PFunctor Empty where - type Fmap a a = Apply (Apply Fmap_0123456789876543210Sym0 a) a - type (<$) a a = Apply (Apply TFHelper_0123456789876543210Sym0 a) a - type family FoldMap_0123456789876543210 (a :: (~>) a0 m0) (a :: Empty a0) :: m0 where - FoldMap_0123456789876543210 _ _ = MemptySym0 - type FoldMap_0123456789876543210Sym2 (a0123456789876543210 :: (~>) a01234567898765432100 m01234567898765432100) (a0123456789876543210 :: Empty a01234567898765432100) = - FoldMap_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (FoldMap_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) FoldMap_0123456789876543210Sym1KindInference) ()) - data FoldMap_0123456789876543210Sym1 (a0123456789876543210 :: (~>) a01234567898765432100 m01234567898765432100) :: (~>) (Empty a01234567898765432100) m01234567898765432100 - where - FoldMap_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (FoldMap_0123456789876543210Sym1 a0123456789876543210) arg) (FoldMap_0123456789876543210Sym2 a0123456789876543210 arg) => - FoldMap_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (FoldMap_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = FoldMap_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings FoldMap_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) FoldMap_0123456789876543210Sym0KindInference) ()) - data FoldMap_0123456789876543210Sym0 :: forall a01234567898765432100 - m01234567898765432100. - (~>) ((~>) a01234567898765432100 m01234567898765432100) ((~>) (Empty a01234567898765432100) m01234567898765432100) - where - FoldMap_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply FoldMap_0123456789876543210Sym0 arg) (FoldMap_0123456789876543210Sym1 arg) => - FoldMap_0123456789876543210Sym0 a0123456789876543210 - type instance Apply FoldMap_0123456789876543210Sym0 a0123456789876543210 = FoldMap_0123456789876543210Sym1 a0123456789876543210 - instance PFoldable Empty where - type FoldMap a a = Apply (Apply FoldMap_0123456789876543210Sym0 a) a - type family Case_0123456789876543210 v_0123456789876543210 t where - type family Traverse_0123456789876543210 (a :: (~>) a0 (f0 b0)) (a :: Empty a0) :: f0 (Empty b0) where - Traverse_0123456789876543210 _ v_0123456789876543210 = Apply PureSym0 (Case_0123456789876543210 v_0123456789876543210 v_0123456789876543210) - type Traverse_0123456789876543210Sym2 (a0123456789876543210 :: (~>) a01234567898765432100 (f01234567898765432100 b01234567898765432100)) (a0123456789876543210 :: Empty a01234567898765432100) = - Traverse_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Traverse_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Traverse_0123456789876543210Sym1KindInference) ()) - data Traverse_0123456789876543210Sym1 (a0123456789876543210 :: (~>) a01234567898765432100 (f01234567898765432100 b01234567898765432100)) :: (~>) (Empty a01234567898765432100) (f01234567898765432100 (Empty b01234567898765432100)) - where - Traverse_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Traverse_0123456789876543210Sym1 a0123456789876543210) arg) (Traverse_0123456789876543210Sym2 a0123456789876543210 arg) => - Traverse_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Traverse_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Traverse_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Traverse_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Traverse_0123456789876543210Sym0KindInference) ()) - data Traverse_0123456789876543210Sym0 :: forall a01234567898765432100 - f01234567898765432100 - b01234567898765432100. - (~>) ((~>) a01234567898765432100 (f01234567898765432100 b01234567898765432100)) ((~>) (Empty a01234567898765432100) (f01234567898765432100 (Empty b01234567898765432100))) - where - Traverse_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Traverse_0123456789876543210Sym0 arg) (Traverse_0123456789876543210Sym1 arg) => - Traverse_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Traverse_0123456789876543210Sym0 a0123456789876543210 = Traverse_0123456789876543210Sym1 a0123456789876543210 - instance PTraversable Empty where - type Traverse a a = Apply (Apply Traverse_0123456789876543210Sym0 a) a - data ST :: forall x a. T x a -> Type - where - SMkT1 :: forall x - a - (n :: x) - (n :: a) - (n :: Maybe a) - (n :: Maybe (Maybe a)). - (Sing (n :: x)) - -> (Sing (n :: a)) - -> (Sing (n :: Maybe a)) - -> (Sing (n :: Maybe (Maybe a))) -> ST (MkT1 n n n n) - SMkT2 :: forall x (n :: Maybe x). - (Sing (n :: Maybe x)) -> ST (MkT2 n) - type instance Sing @(T x a) = ST - instance (SingKind x, SingKind a) => SingKind (T x a) where - type Demote (T x a) = T (Demote x) (Demote a) - fromSing (SMkT1 b b b b) - = (((MkT1 (fromSing b)) (fromSing b)) (fromSing b)) (fromSing b) - fromSing (SMkT2 b) = MkT2 (fromSing b) - toSing - (MkT1 (b :: Demote x) - (b :: Demote a) - (b :: Demote (Maybe a)) - (b :: Demote (Maybe (Maybe a)))) - = case - ((((,,,) (toSing b :: SomeSing x)) (toSing b :: SomeSing a)) - (toSing b :: SomeSing (Maybe a))) - (toSing b :: SomeSing (Maybe (Maybe a))) - of { - (,,,) (SomeSing c) (SomeSing c) (SomeSing c) (SomeSing c) - -> SomeSing ((((SMkT1 c) c) c) c) } - toSing (MkT2 (b :: Demote (Maybe x))) - = case toSing b :: SomeSing (Maybe x) of { - SomeSing c -> SomeSing (SMkT2 c) } - data SEmpty :: forall a. Empty a -> Type - type instance Sing @(Empty a) = SEmpty - instance SingKind a => SingKind (Empty a) where - type Demote (Empty a) = Empty (Demote a) - fromSing x = case x of - toSing x = SomeSing (case x of) - instance SFunctor (T x) where - sFmap :: - forall (a :: Type) (b :: Type) (t1 :: (~>) a b) (t2 :: T x a). - Sing t1 - -> Sing t2 - -> Sing (Apply (Apply (FmapSym0 :: TyFun ((~>) a b) ((~>) (T x a) (T x b)) - -> Type) t1) t2) - (%<$) :: - forall (a :: Type) (b :: Type) (t1 :: a) (t2 :: T x b). - Sing t1 - -> Sing t2 - -> Sing (Apply (Apply ((<$@#@$) :: TyFun a ((~>) (T x b) (T x a)) - -> Type) t1) t2) - sFmap - (_sf_0123456789876543210 :: Sing _f_0123456789876543210) - (SMkT1 (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210)) - = (applySing - ((applySing - ((applySing - ((applySing ((singFun4 @MkT1Sym0) SMkT1)) - ((applySing - ((singFun1 - @(Apply (Apply (Apply (Apply (Apply Lambda_0123456789876543210Sym0 _f_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210)) - (\ sN_0123456789876543210 - -> case sN_0123456789876543210 of { - (_ :: Sing n_0123456789876543210) - -> sN_0123456789876543210 }))) - sA_0123456789876543210))) - ((applySing _sf_0123456789876543210) sA_0123456789876543210))) - ((applySing - ((applySing ((singFun2 @FmapSym0) sFmap)) _sf_0123456789876543210)) - sA_0123456789876543210))) - ((applySing - ((applySing ((singFun2 @FmapSym0) sFmap)) - ((applySing ((singFun2 @FmapSym0) sFmap)) - _sf_0123456789876543210))) - sA_0123456789876543210) - sFmap - (_sf_0123456789876543210 :: Sing _f_0123456789876543210) - (SMkT2 (sA_0123456789876543210 :: Sing a_0123456789876543210)) - = (applySing ((singFun1 @MkT2Sym0) SMkT2)) - ((applySing - ((singFun1 - @(Apply (Apply Lambda_0123456789876543210Sym0 _f_0123456789876543210) a_0123456789876543210)) - (\ sN_0123456789876543210 - -> case sN_0123456789876543210 of { - (_ :: Sing n_0123456789876543210) -> sN_0123456789876543210 }))) - sA_0123456789876543210) - (%<$) - (_sz_0123456789876543210 :: Sing _z_0123456789876543210) - (SMkT1 (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210)) - = (applySing - ((applySing - ((applySing - ((applySing ((singFun4 @MkT1Sym0) SMkT1)) - ((applySing - ((singFun1 - @(Apply (Apply (Apply (Apply (Apply Lambda_0123456789876543210Sym0 _z_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210)) - (\ sN_0123456789876543210 - -> case sN_0123456789876543210 of { - (_ :: Sing n_0123456789876543210) - -> sN_0123456789876543210 }))) - sA_0123456789876543210))) - ((applySing - ((singFun1 - @(Apply (Apply (Apply (Apply (Apply Lambda_0123456789876543210Sym0 _z_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210)) - (\ sN_0123456789876543210 - -> case sN_0123456789876543210 of { - (_ :: Sing n_0123456789876543210) -> _sz_0123456789876543210 }))) - sA_0123456789876543210))) - ((applySing - ((applySing ((singFun2 @(<$@#@$)) (%<$))) _sz_0123456789876543210)) - sA_0123456789876543210))) - ((applySing - ((applySing ((singFun2 @FmapSym0) sFmap)) - ((applySing ((singFun2 @(<$@#@$)) (%<$))) - _sz_0123456789876543210))) - sA_0123456789876543210) - (%<$) - (_sz_0123456789876543210 :: Sing _z_0123456789876543210) - (SMkT2 (sA_0123456789876543210 :: Sing a_0123456789876543210)) - = (applySing ((singFun1 @MkT2Sym0) SMkT2)) - ((applySing - ((singFun1 - @(Apply (Apply Lambda_0123456789876543210Sym0 _z_0123456789876543210) a_0123456789876543210)) - (\ sN_0123456789876543210 - -> case sN_0123456789876543210 of { - (_ :: Sing n_0123456789876543210) -> sN_0123456789876543210 }))) - sA_0123456789876543210) - instance SFoldable (T x) where - sFoldMap :: - forall (a :: Type) (m :: Type) (t1 :: (~>) a m) (t2 :: T x a). - SMonoid m => - Sing t1 - -> Sing t2 - -> Sing (Apply (Apply (FoldMapSym0 :: TyFun ((~>) a m) ((~>) (T x a) m) - -> Type) t1) t2) - sFoldr :: - forall (a :: Type) - (b :: Type) - (t1 :: (~>) a ((~>) b b)) - (t2 :: b) - (t3 :: T x a). - Sing t1 - -> Sing t2 - -> Sing t3 - -> Sing (Apply (Apply (Apply (FoldrSym0 :: TyFun ((~>) a ((~>) b b)) ((~>) b ((~>) (T x a) b)) - -> Type) t1) t2) t3) - sFoldMap - (_sf_0123456789876543210 :: Sing _f_0123456789876543210) - (SMkT1 (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210)) - = (applySing - ((applySing ((singFun2 @MappendSym0) sMappend)) - ((applySing - ((singFun1 - @(Apply (Apply (Apply (Apply (Apply Lambda_0123456789876543210Sym0 _f_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210)) - (\ sN_0123456789876543210 - -> case sN_0123456789876543210 of { - (_ :: Sing n_0123456789876543210) -> sMempty }))) - sA_0123456789876543210))) - ((applySing - ((applySing ((singFun2 @MappendSym0) sMappend)) - ((applySing _sf_0123456789876543210) sA_0123456789876543210))) - ((applySing - ((applySing ((singFun2 @MappendSym0) sMappend)) - ((applySing - ((applySing ((singFun2 @FoldMapSym0) sFoldMap)) - _sf_0123456789876543210)) - sA_0123456789876543210))) - ((applySing - ((applySing ((singFun2 @FoldMapSym0) sFoldMap)) - ((applySing ((singFun2 @FoldMapSym0) sFoldMap)) - _sf_0123456789876543210))) - sA_0123456789876543210))) - sFoldMap - (_sf_0123456789876543210 :: Sing _f_0123456789876543210) - (SMkT2 (sA_0123456789876543210 :: Sing a_0123456789876543210)) - = (applySing - ((singFun1 - @(Apply (Apply Lambda_0123456789876543210Sym0 _f_0123456789876543210) a_0123456789876543210)) - (\ sN_0123456789876543210 - -> case sN_0123456789876543210 of { - (_ :: Sing n_0123456789876543210) -> sMempty }))) - sA_0123456789876543210 - sFoldr - (_sf_0123456789876543210 :: Sing _f_0123456789876543210) - (_sz_0123456789876543210 :: Sing _z_0123456789876543210) - (SMkT1 (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210)) - = (applySing - ((applySing - ((singFun2 - @(Apply (Apply (Apply (Apply (Apply (Apply Lambda_0123456789876543210Sym0 _f_0123456789876543210) _z_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210)) - (\ sN1_0123456789876543210 sN2_0123456789876543210 - -> case ((,) sN1_0123456789876543210) sN2_0123456789876543210 of { - (,) (_ :: Sing n1_0123456789876543210) - (_ :: Sing n2_0123456789876543210) - -> sN2_0123456789876543210 }))) - sA_0123456789876543210)) - ((applySing - ((applySing _sf_0123456789876543210) sA_0123456789876543210)) - ((applySing - ((applySing - ((singFun2 - @(Apply (Apply (Apply (Apply (Apply (Apply Lambda_0123456789876543210Sym0 _f_0123456789876543210) _z_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210)) - (\ sN1_0123456789876543210 sN2_0123456789876543210 - -> case ((,) sN1_0123456789876543210) sN2_0123456789876543210 of { - (,) (_ :: Sing n1_0123456789876543210) - (_ :: Sing n2_0123456789876543210) - -> (applySing - ((applySing - ((applySing ((singFun3 @FoldrSym0) sFoldr)) - _sf_0123456789876543210)) - sN2_0123456789876543210)) - sN1_0123456789876543210 }))) - sA_0123456789876543210)) - ((applySing - ((applySing - ((singFun2 - @(Apply (Apply (Apply (Apply (Apply (Apply Lambda_0123456789876543210Sym0 _f_0123456789876543210) _z_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210)) - (\ sN1_0123456789876543210 sN2_0123456789876543210 - -> case ((,) sN1_0123456789876543210) sN2_0123456789876543210 of { - (,) (_ :: Sing n1_0123456789876543210) - (_ :: Sing n2_0123456789876543210) - -> (applySing - ((applySing - ((applySing ((singFun3 @FoldrSym0) sFoldr)) - ((singFun2 - @(Apply (Apply (Apply (Apply (Apply (Apply (Apply (Apply Lambda_0123456789876543210Sym0 n1_0123456789876543210) n2_0123456789876543210) _f_0123456789876543210) _z_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210)) - (\ sN1_0123456789876543210 - sN2_0123456789876543210 - -> case - ((,) sN1_0123456789876543210) - sN2_0123456789876543210 - of { - (,) (_ :: Sing n1_0123456789876543210) - (_ :: Sing n2_0123456789876543210) - -> (applySing - ((applySing - ((applySing - ((singFun3 - @FoldrSym0) - sFoldr)) - _sf_0123456789876543210)) - sN2_0123456789876543210)) - sN1_0123456789876543210 })))) - sN2_0123456789876543210)) - sN1_0123456789876543210 }))) - sA_0123456789876543210)) - _sz_0123456789876543210))) - sFoldr - (_sf_0123456789876543210 :: Sing _f_0123456789876543210) - (_sz_0123456789876543210 :: Sing _z_0123456789876543210) - (SMkT2 (sA_0123456789876543210 :: Sing a_0123456789876543210)) - = (applySing - ((applySing - ((singFun2 - @(Apply (Apply (Apply Lambda_0123456789876543210Sym0 _f_0123456789876543210) _z_0123456789876543210) a_0123456789876543210)) - (\ sN1_0123456789876543210 sN2_0123456789876543210 - -> case ((,) sN1_0123456789876543210) sN2_0123456789876543210 of { - (,) (_ :: Sing n1_0123456789876543210) - (_ :: Sing n2_0123456789876543210) - -> sN2_0123456789876543210 }))) - sA_0123456789876543210)) - _sz_0123456789876543210 - instance STraversable (T x) where - sTraverse :: - forall (a :: Type) - (f :: Type -> Type) - (b :: Type) - (t1 :: (~>) a (f b)) - (t2 :: T x a). - SApplicative f => - Sing t1 - -> Sing t2 - -> Sing (Apply (Apply (TraverseSym0 :: TyFun ((~>) a (f b)) ((~>) (T x a) (f (T x b))) - -> Type) t1) t2) - sTraverse - (_sf_0123456789876543210 :: Sing _f_0123456789876543210) - (SMkT1 (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210)) - = (applySing - ((applySing ((singFun2 @(<*>@#@$)) (%<*>))) - ((applySing - ((applySing ((singFun2 @(<*>@#@$)) (%<*>))) - ((applySing - ((applySing - ((applySing ((singFun3 @LiftA2Sym0) sLiftA2)) - ((singFun4 @MkT1Sym0) SMkT1))) - ((applySing ((singFun1 @PureSym0) sPure)) sA_0123456789876543210))) - ((applySing _sf_0123456789876543210) sA_0123456789876543210)))) - ((applySing - ((applySing ((singFun2 @TraverseSym0) sTraverse)) - _sf_0123456789876543210)) - sA_0123456789876543210)))) - ((applySing - ((applySing ((singFun2 @TraverseSym0) sTraverse)) - ((applySing ((singFun2 @TraverseSym0) sTraverse)) - _sf_0123456789876543210))) - sA_0123456789876543210) - sTraverse - (_sf_0123456789876543210 :: Sing _f_0123456789876543210) - (SMkT2 (sA_0123456789876543210 :: Sing a_0123456789876543210)) - = (applySing - ((applySing ((singFun2 @FmapSym0) sFmap)) - ((singFun1 @MkT2Sym0) SMkT2))) - ((applySing ((singFun1 @PureSym0) sPure)) sA_0123456789876543210) - instance SFunctor Empty where - sFmap :: - forall (a :: Type) (b :: Type) (t1 :: (~>) a b) (t2 :: Empty a). - Sing t1 - -> Sing t2 - -> Sing (Apply (Apply (FmapSym0 :: TyFun ((~>) a b) ((~>) (Empty a) (Empty b)) - -> Type) t1) t2) - (%<$) :: - forall (a :: Type) (b :: Type) (t1 :: a) (t2 :: Empty b). - Sing t1 - -> Sing t2 - -> Sing (Apply (Apply ((<$@#@$) :: TyFun a ((~>) (Empty b) (Empty a)) - -> Type) t1) t2) - sFmap _ (sV_0123456789876543210 :: Sing v_0123456789876543210) - = (id - @(Sing (Case_0123456789876543210 v_0123456789876543210 v_0123456789876543210))) - (case sV_0123456789876543210 of) - (%<$) _ (sV_0123456789876543210 :: Sing v_0123456789876543210) - = (id - @(Sing (Case_0123456789876543210 v_0123456789876543210 v_0123456789876543210))) - (case sV_0123456789876543210 of) - instance SFoldable Empty where - sFoldMap :: - forall (a :: Type) (m :: Type) (t1 :: (~>) a m) (t2 :: Empty a). - SMonoid m => - Sing t1 - -> Sing t2 - -> Sing (Apply (Apply (FoldMapSym0 :: TyFun ((~>) a m) ((~>) (Empty a) m) - -> Type) t1) t2) - sFoldMap _ _ = sMempty - instance STraversable Empty where - sTraverse :: - forall (a :: Type) - (f :: Type -> Type) - (b :: Type) - (t1 :: (~>) a (f b)) - (t2 :: Empty a). - SApplicative f => - Sing t1 - -> Sing t2 - -> Sing (Apply (Apply (TraverseSym0 :: TyFun ((~>) a (f b)) ((~>) (Empty a) (f (Empty b))) - -> Type) t1) t2) - sTraverse _ (sV_0123456789876543210 :: Sing v_0123456789876543210) - = (applySing ((singFun1 @PureSym0) sPure)) - ((id - @(Sing (Case_0123456789876543210 v_0123456789876543210 v_0123456789876543210))) - (case sV_0123456789876543210 of)) - instance (SingI n, SingI n, SingI n, SingI n) => - SingI (MkT1 (n :: x) (n :: a) (n :: Maybe a) (n :: Maybe (Maybe a))) where - sing = (((SMkT1 sing) sing) sing) sing - instance SingI (MkT1Sym0 :: (~>) x ((~>) a ((~>) (Maybe a) ((~>) (Maybe (Maybe a)) (T x a))))) where - sing = (singFun4 @MkT1Sym0) SMkT1 - instance SingI d => - SingI (MkT1Sym1 (d :: x) :: (~>) a ((~>) (Maybe a) ((~>) (Maybe (Maybe a)) (T x a)))) where - sing = (singFun3 @(MkT1Sym1 (d :: x))) (SMkT1 (sing @d)) - instance (SingI d, SingI d) => - SingI (MkT1Sym2 (d :: x) (d :: a) :: (~>) (Maybe a) ((~>) (Maybe (Maybe a)) (T x a))) where - sing - = (singFun2 @(MkT1Sym2 (d :: x) (d :: a))) - ((SMkT1 (sing @d)) (sing @d)) - instance (SingI d, SingI d, SingI d) => - SingI (MkT1Sym3 (d :: x) (d :: a) (d :: Maybe a) :: (~>) (Maybe (Maybe a)) (T x a)) where - sing - = (singFun1 @(MkT1Sym3 (d :: x) (d :: a) (d :: Maybe a))) - (((SMkT1 (sing @d)) (sing @d)) (sing @d)) - instance SingI n => SingI (MkT2 (n :: Maybe x)) where - sing = SMkT2 sing - instance SingI (MkT2Sym0 :: (~>) (Maybe x) (T x a)) where - sing = (singFun1 @MkT2Sym0) SMkT2 diff --git a/tests/compile-and-dump/Singletons/FunctorLikeDeriving.hs b/tests/compile-and-dump/Singletons/FunctorLikeDeriving.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/FunctorLikeDeriving.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE DeriveTraversable #-} --- Ensure that we can derive Functor, Foldable, and Traversable using only --- an import of Data.Singletons.TH -module FunctorLikeDeriving where - -import Data.Kind -import Data.Singletons.TH - -$(singletons [d| - data T x a - = MkT1 x a (Maybe a) (Maybe (Maybe a)) - | MkT2 (Maybe x) - deriving (Functor, Foldable, Traversable) - - data Empty (a :: Type) - deriving (Functor, Foldable, Traversable) - |]) diff --git a/tests/compile-and-dump/Singletons/HigherOrder.ghc88.template b/tests/compile-and-dump/Singletons/HigherOrder.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/HigherOrder.ghc88.template +++ /dev/null @@ -1,477 +0,0 @@ -Singletons/HigherOrder.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| map :: (a -> b) -> [a] -> [b] - map _ [] = [] - map f (h : t) = (f h) : (map f t) - liftMaybe :: (a -> b) -> Maybe a -> Maybe b - liftMaybe f (Just x) = Just (f x) - liftMaybe _ Nothing = Nothing - 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 |] - ======> - data Either a b = Left a | Right b - map :: (a -> b) -> [a] -> [b] - map _ [] = [] - map f (h : t) = (f h : (map f) t) - liftMaybe :: (a -> b) -> Maybe a -> Maybe b - liftMaybe f (Just x) = Just (f x) - liftMaybe _ Nothing = Nothing - 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) - type LeftSym1 (t0123456789876543210 :: a0123456789876543210) = - Left t0123456789876543210 - instance SuppressUnusedWarnings LeftSym0 where - suppressUnusedWarnings = snd (((,) LeftSym0KindInference) ()) - data LeftSym0 :: forall a0123456789876543210 b0123456789876543210. - (~>) a0123456789876543210 (Either a0123456789876543210 b0123456789876543210) - where - LeftSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply LeftSym0 arg) (LeftSym1 arg) => - LeftSym0 t0123456789876543210 - type instance Apply LeftSym0 t0123456789876543210 = Left t0123456789876543210 - type RightSym1 (t0123456789876543210 :: b0123456789876543210) = - Right t0123456789876543210 - instance SuppressUnusedWarnings RightSym0 where - suppressUnusedWarnings = snd (((,) RightSym0KindInference) ()) - data RightSym0 :: forall b0123456789876543210 a0123456789876543210. - (~>) b0123456789876543210 (Either a0123456789876543210 b0123456789876543210) - where - RightSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply RightSym0 arg) (RightSym1 arg) => - RightSym0 t0123456789876543210 - type instance Apply RightSym0 t0123456789876543210 = Right t0123456789876543210 - type family Case_0123456789876543210 n b a_0123456789876543210 a_0123456789876543210 t where - Case_0123456789876543210 n b a_0123456789876543210 a_0123456789876543210 'True = Apply SuccSym0 (Apply SuccSym0 n) - Case_0123456789876543210 n b a_0123456789876543210 a_0123456789876543210 'False = n - type family Lambda_0123456789876543210 a_0123456789876543210 a_0123456789876543210 t t where - Lambda_0123456789876543210 a_0123456789876543210 a_0123456789876543210 n b = Case_0123456789876543210 n b a_0123456789876543210 a_0123456789876543210 b - type Lambda_0123456789876543210Sym4 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym3 t0123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym3KindInference) ()) - data Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym3KindInference :: forall a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210) arg) (Lambda_0123456789876543210Sym4 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 arg) => - Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym3 t0123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 t0123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) t0123456789876543210 = Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall a_01234567898765432100123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 a_01234567898765432100123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210 - type family Case_0123456789876543210 n b ns bs t where - Case_0123456789876543210 n b ns bs 'True = Apply SuccSym0 (Apply SuccSym0 n) - Case_0123456789876543210 n b ns bs 'False = n - type family Lambda_0123456789876543210 ns bs t t where - Lambda_0123456789876543210 ns bs n b = Case_0123456789876543210 n b ns bs b - type Lambda_0123456789876543210Sym4 ns0123456789876543210 bs0123456789876543210 t0123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 ns0123456789876543210 bs0123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym3 t0123456789876543210 bs0123456789876543210 ns0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym3KindInference) ()) - data Lambda_0123456789876543210Sym3 ns0123456789876543210 bs0123456789876543210 t0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym3KindInference :: forall ns0123456789876543210 - bs0123456789876543210 - t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym3 ns0123456789876543210 bs0123456789876543210 t0123456789876543210) arg) (Lambda_0123456789876543210Sym4 ns0123456789876543210 bs0123456789876543210 t0123456789876543210 arg) => - Lambda_0123456789876543210Sym3 ns0123456789876543210 bs0123456789876543210 t0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym3 t0123456789876543210 bs0123456789876543210 ns0123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 t0123456789876543210 bs0123456789876543210 ns0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 bs0123456789876543210 ns0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 ns0123456789876543210 bs0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall ns0123456789876543210 - bs0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 ns0123456789876543210 bs0123456789876543210) arg) (Lambda_0123456789876543210Sym3 ns0123456789876543210 bs0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 ns0123456789876543210 bs0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 bs0123456789876543210 ns0123456789876543210) t0123456789876543210 = Lambda_0123456789876543210Sym3 bs0123456789876543210 ns0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 ns0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 ns0123456789876543210 bs0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall ns0123456789876543210 - bs0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 ns0123456789876543210) arg) (Lambda_0123456789876543210Sym2 ns0123456789876543210 arg) => - Lambda_0123456789876543210Sym1 ns0123456789876543210 bs0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 ns0123456789876543210) bs0123456789876543210 = Lambda_0123456789876543210Sym2 ns0123456789876543210 bs0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 ns0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall ns0123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 ns0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 ns0123456789876543210 = Lambda_0123456789876543210Sym1 ns0123456789876543210 - type EtadSym2 (a0123456789876543210 :: [Nat]) (a0123456789876543210 :: [Bool]) = - Etad a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (EtadSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) EtadSym1KindInference) ()) - data EtadSym1 (a0123456789876543210 :: [Nat]) :: (~>) [Bool] [Nat] - where - EtadSym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (EtadSym1 a0123456789876543210) arg) (EtadSym2 a0123456789876543210 arg) => - EtadSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (EtadSym1 a0123456789876543210) a0123456789876543210 = Etad a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings EtadSym0 where - suppressUnusedWarnings = snd (((,) EtadSym0KindInference) ()) - data EtadSym0 :: (~>) [Nat] ((~>) [Bool] [Nat]) - where - EtadSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply EtadSym0 arg) (EtadSym1 arg) => - EtadSym0 a0123456789876543210 - type instance Apply EtadSym0 a0123456789876543210 = EtadSym1 a0123456789876543210 - type SplungeSym2 (a0123456789876543210 :: [Nat]) (a0123456789876543210 :: [Bool]) = - Splunge a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (SplungeSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) SplungeSym1KindInference) ()) - data SplungeSym1 (a0123456789876543210 :: [Nat]) :: (~>) [Bool] [Nat] - where - SplungeSym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (SplungeSym1 a0123456789876543210) arg) (SplungeSym2 a0123456789876543210 arg) => - SplungeSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (SplungeSym1 a0123456789876543210) a0123456789876543210 = Splunge a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings SplungeSym0 where - suppressUnusedWarnings = snd (((,) SplungeSym0KindInference) ()) - data SplungeSym0 :: (~>) [Nat] ((~>) [Bool] [Nat]) - where - SplungeSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply SplungeSym0 arg) (SplungeSym1 arg) => - SplungeSym0 a0123456789876543210 - type instance Apply SplungeSym0 a0123456789876543210 = SplungeSym1 a0123456789876543210 - type FooSym3 (a0123456789876543210 :: (~>) ((~>) a0123456789876543210 b0123456789876543210) ((~>) a0123456789876543210 b0123456789876543210)) (a0123456789876543210 :: (~>) a0123456789876543210 b0123456789876543210) (a0123456789876543210 :: a0123456789876543210) = - Foo a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (FooSym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) FooSym2KindInference) ()) - data FooSym2 (a0123456789876543210 :: (~>) ((~>) a0123456789876543210 b0123456789876543210) ((~>) a0123456789876543210 b0123456789876543210)) (a0123456789876543210 :: (~>) a0123456789876543210 b0123456789876543210) :: (~>) a0123456789876543210 b0123456789876543210 - where - FooSym2KindInference :: forall a0123456789876543210 - a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (FooSym2 a0123456789876543210 a0123456789876543210) arg) (FooSym3 a0123456789876543210 a0123456789876543210 arg) => - FooSym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (FooSym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = Foo a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (FooSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) FooSym1KindInference) ()) - data FooSym1 (a0123456789876543210 :: (~>) ((~>) a0123456789876543210 b0123456789876543210) ((~>) a0123456789876543210 b0123456789876543210)) :: (~>) ((~>) a0123456789876543210 b0123456789876543210) ((~>) a0123456789876543210 b0123456789876543210) - where - FooSym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (FooSym1 a0123456789876543210) arg) (FooSym2 a0123456789876543210 arg) => - FooSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (FooSym1 a0123456789876543210) a0123456789876543210 = FooSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings FooSym0 where - suppressUnusedWarnings = snd (((,) FooSym0KindInference) ()) - data FooSym0 :: forall a0123456789876543210 b0123456789876543210. - (~>) ((~>) ((~>) a0123456789876543210 b0123456789876543210) ((~>) a0123456789876543210 b0123456789876543210)) ((~>) ((~>) a0123456789876543210 b0123456789876543210) ((~>) a0123456789876543210 b0123456789876543210)) - where - FooSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply FooSym0 arg) (FooSym1 arg) => - FooSym0 a0123456789876543210 - type instance Apply FooSym0 a0123456789876543210 = FooSym1 a0123456789876543210 - type ZipWithSym3 (a0123456789876543210 :: (~>) a0123456789876543210 ((~>) b0123456789876543210 c0123456789876543210)) (a0123456789876543210 :: [a0123456789876543210]) (a0123456789876543210 :: [b0123456789876543210]) = - ZipWith a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ZipWithSym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) ZipWithSym2KindInference) ()) - data ZipWithSym2 (a0123456789876543210 :: (~>) a0123456789876543210 ((~>) b0123456789876543210 c0123456789876543210)) (a0123456789876543210 :: [a0123456789876543210]) :: (~>) [b0123456789876543210] [c0123456789876543210] - where - ZipWithSym2KindInference :: forall a0123456789876543210 - a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ZipWithSym2 a0123456789876543210 a0123456789876543210) arg) (ZipWithSym3 a0123456789876543210 a0123456789876543210 arg) => - ZipWithSym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (ZipWithSym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = ZipWith a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ZipWithSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) ZipWithSym1KindInference) ()) - data ZipWithSym1 (a0123456789876543210 :: (~>) a0123456789876543210 ((~>) b0123456789876543210 c0123456789876543210)) :: (~>) [a0123456789876543210] ((~>) [b0123456789876543210] [c0123456789876543210]) - where - ZipWithSym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ZipWithSym1 a0123456789876543210) arg) (ZipWithSym2 a0123456789876543210 arg) => - ZipWithSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (ZipWithSym1 a0123456789876543210) a0123456789876543210 = ZipWithSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ZipWithSym0 where - suppressUnusedWarnings = snd (((,) ZipWithSym0KindInference) ()) - data ZipWithSym0 :: forall a0123456789876543210 - b0123456789876543210 - c0123456789876543210. - (~>) ((~>) a0123456789876543210 ((~>) b0123456789876543210 c0123456789876543210)) ((~>) [a0123456789876543210] ((~>) [b0123456789876543210] [c0123456789876543210])) - where - ZipWithSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply ZipWithSym0 arg) (ZipWithSym1 arg) => - ZipWithSym0 a0123456789876543210 - type instance Apply ZipWithSym0 a0123456789876543210 = ZipWithSym1 a0123456789876543210 - type LiftMaybeSym2 (a0123456789876543210 :: (~>) a0123456789876543210 b0123456789876543210) (a0123456789876543210 :: Maybe a0123456789876543210) = - LiftMaybe a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (LiftMaybeSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) LiftMaybeSym1KindInference) ()) - data LiftMaybeSym1 (a0123456789876543210 :: (~>) a0123456789876543210 b0123456789876543210) :: (~>) (Maybe a0123456789876543210) (Maybe b0123456789876543210) - where - LiftMaybeSym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (LiftMaybeSym1 a0123456789876543210) arg) (LiftMaybeSym2 a0123456789876543210 arg) => - LiftMaybeSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (LiftMaybeSym1 a0123456789876543210) a0123456789876543210 = LiftMaybe a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings LiftMaybeSym0 where - suppressUnusedWarnings = snd (((,) LiftMaybeSym0KindInference) ()) - data LiftMaybeSym0 :: forall a0123456789876543210 - b0123456789876543210. - (~>) ((~>) a0123456789876543210 b0123456789876543210) ((~>) (Maybe a0123456789876543210) (Maybe b0123456789876543210)) - where - LiftMaybeSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply LiftMaybeSym0 arg) (LiftMaybeSym1 arg) => - LiftMaybeSym0 a0123456789876543210 - type instance Apply LiftMaybeSym0 a0123456789876543210 = LiftMaybeSym1 a0123456789876543210 - type MapSym2 (a0123456789876543210 :: (~>) a0123456789876543210 b0123456789876543210) (a0123456789876543210 :: [a0123456789876543210]) = - Map a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (MapSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) MapSym1KindInference) ()) - data MapSym1 (a0123456789876543210 :: (~>) a0123456789876543210 b0123456789876543210) :: (~>) [a0123456789876543210] [b0123456789876543210] - where - MapSym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (MapSym1 a0123456789876543210) arg) (MapSym2 a0123456789876543210 arg) => - MapSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (MapSym1 a0123456789876543210) a0123456789876543210 = Map a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings MapSym0 where - suppressUnusedWarnings = snd (((,) MapSym0KindInference) ()) - data MapSym0 :: forall a0123456789876543210 b0123456789876543210. - (~>) ((~>) a0123456789876543210 b0123456789876543210) ((~>) [a0123456789876543210] [b0123456789876543210]) - where - MapSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply MapSym0 arg) (MapSym1 arg) => - MapSym0 a0123456789876543210 - type instance Apply MapSym0 a0123456789876543210 = MapSym1 a0123456789876543210 - type family Etad (a :: [Nat]) (a :: [Bool]) :: [Nat] where - Etad a_0123456789876543210 a_0123456789876543210 = Apply (Apply (Apply ZipWithSym0 (Apply (Apply Lambda_0123456789876543210Sym0 a_0123456789876543210) a_0123456789876543210)) a_0123456789876543210) a_0123456789876543210 - type family Splunge (a :: [Nat]) (a :: [Bool]) :: [Nat] where - Splunge ns bs = Apply (Apply (Apply ZipWithSym0 (Apply (Apply Lambda_0123456789876543210Sym0 ns) bs)) ns) bs - type family Foo (a :: (~>) ((~>) a b) ((~>) a b)) (a :: (~>) a b) (a :: a) :: b where - Foo f g a = Apply (Apply f g) a - type family ZipWith (a :: (~>) a ((~>) b c)) (a :: [a]) (a :: [b]) :: [c] where - ZipWith f ('(:) x xs) ('(:) y ys) = Apply (Apply (:@#@$) (Apply (Apply f x) y)) (Apply (Apply (Apply ZipWithSym0 f) xs) ys) - ZipWith _ '[] '[] = '[] - ZipWith _ ('(:) _ _) '[] = '[] - ZipWith _ '[] ('(:) _ _) = '[] - type family LiftMaybe (a :: (~>) a b) (a :: Maybe a) :: Maybe b where - LiftMaybe f ('Just x) = Apply JustSym0 (Apply f x) - LiftMaybe _ 'Nothing = NothingSym0 - type family Map (a :: (~>) a b) (a :: [a]) :: [b] where - Map _ '[] = '[] - Map f ('(:) h t) = Apply (Apply (:@#@$) (Apply f h)) (Apply (Apply MapSym0 f) t) - sEtad :: - forall (t :: [Nat]) (t :: [Bool]). - Sing t -> Sing t -> Sing (Apply (Apply EtadSym0 t) t :: [Nat]) - sSplunge :: - forall (t :: [Nat]) (t :: [Bool]). - Sing t -> Sing t -> Sing (Apply (Apply SplungeSym0 t) t :: [Nat]) - sFoo :: - forall a - b - (t :: (~>) ((~>) a b) ((~>) a b)) - (t :: (~>) a b) - (t :: a). - Sing t - -> Sing t - -> Sing t -> Sing (Apply (Apply (Apply FooSym0 t) t) t :: b) - sZipWith :: - forall a b c (t :: (~>) a ((~>) b c)) (t :: [a]) (t :: [b]). - Sing t - -> Sing t - -> Sing t -> Sing (Apply (Apply (Apply ZipWithSym0 t) t) t :: [c]) - sLiftMaybe :: - forall a b (t :: (~>) a b) (t :: Maybe a). - Sing t - -> Sing t -> Sing (Apply (Apply LiftMaybeSym0 t) t :: Maybe b) - sMap :: - forall a b (t :: (~>) a b) (t :: [a]). - Sing t -> Sing t -> Sing (Apply (Apply MapSym0 t) t :: [b]) - sEtad - (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing - ((applySing ((singFun3 @ZipWithSym0) sZipWith)) - ((singFun2 - @(Apply (Apply Lambda_0123456789876543210Sym0 a_0123456789876543210) a_0123456789876543210)) - (\ sN sB - -> case ((,) sN) sB of { - (,) (_ :: Sing n) (_ :: Sing b) - -> (id - @(Sing (Case_0123456789876543210 n b a_0123456789876543210 a_0123456789876543210 b))) - (case sB of - STrue - -> (applySing ((singFun1 @SuccSym0) SSucc)) - ((applySing ((singFun1 @SuccSym0) SSucc)) sN) - SFalse -> sN) })))) - sA_0123456789876543210)) - sA_0123456789876543210 - sSplunge (sNs :: Sing ns) (sBs :: Sing bs) - = (applySing - ((applySing - ((applySing ((singFun3 @ZipWithSym0) sZipWith)) - ((singFun2 @(Apply (Apply Lambda_0123456789876543210Sym0 ns) bs)) - (\ sN sB - -> case ((,) sN) sB of { - (,) (_ :: Sing n) (_ :: Sing b) - -> (id @(Sing (Case_0123456789876543210 n b ns bs b))) - (case sB of - STrue - -> (applySing ((singFun1 @SuccSym0) SSucc)) - ((applySing ((singFun1 @SuccSym0) SSucc)) sN) - SFalse -> sN) })))) - sNs)) - sBs - sFoo (sF :: Sing f) (sG :: Sing g) (sA :: Sing a) - = (applySing ((applySing sF) sG)) sA - sZipWith - (sF :: Sing f) - (SCons (sX :: Sing x) (sXs :: Sing xs)) - (SCons (sY :: Sing y) (sYs :: Sing ys)) - = (applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing ((applySing sF) sX)) sY))) - ((applySing - ((applySing ((applySing ((singFun3 @ZipWithSym0) sZipWith)) sF)) - sXs)) - sYs) - sZipWith _ SNil SNil = SNil - sZipWith _ (SCons _ _) SNil = SNil - sZipWith _ SNil (SCons _ _) = SNil - sLiftMaybe (sF :: Sing f) (SJust (sX :: Sing x)) - = (applySing ((singFun1 @JustSym0) SJust)) ((applySing sF) sX) - sLiftMaybe _ SNothing = SNothing - sMap _ SNil = SNil - sMap (sF :: Sing f) (SCons (sH :: Sing h) (sT :: Sing t)) - = (applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) ((applySing sF) sH))) - ((applySing ((applySing ((singFun2 @MapSym0) sMap)) sF)) sT) - instance SingI (EtadSym0 :: (~>) [Nat] ((~>) [Bool] [Nat])) where - sing = (singFun2 @EtadSym0) sEtad - instance SingI d => - SingI (EtadSym1 (d :: [Nat]) :: (~>) [Bool] [Nat]) where - sing = (singFun1 @(EtadSym1 (d :: [Nat]))) (sEtad (sing @d)) - instance SingI (SplungeSym0 :: (~>) [Nat] ((~>) [Bool] [Nat])) where - sing = (singFun2 @SplungeSym0) sSplunge - instance SingI d => - SingI (SplungeSym1 (d :: [Nat]) :: (~>) [Bool] [Nat]) where - sing = (singFun1 @(SplungeSym1 (d :: [Nat]))) (sSplunge (sing @d)) - instance SingI (FooSym0 :: (~>) ((~>) ((~>) a b) ((~>) a b)) ((~>) ((~>) a b) ((~>) a b))) where - sing = (singFun3 @FooSym0) sFoo - instance SingI d => - SingI (FooSym1 (d :: (~>) ((~>) a b) ((~>) a b)) :: (~>) ((~>) a b) ((~>) a b)) where - sing - = (singFun2 @(FooSym1 (d :: (~>) ((~>) a b) ((~>) a b)))) - (sFoo (sing @d)) - instance (SingI d, SingI d) => - SingI (FooSym2 (d :: (~>) ((~>) a b) ((~>) a b)) (d :: (~>) a b) :: (~>) a b) where - sing - = (singFun1 - @(FooSym2 (d :: (~>) ((~>) a b) ((~>) a b)) (d :: (~>) a b))) - ((sFoo (sing @d)) (sing @d)) - instance SingI (ZipWithSym0 :: (~>) ((~>) a ((~>) b c)) ((~>) [a] ((~>) [b] [c]))) where - sing = (singFun3 @ZipWithSym0) sZipWith - instance SingI d => - SingI (ZipWithSym1 (d :: (~>) a ((~>) b c)) :: (~>) [a] ((~>) [b] [c])) where - sing - = (singFun2 @(ZipWithSym1 (d :: (~>) a ((~>) b c)))) - (sZipWith (sing @d)) - instance (SingI d, SingI d) => - SingI (ZipWithSym2 (d :: (~>) a ((~>) b c)) (d :: [a]) :: (~>) [b] [c]) where - sing - = (singFun1 @(ZipWithSym2 (d :: (~>) a ((~>) b c)) (d :: [a]))) - ((sZipWith (sing @d)) (sing @d)) - instance SingI (LiftMaybeSym0 :: (~>) ((~>) a b) ((~>) (Maybe a) (Maybe b))) where - sing = (singFun2 @LiftMaybeSym0) sLiftMaybe - instance SingI d => - SingI (LiftMaybeSym1 (d :: (~>) a b) :: (~>) (Maybe a) (Maybe b)) where - sing - = (singFun1 @(LiftMaybeSym1 (d :: (~>) a b))) - (sLiftMaybe (sing @d)) - instance SingI (MapSym0 :: (~>) ((~>) a b) ((~>) [a] [b])) where - sing = (singFun2 @MapSym0) sMap - instance SingI d => - SingI (MapSym1 (d :: (~>) a b) :: (~>) [a] [b]) where - sing = (singFun1 @(MapSym1 (d :: (~>) a b))) (sMap (sing @d)) - data SEither :: forall a b. Either a b -> GHC.Types.Type - where - SLeft :: forall a (n :: a). (Sing (n :: a)) -> SEither (Left n) - SRight :: forall b (n :: b). (Sing (n :: b)) -> SEither (Right n) - type instance Sing @(Either a b) = SEither - instance (SingKind a, SingKind b) => SingKind (Either a b) where - type Demote (Either a b) = Either (Demote a) (Demote b) - fromSing (SLeft b) = Left (fromSing b) - fromSing (SRight b) = Right (fromSing b) - toSing (Left (b :: Demote a)) - = case toSing b :: SomeSing a of { - SomeSing c -> SomeSing (SLeft c) } - toSing (Right (b :: Demote b)) - = case toSing b :: SomeSing b of { - SomeSing c -> SomeSing (SRight c) } - instance SingI n => SingI (Left (n :: a)) where - sing = SLeft sing - instance SingI (LeftSym0 :: (~>) a (Either a b)) where - sing = (singFun1 @LeftSym0) SLeft - instance SingI n => SingI (Right (n :: b)) where - sing = SRight sing - instance SingI (RightSym0 :: (~>) b (Either a b)) where - sing = (singFun1 @RightSym0) SRight diff --git a/tests/compile-and-dump/Singletons/HigherOrder.hs b/tests/compile-and-dump/Singletons/HigherOrder.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/HigherOrder.hs +++ /dev/null @@ -1,57 +0,0 @@ -module Singletons.HigherOrder where - -import Data.Singletons -import Data.Singletons.TH -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) - - 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 (TyCon Either) '[Int, Bool] '[Char, Double]) -foo1a = Proxy - -foo1b :: Proxy ('[Either Int Char, Either Bool Double]) -foo1b = foo1a - -foo2a :: Proxy (Map (TyCon (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.ghc88.template b/tests/compile-and-dump/Singletons/LambdaCase.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/LambdaCase.ghc88.template +++ /dev/null @@ -1,255 +0,0 @@ -Singletons/LambdaCase.hs:(0,0)-(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) |] - ======> - 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) - type family Case_0123456789876543210 x_0123456789876543210 a b t where - Case_0123456789876543210 x_0123456789876543210 a b '(p, _) = p - type family Lambda_0123456789876543210 a b t where - Lambda_0123456789876543210 a b x_0123456789876543210 = Case_0123456789876543210 x_0123456789876543210 a b x_0123456789876543210 - type Lambda_0123456789876543210Sym3 a0123456789876543210 b0123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 a0123456789876543210 b0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 b0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 a0123456789876543210 b0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall a0123456789876543210 - b0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 a0123456789876543210 b0123456789876543210) arg) (Lambda_0123456789876543210Sym3 a0123456789876543210 b0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 a0123456789876543210 b0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 b0123456789876543210 a0123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 b0123456789876543210 a0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 a0123456789876543210 b0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - b0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 a0123456789876543210) arg) (Lambda_0123456789876543210Sym2 a0123456789876543210 arg) => - Lambda_0123456789876543210Sym1 a0123456789876543210 b0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 a0123456789876543210) b0123456789876543210 = Lambda_0123456789876543210Sym2 a0123456789876543210 b0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 a0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 a0123456789876543210 = Lambda_0123456789876543210Sym1 a0123456789876543210 - type family Case_0123456789876543210 x_0123456789876543210 d t where - Case_0123456789876543210 x_0123456789876543210 d ('Just y) = y - Case_0123456789876543210 x_0123456789876543210 d 'Nothing = d - type family Lambda_0123456789876543210 d t where - Lambda_0123456789876543210 d x_0123456789876543210 = Case_0123456789876543210 x_0123456789876543210 d x_0123456789876543210 - type Lambda_0123456789876543210Sym2 d0123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 d0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 d0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 d0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall d0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 d0123456789876543210) arg) (Lambda_0123456789876543210Sym2 d0123456789876543210 arg) => - Lambda_0123456789876543210Sym1 d0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 d0123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 d0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 d0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall d0123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 d0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 d0123456789876543210 = Lambda_0123456789876543210Sym1 d0123456789876543210 - type family Case_0123456789876543210 x_0123456789876543210 d x t where - Case_0123456789876543210 x_0123456789876543210 d x ('Just y) = y - Case_0123456789876543210 x_0123456789876543210 d x 'Nothing = d - type family Lambda_0123456789876543210 d x t where - Lambda_0123456789876543210 d x x_0123456789876543210 = Case_0123456789876543210 x_0123456789876543210 d x x_0123456789876543210 - type Lambda_0123456789876543210Sym3 d0123456789876543210 x0123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 d0123456789876543210 x0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 x0123456789876543210 d0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 d0123456789876543210 x0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall d0123456789876543210 - x0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 d0123456789876543210 x0123456789876543210) arg) (Lambda_0123456789876543210Sym3 d0123456789876543210 x0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 d0123456789876543210 x0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 x0123456789876543210 d0123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 x0123456789876543210 d0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 d0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 d0123456789876543210 x0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall d0123456789876543210 - x0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 d0123456789876543210) arg) (Lambda_0123456789876543210Sym2 d0123456789876543210 arg) => - Lambda_0123456789876543210Sym1 d0123456789876543210 x0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 d0123456789876543210) x0123456789876543210 = Lambda_0123456789876543210Sym2 d0123456789876543210 x0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 d0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall d0123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 d0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 d0123456789876543210 = Lambda_0123456789876543210Sym1 d0123456789876543210 - type Foo3Sym2 (a0123456789876543210 :: a0123456789876543210) (a0123456789876543210 :: b0123456789876543210) = - Foo3 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Foo3Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) Foo3Sym1KindInference) ()) - data Foo3Sym1 (a0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210. - (~>) b0123456789876543210 a0123456789876543210 - where - Foo3Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Foo3Sym1 a0123456789876543210) arg) (Foo3Sym2 a0123456789876543210 arg) => - Foo3Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Foo3Sym1 a0123456789876543210) a0123456789876543210 = Foo3 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Foo3Sym0 where - suppressUnusedWarnings = snd (((,) Foo3Sym0KindInference) ()) - data Foo3Sym0 :: forall a0123456789876543210 b0123456789876543210. - (~>) a0123456789876543210 ((~>) b0123456789876543210 a0123456789876543210) - where - Foo3Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo3Sym0 arg) (Foo3Sym1 arg) => - Foo3Sym0 a0123456789876543210 - type instance Apply Foo3Sym0 a0123456789876543210 = Foo3Sym1 a0123456789876543210 - type Foo2Sym2 (a0123456789876543210 :: a0123456789876543210) (a0123456789876543210 :: Maybe a0123456789876543210) = - Foo2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Foo2Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) Foo2Sym1KindInference) ()) - data Foo2Sym1 (a0123456789876543210 :: a0123456789876543210) :: (~>) (Maybe a0123456789876543210) a0123456789876543210 - where - Foo2Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Foo2Sym1 a0123456789876543210) arg) (Foo2Sym2 a0123456789876543210 arg) => - Foo2Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Foo2Sym1 a0123456789876543210) a0123456789876543210 = Foo2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Foo2Sym0 where - suppressUnusedWarnings = snd (((,) Foo2Sym0KindInference) ()) - data Foo2Sym0 :: forall a0123456789876543210. - (~>) a0123456789876543210 ((~>) (Maybe a0123456789876543210) a0123456789876543210) - where - Foo2Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo2Sym0 arg) (Foo2Sym1 arg) => - Foo2Sym0 a0123456789876543210 - type instance Apply Foo2Sym0 a0123456789876543210 = Foo2Sym1 a0123456789876543210 - type Foo1Sym2 (a0123456789876543210 :: a0123456789876543210) (a0123456789876543210 :: Maybe a0123456789876543210) = - Foo1 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Foo1Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) Foo1Sym1KindInference) ()) - data Foo1Sym1 (a0123456789876543210 :: a0123456789876543210) :: (~>) (Maybe a0123456789876543210) a0123456789876543210 - where - Foo1Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Foo1Sym1 a0123456789876543210) arg) (Foo1Sym2 a0123456789876543210 arg) => - Foo1Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Foo1Sym1 a0123456789876543210) a0123456789876543210 = Foo1 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Foo1Sym0 where - suppressUnusedWarnings = snd (((,) Foo1Sym0KindInference) ()) - data Foo1Sym0 :: forall a0123456789876543210. - (~>) a0123456789876543210 ((~>) (Maybe a0123456789876543210) a0123456789876543210) - where - Foo1Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo1Sym0 arg) (Foo1Sym1 arg) => - Foo1Sym0 a0123456789876543210 - type instance Apply Foo1Sym0 a0123456789876543210 = Foo1Sym1 a0123456789876543210 - type family Foo3 (a :: a) (a :: b) :: a where - Foo3 a b = Apply (Apply (Apply Lambda_0123456789876543210Sym0 a) b) (Apply (Apply Tuple2Sym0 a) b) - type family Foo2 (a :: a) (a :: Maybe a) :: a where - Foo2 d _ = Apply (Apply Lambda_0123456789876543210Sym0 d) (Apply JustSym0 d) - type family Foo1 (a :: a) (a :: Maybe a) :: a where - Foo1 d x = Apply (Apply (Apply Lambda_0123456789876543210Sym0 d) x) x - sFoo3 :: - forall a b (t :: a) (t :: b). - Sing t -> Sing t -> Sing (Apply (Apply Foo3Sym0 t) t :: a) - sFoo2 :: - forall a (t :: a) (t :: Maybe a). - Sing t -> Sing t -> Sing (Apply (Apply Foo2Sym0 t) t :: a) - sFoo1 :: - forall a (t :: a) (t :: Maybe a). - Sing t -> Sing t -> Sing (Apply (Apply Foo1Sym0 t) t :: a) - sFoo3 (sA :: Sing a) (sB :: Sing b) - = (applySing - ((singFun1 @(Apply (Apply Lambda_0123456789876543210Sym0 a) b)) - (\ sX_0123456789876543210 - -> case sX_0123456789876543210 of { - (_ :: Sing x_0123456789876543210) - -> (id - @(Sing (Case_0123456789876543210 x_0123456789876543210 a b x_0123456789876543210))) - (case sX_0123456789876543210 of { - STuple2 (sP :: Sing p) _ -> sP }) }))) - ((applySing ((applySing ((singFun2 @Tuple2Sym0) STuple2)) sA)) sB) - sFoo2 (sD :: Sing d) _ - = (applySing - ((singFun1 @(Apply Lambda_0123456789876543210Sym0 d)) - (\ sX_0123456789876543210 - -> case sX_0123456789876543210 of { - (_ :: Sing x_0123456789876543210) - -> (id - @(Sing (Case_0123456789876543210 x_0123456789876543210 d x_0123456789876543210))) - (case sX_0123456789876543210 of - SJust (sY :: Sing y) -> sY - SNothing -> sD) }))) - ((applySing ((singFun1 @JustSym0) SJust)) sD) - sFoo1 (sD :: Sing d) (sX :: Sing x) - = (applySing - ((singFun1 @(Apply (Apply Lambda_0123456789876543210Sym0 d) x)) - (\ sX_0123456789876543210 - -> case sX_0123456789876543210 of { - (_ :: Sing x_0123456789876543210) - -> (id - @(Sing (Case_0123456789876543210 x_0123456789876543210 d x x_0123456789876543210))) - (case sX_0123456789876543210 of - SJust (sY :: Sing y) -> sY - SNothing -> sD) }))) - sX - instance SingI (Foo3Sym0 :: (~>) a ((~>) b a)) where - sing = (singFun2 @Foo3Sym0) sFoo3 - instance SingI d => SingI (Foo3Sym1 (d :: a) :: (~>) b a) where - sing = (singFun1 @(Foo3Sym1 (d :: a))) (sFoo3 (sing @d)) - instance SingI (Foo2Sym0 :: (~>) a ((~>) (Maybe a) a)) where - sing = (singFun2 @Foo2Sym0) sFoo2 - instance SingI d => - SingI (Foo2Sym1 (d :: a) :: (~>) (Maybe a) a) where - sing = (singFun1 @(Foo2Sym1 (d :: a))) (sFoo2 (sing @d)) - instance SingI (Foo1Sym0 :: (~>) a ((~>) (Maybe a) a)) where - sing = (singFun2 @Foo1Sym0) sFoo1 - instance SingI d => - SingI (Foo1Sym1 (d :: a) :: (~>) (Maybe a) a) where - sing = (singFun1 @(Foo1Sym1 (d :: a))) (sFoo1 (sing @d)) diff --git a/tests/compile-and-dump/Singletons/LambdaCase.hs b/tests/compile-and-dump/Singletons/LambdaCase.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/LambdaCase.hs +++ /dev/null @@ -1,39 +0,0 @@ -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.ghc88.template b/tests/compile-and-dump/Singletons/Lambdas.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Lambdas.ghc88.template +++ /dev/null @@ -1,832 +0,0 @@ -Singletons/Lambdas.hs:(0,0)-(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 |] - ======> - 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) - data Foo a b = Foo a b - foo8 :: Foo a b -> a - foo8 x = (\ (Foo a _) -> a) x - type FooSym2 (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: b0123456789876543210) = - Foo t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (FooSym1 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) FooSym1KindInference) ()) - data FooSym1 (t0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210. - (~>) b0123456789876543210 (Foo a0123456789876543210 b0123456789876543210) - where - FooSym1KindInference :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (FooSym1 t0123456789876543210) arg) (FooSym2 t0123456789876543210 arg) => - FooSym1 t0123456789876543210 t0123456789876543210 - type instance Apply (FooSym1 t0123456789876543210) t0123456789876543210 = Foo t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings FooSym0 where - suppressUnusedWarnings = snd (((,) FooSym0KindInference) ()) - data FooSym0 :: forall a0123456789876543210 b0123456789876543210. - (~>) a0123456789876543210 ((~>) b0123456789876543210 (Foo a0123456789876543210 b0123456789876543210)) - where - FooSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply FooSym0 arg) (FooSym1 arg) => - FooSym0 t0123456789876543210 - type instance Apply FooSym0 t0123456789876543210 = FooSym1 t0123456789876543210 - type family Case_0123456789876543210 arg_0123456789876543210 x t where - Case_0123456789876543210 arg_0123456789876543210 x (Foo a _) = a - type family Lambda_0123456789876543210 x t where - Lambda_0123456789876543210 x arg_0123456789876543210 = Case_0123456789876543210 arg_0123456789876543210 x arg_0123456789876543210 - type Lambda_0123456789876543210Sym2 x0123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 x0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 x0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall x0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 x0123456789876543210) arg) (Lambda_0123456789876543210Sym2 x0123456789876543210 arg) => - Lambda_0123456789876543210Sym1 x0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 x0123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 x0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 x0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall x0123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 x0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 x0123456789876543210 = Lambda_0123456789876543210Sym1 x0123456789876543210 - type family Case_0123456789876543210 arg_0123456789876543210 x y t where - Case_0123456789876543210 arg_0123456789876543210 x y '(_, b) = b - type family Lambda_0123456789876543210 x y t where - Lambda_0123456789876543210 x y arg_0123456789876543210 = Case_0123456789876543210 arg_0123456789876543210 x y arg_0123456789876543210 - type Lambda_0123456789876543210Sym3 x0123456789876543210 y0123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 x0123456789876543210 y0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 y0123456789876543210 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall x0123456789876543210 - y0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210) arg) (Lambda_0123456789876543210Sym3 x0123456789876543210 y0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 y0123456789876543210 x0123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 y0123456789876543210 x0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 x0123456789876543210 y0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall x0123456789876543210 - y0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 x0123456789876543210) arg) (Lambda_0123456789876543210Sym2 x0123456789876543210 arg) => - Lambda_0123456789876543210Sym1 x0123456789876543210 y0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 x0123456789876543210) y0123456789876543210 = Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 x0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall x0123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 x0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 x0123456789876543210 = Lambda_0123456789876543210Sym1 x0123456789876543210 - type family Case_0123456789876543210 arg_0123456789876543210 x a b t where - Case_0123456789876543210 arg_0123456789876543210 x a b _ = x - type family Lambda_0123456789876543210 x a b t where - Lambda_0123456789876543210 x a b arg_0123456789876543210 = Case_0123456789876543210 arg_0123456789876543210 x a b arg_0123456789876543210 - type Lambda_0123456789876543210Sym4 x0123456789876543210 a0123456789876543210 b0123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 x0123456789876543210 a0123456789876543210 b0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym3 b0123456789876543210 a0123456789876543210 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym3KindInference) ()) - data Lambda_0123456789876543210Sym3 x0123456789876543210 a0123456789876543210 b0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym3KindInference :: forall x0123456789876543210 - a0123456789876543210 - b0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym3 x0123456789876543210 a0123456789876543210 b0123456789876543210) arg) (Lambda_0123456789876543210Sym4 x0123456789876543210 a0123456789876543210 b0123456789876543210 arg) => - Lambda_0123456789876543210Sym3 x0123456789876543210 a0123456789876543210 b0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym3 b0123456789876543210 a0123456789876543210 x0123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 b0123456789876543210 a0123456789876543210 x0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 a0123456789876543210 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 x0123456789876543210 a0123456789876543210 b0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall x0123456789876543210 - a0123456789876543210 - b0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 x0123456789876543210 a0123456789876543210) arg) (Lambda_0123456789876543210Sym3 x0123456789876543210 a0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 x0123456789876543210 a0123456789876543210 b0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 a0123456789876543210 x0123456789876543210) b0123456789876543210 = Lambda_0123456789876543210Sym3 a0123456789876543210 x0123456789876543210 b0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 x0123456789876543210 a0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall x0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 x0123456789876543210) arg) (Lambda_0123456789876543210Sym2 x0123456789876543210 arg) => - Lambda_0123456789876543210Sym1 x0123456789876543210 a0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 x0123456789876543210) a0123456789876543210 = Lambda_0123456789876543210Sym2 x0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 x0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall x0123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 x0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 x0123456789876543210 = Lambda_0123456789876543210Sym1 x0123456789876543210 - type family Lambda_0123456789876543210 a b t where - Lambda_0123456789876543210 a b x = Apply (Apply (Apply Lambda_0123456789876543210Sym0 x) a) b - type Lambda_0123456789876543210Sym3 a0123456789876543210 b0123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 a0123456789876543210 b0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 b0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 a0123456789876543210 b0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall a0123456789876543210 - b0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 a0123456789876543210 b0123456789876543210) arg) (Lambda_0123456789876543210Sym3 a0123456789876543210 b0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 a0123456789876543210 b0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 b0123456789876543210 a0123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 b0123456789876543210 a0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 a0123456789876543210 b0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - b0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 a0123456789876543210) arg) (Lambda_0123456789876543210Sym2 a0123456789876543210 arg) => - Lambda_0123456789876543210Sym1 a0123456789876543210 b0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 a0123456789876543210) b0123456789876543210 = Lambda_0123456789876543210Sym2 a0123456789876543210 b0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 a0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 a0123456789876543210 = Lambda_0123456789876543210Sym1 a0123456789876543210 - type family Lambda_0123456789876543210 x y t where - Lambda_0123456789876543210 x y x = x - type Lambda_0123456789876543210Sym3 x0123456789876543210 y0123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 x0123456789876543210 y0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 y0123456789876543210 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall x0123456789876543210 - y0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210) arg) (Lambda_0123456789876543210Sym3 x0123456789876543210 y0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 y0123456789876543210 x0123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 y0123456789876543210 x0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 x0123456789876543210 y0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall x0123456789876543210 - y0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 x0123456789876543210) arg) (Lambda_0123456789876543210Sym2 x0123456789876543210 arg) => - Lambda_0123456789876543210Sym1 x0123456789876543210 y0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 x0123456789876543210) y0123456789876543210 = Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 x0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall x0123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 x0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 x0123456789876543210 = Lambda_0123456789876543210Sym1 x0123456789876543210 - type family Case_0123456789876543210 arg_0123456789876543210 arg_0123456789876543210 x y z t where - Case_0123456789876543210 arg_0123456789876543210 arg_0123456789876543210 x y z '(_, - _) = x - type family Lambda_0123456789876543210 x y z t t where - Lambda_0123456789876543210 x y z arg_0123456789876543210 arg_0123456789876543210 = Case_0123456789876543210 arg_0123456789876543210 arg_0123456789876543210 x y z (Apply (Apply Tuple2Sym0 arg_0123456789876543210) arg_0123456789876543210) - type Lambda_0123456789876543210Sym5 x0123456789876543210 y0123456789876543210 z0123456789876543210 t0123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 x0123456789876543210 y0123456789876543210 z0123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym4 t0123456789876543210 z0123456789876543210 y0123456789876543210 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym4KindInference) ()) - data Lambda_0123456789876543210Sym4 x0123456789876543210 y0123456789876543210 z0123456789876543210 t0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym4KindInference :: forall x0123456789876543210 - y0123456789876543210 - z0123456789876543210 - t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym4 x0123456789876543210 y0123456789876543210 z0123456789876543210 t0123456789876543210) arg) (Lambda_0123456789876543210Sym5 x0123456789876543210 y0123456789876543210 z0123456789876543210 t0123456789876543210 arg) => - Lambda_0123456789876543210Sym4 x0123456789876543210 y0123456789876543210 z0123456789876543210 t0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym4 t0123456789876543210 z0123456789876543210 y0123456789876543210 x0123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 t0123456789876543210 z0123456789876543210 y0123456789876543210 x0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym3 z0123456789876543210 y0123456789876543210 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym3KindInference) ()) - data Lambda_0123456789876543210Sym3 x0123456789876543210 y0123456789876543210 z0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym3KindInference :: forall x0123456789876543210 - y0123456789876543210 - z0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym3 x0123456789876543210 y0123456789876543210 z0123456789876543210) arg) (Lambda_0123456789876543210Sym4 x0123456789876543210 y0123456789876543210 z0123456789876543210 arg) => - Lambda_0123456789876543210Sym3 x0123456789876543210 y0123456789876543210 z0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym3 z0123456789876543210 y0123456789876543210 x0123456789876543210) t0123456789876543210 = Lambda_0123456789876543210Sym4 z0123456789876543210 y0123456789876543210 x0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 y0123456789876543210 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210 z0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall x0123456789876543210 - y0123456789876543210 - z0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210) arg) (Lambda_0123456789876543210Sym3 x0123456789876543210 y0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210 z0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 y0123456789876543210 x0123456789876543210) z0123456789876543210 = Lambda_0123456789876543210Sym3 y0123456789876543210 x0123456789876543210 z0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 x0123456789876543210 y0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall x0123456789876543210 - y0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 x0123456789876543210) arg) (Lambda_0123456789876543210Sym2 x0123456789876543210 arg) => - Lambda_0123456789876543210Sym1 x0123456789876543210 y0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 x0123456789876543210) y0123456789876543210 = Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 x0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall x0123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 x0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 x0123456789876543210 = Lambda_0123456789876543210Sym1 x0123456789876543210 - type family Lambda_0123456789876543210 x t where - Lambda_0123456789876543210 x y = y - type Lambda_0123456789876543210Sym2 x0123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 x0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 x0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall x0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 x0123456789876543210) arg) (Lambda_0123456789876543210Sym2 x0123456789876543210 arg) => - Lambda_0123456789876543210Sym1 x0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 x0123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 x0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 x0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall x0123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 x0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 x0123456789876543210 = Lambda_0123456789876543210Sym1 x0123456789876543210 - type family Case_0123456789876543210 arg_0123456789876543210 x y t where - Case_0123456789876543210 arg_0123456789876543210 x y _ = x - type family Lambda_0123456789876543210 x y t where - Lambda_0123456789876543210 x y arg_0123456789876543210 = Case_0123456789876543210 arg_0123456789876543210 x y arg_0123456789876543210 - type Lambda_0123456789876543210Sym3 x0123456789876543210 y0123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 x0123456789876543210 y0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 y0123456789876543210 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall x0123456789876543210 - y0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210) arg) (Lambda_0123456789876543210Sym3 x0123456789876543210 y0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 y0123456789876543210 x0123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 y0123456789876543210 x0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 x0123456789876543210 y0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall x0123456789876543210 - y0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 x0123456789876543210) arg) (Lambda_0123456789876543210Sym2 x0123456789876543210 arg) => - Lambda_0123456789876543210Sym1 x0123456789876543210 y0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 x0123456789876543210) y0123456789876543210 = Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 x0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall x0123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 x0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 x0123456789876543210 = Lambda_0123456789876543210Sym1 x0123456789876543210 - type family Case_0123456789876543210 arg_0123456789876543210 x a_0123456789876543210 t where - Case_0123456789876543210 arg_0123456789876543210 x a_0123456789876543210 _ = x - type family Lambda_0123456789876543210 x a_0123456789876543210 t where - Lambda_0123456789876543210 x a_0123456789876543210 arg_0123456789876543210 = Case_0123456789876543210 arg_0123456789876543210 x a_0123456789876543210 arg_0123456789876543210 - type Lambda_0123456789876543210Sym3 x0123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 x0123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 x0123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall x0123456789876543210 - a_01234567898765432100123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 x0123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym3 x0123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym2 x0123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 x0123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 a_01234567898765432100123456789876543210 x0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 x0123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall x0123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 x0123456789876543210) arg) (Lambda_0123456789876543210Sym2 x0123456789876543210 arg) => - Lambda_0123456789876543210Sym1 x0123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 x0123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym2 x0123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 x0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall x0123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 x0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 x0123456789876543210 = Lambda_0123456789876543210Sym1 x0123456789876543210 - type family Lambda_0123456789876543210 a_0123456789876543210 a_0123456789876543210 t t where - Lambda_0123456789876543210 a_0123456789876543210 a_0123456789876543210 x y = x - type Lambda_0123456789876543210Sym4 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym3 t0123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym3KindInference) ()) - data Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym3KindInference :: forall a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210) arg) (Lambda_0123456789876543210Sym4 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 arg) => - Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym3 t0123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 t0123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) t0123456789876543210 = Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall a_01234567898765432100123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 a_01234567898765432100123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210 - type Foo8Sym1 (a0123456789876543210 :: Foo a0123456789876543210 b0123456789876543210) = - Foo8 a0123456789876543210 - instance SuppressUnusedWarnings Foo8Sym0 where - suppressUnusedWarnings = snd (((,) Foo8Sym0KindInference) ()) - data Foo8Sym0 :: forall a0123456789876543210 b0123456789876543210. - (~>) (Foo a0123456789876543210 b0123456789876543210) a0123456789876543210 - where - Foo8Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo8Sym0 arg) (Foo8Sym1 arg) => - Foo8Sym0 a0123456789876543210 - type instance Apply Foo8Sym0 a0123456789876543210 = Foo8 a0123456789876543210 - type Foo7Sym2 (a0123456789876543210 :: a0123456789876543210) (a0123456789876543210 :: b0123456789876543210) = - Foo7 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Foo7Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) Foo7Sym1KindInference) ()) - data Foo7Sym1 (a0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210. - (~>) b0123456789876543210 b0123456789876543210 - where - Foo7Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Foo7Sym1 a0123456789876543210) arg) (Foo7Sym2 a0123456789876543210 arg) => - Foo7Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Foo7Sym1 a0123456789876543210) a0123456789876543210 = Foo7 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Foo7Sym0 where - suppressUnusedWarnings = snd (((,) Foo7Sym0KindInference) ()) - data Foo7Sym0 :: forall a0123456789876543210 b0123456789876543210. - (~>) a0123456789876543210 ((~>) b0123456789876543210 b0123456789876543210) - where - Foo7Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo7Sym0 arg) (Foo7Sym1 arg) => - Foo7Sym0 a0123456789876543210 - type instance Apply Foo7Sym0 a0123456789876543210 = Foo7Sym1 a0123456789876543210 - type Foo6Sym2 (a0123456789876543210 :: a0123456789876543210) (a0123456789876543210 :: b0123456789876543210) = - Foo6 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Foo6Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) Foo6Sym1KindInference) ()) - data Foo6Sym1 (a0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210. - (~>) b0123456789876543210 a0123456789876543210 - where - Foo6Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Foo6Sym1 a0123456789876543210) arg) (Foo6Sym2 a0123456789876543210 arg) => - Foo6Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Foo6Sym1 a0123456789876543210) a0123456789876543210 = Foo6 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Foo6Sym0 where - suppressUnusedWarnings = snd (((,) Foo6Sym0KindInference) ()) - data Foo6Sym0 :: forall a0123456789876543210 b0123456789876543210. - (~>) a0123456789876543210 ((~>) b0123456789876543210 a0123456789876543210) - where - Foo6Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo6Sym0 arg) (Foo6Sym1 arg) => - Foo6Sym0 a0123456789876543210 - type instance Apply Foo6Sym0 a0123456789876543210 = Foo6Sym1 a0123456789876543210 - type Foo5Sym2 (a0123456789876543210 :: a0123456789876543210) (a0123456789876543210 :: b0123456789876543210) = - Foo5 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Foo5Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) Foo5Sym1KindInference) ()) - data Foo5Sym1 (a0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210. - (~>) b0123456789876543210 b0123456789876543210 - where - Foo5Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Foo5Sym1 a0123456789876543210) arg) (Foo5Sym2 a0123456789876543210 arg) => - Foo5Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Foo5Sym1 a0123456789876543210) a0123456789876543210 = Foo5 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Foo5Sym0 where - suppressUnusedWarnings = snd (((,) Foo5Sym0KindInference) ()) - data Foo5Sym0 :: forall a0123456789876543210 b0123456789876543210. - (~>) a0123456789876543210 ((~>) b0123456789876543210 b0123456789876543210) - where - Foo5Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo5Sym0 arg) (Foo5Sym1 arg) => - Foo5Sym0 a0123456789876543210 - type instance Apply Foo5Sym0 a0123456789876543210 = Foo5Sym1 a0123456789876543210 - type Foo4Sym3 (a0123456789876543210 :: a0123456789876543210) (a0123456789876543210 :: b0123456789876543210) (a0123456789876543210 :: c0123456789876543210) = - Foo4 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Foo4Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) Foo4Sym2KindInference) ()) - data Foo4Sym2 (a0123456789876543210 :: a0123456789876543210) (a0123456789876543210 :: b0123456789876543210) :: forall c0123456789876543210. - (~>) c0123456789876543210 a0123456789876543210 - where - Foo4Sym2KindInference :: forall a0123456789876543210 - a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Foo4Sym2 a0123456789876543210 a0123456789876543210) arg) (Foo4Sym3 a0123456789876543210 a0123456789876543210 arg) => - Foo4Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (Foo4Sym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = Foo4 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Foo4Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) Foo4Sym1KindInference) ()) - data Foo4Sym1 (a0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210 - c0123456789876543210. - (~>) b0123456789876543210 ((~>) c0123456789876543210 a0123456789876543210) - where - Foo4Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Foo4Sym1 a0123456789876543210) arg) (Foo4Sym2 a0123456789876543210 arg) => - Foo4Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Foo4Sym1 a0123456789876543210) a0123456789876543210 = Foo4Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Foo4Sym0 where - suppressUnusedWarnings = snd (((,) Foo4Sym0KindInference) ()) - data Foo4Sym0 :: forall a0123456789876543210 - b0123456789876543210 - c0123456789876543210. - (~>) a0123456789876543210 ((~>) b0123456789876543210 ((~>) c0123456789876543210 a0123456789876543210)) - where - Foo4Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo4Sym0 arg) (Foo4Sym1 arg) => - Foo4Sym0 a0123456789876543210 - type instance Apply Foo4Sym0 a0123456789876543210 = Foo4Sym1 a0123456789876543210 - type Foo3Sym1 (a0123456789876543210 :: a0123456789876543210) = - Foo3 a0123456789876543210 - instance SuppressUnusedWarnings Foo3Sym0 where - suppressUnusedWarnings = snd (((,) Foo3Sym0KindInference) ()) - data Foo3Sym0 :: forall a0123456789876543210. - (~>) a0123456789876543210 a0123456789876543210 - where - Foo3Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo3Sym0 arg) (Foo3Sym1 arg) => - Foo3Sym0 a0123456789876543210 - type instance Apply Foo3Sym0 a0123456789876543210 = Foo3 a0123456789876543210 - type Foo2Sym2 (a0123456789876543210 :: a0123456789876543210) (a0123456789876543210 :: b0123456789876543210) = - Foo2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Foo2Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) Foo2Sym1KindInference) ()) - data Foo2Sym1 (a0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210. - (~>) b0123456789876543210 a0123456789876543210 - where - Foo2Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Foo2Sym1 a0123456789876543210) arg) (Foo2Sym2 a0123456789876543210 arg) => - Foo2Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Foo2Sym1 a0123456789876543210) a0123456789876543210 = Foo2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Foo2Sym0 where - suppressUnusedWarnings = snd (((,) Foo2Sym0KindInference) ()) - data Foo2Sym0 :: forall a0123456789876543210 b0123456789876543210. - (~>) a0123456789876543210 ((~>) b0123456789876543210 a0123456789876543210) - where - Foo2Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo2Sym0 arg) (Foo2Sym1 arg) => - Foo2Sym0 a0123456789876543210 - type instance Apply Foo2Sym0 a0123456789876543210 = Foo2Sym1 a0123456789876543210 - type Foo1Sym2 (a0123456789876543210 :: a0123456789876543210) (a0123456789876543210 :: b0123456789876543210) = - Foo1 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Foo1Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) Foo1Sym1KindInference) ()) - data Foo1Sym1 (a0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210. - (~>) b0123456789876543210 a0123456789876543210 - where - Foo1Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Foo1Sym1 a0123456789876543210) arg) (Foo1Sym2 a0123456789876543210 arg) => - Foo1Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Foo1Sym1 a0123456789876543210) a0123456789876543210 = Foo1 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Foo1Sym0 where - suppressUnusedWarnings = snd (((,) Foo1Sym0KindInference) ()) - data Foo1Sym0 :: forall a0123456789876543210 b0123456789876543210. - (~>) a0123456789876543210 ((~>) b0123456789876543210 a0123456789876543210) - where - Foo1Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo1Sym0 arg) (Foo1Sym1 arg) => - Foo1Sym0 a0123456789876543210 - type instance Apply Foo1Sym0 a0123456789876543210 = Foo1Sym1 a0123456789876543210 - type Foo0Sym2 (a0123456789876543210 :: a0123456789876543210) (a0123456789876543210 :: b0123456789876543210) = - Foo0 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Foo0Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) Foo0Sym1KindInference) ()) - data Foo0Sym1 (a0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210. - (~>) b0123456789876543210 a0123456789876543210 - where - Foo0Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Foo0Sym1 a0123456789876543210) arg) (Foo0Sym2 a0123456789876543210 arg) => - Foo0Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Foo0Sym1 a0123456789876543210) a0123456789876543210 = Foo0 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Foo0Sym0 where - suppressUnusedWarnings = snd (((,) Foo0Sym0KindInference) ()) - data Foo0Sym0 :: forall a0123456789876543210 b0123456789876543210. - (~>) a0123456789876543210 ((~>) b0123456789876543210 a0123456789876543210) - where - Foo0Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo0Sym0 arg) (Foo0Sym1 arg) => - Foo0Sym0 a0123456789876543210 - type instance Apply Foo0Sym0 a0123456789876543210 = Foo0Sym1 a0123456789876543210 - type family Foo8 (a :: Foo a b) :: a where - Foo8 x = Apply (Apply Lambda_0123456789876543210Sym0 x) x - type family Foo7 (a :: a) (a :: b) :: b where - Foo7 x y = Apply (Apply (Apply Lambda_0123456789876543210Sym0 x) y) (Apply (Apply Tuple2Sym0 x) y) - type family Foo6 (a :: a) (a :: b) :: a where - Foo6 a b = Apply (Apply (Apply (Apply Lambda_0123456789876543210Sym0 a) b) a) b - type family Foo5 (a :: a) (a :: b) :: b where - Foo5 x y = Apply (Apply (Apply Lambda_0123456789876543210Sym0 x) y) y - type family Foo4 (a :: a) (a :: b) (a :: c) :: a where - Foo4 x y z = Apply (Apply (Apply (Apply (Apply Lambda_0123456789876543210Sym0 x) y) z) y) z - type family Foo3 (a :: a) :: a where - Foo3 x = Apply (Apply Lambda_0123456789876543210Sym0 x) x - type family Foo2 (a :: a) (a :: b) :: a where - Foo2 x y = Apply (Apply (Apply Lambda_0123456789876543210Sym0 x) y) y - type family Foo1 (a :: a) (a :: b) :: a where - Foo1 x a_0123456789876543210 = Apply (Apply (Apply Lambda_0123456789876543210Sym0 x) a_0123456789876543210) a_0123456789876543210 - type family Foo0 (a :: a) (a :: b) :: a where - Foo0 a_0123456789876543210 a_0123456789876543210 = Apply (Apply (Apply (Apply Lambda_0123456789876543210Sym0 a_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210 - sFoo8 :: - forall a b (t :: Foo a b). Sing t -> Sing (Apply Foo8Sym0 t :: a) - sFoo7 :: - forall a b (t :: a) (t :: b). - Sing t -> Sing t -> Sing (Apply (Apply Foo7Sym0 t) t :: b) - sFoo6 :: - forall a b (t :: a) (t :: b). - Sing t -> Sing t -> Sing (Apply (Apply Foo6Sym0 t) t :: a) - sFoo5 :: - forall a b (t :: a) (t :: b). - Sing t -> Sing t -> Sing (Apply (Apply Foo5Sym0 t) t :: b) - sFoo4 :: - forall a b c (t :: a) (t :: b) (t :: c). - Sing t - -> Sing t - -> Sing t -> Sing (Apply (Apply (Apply Foo4Sym0 t) t) t :: a) - sFoo3 :: forall a (t :: a). Sing t -> Sing (Apply Foo3Sym0 t :: a) - sFoo2 :: - forall a b (t :: a) (t :: b). - Sing t -> Sing t -> Sing (Apply (Apply Foo2Sym0 t) t :: a) - sFoo1 :: - forall a b (t :: a) (t :: b). - Sing t -> Sing t -> Sing (Apply (Apply Foo1Sym0 t) t :: a) - sFoo0 :: - forall a b (t :: a) (t :: b). - Sing t -> Sing t -> Sing (Apply (Apply Foo0Sym0 t) t :: a) - sFoo8 (sX :: Sing x) - = (applySing - ((singFun1 @(Apply Lambda_0123456789876543210Sym0 x)) - (\ sArg_0123456789876543210 - -> case sArg_0123456789876543210 of { - (_ :: Sing arg_0123456789876543210) - -> (id - @(Sing (Case_0123456789876543210 arg_0123456789876543210 x arg_0123456789876543210))) - (case sArg_0123456789876543210 of { - SFoo (sA :: Sing a) _ -> sA }) }))) - sX - sFoo7 (sX :: Sing x) (sY :: Sing y) - = (applySing - ((singFun1 @(Apply (Apply Lambda_0123456789876543210Sym0 x) y)) - (\ sArg_0123456789876543210 - -> case sArg_0123456789876543210 of { - (_ :: Sing arg_0123456789876543210) - -> (id - @(Sing (Case_0123456789876543210 arg_0123456789876543210 x y arg_0123456789876543210))) - (case sArg_0123456789876543210 of { - STuple2 _ (sB :: Sing b) -> sB }) }))) - ((applySing ((applySing ((singFun2 @Tuple2Sym0) STuple2)) sX)) sY) - sFoo6 (sA :: Sing a) (sB :: Sing b) - = (applySing - ((applySing - ((singFun1 @(Apply (Apply Lambda_0123456789876543210Sym0 a) b)) - (\ sX - -> case sX of { - (_ :: Sing x) - -> (singFun1 - @(Apply (Apply (Apply Lambda_0123456789876543210Sym0 x) a) b)) - (\ sArg_0123456789876543210 - -> case sArg_0123456789876543210 of { - (_ :: Sing arg_0123456789876543210) - -> (id - @(Sing (Case_0123456789876543210 arg_0123456789876543210 x a b arg_0123456789876543210))) - (case sArg_0123456789876543210 of { - _ -> sX }) }) }))) - sA)) - sB - sFoo5 (sX :: Sing x) (sY :: Sing y) - = (applySing - ((singFun1 @(Apply (Apply Lambda_0123456789876543210Sym0 x) y)) - (\ sX -> case sX of { (_ :: Sing x) -> sX }))) - sY - sFoo4 (sX :: Sing x) (sY :: Sing y) (sZ :: Sing z) - = (applySing - ((applySing - ((singFun2 - @(Apply (Apply (Apply Lambda_0123456789876543210Sym0 x) y) z)) - (\ sArg_0123456789876543210 sArg_0123456789876543210 - -> case - ((,) sArg_0123456789876543210) sArg_0123456789876543210 - of { - (,) (_ :: Sing arg_0123456789876543210) - (_ :: Sing arg_0123456789876543210) - -> (id - @(Sing (Case_0123456789876543210 arg_0123456789876543210 arg_0123456789876543210 x y z (Apply (Apply Tuple2Sym0 arg_0123456789876543210) arg_0123456789876543210)))) - (case - (applySing - ((applySing ((singFun2 @Tuple2Sym0) STuple2)) - sArg_0123456789876543210)) - sArg_0123456789876543210 - of { - STuple2 _ _ -> sX }) }))) - sY)) - sZ - sFoo3 (sX :: Sing x) - = (applySing - ((singFun1 @(Apply Lambda_0123456789876543210Sym0 x)) - (\ sY -> case sY of { (_ :: Sing y) -> sY }))) - sX - sFoo2 (sX :: Sing x) (sY :: Sing y) - = (applySing - ((singFun1 @(Apply (Apply Lambda_0123456789876543210Sym0 x) y)) - (\ sArg_0123456789876543210 - -> case sArg_0123456789876543210 of { - (_ :: Sing arg_0123456789876543210) - -> (id - @(Sing (Case_0123456789876543210 arg_0123456789876543210 x y arg_0123456789876543210))) - (case sArg_0123456789876543210 of { _ -> sX }) }))) - sY - sFoo1 - (sX :: Sing x) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((singFun1 - @(Apply (Apply Lambda_0123456789876543210Sym0 x) a_0123456789876543210)) - (\ sArg_0123456789876543210 - -> case sArg_0123456789876543210 of { - (_ :: Sing arg_0123456789876543210) - -> (id - @(Sing (Case_0123456789876543210 arg_0123456789876543210 x a_0123456789876543210 arg_0123456789876543210))) - (case sArg_0123456789876543210 of { _ -> sX }) }))) - sA_0123456789876543210 - sFoo0 - (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing - ((singFun2 - @(Apply (Apply Lambda_0123456789876543210Sym0 a_0123456789876543210) a_0123456789876543210)) - (\ sX sY - -> case ((,) sX) sY of { (,) (_ :: Sing x) (_ :: Sing y) -> sX }))) - sA_0123456789876543210)) - sA_0123456789876543210 - instance SingI (Foo8Sym0 :: (~>) (Foo a b) a) where - sing = (singFun1 @Foo8Sym0) sFoo8 - instance SingI (Foo7Sym0 :: (~>) a ((~>) b b)) where - sing = (singFun2 @Foo7Sym0) sFoo7 - instance SingI d => SingI (Foo7Sym1 (d :: a) :: (~>) b b) where - sing = (singFun1 @(Foo7Sym1 (d :: a))) (sFoo7 (sing @d)) - instance SingI (Foo6Sym0 :: (~>) a ((~>) b a)) where - sing = (singFun2 @Foo6Sym0) sFoo6 - instance SingI d => SingI (Foo6Sym1 (d :: a) :: (~>) b a) where - sing = (singFun1 @(Foo6Sym1 (d :: a))) (sFoo6 (sing @d)) - instance SingI (Foo5Sym0 :: (~>) a ((~>) b b)) where - sing = (singFun2 @Foo5Sym0) sFoo5 - instance SingI d => SingI (Foo5Sym1 (d :: a) :: (~>) b b) where - sing = (singFun1 @(Foo5Sym1 (d :: a))) (sFoo5 (sing @d)) - instance SingI (Foo4Sym0 :: (~>) a ((~>) b ((~>) c a))) where - sing = (singFun3 @Foo4Sym0) sFoo4 - instance SingI d => - SingI (Foo4Sym1 (d :: a) :: (~>) b ((~>) c a)) where - sing = (singFun2 @(Foo4Sym1 (d :: a))) (sFoo4 (sing @d)) - instance (SingI d, SingI d) => - SingI (Foo4Sym2 (d :: a) (d :: b) :: (~>) c a) where - sing - = (singFun1 @(Foo4Sym2 (d :: a) (d :: b))) - ((sFoo4 (sing @d)) (sing @d)) - instance SingI (Foo3Sym0 :: (~>) a a) where - sing = (singFun1 @Foo3Sym0) sFoo3 - instance SingI (Foo2Sym0 :: (~>) a ((~>) b a)) where - sing = (singFun2 @Foo2Sym0) sFoo2 - instance SingI d => SingI (Foo2Sym1 (d :: a) :: (~>) b a) where - sing = (singFun1 @(Foo2Sym1 (d :: a))) (sFoo2 (sing @d)) - instance SingI (Foo1Sym0 :: (~>) a ((~>) b a)) where - sing = (singFun2 @Foo1Sym0) sFoo1 - instance SingI d => SingI (Foo1Sym1 (d :: a) :: (~>) b a) where - sing = (singFun1 @(Foo1Sym1 (d :: a))) (sFoo1 (sing @d)) - instance SingI (Foo0Sym0 :: (~>) a ((~>) b a)) where - sing = (singFun2 @Foo0Sym0) sFoo0 - instance SingI d => SingI (Foo0Sym1 (d :: a) :: (~>) b a) where - sing = (singFun1 @(Foo0Sym1 (d :: a))) (sFoo0 (sing @d)) - data SFoo :: forall a b. Foo a b -> GHC.Types.Type - where - SFoo :: forall a b (n :: a) (n :: b). - (Sing (n :: a)) -> (Sing (n :: b)) -> SFoo (Foo n n) - type instance Sing @(Foo a b) = SFoo - instance (SingKind a, SingKind b) => SingKind (Foo a b) where - type Demote (Foo a b) = Foo (Demote a) (Demote b) - fromSing (SFoo b b) = (Foo (fromSing b)) (fromSing b) - toSing (Foo (b :: Demote a) (b :: Demote b)) - = case ((,) (toSing b :: SomeSing a)) (toSing b :: SomeSing b) of { - (,) (SomeSing c) (SomeSing c) -> SomeSing ((SFoo c) c) } - instance (SingI n, SingI n) => SingI (Foo (n :: a) (n :: b)) where - sing = (SFoo sing) sing - instance SingI (FooSym0 :: (~>) a ((~>) b (Foo a b))) where - sing = (singFun2 @FooSym0) SFoo - instance SingI d => - SingI (FooSym1 (d :: a) :: (~>) b (Foo a b)) where - sing = (singFun1 @(FooSym1 (d :: a))) (SFoo (sing @d)) diff --git a/tests/compile-and-dump/Singletons/Lambdas.hs b/tests/compile-and-dump/Singletons/Lambdas.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Lambdas.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# OPTIONS_GHC -Wno-unused-matches -Wno-name-shadowing #-} - -{-# 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.ghc88.template b/tests/compile-and-dump/Singletons/LambdasComprehensive.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/LambdasComprehensive.ghc88.template +++ /dev/null @@ -1,71 +0,0 @@ -Singletons/LambdasComprehensive.hs:(0,0)-(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)] |] - ======> - 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_0123456789876543210 t where - Lambda_0123456789876543210 x = Apply (Apply (Apply Either_Sym0 PredSym0) SuccSym0) x - type Lambda_0123456789876543210Sym1 t0123456789876543210 = - Lambda_0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 t0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 t0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 t0123456789876543210 = Lambda_0123456789876543210 t0123456789876543210 - type BarSym0 = Bar - type FooSym0 = Foo - type family Bar :: [Nat] where - Bar = Apply (Apply MapSym0 (Apply (Apply Either_Sym0 PredSym0) SuccSym0)) (Apply (Apply (:@#@$) (Apply LeftSym0 ZeroSym0)) (Apply (Apply (:@#@$) (Apply RightSym0 (Apply SuccSym0 ZeroSym0))) '[])) - type family Foo :: [Nat] where - Foo = Apply (Apply MapSym0 Lambda_0123456789876543210Sym0) (Apply (Apply (:@#@$) (Apply LeftSym0 ZeroSym0)) (Apply (Apply (:@#@$) (Apply RightSym0 (Apply SuccSym0 ZeroSym0))) '[])) - sBar :: Sing (BarSym0 :: [Nat]) - sFoo :: Sing (FooSym0 :: [Nat]) - sBar - = (applySing - ((applySing ((singFun2 @MapSym0) sMap)) - ((applySing - ((applySing ((singFun3 @Either_Sym0) sEither_)) - ((singFun1 @PredSym0) sPred))) - ((singFun1 @SuccSym0) SSucc)))) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing ((singFun1 @LeftSym0) SLeft)) SZero))) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing ((singFun1 @RightSym0) SRight)) - ((applySing ((singFun1 @SuccSym0) SSucc)) SZero)))) - SNil)) - sFoo - = (applySing - ((applySing ((singFun2 @MapSym0) sMap)) - ((singFun1 @Lambda_0123456789876543210Sym0) - (\ sX - -> case sX of { - (_ :: Sing x) - -> (applySing - ((applySing - ((applySing ((singFun3 @Either_Sym0) sEither_)) - ((singFun1 @PredSym0) sPred))) - ((singFun1 @SuccSym0) SSucc))) - sX })))) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing ((singFun1 @LeftSym0) SLeft)) SZero))) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing ((singFun1 @RightSym0) SRight)) - ((applySing ((singFun1 @SuccSym0) SSucc)) SZero)))) - SNil)) diff --git a/tests/compile-and-dump/Singletons/LambdasComprehensive.hs b/tests/compile-and-dump/Singletons/LambdasComprehensive.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/LambdasComprehensive.hs +++ /dev/null @@ -1,29 +0,0 @@ -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.ghc88.template b/tests/compile-and-dump/Singletons/LetStatements.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/LetStatements.ghc88.template +++ /dev/null @@ -1,1004 +0,0 @@ -Singletons/LetStatements.hs:(0,0)-(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) |] - ======> - 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_ :: a -> a - foo13_ y = y - foo14 :: Nat -> (Nat, Nat) - foo14 x = let (y, z) = (Succ x, x) in (z, y) - type family Case_0123456789876543210 x t where - Case_0123456789876543210 x '(_, - y_0123456789876543210) = y_0123456789876543210 - type family Case_0123456789876543210 x t where - Case_0123456789876543210 x '(y_0123456789876543210, - _) = y_0123456789876543210 - type Let0123456789876543210ZSym1 x0123456789876543210 = - Let0123456789876543210Z x0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210ZSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210ZSym0KindInference) ()) - data Let0123456789876543210ZSym0 x0123456789876543210 - where - Let0123456789876543210ZSym0KindInference :: forall x0123456789876543210 - arg. SameKind (Apply Let0123456789876543210ZSym0 arg) (Let0123456789876543210ZSym1 arg) => - Let0123456789876543210ZSym0 x0123456789876543210 - type instance Apply Let0123456789876543210ZSym0 x0123456789876543210 = Let0123456789876543210Z x0123456789876543210 - type Let0123456789876543210YSym1 x0123456789876543210 = - Let0123456789876543210Y x0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210YSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210YSym0KindInference) ()) - data Let0123456789876543210YSym0 x0123456789876543210 - where - Let0123456789876543210YSym0KindInference :: forall x0123456789876543210 - arg. SameKind (Apply Let0123456789876543210YSym0 arg) (Let0123456789876543210YSym1 arg) => - Let0123456789876543210YSym0 x0123456789876543210 - type instance Apply Let0123456789876543210YSym0 x0123456789876543210 = Let0123456789876543210Y x0123456789876543210 - type Let0123456789876543210X_0123456789876543210Sym1 x0123456789876543210 = - Let0123456789876543210X_0123456789876543210 x0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210X_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd - (((,) Let0123456789876543210X_0123456789876543210Sym0KindInference) - ()) - data Let0123456789876543210X_0123456789876543210Sym0 x0123456789876543210 - where - Let0123456789876543210X_0123456789876543210Sym0KindInference :: forall x0123456789876543210 - arg. SameKind (Apply Let0123456789876543210X_0123456789876543210Sym0 arg) (Let0123456789876543210X_0123456789876543210Sym1 arg) => - Let0123456789876543210X_0123456789876543210Sym0 x0123456789876543210 - type instance Apply Let0123456789876543210X_0123456789876543210Sym0 x0123456789876543210 = Let0123456789876543210X_0123456789876543210 x0123456789876543210 - type family Let0123456789876543210Z x where - Let0123456789876543210Z x = Case_0123456789876543210 x (Let0123456789876543210X_0123456789876543210Sym1 x) - type family Let0123456789876543210Y x where - Let0123456789876543210Y x = Case_0123456789876543210 x (Let0123456789876543210X_0123456789876543210Sym1 x) - type family Let0123456789876543210X_0123456789876543210 x where - Let0123456789876543210X_0123456789876543210 x = Apply (Apply Tuple2Sym0 (Apply SuccSym0 x)) x - type Let0123456789876543210BarSym1 x0123456789876543210 = - Let0123456789876543210Bar x0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210BarSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210BarSym0KindInference) ()) - data Let0123456789876543210BarSym0 x0123456789876543210 - where - Let0123456789876543210BarSym0KindInference :: forall x0123456789876543210 - arg. SameKind (Apply Let0123456789876543210BarSym0 arg) (Let0123456789876543210BarSym1 arg) => - Let0123456789876543210BarSym0 x0123456789876543210 - type instance Apply Let0123456789876543210BarSym0 x0123456789876543210 = Let0123456789876543210Bar x0123456789876543210 - type family Let0123456789876543210Bar x :: a where - Let0123456789876543210Bar x = x - type (<<<%%%%%%%%%%%%%%%%%%%%@#@$$$$) x0123456789876543210 (a0123456789876543210 :: Nat) (a0123456789876543210 :: Nat) = - (<<<%%%%%%%%%%%%%%%%%%%%) x0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) a0123456789876543210 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) (:<<<%%%%%%%%%%%%%%%%%%%%@#@$$$###)) ()) - data (<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 (a0123456789876543210 :: Nat) :: (~>) Nat Nat - where - (:<<<%%%%%%%%%%%%%%%%%%%%@#@$$$###) :: forall x0123456789876543210 - a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 a0123456789876543210) arg) ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$$$) x0123456789876543210 a0123456789876543210 arg) => - (<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) a0123456789876543210 x0123456789876543210) a0123456789876543210 = (<<<%%%%%%%%%%%%%%%%%%%%) a0123456789876543210 x0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) (:<<<%%%%%%%%%%%%%%%%%%%%@#@$$###)) ()) - data (<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210 :: (~>) Nat ((~>) Nat Nat) - where - (:<<<%%%%%%%%%%%%%%%%%%%%@#@$$###) :: forall x0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210) arg) ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 arg) => - (<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210 a0123456789876543210 - type instance Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210) a0123456789876543210 = (<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (<<<%%%%%%%%%%%%%%%%%%%%@#@$) where - suppressUnusedWarnings - = snd (((,) (:<<<%%%%%%%%%%%%%%%%%%%%@#@$###)) ()) - data (<<<%%%%%%%%%%%%%%%%%%%%@#@$) x0123456789876543210 - where - (:<<<%%%%%%%%%%%%%%%%%%%%@#@$###) :: forall x0123456789876543210 - arg. SameKind (Apply (<<<%%%%%%%%%%%%%%%%%%%%@#@$) arg) ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) arg) => - (<<<%%%%%%%%%%%%%%%%%%%%@#@$) x0123456789876543210 - type instance Apply (<<<%%%%%%%%%%%%%%%%%%%%@#@$) x0123456789876543210 = (<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210 - type family (<<<%%%%%%%%%%%%%%%%%%%%) x (a :: Nat) (a :: Nat) :: Nat where - (<<<%%%%%%%%%%%%%%%%%%%%) x 'Zero m = m - (<<<%%%%%%%%%%%%%%%%%%%%) x ('Succ n) m = Apply SuccSym0 (Apply (Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x) n) x) - type Let0123456789876543210ZSym1 x0123456789876543210 = - Let0123456789876543210Z x0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210ZSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210ZSym0KindInference) ()) - data Let0123456789876543210ZSym0 x0123456789876543210 - where - Let0123456789876543210ZSym0KindInference :: forall x0123456789876543210 - arg. SameKind (Apply Let0123456789876543210ZSym0 arg) (Let0123456789876543210ZSym1 arg) => - Let0123456789876543210ZSym0 x0123456789876543210 - type instance Apply Let0123456789876543210ZSym0 x0123456789876543210 = Let0123456789876543210Z x0123456789876543210 - type (<<<%%%%%%%%%%%%%%%%%%%%@#@$$$$) x0123456789876543210 (a0123456789876543210 :: Nat) (a0123456789876543210 :: Nat) = - (<<<%%%%%%%%%%%%%%%%%%%%) x0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) a0123456789876543210 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) (:<<<%%%%%%%%%%%%%%%%%%%%@#@$$$###)) ()) - data (<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 (a0123456789876543210 :: Nat) :: (~>) Nat Nat - where - (:<<<%%%%%%%%%%%%%%%%%%%%@#@$$$###) :: forall x0123456789876543210 - a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 a0123456789876543210) arg) ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$$$) x0123456789876543210 a0123456789876543210 arg) => - (<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) a0123456789876543210 x0123456789876543210) a0123456789876543210 = (<<<%%%%%%%%%%%%%%%%%%%%) a0123456789876543210 x0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) (:<<<%%%%%%%%%%%%%%%%%%%%@#@$$###)) ()) - data (<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210 :: (~>) Nat ((~>) Nat Nat) - where - (:<<<%%%%%%%%%%%%%%%%%%%%@#@$$###) :: forall x0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210) arg) ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 arg) => - (<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210 a0123456789876543210 - type instance Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210) a0123456789876543210 = (<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (<<<%%%%%%%%%%%%%%%%%%%%@#@$) where - suppressUnusedWarnings - = snd (((,) (:<<<%%%%%%%%%%%%%%%%%%%%@#@$###)) ()) - data (<<<%%%%%%%%%%%%%%%%%%%%@#@$) x0123456789876543210 - where - (:<<<%%%%%%%%%%%%%%%%%%%%@#@$###) :: forall x0123456789876543210 - arg. SameKind (Apply (<<<%%%%%%%%%%%%%%%%%%%%@#@$) arg) ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) arg) => - (<<<%%%%%%%%%%%%%%%%%%%%@#@$) x0123456789876543210 - type instance Apply (<<<%%%%%%%%%%%%%%%%%%%%@#@$) x0123456789876543210 = (<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210 - type family Let0123456789876543210Z x :: Nat where - Let0123456789876543210Z x = x - type family (<<<%%%%%%%%%%%%%%%%%%%%) x (a :: Nat) (a :: Nat) :: Nat where - (<<<%%%%%%%%%%%%%%%%%%%%) x 'Zero m = m - (<<<%%%%%%%%%%%%%%%%%%%%) x ('Succ n) m = Apply SuccSym0 (Apply (Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x) n) m) - type (<<<%%%%%%%%%%%%%%%%%%%%@#@$$$$) x0123456789876543210 (a0123456789876543210 :: Nat) (a0123456789876543210 :: Nat) = - (<<<%%%%%%%%%%%%%%%%%%%%) x0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) a0123456789876543210 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) (:<<<%%%%%%%%%%%%%%%%%%%%@#@$$$###)) ()) - data (<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 (a0123456789876543210 :: Nat) :: (~>) Nat Nat - where - (:<<<%%%%%%%%%%%%%%%%%%%%@#@$$$###) :: forall x0123456789876543210 - a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 a0123456789876543210) arg) ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$$$) x0123456789876543210 a0123456789876543210 arg) => - (<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) a0123456789876543210 x0123456789876543210) a0123456789876543210 = (<<<%%%%%%%%%%%%%%%%%%%%) a0123456789876543210 x0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) (:<<<%%%%%%%%%%%%%%%%%%%%@#@$$###)) ()) - data (<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210 :: (~>) Nat ((~>) Nat Nat) - where - (:<<<%%%%%%%%%%%%%%%%%%%%@#@$$###) :: forall x0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210) arg) ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 arg) => - (<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210 a0123456789876543210 - type instance Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210) a0123456789876543210 = (<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (<<<%%%%%%%%%%%%%%%%%%%%@#@$) where - suppressUnusedWarnings - = snd (((,) (:<<<%%%%%%%%%%%%%%%%%%%%@#@$###)) ()) - data (<<<%%%%%%%%%%%%%%%%%%%%@#@$) x0123456789876543210 - where - (:<<<%%%%%%%%%%%%%%%%%%%%@#@$###) :: forall x0123456789876543210 - arg. SameKind (Apply (<<<%%%%%%%%%%%%%%%%%%%%@#@$) arg) ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) arg) => - (<<<%%%%%%%%%%%%%%%%%%%%@#@$) x0123456789876543210 - type instance Apply (<<<%%%%%%%%%%%%%%%%%%%%@#@$) x0123456789876543210 = (<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210 - type family (<<<%%%%%%%%%%%%%%%%%%%%) x (a :: Nat) (a :: Nat) :: Nat where - (<<<%%%%%%%%%%%%%%%%%%%%) x 'Zero m = m - (<<<%%%%%%%%%%%%%%%%%%%%) x ('Succ n) m = Apply SuccSym0 (Apply (Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x) n) m) - type family Lambda_0123456789876543210 a_0123456789876543210 x t where - Lambda_0123456789876543210 a_0123456789876543210 x x = x - type Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 x0123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 a_01234567898765432100123456789876543210 x0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 x0123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 x0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall a_01234567898765432100123456789876543210 - x0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 x0123456789876543210) arg) (Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 x0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 x0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 x0123456789876543210 a_01234567898765432100123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 x0123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210 x0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall a_01234567898765432100123456789876543210 - x0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210 x0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210) x0123456789876543210 = Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 x0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall a_01234567898765432100123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 a_01234567898765432100123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210 - type Let0123456789876543210ZSym2 x0123456789876543210 (a0123456789876543210 :: Nat) = - Let0123456789876543210Z x0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210ZSym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210ZSym1KindInference) ()) - data Let0123456789876543210ZSym1 x0123456789876543210 :: (~>) Nat Nat - where - Let0123456789876543210ZSym1KindInference :: forall x0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Let0123456789876543210ZSym1 x0123456789876543210) arg) (Let0123456789876543210ZSym2 x0123456789876543210 arg) => - Let0123456789876543210ZSym1 x0123456789876543210 a0123456789876543210 - type instance Apply (Let0123456789876543210ZSym1 x0123456789876543210) a0123456789876543210 = Let0123456789876543210Z x0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210ZSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210ZSym0KindInference) ()) - data Let0123456789876543210ZSym0 x0123456789876543210 - where - Let0123456789876543210ZSym0KindInference :: forall x0123456789876543210 - arg. SameKind (Apply Let0123456789876543210ZSym0 arg) (Let0123456789876543210ZSym1 arg) => - Let0123456789876543210ZSym0 x0123456789876543210 - type instance Apply Let0123456789876543210ZSym0 x0123456789876543210 = Let0123456789876543210ZSym1 x0123456789876543210 - type family Let0123456789876543210Z x (a :: Nat) :: Nat where - Let0123456789876543210Z x a_0123456789876543210 = Apply (Apply (Apply Lambda_0123456789876543210Sym0 a_0123456789876543210) x) a_0123456789876543210 - type family Lambda_0123456789876543210 x t where - Lambda_0123456789876543210 x x = x - type Lambda_0123456789876543210Sym2 x0123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 x0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 x0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall x0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 x0123456789876543210) arg) (Lambda_0123456789876543210Sym2 x0123456789876543210 arg) => - Lambda_0123456789876543210Sym1 x0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 x0123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 x0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 x0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall x0123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 x0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 x0123456789876543210 = Lambda_0123456789876543210Sym1 x0123456789876543210 - type Let0123456789876543210ZSym1 x0123456789876543210 = - Let0123456789876543210Z x0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210ZSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210ZSym0KindInference) ()) - data Let0123456789876543210ZSym0 x0123456789876543210 - where - Let0123456789876543210ZSym0KindInference :: forall x0123456789876543210 - arg. SameKind (Apply Let0123456789876543210ZSym0 arg) (Let0123456789876543210ZSym1 arg) => - Let0123456789876543210ZSym0 x0123456789876543210 - type instance Apply Let0123456789876543210ZSym0 x0123456789876543210 = Let0123456789876543210Z x0123456789876543210 - type family Let0123456789876543210Z x :: Nat where - Let0123456789876543210Z x = Apply (Apply Lambda_0123456789876543210Sym0 x) ZeroSym0 - type Let0123456789876543210XSym1 x0123456789876543210 = - Let0123456789876543210X x0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210XSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210XSym0KindInference) ()) - data Let0123456789876543210XSym0 x0123456789876543210 - where - Let0123456789876543210XSym0KindInference :: forall x0123456789876543210 - arg. SameKind (Apply Let0123456789876543210XSym0 arg) (Let0123456789876543210XSym1 arg) => - Let0123456789876543210XSym0 x0123456789876543210 - type instance Apply Let0123456789876543210XSym0 x0123456789876543210 = Let0123456789876543210X x0123456789876543210 - type family Let0123456789876543210X x :: Nat where - Let0123456789876543210X x = ZeroSym0 - type Let0123456789876543210FSym2 x0123456789876543210 (a0123456789876543210 :: Nat) = - Let0123456789876543210F x0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210FSym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210FSym1KindInference) ()) - data Let0123456789876543210FSym1 x0123456789876543210 :: (~>) Nat Nat - where - Let0123456789876543210FSym1KindInference :: forall x0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Let0123456789876543210FSym1 x0123456789876543210) arg) (Let0123456789876543210FSym2 x0123456789876543210 arg) => - Let0123456789876543210FSym1 x0123456789876543210 a0123456789876543210 - type instance Apply (Let0123456789876543210FSym1 x0123456789876543210) a0123456789876543210 = Let0123456789876543210F x0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210FSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210FSym0KindInference) ()) - data Let0123456789876543210FSym0 x0123456789876543210 - where - Let0123456789876543210FSym0KindInference :: forall x0123456789876543210 - arg. SameKind (Apply Let0123456789876543210FSym0 arg) (Let0123456789876543210FSym1 arg) => - Let0123456789876543210FSym0 x0123456789876543210 - type instance Apply Let0123456789876543210FSym0 x0123456789876543210 = Let0123456789876543210FSym1 x0123456789876543210 - type family Let0123456789876543210F x (a :: Nat) :: Nat where - Let0123456789876543210F x y = Apply SuccSym0 y - type Let0123456789876543210ZSym1 x0123456789876543210 = - Let0123456789876543210Z x0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210ZSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210ZSym0KindInference) ()) - data Let0123456789876543210ZSym0 x0123456789876543210 - where - Let0123456789876543210ZSym0KindInference :: forall x0123456789876543210 - arg. SameKind (Apply Let0123456789876543210ZSym0 arg) (Let0123456789876543210ZSym1 arg) => - Let0123456789876543210ZSym0 x0123456789876543210 - type instance Apply Let0123456789876543210ZSym0 x0123456789876543210 = Let0123456789876543210Z x0123456789876543210 - type family Let0123456789876543210Z x :: Nat where - Let0123456789876543210Z x = Apply (Let0123456789876543210FSym1 x) x - type Let0123456789876543210ZSym2 y0123456789876543210 x0123456789876543210 = - Let0123456789876543210Z y0123456789876543210 x0123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210ZSym1 y0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210ZSym1KindInference) ()) - data Let0123456789876543210ZSym1 y0123456789876543210 x0123456789876543210 - where - Let0123456789876543210ZSym1KindInference :: forall y0123456789876543210 - x0123456789876543210 - arg. SameKind (Apply (Let0123456789876543210ZSym1 y0123456789876543210) arg) (Let0123456789876543210ZSym2 y0123456789876543210 arg) => - Let0123456789876543210ZSym1 y0123456789876543210 x0123456789876543210 - type instance Apply (Let0123456789876543210ZSym1 y0123456789876543210) x0123456789876543210 = Let0123456789876543210Z y0123456789876543210 x0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210ZSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210ZSym0KindInference) ()) - data Let0123456789876543210ZSym0 y0123456789876543210 - where - Let0123456789876543210ZSym0KindInference :: forall y0123456789876543210 - arg. SameKind (Apply Let0123456789876543210ZSym0 arg) (Let0123456789876543210ZSym1 arg) => - Let0123456789876543210ZSym0 y0123456789876543210 - type instance Apply Let0123456789876543210ZSym0 y0123456789876543210 = Let0123456789876543210ZSym1 y0123456789876543210 - type family Let0123456789876543210Z y x :: Nat where - Let0123456789876543210Z y x = Apply SuccSym0 y - type Let0123456789876543210FSym2 x0123456789876543210 (a0123456789876543210 :: Nat) = - Let0123456789876543210F x0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210FSym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210FSym1KindInference) ()) - data Let0123456789876543210FSym1 x0123456789876543210 :: (~>) Nat Nat - where - Let0123456789876543210FSym1KindInference :: forall x0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Let0123456789876543210FSym1 x0123456789876543210) arg) (Let0123456789876543210FSym2 x0123456789876543210 arg) => - Let0123456789876543210FSym1 x0123456789876543210 a0123456789876543210 - type instance Apply (Let0123456789876543210FSym1 x0123456789876543210) a0123456789876543210 = Let0123456789876543210F x0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210FSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210FSym0KindInference) ()) - data Let0123456789876543210FSym0 x0123456789876543210 - where - Let0123456789876543210FSym0KindInference :: forall x0123456789876543210 - arg. SameKind (Apply Let0123456789876543210FSym0 arg) (Let0123456789876543210FSym1 arg) => - Let0123456789876543210FSym0 x0123456789876543210 - type instance Apply Let0123456789876543210FSym0 x0123456789876543210 = Let0123456789876543210FSym1 x0123456789876543210 - type family Let0123456789876543210F x (a :: Nat) :: Nat where - Let0123456789876543210F x y = Apply SuccSym0 (Let0123456789876543210ZSym2 y x) - type Let0123456789876543210FSym2 x0123456789876543210 (a0123456789876543210 :: Nat) = - Let0123456789876543210F x0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210FSym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210FSym1KindInference) ()) - data Let0123456789876543210FSym1 x0123456789876543210 :: (~>) Nat Nat - where - Let0123456789876543210FSym1KindInference :: forall x0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Let0123456789876543210FSym1 x0123456789876543210) arg) (Let0123456789876543210FSym2 x0123456789876543210 arg) => - Let0123456789876543210FSym1 x0123456789876543210 a0123456789876543210 - type instance Apply (Let0123456789876543210FSym1 x0123456789876543210) a0123456789876543210 = Let0123456789876543210F x0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210FSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210FSym0KindInference) ()) - data Let0123456789876543210FSym0 x0123456789876543210 - where - Let0123456789876543210FSym0KindInference :: forall x0123456789876543210 - arg. SameKind (Apply Let0123456789876543210FSym0 arg) (Let0123456789876543210FSym1 arg) => - Let0123456789876543210FSym0 x0123456789876543210 - type instance Apply Let0123456789876543210FSym0 x0123456789876543210 = Let0123456789876543210FSym1 x0123456789876543210 - type family Let0123456789876543210F x (a :: Nat) :: Nat where - Let0123456789876543210F x y = Apply SuccSym0 y - type Let0123456789876543210YSym1 x0123456789876543210 = - Let0123456789876543210Y x0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210YSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210YSym0KindInference) ()) - data Let0123456789876543210YSym0 x0123456789876543210 - where - Let0123456789876543210YSym0KindInference :: forall x0123456789876543210 - arg. SameKind (Apply Let0123456789876543210YSym0 arg) (Let0123456789876543210YSym1 arg) => - Let0123456789876543210YSym0 x0123456789876543210 - type instance Apply Let0123456789876543210YSym0 x0123456789876543210 = Let0123456789876543210Y x0123456789876543210 - type family Let0123456789876543210Y x :: Nat where - Let0123456789876543210Y x = Apply SuccSym0 x - type Let0123456789876543210ZSym0 = Let0123456789876543210Z - type Let0123456789876543210YSym0 = Let0123456789876543210Y - type family Let0123456789876543210Z where - Let0123456789876543210Z = Apply SuccSym0 Let0123456789876543210YSym0 - type family Let0123456789876543210Y where - Let0123456789876543210Y = Apply SuccSym0 ZeroSym0 - type Let0123456789876543210YSym1 x0123456789876543210 = - Let0123456789876543210Y x0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210YSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210YSym0KindInference) ()) - data Let0123456789876543210YSym0 x0123456789876543210 - where - Let0123456789876543210YSym0KindInference :: forall x0123456789876543210 - arg. SameKind (Apply Let0123456789876543210YSym0 arg) (Let0123456789876543210YSym1 arg) => - Let0123456789876543210YSym0 x0123456789876543210 - type instance Apply Let0123456789876543210YSym0 x0123456789876543210 = Let0123456789876543210Y x0123456789876543210 - type family Let0123456789876543210Y x :: Nat where - Let0123456789876543210Y x = Apply SuccSym0 ZeroSym0 - type Foo14Sym1 (a0123456789876543210 :: Nat) = - Foo14 a0123456789876543210 - instance SuppressUnusedWarnings Foo14Sym0 where - suppressUnusedWarnings = snd (((,) Foo14Sym0KindInference) ()) - data Foo14Sym0 :: (~>) Nat (Nat, Nat) - where - Foo14Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo14Sym0 arg) (Foo14Sym1 arg) => - Foo14Sym0 a0123456789876543210 - type instance Apply Foo14Sym0 a0123456789876543210 = Foo14 a0123456789876543210 - type Foo13_Sym1 (a0123456789876543210 :: a0123456789876543210) = - Foo13_ a0123456789876543210 - instance SuppressUnusedWarnings Foo13_Sym0 where - suppressUnusedWarnings = snd (((,) Foo13_Sym0KindInference) ()) - data Foo13_Sym0 :: forall a0123456789876543210. - (~>) a0123456789876543210 a0123456789876543210 - where - Foo13_Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo13_Sym0 arg) (Foo13_Sym1 arg) => - Foo13_Sym0 a0123456789876543210 - type instance Apply Foo13_Sym0 a0123456789876543210 = Foo13_ a0123456789876543210 - type Foo13Sym1 (a0123456789876543210 :: a0123456789876543210) = - Foo13 a0123456789876543210 - instance SuppressUnusedWarnings Foo13Sym0 where - suppressUnusedWarnings = snd (((,) Foo13Sym0KindInference) ()) - data Foo13Sym0 :: forall a0123456789876543210. - (~>) a0123456789876543210 a0123456789876543210 - where - Foo13Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo13Sym0 arg) (Foo13Sym1 arg) => - Foo13Sym0 a0123456789876543210 - type instance Apply Foo13Sym0 a0123456789876543210 = Foo13 a0123456789876543210 - type Foo12Sym1 (a0123456789876543210 :: Nat) = - Foo12 a0123456789876543210 - instance SuppressUnusedWarnings Foo12Sym0 where - suppressUnusedWarnings = snd (((,) Foo12Sym0KindInference) ()) - data Foo12Sym0 :: (~>) Nat Nat - where - Foo12Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo12Sym0 arg) (Foo12Sym1 arg) => - Foo12Sym0 a0123456789876543210 - type instance Apply Foo12Sym0 a0123456789876543210 = Foo12 a0123456789876543210 - type Foo11Sym1 (a0123456789876543210 :: Nat) = - Foo11 a0123456789876543210 - instance SuppressUnusedWarnings Foo11Sym0 where - suppressUnusedWarnings = snd (((,) Foo11Sym0KindInference) ()) - data Foo11Sym0 :: (~>) Nat Nat - where - Foo11Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo11Sym0 arg) (Foo11Sym1 arg) => - Foo11Sym0 a0123456789876543210 - type instance Apply Foo11Sym0 a0123456789876543210 = Foo11 a0123456789876543210 - type Foo10Sym1 (a0123456789876543210 :: Nat) = - Foo10 a0123456789876543210 - instance SuppressUnusedWarnings Foo10Sym0 where - suppressUnusedWarnings = snd (((,) Foo10Sym0KindInference) ()) - data Foo10Sym0 :: (~>) Nat Nat - where - Foo10Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo10Sym0 arg) (Foo10Sym1 arg) => - Foo10Sym0 a0123456789876543210 - type instance Apply Foo10Sym0 a0123456789876543210 = Foo10 a0123456789876543210 - type Foo9Sym1 (a0123456789876543210 :: Nat) = - Foo9 a0123456789876543210 - instance SuppressUnusedWarnings Foo9Sym0 where - suppressUnusedWarnings = snd (((,) Foo9Sym0KindInference) ()) - data Foo9Sym0 :: (~>) Nat Nat - where - Foo9Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo9Sym0 arg) (Foo9Sym1 arg) => - Foo9Sym0 a0123456789876543210 - type instance Apply Foo9Sym0 a0123456789876543210 = Foo9 a0123456789876543210 - type Foo8Sym1 (a0123456789876543210 :: Nat) = - Foo8 a0123456789876543210 - instance SuppressUnusedWarnings Foo8Sym0 where - suppressUnusedWarnings = snd (((,) Foo8Sym0KindInference) ()) - data Foo8Sym0 :: (~>) Nat Nat - where - Foo8Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo8Sym0 arg) (Foo8Sym1 arg) => - Foo8Sym0 a0123456789876543210 - type instance Apply Foo8Sym0 a0123456789876543210 = Foo8 a0123456789876543210 - type Foo7Sym1 (a0123456789876543210 :: Nat) = - Foo7 a0123456789876543210 - instance SuppressUnusedWarnings Foo7Sym0 where - suppressUnusedWarnings = snd (((,) Foo7Sym0KindInference) ()) - data Foo7Sym0 :: (~>) Nat Nat - where - Foo7Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo7Sym0 arg) (Foo7Sym1 arg) => - Foo7Sym0 a0123456789876543210 - type instance Apply Foo7Sym0 a0123456789876543210 = Foo7 a0123456789876543210 - type Foo6Sym1 (a0123456789876543210 :: Nat) = - Foo6 a0123456789876543210 - instance SuppressUnusedWarnings Foo6Sym0 where - suppressUnusedWarnings = snd (((,) Foo6Sym0KindInference) ()) - data Foo6Sym0 :: (~>) Nat Nat - where - Foo6Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo6Sym0 arg) (Foo6Sym1 arg) => - Foo6Sym0 a0123456789876543210 - type instance Apply Foo6Sym0 a0123456789876543210 = Foo6 a0123456789876543210 - type Foo5Sym1 (a0123456789876543210 :: Nat) = - Foo5 a0123456789876543210 - instance SuppressUnusedWarnings Foo5Sym0 where - suppressUnusedWarnings = snd (((,) Foo5Sym0KindInference) ()) - data Foo5Sym0 :: (~>) Nat Nat - where - Foo5Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo5Sym0 arg) (Foo5Sym1 arg) => - Foo5Sym0 a0123456789876543210 - type instance Apply Foo5Sym0 a0123456789876543210 = Foo5 a0123456789876543210 - type Foo4Sym1 (a0123456789876543210 :: Nat) = - Foo4 a0123456789876543210 - instance SuppressUnusedWarnings Foo4Sym0 where - suppressUnusedWarnings = snd (((,) Foo4Sym0KindInference) ()) - data Foo4Sym0 :: (~>) Nat Nat - where - Foo4Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo4Sym0 arg) (Foo4Sym1 arg) => - Foo4Sym0 a0123456789876543210 - type instance Apply Foo4Sym0 a0123456789876543210 = Foo4 a0123456789876543210 - type Foo3Sym1 (a0123456789876543210 :: Nat) = - Foo3 a0123456789876543210 - instance SuppressUnusedWarnings Foo3Sym0 where - suppressUnusedWarnings = snd (((,) Foo3Sym0KindInference) ()) - data Foo3Sym0 :: (~>) Nat Nat - where - Foo3Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo3Sym0 arg) (Foo3Sym1 arg) => - Foo3Sym0 a0123456789876543210 - type instance Apply Foo3Sym0 a0123456789876543210 = Foo3 a0123456789876543210 - type Foo2Sym0 = Foo2 - type Foo1Sym1 (a0123456789876543210 :: Nat) = - Foo1 a0123456789876543210 - instance SuppressUnusedWarnings Foo1Sym0 where - suppressUnusedWarnings = snd (((,) Foo1Sym0KindInference) ()) - data Foo1Sym0 :: (~>) Nat Nat - where - Foo1Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo1Sym0 arg) (Foo1Sym1 arg) => - Foo1Sym0 a0123456789876543210 - type instance Apply Foo1Sym0 a0123456789876543210 = Foo1 a0123456789876543210 - type family Foo14 (a :: Nat) :: (Nat, Nat) where - Foo14 x = Apply (Apply Tuple2Sym0 (Let0123456789876543210ZSym1 x)) (Let0123456789876543210YSym1 x) - type family Foo13_ (a :: a) :: a where - Foo13_ y = y - type family Foo13 (a :: a) :: a where - Foo13 x = Apply Foo13_Sym0 (Let0123456789876543210BarSym1 x) - type family Foo12 (a :: Nat) :: Nat where - Foo12 x = Apply (Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x) x) (Apply SuccSym0 (Apply SuccSym0 ZeroSym0)) - type family Foo11 (a :: Nat) :: Nat where - Foo11 x = Apply (Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x) (Apply SuccSym0 ZeroSym0)) (Let0123456789876543210ZSym1 x) - type family Foo10 (a :: Nat) :: Nat where - Foo10 x = Apply (Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x) (Apply SuccSym0 ZeroSym0)) x - type family Foo9 (a :: Nat) :: Nat where - Foo9 x = Apply (Let0123456789876543210ZSym1 x) x - type family Foo8 (a :: Nat) :: Nat where - Foo8 x = Let0123456789876543210ZSym1 x - type family Foo7 (a :: Nat) :: Nat where - Foo7 x = Let0123456789876543210XSym1 x - type family Foo6 (a :: Nat) :: Nat where - Foo6 x = Let0123456789876543210ZSym1 x - type family Foo5 (a :: Nat) :: Nat where - Foo5 x = Apply (Let0123456789876543210FSym1 x) x - type family Foo4 (a :: Nat) :: Nat where - Foo4 x = Apply (Let0123456789876543210FSym1 x) x - type family Foo3 (a :: Nat) :: Nat where - Foo3 x = Let0123456789876543210YSym1 x - type family Foo2 :: Nat where - Foo2 = Let0123456789876543210ZSym0 - type family Foo1 (a :: Nat) :: Nat where - Foo1 x = Let0123456789876543210YSym1 x - sFoo14 :: - forall (t :: Nat). Sing t -> Sing (Apply Foo14Sym0 t :: (Nat, Nat)) - sFoo13_ :: - forall a (t :: a). Sing t -> Sing (Apply Foo13_Sym0 t :: a) - sFoo13 :: - forall a (t :: a). Sing t -> Sing (Apply Foo13Sym0 t :: a) - sFoo12 :: - forall (t :: Nat). Sing t -> Sing (Apply Foo12Sym0 t :: Nat) - sFoo11 :: - forall (t :: Nat). Sing t -> Sing (Apply Foo11Sym0 t :: Nat) - sFoo10 :: - forall (t :: Nat). Sing t -> Sing (Apply Foo10Sym0 t :: Nat) - sFoo9 :: - forall (t :: Nat). Sing t -> Sing (Apply Foo9Sym0 t :: Nat) - sFoo8 :: - forall (t :: Nat). Sing t -> Sing (Apply Foo8Sym0 t :: Nat) - sFoo7 :: - forall (t :: Nat). Sing t -> Sing (Apply Foo7Sym0 t :: Nat) - sFoo6 :: - forall (t :: Nat). Sing t -> Sing (Apply Foo6Sym0 t :: Nat) - sFoo5 :: - forall (t :: Nat). Sing t -> Sing (Apply Foo5Sym0 t :: Nat) - sFoo4 :: - forall (t :: Nat). Sing t -> Sing (Apply Foo4Sym0 t :: Nat) - sFoo3 :: - forall (t :: Nat). Sing t -> Sing (Apply Foo3Sym0 t :: Nat) - sFoo2 :: Sing (Foo2Sym0 :: Nat) - sFoo1 :: - forall (t :: Nat). Sing t -> Sing (Apply Foo1Sym0 t :: Nat) - sFoo14 (sX :: Sing x) - = let - sZ :: Sing (Let0123456789876543210ZSym1 x) - sY :: Sing (Let0123456789876543210YSym1 x) - sX_0123456789876543210 :: - Sing (Let0123456789876543210X_0123456789876543210Sym1 x) - sZ - = (id - @(Sing (Case_0123456789876543210 x (Let0123456789876543210X_0123456789876543210Sym1 x)))) - (case sX_0123456789876543210 of { - STuple2 _ (sY_0123456789876543210 :: Sing y_0123456789876543210) - -> sY_0123456789876543210 }) - sY - = (id - @(Sing (Case_0123456789876543210 x (Let0123456789876543210X_0123456789876543210Sym1 x)))) - (case sX_0123456789876543210 of { - STuple2 (sY_0123456789876543210 :: Sing y_0123456789876543210) _ - -> sY_0123456789876543210 }) - sX_0123456789876543210 - = (applySing - ((applySing ((singFun2 @Tuple2Sym0) STuple2)) - ((applySing ((singFun1 @SuccSym0) SSucc)) sX))) - sX - in (applySing ((applySing ((singFun2 @Tuple2Sym0) STuple2)) sZ)) sY - sFoo13_ (sY :: Sing y) = sY - sFoo13 (sX :: Sing x) - = let - sBar :: Sing (Let0123456789876543210BarSym1 x :: a) - sBar = sX - in (applySing ((singFun1 @Foo13_Sym0) sFoo13_)) sBar - sFoo12 (sX :: Sing x) - = let - (%+) :: - forall (t :: Nat) (t :: Nat). - Sing t - -> Sing t - -> Sing (Apply (Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x) t) t :: Nat) - (%+) SZero (sM :: Sing m) = sM - (%+) (SSucc (sN :: Sing n)) (sM :: Sing m) - = (applySing ((singFun1 @SuccSym0) SSucc)) - ((applySing - ((applySing ((singFun2 @((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x)) (%+))) - sN)) - sX) - in - (applySing - ((applySing ((singFun2 @((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x)) (%+))) - sX)) - ((applySing ((singFun1 @SuccSym0) SSucc)) - ((applySing ((singFun1 @SuccSym0) SSucc)) SZero)) - sFoo11 (sX :: Sing x) - = let - sZ :: Sing (Let0123456789876543210ZSym1 x :: Nat) - (%+) :: - forall (t :: Nat) (t :: Nat). - Sing t - -> Sing t - -> Sing (Apply (Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x) t) t :: Nat) - sZ = sX - (%+) SZero (sM :: Sing m) = sM - (%+) (SSucc (sN :: Sing n)) (sM :: Sing m) - = (applySing ((singFun1 @SuccSym0) SSucc)) - ((applySing - ((applySing ((singFun2 @((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x)) (%+))) - sN)) - sM) - in - (applySing - ((applySing ((singFun2 @((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x)) (%+))) - ((applySing ((singFun1 @SuccSym0) SSucc)) SZero))) - sZ - sFoo10 (sX :: Sing x) - = let - (%+) :: - forall (t :: Nat) (t :: Nat). - Sing t - -> Sing t - -> Sing (Apply (Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x) t) t :: Nat) - (%+) SZero (sM :: Sing m) = sM - (%+) (SSucc (sN :: Sing n)) (sM :: Sing m) - = (applySing ((singFun1 @SuccSym0) SSucc)) - ((applySing - ((applySing ((singFun2 @((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x)) (%+))) - sN)) - sM) - in - (applySing - ((applySing ((singFun2 @((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x)) (%+))) - ((applySing ((singFun1 @SuccSym0) SSucc)) SZero))) - sX - sFoo9 (sX :: Sing x) - = let - sZ :: - forall (t :: Nat). - Sing t -> Sing (Apply (Let0123456789876543210ZSym1 x) t :: Nat) - sZ (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((singFun1 - @(Apply (Apply Lambda_0123456789876543210Sym0 a_0123456789876543210) x)) - (\ sX -> case sX of { (_ :: Sing x) -> sX }))) - sA_0123456789876543210 - in (applySing ((singFun1 @(Let0123456789876543210ZSym1 x)) sZ)) sX - sFoo8 (sX :: Sing x) - = let - sZ :: Sing (Let0123456789876543210ZSym1 x :: Nat) - sZ - = (applySing - ((singFun1 @(Apply Lambda_0123456789876543210Sym0 x)) - (\ sX -> case sX of { (_ :: Sing x) -> sX }))) - SZero - in sZ - sFoo7 (sX :: Sing x) - = let - sX :: Sing (Let0123456789876543210XSym1 x :: Nat) - sX = SZero - in sX - sFoo6 (sX :: Sing x) - = let - sF :: - forall (t :: Nat). - Sing t -> Sing (Apply (Let0123456789876543210FSym1 x) t :: Nat) - sF (sY :: Sing y) = (applySing ((singFun1 @SuccSym0) SSucc)) sY in - let - sZ :: Sing (Let0123456789876543210ZSym1 x :: Nat) - sZ - = (applySing ((singFun1 @(Let0123456789876543210FSym1 x)) sF)) sX - in sZ - sFoo5 (sX :: Sing x) - = let - sF :: - forall (t :: Nat). - Sing t -> Sing (Apply (Let0123456789876543210FSym1 x) t :: Nat) - sF (sY :: Sing y) - = let - sZ :: Sing (Let0123456789876543210ZSym2 y x :: Nat) - sZ = (applySing ((singFun1 @SuccSym0) SSucc)) sY - in (applySing ((singFun1 @SuccSym0) SSucc)) sZ - in (applySing ((singFun1 @(Let0123456789876543210FSym1 x)) sF)) sX - sFoo4 (sX :: Sing x) - = let - sF :: - forall (t :: Nat). - Sing t -> Sing (Apply (Let0123456789876543210FSym1 x) t :: Nat) - sF (sY :: Sing y) = (applySing ((singFun1 @SuccSym0) SSucc)) sY - in (applySing ((singFun1 @(Let0123456789876543210FSym1 x)) sF)) sX - sFoo3 (sX :: Sing x) - = let - sY :: Sing (Let0123456789876543210YSym1 x :: Nat) - sY = (applySing ((singFun1 @SuccSym0) SSucc)) sX - in sY - sFoo2 - = let - sZ :: Sing Let0123456789876543210ZSym0 - sY :: Sing Let0123456789876543210YSym0 - sZ = (applySing ((singFun1 @SuccSym0) SSucc)) sY - sY = (applySing ((singFun1 @SuccSym0) SSucc)) SZero - in sZ - sFoo1 (sX :: Sing x) - = let - sY :: Sing (Let0123456789876543210YSym1 x :: Nat) - sY = (applySing ((singFun1 @SuccSym0) SSucc)) SZero - in sY - instance SingI (Foo14Sym0 :: (~>) Nat (Nat, Nat)) where - sing = (singFun1 @Foo14Sym0) sFoo14 - instance SingI (Foo13_Sym0 :: (~>) a a) where - sing = (singFun1 @Foo13_Sym0) sFoo13_ - instance SingI (Foo13Sym0 :: (~>) a a) where - sing = (singFun1 @Foo13Sym0) sFoo13 - instance SingI (Foo12Sym0 :: (~>) Nat Nat) where - sing = (singFun1 @Foo12Sym0) sFoo12 - instance SingI (Foo11Sym0 :: (~>) Nat Nat) where - sing = (singFun1 @Foo11Sym0) sFoo11 - instance SingI (Foo10Sym0 :: (~>) Nat Nat) where - sing = (singFun1 @Foo10Sym0) sFoo10 - instance SingI (Foo9Sym0 :: (~>) Nat Nat) where - sing = (singFun1 @Foo9Sym0) sFoo9 - instance SingI (Foo8Sym0 :: (~>) Nat Nat) where - sing = (singFun1 @Foo8Sym0) sFoo8 - instance SingI (Foo7Sym0 :: (~>) Nat Nat) where - sing = (singFun1 @Foo7Sym0) sFoo7 - instance SingI (Foo6Sym0 :: (~>) Nat Nat) where - sing = (singFun1 @Foo6Sym0) sFoo6 - instance SingI (Foo5Sym0 :: (~>) Nat Nat) where - sing = (singFun1 @Foo5Sym0) sFoo5 - instance SingI (Foo4Sym0 :: (~>) Nat Nat) where - sing = (singFun1 @Foo4Sym0) sFoo4 - instance SingI (Foo3Sym0 :: (~>) Nat Nat) where - sing = (singFun1 @Foo3Sym0) sFoo3 - instance SingI (Foo1Sym0 :: (~>) Nat Nat) where - sing = (singFun1 @Foo1Sym0) sFoo1 diff --git a/tests/compile-and-dump/Singletons/LetStatements.hs b/tests/compile-and-dump/Singletons/LetStatements.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/LetStatements.hs +++ /dev/null @@ -1,193 +0,0 @@ -{-# OPTIONS_GHC -Wno-unused-binds -Wno-unused-matches - -Wno-name-shadowing #-} - -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.ghc88.template b/tests/compile-and-dump/Singletons/Maybe.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Maybe.ghc88.template +++ /dev/null @@ -1,157 +0,0 @@ -Singletons/Maybe.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| data Maybe a - = Nothing | Just a - deriving (Eq, Show) |] - ======> - data Maybe a - = Nothing | Just a - deriving (Eq, Show) - type NothingSym0 = Nothing - type JustSym1 (t0123456789876543210 :: a0123456789876543210) = - Just t0123456789876543210 - instance SuppressUnusedWarnings JustSym0 where - suppressUnusedWarnings = snd (((,) JustSym0KindInference) ()) - data JustSym0 :: forall a0123456789876543210. - (~>) a0123456789876543210 (Maybe a0123456789876543210) - where - JustSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply JustSym0 arg) (JustSym1 arg) => - JustSym0 t0123456789876543210 - type instance Apply JustSym0 t0123456789876543210 = Just t0123456789876543210 - type family ShowsPrec_0123456789876543210 (a :: GHC.Types.Nat) (a :: Maybe a) (a :: GHC.Types.Symbol) :: GHC.Types.Symbol where - ShowsPrec_0123456789876543210 _ Nothing a_0123456789876543210 = Apply (Apply ShowStringSym0 "Nothing") a_0123456789876543210 - ShowsPrec_0123456789876543210 p_0123456789876543210 (Just arg_0123456789876543210) a_0123456789876543210 = Apply (Apply (Apply ShowParenSym0 (Apply (Apply (>@#@$) p_0123456789876543210) (Data.Singletons.Prelude.Num.FromInteger 10))) (Apply (Apply (.@#@$) (Apply ShowStringSym0 "Just ")) (Apply (Apply ShowsPrecSym0 (Data.Singletons.Prelude.Num.FromInteger 11)) arg_0123456789876543210))) a_0123456789876543210 - type ShowsPrec_0123456789876543210Sym3 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: Maybe a0123456789876543210) (a0123456789876543210 :: GHC.Types.Symbol) = - ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym2KindInference) ()) - data ShowsPrec_0123456789876543210Sym2 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: Maybe a0123456789876543210) :: (~>) GHC.Types.Symbol GHC.Types.Symbol - where - ShowsPrec_0123456789876543210Sym2KindInference :: forall a0123456789876543210 - a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) arg) (ShowsPrec_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 arg) => - ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym1KindInference) ()) - data ShowsPrec_0123456789876543210Sym1 (a0123456789876543210 :: GHC.Types.Nat) :: forall a0123456789876543210. - (~>) (Maybe a0123456789876543210) ((~>) GHC.Types.Symbol GHC.Types.Symbol) - where - ShowsPrec_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) arg) (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 arg) => - ShowsPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ShowsPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym0KindInference) ()) - data ShowsPrec_0123456789876543210Sym0 :: forall a0123456789876543210. - (~>) GHC.Types.Nat ((~>) (Maybe a0123456789876543210) ((~>) GHC.Types.Symbol GHC.Types.Symbol)) - where - ShowsPrec_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply ShowsPrec_0123456789876543210Sym0 arg) (ShowsPrec_0123456789876543210Sym1 arg) => - ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ShowsPrec_0123456789876543210Sym0 a0123456789876543210 = ShowsPrec_0123456789876543210Sym1 a0123456789876543210 - instance PShow (Maybe a) where - type ShowsPrec a a a = Apply (Apply (Apply ShowsPrec_0123456789876543210Sym0 a) a) a - type family Equals_0123456789876543210 (a :: Maybe a) (b :: Maybe a) :: Bool where - Equals_0123456789876543210 Nothing Nothing = TrueSym0 - Equals_0123456789876543210 (Just a) (Just b) = (==) a b - Equals_0123456789876543210 (_ :: Maybe a) (_ :: Maybe a) = FalseSym0 - instance PEq (Maybe a) where - type (==) a b = Equals_0123456789876543210 a b - data SMaybe :: forall a. Maybe a -> GHC.Types.Type - where - SNothing :: SMaybe Nothing - SJust :: forall a (n :: a). (Sing (n :: a)) -> SMaybe (Just n) - type instance Sing @(Maybe a) = SMaybe - instance SingKind a => SingKind (Maybe a) where - type Demote (Maybe a) = Maybe (Demote a) - fromSing SNothing = Nothing - fromSing (SJust b) = Just (fromSing b) - toSing Nothing = SomeSing SNothing - toSing (Just (b :: Demote a)) - = case toSing b :: SomeSing a of { - SomeSing c -> SomeSing (SJust c) } - instance SShow a => SShow (Maybe a) where - sShowsPrec :: - forall (t1 :: GHC.Types.Nat) - (t2 :: Maybe a) - (t3 :: GHC.Types.Symbol). - Sing t1 - -> Sing t2 - -> Sing t3 - -> Sing (Apply (Apply (Apply (ShowsPrecSym0 :: TyFun GHC.Types.Nat ((~>) (Maybe a) ((~>) GHC.Types.Symbol GHC.Types.Symbol)) - -> GHC.Types.Type) t1) t2) t3) - sShowsPrec - _ - SNothing - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "Nothing"))) - sA_0123456789876543210 - sShowsPrec - (sP_0123456789876543210 :: Sing p_0123456789876543210) - (SJust (sArg_0123456789876543210 :: Sing arg_0123456789876543210)) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing - ((applySing ((singFun3 @ShowParenSym0) sShowParen)) - ((applySing - ((applySing ((singFun2 @(>@#@$)) (%>))) sP_0123456789876543210)) - (Data.Singletons.Prelude.Num.sFromInteger (sing :: Sing 10))))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "Just ")))) - ((applySing - ((applySing ((singFun3 @ShowsPrecSym0) sShowsPrec)) - (Data.Singletons.Prelude.Num.sFromInteger (sing :: Sing 11)))) - sArg_0123456789876543210)))) - sA_0123456789876543210 - instance SEq a => SEq (Maybe a) where - (%==) SNothing SNothing = STrue - (%==) SNothing (SJust _) = SFalse - (%==) (SJust _) SNothing = SFalse - (%==) (SJust a) (SJust b) = ((%==) a) b - instance SDecide a => SDecide (Maybe a) where - (%~) SNothing SNothing = Proved Refl - (%~) SNothing (SJust _) = Disproved (\ x -> case x of) - (%~) (SJust _) SNothing = Disproved (\ x -> case x of) - (%~) (SJust a) (SJust b) - = case ((%~) a) b of - Proved Refl -> Proved Refl - Disproved contra - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - instance SDecide a => - Data.Type.Equality.TestEquality (SMaybe :: Maybe a - -> GHC.Types.Type) where - Data.Type.Equality.testEquality - = Data.Singletons.Decide.decideEquality - instance SDecide a => - Data.Type.Coercion.TestCoercion (SMaybe :: Maybe a - -> GHC.Types.Type) where - Data.Type.Coercion.testCoercion - = Data.Singletons.Decide.decideCoercion - instance Data.Singletons.ShowSing.ShowSing a => - Show (SMaybe (z :: Maybe a)) where - showsPrec _ SNothing = showString "SNothing" - showsPrec - p_0123456789876543210 - (SJust (arg_0123456789876543210 :: Sing argTy_0123456789876543210)) - = (showParen (((>) p_0123456789876543210) 10)) - (((.) (showString "SJust ")) - ((showsPrec 11) arg_0123456789876543210)) :: - Data.Singletons.ShowSing.ShowSing' argTy_0123456789876543210 => - ShowS - instance SingI Nothing where - sing = SNothing - instance SingI n => SingI (Just (n :: a)) where - sing = SJust sing - instance SingI (JustSym0 :: (~>) a (Maybe a)) where - sing = (singFun1 @JustSym0) SJust diff --git a/tests/compile-and-dump/Singletons/Maybe.hs b/tests/compile-and-dump/Singletons/Maybe.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Maybe.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Singletons.Maybe where - -import Data.Singletons.TH - -$(singletons [d| - data Maybe a = Nothing | Just a deriving (Eq, Show) - |]) diff --git a/tests/compile-and-dump/Singletons/Nat.ghc88.template b/tests/compile-and-dump/Singletons/Nat.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Nat.ghc88.template +++ /dev/null @@ -1,283 +0,0 @@ -Singletons/Nat.hs:(0,0)-(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, Ord) |] - ======> - data Nat - where - Zero :: Nat - Succ :: Nat -> Nat - deriving (Eq, Show, Read, Ord) - 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 ZeroSym0 = Zero - type SuccSym1 (t0123456789876543210 :: Nat) = - Succ t0123456789876543210 - instance SuppressUnusedWarnings SuccSym0 where - suppressUnusedWarnings = snd (((,) SuccSym0KindInference) ()) - data SuccSym0 :: (~>) Nat Nat - where - SuccSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply SuccSym0 arg) (SuccSym1 arg) => - SuccSym0 t0123456789876543210 - type instance Apply SuccSym0 t0123456789876543210 = Succ t0123456789876543210 - type PredSym1 (a0123456789876543210 :: Nat) = - Pred a0123456789876543210 - instance SuppressUnusedWarnings PredSym0 where - suppressUnusedWarnings = snd (((,) PredSym0KindInference) ()) - data PredSym0 :: (~>) Nat Nat - where - PredSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply PredSym0 arg) (PredSym1 arg) => - PredSym0 a0123456789876543210 - type instance Apply PredSym0 a0123456789876543210 = Pred a0123456789876543210 - type PlusSym2 (a0123456789876543210 :: Nat) (a0123456789876543210 :: Nat) = - Plus a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (PlusSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) PlusSym1KindInference) ()) - data PlusSym1 (a0123456789876543210 :: Nat) :: (~>) Nat Nat - where - PlusSym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (PlusSym1 a0123456789876543210) arg) (PlusSym2 a0123456789876543210 arg) => - PlusSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (PlusSym1 a0123456789876543210) a0123456789876543210 = Plus a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings PlusSym0 where - suppressUnusedWarnings = snd (((,) PlusSym0KindInference) ()) - data PlusSym0 :: (~>) Nat ((~>) Nat Nat) - where - PlusSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply PlusSym0 arg) (PlusSym1 arg) => - PlusSym0 a0123456789876543210 - type instance Apply PlusSym0 a0123456789876543210 = PlusSym1 a0123456789876543210 - 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) - type family ShowsPrec_0123456789876543210 (a :: GHC.Types.Nat) (a :: Nat) (a :: GHC.Types.Symbol) :: GHC.Types.Symbol where - ShowsPrec_0123456789876543210 _ Zero a_0123456789876543210 = Apply (Apply ShowStringSym0 "Zero") a_0123456789876543210 - ShowsPrec_0123456789876543210 p_0123456789876543210 (Succ arg_0123456789876543210) a_0123456789876543210 = Apply (Apply (Apply ShowParenSym0 (Apply (Apply (>@#@$) p_0123456789876543210) (Data.Singletons.Prelude.Num.FromInteger 10))) (Apply (Apply (.@#@$) (Apply ShowStringSym0 "Succ ")) (Apply (Apply ShowsPrecSym0 (Data.Singletons.Prelude.Num.FromInteger 11)) arg_0123456789876543210))) a_0123456789876543210 - type ShowsPrec_0123456789876543210Sym3 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: Nat) (a0123456789876543210 :: GHC.Types.Symbol) = - ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym2KindInference) ()) - data ShowsPrec_0123456789876543210Sym2 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: Nat) :: (~>) GHC.Types.Symbol GHC.Types.Symbol - where - ShowsPrec_0123456789876543210Sym2KindInference :: forall a0123456789876543210 - a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) arg) (ShowsPrec_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 arg) => - ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym1KindInference) ()) - data ShowsPrec_0123456789876543210Sym1 (a0123456789876543210 :: GHC.Types.Nat) :: (~>) Nat ((~>) GHC.Types.Symbol GHC.Types.Symbol) - where - ShowsPrec_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) arg) (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 arg) => - ShowsPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ShowsPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym0KindInference) ()) - data ShowsPrec_0123456789876543210Sym0 :: (~>) GHC.Types.Nat ((~>) Nat ((~>) GHC.Types.Symbol GHC.Types.Symbol)) - where - ShowsPrec_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply ShowsPrec_0123456789876543210Sym0 arg) (ShowsPrec_0123456789876543210Sym1 arg) => - ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ShowsPrec_0123456789876543210Sym0 a0123456789876543210 = ShowsPrec_0123456789876543210Sym1 a0123456789876543210 - instance PShow Nat where - type ShowsPrec a a a = Apply (Apply (Apply ShowsPrec_0123456789876543210Sym0 a) a) a - type family Compare_0123456789876543210 (a :: Nat) (a :: Nat) :: Ordering where - Compare_0123456789876543210 Zero Zero = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) '[] - Compare_0123456789876543210 (Succ a_0123456789876543210) (Succ b_0123456789876543210) = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) '[]) - Compare_0123456789876543210 Zero (Succ _) = LTSym0 - Compare_0123456789876543210 (Succ _) Zero = GTSym0 - type Compare_0123456789876543210Sym2 (a0123456789876543210 :: Nat) (a0123456789876543210 :: Nat) = - Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Compare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym1KindInference) ()) - data Compare_0123456789876543210Sym1 (a0123456789876543210 :: Nat) :: (~>) Nat Ordering - where - Compare_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Compare_0123456789876543210Sym1 a0123456789876543210) arg) (Compare_0123456789876543210Sym2 a0123456789876543210 arg) => - Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Compare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Compare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym0KindInference) ()) - data Compare_0123456789876543210Sym0 :: (~>) Nat ((~>) Nat Ordering) - where - Compare_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Compare_0123456789876543210Sym0 arg) (Compare_0123456789876543210Sym1 arg) => - Compare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Compare_0123456789876543210Sym0 a0123456789876543210 = Compare_0123456789876543210Sym1 a0123456789876543210 - instance POrd Nat where - type Compare a a = Apply (Apply Compare_0123456789876543210Sym0 a) a - type family Equals_0123456789876543210 (a :: Nat) (b :: Nat) :: Bool where - Equals_0123456789876543210 Zero Zero = TrueSym0 - Equals_0123456789876543210 (Succ a) (Succ b) = (==) a b - Equals_0123456789876543210 (_ :: Nat) (_ :: Nat) = FalseSym0 - instance PEq Nat where - type (==) a b = Equals_0123456789876543210 a b - sPred :: - forall (t :: Nat). Sing t -> Sing (Apply PredSym0 t :: Nat) - sPlus :: - forall (t :: Nat) (t :: Nat). - Sing t -> Sing t -> Sing (Apply (Apply PlusSym0 t) t :: Nat) - sPred SZero = SZero - sPred (SSucc (sN :: Sing n)) = sN - sPlus SZero (sM :: Sing m) = sM - sPlus (SSucc (sN :: Sing n)) (sM :: Sing m) - = (applySing ((singFun1 @SuccSym0) SSucc)) - ((applySing ((applySing ((singFun2 @PlusSym0) sPlus)) sN)) sM) - instance SingI (PredSym0 :: (~>) Nat Nat) where - sing = (singFun1 @PredSym0) sPred - instance SingI (PlusSym0 :: (~>) Nat ((~>) Nat Nat)) where - sing = (singFun2 @PlusSym0) sPlus - instance SingI d => - SingI (PlusSym1 (d :: Nat) :: (~>) Nat Nat) where - sing = (singFun1 @(PlusSym1 (d :: Nat))) (sPlus (sing @d)) - data SNat :: Nat -> GHC.Types.Type - where - SZero :: SNat Zero - SSucc :: forall (n :: Nat). (Sing (n :: Nat)) -> SNat (Succ n) - type instance Sing @Nat = SNat - instance SingKind Nat where - type Demote Nat = Nat - fromSing SZero = Zero - fromSing (SSucc b) = Succ (fromSing b) - toSing Zero = SomeSing SZero - toSing (Succ (b :: Demote Nat)) - = case toSing b :: SomeSing Nat of { - SomeSing c -> SomeSing (SSucc c) } - instance SShow Nat => SShow Nat where - sShowsPrec :: - forall (t1 :: GHC.Types.Nat) (t2 :: Nat) (t3 :: GHC.Types.Symbol). - Sing t1 - -> Sing t2 - -> Sing t3 - -> Sing (Apply (Apply (Apply (ShowsPrecSym0 :: TyFun GHC.Types.Nat ((~>) Nat ((~>) GHC.Types.Symbol GHC.Types.Symbol)) - -> GHC.Types.Type) t1) t2) t3) - sShowsPrec - _ - SZero - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "Zero"))) - sA_0123456789876543210 - sShowsPrec - (sP_0123456789876543210 :: Sing p_0123456789876543210) - (SSucc (sArg_0123456789876543210 :: Sing arg_0123456789876543210)) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing - ((applySing ((singFun3 @ShowParenSym0) sShowParen)) - ((applySing - ((applySing ((singFun2 @(>@#@$)) (%>))) sP_0123456789876543210)) - (Data.Singletons.Prelude.Num.sFromInteger (sing :: Sing 10))))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "Succ ")))) - ((applySing - ((applySing ((singFun3 @ShowsPrecSym0) sShowsPrec)) - (Data.Singletons.Prelude.Num.sFromInteger (sing :: Sing 11)))) - sArg_0123456789876543210)))) - sA_0123456789876543210 - instance SOrd Nat => SOrd Nat where - sCompare :: - forall (t1 :: Nat) (t2 :: Nat). - Sing t1 - -> Sing t2 - -> Sing (Apply (Apply (CompareSym0 :: TyFun Nat ((~>) Nat Ordering) - -> GHC.Types.Type) t1) t2) - sCompare SZero SZero - = (applySing - ((applySing - ((applySing ((singFun3 @FoldlSym0) sFoldl)) - ((singFun2 @ThenCmpSym0) sThenCmp))) - SEQ)) - Data.Singletons.Prelude.Instances.SNil - sCompare - (SSucc (sA_0123456789876543210 :: Sing a_0123456789876543210)) - (SSucc (sB_0123456789876543210 :: Sing b_0123456789876543210)) - = (applySing - ((applySing - ((applySing ((singFun3 @FoldlSym0) sFoldl)) - ((singFun2 @ThenCmpSym0) sThenCmp))) - SEQ)) - ((applySing - ((applySing - ((singFun2 @(:@#@$)) - Data.Singletons.Prelude.Instances.SCons)) - ((applySing - ((applySing ((singFun2 @CompareSym0) sCompare)) - sA_0123456789876543210)) - sB_0123456789876543210))) - Data.Singletons.Prelude.Instances.SNil) - sCompare SZero (SSucc _) = SLT - sCompare (SSucc _) SZero = SGT - instance SEq Nat => SEq Nat where - (%==) SZero SZero = STrue - (%==) SZero (SSucc _) = SFalse - (%==) (SSucc _) SZero = SFalse - (%==) (SSucc a) (SSucc b) = ((%==) a) b - instance SDecide Nat => SDecide Nat where - (%~) SZero SZero = Proved Refl - (%~) SZero (SSucc _) = Disproved (\ x -> case x of) - (%~) (SSucc _) SZero = Disproved (\ x -> case x of) - (%~) (SSucc a) (SSucc b) - = case ((%~) a) b of - Proved Refl -> Proved Refl - Disproved contra - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - instance SDecide Nat => - Data.Type.Equality.TestEquality (SNat :: Nat - -> GHC.Types.Type) where - Data.Type.Equality.testEquality - = Data.Singletons.Decide.decideEquality - instance SDecide Nat => - Data.Type.Coercion.TestCoercion (SNat :: Nat - -> GHC.Types.Type) where - Data.Type.Coercion.testCoercion - = Data.Singletons.Decide.decideCoercion - instance Data.Singletons.ShowSing.ShowSing Nat => - Show (SNat (z :: Nat)) where - showsPrec _ SZero = showString "SZero" - showsPrec - p_0123456789876543210 - (SSucc (arg_0123456789876543210 :: Sing argTy_0123456789876543210)) - = (showParen (((>) p_0123456789876543210) 10)) - (((.) (showString "SSucc ")) - ((showsPrec 11) arg_0123456789876543210)) :: - Data.Singletons.ShowSing.ShowSing' argTy_0123456789876543210 => - ShowS - instance SingI Zero where - sing = SZero - instance SingI n => SingI (Succ (n :: Nat)) where - sing = SSucc sing - instance SingI (SuccSym0 :: (~>) Nat Nat) where - sing = (singFun1 @SuccSym0) SSucc diff --git a/tests/compile-and-dump/Singletons/Nat.hs b/tests/compile-and-dump/Singletons/Nat.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Nat.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Singletons.Nat where - -import Data.Singletons.TH - -$(singletons [d| - data Nat where - Zero :: Nat - Succ :: Nat -> Nat - deriving (Eq, Show, Read, Ord) - - plus :: Nat -> Nat -> Nat - plus Zero m = m - plus (Succ n) m = Succ (plus n m) - - pred :: Nat -> Nat - pred Zero = Zero - pred (Succ n) = n - |]) diff --git a/tests/compile-and-dump/Singletons/NatSymbolReflexive.ghc88.template b/tests/compile-and-dump/Singletons/NatSymbolReflexive.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/NatSymbolReflexive.ghc88.template +++ /dev/null diff --git a/tests/compile-and-dump/Singletons/NatSymbolReflexive.hs b/tests/compile-and-dump/Singletons/NatSymbolReflexive.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/NatSymbolReflexive.hs +++ /dev/null @@ -1,11 +0,0 @@ -module NatSymbolReflexive where - -import Data.Singletons.Prelude -import Data.Type.Equality ((:~:)(..)) -import GHC.TypeLits - -test1 :: forall (a :: Nat). Sing a -> (a == a) :~: True -test1 _ = Refl - -test2 :: forall (a :: Symbol). Sing a -> (a == a) :~: True -test2 _ = Refl diff --git a/tests/compile-and-dump/Singletons/Operators.ghc88.template b/tests/compile-and-dump/Singletons/Operators.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Operators.ghc88.template +++ /dev/null @@ -1,123 +0,0 @@ -Singletons/Operators.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| child :: Foo -> Foo - child FLeaf = FLeaf - child (a :+: _) = a - (+) :: Nat -> Nat -> Nat - Zero + m = m - (Succ n) + m = Succ (n + m) - - data Foo - where - FLeaf :: Foo - (:+:) :: Foo -> Foo -> Foo |] - ======> - data Foo - where - FLeaf :: Foo - (:+:) :: Foo -> Foo -> Foo - child :: Foo -> Foo - child FLeaf = FLeaf - child (a :+: _) = a - (+) :: Nat -> Nat -> Nat - (+) Zero m = m - (+) (Succ n) m = Succ (n + m) - type FLeafSym0 = FLeaf - type (:+:@#@$$$) (t0123456789876543210 :: Foo) (t0123456789876543210 :: Foo) = - (:+:) t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings ((:+:@#@$$) t0123456789876543210) where - suppressUnusedWarnings = snd (((,) (::+:@#@$$###)) ()) - data (:+:@#@$$) (t0123456789876543210 :: Foo) :: (~>) Foo Foo - where - (::+:@#@$$###) :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply ((:+:@#@$$) t0123456789876543210) arg) ((:+:@#@$$$) t0123456789876543210 arg) => - (:+:@#@$$) t0123456789876543210 t0123456789876543210 - type instance Apply ((:+:@#@$$) t0123456789876543210) t0123456789876543210 = (:+:) t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (:+:@#@$) where - suppressUnusedWarnings = snd (((,) (::+:@#@$###)) ()) - data (:+:@#@$) :: (~>) Foo ((~>) Foo Foo) - where - (::+:@#@$###) :: forall t0123456789876543210 - arg. SameKind (Apply (:+:@#@$) arg) ((:+:@#@$$) arg) => - (:+:@#@$) t0123456789876543210 - type instance Apply (:+:@#@$) t0123456789876543210 = (:+:@#@$$) t0123456789876543210 - type (+@#@$$$) (a0123456789876543210 :: Nat) (a0123456789876543210 :: Nat) = - (+) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((+@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (:+@#@$$###)) ()) - data (+@#@$$) (a0123456789876543210 :: Nat) :: (~>) Nat Nat - where - (:+@#@$$###) :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply ((+@#@$$) a0123456789876543210) arg) ((+@#@$$$) a0123456789876543210 arg) => - (+@#@$$) a0123456789876543210 a0123456789876543210 - type instance Apply ((+@#@$$) a0123456789876543210) a0123456789876543210 = (+) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (+@#@$) where - suppressUnusedWarnings = snd (((,) (:+@#@$###)) ()) - data (+@#@$) :: (~>) Nat ((~>) Nat Nat) - where - (:+@#@$###) :: forall a0123456789876543210 - arg. SameKind (Apply (+@#@$) arg) ((+@#@$$) arg) => - (+@#@$) a0123456789876543210 - type instance Apply (+@#@$) a0123456789876543210 = (+@#@$$) a0123456789876543210 - type ChildSym1 (a0123456789876543210 :: Foo) = - Child a0123456789876543210 - instance SuppressUnusedWarnings ChildSym0 where - suppressUnusedWarnings = snd (((,) ChildSym0KindInference) ()) - data ChildSym0 :: (~>) Foo Foo - where - ChildSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply ChildSym0 arg) (ChildSym1 arg) => - ChildSym0 a0123456789876543210 - type instance Apply ChildSym0 a0123456789876543210 = Child a0123456789876543210 - type family (+) (a :: Nat) (a :: Nat) :: Nat where - (+) 'Zero m = m - (+) ('Succ n) m = Apply SuccSym0 (Apply (Apply (+@#@$) n) m) - type family Child (a :: Foo) :: Foo where - Child FLeaf = FLeafSym0 - Child ((:+:) a _) = a - (%+) :: - forall (t :: Nat) (t :: Nat). - Sing t -> Sing t -> Sing (Apply (Apply (+@#@$) t) t :: Nat) - sChild :: - forall (t :: Foo). Sing t -> Sing (Apply ChildSym0 t :: Foo) - (%+) SZero (sM :: Sing m) = sM - (%+) (SSucc (sN :: Sing n)) (sM :: Sing m) - = (applySing ((singFun1 @SuccSym0) SSucc)) - ((applySing ((applySing ((singFun2 @(+@#@$)) (%+))) sN)) sM) - sChild SFLeaf = SFLeaf - sChild ((:%+:) (sA :: Sing a) _) = sA - instance SingI ((+@#@$) :: (~>) Nat ((~>) Nat Nat)) where - sing = (singFun2 @(+@#@$)) (%+) - instance SingI d => - SingI ((+@#@$$) (d :: Nat) :: (~>) Nat Nat) where - sing = (singFun1 @((+@#@$$) (d :: Nat))) ((%+) (sing @d)) - instance SingI (ChildSym0 :: (~>) Foo Foo) where - sing = (singFun1 @ChildSym0) sChild - data SFoo :: Foo -> GHC.Types.Type - where - SFLeaf :: SFoo FLeaf - (:%+:) :: forall (n :: Foo) (n :: Foo). - (Sing (n :: Foo)) -> (Sing (n :: Foo)) -> SFoo ((:+:) n n) - type instance Sing @Foo = SFoo - instance SingKind Foo where - type Demote Foo = Foo - fromSing SFLeaf = FLeaf - fromSing ((:%+:) b b) = ((:+:) (fromSing b)) (fromSing b) - toSing FLeaf = SomeSing SFLeaf - toSing ((:+:) (b :: Demote Foo) (b :: Demote Foo)) - = case - ((,) (toSing b :: SomeSing Foo)) (toSing b :: SomeSing Foo) - of { - (,) (SomeSing c) (SomeSing c) -> SomeSing (((:%+:) c) c) } - instance SingI FLeaf where - sing = SFLeaf - instance (SingI n, SingI n) => - SingI ((:+:) (n :: Foo) (n :: Foo)) where - sing = ((:%+:) sing) sing - instance SingI ((:+:@#@$) :: (~>) Foo ((~>) Foo Foo)) where - sing = (singFun2 @(:+:@#@$)) (:%+:) - instance SingI d => - SingI ((:+:@#@$$) (d :: Foo) :: (~>) Foo Foo) where - sing = (singFun1 @((:+:@#@$$) (d :: Foo))) ((:%+:) (sing @d)) diff --git a/tests/compile-and-dump/Singletons/Operators.hs b/tests/compile-and-dump/Singletons/Operators.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Operators.hs +++ /dev/null @@ -1,20 +0,0 @@ -module Singletons.Operators where - -import Data.Singletons -import Data.Singletons.TH -import Singletons.Nat -import Data.Singletons.SuppressUnusedWarnings - -$(singletons [d| - data Foo where - FLeaf :: Foo - (:+:) :: Foo -> Foo -> Foo - - child :: Foo -> Foo - child FLeaf = FLeaf - child (a :+: _) = a - - (+) :: Nat -> Nat -> Nat - Zero + m = m - (Succ n) + m = Succ (n + m) - |]) diff --git a/tests/compile-and-dump/Singletons/OrdDeriving.ghc88.template b/tests/compile-and-dump/Singletons/OrdDeriving.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/OrdDeriving.ghc88.template +++ /dev/null @@ -1,1163 +0,0 @@ -Singletons/OrdDeriving.hs:(0,0)-(0,0): Splicing declarations - singletons - [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) |] - ======> - 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 ZeroSym0 = Zero - type SuccSym1 (t0123456789876543210 :: Nat) = - Succ t0123456789876543210 - instance SuppressUnusedWarnings SuccSym0 where - suppressUnusedWarnings = snd (((,) SuccSym0KindInference) ()) - data SuccSym0 :: (~>) Nat Nat - where - SuccSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply SuccSym0 arg) (SuccSym1 arg) => - SuccSym0 t0123456789876543210 - type instance Apply SuccSym0 t0123456789876543210 = Succ t0123456789876543210 - type ASym4 (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: b0123456789876543210) (t0123456789876543210 :: c0123456789876543210) (t0123456789876543210 :: d0123456789876543210) = - A t0123456789876543210 t0123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (ASym3 t0123456789876543210 t0123456789876543210 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) ASym3KindInference) ()) - data ASym3 (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: b0123456789876543210) (t0123456789876543210 :: c0123456789876543210) :: forall d0123456789876543210. - (~>) d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) - where - ASym3KindInference :: forall t0123456789876543210 - t0123456789876543210 - t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (ASym3 t0123456789876543210 t0123456789876543210 t0123456789876543210) arg) (ASym4 t0123456789876543210 t0123456789876543210 t0123456789876543210 arg) => - ASym3 t0123456789876543210 t0123456789876543210 t0123456789876543210 t0123456789876543210 - type instance Apply (ASym3 t0123456789876543210 t0123456789876543210 t0123456789876543210) t0123456789876543210 = A t0123456789876543210 t0123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (ASym2 t0123456789876543210 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) ASym2KindInference) ()) - data ASym2 (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: b0123456789876543210) :: forall c0123456789876543210 - d0123456789876543210. - (~>) c0123456789876543210 ((~>) d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210)) - where - ASym2KindInference :: forall t0123456789876543210 - t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (ASym2 t0123456789876543210 t0123456789876543210) arg) (ASym3 t0123456789876543210 t0123456789876543210 arg) => - ASym2 t0123456789876543210 t0123456789876543210 t0123456789876543210 - type instance Apply (ASym2 t0123456789876543210 t0123456789876543210) t0123456789876543210 = ASym3 t0123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (ASym1 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) ASym1KindInference) ()) - data ASym1 (t0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210 - c0123456789876543210 - d0123456789876543210. - (~>) b0123456789876543210 ((~>) c0123456789876543210 ((~>) d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210))) - where - ASym1KindInference :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (ASym1 t0123456789876543210) arg) (ASym2 t0123456789876543210 arg) => - ASym1 t0123456789876543210 t0123456789876543210 - type instance Apply (ASym1 t0123456789876543210) t0123456789876543210 = ASym2 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings ASym0 where - suppressUnusedWarnings = snd (((,) ASym0KindInference) ()) - data ASym0 :: forall a0123456789876543210 - b0123456789876543210 - c0123456789876543210 - d0123456789876543210. - (~>) a0123456789876543210 ((~>) b0123456789876543210 ((~>) c0123456789876543210 ((~>) d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210)))) - where - ASym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply ASym0 arg) (ASym1 arg) => - ASym0 t0123456789876543210 - type instance Apply ASym0 t0123456789876543210 = ASym1 t0123456789876543210 - type BSym4 (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: b0123456789876543210) (t0123456789876543210 :: c0123456789876543210) (t0123456789876543210 :: d0123456789876543210) = - B t0123456789876543210 t0123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (BSym3 t0123456789876543210 t0123456789876543210 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) BSym3KindInference) ()) - data BSym3 (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: b0123456789876543210) (t0123456789876543210 :: c0123456789876543210) :: forall d0123456789876543210. - (~>) d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) - where - BSym3KindInference :: forall t0123456789876543210 - t0123456789876543210 - t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (BSym3 t0123456789876543210 t0123456789876543210 t0123456789876543210) arg) (BSym4 t0123456789876543210 t0123456789876543210 t0123456789876543210 arg) => - BSym3 t0123456789876543210 t0123456789876543210 t0123456789876543210 t0123456789876543210 - type instance Apply (BSym3 t0123456789876543210 t0123456789876543210 t0123456789876543210) t0123456789876543210 = B t0123456789876543210 t0123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (BSym2 t0123456789876543210 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) BSym2KindInference) ()) - data BSym2 (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: b0123456789876543210) :: forall c0123456789876543210 - d0123456789876543210. - (~>) c0123456789876543210 ((~>) d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210)) - where - BSym2KindInference :: forall t0123456789876543210 - t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (BSym2 t0123456789876543210 t0123456789876543210) arg) (BSym3 t0123456789876543210 t0123456789876543210 arg) => - BSym2 t0123456789876543210 t0123456789876543210 t0123456789876543210 - type instance Apply (BSym2 t0123456789876543210 t0123456789876543210) t0123456789876543210 = BSym3 t0123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (BSym1 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) BSym1KindInference) ()) - data BSym1 (t0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210 - c0123456789876543210 - d0123456789876543210. - (~>) b0123456789876543210 ((~>) c0123456789876543210 ((~>) d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210))) - where - BSym1KindInference :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (BSym1 t0123456789876543210) arg) (BSym2 t0123456789876543210 arg) => - BSym1 t0123456789876543210 t0123456789876543210 - type instance Apply (BSym1 t0123456789876543210) t0123456789876543210 = BSym2 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings BSym0 where - suppressUnusedWarnings = snd (((,) BSym0KindInference) ()) - data BSym0 :: forall a0123456789876543210 - b0123456789876543210 - c0123456789876543210 - d0123456789876543210. - (~>) a0123456789876543210 ((~>) b0123456789876543210 ((~>) c0123456789876543210 ((~>) d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210)))) - where - BSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply BSym0 arg) (BSym1 arg) => - BSym0 t0123456789876543210 - type instance Apply BSym0 t0123456789876543210 = BSym1 t0123456789876543210 - type CSym4 (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: b0123456789876543210) (t0123456789876543210 :: c0123456789876543210) (t0123456789876543210 :: d0123456789876543210) = - C t0123456789876543210 t0123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (CSym3 t0123456789876543210 t0123456789876543210 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) CSym3KindInference) ()) - data CSym3 (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: b0123456789876543210) (t0123456789876543210 :: c0123456789876543210) :: forall d0123456789876543210. - (~>) d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) - where - CSym3KindInference :: forall t0123456789876543210 - t0123456789876543210 - t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (CSym3 t0123456789876543210 t0123456789876543210 t0123456789876543210) arg) (CSym4 t0123456789876543210 t0123456789876543210 t0123456789876543210 arg) => - CSym3 t0123456789876543210 t0123456789876543210 t0123456789876543210 t0123456789876543210 - type instance Apply (CSym3 t0123456789876543210 t0123456789876543210 t0123456789876543210) t0123456789876543210 = C t0123456789876543210 t0123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (CSym2 t0123456789876543210 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) CSym2KindInference) ()) - data CSym2 (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: b0123456789876543210) :: forall c0123456789876543210 - d0123456789876543210. - (~>) c0123456789876543210 ((~>) d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210)) - where - CSym2KindInference :: forall t0123456789876543210 - t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (CSym2 t0123456789876543210 t0123456789876543210) arg) (CSym3 t0123456789876543210 t0123456789876543210 arg) => - CSym2 t0123456789876543210 t0123456789876543210 t0123456789876543210 - type instance Apply (CSym2 t0123456789876543210 t0123456789876543210) t0123456789876543210 = CSym3 t0123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (CSym1 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) CSym1KindInference) ()) - data CSym1 (t0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210 - c0123456789876543210 - d0123456789876543210. - (~>) b0123456789876543210 ((~>) c0123456789876543210 ((~>) d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210))) - where - CSym1KindInference :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (CSym1 t0123456789876543210) arg) (CSym2 t0123456789876543210 arg) => - CSym1 t0123456789876543210 t0123456789876543210 - type instance Apply (CSym1 t0123456789876543210) t0123456789876543210 = CSym2 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings CSym0 where - suppressUnusedWarnings = snd (((,) CSym0KindInference) ()) - data CSym0 :: forall a0123456789876543210 - b0123456789876543210 - c0123456789876543210 - d0123456789876543210. - (~>) a0123456789876543210 ((~>) b0123456789876543210 ((~>) c0123456789876543210 ((~>) d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210)))) - where - CSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply CSym0 arg) (CSym1 arg) => - CSym0 t0123456789876543210 - type instance Apply CSym0 t0123456789876543210 = CSym1 t0123456789876543210 - type DSym4 (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: b0123456789876543210) (t0123456789876543210 :: c0123456789876543210) (t0123456789876543210 :: d0123456789876543210) = - D t0123456789876543210 t0123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (DSym3 t0123456789876543210 t0123456789876543210 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) DSym3KindInference) ()) - data DSym3 (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: b0123456789876543210) (t0123456789876543210 :: c0123456789876543210) :: forall d0123456789876543210. - (~>) d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) - where - DSym3KindInference :: forall t0123456789876543210 - t0123456789876543210 - t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (DSym3 t0123456789876543210 t0123456789876543210 t0123456789876543210) arg) (DSym4 t0123456789876543210 t0123456789876543210 t0123456789876543210 arg) => - DSym3 t0123456789876543210 t0123456789876543210 t0123456789876543210 t0123456789876543210 - type instance Apply (DSym3 t0123456789876543210 t0123456789876543210 t0123456789876543210) t0123456789876543210 = D t0123456789876543210 t0123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (DSym2 t0123456789876543210 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) DSym2KindInference) ()) - data DSym2 (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: b0123456789876543210) :: forall c0123456789876543210 - d0123456789876543210. - (~>) c0123456789876543210 ((~>) d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210)) - where - DSym2KindInference :: forall t0123456789876543210 - t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (DSym2 t0123456789876543210 t0123456789876543210) arg) (DSym3 t0123456789876543210 t0123456789876543210 arg) => - DSym2 t0123456789876543210 t0123456789876543210 t0123456789876543210 - type instance Apply (DSym2 t0123456789876543210 t0123456789876543210) t0123456789876543210 = DSym3 t0123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (DSym1 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) DSym1KindInference) ()) - data DSym1 (t0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210 - c0123456789876543210 - d0123456789876543210. - (~>) b0123456789876543210 ((~>) c0123456789876543210 ((~>) d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210))) - where - DSym1KindInference :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (DSym1 t0123456789876543210) arg) (DSym2 t0123456789876543210 arg) => - DSym1 t0123456789876543210 t0123456789876543210 - type instance Apply (DSym1 t0123456789876543210) t0123456789876543210 = DSym2 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings DSym0 where - suppressUnusedWarnings = snd (((,) DSym0KindInference) ()) - data DSym0 :: forall a0123456789876543210 - b0123456789876543210 - c0123456789876543210 - d0123456789876543210. - (~>) a0123456789876543210 ((~>) b0123456789876543210 ((~>) c0123456789876543210 ((~>) d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210)))) - where - DSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply DSym0 arg) (DSym1 arg) => - DSym0 t0123456789876543210 - type instance Apply DSym0 t0123456789876543210 = DSym1 t0123456789876543210 - type ESym4 (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: b0123456789876543210) (t0123456789876543210 :: c0123456789876543210) (t0123456789876543210 :: d0123456789876543210) = - E t0123456789876543210 t0123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (ESym3 t0123456789876543210 t0123456789876543210 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) ESym3KindInference) ()) - data ESym3 (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: b0123456789876543210) (t0123456789876543210 :: c0123456789876543210) :: forall d0123456789876543210. - (~>) d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) - where - ESym3KindInference :: forall t0123456789876543210 - t0123456789876543210 - t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (ESym3 t0123456789876543210 t0123456789876543210 t0123456789876543210) arg) (ESym4 t0123456789876543210 t0123456789876543210 t0123456789876543210 arg) => - ESym3 t0123456789876543210 t0123456789876543210 t0123456789876543210 t0123456789876543210 - type instance Apply (ESym3 t0123456789876543210 t0123456789876543210 t0123456789876543210) t0123456789876543210 = E t0123456789876543210 t0123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (ESym2 t0123456789876543210 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) ESym2KindInference) ()) - data ESym2 (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: b0123456789876543210) :: forall c0123456789876543210 - d0123456789876543210. - (~>) c0123456789876543210 ((~>) d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210)) - where - ESym2KindInference :: forall t0123456789876543210 - t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (ESym2 t0123456789876543210 t0123456789876543210) arg) (ESym3 t0123456789876543210 t0123456789876543210 arg) => - ESym2 t0123456789876543210 t0123456789876543210 t0123456789876543210 - type instance Apply (ESym2 t0123456789876543210 t0123456789876543210) t0123456789876543210 = ESym3 t0123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (ESym1 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) ESym1KindInference) ()) - data ESym1 (t0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210 - c0123456789876543210 - d0123456789876543210. - (~>) b0123456789876543210 ((~>) c0123456789876543210 ((~>) d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210))) - where - ESym1KindInference :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (ESym1 t0123456789876543210) arg) (ESym2 t0123456789876543210 arg) => - ESym1 t0123456789876543210 t0123456789876543210 - type instance Apply (ESym1 t0123456789876543210) t0123456789876543210 = ESym2 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings ESym0 where - suppressUnusedWarnings = snd (((,) ESym0KindInference) ()) - data ESym0 :: forall a0123456789876543210 - b0123456789876543210 - c0123456789876543210 - d0123456789876543210. - (~>) a0123456789876543210 ((~>) b0123456789876543210 ((~>) c0123456789876543210 ((~>) d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210)))) - where - ESym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply ESym0 arg) (ESym1 arg) => - ESym0 t0123456789876543210 - type instance Apply ESym0 t0123456789876543210 = ESym1 t0123456789876543210 - type FSym4 (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: b0123456789876543210) (t0123456789876543210 :: c0123456789876543210) (t0123456789876543210 :: d0123456789876543210) = - F t0123456789876543210 t0123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (FSym3 t0123456789876543210 t0123456789876543210 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) FSym3KindInference) ()) - data FSym3 (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: b0123456789876543210) (t0123456789876543210 :: c0123456789876543210) :: forall d0123456789876543210. - (~>) d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) - where - FSym3KindInference :: forall t0123456789876543210 - t0123456789876543210 - t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (FSym3 t0123456789876543210 t0123456789876543210 t0123456789876543210) arg) (FSym4 t0123456789876543210 t0123456789876543210 t0123456789876543210 arg) => - FSym3 t0123456789876543210 t0123456789876543210 t0123456789876543210 t0123456789876543210 - type instance Apply (FSym3 t0123456789876543210 t0123456789876543210 t0123456789876543210) t0123456789876543210 = F t0123456789876543210 t0123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (FSym2 t0123456789876543210 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) FSym2KindInference) ()) - data FSym2 (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: b0123456789876543210) :: forall c0123456789876543210 - d0123456789876543210. - (~>) c0123456789876543210 ((~>) d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210)) - where - FSym2KindInference :: forall t0123456789876543210 - t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (FSym2 t0123456789876543210 t0123456789876543210) arg) (FSym3 t0123456789876543210 t0123456789876543210 arg) => - FSym2 t0123456789876543210 t0123456789876543210 t0123456789876543210 - type instance Apply (FSym2 t0123456789876543210 t0123456789876543210) t0123456789876543210 = FSym3 t0123456789876543210 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (FSym1 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) FSym1KindInference) ()) - data FSym1 (t0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210 - c0123456789876543210 - d0123456789876543210. - (~>) b0123456789876543210 ((~>) c0123456789876543210 ((~>) d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210))) - where - FSym1KindInference :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (FSym1 t0123456789876543210) arg) (FSym2 t0123456789876543210 arg) => - FSym1 t0123456789876543210 t0123456789876543210 - type instance Apply (FSym1 t0123456789876543210) t0123456789876543210 = FSym2 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings FSym0 where - suppressUnusedWarnings = snd (((,) FSym0KindInference) ()) - data FSym0 :: forall a0123456789876543210 - b0123456789876543210 - c0123456789876543210 - d0123456789876543210. - (~>) a0123456789876543210 ((~>) b0123456789876543210 ((~>) c0123456789876543210 ((~>) d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210)))) - where - FSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply FSym0 arg) (FSym1 arg) => - FSym0 t0123456789876543210 - type instance Apply FSym0 t0123456789876543210 = FSym1 t0123456789876543210 - type family Compare_0123456789876543210 (a :: Nat) (a :: Nat) :: Ordering where - Compare_0123456789876543210 Zero Zero = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) '[] - Compare_0123456789876543210 (Succ a_0123456789876543210) (Succ b_0123456789876543210) = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) '[]) - Compare_0123456789876543210 Zero (Succ _) = LTSym0 - Compare_0123456789876543210 (Succ _) Zero = GTSym0 - type Compare_0123456789876543210Sym2 (a0123456789876543210 :: Nat) (a0123456789876543210 :: Nat) = - Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Compare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym1KindInference) ()) - data Compare_0123456789876543210Sym1 (a0123456789876543210 :: Nat) :: (~>) Nat Ordering - where - Compare_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Compare_0123456789876543210Sym1 a0123456789876543210) arg) (Compare_0123456789876543210Sym2 a0123456789876543210 arg) => - Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Compare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Compare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym0KindInference) ()) - data Compare_0123456789876543210Sym0 :: (~>) Nat ((~>) Nat Ordering) - where - Compare_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Compare_0123456789876543210Sym0 arg) (Compare_0123456789876543210Sym1 arg) => - Compare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Compare_0123456789876543210Sym0 a0123456789876543210 = Compare_0123456789876543210Sym1 a0123456789876543210 - instance POrd Nat where - type Compare a a = Apply (Apply Compare_0123456789876543210Sym0 a) a - type family Compare_0123456789876543210 (a :: Foo a b c d) (a :: Foo a b c d) :: Ordering where - Compare_0123456789876543210 (A a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210) (A b_0123456789876543210 b_0123456789876543210 b_0123456789876543210 b_0123456789876543210) = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) '[])))) - Compare_0123456789876543210 (B a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210) (B b_0123456789876543210 b_0123456789876543210 b_0123456789876543210 b_0123456789876543210) = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) '[])))) - Compare_0123456789876543210 (C a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210) (C b_0123456789876543210 b_0123456789876543210 b_0123456789876543210 b_0123456789876543210) = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) '[])))) - Compare_0123456789876543210 (D a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210) (D b_0123456789876543210 b_0123456789876543210 b_0123456789876543210 b_0123456789876543210) = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) '[])))) - Compare_0123456789876543210 (E a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210) (E b_0123456789876543210 b_0123456789876543210 b_0123456789876543210 b_0123456789876543210) = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) '[])))) - Compare_0123456789876543210 (F a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210) (F b_0123456789876543210 b_0123456789876543210 b_0123456789876543210 b_0123456789876543210) = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) '[])))) - Compare_0123456789876543210 (A _ _ _ _) (B _ _ _ _) = LTSym0 - Compare_0123456789876543210 (A _ _ _ _) (C _ _ _ _) = LTSym0 - Compare_0123456789876543210 (A _ _ _ _) (D _ _ _ _) = LTSym0 - Compare_0123456789876543210 (A _ _ _ _) (E _ _ _ _) = LTSym0 - Compare_0123456789876543210 (A _ _ _ _) (F _ _ _ _) = LTSym0 - Compare_0123456789876543210 (B _ _ _ _) (A _ _ _ _) = GTSym0 - Compare_0123456789876543210 (B _ _ _ _) (C _ _ _ _) = LTSym0 - Compare_0123456789876543210 (B _ _ _ _) (D _ _ _ _) = LTSym0 - Compare_0123456789876543210 (B _ _ _ _) (E _ _ _ _) = LTSym0 - Compare_0123456789876543210 (B _ _ _ _) (F _ _ _ _) = LTSym0 - Compare_0123456789876543210 (C _ _ _ _) (A _ _ _ _) = GTSym0 - Compare_0123456789876543210 (C _ _ _ _) (B _ _ _ _) = GTSym0 - Compare_0123456789876543210 (C _ _ _ _) (D _ _ _ _) = LTSym0 - Compare_0123456789876543210 (C _ _ _ _) (E _ _ _ _) = LTSym0 - Compare_0123456789876543210 (C _ _ _ _) (F _ _ _ _) = LTSym0 - Compare_0123456789876543210 (D _ _ _ _) (A _ _ _ _) = GTSym0 - Compare_0123456789876543210 (D _ _ _ _) (B _ _ _ _) = GTSym0 - Compare_0123456789876543210 (D _ _ _ _) (C _ _ _ _) = GTSym0 - Compare_0123456789876543210 (D _ _ _ _) (E _ _ _ _) = LTSym0 - Compare_0123456789876543210 (D _ _ _ _) (F _ _ _ _) = LTSym0 - Compare_0123456789876543210 (E _ _ _ _) (A _ _ _ _) = GTSym0 - Compare_0123456789876543210 (E _ _ _ _) (B _ _ _ _) = GTSym0 - Compare_0123456789876543210 (E _ _ _ _) (C _ _ _ _) = GTSym0 - Compare_0123456789876543210 (E _ _ _ _) (D _ _ _ _) = GTSym0 - Compare_0123456789876543210 (E _ _ _ _) (F _ _ _ _) = LTSym0 - Compare_0123456789876543210 (F _ _ _ _) (A _ _ _ _) = GTSym0 - Compare_0123456789876543210 (F _ _ _ _) (B _ _ _ _) = GTSym0 - Compare_0123456789876543210 (F _ _ _ _) (C _ _ _ _) = GTSym0 - Compare_0123456789876543210 (F _ _ _ _) (D _ _ _ _) = GTSym0 - Compare_0123456789876543210 (F _ _ _ _) (E _ _ _ _) = GTSym0 - type Compare_0123456789876543210Sym2 (a0123456789876543210 :: Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) (a0123456789876543210 :: Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) = - Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Compare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym1KindInference) ()) - data Compare_0123456789876543210Sym1 (a0123456789876543210 :: Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) :: (~>) (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) Ordering - where - Compare_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Compare_0123456789876543210Sym1 a0123456789876543210) arg) (Compare_0123456789876543210Sym2 a0123456789876543210 arg) => - Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Compare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Compare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym0KindInference) ()) - data Compare_0123456789876543210Sym0 :: forall a0123456789876543210 - b0123456789876543210 - c0123456789876543210 - d0123456789876543210. - (~>) (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) ((~>) (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) Ordering) - where - Compare_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Compare_0123456789876543210Sym0 arg) (Compare_0123456789876543210Sym1 arg) => - Compare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Compare_0123456789876543210Sym0 a0123456789876543210 = Compare_0123456789876543210Sym1 a0123456789876543210 - instance POrd (Foo a b c d) where - type Compare a a = Apply (Apply Compare_0123456789876543210Sym0 a) a - type family Equals_0123456789876543210 (a :: Nat) (b :: Nat) :: Bool where - Equals_0123456789876543210 Zero Zero = TrueSym0 - Equals_0123456789876543210 (Succ a) (Succ b) = (==) a b - Equals_0123456789876543210 (_ :: Nat) (_ :: Nat) = FalseSym0 - instance PEq Nat where - type (==) a b = Equals_0123456789876543210 a b - type family Equals_0123456789876543210 (a :: Foo a b c d) (b :: Foo a b c d) :: Bool where - Equals_0123456789876543210 (A a a a a) (A b b b b) = (&&) ((==) a b) ((&&) ((==) a b) ((&&) ((==) a b) ((==) a b))) - Equals_0123456789876543210 (B a a a a) (B b b b b) = (&&) ((==) a b) ((&&) ((==) a b) ((&&) ((==) a b) ((==) a b))) - Equals_0123456789876543210 (C a a a a) (C b b b b) = (&&) ((==) a b) ((&&) ((==) a b) ((&&) ((==) a b) ((==) a b))) - Equals_0123456789876543210 (D a a a a) (D b b b b) = (&&) ((==) a b) ((&&) ((==) a b) ((&&) ((==) a b) ((==) a b))) - Equals_0123456789876543210 (E a a a a) (E b b b b) = (&&) ((==) a b) ((&&) ((==) a b) ((&&) ((==) a b) ((==) a b))) - Equals_0123456789876543210 (F a a a a) (F b b b b) = (&&) ((==) a b) ((&&) ((==) a b) ((&&) ((==) a b) ((==) a b))) - Equals_0123456789876543210 (_ :: Foo a b c d) (_ :: Foo a b c d) = FalseSym0 - instance PEq (Foo a b c d) where - type (==) a b = Equals_0123456789876543210 a b - data SNat :: Nat -> GHC.Types.Type - where - SZero :: SNat Zero - SSucc :: forall (n :: Nat). (Sing (n :: Nat)) -> SNat (Succ n) - type instance Sing @Nat = SNat - instance SingKind Nat where - type Demote Nat = Nat - fromSing SZero = Zero - fromSing (SSucc b) = Succ (fromSing b) - toSing Zero = SomeSing SZero - toSing (Succ (b :: Demote Nat)) - = case toSing b :: SomeSing Nat of { - SomeSing c -> SomeSing (SSucc c) } - data SFoo :: forall a b c d. Foo a b c d -> GHC.Types.Type - where - SA :: forall a b c d (n :: a) (n :: b) (n :: c) (n :: d). - (Sing (n :: a)) - -> (Sing (n :: b)) - -> (Sing (n :: c)) -> (Sing (n :: d)) -> SFoo (A n n n n) - SB :: forall a b c d (n :: a) (n :: b) (n :: c) (n :: d). - (Sing (n :: a)) - -> (Sing (n :: b)) - -> (Sing (n :: c)) -> (Sing (n :: d)) -> SFoo (B n n n n) - SC :: forall a b c d (n :: a) (n :: b) (n :: c) (n :: d). - (Sing (n :: a)) - -> (Sing (n :: b)) - -> (Sing (n :: c)) -> (Sing (n :: d)) -> SFoo (C n n n n) - SD :: forall a b c d (n :: a) (n :: b) (n :: c) (n :: d). - (Sing (n :: a)) - -> (Sing (n :: b)) - -> (Sing (n :: c)) -> (Sing (n :: d)) -> SFoo (D n n n n) - SE :: forall a b c d (n :: a) (n :: b) (n :: c) (n :: d). - (Sing (n :: a)) - -> (Sing (n :: b)) - -> (Sing (n :: c)) -> (Sing (n :: d)) -> SFoo (E n n n n) - SF :: forall a b c d (n :: a) (n :: b) (n :: c) (n :: d). - (Sing (n :: a)) - -> (Sing (n :: b)) - -> (Sing (n :: c)) -> (Sing (n :: d)) -> SFoo (F n n n n) - type instance Sing @(Foo a b c d) = SFoo - instance (SingKind a, SingKind b, SingKind c, SingKind d) => - SingKind (Foo a b c d) where - type Demote (Foo a b c d) = Foo (Demote a) (Demote b) (Demote c) (Demote d) - fromSing (SA b b b b) - = (((A (fromSing b)) (fromSing b)) (fromSing b)) (fromSing b) - fromSing (SB b b b b) - = (((B (fromSing b)) (fromSing b)) (fromSing b)) (fromSing b) - fromSing (SC b b b b) - = (((C (fromSing b)) (fromSing b)) (fromSing b)) (fromSing b) - fromSing (SD b b b b) - = (((D (fromSing b)) (fromSing b)) (fromSing b)) (fromSing b) - fromSing (SE b b b b) - = (((E (fromSing b)) (fromSing b)) (fromSing b)) (fromSing b) - fromSing (SF b b b b) - = (((F (fromSing b)) (fromSing b)) (fromSing b)) (fromSing b) - toSing - (A (b :: Demote a) (b :: Demote b) (b :: Demote c) (b :: Demote d)) - = case - ((((,,,) (toSing b :: SomeSing a)) (toSing b :: SomeSing b)) - (toSing b :: SomeSing c)) - (toSing b :: SomeSing d) - of { - (,,,) (SomeSing c) (SomeSing c) (SomeSing c) (SomeSing c) - -> SomeSing ((((SA c) c) c) c) } - toSing - (B (b :: Demote a) (b :: Demote b) (b :: Demote c) (b :: Demote d)) - = case - ((((,,,) (toSing b :: SomeSing a)) (toSing b :: SomeSing b)) - (toSing b :: SomeSing c)) - (toSing b :: SomeSing d) - of { - (,,,) (SomeSing c) (SomeSing c) (SomeSing c) (SomeSing c) - -> SomeSing ((((SB c) c) c) c) } - toSing - (C (b :: Demote a) (b :: Demote b) (b :: Demote c) (b :: Demote d)) - = case - ((((,,,) (toSing b :: SomeSing a)) (toSing b :: SomeSing b)) - (toSing b :: SomeSing c)) - (toSing b :: SomeSing d) - of { - (,,,) (SomeSing c) (SomeSing c) (SomeSing c) (SomeSing c) - -> SomeSing ((((SC c) c) c) c) } - toSing - (D (b :: Demote a) (b :: Demote b) (b :: Demote c) (b :: Demote d)) - = case - ((((,,,) (toSing b :: SomeSing a)) (toSing b :: SomeSing b)) - (toSing b :: SomeSing c)) - (toSing b :: SomeSing d) - of { - (,,,) (SomeSing c) (SomeSing c) (SomeSing c) (SomeSing c) - -> SomeSing ((((SD c) c) c) c) } - toSing - (E (b :: Demote a) (b :: Demote b) (b :: Demote c) (b :: Demote d)) - = case - ((((,,,) (toSing b :: SomeSing a)) (toSing b :: SomeSing b)) - (toSing b :: SomeSing c)) - (toSing b :: SomeSing d) - of { - (,,,) (SomeSing c) (SomeSing c) (SomeSing c) (SomeSing c) - -> SomeSing ((((SE c) c) c) c) } - toSing - (F (b :: Demote a) (b :: Demote b) (b :: Demote c) (b :: Demote d)) - = case - ((((,,,) (toSing b :: SomeSing a)) (toSing b :: SomeSing b)) - (toSing b :: SomeSing c)) - (toSing b :: SomeSing d) - of { - (,,,) (SomeSing c) (SomeSing c) (SomeSing c) (SomeSing c) - -> SomeSing ((((SF c) c) c) c) } - instance SOrd Nat => SOrd Nat where - sCompare :: - forall (t1 :: Nat) (t2 :: Nat). - Sing t1 - -> Sing t2 - -> Sing (Apply (Apply (CompareSym0 :: TyFun Nat ((~>) Nat Ordering) - -> GHC.Types.Type) t1) t2) - sCompare SZero SZero - = (applySing - ((applySing - ((applySing ((singFun3 @FoldlSym0) sFoldl)) - ((singFun2 @ThenCmpSym0) sThenCmp))) - SEQ)) - SNil - sCompare - (SSucc (sA_0123456789876543210 :: Sing a_0123456789876543210)) - (SSucc (sB_0123456789876543210 :: Sing b_0123456789876543210)) - = (applySing - ((applySing - ((applySing ((singFun3 @FoldlSym0) sFoldl)) - ((singFun2 @ThenCmpSym0) sThenCmp))) - SEQ)) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing - ((applySing ((singFun2 @CompareSym0) sCompare)) - sA_0123456789876543210)) - sB_0123456789876543210))) - SNil) - sCompare SZero (SSucc _) = SLT - sCompare (SSucc _) SZero = SGT - instance (SOrd a, SOrd b, SOrd c, SOrd d) => - SOrd (Foo a b c d) where - sCompare :: - forall (t1 :: Foo a b c d) (t2 :: Foo a b c d). - Sing t1 - -> Sing t2 - -> Sing (Apply (Apply (CompareSym0 :: TyFun (Foo a b c d) ((~>) (Foo a b c d) Ordering) - -> GHC.Types.Type) t1) t2) - sCompare - (SA (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210)) - (SA (sB_0123456789876543210 :: Sing b_0123456789876543210) - (sB_0123456789876543210 :: Sing b_0123456789876543210) - (sB_0123456789876543210 :: Sing b_0123456789876543210) - (sB_0123456789876543210 :: Sing b_0123456789876543210)) - = (applySing - ((applySing - ((applySing ((singFun3 @FoldlSym0) sFoldl)) - ((singFun2 @ThenCmpSym0) sThenCmp))) - SEQ)) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing - ((applySing ((singFun2 @CompareSym0) sCompare)) - sA_0123456789876543210)) - sB_0123456789876543210))) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing - ((applySing ((singFun2 @CompareSym0) sCompare)) - sA_0123456789876543210)) - sB_0123456789876543210))) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing - ((applySing ((singFun2 @CompareSym0) sCompare)) - sA_0123456789876543210)) - sB_0123456789876543210))) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing - ((applySing ((singFun2 @CompareSym0) sCompare)) - sA_0123456789876543210)) - sB_0123456789876543210))) - SNil)))) - sCompare - (SB (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210)) - (SB (sB_0123456789876543210 :: Sing b_0123456789876543210) - (sB_0123456789876543210 :: Sing b_0123456789876543210) - (sB_0123456789876543210 :: Sing b_0123456789876543210) - (sB_0123456789876543210 :: Sing b_0123456789876543210)) - = (applySing - ((applySing - ((applySing ((singFun3 @FoldlSym0) sFoldl)) - ((singFun2 @ThenCmpSym0) sThenCmp))) - SEQ)) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing - ((applySing ((singFun2 @CompareSym0) sCompare)) - sA_0123456789876543210)) - sB_0123456789876543210))) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing - ((applySing ((singFun2 @CompareSym0) sCompare)) - sA_0123456789876543210)) - sB_0123456789876543210))) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing - ((applySing ((singFun2 @CompareSym0) sCompare)) - sA_0123456789876543210)) - sB_0123456789876543210))) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing - ((applySing ((singFun2 @CompareSym0) sCompare)) - sA_0123456789876543210)) - sB_0123456789876543210))) - SNil)))) - sCompare - (SC (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210)) - (SC (sB_0123456789876543210 :: Sing b_0123456789876543210) - (sB_0123456789876543210 :: Sing b_0123456789876543210) - (sB_0123456789876543210 :: Sing b_0123456789876543210) - (sB_0123456789876543210 :: Sing b_0123456789876543210)) - = (applySing - ((applySing - ((applySing ((singFun3 @FoldlSym0) sFoldl)) - ((singFun2 @ThenCmpSym0) sThenCmp))) - SEQ)) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing - ((applySing ((singFun2 @CompareSym0) sCompare)) - sA_0123456789876543210)) - sB_0123456789876543210))) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing - ((applySing ((singFun2 @CompareSym0) sCompare)) - sA_0123456789876543210)) - sB_0123456789876543210))) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing - ((applySing ((singFun2 @CompareSym0) sCompare)) - sA_0123456789876543210)) - sB_0123456789876543210))) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing - ((applySing ((singFun2 @CompareSym0) sCompare)) - sA_0123456789876543210)) - sB_0123456789876543210))) - SNil)))) - sCompare - (SD (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210)) - (SD (sB_0123456789876543210 :: Sing b_0123456789876543210) - (sB_0123456789876543210 :: Sing b_0123456789876543210) - (sB_0123456789876543210 :: Sing b_0123456789876543210) - (sB_0123456789876543210 :: Sing b_0123456789876543210)) - = (applySing - ((applySing - ((applySing ((singFun3 @FoldlSym0) sFoldl)) - ((singFun2 @ThenCmpSym0) sThenCmp))) - SEQ)) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing - ((applySing ((singFun2 @CompareSym0) sCompare)) - sA_0123456789876543210)) - sB_0123456789876543210))) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing - ((applySing ((singFun2 @CompareSym0) sCompare)) - sA_0123456789876543210)) - sB_0123456789876543210))) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing - ((applySing ((singFun2 @CompareSym0) sCompare)) - sA_0123456789876543210)) - sB_0123456789876543210))) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing - ((applySing ((singFun2 @CompareSym0) sCompare)) - sA_0123456789876543210)) - sB_0123456789876543210))) - SNil)))) - sCompare - (SE (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210)) - (SE (sB_0123456789876543210 :: Sing b_0123456789876543210) - (sB_0123456789876543210 :: Sing b_0123456789876543210) - (sB_0123456789876543210 :: Sing b_0123456789876543210) - (sB_0123456789876543210 :: Sing b_0123456789876543210)) - = (applySing - ((applySing - ((applySing ((singFun3 @FoldlSym0) sFoldl)) - ((singFun2 @ThenCmpSym0) sThenCmp))) - SEQ)) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing - ((applySing ((singFun2 @CompareSym0) sCompare)) - sA_0123456789876543210)) - sB_0123456789876543210))) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing - ((applySing ((singFun2 @CompareSym0) sCompare)) - sA_0123456789876543210)) - sB_0123456789876543210))) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing - ((applySing ((singFun2 @CompareSym0) sCompare)) - sA_0123456789876543210)) - sB_0123456789876543210))) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing - ((applySing ((singFun2 @CompareSym0) sCompare)) - sA_0123456789876543210)) - sB_0123456789876543210))) - SNil)))) - sCompare - (SF (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210)) - (SF (sB_0123456789876543210 :: Sing b_0123456789876543210) - (sB_0123456789876543210 :: Sing b_0123456789876543210) - (sB_0123456789876543210 :: Sing b_0123456789876543210) - (sB_0123456789876543210 :: Sing b_0123456789876543210)) - = (applySing - ((applySing - ((applySing ((singFun3 @FoldlSym0) sFoldl)) - ((singFun2 @ThenCmpSym0) sThenCmp))) - SEQ)) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing - ((applySing ((singFun2 @CompareSym0) sCompare)) - sA_0123456789876543210)) - sB_0123456789876543210))) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing - ((applySing ((singFun2 @CompareSym0) sCompare)) - sA_0123456789876543210)) - sB_0123456789876543210))) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing - ((applySing ((singFun2 @CompareSym0) sCompare)) - sA_0123456789876543210)) - sB_0123456789876543210))) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing - ((applySing ((singFun2 @CompareSym0) sCompare)) - sA_0123456789876543210)) - sB_0123456789876543210))) - SNil)))) - sCompare (SA _ _ _ _) (SB _ _ _ _) = SLT - sCompare (SA _ _ _ _) (SC _ _ _ _) = SLT - sCompare (SA _ _ _ _) (SD _ _ _ _) = SLT - sCompare (SA _ _ _ _) (SE _ _ _ _) = SLT - sCompare (SA _ _ _ _) (SF _ _ _ _) = SLT - sCompare (SB _ _ _ _) (SA _ _ _ _) = SGT - sCompare (SB _ _ _ _) (SC _ _ _ _) = SLT - sCompare (SB _ _ _ _) (SD _ _ _ _) = SLT - sCompare (SB _ _ _ _) (SE _ _ _ _) = SLT - sCompare (SB _ _ _ _) (SF _ _ _ _) = SLT - sCompare (SC _ _ _ _) (SA _ _ _ _) = SGT - sCompare (SC _ _ _ _) (SB _ _ _ _) = SGT - sCompare (SC _ _ _ _) (SD _ _ _ _) = SLT - sCompare (SC _ _ _ _) (SE _ _ _ _) = SLT - sCompare (SC _ _ _ _) (SF _ _ _ _) = SLT - sCompare (SD _ _ _ _) (SA _ _ _ _) = SGT - sCompare (SD _ _ _ _) (SB _ _ _ _) = SGT - sCompare (SD _ _ _ _) (SC _ _ _ _) = SGT - sCompare (SD _ _ _ _) (SE _ _ _ _) = SLT - sCompare (SD _ _ _ _) (SF _ _ _ _) = SLT - sCompare (SE _ _ _ _) (SA _ _ _ _) = SGT - sCompare (SE _ _ _ _) (SB _ _ _ _) = SGT - sCompare (SE _ _ _ _) (SC _ _ _ _) = SGT - sCompare (SE _ _ _ _) (SD _ _ _ _) = SGT - sCompare (SE _ _ _ _) (SF _ _ _ _) = SLT - sCompare (SF _ _ _ _) (SA _ _ _ _) = SGT - sCompare (SF _ _ _ _) (SB _ _ _ _) = SGT - sCompare (SF _ _ _ _) (SC _ _ _ _) = SGT - sCompare (SF _ _ _ _) (SD _ _ _ _) = SGT - sCompare (SF _ _ _ _) (SE _ _ _ _) = SGT - instance SEq Nat => SEq Nat where - (%==) SZero SZero = STrue - (%==) SZero (SSucc _) = SFalse - (%==) (SSucc _) SZero = SFalse - (%==) (SSucc a) (SSucc b) = ((%==) a) b - instance SDecide Nat => SDecide Nat where - (%~) SZero SZero = Proved Refl - (%~) SZero (SSucc _) = Disproved (\ x -> case x of) - (%~) (SSucc _) SZero = Disproved (\ x -> case x of) - (%~) (SSucc a) (SSucc b) - = case ((%~) a) b of - Proved Refl -> Proved Refl - Disproved contra - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - instance SDecide Nat => - Data.Type.Equality.TestEquality (SNat :: Nat - -> GHC.Types.Type) where - Data.Type.Equality.testEquality - = Data.Singletons.Decide.decideEquality - instance SDecide Nat => - Data.Type.Coercion.TestCoercion (SNat :: Nat - -> GHC.Types.Type) where - Data.Type.Coercion.testCoercion - = Data.Singletons.Decide.decideCoercion - instance (SEq a, SEq b, SEq c, SEq d) => SEq (Foo a b c d) where - (%==) (SA a a a a) (SA b b b b) - = ((%&&) (((%==) a) b)) - (((%&&) (((%==) a) b)) (((%&&) (((%==) a) b)) (((%==) a) b))) - (%==) (SA _ _ _ _) (SB _ _ _ _) = SFalse - (%==) (SA _ _ _ _) (SC _ _ _ _) = SFalse - (%==) (SA _ _ _ _) (SD _ _ _ _) = SFalse - (%==) (SA _ _ _ _) (SE _ _ _ _) = SFalse - (%==) (SA _ _ _ _) (SF _ _ _ _) = SFalse - (%==) (SB _ _ _ _) (SA _ _ _ _) = SFalse - (%==) (SB a a a a) (SB b b b b) - = ((%&&) (((%==) a) b)) - (((%&&) (((%==) a) b)) (((%&&) (((%==) a) b)) (((%==) a) b))) - (%==) (SB _ _ _ _) (SC _ _ _ _) = SFalse - (%==) (SB _ _ _ _) (SD _ _ _ _) = SFalse - (%==) (SB _ _ _ _) (SE _ _ _ _) = SFalse - (%==) (SB _ _ _ _) (SF _ _ _ _) = SFalse - (%==) (SC _ _ _ _) (SA _ _ _ _) = SFalse - (%==) (SC _ _ _ _) (SB _ _ _ _) = SFalse - (%==) (SC a a a a) (SC b b b b) - = ((%&&) (((%==) a) b)) - (((%&&) (((%==) a) b)) (((%&&) (((%==) a) b)) (((%==) a) b))) - (%==) (SC _ _ _ _) (SD _ _ _ _) = SFalse - (%==) (SC _ _ _ _) (SE _ _ _ _) = SFalse - (%==) (SC _ _ _ _) (SF _ _ _ _) = SFalse - (%==) (SD _ _ _ _) (SA _ _ _ _) = SFalse - (%==) (SD _ _ _ _) (SB _ _ _ _) = SFalse - (%==) (SD _ _ _ _) (SC _ _ _ _) = SFalse - (%==) (SD a a a a) (SD b b b b) - = ((%&&) (((%==) a) b)) - (((%&&) (((%==) a) b)) (((%&&) (((%==) a) b)) (((%==) a) b))) - (%==) (SD _ _ _ _) (SE _ _ _ _) = SFalse - (%==) (SD _ _ _ _) (SF _ _ _ _) = SFalse - (%==) (SE _ _ _ _) (SA _ _ _ _) = SFalse - (%==) (SE _ _ _ _) (SB _ _ _ _) = SFalse - (%==) (SE _ _ _ _) (SC _ _ _ _) = SFalse - (%==) (SE _ _ _ _) (SD _ _ _ _) = SFalse - (%==) (SE a a a a) (SE b b b b) - = ((%&&) (((%==) a) b)) - (((%&&) (((%==) a) b)) (((%&&) (((%==) a) b)) (((%==) a) b))) - (%==) (SE _ _ _ _) (SF _ _ _ _) = SFalse - (%==) (SF _ _ _ _) (SA _ _ _ _) = SFalse - (%==) (SF _ _ _ _) (SB _ _ _ _) = SFalse - (%==) (SF _ _ _ _) (SC _ _ _ _) = SFalse - (%==) (SF _ _ _ _) (SD _ _ _ _) = SFalse - (%==) (SF _ _ _ _) (SE _ _ _ _) = SFalse - (%==) (SF a a a a) (SF b b b b) - = ((%&&) (((%==) a) b)) - (((%&&) (((%==) a) b)) (((%&&) (((%==) a) b)) (((%==) a) b))) - instance (SDecide a, SDecide b, SDecide c, SDecide d) => - SDecide (Foo a b c d) where - (%~) (SA a a a a) (SA b b b b) - = case - ((((,,,) (((%~) a) b)) (((%~) a) b)) (((%~) a) b)) (((%~) a) b) - of - (,,,) (Proved Refl) (Proved Refl) (Proved Refl) (Proved Refl) - -> Proved Refl - (,,,) (Disproved contra) _ _ _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - (,,,) _ (Disproved contra) _ _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - (,,,) _ _ (Disproved contra) _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - (,,,) _ _ _ (Disproved contra) - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - (%~) (SA _ _ _ _) (SB _ _ _ _) = Disproved (\ x -> case x of) - (%~) (SA _ _ _ _) (SC _ _ _ _) = Disproved (\ x -> case x of) - (%~) (SA _ _ _ _) (SD _ _ _ _) = Disproved (\ x -> case x of) - (%~) (SA _ _ _ _) (SE _ _ _ _) = Disproved (\ x -> case x of) - (%~) (SA _ _ _ _) (SF _ _ _ _) = Disproved (\ x -> case x of) - (%~) (SB _ _ _ _) (SA _ _ _ _) = Disproved (\ x -> case x of) - (%~) (SB a a a a) (SB b b b b) - = case - ((((,,,) (((%~) a) b)) (((%~) a) b)) (((%~) a) b)) (((%~) a) b) - of - (,,,) (Proved Refl) (Proved Refl) (Proved Refl) (Proved Refl) - -> Proved Refl - (,,,) (Disproved contra) _ _ _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - (,,,) _ (Disproved contra) _ _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - (,,,) _ _ (Disproved contra) _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - (,,,) _ _ _ (Disproved contra) - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - (%~) (SB _ _ _ _) (SC _ _ _ _) = Disproved (\ x -> case x of) - (%~) (SB _ _ _ _) (SD _ _ _ _) = Disproved (\ x -> case x of) - (%~) (SB _ _ _ _) (SE _ _ _ _) = Disproved (\ x -> case x of) - (%~) (SB _ _ _ _) (SF _ _ _ _) = Disproved (\ x -> case x of) - (%~) (SC _ _ _ _) (SA _ _ _ _) = Disproved (\ x -> case x of) - (%~) (SC _ _ _ _) (SB _ _ _ _) = Disproved (\ x -> case x of) - (%~) (SC a a a a) (SC b b b b) - = case - ((((,,,) (((%~) a) b)) (((%~) a) b)) (((%~) a) b)) (((%~) a) b) - of - (,,,) (Proved Refl) (Proved Refl) (Proved Refl) (Proved Refl) - -> Proved Refl - (,,,) (Disproved contra) _ _ _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - (,,,) _ (Disproved contra) _ _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - (,,,) _ _ (Disproved contra) _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - (,,,) _ _ _ (Disproved contra) - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - (%~) (SC _ _ _ _) (SD _ _ _ _) = Disproved (\ x -> case x of) - (%~) (SC _ _ _ _) (SE _ _ _ _) = Disproved (\ x -> case x of) - (%~) (SC _ _ _ _) (SF _ _ _ _) = Disproved (\ x -> case x of) - (%~) (SD _ _ _ _) (SA _ _ _ _) = Disproved (\ x -> case x of) - (%~) (SD _ _ _ _) (SB _ _ _ _) = Disproved (\ x -> case x of) - (%~) (SD _ _ _ _) (SC _ _ _ _) = Disproved (\ x -> case x of) - (%~) (SD a a a a) (SD b b b b) - = case - ((((,,,) (((%~) a) b)) (((%~) a) b)) (((%~) a) b)) (((%~) a) b) - of - (,,,) (Proved Refl) (Proved Refl) (Proved Refl) (Proved Refl) - -> Proved Refl - (,,,) (Disproved contra) _ _ _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - (,,,) _ (Disproved contra) _ _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - (,,,) _ _ (Disproved contra) _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - (,,,) _ _ _ (Disproved contra) - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - (%~) (SD _ _ _ _) (SE _ _ _ _) = Disproved (\ x -> case x of) - (%~) (SD _ _ _ _) (SF _ _ _ _) = Disproved (\ x -> case x of) - (%~) (SE _ _ _ _) (SA _ _ _ _) = Disproved (\ x -> case x of) - (%~) (SE _ _ _ _) (SB _ _ _ _) = Disproved (\ x -> case x of) - (%~) (SE _ _ _ _) (SC _ _ _ _) = Disproved (\ x -> case x of) - (%~) (SE _ _ _ _) (SD _ _ _ _) = Disproved (\ x -> case x of) - (%~) (SE a a a a) (SE b b b b) - = case - ((((,,,) (((%~) a) b)) (((%~) a) b)) (((%~) a) b)) (((%~) a) b) - of - (,,,) (Proved Refl) (Proved Refl) (Proved Refl) (Proved Refl) - -> Proved Refl - (,,,) (Disproved contra) _ _ _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - (,,,) _ (Disproved contra) _ _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - (,,,) _ _ (Disproved contra) _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - (,,,) _ _ _ (Disproved contra) - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - (%~) (SE _ _ _ _) (SF _ _ _ _) = Disproved (\ x -> case x of) - (%~) (SF _ _ _ _) (SA _ _ _ _) = Disproved (\ x -> case x of) - (%~) (SF _ _ _ _) (SB _ _ _ _) = Disproved (\ x -> case x of) - (%~) (SF _ _ _ _) (SC _ _ _ _) = Disproved (\ x -> case x of) - (%~) (SF _ _ _ _) (SD _ _ _ _) = Disproved (\ x -> case x of) - (%~) (SF _ _ _ _) (SE _ _ _ _) = Disproved (\ x -> case x of) - (%~) (SF a a a a) (SF b b b b) - = case - ((((,,,) (((%~) a) b)) (((%~) a) b)) (((%~) a) b)) (((%~) a) b) - of - (,,,) (Proved Refl) (Proved Refl) (Proved Refl) (Proved Refl) - -> Proved Refl - (,,,) (Disproved contra) _ _ _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - (,,,) _ (Disproved contra) _ _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - (,,,) _ _ (Disproved contra) _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - (,,,) _ _ _ (Disproved contra) - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - instance (SDecide a, SDecide b, SDecide c, SDecide d) => - Data.Type.Equality.TestEquality (SFoo :: Foo a b c d - -> GHC.Types.Type) where - Data.Type.Equality.testEquality - = Data.Singletons.Decide.decideEquality - instance (SDecide a, SDecide b, SDecide c, SDecide d) => - Data.Type.Coercion.TestCoercion (SFoo :: Foo a b c d - -> GHC.Types.Type) where - Data.Type.Coercion.testCoercion - = Data.Singletons.Decide.decideCoercion - instance SingI Zero where - sing = SZero - instance SingI n => SingI (Succ (n :: Nat)) where - sing = SSucc sing - instance SingI (SuccSym0 :: (~>) Nat Nat) where - sing = (singFun1 @SuccSym0) SSucc - instance (SingI n, SingI n, SingI n, SingI n) => - SingI (A (n :: a) (n :: b) (n :: c) (n :: d)) where - sing = (((SA sing) sing) sing) sing - instance SingI (ASym0 :: (~>) a ((~>) b ((~>) c ((~>) d (Foo a b c d))))) where - sing = (singFun4 @ASym0) SA - instance SingI d => - SingI (ASym1 (d :: a) :: (~>) b ((~>) c ((~>) d (Foo a b c d)))) where - sing = (singFun3 @(ASym1 (d :: a))) (SA (sing @d)) - instance (SingI d, SingI d) => - SingI (ASym2 (d :: a) (d :: b) :: (~>) c ((~>) d (Foo a b c d))) where - sing - = (singFun2 @(ASym2 (d :: a) (d :: b))) ((SA (sing @d)) (sing @d)) - instance (SingI d, SingI d, SingI d) => - SingI (ASym3 (d :: a) (d :: b) (d :: c) :: (~>) d (Foo a b c d)) where - sing - = (singFun1 @(ASym3 (d :: a) (d :: b) (d :: c))) - (((SA (sing @d)) (sing @d)) (sing @d)) - instance (SingI n, SingI n, SingI n, SingI n) => - SingI (B (n :: a) (n :: b) (n :: c) (n :: d)) where - sing = (((SB sing) sing) sing) sing - instance SingI (BSym0 :: (~>) a ((~>) b ((~>) c ((~>) d (Foo a b c d))))) where - sing = (singFun4 @BSym0) SB - instance SingI d => - SingI (BSym1 (d :: a) :: (~>) b ((~>) c ((~>) d (Foo a b c d)))) where - sing = (singFun3 @(BSym1 (d :: a))) (SB (sing @d)) - instance (SingI d, SingI d) => - SingI (BSym2 (d :: a) (d :: b) :: (~>) c ((~>) d (Foo a b c d))) where - sing - = (singFun2 @(BSym2 (d :: a) (d :: b))) ((SB (sing @d)) (sing @d)) - instance (SingI d, SingI d, SingI d) => - SingI (BSym3 (d :: a) (d :: b) (d :: c) :: (~>) d (Foo a b c d)) where - sing - = (singFun1 @(BSym3 (d :: a) (d :: b) (d :: c))) - (((SB (sing @d)) (sing @d)) (sing @d)) - instance (SingI n, SingI n, SingI n, SingI n) => - SingI (C (n :: a) (n :: b) (n :: c) (n :: d)) where - sing = (((SC sing) sing) sing) sing - instance SingI (CSym0 :: (~>) a ((~>) b ((~>) c ((~>) d (Foo a b c d))))) where - sing = (singFun4 @CSym0) SC - instance SingI d => - SingI (CSym1 (d :: a) :: (~>) b ((~>) c ((~>) d (Foo a b c d)))) where - sing = (singFun3 @(CSym1 (d :: a))) (SC (sing @d)) - instance (SingI d, SingI d) => - SingI (CSym2 (d :: a) (d :: b) :: (~>) c ((~>) d (Foo a b c d))) where - sing - = (singFun2 @(CSym2 (d :: a) (d :: b))) ((SC (sing @d)) (sing @d)) - instance (SingI d, SingI d, SingI d) => - SingI (CSym3 (d :: a) (d :: b) (d :: c) :: (~>) d (Foo a b c d)) where - sing - = (singFun1 @(CSym3 (d :: a) (d :: b) (d :: c))) - (((SC (sing @d)) (sing @d)) (sing @d)) - instance (SingI n, SingI n, SingI n, SingI n) => - SingI (D (n :: a) (n :: b) (n :: c) (n :: d)) where - sing = (((SD sing) sing) sing) sing - instance SingI (DSym0 :: (~>) a ((~>) b ((~>) c ((~>) d (Foo a b c d))))) where - sing = (singFun4 @DSym0) SD - instance SingI d => - SingI (DSym1 (d :: a) :: (~>) b ((~>) c ((~>) d (Foo a b c d)))) where - sing = (singFun3 @(DSym1 (d :: a))) (SD (sing @d)) - instance (SingI d, SingI d) => - SingI (DSym2 (d :: a) (d :: b) :: (~>) c ((~>) d (Foo a b c d))) where - sing - = (singFun2 @(DSym2 (d :: a) (d :: b))) ((SD (sing @d)) (sing @d)) - instance (SingI d, SingI d, SingI d) => - SingI (DSym3 (d :: a) (d :: b) (d :: c) :: (~>) d (Foo a b c d)) where - sing - = (singFun1 @(DSym3 (d :: a) (d :: b) (d :: c))) - (((SD (sing @d)) (sing @d)) (sing @d)) - instance (SingI n, SingI n, SingI n, SingI n) => - SingI (E (n :: a) (n :: b) (n :: c) (n :: d)) where - sing = (((SE sing) sing) sing) sing - instance SingI (ESym0 :: (~>) a ((~>) b ((~>) c ((~>) d (Foo a b c d))))) where - sing = (singFun4 @ESym0) SE - instance SingI d => - SingI (ESym1 (d :: a) :: (~>) b ((~>) c ((~>) d (Foo a b c d)))) where - sing = (singFun3 @(ESym1 (d :: a))) (SE (sing @d)) - instance (SingI d, SingI d) => - SingI (ESym2 (d :: a) (d :: b) :: (~>) c ((~>) d (Foo a b c d))) where - sing - = (singFun2 @(ESym2 (d :: a) (d :: b))) ((SE (sing @d)) (sing @d)) - instance (SingI d, SingI d, SingI d) => - SingI (ESym3 (d :: a) (d :: b) (d :: c) :: (~>) d (Foo a b c d)) where - sing - = (singFun1 @(ESym3 (d :: a) (d :: b) (d :: c))) - (((SE (sing @d)) (sing @d)) (sing @d)) - instance (SingI n, SingI n, SingI n, SingI n) => - SingI (F (n :: a) (n :: b) (n :: c) (n :: d)) where - sing = (((SF sing) sing) sing) sing - instance SingI (FSym0 :: (~>) a ((~>) b ((~>) c ((~>) d (Foo a b c d))))) where - sing = (singFun4 @FSym0) SF - instance SingI d => - SingI (FSym1 (d :: a) :: (~>) b ((~>) c ((~>) d (Foo a b c d)))) where - sing = (singFun3 @(FSym1 (d :: a))) (SF (sing @d)) - instance (SingI d, SingI d) => - SingI (FSym2 (d :: a) (d :: b) :: (~>) c ((~>) d (Foo a b c d))) where - sing - = (singFun2 @(FSym2 (d :: a) (d :: b))) ((SF (sing @d)) (sing @d)) - instance (SingI d, SingI d, SingI d) => - SingI (FSym3 (d :: a) (d :: b) (d :: c) :: (~>) d (Foo a b c d)) where - sing - = (singFun1 @(FSym3 (d :: a) (d :: b) (d :: c))) - (((SF (sing @d)) (sing @d)) (sing @d)) diff --git a/tests/compile-and-dump/Singletons/OrdDeriving.hs b/tests/compile-and-dump/Singletons/OrdDeriving.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/OrdDeriving.hs +++ /dev/null @@ -1,58 +0,0 @@ -module Singletons.OrdDeriving where - -import Data.Singletons.Prelude -import Data.Singletons.TH - -$(singletons [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 - -foo3a :: Proxy (A 1 2 3 4 `Compare` A 1 2 3 4) -foo3a = Proxy - -foo3b :: Proxy EQ -foo3b = foo3a - -foo4a :: Proxy (A 1 2 3 4 `Compare` A 1 2 3 5) -foo4a = Proxy - -foo4b :: Proxy LT -foo4b = foo4a - -foo5a :: Proxy (A 1 2 3 4 `Compare` A 1 2 3 3) -foo5a = Proxy - -foo5b :: Proxy GT -foo5b = foo5a - -foo6a :: Proxy (A 1 2 3 4 `Compare` B 1 2 3 4) -foo6a = Proxy - -foo6b :: Proxy LT -foo6b = foo6a - -foo7a :: Proxy (B 1 2 3 4 `Compare` A 1 2 3 4) -foo7a = Proxy - -foo7b :: Proxy GT -foo7b = foo7a diff --git a/tests/compile-and-dump/Singletons/OverloadedStrings.ghc88.template b/tests/compile-and-dump/Singletons/OverloadedStrings.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/OverloadedStrings.ghc88.template +++ /dev/null @@ -1,35 +0,0 @@ -Singletons/OverloadedStrings.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| symId :: Symbol -> Symbol - symId x = x - foo :: Symbol - foo = symId "foo" |] - ======> - symId :: Symbol -> Symbol - symId x = x - foo :: Symbol - foo = symId "foo" - type FooSym0 = Foo - type SymIdSym1 (a0123456789876543210 :: Symbol) = - SymId a0123456789876543210 - instance SuppressUnusedWarnings SymIdSym0 where - suppressUnusedWarnings = snd (((,) SymIdSym0KindInference) ()) - data SymIdSym0 :: (~>) Symbol Symbol - where - SymIdSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply SymIdSym0 arg) (SymIdSym1 arg) => - SymIdSym0 a0123456789876543210 - type instance Apply SymIdSym0 a0123456789876543210 = SymId a0123456789876543210 - type family Foo :: Symbol where - Foo = Apply SymIdSym0 (Data.Singletons.Prelude.IsString.FromString "foo") - type family SymId (a :: Symbol) :: Symbol where - SymId x = x - sFoo :: Sing (FooSym0 :: Symbol) - sSymId :: - forall (t :: Symbol). Sing t -> Sing (Apply SymIdSym0 t :: Symbol) - sFoo - = (applySing ((singFun1 @SymIdSym0) sSymId)) - (Data.Singletons.Prelude.IsString.sFromString (sing :: Sing "foo")) - sSymId (sX :: Sing x) = sX - instance SingI (SymIdSym0 :: (~>) Symbol Symbol) where - sing = (singFun1 @SymIdSym0) sSymId diff --git a/tests/compile-and-dump/Singletons/OverloadedStrings.hs b/tests/compile-and-dump/Singletons/OverloadedStrings.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/OverloadedStrings.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module OverloadedStrings where - -import Data.Singletons.TH -import Data.Singletons.TypeLits - -$(singletons - [d| symId :: Symbol -> Symbol - symId x = x - - foo :: Symbol - foo = symId "foo" - |]) diff --git a/tests/compile-and-dump/Singletons/PatternMatching.ghc88.template b/tests/compile-and-dump/Singletons/PatternMatching.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/PatternMatching.ghc88.template +++ /dev/null @@ -1,587 +0,0 @@ -Singletons/PatternMatching.hs:(0,0)-(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 |] - ======> - 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 (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: b0123456789876543210) = - Pair t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (PairSym1 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) PairSym1KindInference) ()) - data PairSym1 (t0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210. - (~>) b0123456789876543210 (Pair a0123456789876543210 b0123456789876543210) - where - PairSym1KindInference :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (PairSym1 t0123456789876543210) arg) (PairSym2 t0123456789876543210 arg) => - PairSym1 t0123456789876543210 t0123456789876543210 - type instance Apply (PairSym1 t0123456789876543210) t0123456789876543210 = Pair t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings PairSym0 where - suppressUnusedWarnings = snd (((,) PairSym0KindInference) ()) - data PairSym0 :: forall a0123456789876543210 b0123456789876543210. - (~>) a0123456789876543210 ((~>) b0123456789876543210 (Pair a0123456789876543210 b0123456789876543210)) - where - PairSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply PairSym0 arg) (PairSym1 arg) => - PairSym0 t0123456789876543210 - type instance Apply PairSym0 t0123456789876543210 = PairSym1 t0123456789876543210 - type AListSym0 = AList - type TupleSym0 = Tuple - type ComplexSym0 = Complex - type PrSym0 = Pr - type family AList where - AList = Apply (Apply (:@#@$) ZeroSym0) (Apply (Apply (:@#@$) (Apply SuccSym0 ZeroSym0)) (Apply (Apply (:@#@$) (Apply SuccSym0 (Apply SuccSym0 ZeroSym0))) '[])) - type family Tuple where - Tuple = Apply (Apply (Apply Tuple3Sym0 FalseSym0) (Apply JustSym0 ZeroSym0)) TrueSym0 - type family Complex where - Complex = Apply (Apply PairSym0 (Apply (Apply PairSym0 (Apply JustSym0 ZeroSym0)) ZeroSym0)) FalseSym0 - type family Pr where - Pr = Apply (Apply PairSym0 (Apply SuccSym0 ZeroSym0)) (Apply (Apply (:@#@$) ZeroSym0) '[]) - type family ShowsPrec_0123456789876543210 (a :: GHC.Types.Nat) (a :: Pair a b) (a :: Symbol) :: Symbol where - ShowsPrec_0123456789876543210 p_0123456789876543210 (Pair arg_0123456789876543210 arg_0123456789876543210) a_0123456789876543210 = Apply (Apply (Apply ShowParenSym0 (Apply (Apply (>@#@$) p_0123456789876543210) (FromInteger 10))) (Apply (Apply (.@#@$) (Apply ShowStringSym0 "Pair ")) (Apply (Apply (.@#@$) (Apply (Apply ShowsPrecSym0 (FromInteger 11)) arg_0123456789876543210)) (Apply (Apply (.@#@$) ShowSpaceSym0) (Apply (Apply ShowsPrecSym0 (FromInteger 11)) arg_0123456789876543210))))) a_0123456789876543210 - type ShowsPrec_0123456789876543210Sym3 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: Pair a0123456789876543210 b0123456789876543210) (a0123456789876543210 :: Symbol) = - ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym2KindInference) ()) - data ShowsPrec_0123456789876543210Sym2 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: Pair a0123456789876543210 b0123456789876543210) :: (~>) Symbol Symbol - where - ShowsPrec_0123456789876543210Sym2KindInference :: forall a0123456789876543210 - a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) arg) (ShowsPrec_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 arg) => - ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym1KindInference) ()) - data ShowsPrec_0123456789876543210Sym1 (a0123456789876543210 :: GHC.Types.Nat) :: forall a0123456789876543210 - b0123456789876543210. - (~>) (Pair a0123456789876543210 b0123456789876543210) ((~>) Symbol Symbol) - where - ShowsPrec_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) arg) (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 arg) => - ShowsPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ShowsPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym0KindInference) ()) - data ShowsPrec_0123456789876543210Sym0 :: forall a0123456789876543210 - b0123456789876543210. - (~>) GHC.Types.Nat ((~>) (Pair a0123456789876543210 b0123456789876543210) ((~>) Symbol Symbol)) - where - ShowsPrec_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply ShowsPrec_0123456789876543210Sym0 arg) (ShowsPrec_0123456789876543210Sym1 arg) => - ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ShowsPrec_0123456789876543210Sym0 a0123456789876543210 = ShowsPrec_0123456789876543210Sym1 a0123456789876543210 - instance PShow (Pair a b) where - type ShowsPrec a a a = Apply (Apply (Apply ShowsPrec_0123456789876543210Sym0 a) a) a - sAList :: Sing AListSym0 - sTuple :: Sing TupleSym0 - sComplex :: Sing ComplexSym0 - sPr :: Sing PrSym0 - sAList - = (applySing ((applySing ((singFun2 @(:@#@$)) SCons)) SZero)) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing ((singFun1 @SuccSym0) SSucc)) SZero))) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing ((singFun1 @SuccSym0) SSucc)) - ((applySing ((singFun1 @SuccSym0) SSucc)) SZero)))) - SNil)) - sTuple - = (applySing - ((applySing ((applySing ((singFun3 @Tuple3Sym0) STuple3)) SFalse)) - ((applySing ((singFun1 @JustSym0) SJust)) SZero))) - STrue - sComplex - = (applySing - ((applySing ((singFun2 @PairSym0) SPair)) - ((applySing - ((applySing ((singFun2 @PairSym0) SPair)) - ((applySing ((singFun1 @JustSym0) SJust)) SZero))) - SZero))) - SFalse - sPr - = (applySing - ((applySing ((singFun2 @PairSym0) SPair)) - ((applySing ((singFun1 @SuccSym0) SSucc)) SZero))) - ((applySing ((applySing ((singFun2 @(:@#@$)) SCons)) SZero)) SNil) - data SPair :: forall a b. Pair a b -> GHC.Types.Type - where - SPair :: forall a b (n :: a) (n :: b). - (Sing (n :: a)) -> (Sing (n :: b)) -> SPair (Pair n n) - type instance Sing @(Pair a b) = SPair - instance (SingKind a, SingKind b) => SingKind (Pair a b) where - type Demote (Pair a b) = Pair (Demote a) (Demote b) - fromSing (SPair b b) = (Pair (fromSing b)) (fromSing b) - toSing (Pair (b :: Demote a) (b :: Demote b)) - = case ((,) (toSing b :: SomeSing a)) (toSing b :: SomeSing b) of { - (,) (SomeSing c) (SomeSing c) -> SomeSing ((SPair c) c) } - instance (SShow a, SShow b) => SShow (Pair a b) where - sShowsPrec :: - forall (t1 :: GHC.Types.Nat) (t2 :: Pair a b) (t3 :: Symbol). - Sing t1 - -> Sing t2 - -> Sing t3 - -> Sing (Apply (Apply (Apply (ShowsPrecSym0 :: TyFun GHC.Types.Nat ((~>) (Pair a b) ((~>) Symbol Symbol)) - -> GHC.Types.Type) t1) t2) t3) - sShowsPrec - (sP_0123456789876543210 :: Sing p_0123456789876543210) - (SPair (sArg_0123456789876543210 :: Sing arg_0123456789876543210) - (sArg_0123456789876543210 :: Sing arg_0123456789876543210)) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing - ((applySing ((singFun3 @ShowParenSym0) sShowParen)) - ((applySing - ((applySing ((singFun2 @(>@#@$)) (%>))) sP_0123456789876543210)) - (sFromInteger (sing :: Sing 10))))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "Pair ")))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((applySing - ((applySing ((singFun3 @ShowsPrecSym0) sShowsPrec)) - (sFromInteger (sing :: Sing 11)))) - sArg_0123456789876543210))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((singFun1 @ShowSpaceSym0) sShowSpace))) - ((applySing - ((applySing ((singFun3 @ShowsPrecSym0) sShowsPrec)) - (sFromInteger (sing :: Sing 11)))) - sArg_0123456789876543210)))))) - sA_0123456789876543210 - instance (Data.Singletons.ShowSing.ShowSing a, - Data.Singletons.ShowSing.ShowSing b) => - Show (SPair (z :: Pair a b)) where - showsPrec - p_0123456789876543210 - (SPair (arg_0123456789876543210 :: Sing argTy_0123456789876543210) - (arg_0123456789876543210 :: Sing argTy_0123456789876543210)) - = (showParen (((>) p_0123456789876543210) 10)) - (((.) (showString "SPair ")) - (((.) ((showsPrec 11) arg_0123456789876543210)) - (((.) GHC.Show.showSpace) - ((showsPrec 11) arg_0123456789876543210)))) :: - (Data.Singletons.ShowSing.ShowSing' argTy_0123456789876543210, - Data.Singletons.ShowSing.ShowSing' argTy_0123456789876543210) => - ShowS - instance (SingI n, SingI n) => SingI (Pair (n :: a) (n :: b)) where - sing = (SPair sing) sing - instance SingI (PairSym0 :: (~>) a ((~>) b (Pair a b))) where - sing = (singFun2 @PairSym0) SPair - instance SingI d => - SingI (PairSym1 (d :: a) :: (~>) b (Pair a b)) where - sing = (singFun1 @(PairSym1 (d :: a))) (SPair (sing @d)) -Singletons/PatternMatching.hs:(0,0)-(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 } - silly :: a -> () - silly x = case x of { _ -> () } |] - ======> - 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 } - silly :: a -> () - silly x = case x of { _ -> () } - type family Case_0123456789876543210 x t where - Case_0123456789876543210 x _ = Tuple0Sym0 - type Let0123456789876543210TSym2 x0123456789876543210 y0123456789876543210 = - Let0123456789876543210T x0123456789876543210 y0123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210TSym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210TSym1KindInference) ()) - data Let0123456789876543210TSym1 x0123456789876543210 y0123456789876543210 - where - Let0123456789876543210TSym1KindInference :: forall x0123456789876543210 - y0123456789876543210 - arg. SameKind (Apply (Let0123456789876543210TSym1 x0123456789876543210) arg) (Let0123456789876543210TSym2 x0123456789876543210 arg) => - Let0123456789876543210TSym1 x0123456789876543210 y0123456789876543210 - type instance Apply (Let0123456789876543210TSym1 x0123456789876543210) y0123456789876543210 = Let0123456789876543210T x0123456789876543210 y0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210TSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210TSym0KindInference) ()) - data Let0123456789876543210TSym0 x0123456789876543210 - where - Let0123456789876543210TSym0KindInference :: forall x0123456789876543210 - arg. SameKind (Apply Let0123456789876543210TSym0 arg) (Let0123456789876543210TSym1 arg) => - Let0123456789876543210TSym0 x0123456789876543210 - type instance Apply Let0123456789876543210TSym0 x0123456789876543210 = Let0123456789876543210TSym1 x0123456789876543210 - type family Let0123456789876543210T x y where - Let0123456789876543210T x y = Apply (Apply Tuple2Sym0 x) y - type family Case_0123456789876543210 arg_0123456789876543210 a b x y t where - Case_0123456789876543210 arg_0123456789876543210 a b x y _ = a - type family Lambda_0123456789876543210 a b x y t where - Lambda_0123456789876543210 a b x y arg_0123456789876543210 = Case_0123456789876543210 arg_0123456789876543210 a b x y arg_0123456789876543210 - type Lambda_0123456789876543210Sym5 a0123456789876543210 b0123456789876543210 x0123456789876543210 y0123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 a0123456789876543210 b0123456789876543210 x0123456789876543210 y0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym4 y0123456789876543210 x0123456789876543210 b0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym4KindInference) ()) - data Lambda_0123456789876543210Sym4 a0123456789876543210 b0123456789876543210 x0123456789876543210 y0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym4KindInference :: forall a0123456789876543210 - b0123456789876543210 - x0123456789876543210 - y0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym4 a0123456789876543210 b0123456789876543210 x0123456789876543210 y0123456789876543210) arg) (Lambda_0123456789876543210Sym5 a0123456789876543210 b0123456789876543210 x0123456789876543210 y0123456789876543210 arg) => - Lambda_0123456789876543210Sym4 a0123456789876543210 b0123456789876543210 x0123456789876543210 y0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym4 y0123456789876543210 x0123456789876543210 b0123456789876543210 a0123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 y0123456789876543210 x0123456789876543210 b0123456789876543210 a0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym3 x0123456789876543210 b0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym3KindInference) ()) - data Lambda_0123456789876543210Sym3 a0123456789876543210 b0123456789876543210 x0123456789876543210 y0123456789876543210 - where - Lambda_0123456789876543210Sym3KindInference :: forall a0123456789876543210 - b0123456789876543210 - x0123456789876543210 - y0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym3 a0123456789876543210 b0123456789876543210 x0123456789876543210) arg) (Lambda_0123456789876543210Sym4 a0123456789876543210 b0123456789876543210 x0123456789876543210 arg) => - Lambda_0123456789876543210Sym3 a0123456789876543210 b0123456789876543210 x0123456789876543210 y0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym3 x0123456789876543210 b0123456789876543210 a0123456789876543210) y0123456789876543210 = Lambda_0123456789876543210Sym4 x0123456789876543210 b0123456789876543210 a0123456789876543210 y0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 b0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 a0123456789876543210 b0123456789876543210 x0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall a0123456789876543210 - b0123456789876543210 - x0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 a0123456789876543210 b0123456789876543210) arg) (Lambda_0123456789876543210Sym3 a0123456789876543210 b0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 a0123456789876543210 b0123456789876543210 x0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 b0123456789876543210 a0123456789876543210) x0123456789876543210 = Lambda_0123456789876543210Sym3 b0123456789876543210 a0123456789876543210 x0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 a0123456789876543210 b0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - b0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 a0123456789876543210) arg) (Lambda_0123456789876543210Sym2 a0123456789876543210 arg) => - Lambda_0123456789876543210Sym1 a0123456789876543210 b0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 a0123456789876543210) b0123456789876543210 = Lambda_0123456789876543210Sym2 a0123456789876543210 b0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 a0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 a0123456789876543210 = Lambda_0123456789876543210Sym1 a0123456789876543210 - type family Case_0123456789876543210 x y t where - Case_0123456789876543210 x y '(a, - b) = Apply (Apply (Apply (Apply (Apply Lambda_0123456789876543210Sym0 a) b) x) y) b - type family Case_0123456789876543210 arg_0123456789876543210 x y t where - Case_0123456789876543210 arg_0123456789876543210 x y _ = x - type family Lambda_0123456789876543210 x y t where - Lambda_0123456789876543210 x y arg_0123456789876543210 = Case_0123456789876543210 arg_0123456789876543210 x y arg_0123456789876543210 - type Lambda_0123456789876543210Sym3 x0123456789876543210 y0123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 x0123456789876543210 y0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 y0123456789876543210 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall x0123456789876543210 - y0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210) arg) (Lambda_0123456789876543210Sym3 x0123456789876543210 y0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 y0123456789876543210 x0123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 y0123456789876543210 x0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 x0123456789876543210 y0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall x0123456789876543210 - y0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 x0123456789876543210) arg) (Lambda_0123456789876543210Sym2 x0123456789876543210 arg) => - Lambda_0123456789876543210Sym1 x0123456789876543210 y0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 x0123456789876543210) y0123456789876543210 = Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 x0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall x0123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 x0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 x0123456789876543210 = Lambda_0123456789876543210Sym1 x0123456789876543210 - type family Case_0123456789876543210 t where - Case_0123456789876543210 '[_, - _, - 'Succ y_0123456789876543210] = y_0123456789876543210 - type family Case_0123456789876543210 t where - Case_0123456789876543210 '[_, - y_0123456789876543210, - 'Succ _] = y_0123456789876543210 - type family Case_0123456789876543210 t where - Case_0123456789876543210 '(_, - _, - y_0123456789876543210) = y_0123456789876543210 - type family Case_0123456789876543210 t where - Case_0123456789876543210 '(_, - y_0123456789876543210, - _) = y_0123456789876543210 - type family Case_0123456789876543210 t where - Case_0123456789876543210 '(y_0123456789876543210, - _, - _) = y_0123456789876543210 - type family Case_0123456789876543210 t where - Case_0123456789876543210 ('Pair ('Pair _ _) y_0123456789876543210) = y_0123456789876543210 - type family Case_0123456789876543210 t where - Case_0123456789876543210 ('Pair ('Pair _ y_0123456789876543210) _) = y_0123456789876543210 - type family Case_0123456789876543210 t where - Case_0123456789876543210 ('Pair ('Pair y_0123456789876543210 _) _) = y_0123456789876543210 - type family Case_0123456789876543210 t where - Case_0123456789876543210 ('Pair _ y_0123456789876543210) = y_0123456789876543210 - type family Case_0123456789876543210 t where - Case_0123456789876543210 ('Pair y_0123456789876543210 _) = y_0123456789876543210 - type SillySym1 (a0123456789876543210 :: a0123456789876543210) = - Silly a0123456789876543210 - instance SuppressUnusedWarnings SillySym0 where - suppressUnusedWarnings = snd (((,) SillySym0KindInference) ()) - data SillySym0 :: forall a0123456789876543210. - (~>) a0123456789876543210 () - where - SillySym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply SillySym0 arg) (SillySym1 arg) => - SillySym0 a0123456789876543210 - type instance Apply SillySym0 a0123456789876543210 = Silly a0123456789876543210 - type Foo2Sym1 (a0123456789876543210 :: (a0123456789876543210, - b0123456789876543210)) = - Foo2 a0123456789876543210 - instance SuppressUnusedWarnings Foo2Sym0 where - suppressUnusedWarnings = snd (((,) Foo2Sym0KindInference) ()) - data Foo2Sym0 :: forall a0123456789876543210 b0123456789876543210. - (~>) (a0123456789876543210, - b0123456789876543210) a0123456789876543210 - where - Foo2Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo2Sym0 arg) (Foo2Sym1 arg) => - Foo2Sym0 a0123456789876543210 - type instance Apply Foo2Sym0 a0123456789876543210 = Foo2 a0123456789876543210 - type Foo1Sym1 (a0123456789876543210 :: (a0123456789876543210, - b0123456789876543210)) = - Foo1 a0123456789876543210 - instance SuppressUnusedWarnings Foo1Sym0 where - suppressUnusedWarnings = snd (((,) Foo1Sym0KindInference) ()) - data Foo1Sym0 :: forall a0123456789876543210 b0123456789876543210. - (~>) (a0123456789876543210, - b0123456789876543210) a0123456789876543210 - where - Foo1Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo1Sym0 arg) (Foo1Sym1 arg) => - Foo1Sym0 a0123456789876543210 - type instance Apply Foo1Sym0 a0123456789876543210 = Foo1 a0123456789876543210 - type BlimySym0 = Blimy - type LszSym0 = Lsz - type X_0123456789876543210Sym0 = X_0123456789876543210 - type TtSym0 = Tt - type TjzSym0 = Tjz - type TfSym0 = Tf - type X_0123456789876543210Sym0 = X_0123456789876543210 - type FlsSym0 = Fls - type ZzSym0 = Zz - type JzSym0 = Jz - type X_0123456789876543210Sym0 = X_0123456789876543210 - type LzSym0 = Lz - type SzSym0 = Sz - type X_0123456789876543210Sym0 = X_0123456789876543210 - type family Silly (a :: a) :: () where - Silly x = Case_0123456789876543210 x x - type family Foo2 (a :: (a, b)) :: a where - Foo2 '(x, - y) = Case_0123456789876543210 x y (Let0123456789876543210TSym2 x y) - type family Foo1 (a :: (a, b)) :: a where - Foo1 '(x, - y) = Apply (Apply (Apply Lambda_0123456789876543210Sym0 x) y) y - type family Blimy where - Blimy = Case_0123456789876543210 X_0123456789876543210Sym0 - type family Lsz :: Nat where - Lsz = Case_0123456789876543210 X_0123456789876543210Sym0 - type family X_0123456789876543210 where - X_0123456789876543210 = AListSym0 - type family Tt where - Tt = Case_0123456789876543210 X_0123456789876543210Sym0 - type family Tjz where - Tjz = Case_0123456789876543210 X_0123456789876543210Sym0 - type family Tf where - Tf = Case_0123456789876543210 X_0123456789876543210Sym0 - type family X_0123456789876543210 where - X_0123456789876543210 = TupleSym0 - type family Fls :: Bool where - Fls = Case_0123456789876543210 X_0123456789876543210Sym0 - type family Zz where - Zz = Case_0123456789876543210 X_0123456789876543210Sym0 - type family Jz where - Jz = Case_0123456789876543210 X_0123456789876543210Sym0 - type family X_0123456789876543210 where - X_0123456789876543210 = ComplexSym0 - type family Lz where - Lz = Case_0123456789876543210 X_0123456789876543210Sym0 - type family Sz where - Sz = Case_0123456789876543210 X_0123456789876543210Sym0 - type family X_0123456789876543210 where - X_0123456789876543210 = PrSym0 - sSilly :: - forall a (t :: a). Sing t -> Sing (Apply SillySym0 t :: ()) - sFoo2 :: - forall a b (t :: (a, b)). Sing t -> Sing (Apply Foo2Sym0 t :: a) - sFoo1 :: - forall a b (t :: (a, b)). Sing t -> Sing (Apply Foo1Sym0 t :: a) - sBlimy :: Sing BlimySym0 - sLsz :: Sing (LszSym0 :: Nat) - sX_0123456789876543210 :: Sing X_0123456789876543210Sym0 - sTt :: Sing TtSym0 - sTjz :: Sing TjzSym0 - sTf :: Sing TfSym0 - sX_0123456789876543210 :: Sing X_0123456789876543210Sym0 - sFls :: Sing (FlsSym0 :: Bool) - sZz :: Sing ZzSym0 - sJz :: Sing JzSym0 - sX_0123456789876543210 :: Sing X_0123456789876543210Sym0 - sLz :: Sing LzSym0 - sSz :: Sing SzSym0 - sX_0123456789876543210 :: Sing X_0123456789876543210Sym0 - sSilly (sX :: Sing x) - = (id @(Sing (Case_0123456789876543210 x x :: ()))) - (case sX of { _ -> STuple0 }) - sFoo2 (STuple2 (sX :: Sing x) (sY :: Sing y)) - = let - sT :: Sing (Let0123456789876543210TSym2 x y) - sT - = (applySing ((applySing ((singFun2 @Tuple2Sym0) STuple2)) sX)) sY - in - (id - @(Sing (Case_0123456789876543210 x y (Let0123456789876543210TSym2 x y) :: a))) - (case sT of { - STuple2 (sA :: Sing a) (sB :: Sing b) - -> (applySing - ((singFun1 - @(Apply (Apply (Apply (Apply Lambda_0123456789876543210Sym0 a) b) x) y)) - (\ sArg_0123456789876543210 - -> case sArg_0123456789876543210 of { - (_ :: Sing arg_0123456789876543210) - -> (id - @(Sing (Case_0123456789876543210 arg_0123456789876543210 a b x y arg_0123456789876543210))) - (case sArg_0123456789876543210 of { _ -> sA }) }))) - sB }) - sFoo1 (STuple2 (sX :: Sing x) (sY :: Sing y)) - = (applySing - ((singFun1 @(Apply (Apply Lambda_0123456789876543210Sym0 x) y)) - (\ sArg_0123456789876543210 - -> case sArg_0123456789876543210 of { - (_ :: Sing arg_0123456789876543210) - -> (id - @(Sing (Case_0123456789876543210 arg_0123456789876543210 x y arg_0123456789876543210))) - (case sArg_0123456789876543210 of { _ -> sX }) }))) - sY - sBlimy - = (id @(Sing (Case_0123456789876543210 X_0123456789876543210Sym0))) - (case sX_0123456789876543210 of { - SCons _ - (SCons _ - (SCons (SSucc (sY_0123456789876543210 :: Sing y_0123456789876543210)) - SNil)) - -> sY_0123456789876543210 }) - sLsz - = (id - @(Sing (Case_0123456789876543210 X_0123456789876543210Sym0 :: Nat))) - (case sX_0123456789876543210 of { - SCons _ - (SCons (sY_0123456789876543210 :: Sing y_0123456789876543210) - (SCons (SSucc _) SNil)) - -> sY_0123456789876543210 }) - sX_0123456789876543210 = sAList - sTt - = (id @(Sing (Case_0123456789876543210 X_0123456789876543210Sym0))) - (case sX_0123456789876543210 of { - STuple3 _ _ (sY_0123456789876543210 :: Sing y_0123456789876543210) - -> sY_0123456789876543210 }) - sTjz - = (id @(Sing (Case_0123456789876543210 X_0123456789876543210Sym0))) - (case sX_0123456789876543210 of { - STuple3 _ (sY_0123456789876543210 :: Sing y_0123456789876543210) _ - -> sY_0123456789876543210 }) - sTf - = (id @(Sing (Case_0123456789876543210 X_0123456789876543210Sym0))) - (case sX_0123456789876543210 of { - STuple3 (sY_0123456789876543210 :: Sing y_0123456789876543210) _ _ - -> sY_0123456789876543210 }) - sX_0123456789876543210 = sTuple - sFls - = (id - @(Sing (Case_0123456789876543210 X_0123456789876543210Sym0 :: Bool))) - (case sX_0123456789876543210 of { - SPair (SPair _ _) - (sY_0123456789876543210 :: Sing y_0123456789876543210) - -> sY_0123456789876543210 }) - sZz - = (id @(Sing (Case_0123456789876543210 X_0123456789876543210Sym0))) - (case sX_0123456789876543210 of { - SPair (SPair _ - (sY_0123456789876543210 :: Sing y_0123456789876543210)) - _ - -> sY_0123456789876543210 }) - sJz - = (id @(Sing (Case_0123456789876543210 X_0123456789876543210Sym0))) - (case sX_0123456789876543210 of { - SPair (SPair (sY_0123456789876543210 :: Sing y_0123456789876543210) - _) - _ - -> sY_0123456789876543210 }) - sX_0123456789876543210 = sComplex - sLz - = (id @(Sing (Case_0123456789876543210 X_0123456789876543210Sym0))) - (case sX_0123456789876543210 of { - SPair _ (sY_0123456789876543210 :: Sing y_0123456789876543210) - -> sY_0123456789876543210 }) - sSz - = (id @(Sing (Case_0123456789876543210 X_0123456789876543210Sym0))) - (case sX_0123456789876543210 of { - SPair (sY_0123456789876543210 :: Sing y_0123456789876543210) _ - -> sY_0123456789876543210 }) - sX_0123456789876543210 = sPr - instance SingI (SillySym0 :: (~>) a ()) where - sing = (singFun1 @SillySym0) sSilly - instance SingI (Foo2Sym0 :: (~>) (a, b) a) where - sing = (singFun1 @Foo2Sym0) sFoo2 - instance SingI (Foo1Sym0 :: (~>) (a, b) a) where - sing = (singFun1 @Foo1Sym0) sFoo1 diff --git a/tests/compile-and-dump/Singletons/PatternMatching.hs b/tests/compile-and-dump/Singletons/PatternMatching.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/PatternMatching.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# OPTIONS_GHC -Wno-unused-matches #-} -{-# OPTIONS_GHC -Wno-incomplete-patterns #-} - -module Singletons.PatternMatching where - -import Data.Singletons.Prelude -import Data.Singletons.Prelude.Show -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 - - foo1 :: (a, b) -> a - foo1 (x, y) = (\_ -> x) y - - foo2 :: (# a, b #) -> a - foo2 t@(# x, y #) = case t of - (# a, b #) -> (\_ -> a) b - - silly :: a -> () - silly x = case x of _ -> () - |]) - -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/PolyKinds.ghc88.template b/tests/compile-and-dump/Singletons/PolyKinds.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/PolyKinds.ghc88.template +++ /dev/null @@ -1,28 +0,0 @@ -Singletons/PolyKinds.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| class Cls (a :: k) where - fff :: Proxy (a :: k) -> () |] - ======> - class Cls (a :: k) where - fff :: Proxy (a :: k) -> () - type FffSym1 (arg0123456789876543210 :: Proxy (a0123456789876543210 :: k0123456789876543210)) = - Fff arg0123456789876543210 - instance SuppressUnusedWarnings FffSym0 where - suppressUnusedWarnings = snd (((,) FffSym0KindInference) ()) - data FffSym0 :: forall k0123456789876543210 - (a0123456789876543210 :: k0123456789876543210). - (~>) (Proxy (a0123456789876543210 :: k0123456789876543210)) () - where - FffSym0KindInference :: forall arg0123456789876543210 - arg. SameKind (Apply FffSym0 arg) (FffSym1 arg) => - FffSym0 arg0123456789876543210 - type instance Apply FffSym0 arg0123456789876543210 = Fff arg0123456789876543210 - class PCls (a :: k) where - type Fff (arg :: Proxy (a :: k)) :: () - class SCls (a :: k) where - sFff :: - forall (t :: Proxy (a :: k)). - Sing t -> Sing (Apply FffSym0 t :: ()) - instance SCls a => - SingI (FffSym0 :: (~>) (Proxy (a :: k)) ()) where - sing = (singFun1 @FffSym0) sFff diff --git a/tests/compile-and-dump/Singletons/PolyKinds.hs b/tests/compile-and-dump/Singletons/PolyKinds.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/PolyKinds.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Singletons.PolyKinds where - -import Data.Singletons.TH - -$(singletons [d| - class Cls (a :: k) where - fff :: Proxy (a :: k) -> () - |]) diff --git a/tests/compile-and-dump/Singletons/PolyKindsApp.ghc88.template b/tests/compile-and-dump/Singletons/PolyKindsApp.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/PolyKindsApp.ghc88.template +++ /dev/null @@ -1,12 +0,0 @@ -Singletons/PolyKindsApp.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| class Cls (a :: k -> Type) where - fff :: (a :: k -> Type) (b :: k) |] - ======> - class Cls (a :: k -> Type) where - fff :: (a :: k -> Type) (b :: k) - type FffSym0 = Fff - class PCls (a :: k -> Type) where - type Fff :: (a :: k -> Type) (b :: k) - class SCls (a :: k -> Type) where - sFff :: forall b. Sing (FffSym0 :: (a :: k -> Type) (b :: k)) diff --git a/tests/compile-and-dump/Singletons/PolyKindsApp.hs b/tests/compile-and-dump/Singletons/PolyKindsApp.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/PolyKindsApp.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Singletons.PolyKindsApp where - -import Data.Kind (Type) -import Data.Singletons.TH - -$(singletons [d| - class Cls (a :: k -> Type) where - fff :: (a :: k -> Type) (b :: k) - - -- instance Cls Proxy where - -- fff = Proxy - |]) diff --git a/tests/compile-and-dump/Singletons/Records.ghc88.template b/tests/compile-and-dump/Singletons/Records.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Records.ghc88.template +++ /dev/null @@ -1,73 +0,0 @@ -Singletons/Records.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| data Record a = MkRecord {field1 :: a, field2 :: Bool} |] - ======> - data Record a = MkRecord {field1 :: a, field2 :: Bool} - type Field2Sym1 (a0123456789876543210 :: Record a0123456789876543210) = - Field2 a0123456789876543210 - instance SuppressUnusedWarnings Field2Sym0 where - suppressUnusedWarnings = snd (((,) Field2Sym0KindInference) ()) - data Field2Sym0 :: forall a0123456789876543210. - (~>) (Record a0123456789876543210) Bool - where - Field2Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Field2Sym0 arg) (Field2Sym1 arg) => - Field2Sym0 a0123456789876543210 - type instance Apply Field2Sym0 a0123456789876543210 = Field2 a0123456789876543210 - type Field1Sym1 (a0123456789876543210 :: Record a0123456789876543210) = - Field1 a0123456789876543210 - instance SuppressUnusedWarnings Field1Sym0 where - suppressUnusedWarnings = snd (((,) Field1Sym0KindInference) ()) - data Field1Sym0 :: forall a0123456789876543210. - (~>) (Record a0123456789876543210) a0123456789876543210 - where - Field1Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Field1Sym0 arg) (Field1Sym1 arg) => - Field1Sym0 a0123456789876543210 - type instance Apply Field1Sym0 a0123456789876543210 = Field1 a0123456789876543210 - type family Field2 (a :: Record a) :: Bool where - Field2 (MkRecord _ field) = field - type family Field1 (a :: Record a) :: a where - Field1 (MkRecord field _) = field - type MkRecordSym2 (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: Bool) = - MkRecord t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (MkRecordSym1 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) MkRecordSym1KindInference) ()) - data MkRecordSym1 (t0123456789876543210 :: a0123456789876543210) :: (~>) Bool (Record a0123456789876543210) - where - MkRecordSym1KindInference :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (MkRecordSym1 t0123456789876543210) arg) (MkRecordSym2 t0123456789876543210 arg) => - MkRecordSym1 t0123456789876543210 t0123456789876543210 - type instance Apply (MkRecordSym1 t0123456789876543210) t0123456789876543210 = MkRecord t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings MkRecordSym0 where - suppressUnusedWarnings = snd (((,) MkRecordSym0KindInference) ()) - data MkRecordSym0 :: forall a0123456789876543210. - (~>) a0123456789876543210 ((~>) Bool (Record a0123456789876543210)) - where - MkRecordSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply MkRecordSym0 arg) (MkRecordSym1 arg) => - MkRecordSym0 t0123456789876543210 - type instance Apply MkRecordSym0 t0123456789876543210 = MkRecordSym1 t0123456789876543210 - data SRecord :: forall a. Record a -> GHC.Types.Type - where - SMkRecord :: forall a (n :: a) (n :: Bool). - {sField1 :: (Sing (n :: a)), sField2 :: (Sing (n :: Bool))} - -> SRecord (MkRecord n n) - type instance Sing @(Record a) = SRecord - instance SingKind a => SingKind (Record a) where - type Demote (Record a) = Record (Demote a) - fromSing (SMkRecord b b) = (MkRecord (fromSing b)) (fromSing b) - toSing (MkRecord (b :: Demote a) (b :: Demote Bool)) - = case - ((,) (toSing b :: SomeSing a)) (toSing b :: SomeSing Bool) - of { - (,) (SomeSing c) (SomeSing c) -> SomeSing ((SMkRecord c) c) } - instance (SingI n, SingI n) => - SingI (MkRecord (n :: a) (n :: Bool)) where - sing = (SMkRecord sing) sing - instance SingI (MkRecordSym0 :: (~>) a ((~>) Bool (Record a))) where - sing = (singFun2 @MkRecordSym0) SMkRecord - instance SingI d => - SingI (MkRecordSym1 (d :: a) :: (~>) Bool (Record a)) where - sing = (singFun1 @(MkRecordSym1 (d :: a))) (SMkRecord (sing @d)) diff --git a/tests/compile-and-dump/Singletons/Records.hs b/tests/compile-and-dump/Singletons/Records.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Records.hs +++ /dev/null @@ -1,29 +0,0 @@ -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.ghc88.template b/tests/compile-and-dump/Singletons/ReturnFunc.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/ReturnFunc.ghc88.template +++ /dev/null @@ -1,98 +0,0 @@ -Singletons/ReturnFunc.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| returnFunc :: Nat -> Nat -> Nat - returnFunc _ = Succ - id :: a -> a - id x = x - idFoo :: c -> a -> a - idFoo _ = id |] - ======> - returnFunc :: Nat -> Nat -> Nat - returnFunc _ = Succ - id :: a -> a - id x = x - idFoo :: c -> a -> a - idFoo _ = id - type IdFooSym2 (a0123456789876543210 :: c0123456789876543210) (a0123456789876543210 :: a0123456789876543210) = - IdFoo a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (IdFooSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) IdFooSym1KindInference) ()) - data IdFooSym1 (a0123456789876543210 :: c0123456789876543210) :: forall a0123456789876543210. - (~>) a0123456789876543210 a0123456789876543210 - where - IdFooSym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (IdFooSym1 a0123456789876543210) arg) (IdFooSym2 a0123456789876543210 arg) => - IdFooSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (IdFooSym1 a0123456789876543210) a0123456789876543210 = IdFoo a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings IdFooSym0 where - suppressUnusedWarnings = snd (((,) IdFooSym0KindInference) ()) - data IdFooSym0 :: forall c0123456789876543210 a0123456789876543210. - (~>) c0123456789876543210 ((~>) a0123456789876543210 a0123456789876543210) - where - IdFooSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply IdFooSym0 arg) (IdFooSym1 arg) => - IdFooSym0 a0123456789876543210 - type instance Apply IdFooSym0 a0123456789876543210 = IdFooSym1 a0123456789876543210 - type IdSym1 (a0123456789876543210 :: a0123456789876543210) = - Id a0123456789876543210 - instance SuppressUnusedWarnings IdSym0 where - suppressUnusedWarnings = snd (((,) IdSym0KindInference) ()) - data IdSym0 :: forall a0123456789876543210. - (~>) a0123456789876543210 a0123456789876543210 - where - IdSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply IdSym0 arg) (IdSym1 arg) => - IdSym0 a0123456789876543210 - type instance Apply IdSym0 a0123456789876543210 = Id a0123456789876543210 - type ReturnFuncSym2 (a0123456789876543210 :: Nat) (a0123456789876543210 :: Nat) = - ReturnFunc a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ReturnFuncSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) ReturnFuncSym1KindInference) ()) - data ReturnFuncSym1 (a0123456789876543210 :: Nat) :: (~>) Nat Nat - where - ReturnFuncSym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ReturnFuncSym1 a0123456789876543210) arg) (ReturnFuncSym2 a0123456789876543210 arg) => - ReturnFuncSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (ReturnFuncSym1 a0123456789876543210) a0123456789876543210 = ReturnFunc a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ReturnFuncSym0 where - suppressUnusedWarnings = snd (((,) ReturnFuncSym0KindInference) ()) - data ReturnFuncSym0 :: (~>) Nat ((~>) Nat Nat) - where - ReturnFuncSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply ReturnFuncSym0 arg) (ReturnFuncSym1 arg) => - ReturnFuncSym0 a0123456789876543210 - type instance Apply ReturnFuncSym0 a0123456789876543210 = ReturnFuncSym1 a0123456789876543210 - type family IdFoo (a :: c) (a :: a) :: a where - IdFoo _ a_0123456789876543210 = Apply IdSym0 a_0123456789876543210 - type family Id (a :: a) :: a where - Id x = x - type family ReturnFunc (a :: Nat) (a :: Nat) :: Nat where - ReturnFunc _ a_0123456789876543210 = Apply SuccSym0 a_0123456789876543210 - sIdFoo :: - forall c a (t :: c) (t :: a). - Sing t -> Sing t -> Sing (Apply (Apply IdFooSym0 t) t :: a) - sId :: forall a (t :: a). Sing t -> Sing (Apply IdSym0 t :: a) - sReturnFunc :: - forall (t :: Nat) (t :: Nat). - Sing t -> Sing t -> Sing (Apply (Apply ReturnFuncSym0 t) t :: Nat) - sIdFoo _ (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing ((singFun1 @IdSym0) sId)) sA_0123456789876543210 - sId (sX :: Sing x) = sX - sReturnFunc - _ - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing ((singFun1 @SuccSym0) SSucc)) sA_0123456789876543210 - instance SingI (IdFooSym0 :: (~>) c ((~>) a a)) where - sing = (singFun2 @IdFooSym0) sIdFoo - instance SingI d => SingI (IdFooSym1 (d :: c) :: (~>) a a) where - sing = (singFun1 @(IdFooSym1 (d :: c))) (sIdFoo (sing @d)) - instance SingI (IdSym0 :: (~>) a a) where - sing = (singFun1 @IdSym0) sId - instance SingI (ReturnFuncSym0 :: (~>) Nat ((~>) Nat Nat)) where - sing = (singFun2 @ReturnFuncSym0) sReturnFunc - instance SingI d => - SingI (ReturnFuncSym1 (d :: Nat) :: (~>) Nat Nat) where - sing - = (singFun1 @(ReturnFuncSym1 (d :: Nat))) (sReturnFunc (sing @d)) diff --git a/tests/compile-and-dump/Singletons/ReturnFunc.hs b/tests/compile-and-dump/Singletons/ReturnFunc.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/ReturnFunc.hs +++ /dev/null @@ -1,23 +0,0 @@ -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.ghc88.template b/tests/compile-and-dump/Singletons/Sections.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Sections.ghc88.template +++ /dev/null @@ -1,122 +0,0 @@ -Singletons/Sections.hs:(0,0)-(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] |] - ======> - (+) :: 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_0123456789876543210 t where - Lambda_0123456789876543210 lhs_0123456789876543210 = Apply (Apply (+@#@$) lhs_0123456789876543210) (Apply SuccSym0 ZeroSym0) - type Lambda_0123456789876543210Sym1 t0123456789876543210 = - Lambda_0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 t0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 t0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 t0123456789876543210 = Lambda_0123456789876543210 t0123456789876543210 - type Foo3Sym0 = Foo3 - type Foo2Sym0 = Foo2 - type Foo1Sym0 = Foo1 - type (+@#@$$$) (a0123456789876543210 :: Nat) (a0123456789876543210 :: Nat) = - (+) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((+@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (:+@#@$$###)) ()) - data (+@#@$$) (a0123456789876543210 :: Nat) :: (~>) Nat Nat - where - (:+@#@$$###) :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply ((+@#@$$) a0123456789876543210) arg) ((+@#@$$$) a0123456789876543210 arg) => - (+@#@$$) a0123456789876543210 a0123456789876543210 - type instance Apply ((+@#@$$) a0123456789876543210) a0123456789876543210 = (+) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (+@#@$) where - suppressUnusedWarnings = snd (((,) (:+@#@$###)) ()) - data (+@#@$) :: (~>) Nat ((~>) Nat Nat) - where - (:+@#@$###) :: forall a0123456789876543210 - arg. SameKind (Apply (+@#@$) arg) ((+@#@$$) arg) => - (+@#@$) a0123456789876543210 - type instance Apply (+@#@$) a0123456789876543210 = (+@#@$$) a0123456789876543210 - type family Foo3 :: [Nat] where - Foo3 = Apply (Apply (Apply ZipWithSym0 (+@#@$)) (Apply (Apply (:@#@$) (Apply SuccSym0 ZeroSym0)) (Apply (Apply (:@#@$) (Apply SuccSym0 ZeroSym0)) '[]))) (Apply (Apply (:@#@$) ZeroSym0) (Apply (Apply (:@#@$) (Apply SuccSym0 ZeroSym0)) '[])) - type family Foo2 :: [Nat] where - Foo2 = Apply (Apply MapSym0 Lambda_0123456789876543210Sym0) (Apply (Apply (:@#@$) ZeroSym0) (Apply (Apply (:@#@$) (Apply SuccSym0 ZeroSym0)) '[])) - type family Foo1 :: [Nat] where - Foo1 = Apply (Apply MapSym0 (Apply (+@#@$) (Apply SuccSym0 ZeroSym0))) (Apply (Apply (:@#@$) ZeroSym0) (Apply (Apply (:@#@$) (Apply SuccSym0 ZeroSym0)) '[])) - type family (+) (a :: Nat) (a :: Nat) :: Nat where - (+) 'Zero m = m - (+) ('Succ n) m = Apply SuccSym0 (Apply (Apply (+@#@$) n) m) - sFoo3 :: Sing (Foo3Sym0 :: [Nat]) - sFoo2 :: Sing (Foo2Sym0 :: [Nat]) - sFoo1 :: Sing (Foo1Sym0 :: [Nat]) - (%+) :: - forall (t :: Nat) (t :: Nat). - Sing t -> Sing t -> Sing (Apply (Apply (+@#@$) t) t :: Nat) - sFoo3 - = (applySing - ((applySing - ((applySing ((singFun3 @ZipWithSym0) sZipWith)) - ((singFun2 @(+@#@$)) (%+)))) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing ((singFun1 @SuccSym0) SSucc)) SZero))) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing ((singFun1 @SuccSym0) SSucc)) SZero))) - SNil)))) - ((applySing ((applySing ((singFun2 @(:@#@$)) SCons)) SZero)) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing ((singFun1 @SuccSym0) SSucc)) SZero))) - SNil)) - sFoo2 - = (applySing - ((applySing ((singFun2 @MapSym0) sMap)) - ((singFun1 @Lambda_0123456789876543210Sym0) - (\ sLhs_0123456789876543210 - -> case sLhs_0123456789876543210 of { - (_ :: Sing lhs_0123456789876543210) - -> (applySing - ((applySing ((singFun2 @(+@#@$)) (%+))) sLhs_0123456789876543210)) - ((applySing ((singFun1 @SuccSym0) SSucc)) SZero) })))) - ((applySing ((applySing ((singFun2 @(:@#@$)) SCons)) SZero)) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing ((singFun1 @SuccSym0) SSucc)) SZero))) - SNil)) - sFoo1 - = (applySing - ((applySing ((singFun2 @MapSym0) sMap)) - ((applySing ((singFun2 @(+@#@$)) (%+))) - ((applySing ((singFun1 @SuccSym0) SSucc)) SZero)))) - ((applySing ((applySing ((singFun2 @(:@#@$)) SCons)) SZero)) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing ((singFun1 @SuccSym0) SSucc)) SZero))) - SNil)) - (%+) SZero (sM :: Sing m) = sM - (%+) (SSucc (sN :: Sing n)) (sM :: Sing m) - = (applySing ((singFun1 @SuccSym0) SSucc)) - ((applySing ((applySing ((singFun2 @(+@#@$)) (%+))) sN)) sM) - instance SingI ((+@#@$) :: (~>) Nat ((~>) Nat Nat)) where - sing = (singFun2 @(+@#@$)) (%+) - instance SingI d => - SingI ((+@#@$$) (d :: Nat) :: (~>) Nat Nat) where - sing = (singFun1 @((+@#@$$) (d :: Nat))) ((%+) (sing @d)) diff --git a/tests/compile-and-dump/Singletons/Sections.hs b/tests/compile-and-dump/Singletons/Sections.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Sections.hs +++ /dev/null @@ -1,40 +0,0 @@ -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/ShowDeriving.ghc88.template b/tests/compile-and-dump/Singletons/ShowDeriving.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/ShowDeriving.ghc88.template +++ /dev/null @@ -1,618 +0,0 @@ -Singletons/ShowDeriving.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| infixl 5 `MkFoo2b`, :*:, :&: - - data Foo1 - = MkFoo1 - deriving Show - data Foo2 a - = MkFoo2a a a | a `MkFoo2b` a | (:*:) a a | a :&: a - deriving Show - data Foo3 - = MkFoo3 {getFoo3a :: Bool, *** :: Bool} - deriving Show |] - ======> - data Foo1 - = MkFoo1 - deriving Show - infixl 5 `MkFoo2b` - infixl 5 :*: - infixl 5 :&: - data Foo2 a - = MkFoo2a a a | a `MkFoo2b` a | (:*:) a a | a :&: a - deriving Show - data Foo3 - = MkFoo3 {getFoo3a :: Bool, *** :: Bool} - deriving Show - type (***@#@$$) (a0123456789876543210 :: Foo3) = - (***) a0123456789876543210 - instance SuppressUnusedWarnings (***@#@$) where - suppressUnusedWarnings = snd (((,) (:***@#@$###)) ()) - data (***@#@$) :: (~>) Foo3 Bool - where - (:***@#@$###) :: forall a0123456789876543210 - arg. SameKind (Apply (***@#@$) arg) ((***@#@$$) arg) => - (***@#@$) a0123456789876543210 - type instance Apply (***@#@$) a0123456789876543210 = (***) a0123456789876543210 - type GetFoo3aSym1 (a0123456789876543210 :: Foo3) = - GetFoo3a a0123456789876543210 - instance SuppressUnusedWarnings GetFoo3aSym0 where - suppressUnusedWarnings = snd (((,) GetFoo3aSym0KindInference) ()) - data GetFoo3aSym0 :: (~>) Foo3 Bool - where - GetFoo3aSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply GetFoo3aSym0 arg) (GetFoo3aSym1 arg) => - GetFoo3aSym0 a0123456789876543210 - type instance Apply GetFoo3aSym0 a0123456789876543210 = GetFoo3a a0123456789876543210 - type family (***) (a :: Foo3) :: Bool where - (***) (MkFoo3 _ field) = field - type family GetFoo3a (a :: Foo3) :: Bool where - GetFoo3a (MkFoo3 field _) = field - type MkFoo1Sym0 = MkFoo1 - type MkFoo2aSym2 (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: a0123456789876543210) = - MkFoo2a t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (MkFoo2aSym1 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) MkFoo2aSym1KindInference) ()) - data MkFoo2aSym1 (t0123456789876543210 :: a0123456789876543210) :: (~>) a0123456789876543210 (Foo2 a0123456789876543210) - where - MkFoo2aSym1KindInference :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (MkFoo2aSym1 t0123456789876543210) arg) (MkFoo2aSym2 t0123456789876543210 arg) => - MkFoo2aSym1 t0123456789876543210 t0123456789876543210 - type instance Apply (MkFoo2aSym1 t0123456789876543210) t0123456789876543210 = MkFoo2a t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings MkFoo2aSym0 where - suppressUnusedWarnings = snd (((,) MkFoo2aSym0KindInference) ()) - data MkFoo2aSym0 :: forall a0123456789876543210. - (~>) a0123456789876543210 ((~>) a0123456789876543210 (Foo2 a0123456789876543210)) - where - MkFoo2aSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply MkFoo2aSym0 arg) (MkFoo2aSym1 arg) => - MkFoo2aSym0 t0123456789876543210 - type instance Apply MkFoo2aSym0 t0123456789876543210 = MkFoo2aSym1 t0123456789876543210 - type MkFoo2bSym2 (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: a0123456789876543210) = - MkFoo2b t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (MkFoo2bSym1 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) MkFoo2bSym1KindInference) ()) - data MkFoo2bSym1 (t0123456789876543210 :: a0123456789876543210) :: (~>) a0123456789876543210 (Foo2 a0123456789876543210) - where - MkFoo2bSym1KindInference :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (MkFoo2bSym1 t0123456789876543210) arg) (MkFoo2bSym2 t0123456789876543210 arg) => - MkFoo2bSym1 t0123456789876543210 t0123456789876543210 - type instance Apply (MkFoo2bSym1 t0123456789876543210) t0123456789876543210 = MkFoo2b t0123456789876543210 t0123456789876543210 - infixl 5 `MkFoo2bSym1` - instance SuppressUnusedWarnings MkFoo2bSym0 where - suppressUnusedWarnings = snd (((,) MkFoo2bSym0KindInference) ()) - data MkFoo2bSym0 :: forall a0123456789876543210. - (~>) a0123456789876543210 ((~>) a0123456789876543210 (Foo2 a0123456789876543210)) - where - MkFoo2bSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply MkFoo2bSym0 arg) (MkFoo2bSym1 arg) => - MkFoo2bSym0 t0123456789876543210 - type instance Apply MkFoo2bSym0 t0123456789876543210 = MkFoo2bSym1 t0123456789876543210 - infixl 5 `MkFoo2bSym0` - type (:*:@#@$$$) (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: a0123456789876543210) = - (:*:) t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings ((:*:@#@$$) t0123456789876543210) where - suppressUnusedWarnings = snd (((,) (::*:@#@$$###)) ()) - data (:*:@#@$$) (t0123456789876543210 :: a0123456789876543210) :: (~>) a0123456789876543210 (Foo2 a0123456789876543210) - where - (::*:@#@$$###) :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply ((:*:@#@$$) t0123456789876543210) arg) ((:*:@#@$$$) t0123456789876543210 arg) => - (:*:@#@$$) t0123456789876543210 t0123456789876543210 - type instance Apply ((:*:@#@$$) t0123456789876543210) t0123456789876543210 = (:*:) t0123456789876543210 t0123456789876543210 - infixl 5 :*:@#@$$ - instance SuppressUnusedWarnings (:*:@#@$) where - suppressUnusedWarnings = snd (((,) (::*:@#@$###)) ()) - data (:*:@#@$) :: forall a0123456789876543210. - (~>) a0123456789876543210 ((~>) a0123456789876543210 (Foo2 a0123456789876543210)) - where - (::*:@#@$###) :: forall t0123456789876543210 - arg. SameKind (Apply (:*:@#@$) arg) ((:*:@#@$$) arg) => - (:*:@#@$) t0123456789876543210 - type instance Apply (:*:@#@$) t0123456789876543210 = (:*:@#@$$) t0123456789876543210 - infixl 5 :*:@#@$ - type (:&:@#@$$$) (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: a0123456789876543210) = - (:&:) t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings ((:&:@#@$$) t0123456789876543210) where - suppressUnusedWarnings = snd (((,) (::&:@#@$$###)) ()) - data (:&:@#@$$) (t0123456789876543210 :: a0123456789876543210) :: (~>) a0123456789876543210 (Foo2 a0123456789876543210) - where - (::&:@#@$$###) :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply ((:&:@#@$$) t0123456789876543210) arg) ((:&:@#@$$$) t0123456789876543210 arg) => - (:&:@#@$$) t0123456789876543210 t0123456789876543210 - type instance Apply ((:&:@#@$$) t0123456789876543210) t0123456789876543210 = (:&:) t0123456789876543210 t0123456789876543210 - infixl 5 :&:@#@$$ - instance SuppressUnusedWarnings (:&:@#@$) where - suppressUnusedWarnings = snd (((,) (::&:@#@$###)) ()) - data (:&:@#@$) :: forall a0123456789876543210. - (~>) a0123456789876543210 ((~>) a0123456789876543210 (Foo2 a0123456789876543210)) - where - (::&:@#@$###) :: forall t0123456789876543210 - arg. SameKind (Apply (:&:@#@$) arg) ((:&:@#@$$) arg) => - (:&:@#@$) t0123456789876543210 - type instance Apply (:&:@#@$) t0123456789876543210 = (:&:@#@$$) t0123456789876543210 - infixl 5 :&:@#@$ - type MkFoo3Sym2 (t0123456789876543210 :: Bool) (t0123456789876543210 :: Bool) = - MkFoo3 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (MkFoo3Sym1 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) MkFoo3Sym1KindInference) ()) - data MkFoo3Sym1 (t0123456789876543210 :: Bool) :: (~>) Bool Foo3 - where - MkFoo3Sym1KindInference :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (MkFoo3Sym1 t0123456789876543210) arg) (MkFoo3Sym2 t0123456789876543210 arg) => - MkFoo3Sym1 t0123456789876543210 t0123456789876543210 - type instance Apply (MkFoo3Sym1 t0123456789876543210) t0123456789876543210 = MkFoo3 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings MkFoo3Sym0 where - suppressUnusedWarnings = snd (((,) MkFoo3Sym0KindInference) ()) - data MkFoo3Sym0 :: (~>) Bool ((~>) Bool Foo3) - where - MkFoo3Sym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply MkFoo3Sym0 arg) (MkFoo3Sym1 arg) => - MkFoo3Sym0 t0123456789876543210 - type instance Apply MkFoo3Sym0 t0123456789876543210 = MkFoo3Sym1 t0123456789876543210 - type family ShowsPrec_0123456789876543210 (a :: GHC.Types.Nat) (a :: Foo1) (a :: Symbol) :: Symbol where - ShowsPrec_0123456789876543210 _ MkFoo1 a_0123456789876543210 = Apply (Apply ShowStringSym0 "MkFoo1") a_0123456789876543210 - type ShowsPrec_0123456789876543210Sym3 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: Foo1) (a0123456789876543210 :: Symbol) = - ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym2KindInference) ()) - data ShowsPrec_0123456789876543210Sym2 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: Foo1) :: (~>) Symbol Symbol - where - ShowsPrec_0123456789876543210Sym2KindInference :: forall a0123456789876543210 - a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) arg) (ShowsPrec_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 arg) => - ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym1KindInference) ()) - data ShowsPrec_0123456789876543210Sym1 (a0123456789876543210 :: GHC.Types.Nat) :: (~>) Foo1 ((~>) Symbol Symbol) - where - ShowsPrec_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) arg) (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 arg) => - ShowsPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ShowsPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym0KindInference) ()) - data ShowsPrec_0123456789876543210Sym0 :: (~>) GHC.Types.Nat ((~>) Foo1 ((~>) Symbol Symbol)) - where - ShowsPrec_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply ShowsPrec_0123456789876543210Sym0 arg) (ShowsPrec_0123456789876543210Sym1 arg) => - ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ShowsPrec_0123456789876543210Sym0 a0123456789876543210 = ShowsPrec_0123456789876543210Sym1 a0123456789876543210 - instance PShow Foo1 where - type ShowsPrec a a a = Apply (Apply (Apply ShowsPrec_0123456789876543210Sym0 a) a) a - type family ShowsPrec_0123456789876543210 (a :: GHC.Types.Nat) (a :: Foo2 a) (a :: Symbol) :: Symbol where - ShowsPrec_0123456789876543210 p_0123456789876543210 (MkFoo2a arg_0123456789876543210 arg_0123456789876543210) a_0123456789876543210 = Apply (Apply (Apply ShowParenSym0 (Apply (Apply (>@#@$) p_0123456789876543210) (FromInteger 10))) (Apply (Apply (.@#@$) (Apply ShowStringSym0 "MkFoo2a ")) (Apply (Apply (.@#@$) (Apply (Apply ShowsPrecSym0 (FromInteger 11)) arg_0123456789876543210)) (Apply (Apply (.@#@$) ShowSpaceSym0) (Apply (Apply ShowsPrecSym0 (FromInteger 11)) arg_0123456789876543210))))) a_0123456789876543210 - ShowsPrec_0123456789876543210 p_0123456789876543210 (MkFoo2b argL_0123456789876543210 argR_0123456789876543210) a_0123456789876543210 = Apply (Apply (Apply ShowParenSym0 (Apply (Apply (>@#@$) p_0123456789876543210) (FromInteger 5))) (Apply (Apply (.@#@$) (Apply (Apply ShowsPrecSym0 (FromInteger 6)) argL_0123456789876543210)) (Apply (Apply (.@#@$) (Apply ShowStringSym0 " `MkFoo2b` ")) (Apply (Apply ShowsPrecSym0 (FromInteger 6)) argR_0123456789876543210)))) a_0123456789876543210 - ShowsPrec_0123456789876543210 p_0123456789876543210 ((:*:) arg_0123456789876543210 arg_0123456789876543210) a_0123456789876543210 = Apply (Apply (Apply ShowParenSym0 (Apply (Apply (>@#@$) p_0123456789876543210) (FromInteger 10))) (Apply (Apply (.@#@$) (Apply ShowStringSym0 "(:*:) ")) (Apply (Apply (.@#@$) (Apply (Apply ShowsPrecSym0 (FromInteger 11)) arg_0123456789876543210)) (Apply (Apply (.@#@$) ShowSpaceSym0) (Apply (Apply ShowsPrecSym0 (FromInteger 11)) arg_0123456789876543210))))) a_0123456789876543210 - ShowsPrec_0123456789876543210 p_0123456789876543210 ((:&:) argL_0123456789876543210 argR_0123456789876543210) a_0123456789876543210 = Apply (Apply (Apply ShowParenSym0 (Apply (Apply (>@#@$) p_0123456789876543210) (FromInteger 5))) (Apply (Apply (.@#@$) (Apply (Apply ShowsPrecSym0 (FromInteger 6)) argL_0123456789876543210)) (Apply (Apply (.@#@$) (Apply ShowStringSym0 " :&: ")) (Apply (Apply ShowsPrecSym0 (FromInteger 6)) argR_0123456789876543210)))) a_0123456789876543210 - type ShowsPrec_0123456789876543210Sym3 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: Foo2 a0123456789876543210) (a0123456789876543210 :: Symbol) = - ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym2KindInference) ()) - data ShowsPrec_0123456789876543210Sym2 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: Foo2 a0123456789876543210) :: (~>) Symbol Symbol - where - ShowsPrec_0123456789876543210Sym2KindInference :: forall a0123456789876543210 - a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) arg) (ShowsPrec_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 arg) => - ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym1KindInference) ()) - data ShowsPrec_0123456789876543210Sym1 (a0123456789876543210 :: GHC.Types.Nat) :: forall a0123456789876543210. - (~>) (Foo2 a0123456789876543210) ((~>) Symbol Symbol) - where - ShowsPrec_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) arg) (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 arg) => - ShowsPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ShowsPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym0KindInference) ()) - data ShowsPrec_0123456789876543210Sym0 :: forall a0123456789876543210. - (~>) GHC.Types.Nat ((~>) (Foo2 a0123456789876543210) ((~>) Symbol Symbol)) - where - ShowsPrec_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply ShowsPrec_0123456789876543210Sym0 arg) (ShowsPrec_0123456789876543210Sym1 arg) => - ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ShowsPrec_0123456789876543210Sym0 a0123456789876543210 = ShowsPrec_0123456789876543210Sym1 a0123456789876543210 - instance PShow (Foo2 a) where - type ShowsPrec a a a = Apply (Apply (Apply ShowsPrec_0123456789876543210Sym0 a) a) a - type family ShowsPrec_0123456789876543210 (a :: GHC.Types.Nat) (a :: Foo3) (a :: Symbol) :: Symbol where - ShowsPrec_0123456789876543210 p_0123456789876543210 (MkFoo3 arg_0123456789876543210 arg_0123456789876543210) a_0123456789876543210 = Apply (Apply (Apply ShowParenSym0 (Apply (Apply (>@#@$) p_0123456789876543210) (FromInteger 10))) (Apply (Apply (.@#@$) (Apply ShowStringSym0 "MkFoo3 ")) (Apply (Apply (.@#@$) (Apply ShowCharSym0 "{")) (Apply (Apply (.@#@$) (Apply ShowStringSym0 "getFoo3a = ")) (Apply (Apply (.@#@$) (Apply (Apply ShowsPrecSym0 (FromInteger 0)) arg_0123456789876543210)) (Apply (Apply (.@#@$) ShowCommaSpaceSym0) (Apply (Apply (.@#@$) (Apply ShowStringSym0 "(***) = ")) (Apply (Apply (.@#@$) (Apply (Apply ShowsPrecSym0 (FromInteger 0)) arg_0123456789876543210)) (Apply ShowCharSym0 "}"))))))))) a_0123456789876543210 - type ShowsPrec_0123456789876543210Sym3 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: Foo3) (a0123456789876543210 :: Symbol) = - ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym2KindInference) ()) - data ShowsPrec_0123456789876543210Sym2 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: Foo3) :: (~>) Symbol Symbol - where - ShowsPrec_0123456789876543210Sym2KindInference :: forall a0123456789876543210 - a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) arg) (ShowsPrec_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 arg) => - ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym1KindInference) ()) - data ShowsPrec_0123456789876543210Sym1 (a0123456789876543210 :: GHC.Types.Nat) :: (~>) Foo3 ((~>) Symbol Symbol) - where - ShowsPrec_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) arg) (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 arg) => - ShowsPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ShowsPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym0KindInference) ()) - data ShowsPrec_0123456789876543210Sym0 :: (~>) GHC.Types.Nat ((~>) Foo3 ((~>) Symbol Symbol)) - where - ShowsPrec_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply ShowsPrec_0123456789876543210Sym0 arg) (ShowsPrec_0123456789876543210Sym1 arg) => - ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ShowsPrec_0123456789876543210Sym0 a0123456789876543210 = ShowsPrec_0123456789876543210Sym1 a0123456789876543210 - instance PShow Foo3 where - type ShowsPrec a a a = Apply (Apply (Apply ShowsPrec_0123456789876543210Sym0 a) a) a - infixl 5 :%&: - infixl 5 :%*: - infixl 5 `SMkFoo2b` - data SFoo1 :: Foo1 -> GHC.Types.Type where SMkFoo1 :: SFoo1 MkFoo1 - type instance Sing @Foo1 = SFoo1 - instance SingKind Foo1 where - type Demote Foo1 = Foo1 - fromSing SMkFoo1 = MkFoo1 - toSing MkFoo1 = SomeSing SMkFoo1 - data SFoo2 :: forall a. Foo2 a -> GHC.Types.Type - where - SMkFoo2a :: forall a (n :: a) (n :: a). - (Sing (n :: a)) -> (Sing (n :: a)) -> SFoo2 (MkFoo2a n n) - SMkFoo2b :: forall a (n :: a) (n :: a). - (Sing (n :: a)) -> (Sing (n :: a)) -> SFoo2 (MkFoo2b n n) - (:%*:) :: forall a (n :: a) (n :: a). - (Sing (n :: a)) -> (Sing (n :: a)) -> SFoo2 ((:*:) n n) - (:%&:) :: forall a (n :: a) (n :: a). - (Sing (n :: a)) -> (Sing (n :: a)) -> SFoo2 ((:&:) n n) - type instance Sing @(Foo2 a) = SFoo2 - instance SingKind a => SingKind (Foo2 a) where - type Demote (Foo2 a) = Foo2 (Demote a) - fromSing (SMkFoo2a b b) = (MkFoo2a (fromSing b)) (fromSing b) - fromSing (SMkFoo2b b b) = (MkFoo2b (fromSing b)) (fromSing b) - fromSing ((:%*:) b b) = ((:*:) (fromSing b)) (fromSing b) - fromSing ((:%&:) b b) = ((:&:) (fromSing b)) (fromSing b) - toSing (MkFoo2a (b :: Demote a) (b :: Demote a)) - = case ((,) (toSing b :: SomeSing a)) (toSing b :: SomeSing a) of { - (,) (SomeSing c) (SomeSing c) -> SomeSing ((SMkFoo2a c) c) } - toSing (MkFoo2b (b :: Demote a) (b :: Demote a)) - = case ((,) (toSing b :: SomeSing a)) (toSing b :: SomeSing a) of { - (,) (SomeSing c) (SomeSing c) -> SomeSing ((SMkFoo2b c) c) } - toSing ((:*:) (b :: Demote a) (b :: Demote a)) - = case ((,) (toSing b :: SomeSing a)) (toSing b :: SomeSing a) of { - (,) (SomeSing c) (SomeSing c) -> SomeSing (((:%*:) c) c) } - toSing ((:&:) (b :: Demote a) (b :: Demote a)) - = case ((,) (toSing b :: SomeSing a)) (toSing b :: SomeSing a) of { - (,) (SomeSing c) (SomeSing c) -> SomeSing (((:%&:) c) c) } - data SFoo3 :: Foo3 -> GHC.Types.Type - where - SMkFoo3 :: forall (n :: Bool) (n :: Bool). - {sGetFoo3a :: (Sing (n :: Bool)), %*** :: (Sing (n :: Bool))} - -> SFoo3 (MkFoo3 n n) - type instance Sing @Foo3 = SFoo3 - instance SingKind Foo3 where - type Demote Foo3 = Foo3 - fromSing (SMkFoo3 b b) = (MkFoo3 (fromSing b)) (fromSing b) - toSing (MkFoo3 (b :: Demote Bool) (b :: Demote Bool)) - = case - ((,) (toSing b :: SomeSing Bool)) (toSing b :: SomeSing Bool) - of { - (,) (SomeSing c) (SomeSing c) -> SomeSing ((SMkFoo3 c) c) } - instance SShow Foo1 where - sShowsPrec :: - forall (t1 :: GHC.Types.Nat) (t2 :: Foo1) (t3 :: Symbol). - Sing t1 - -> Sing t2 - -> Sing t3 - -> Sing (Apply (Apply (Apply (ShowsPrecSym0 :: TyFun GHC.Types.Nat ((~>) Foo1 ((~>) Symbol Symbol)) - -> GHC.Types.Type) t1) t2) t3) - sShowsPrec - _ - SMkFoo1 - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "MkFoo1"))) - sA_0123456789876543210 - instance SShow a => SShow (Foo2 a) where - sShowsPrec :: - forall (t1 :: GHC.Types.Nat) (t2 :: Foo2 a) (t3 :: Symbol). - Sing t1 - -> Sing t2 - -> Sing t3 - -> Sing (Apply (Apply (Apply (ShowsPrecSym0 :: TyFun GHC.Types.Nat ((~>) (Foo2 a) ((~>) Symbol Symbol)) - -> GHC.Types.Type) t1) t2) t3) - sShowsPrec - (sP_0123456789876543210 :: Sing p_0123456789876543210) - (SMkFoo2a (sArg_0123456789876543210 :: Sing arg_0123456789876543210) - (sArg_0123456789876543210 :: Sing arg_0123456789876543210)) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing - ((applySing ((singFun3 @ShowParenSym0) sShowParen)) - ((applySing - ((applySing ((singFun2 @(>@#@$)) (%>))) sP_0123456789876543210)) - (sFromInteger (sing :: Sing 10))))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "MkFoo2a ")))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((applySing - ((applySing ((singFun3 @ShowsPrecSym0) sShowsPrec)) - (sFromInteger (sing :: Sing 11)))) - sArg_0123456789876543210))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((singFun1 @ShowSpaceSym0) sShowSpace))) - ((applySing - ((applySing ((singFun3 @ShowsPrecSym0) sShowsPrec)) - (sFromInteger (sing :: Sing 11)))) - sArg_0123456789876543210)))))) - sA_0123456789876543210 - sShowsPrec - (sP_0123456789876543210 :: Sing p_0123456789876543210) - (SMkFoo2b (sArgL_0123456789876543210 :: Sing argL_0123456789876543210) - (sArgR_0123456789876543210 :: Sing argR_0123456789876543210)) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing - ((applySing ((singFun3 @ShowParenSym0) sShowParen)) - ((applySing - ((applySing ((singFun2 @(>@#@$)) (%>))) sP_0123456789876543210)) - (sFromInteger (sing :: Sing 5))))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((applySing - ((applySing ((singFun3 @ShowsPrecSym0) sShowsPrec)) - (sFromInteger (sing :: Sing 6)))) - sArgL_0123456789876543210))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing " `MkFoo2b` ")))) - ((applySing - ((applySing ((singFun3 @ShowsPrecSym0) sShowsPrec)) - (sFromInteger (sing :: Sing 6)))) - sArgR_0123456789876543210))))) - sA_0123456789876543210 - sShowsPrec - (sP_0123456789876543210 :: Sing p_0123456789876543210) - ((:%*:) (sArg_0123456789876543210 :: Sing arg_0123456789876543210) - (sArg_0123456789876543210 :: Sing arg_0123456789876543210)) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing - ((applySing ((singFun3 @ShowParenSym0) sShowParen)) - ((applySing - ((applySing ((singFun2 @(>@#@$)) (%>))) sP_0123456789876543210)) - (sFromInteger (sing :: Sing 10))))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "(:*:) ")))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((applySing - ((applySing ((singFun3 @ShowsPrecSym0) sShowsPrec)) - (sFromInteger (sing :: Sing 11)))) - sArg_0123456789876543210))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((singFun1 @ShowSpaceSym0) sShowSpace))) - ((applySing - ((applySing ((singFun3 @ShowsPrecSym0) sShowsPrec)) - (sFromInteger (sing :: Sing 11)))) - sArg_0123456789876543210)))))) - sA_0123456789876543210 - sShowsPrec - (sP_0123456789876543210 :: Sing p_0123456789876543210) - ((:%&:) (sArgL_0123456789876543210 :: Sing argL_0123456789876543210) - (sArgR_0123456789876543210 :: Sing argR_0123456789876543210)) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing - ((applySing ((singFun3 @ShowParenSym0) sShowParen)) - ((applySing - ((applySing ((singFun2 @(>@#@$)) (%>))) sP_0123456789876543210)) - (sFromInteger (sing :: Sing 5))))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((applySing - ((applySing ((singFun3 @ShowsPrecSym0) sShowsPrec)) - (sFromInteger (sing :: Sing 6)))) - sArgL_0123456789876543210))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing " :&: ")))) - ((applySing - ((applySing ((singFun3 @ShowsPrecSym0) sShowsPrec)) - (sFromInteger (sing :: Sing 6)))) - sArgR_0123456789876543210))))) - sA_0123456789876543210 - instance SShow Bool => SShow Foo3 where - sShowsPrec :: - forall (t1 :: GHC.Types.Nat) (t2 :: Foo3) (t3 :: Symbol). - Sing t1 - -> Sing t2 - -> Sing t3 - -> Sing (Apply (Apply (Apply (ShowsPrecSym0 :: TyFun GHC.Types.Nat ((~>) Foo3 ((~>) Symbol Symbol)) - -> GHC.Types.Type) t1) t2) t3) - sShowsPrec - (sP_0123456789876543210 :: Sing p_0123456789876543210) - (SMkFoo3 (sArg_0123456789876543210 :: Sing arg_0123456789876543210) - (sArg_0123456789876543210 :: Sing arg_0123456789876543210)) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing - ((applySing ((singFun3 @ShowParenSym0) sShowParen)) - ((applySing - ((applySing ((singFun2 @(>@#@$)) (%>))) sP_0123456789876543210)) - (sFromInteger (sing :: Sing 10))))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "MkFoo3 ")))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((applySing ((singFun2 @ShowCharSym0) sShowChar)) - (sing :: Sing "{")))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "getFoo3a = ")))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((applySing - ((applySing ((singFun3 @ShowsPrecSym0) sShowsPrec)) - (sFromInteger (sing :: Sing 0)))) - sArg_0123456789876543210))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((singFun1 @ShowCommaSpaceSym0) sShowCommaSpace))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "(***) = ")))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((applySing - ((applySing ((singFun3 @ShowsPrecSym0) sShowsPrec)) - (sFromInteger (sing :: Sing 0)))) - sArg_0123456789876543210))) - ((applySing ((singFun2 @ShowCharSym0) sShowChar)) - (sing :: Sing "}"))))))))))) - sA_0123456789876543210 - instance Show (SFoo1 (z :: Foo1)) where - showsPrec _ SMkFoo1 = showString "SMkFoo1" - instance Data.Singletons.ShowSing.ShowSing a => - Show (SFoo2 (z :: Foo2 a)) where - showsPrec - p_0123456789876543210 - (SMkFoo2a (arg_0123456789876543210 :: Sing argTy_0123456789876543210) - (arg_0123456789876543210 :: Sing argTy_0123456789876543210)) - = (showParen (((>) p_0123456789876543210) 10)) - (((.) (showString "SMkFoo2a ")) - (((.) ((showsPrec 11) arg_0123456789876543210)) - (((.) GHC.Show.showSpace) - ((showsPrec 11) arg_0123456789876543210)))) :: - (Data.Singletons.ShowSing.ShowSing' argTy_0123456789876543210, - Data.Singletons.ShowSing.ShowSing' argTy_0123456789876543210) => - ShowS - showsPrec - p_0123456789876543210 - (SMkFoo2b (argL_0123456789876543210 :: Sing argTyL_0123456789876543210) - (argR_0123456789876543210 :: Sing argTyR_0123456789876543210)) - = (showParen (((>) p_0123456789876543210) 9)) - (((.) ((showsPrec 10) argL_0123456789876543210)) - (((.) (showString " `SMkFoo2b` ")) - ((showsPrec 10) argR_0123456789876543210))) :: - (Data.Singletons.ShowSing.ShowSing' argTyL_0123456789876543210, - Data.Singletons.ShowSing.ShowSing' argTyR_0123456789876543210) => - ShowS - showsPrec - p_0123456789876543210 - ((:%*:) (arg_0123456789876543210 :: Sing argTy_0123456789876543210) - (arg_0123456789876543210 :: Sing argTy_0123456789876543210)) - = (showParen (((>) p_0123456789876543210) 10)) - (((.) (showString "(:%*:) ")) - (((.) ((showsPrec 11) arg_0123456789876543210)) - (((.) GHC.Show.showSpace) - ((showsPrec 11) arg_0123456789876543210)))) :: - (Data.Singletons.ShowSing.ShowSing' argTy_0123456789876543210, - Data.Singletons.ShowSing.ShowSing' argTy_0123456789876543210) => - ShowS - showsPrec - p_0123456789876543210 - ((:%&:) (argL_0123456789876543210 :: Sing argTyL_0123456789876543210) - (argR_0123456789876543210 :: Sing argTyR_0123456789876543210)) - = (showParen (((>) p_0123456789876543210) 9)) - (((.) ((showsPrec 10) argL_0123456789876543210)) - (((.) (showString " :%&: ")) - ((showsPrec 10) argR_0123456789876543210))) :: - (Data.Singletons.ShowSing.ShowSing' argTyL_0123456789876543210, - Data.Singletons.ShowSing.ShowSing' argTyR_0123456789876543210) => - ShowS - instance Data.Singletons.ShowSing.ShowSing Bool => - Show (SFoo3 (z :: Foo3)) where - showsPrec - p_0123456789876543210 - (SMkFoo3 (arg_0123456789876543210 :: Sing argTy_0123456789876543210) - (arg_0123456789876543210 :: Sing argTy_0123456789876543210)) - = (showParen (((>) p_0123456789876543210) 10)) - (((.) (showString "SMkFoo3 ")) - (((.) (showChar '{')) - (((.) (showString "sGetFoo3a = ")) - (((.) ((showsPrec 0) arg_0123456789876543210)) - (((.) GHC.Show.showCommaSpace) - (((.) (showString "(%***) = ")) - (((.) ((showsPrec 0) arg_0123456789876543210)) - (showChar '}')))))))) :: - (Data.Singletons.ShowSing.ShowSing' argTy_0123456789876543210, - Data.Singletons.ShowSing.ShowSing' argTy_0123456789876543210) => - ShowS - instance SingI MkFoo1 where - sing = SMkFoo1 - instance (SingI n, SingI n) => - SingI (MkFoo2a (n :: a) (n :: a)) where - sing = (SMkFoo2a sing) sing - instance SingI (MkFoo2aSym0 :: (~>) a ((~>) a (Foo2 a))) where - sing = (singFun2 @MkFoo2aSym0) SMkFoo2a - instance SingI d => - SingI (MkFoo2aSym1 (d :: a) :: (~>) a (Foo2 a)) where - sing = (singFun1 @(MkFoo2aSym1 (d :: a))) (SMkFoo2a (sing @d)) - instance (SingI n, SingI n) => - SingI (MkFoo2b (n :: a) (n :: a)) where - sing = (SMkFoo2b sing) sing - instance SingI (MkFoo2bSym0 :: (~>) a ((~>) a (Foo2 a))) where - sing = (singFun2 @MkFoo2bSym0) SMkFoo2b - instance SingI d => - SingI (MkFoo2bSym1 (d :: a) :: (~>) a (Foo2 a)) where - sing = (singFun1 @(MkFoo2bSym1 (d :: a))) (SMkFoo2b (sing @d)) - instance (SingI n, SingI n) => - SingI ((:*:) (n :: a) (n :: a)) where - sing = ((:%*:) sing) sing - instance SingI ((:*:@#@$) :: (~>) a ((~>) a (Foo2 a))) where - sing = (singFun2 @(:*:@#@$)) (:%*:) - instance SingI d => - SingI ((:*:@#@$$) (d :: a) :: (~>) a (Foo2 a)) where - sing = (singFun1 @((:*:@#@$$) (d :: a))) ((:%*:) (sing @d)) - instance (SingI n, SingI n) => - SingI ((:&:) (n :: a) (n :: a)) where - sing = ((:%&:) sing) sing - instance SingI ((:&:@#@$) :: (~>) a ((~>) a (Foo2 a))) where - sing = (singFun2 @(:&:@#@$)) (:%&:) - instance SingI d => - SingI ((:&:@#@$$) (d :: a) :: (~>) a (Foo2 a)) where - sing = (singFun1 @((:&:@#@$$) (d :: a))) ((:%&:) (sing @d)) - instance (SingI n, SingI n) => - SingI (MkFoo3 (n :: Bool) (n :: Bool)) where - sing = (SMkFoo3 sing) sing - instance SingI (MkFoo3Sym0 :: (~>) Bool ((~>) Bool Foo3)) where - sing = (singFun2 @MkFoo3Sym0) SMkFoo3 - instance SingI d => - SingI (MkFoo3Sym1 (d :: Bool) :: (~>) Bool Foo3) where - sing = (singFun1 @(MkFoo3Sym1 (d :: Bool))) (SMkFoo3 (sing @d)) diff --git a/tests/compile-and-dump/Singletons/ShowDeriving.hs b/tests/compile-and-dump/Singletons/ShowDeriving.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/ShowDeriving.hs +++ /dev/null @@ -1,41 +0,0 @@ -module Singletons.ShowDeriving where - -import Data.Type.Equality -import Data.Singletons.Prelude -import Data.Singletons.Prelude.Show -import Data.Singletons.TH - -$(singletons [d| - data Foo1 = MkFoo1 deriving Show - - infixl 5 `MkFoo2b`, :*:, :&: - data Foo2 a = MkFoo2a a a - | a `MkFoo2b` a - | (:*:) a a - | a :&: a - deriving Show - - data Foo3 = MkFoo3 { getFoo3a :: Bool, (***) :: Bool } deriving Show - - |]) - -foo1 :: "MkFoo1" :~: Show_ MkFoo1 -foo1 = Refl - -foo2a :: "(MkFoo2a LT GT)" :~: ShowsPrec 11 (MkFoo2a LT GT) "" -foo2a = Refl - -foo2b :: "True `MkFoo2b` False" :~: Show_ (True `MkFoo2b` False) -foo2b = Refl - -foo2c :: "(:*:) () ()" :~: Show_ ('() :*: '()) -foo2c = Refl - -foo2d' :: "False :&: True" :~: ShowsPrec 5 (False :&: True) "" -foo2d' = Refl - -foo2d'' :: "(False :&: True)" :~: ShowsPrec 6 (False :&: True) "" -foo2d'' = Refl - -foo3 :: "MkFoo3 {getFoo3a = True, (***) = False}" :~: Show_ (MkFoo3 True False) -foo3 = Refl diff --git a/tests/compile-and-dump/Singletons/StandaloneDeriving.ghc88.template b/tests/compile-and-dump/Singletons/StandaloneDeriving.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/StandaloneDeriving.ghc88.template +++ /dev/null @@ -1,475 +0,0 @@ -Singletons/StandaloneDeriving.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| infixl 6 :*: - - data T a b = a :*: b - data S = S1 | S2 - - deriving instance Enum S - deriving instance Bounded S - deriving instance Show S - deriving instance Ord S - deriving instance Eq S - deriving instance Show a => Show (T a ()) - deriving instance Ord a => Ord (T a ()) - deriving instance Eq a => Eq (T a ()) |] - ======> - infixl 6 :*: - data T a b = a :*: b - data S = S1 | S2 - deriving instance Eq a => Eq (T a ()) - deriving instance Ord a => Ord (T a ()) - deriving instance Show a => Show (T a ()) - deriving instance Eq S - deriving instance Ord S - deriving instance Show S - deriving instance Bounded S - deriving instance Enum S - type (:*:@#@$$$) (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: b0123456789876543210) = - (:*:) t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings ((:*:@#@$$) t0123456789876543210) where - suppressUnusedWarnings = snd (((,) (::*:@#@$$###)) ()) - data (:*:@#@$$) (t0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210. - (~>) b0123456789876543210 (T a0123456789876543210 b0123456789876543210) - where - (::*:@#@$$###) :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply ((:*:@#@$$) t0123456789876543210) arg) ((:*:@#@$$$) t0123456789876543210 arg) => - (:*:@#@$$) t0123456789876543210 t0123456789876543210 - type instance Apply ((:*:@#@$$) t0123456789876543210) t0123456789876543210 = (:*:) t0123456789876543210 t0123456789876543210 - infixl 6 :*:@#@$$ - instance SuppressUnusedWarnings (:*:@#@$) where - suppressUnusedWarnings = snd (((,) (::*:@#@$###)) ()) - data (:*:@#@$) :: forall a0123456789876543210 b0123456789876543210. - (~>) a0123456789876543210 ((~>) b0123456789876543210 (T a0123456789876543210 b0123456789876543210)) - where - (::*:@#@$###) :: forall t0123456789876543210 - arg. SameKind (Apply (:*:@#@$) arg) ((:*:@#@$$) arg) => - (:*:@#@$) t0123456789876543210 - type instance Apply (:*:@#@$) t0123456789876543210 = (:*:@#@$$) t0123456789876543210 - infixl 6 :*:@#@$ - type S1Sym0 = S1 - type S2Sym0 = S2 - type family Compare_0123456789876543210 (a :: T a ()) (a :: T a ()) :: Ordering where - Compare_0123456789876543210 ((:*:) a_0123456789876543210 a_0123456789876543210) ((:*:) b_0123456789876543210 b_0123456789876543210) = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) '[])) - type Compare_0123456789876543210Sym2 (a0123456789876543210 :: T a0123456789876543210 ()) (a0123456789876543210 :: T a0123456789876543210 ()) = - Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Compare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym1KindInference) ()) - data Compare_0123456789876543210Sym1 (a0123456789876543210 :: T a0123456789876543210 ()) :: (~>) (T a0123456789876543210 ()) Ordering - where - Compare_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Compare_0123456789876543210Sym1 a0123456789876543210) arg) (Compare_0123456789876543210Sym2 a0123456789876543210 arg) => - Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Compare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Compare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym0KindInference) ()) - data Compare_0123456789876543210Sym0 :: forall a0123456789876543210. - (~>) (T a0123456789876543210 ()) ((~>) (T a0123456789876543210 ()) Ordering) - where - Compare_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Compare_0123456789876543210Sym0 arg) (Compare_0123456789876543210Sym1 arg) => - Compare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Compare_0123456789876543210Sym0 a0123456789876543210 = Compare_0123456789876543210Sym1 a0123456789876543210 - instance POrd (T a ()) where - type Compare a a = Apply (Apply Compare_0123456789876543210Sym0 a) a - type family ShowsPrec_0123456789876543210 (a :: GHC.Types.Nat) (a :: T a ()) (a :: Symbol) :: Symbol where - ShowsPrec_0123456789876543210 p_0123456789876543210 ((:*:) argL_0123456789876543210 argR_0123456789876543210) a_0123456789876543210 = Apply (Apply (Apply ShowParenSym0 (Apply (Apply (>@#@$) p_0123456789876543210) (FromInteger 6))) (Apply (Apply (.@#@$) (Apply (Apply ShowsPrecSym0 (FromInteger 7)) argL_0123456789876543210)) (Apply (Apply (.@#@$) (Apply ShowStringSym0 " :*: ")) (Apply (Apply ShowsPrecSym0 (FromInteger 7)) argR_0123456789876543210)))) a_0123456789876543210 - type ShowsPrec_0123456789876543210Sym3 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: T a0123456789876543210 ()) (a0123456789876543210 :: Symbol) = - ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym2KindInference) ()) - data ShowsPrec_0123456789876543210Sym2 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: T a0123456789876543210 ()) :: (~>) Symbol Symbol - where - ShowsPrec_0123456789876543210Sym2KindInference :: forall a0123456789876543210 - a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) arg) (ShowsPrec_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 arg) => - ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym1KindInference) ()) - data ShowsPrec_0123456789876543210Sym1 (a0123456789876543210 :: GHC.Types.Nat) :: forall a0123456789876543210. - (~>) (T a0123456789876543210 ()) ((~>) Symbol Symbol) - where - ShowsPrec_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) arg) (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 arg) => - ShowsPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ShowsPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym0KindInference) ()) - data ShowsPrec_0123456789876543210Sym0 :: forall a0123456789876543210. - (~>) GHC.Types.Nat ((~>) (T a0123456789876543210 ()) ((~>) Symbol Symbol)) - where - ShowsPrec_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply ShowsPrec_0123456789876543210Sym0 arg) (ShowsPrec_0123456789876543210Sym1 arg) => - ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ShowsPrec_0123456789876543210Sym0 a0123456789876543210 = ShowsPrec_0123456789876543210Sym1 a0123456789876543210 - instance PShow (T a ()) where - type ShowsPrec a a a = Apply (Apply (Apply ShowsPrec_0123456789876543210Sym0 a) a) a - type family Compare_0123456789876543210 (a :: S) (a :: S) :: Ordering where - Compare_0123456789876543210 S1 S1 = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) '[] - Compare_0123456789876543210 S2 S2 = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) '[] - Compare_0123456789876543210 S1 S2 = LTSym0 - Compare_0123456789876543210 S2 S1 = GTSym0 - type Compare_0123456789876543210Sym2 (a0123456789876543210 :: S) (a0123456789876543210 :: S) = - Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Compare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym1KindInference) ()) - data Compare_0123456789876543210Sym1 (a0123456789876543210 :: S) :: (~>) S Ordering - where - Compare_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Compare_0123456789876543210Sym1 a0123456789876543210) arg) (Compare_0123456789876543210Sym2 a0123456789876543210 arg) => - Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Compare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Compare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym0KindInference) ()) - data Compare_0123456789876543210Sym0 :: (~>) S ((~>) S Ordering) - where - Compare_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Compare_0123456789876543210Sym0 arg) (Compare_0123456789876543210Sym1 arg) => - Compare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Compare_0123456789876543210Sym0 a0123456789876543210 = Compare_0123456789876543210Sym1 a0123456789876543210 - instance POrd S where - type Compare a a = Apply (Apply Compare_0123456789876543210Sym0 a) a - type family ShowsPrec_0123456789876543210 (a :: GHC.Types.Nat) (a :: S) (a :: Symbol) :: Symbol where - ShowsPrec_0123456789876543210 _ S1 a_0123456789876543210 = Apply (Apply ShowStringSym0 "S1") a_0123456789876543210 - ShowsPrec_0123456789876543210 _ S2 a_0123456789876543210 = Apply (Apply ShowStringSym0 "S2") a_0123456789876543210 - type ShowsPrec_0123456789876543210Sym3 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: S) (a0123456789876543210 :: Symbol) = - ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym2KindInference) ()) - data ShowsPrec_0123456789876543210Sym2 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: S) :: (~>) Symbol Symbol - where - ShowsPrec_0123456789876543210Sym2KindInference :: forall a0123456789876543210 - a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) arg) (ShowsPrec_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 arg) => - ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym1KindInference) ()) - data ShowsPrec_0123456789876543210Sym1 (a0123456789876543210 :: GHC.Types.Nat) :: (~>) S ((~>) Symbol Symbol) - where - ShowsPrec_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) arg) (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 arg) => - ShowsPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ShowsPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym0KindInference) ()) - data ShowsPrec_0123456789876543210Sym0 :: (~>) GHC.Types.Nat ((~>) S ((~>) Symbol Symbol)) - where - ShowsPrec_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply ShowsPrec_0123456789876543210Sym0 arg) (ShowsPrec_0123456789876543210Sym1 arg) => - ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ShowsPrec_0123456789876543210Sym0 a0123456789876543210 = ShowsPrec_0123456789876543210Sym1 a0123456789876543210 - instance PShow S where - type ShowsPrec a a a = Apply (Apply (Apply ShowsPrec_0123456789876543210Sym0 a) a) a - type family MinBound_0123456789876543210 :: S where - MinBound_0123456789876543210 = S1Sym0 - type MinBound_0123456789876543210Sym0 = - MinBound_0123456789876543210 - type family MaxBound_0123456789876543210 :: S where - MaxBound_0123456789876543210 = S2Sym0 - type MaxBound_0123456789876543210Sym0 = - MaxBound_0123456789876543210 - instance PBounded S where - type MinBound = MinBound_0123456789876543210Sym0 - type MaxBound = MaxBound_0123456789876543210Sym0 - type family Case_0123456789876543210 n t where - Case_0123456789876543210 n 'True = S2Sym0 - Case_0123456789876543210 n 'False = Apply ErrorSym0 "toEnum: bad argument" - type family Case_0123456789876543210 n t where - Case_0123456789876543210 n 'True = S1Sym0 - Case_0123456789876543210 n 'False = Case_0123456789876543210 n (Apply (Apply (==@#@$) n) (FromInteger 1)) - type family ToEnum_0123456789876543210 (a :: GHC.Types.Nat) :: S where - ToEnum_0123456789876543210 n = Case_0123456789876543210 n (Apply (Apply (==@#@$) n) (FromInteger 0)) - type ToEnum_0123456789876543210Sym1 (a0123456789876543210 :: GHC.Types.Nat) = - ToEnum_0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ToEnum_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ToEnum_0123456789876543210Sym0KindInference) ()) - data ToEnum_0123456789876543210Sym0 :: (~>) GHC.Types.Nat S - where - ToEnum_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply ToEnum_0123456789876543210Sym0 arg) (ToEnum_0123456789876543210Sym1 arg) => - ToEnum_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ToEnum_0123456789876543210Sym0 a0123456789876543210 = ToEnum_0123456789876543210 a0123456789876543210 - type family FromEnum_0123456789876543210 (a :: S) :: GHC.Types.Nat where - FromEnum_0123456789876543210 S1 = FromInteger 0 - FromEnum_0123456789876543210 S2 = FromInteger 1 - type FromEnum_0123456789876543210Sym1 (a0123456789876543210 :: S) = - FromEnum_0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings FromEnum_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) FromEnum_0123456789876543210Sym0KindInference) ()) - data FromEnum_0123456789876543210Sym0 :: (~>) S GHC.Types.Nat - where - FromEnum_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply FromEnum_0123456789876543210Sym0 arg) (FromEnum_0123456789876543210Sym1 arg) => - FromEnum_0123456789876543210Sym0 a0123456789876543210 - type instance Apply FromEnum_0123456789876543210Sym0 a0123456789876543210 = FromEnum_0123456789876543210 a0123456789876543210 - instance PEnum S where - type ToEnum a = Apply ToEnum_0123456789876543210Sym0 a - type FromEnum a = Apply FromEnum_0123456789876543210Sym0 a - type family Equals_0123456789876543210 (a :: T a ()) (b :: T a ()) :: Bool where - Equals_0123456789876543210 ((:*:) a a) ((:*:) b b) = (&&) ((==) a b) ((==) a b) - Equals_0123456789876543210 (_ :: T a ()) (_ :: T a ()) = FalseSym0 - instance PEq (T a ()) where - type (==) a b = Equals_0123456789876543210 a b - type family Equals_0123456789876543210 (a :: S) (b :: S) :: Bool where - Equals_0123456789876543210 S1 S1 = TrueSym0 - Equals_0123456789876543210 S2 S2 = TrueSym0 - Equals_0123456789876543210 (_ :: S) (_ :: S) = FalseSym0 - instance PEq S where - type (==) a b = Equals_0123456789876543210 a b - infixl 6 :%*: - data ST :: forall a b. T a b -> GHC.Types.Type - where - (:%*:) :: forall a b (n :: a) (n :: b). - (Sing (n :: a)) -> (Sing (n :: b)) -> ST ((:*:) n n) - type instance Sing @(T a b) = ST - instance (SingKind a, SingKind b) => SingKind (T a b) where - type Demote (T a b) = T (Demote a) (Demote b) - fromSing ((:%*:) b b) = ((:*:) (fromSing b)) (fromSing b) - toSing ((:*:) (b :: Demote a) (b :: Demote b)) - = case ((,) (toSing b :: SomeSing a)) (toSing b :: SomeSing b) of { - (,) (SomeSing c) (SomeSing c) -> SomeSing (((:%*:) c) c) } - data SS :: S -> GHC.Types.Type - where - SS1 :: SS S1 - SS2 :: SS S2 - type instance Sing @S = SS - instance SingKind S where - type Demote S = S - fromSing SS1 = S1 - fromSing SS2 = S2 - toSing S1 = SomeSing SS1 - toSing S2 = SomeSing SS2 - instance SOrd a => SOrd (T a ()) where - sCompare :: - forall (t1 :: T a ()) (t2 :: T a ()). - Sing t1 - -> Sing t2 - -> Sing (Apply (Apply (CompareSym0 :: TyFun (T a ()) ((~>) (T a ()) Ordering) - -> GHC.Types.Type) t1) t2) - sCompare - ((:%*:) (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210)) - ((:%*:) (sB_0123456789876543210 :: Sing b_0123456789876543210) - (sB_0123456789876543210 :: Sing b_0123456789876543210)) - = (applySing - ((applySing - ((applySing ((singFun3 @FoldlSym0) sFoldl)) - ((singFun2 @ThenCmpSym0) sThenCmp))) - SEQ)) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing - ((applySing ((singFun2 @CompareSym0) sCompare)) - sA_0123456789876543210)) - sB_0123456789876543210))) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing - ((applySing ((singFun2 @CompareSym0) sCompare)) - sA_0123456789876543210)) - sB_0123456789876543210))) - SNil)) - instance SShow a => SShow (T a ()) where - sShowsPrec :: - forall (t1 :: GHC.Types.Nat) (t2 :: T a ()) (t3 :: Symbol). - Sing t1 - -> Sing t2 - -> Sing t3 - -> Sing (Apply (Apply (Apply (ShowsPrecSym0 :: TyFun GHC.Types.Nat ((~>) (T a ()) ((~>) Symbol Symbol)) - -> GHC.Types.Type) t1) t2) t3) - sShowsPrec - (sP_0123456789876543210 :: Sing p_0123456789876543210) - ((:%*:) (sArgL_0123456789876543210 :: Sing argL_0123456789876543210) - (sArgR_0123456789876543210 :: Sing argR_0123456789876543210)) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing - ((applySing ((singFun3 @ShowParenSym0) sShowParen)) - ((applySing - ((applySing ((singFun2 @(>@#@$)) (%>))) sP_0123456789876543210)) - (sFromInteger (sing :: Sing 6))))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((applySing - ((applySing ((singFun3 @ShowsPrecSym0) sShowsPrec)) - (sFromInteger (sing :: Sing 7)))) - sArgL_0123456789876543210))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing " :*: ")))) - ((applySing - ((applySing ((singFun3 @ShowsPrecSym0) sShowsPrec)) - (sFromInteger (sing :: Sing 7)))) - sArgR_0123456789876543210))))) - sA_0123456789876543210 - instance SOrd S where - sCompare :: - forall (t1 :: S) (t2 :: S). - Sing t1 - -> Sing t2 - -> Sing (Apply (Apply (CompareSym0 :: TyFun S ((~>) S Ordering) - -> GHC.Types.Type) t1) t2) - sCompare SS1 SS1 - = (applySing - ((applySing - ((applySing ((singFun3 @FoldlSym0) sFoldl)) - ((singFun2 @ThenCmpSym0) sThenCmp))) - SEQ)) - SNil - sCompare SS2 SS2 - = (applySing - ((applySing - ((applySing ((singFun3 @FoldlSym0) sFoldl)) - ((singFun2 @ThenCmpSym0) sThenCmp))) - SEQ)) - SNil - sCompare SS1 SS2 = SLT - sCompare SS2 SS1 = SGT - instance SShow S where - sShowsPrec :: - forall (t1 :: GHC.Types.Nat) (t2 :: S) (t3 :: Symbol). - Sing t1 - -> Sing t2 - -> Sing t3 - -> Sing (Apply (Apply (Apply (ShowsPrecSym0 :: TyFun GHC.Types.Nat ((~>) S ((~>) Symbol Symbol)) - -> GHC.Types.Type) t1) t2) t3) - sShowsPrec - _ - SS1 - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "S1"))) - sA_0123456789876543210 - sShowsPrec - _ - SS2 - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "S2"))) - sA_0123456789876543210 - instance SBounded S where - sMinBound :: Sing (MinBoundSym0 :: S) - sMaxBound :: Sing (MaxBoundSym0 :: S) - sMinBound = SS1 - sMaxBound = SS2 - instance SEnum S where - sToEnum :: - forall (t :: GHC.Types.Nat). - Sing t - -> Sing (Apply (ToEnumSym0 :: TyFun GHC.Types.Nat S - -> GHC.Types.Type) t) - sFromEnum :: - forall (t :: S). - Sing t - -> Sing (Apply (FromEnumSym0 :: TyFun S GHC.Types.Nat - -> GHC.Types.Type) t) - sToEnum (sN :: Sing n) - = (id - @(Sing (Case_0123456789876543210 n (Apply (Apply (==@#@$) n) (FromInteger 0))))) - (case - (applySing ((applySing ((singFun2 @(==@#@$)) (%==))) sN)) - (sFromInteger (sing :: Sing 0)) - of - STrue -> SS1 - SFalse - -> (id - @(Sing (Case_0123456789876543210 n (Apply (Apply (==@#@$) n) (FromInteger 1))))) - (case - (applySing ((applySing ((singFun2 @(==@#@$)) (%==))) sN)) - (sFromInteger (sing :: Sing 1)) - of - STrue -> SS2 - SFalse -> sError (sing :: Sing "toEnum: bad argument"))) - sFromEnum SS1 = sFromInteger (sing :: Sing 0) - sFromEnum SS2 = sFromInteger (sing :: Sing 1) - instance SEq a => SEq (T a ()) where - (%==) ((:%*:) a a) ((:%*:) b b) - = ((%&&) (((%==) a) b)) (((%==) a) b) - instance SDecide a => SDecide (T a ()) where - (%~) ((:%*:) a a) ((:%*:) b b) - = case ((,) (((%~) a) b)) (((%~) a) b) of - (,) (Proved Refl) (Proved Refl) -> Proved Refl - (,) (Disproved contra) _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - (,) _ (Disproved contra) - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - instance SDecide a => - Data.Type.Equality.TestEquality (ST :: T a () - -> GHC.Types.Type) where - Data.Type.Equality.testEquality - = Data.Singletons.Decide.decideEquality - instance SDecide a => - Data.Type.Coercion.TestCoercion (ST :: T a () - -> GHC.Types.Type) where - Data.Type.Coercion.testCoercion - = Data.Singletons.Decide.decideCoercion - instance SEq S where - (%==) SS1 SS1 = STrue - (%==) SS1 SS2 = SFalse - (%==) SS2 SS1 = SFalse - (%==) SS2 SS2 = STrue - instance SDecide S where - (%~) SS1 SS1 = Proved Refl - (%~) SS1 SS2 = Disproved (\ x -> case x of) - (%~) SS2 SS1 = Disproved (\ x -> case x of) - (%~) SS2 SS2 = Proved Refl - instance Data.Type.Equality.TestEquality (SS :: S - -> GHC.Types.Type) where - Data.Type.Equality.testEquality - = Data.Singletons.Decide.decideEquality - instance Data.Type.Coercion.TestCoercion (SS :: S - -> GHC.Types.Type) where - Data.Type.Coercion.testCoercion - = Data.Singletons.Decide.decideCoercion - instance Data.Singletons.ShowSing.ShowSing a => - Show (ST (z :: T a ())) where - showsPrec - p_0123456789876543210 - ((:%*:) (argL_0123456789876543210 :: Sing argTyL_0123456789876543210) - (argR_0123456789876543210 :: Sing argTyR_0123456789876543210)) - = (showParen (((>) p_0123456789876543210) 9)) - (((.) ((showsPrec 10) argL_0123456789876543210)) - (((.) (showString " :%*: ")) - ((showsPrec 10) argR_0123456789876543210))) :: - (Data.Singletons.ShowSing.ShowSing' argTyL_0123456789876543210, - Data.Singletons.ShowSing.ShowSing' argTyR_0123456789876543210) => - ShowS - instance Show (SS (z :: S)) where - showsPrec _ SS1 = showString "SS1" - showsPrec _ SS2 = showString "SS2" - instance (SingI n, SingI n) => - SingI ((:*:) (n :: a) (n :: b)) where - sing = ((:%*:) sing) sing - instance SingI ((:*:@#@$) :: (~>) a ((~>) b (T a b))) where - sing = (singFun2 @(:*:@#@$)) (:%*:) - instance SingI d => - SingI ((:*:@#@$$) (d :: a) :: (~>) b (T a b)) where - sing = (singFun1 @((:*:@#@$$) (d :: a))) ((:%*:) (sing @d)) - instance SingI S1 where - sing = SS1 - instance SingI S2 where - sing = SS2 diff --git a/tests/compile-and-dump/Singletons/StandaloneDeriving.hs b/tests/compile-and-dump/Singletons/StandaloneDeriving.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/StandaloneDeriving.hs +++ /dev/null @@ -1,30 +0,0 @@ -module Singletons.StandaloneDeriving where - -import Data.Singletons.Prelude -import Data.Singletons.Prelude.Show -import Data.Singletons.TH - -$(singletons [d| - - infixl 6 :*: - data T a b = a :*: b - data S = S1 | S2 - - deriving instance Eq a => Eq (T a ()) - deriving instance Ord a => Ord (T a ()) - deriving instance Show a => Show (T a ()) - - deriving instance Eq S - deriving instance Ord S - deriving instance Show S - deriving instance Bounded S - deriving instance Enum S - - |]) - --- Ensure that the fixity is discovered -test1 :: "() :*: ()" :~: ShowsPrec 6 ('() :*: '()) "" -test1 = Refl - -test2 :: "(() :*: ())" :~: ShowsPrec 7 ('() :*: '()) "" -test2 = Refl diff --git a/tests/compile-and-dump/Singletons/Star.ghc88.template b/tests/compile-and-dump/Singletons/Star.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Star.ghc88.template +++ /dev/null @@ -1,421 +0,0 @@ -Singletons/Star.hs:0:0:: Splicing declarations - singletonStar [''Nat, ''Int, ''String, ''Maybe, ''Vec] - ======> - data Rep :: Type - where - Singletons.Star.Nat :: Rep - Singletons.Star.Int :: Rep - Singletons.Star.String :: Rep - Singletons.Star.Maybe :: Rep -> Rep - Singletons.Star.Vec :: Rep -> Nat -> Rep - deriving (Eq, Ord, Read, Show) - type NatSym0 = Nat - type IntSym0 = Int - type StringSym0 = String - type MaybeSym1 (t0123456789876543210 :: Type) = - Maybe t0123456789876543210 - instance SuppressUnusedWarnings MaybeSym0 where - suppressUnusedWarnings = snd (((,) MaybeSym0KindInference) ()) - data MaybeSym0 :: (~>) Type Type - where - MaybeSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply MaybeSym0 arg) (MaybeSym1 arg) => - MaybeSym0 t0123456789876543210 - type instance Apply MaybeSym0 t0123456789876543210 = Maybe t0123456789876543210 - type VecSym2 (t0123456789876543210 :: Type) (t0123456789876543210 :: Nat) = - Vec t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (VecSym1 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) VecSym1KindInference) ()) - data VecSym1 (t0123456789876543210 :: Type) :: (~>) Nat Type - where - VecSym1KindInference :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (VecSym1 t0123456789876543210) arg) (VecSym2 t0123456789876543210 arg) => - VecSym1 t0123456789876543210 t0123456789876543210 - type instance Apply (VecSym1 t0123456789876543210) t0123456789876543210 = Vec t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings VecSym0 where - suppressUnusedWarnings = snd (((,) VecSym0KindInference) ()) - data VecSym0 :: (~>) Type ((~>) Nat Type) - where - VecSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply VecSym0 arg) (VecSym1 arg) => - VecSym0 t0123456789876543210 - type instance Apply VecSym0 t0123456789876543210 = VecSym1 t0123456789876543210 - type family Equals_0123456789876543210 (a :: Type) (b :: Type) :: Bool where - Equals_0123456789876543210 Nat Nat = TrueSym0 - Equals_0123456789876543210 Int Int = TrueSym0 - Equals_0123456789876543210 String String = TrueSym0 - Equals_0123456789876543210 (Maybe a) (Maybe b) = (==) a b - Equals_0123456789876543210 (Vec a a) (Vec b b) = (&&) ((==) a b) ((==) a b) - Equals_0123456789876543210 (_ :: Type) (_ :: Type) = FalseSym0 - instance PEq Type where - type (==) a b = Equals_0123456789876543210 a b - type family Compare_0123456789876543210 (a :: Type) (a :: Type) :: Ordering where - Compare_0123456789876543210 Nat Nat = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) '[] - Compare_0123456789876543210 Int Int = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) '[] - Compare_0123456789876543210 String String = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) '[] - Compare_0123456789876543210 (Maybe a_0123456789876543210) (Maybe b_0123456789876543210) = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) '[]) - Compare_0123456789876543210 (Vec a_0123456789876543210 a_0123456789876543210) (Vec b_0123456789876543210 b_0123456789876543210) = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) '[])) - Compare_0123456789876543210 Nat Int = LTSym0 - Compare_0123456789876543210 Nat String = LTSym0 - Compare_0123456789876543210 Nat (Maybe _) = LTSym0 - Compare_0123456789876543210 Nat (Vec _ _) = LTSym0 - Compare_0123456789876543210 Int Nat = GTSym0 - Compare_0123456789876543210 Int String = LTSym0 - Compare_0123456789876543210 Int (Maybe _) = LTSym0 - Compare_0123456789876543210 Int (Vec _ _) = LTSym0 - Compare_0123456789876543210 String Nat = GTSym0 - Compare_0123456789876543210 String Int = GTSym0 - Compare_0123456789876543210 String (Maybe _) = LTSym0 - Compare_0123456789876543210 String (Vec _ _) = LTSym0 - Compare_0123456789876543210 (Maybe _) Nat = GTSym0 - Compare_0123456789876543210 (Maybe _) Int = GTSym0 - Compare_0123456789876543210 (Maybe _) String = GTSym0 - Compare_0123456789876543210 (Maybe _) (Vec _ _) = LTSym0 - Compare_0123456789876543210 (Vec _ _) Nat = GTSym0 - Compare_0123456789876543210 (Vec _ _) Int = GTSym0 - Compare_0123456789876543210 (Vec _ _) String = GTSym0 - Compare_0123456789876543210 (Vec _ _) (Maybe _) = GTSym0 - type Compare_0123456789876543210Sym2 (a0123456789876543210 :: Type) (a0123456789876543210 :: Type) = - Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Compare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym1KindInference) ()) - data Compare_0123456789876543210Sym1 (a0123456789876543210 :: Type) :: (~>) Type Ordering - where - Compare_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Compare_0123456789876543210Sym1 a0123456789876543210) arg) (Compare_0123456789876543210Sym2 a0123456789876543210 arg) => - Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Compare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Compare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym0KindInference) ()) - data Compare_0123456789876543210Sym0 :: (~>) Type ((~>) Type Ordering) - where - Compare_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Compare_0123456789876543210Sym0 arg) (Compare_0123456789876543210Sym1 arg) => - Compare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Compare_0123456789876543210Sym0 a0123456789876543210 = Compare_0123456789876543210Sym1 a0123456789876543210 - instance POrd Type where - type Compare a a = Apply (Apply Compare_0123456789876543210Sym0 a) a - type family ShowsPrec_0123456789876543210 (a :: GHC.Types.Nat) (a :: Type) (a :: Symbol) :: Symbol where - ShowsPrec_0123456789876543210 _ Nat a_0123456789876543210 = Apply (Apply ShowStringSym0 "Nat") a_0123456789876543210 - ShowsPrec_0123456789876543210 _ Int a_0123456789876543210 = Apply (Apply ShowStringSym0 "Int") a_0123456789876543210 - ShowsPrec_0123456789876543210 _ String a_0123456789876543210 = Apply (Apply ShowStringSym0 "String") a_0123456789876543210 - ShowsPrec_0123456789876543210 p_0123456789876543210 (Maybe arg_0123456789876543210) a_0123456789876543210 = Apply (Apply (Apply ShowParenSym0 (Apply (Apply (>@#@$) p_0123456789876543210) (FromInteger 10))) (Apply (Apply (.@#@$) (Apply ShowStringSym0 "Maybe ")) (Apply (Apply ShowsPrecSym0 (FromInteger 11)) arg_0123456789876543210))) a_0123456789876543210 - ShowsPrec_0123456789876543210 p_0123456789876543210 (Vec arg_0123456789876543210 arg_0123456789876543210) a_0123456789876543210 = Apply (Apply (Apply ShowParenSym0 (Apply (Apply (>@#@$) p_0123456789876543210) (FromInteger 10))) (Apply (Apply (.@#@$) (Apply ShowStringSym0 "Vec ")) (Apply (Apply (.@#@$) (Apply (Apply ShowsPrecSym0 (FromInteger 11)) arg_0123456789876543210)) (Apply (Apply (.@#@$) ShowSpaceSym0) (Apply (Apply ShowsPrecSym0 (FromInteger 11)) arg_0123456789876543210))))) a_0123456789876543210 - type ShowsPrec_0123456789876543210Sym3 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: Type) (a0123456789876543210 :: Symbol) = - ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym2KindInference) ()) - data ShowsPrec_0123456789876543210Sym2 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: Type) :: (~>) Symbol Symbol - where - ShowsPrec_0123456789876543210Sym2KindInference :: forall a0123456789876543210 - a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) arg) (ShowsPrec_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 arg) => - ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym1KindInference) ()) - data ShowsPrec_0123456789876543210Sym1 (a0123456789876543210 :: GHC.Types.Nat) :: (~>) Type ((~>) Symbol Symbol) - where - ShowsPrec_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) arg) (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 arg) => - ShowsPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ShowsPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym0KindInference) ()) - data ShowsPrec_0123456789876543210Sym0 :: (~>) GHC.Types.Nat ((~>) Type ((~>) Symbol Symbol)) - where - ShowsPrec_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply ShowsPrec_0123456789876543210Sym0 arg) (ShowsPrec_0123456789876543210Sym1 arg) => - ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ShowsPrec_0123456789876543210Sym0 a0123456789876543210 = ShowsPrec_0123456789876543210Sym1 a0123456789876543210 - instance PShow Type where - type ShowsPrec a a a = Apply (Apply (Apply ShowsPrec_0123456789876543210Sym0 a) a) a - data SRep :: Type -> Type - where - SNat :: SRep Nat - SInt :: SRep Int - SString :: SRep String - SMaybe :: forall (n :: Type). (Sing (n :: Type)) -> SRep (Maybe n) - SVec :: forall (n :: Type) (n :: Nat). - (Sing (n :: Type)) -> (Sing (n :: Nat)) -> SRep (Vec n n) - type instance Sing @Type = SRep - instance SingKind Type where - type Demote Type = 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 :: Demote Type)) - = case toSing b :: SomeSing Type of { - SomeSing c -> SomeSing (SMaybe c) } - toSing (Singletons.Star.Vec (b :: Demote Type) (b :: Demote Nat)) - = case - ((,) (toSing b :: SomeSing Type)) (toSing b :: SomeSing Nat) - of { - (,) (SomeSing c) (SomeSing c) -> SomeSing ((SVec c) c) } - instance (SEq Type, SEq Nat) => SEq Type 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 Type, SDecide Nat) => SDecide Type where - (%~) SNat SNat = Proved Refl - (%~) SNat SInt = Disproved (\ x -> case x of) - (%~) SNat SString = Disproved (\ x -> case x of) - (%~) SNat (SMaybe _) = Disproved (\ x -> case x of) - (%~) SNat (SVec _ _) = Disproved (\ x -> case x of) - (%~) SInt SNat = Disproved (\ x -> case x of) - (%~) SInt SInt = Proved Refl - (%~) SInt SString = Disproved (\ x -> case x of) - (%~) SInt (SMaybe _) = Disproved (\ x -> case x of) - (%~) SInt (SVec _ _) = Disproved (\ x -> case x of) - (%~) SString SNat = Disproved (\ x -> case x of) - (%~) SString SInt = Disproved (\ x -> case x of) - (%~) SString SString = Proved Refl - (%~) SString (SMaybe _) = Disproved (\ x -> case x of) - (%~) SString (SVec _ _) = Disproved (\ x -> case x of) - (%~) (SMaybe _) SNat = Disproved (\ x -> case x of) - (%~) (SMaybe _) SInt = Disproved (\ x -> case x of) - (%~) (SMaybe _) SString = Disproved (\ x -> case x of) - (%~) (SMaybe a) (SMaybe b) - = case ((%~) a) b of - Proved Refl -> Proved Refl - Disproved contra - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - (%~) (SMaybe _) (SVec _ _) = Disproved (\ x -> case x of) - (%~) (SVec _ _) SNat = Disproved (\ x -> case x of) - (%~) (SVec _ _) SInt = Disproved (\ x -> case x of) - (%~) (SVec _ _) SString = Disproved (\ x -> case x of) - (%~) (SVec _ _) (SMaybe _) = Disproved (\ x -> case x of) - (%~) (SVec a a) (SVec b b) - = case ((,) (((%~) a) b)) (((%~) a) b) of - (,) (Proved Refl) (Proved Refl) -> Proved Refl - (,) (Disproved contra) _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - (,) _ (Disproved contra) - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - instance (SDecide Type, SDecide Nat) => - Data.Type.Equality.TestEquality (SRep :: Type -> Type) where - Data.Type.Equality.testEquality = decideEquality - instance (SDecide Type, SDecide Nat) => - Data.Type.Coercion.TestCoercion (SRep :: Type -> Type) where - Data.Type.Coercion.testCoercion = decideCoercion - instance (SOrd Type, SOrd Nat) => SOrd Type where - sCompare :: - forall (t1 :: Type) (t2 :: Type). - Sing t1 - -> Sing t2 - -> Sing (Apply (Apply (CompareSym0 :: TyFun Type ((~>) Type Ordering) - -> Type) t1) t2) - sCompare SNat SNat - = (applySing - ((applySing - ((applySing ((singFun3 @FoldlSym0) sFoldl)) - ((singFun2 @ThenCmpSym0) sThenCmp))) - SEQ)) - SNil - sCompare SInt SInt - = (applySing - ((applySing - ((applySing ((singFun3 @FoldlSym0) sFoldl)) - ((singFun2 @ThenCmpSym0) sThenCmp))) - SEQ)) - SNil - sCompare SString SString - = (applySing - ((applySing - ((applySing ((singFun3 @FoldlSym0) sFoldl)) - ((singFun2 @ThenCmpSym0) sThenCmp))) - SEQ)) - SNil - sCompare - (SMaybe (sA_0123456789876543210 :: Sing a_0123456789876543210)) - (SMaybe (sB_0123456789876543210 :: Sing b_0123456789876543210)) - = (applySing - ((applySing - ((applySing ((singFun3 @FoldlSym0) sFoldl)) - ((singFun2 @ThenCmpSym0) sThenCmp))) - SEQ)) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing - ((applySing ((singFun2 @CompareSym0) sCompare)) - sA_0123456789876543210)) - sB_0123456789876543210))) - SNil) - sCompare - (SVec (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210)) - (SVec (sB_0123456789876543210 :: Sing b_0123456789876543210) - (sB_0123456789876543210 :: Sing b_0123456789876543210)) - = (applySing - ((applySing - ((applySing ((singFun3 @FoldlSym0) sFoldl)) - ((singFun2 @ThenCmpSym0) sThenCmp))) - SEQ)) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing - ((applySing ((singFun2 @CompareSym0) sCompare)) - sA_0123456789876543210)) - sB_0123456789876543210))) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing - ((applySing ((singFun2 @CompareSym0) sCompare)) - sA_0123456789876543210)) - sB_0123456789876543210))) - SNil)) - sCompare SNat SInt = SLT - sCompare SNat SString = SLT - sCompare SNat (SMaybe _) = SLT - sCompare SNat (SVec _ _) = SLT - sCompare SInt SNat = SGT - sCompare SInt SString = SLT - sCompare SInt (SMaybe _) = SLT - sCompare SInt (SVec _ _) = SLT - sCompare SString SNat = SGT - sCompare SString SInt = SGT - sCompare SString (SMaybe _) = SLT - sCompare SString (SVec _ _) = SLT - sCompare (SMaybe _) SNat = SGT - sCompare (SMaybe _) SInt = SGT - sCompare (SMaybe _) SString = SGT - sCompare (SMaybe _) (SVec _ _) = SLT - sCompare (SVec _ _) SNat = SGT - sCompare (SVec _ _) SInt = SGT - sCompare (SVec _ _) SString = SGT - sCompare (SVec _ _) (SMaybe _) = SGT - instance (SShow Type, SShow Nat) => SShow Type where - sShowsPrec :: - forall (t1 :: GHC.Types.Nat) (t2 :: Type) (t3 :: Symbol). - Sing t1 - -> Sing t2 - -> Sing t3 - -> Sing (Apply (Apply (Apply (ShowsPrecSym0 :: TyFun GHC.Types.Nat ((~>) Type ((~>) Symbol Symbol)) - -> Type) t1) t2) t3) - sShowsPrec - _ - SNat - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "Nat"))) - sA_0123456789876543210 - sShowsPrec - _ - SInt - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "Int"))) - sA_0123456789876543210 - sShowsPrec - _ - SString - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "String"))) - sA_0123456789876543210 - sShowsPrec - (sP_0123456789876543210 :: Sing p_0123456789876543210) - (SMaybe (sArg_0123456789876543210 :: Sing arg_0123456789876543210)) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing - ((applySing ((singFun3 @ShowParenSym0) sShowParen)) - ((applySing - ((applySing ((singFun2 @(>@#@$)) (%>))) sP_0123456789876543210)) - (sFromInteger (sing :: Sing 10))))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "Maybe ")))) - ((applySing - ((applySing ((singFun3 @ShowsPrecSym0) sShowsPrec)) - (sFromInteger (sing :: Sing 11)))) - sArg_0123456789876543210)))) - sA_0123456789876543210 - sShowsPrec - (sP_0123456789876543210 :: Sing p_0123456789876543210) - (SVec (sArg_0123456789876543210 :: Sing arg_0123456789876543210) - (sArg_0123456789876543210 :: Sing arg_0123456789876543210)) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing - ((applySing ((singFun3 @ShowParenSym0) sShowParen)) - ((applySing - ((applySing ((singFun2 @(>@#@$)) (%>))) sP_0123456789876543210)) - (sFromInteger (sing :: Sing 10))))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "Vec ")))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((applySing - ((applySing ((singFun3 @ShowsPrecSym0) sShowsPrec)) - (sFromInteger (sing :: Sing 11)))) - sArg_0123456789876543210))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((singFun1 @ShowSpaceSym0) sShowSpace))) - ((applySing - ((applySing ((singFun3 @ShowsPrecSym0) sShowsPrec)) - (sFromInteger (sing :: Sing 11)))) - sArg_0123456789876543210)))))) - sA_0123456789876543210 - instance SingI Nat where - sing = SNat - instance SingI Int where - sing = SInt - instance SingI String where - sing = SString - instance SingI n => SingI (Maybe (n :: Type)) where - sing = SMaybe sing - instance SingI (MaybeSym0 :: (~>) Type Type) where - sing = (singFun1 @MaybeSym0) SMaybe - instance (SingI n, SingI n) => - SingI (Vec (n :: Type) (n :: Nat)) where - sing = (SVec sing) sing - instance SingI (VecSym0 :: (~>) Type ((~>) Nat Type)) where - sing = (singFun2 @VecSym0) SVec - instance SingI d => - SingI (VecSym1 (d :: Type) :: (~>) Nat Type) where - sing = (singFun1 @(VecSym1 (d :: Type))) (SVec (sing @d)) diff --git a/tests/compile-and-dump/Singletons/Star.hs b/tests/compile-and-dump/Singletons/Star.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Star.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Singletons.Star where - -import Data.Singletons.Prelude -import Data.Singletons.Decide -import Data.Singletons.CustomStar -import Singletons.Nat -import Data.Kind (Type) - -data Vec :: Type -> Nat -> Type where - VNil :: Vec a Zero - VCons :: a -> Vec a n -> Vec a (Succ n) - -$(singletonStar [''Nat, ''Int, ''String, ''Maybe, ''Vec]) diff --git a/tests/compile-and-dump/Singletons/T124.ghc88.template b/tests/compile-and-dump/Singletons/T124.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T124.ghc88.template +++ /dev/null @@ -1,33 +0,0 @@ -Singletons/T124.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| foo :: Bool -> () - foo True = () - foo False = () |] - ======> - foo :: Bool -> () - foo True = () - foo False = () - type FooSym1 (a0123456789876543210 :: Bool) = - Foo a0123456789876543210 - instance SuppressUnusedWarnings FooSym0 where - suppressUnusedWarnings = snd (((,) FooSym0KindInference) ()) - data FooSym0 :: (~>) Bool () - where - FooSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply FooSym0 arg) (FooSym1 arg) => - FooSym0 a0123456789876543210 - type instance Apply FooSym0 a0123456789876543210 = Foo a0123456789876543210 - type family Foo (a :: Bool) :: () where - Foo 'True = Tuple0Sym0 - Foo 'False = Tuple0Sym0 - sFoo :: forall (t :: Bool). Sing t -> Sing (Apply FooSym0 t :: ()) - sFoo STrue = STuple0 - sFoo SFalse = STuple0 - instance SingI (FooSym0 :: (~>) Bool ()) where - sing = (singFun1 @FooSym0) sFoo -Singletons/T124.hs:0:0:: Splicing expression - sCases ''Bool [| b |] [| STuple0 |] - ======> - case b of - SFalse -> STuple0 - STrue -> STuple0 diff --git a/tests/compile-and-dump/Singletons/T124.hs b/tests/compile-and-dump/Singletons/T124.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T124.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Singletons.T124 where - -import Data.Singletons.TH -import Data.Singletons.Prelude - -$(singletons [d| - foo :: Bool -> () - foo True = () - foo False = () - |]) - -bar :: SBool b -> STuple0 (Foo b) -bar b = $(sCases ''Bool [| b |] [| STuple0 |]) diff --git a/tests/compile-and-dump/Singletons/T136.ghc88.template b/tests/compile-and-dump/Singletons/T136.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T136.ghc88.template +++ /dev/null @@ -1,174 +0,0 @@ -Singletons/T136.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| instance Enum BiNat where - succ [] = [True] - succ (False : as) = True : as - succ (True : as) = False : succ as - pred [] = error "pred 0" - pred (False : as) = True : pred as - pred (True : as) = False : as - toEnum i - | i < 0 = error "negative toEnum" - | i == 0 = [] - | otherwise = succ (toEnum (pred i)) - fromEnum [] = 0 - fromEnum (False : as) = 2 * fromEnum as - fromEnum (True : as) = 1 + 2 * fromEnum as |] - ======> - instance Enum BiNat where - succ [] = [True] - succ (False : as) = (True : as) - succ (True : as) = (False : succ as) - pred [] = error "pred 0" - pred (False : as) = (True : pred as) - pred (True : as) = (False : as) - toEnum i - | (i < 0) = error "negative toEnum" - | (i == 0) = [] - | otherwise = succ (toEnum (pred i)) - fromEnum [] = 0 - fromEnum (False : as) = (2 * fromEnum as) - fromEnum (True : as) = (1 + (2 * fromEnum as)) - type family Succ_0123456789876543210 (a :: [Bool]) :: [Bool] where - Succ_0123456789876543210 '[] = Apply (Apply (:@#@$) TrueSym0) '[] - Succ_0123456789876543210 ('(:) 'False as) = Apply (Apply (:@#@$) TrueSym0) as - Succ_0123456789876543210 ('(:) 'True as) = Apply (Apply (:@#@$) FalseSym0) (Apply SuccSym0 as) - type Succ_0123456789876543210Sym1 (a0123456789876543210 :: [Bool]) = - Succ_0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Succ_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Succ_0123456789876543210Sym0KindInference) ()) - data Succ_0123456789876543210Sym0 :: (~>) [Bool] [Bool] - where - Succ_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Succ_0123456789876543210Sym0 arg) (Succ_0123456789876543210Sym1 arg) => - Succ_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Succ_0123456789876543210Sym0 a0123456789876543210 = Succ_0123456789876543210 a0123456789876543210 - type family Pred_0123456789876543210 (a :: [Bool]) :: [Bool] where - Pred_0123456789876543210 '[] = Apply ErrorSym0 "pred 0" - Pred_0123456789876543210 ('(:) 'False as) = Apply (Apply (:@#@$) TrueSym0) (Apply PredSym0 as) - Pred_0123456789876543210 ('(:) 'True as) = Apply (Apply (:@#@$) FalseSym0) as - type Pred_0123456789876543210Sym1 (a0123456789876543210 :: [Bool]) = - Pred_0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Pred_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Pred_0123456789876543210Sym0KindInference) ()) - data Pred_0123456789876543210Sym0 :: (~>) [Bool] [Bool] - where - Pred_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Pred_0123456789876543210Sym0 arg) (Pred_0123456789876543210Sym1 arg) => - Pred_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Pred_0123456789876543210Sym0 a0123456789876543210 = Pred_0123456789876543210 a0123456789876543210 - type family Case_0123456789876543210 i arg_0123456789876543210 t where - Case_0123456789876543210 i arg_0123456789876543210 'True = '[] - Case_0123456789876543210 i arg_0123456789876543210 'False = Apply SuccSym0 (Apply ToEnumSym0 (Apply PredSym0 i)) - type family Case_0123456789876543210 i arg_0123456789876543210 t where - Case_0123456789876543210 i arg_0123456789876543210 'True = Apply ErrorSym0 "negative toEnum" - Case_0123456789876543210 i arg_0123456789876543210 'False = Case_0123456789876543210 i arg_0123456789876543210 (Apply (Apply (==@#@$) i) (FromInteger 0)) - type family Case_0123456789876543210 arg_0123456789876543210 t where - Case_0123456789876543210 arg_0123456789876543210 i = Case_0123456789876543210 i arg_0123456789876543210 (Apply (Apply (<@#@$) i) (FromInteger 0)) - type family ToEnum_0123456789876543210 (a :: GHC.Types.Nat) :: [Bool] where - ToEnum_0123456789876543210 arg_0123456789876543210 = Case_0123456789876543210 arg_0123456789876543210 arg_0123456789876543210 - type ToEnum_0123456789876543210Sym1 (a0123456789876543210 :: GHC.Types.Nat) = - ToEnum_0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ToEnum_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ToEnum_0123456789876543210Sym0KindInference) ()) - data ToEnum_0123456789876543210Sym0 :: (~>) GHC.Types.Nat [Bool] - where - ToEnum_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply ToEnum_0123456789876543210Sym0 arg) (ToEnum_0123456789876543210Sym1 arg) => - ToEnum_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ToEnum_0123456789876543210Sym0 a0123456789876543210 = ToEnum_0123456789876543210 a0123456789876543210 - type family FromEnum_0123456789876543210 (a :: [Bool]) :: GHC.Types.Nat where - FromEnum_0123456789876543210 '[] = FromInteger 0 - FromEnum_0123456789876543210 ('(:) 'False as) = Apply (Apply (*@#@$) (FromInteger 2)) (Apply FromEnumSym0 as) - FromEnum_0123456789876543210 ('(:) 'True as) = Apply (Apply (+@#@$) (FromInteger 1)) (Apply (Apply (*@#@$) (FromInteger 2)) (Apply FromEnumSym0 as)) - type FromEnum_0123456789876543210Sym1 (a0123456789876543210 :: [Bool]) = - FromEnum_0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings FromEnum_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) FromEnum_0123456789876543210Sym0KindInference) ()) - data FromEnum_0123456789876543210Sym0 :: (~>) [Bool] GHC.Types.Nat - where - FromEnum_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply FromEnum_0123456789876543210Sym0 arg) (FromEnum_0123456789876543210Sym1 arg) => - FromEnum_0123456789876543210Sym0 a0123456789876543210 - type instance Apply FromEnum_0123456789876543210Sym0 a0123456789876543210 = FromEnum_0123456789876543210 a0123456789876543210 - instance PEnum [Bool] where - type Succ a = Apply Succ_0123456789876543210Sym0 a - type Pred a = Apply Pred_0123456789876543210Sym0 a - type ToEnum a = Apply ToEnum_0123456789876543210Sym0 a - type FromEnum a = Apply FromEnum_0123456789876543210Sym0 a - instance SEnum [Bool] where - sSucc :: - forall (t :: [Bool]). - Sing t - -> Sing (Apply (SuccSym0 :: TyFun [Bool] [Bool] - -> GHC.Types.Type) t) - sPred :: - forall (t :: [Bool]). - Sing t - -> Sing (Apply (PredSym0 :: TyFun [Bool] [Bool] - -> GHC.Types.Type) t) - sToEnum :: - forall (t :: GHC.Types.Nat). - Sing t - -> Sing (Apply (ToEnumSym0 :: TyFun GHC.Types.Nat [Bool] - -> GHC.Types.Type) t) - sFromEnum :: - forall (t :: [Bool]). - Sing t - -> Sing (Apply (FromEnumSym0 :: TyFun [Bool] GHC.Types.Nat - -> GHC.Types.Type) t) - sSucc SNil - = (applySing ((applySing ((singFun2 @(:@#@$)) SCons)) STrue)) SNil - sSucc (SCons SFalse (sAs :: Sing as)) - = (applySing ((applySing ((singFun2 @(:@#@$)) SCons)) STrue)) sAs - sSucc (SCons STrue (sAs :: Sing as)) - = (applySing ((applySing ((singFun2 @(:@#@$)) SCons)) SFalse)) - ((applySing ((singFun1 @SuccSym0) sSucc)) sAs) - sPred SNil = sError (sing :: Sing "pred 0") - sPred (SCons SFalse (sAs :: Sing as)) - = (applySing ((applySing ((singFun2 @(:@#@$)) SCons)) STrue)) - ((applySing ((singFun1 @PredSym0) sPred)) sAs) - sPred (SCons STrue (sAs :: Sing as)) - = (applySing ((applySing ((singFun2 @(:@#@$)) SCons)) SFalse)) sAs - sToEnum (sArg_0123456789876543210 :: Sing arg_0123456789876543210) - = (id - @(Sing (Case_0123456789876543210 arg_0123456789876543210 arg_0123456789876543210))) - (case sArg_0123456789876543210 of { - (sI :: Sing i) - -> (id - @(Sing (Case_0123456789876543210 i arg_0123456789876543210 (Apply (Apply (<@#@$) i) (FromInteger 0))))) - (case - (applySing ((applySing ((singFun2 @(<@#@$)) (%<))) sI)) - (sFromInteger (sing :: Sing 0)) - of - STrue -> sError (sing :: Sing "negative toEnum") - SFalse - -> (id - @(Sing (Case_0123456789876543210 i arg_0123456789876543210 (Apply (Apply (==@#@$) i) (FromInteger 0))))) - (case - (applySing ((applySing ((singFun2 @(==@#@$)) (%==))) sI)) - (sFromInteger (sing :: Sing 0)) - of - STrue -> SNil - SFalse - -> (applySing ((singFun1 @SuccSym0) sSucc)) - ((applySing ((singFun1 @ToEnumSym0) sToEnum)) - ((applySing ((singFun1 @PredSym0) sPred)) sI)))) }) - sFromEnum SNil = sFromInteger (sing :: Sing 0) - sFromEnum (SCons SFalse (sAs :: Sing as)) - = (applySing - ((applySing ((singFun2 @(*@#@$)) (%*))) - (sFromInteger (sing :: Sing 2)))) - ((applySing ((singFun1 @FromEnumSym0) sFromEnum)) sAs) - sFromEnum (SCons STrue (sAs :: Sing as)) - = (applySing - ((applySing ((singFun2 @(+@#@$)) (%+))) - (sFromInteger (sing :: Sing 1)))) - ((applySing - ((applySing ((singFun2 @(*@#@$)) (%*))) - (sFromInteger (sing :: Sing 2)))) - ((applySing ((singFun1 @FromEnumSym0) sFromEnum)) sAs)) diff --git a/tests/compile-and-dump/Singletons/T136.hs b/tests/compile-and-dump/Singletons/T136.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T136.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE GADTs, DataKinds, PolyKinds, TypeFamilies, KindSignatures #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} -{-# LANGUAGE InstanceSigs, DefaultSignatures #-} - -module Binary where - -import Data.Singletons.TH -import Data.Singletons.Prelude -import Data.Singletons.Prelude.Enum -import Data.Singletons.Prelude.Num - -type Bit = Bool -type BiNat = [Bit] - -$(singletons [d| - instance Enum BiNat where - succ [] = [True] - succ (False:as) = True : as - succ (True:as) = False : succ as - - pred [] = error "pred 0" - pred (False:as) = True : pred as - pred (True:as) = False : as - - toEnum i | i < 0 = error "negative toEnum" - | i == 0 = [] - | otherwise = succ (toEnum (pred i)) - - fromEnum [] = 0 - fromEnum (False:as) = 2 * fromEnum as - fromEnum (True:as) = 1 + 2 * fromEnum as - |]) diff --git a/tests/compile-and-dump/Singletons/T136b.ghc88.template b/tests/compile-and-dump/Singletons/T136b.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T136b.ghc88.template +++ /dev/null @@ -1,53 +0,0 @@ -Singletons/T136b.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| class C a where - meth :: a -> a |] - ======> - class C a where - meth :: a -> a - type MethSym1 (arg0123456789876543210 :: a0123456789876543210) = - Meth arg0123456789876543210 - instance SuppressUnusedWarnings MethSym0 where - suppressUnusedWarnings = snd (((,) MethSym0KindInference) ()) - data MethSym0 :: forall a0123456789876543210. - (~>) a0123456789876543210 a0123456789876543210 - where - MethSym0KindInference :: forall arg0123456789876543210 - arg. SameKind (Apply MethSym0 arg) (MethSym1 arg) => - MethSym0 arg0123456789876543210 - type instance Apply MethSym0 arg0123456789876543210 = Meth arg0123456789876543210 - class PC (a :: GHC.Types.Type) where - type Meth (arg :: a) :: a - class SC a where - sMeth :: forall (t :: a). Sing t -> Sing (Apply MethSym0 t :: a) - instance SC a => SingI (MethSym0 :: (~>) a a) where - sing = (singFun1 @MethSym0) sMeth -Singletons/T136b.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| instance C Bool where - meth = not |] - ======> - instance C Bool where - meth = not - type family Meth_0123456789876543210 (a :: Bool) :: Bool where - Meth_0123456789876543210 a_0123456789876543210 = Apply NotSym0 a_0123456789876543210 - type Meth_0123456789876543210Sym1 (a0123456789876543210 :: Bool) = - Meth_0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Meth_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Meth_0123456789876543210Sym0KindInference) ()) - data Meth_0123456789876543210Sym0 :: (~>) Bool Bool - where - Meth_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Meth_0123456789876543210Sym0 arg) (Meth_0123456789876543210Sym1 arg) => - Meth_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Meth_0123456789876543210Sym0 a0123456789876543210 = Meth_0123456789876543210 a0123456789876543210 - instance PC Bool where - type Meth a = Apply Meth_0123456789876543210Sym0 a - instance SC Bool where - sMeth :: - forall (t :: Bool). - Sing t - -> Sing (Apply (MethSym0 :: TyFun Bool Bool -> GHC.Types.Type) t) - sMeth (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing ((singFun1 @NotSym0) sNot)) sA_0123456789876543210 diff --git a/tests/compile-and-dump/Singletons/T136b.hs b/tests/compile-and-dump/Singletons/T136b.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T136b.hs +++ /dev/null @@ -1,14 +0,0 @@ -module T136b where - -import Data.Singletons.TH -import Data.Singletons.Prelude.Bool - -$(singletons [d| - class C a where - meth :: a -> a - |]) - -$(singletons [d| - instance C Bool where - meth = not - |]) diff --git a/tests/compile-and-dump/Singletons/T145.ghc88.template b/tests/compile-and-dump/Singletons/T145.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T145.ghc88.template +++ /dev/null @@ -1,39 +0,0 @@ -Singletons/T145.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| class Column (f :: Type -> Type) where - col :: f a -> a -> Bool |] - ======> - class Column (f :: Type -> Type) where - col :: f a -> a -> Bool - type ColSym2 (arg0123456789876543210 :: f0123456789876543210 a0123456789876543210) (arg0123456789876543210 :: a0123456789876543210) = - Col arg0123456789876543210 arg0123456789876543210 - instance SuppressUnusedWarnings (ColSym1 arg0123456789876543210) where - suppressUnusedWarnings = snd (((,) ColSym1KindInference) ()) - data ColSym1 (arg0123456789876543210 :: f0123456789876543210 a0123456789876543210) :: (~>) a0123456789876543210 Bool - where - ColSym1KindInference :: forall arg0123456789876543210 - arg0123456789876543210 - arg. SameKind (Apply (ColSym1 arg0123456789876543210) arg) (ColSym2 arg0123456789876543210 arg) => - ColSym1 arg0123456789876543210 arg0123456789876543210 - type instance Apply (ColSym1 arg0123456789876543210) arg0123456789876543210 = Col arg0123456789876543210 arg0123456789876543210 - instance SuppressUnusedWarnings ColSym0 where - suppressUnusedWarnings = snd (((,) ColSym0KindInference) ()) - data ColSym0 :: forall f0123456789876543210 a0123456789876543210. - (~>) (f0123456789876543210 a0123456789876543210) ((~>) a0123456789876543210 Bool) - where - ColSym0KindInference :: forall arg0123456789876543210 - arg. SameKind (Apply ColSym0 arg) (ColSym1 arg) => - ColSym0 arg0123456789876543210 - type instance Apply ColSym0 arg0123456789876543210 = ColSym1 arg0123456789876543210 - class PColumn (f :: Type -> Type) where - type Col (arg :: f a) (arg :: a) :: Bool - class SColumn (f :: Type -> Type) where - sCol :: - forall a (t :: f a) (t :: a). - Sing t -> Sing t -> Sing (Apply (Apply ColSym0 t) t :: Bool) - instance SColumn f => - SingI (ColSym0 :: (~>) (f a) ((~>) a Bool)) where - sing = (singFun2 @ColSym0) sCol - instance (SColumn f, SingI d) => - SingI (ColSym1 (d :: f a) :: (~>) a Bool) where - sing = (singFun1 @(ColSym1 (d :: f a))) (sCol (sing @d)) diff --git a/tests/compile-and-dump/Singletons/T145.hs b/tests/compile-and-dump/Singletons/T145.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T145.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Singletons.T145 where - -import Data.Singletons.TH -import Data.Kind (Type) - -$(singletons [d| - class Column (f :: Type -> Type) where - col :: f a -> a -> Bool - |]) diff --git a/tests/compile-and-dump/Singletons/T153.ghc88.template b/tests/compile-and-dump/Singletons/T153.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T153.ghc88.template +++ /dev/null diff --git a/tests/compile-and-dump/Singletons/T153.hs b/tests/compile-and-dump/Singletons/T153.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T153.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE LambdaCase, GADTs, ScopedTypeVariables, - TypeApplications, RankNTypes #-} - -module Singletons.T153 where - -import Data.Singletons -import Data.Singletons.Prelude - -foo :: Int -foo = withSomeSing @(Maybe Bool) (Just True) $ \case - SJust STrue -> 0 - SJust SFalse -> 1 - SNothing -> 2 diff --git a/tests/compile-and-dump/Singletons/T157.ghc88.template b/tests/compile-and-dump/Singletons/T157.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T157.ghc88.template +++ /dev/null diff --git a/tests/compile-and-dump/Singletons/T157.hs b/tests/compile-and-dump/Singletons/T157.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T157.hs +++ /dev/null @@ -1,6 +0,0 @@ -module T157 where - -import Data.Singletons.Prelude - -foo :: SList '["a", "b", "c"] -foo = sing `SCons` sing `SCons` sing diff --git a/tests/compile-and-dump/Singletons/T159.ghc88.template b/tests/compile-and-dump/Singletons/T159.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T159.ghc88.template +++ /dev/null @@ -1,225 +0,0 @@ -Singletons/T159.hs:0:0:: Splicing declarations - genSingletons [''T0, ''T1] - ======> - type ASym0 = 'A - type BSym0 = 'B - type CSym0 = 'C - type DSym0 = 'D - type ESym0 = 'E - type FSym0 = 'F - data ST0 :: T0 -> GHC.Types.Type - where - SA :: ST0 'A - SB :: ST0 'B - SC :: ST0 'C - SD :: ST0 'D - SE :: ST0 'E - SF :: ST0 'F - type instance Sing @T0 = ST0 - instance SingKind T0 where - type Demote T0 = T0 - fromSing SA = A - fromSing SB = B - fromSing SC = C - fromSing SD = D - fromSing SE = E - fromSing SF = F - toSing A = SomeSing SA - toSing B = SomeSing SB - toSing C = SomeSing SC - toSing D = SomeSing SD - toSing E = SomeSing SE - toSing F = SomeSing SF - instance SingI 'A where - sing = SA - instance SingI 'B where - sing = SB - instance SingI 'C where - sing = SC - instance SingI 'D where - sing = SD - instance SingI 'E where - sing = SE - instance SingI 'F where - sing = SF - type N1Sym0 = 'N1 - type C1Sym2 (t0123456789876543210 :: T0) (t0123456789876543210 :: T1) = - 'C1 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (C1Sym1 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) C1Sym1KindInference) ()) - data C1Sym1 (t0123456789876543210 :: T0) :: (~>) T1 T1 - where - C1Sym1KindInference :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (C1Sym1 t0123456789876543210) arg) (C1Sym2 t0123456789876543210 arg) => - C1Sym1 t0123456789876543210 t0123456789876543210 - type instance Apply (C1Sym1 t0123456789876543210) t0123456789876543210 = 'C1 t0123456789876543210 t0123456789876543210 - infixr 5 `C1Sym1` - instance SuppressUnusedWarnings C1Sym0 where - suppressUnusedWarnings = snd (((,) C1Sym0KindInference) ()) - data C1Sym0 :: (~>) T0 ((~>) T1 T1) - where - C1Sym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply C1Sym0 arg) (C1Sym1 arg) => - C1Sym0 t0123456789876543210 - type instance Apply C1Sym0 t0123456789876543210 = C1Sym1 t0123456789876543210 - infixr 5 `C1Sym0` - type (:&&@#@$$$) (t0123456789876543210 :: T0) (t0123456789876543210 :: T1) = - '(:&&) t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings ((:&&@#@$$) t0123456789876543210) where - suppressUnusedWarnings = snd (((,) (::&&@#@$$###)) ()) - data (:&&@#@$$) (t0123456789876543210 :: T0) :: (~>) T1 T1 - where - (::&&@#@$$###) :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply ((:&&@#@$$) t0123456789876543210) arg) ((:&&@#@$$$) t0123456789876543210 arg) => - (:&&@#@$$) t0123456789876543210 t0123456789876543210 - type instance Apply ((:&&@#@$$) t0123456789876543210) t0123456789876543210 = '(:&&) t0123456789876543210 t0123456789876543210 - infixr 5 :&&@#@$$ - instance SuppressUnusedWarnings (:&&@#@$) where - suppressUnusedWarnings = snd (((,) (::&&@#@$###)) ()) - data (:&&@#@$) :: (~>) T0 ((~>) T1 T1) - where - (::&&@#@$###) :: forall t0123456789876543210 - arg. SameKind (Apply (:&&@#@$) arg) ((:&&@#@$$) arg) => - (:&&@#@$) t0123456789876543210 - type instance Apply (:&&@#@$) t0123456789876543210 = (:&&@#@$$) t0123456789876543210 - infixr 5 :&&@#@$ - data ST1 :: T1 -> GHC.Types.Type - where - SN1 :: ST1 'N1 - SC1 :: forall (n :: T0) (n :: T1). - (Sing (n :: T0)) -> (Sing (n :: T1)) -> ST1 ('C1 n n) - (:%&&) :: forall (n :: T0) (n :: T1). - (Sing (n :: T0)) -> (Sing (n :: T1)) -> ST1 ('(:&&) n n) - type instance Sing @T1 = ST1 - instance SingKind T1 where - type Demote T1 = T1 - fromSing SN1 = N1 - fromSing (SC1 b b) = (C1 (fromSing b)) (fromSing b) - fromSing ((:%&&) b b) = ((:&&) (fromSing b)) (fromSing b) - toSing N1 = SomeSing SN1 - toSing (C1 (b :: Demote T0) (b :: Demote T1)) - = case - ((,) (toSing b :: SomeSing T0)) (toSing b :: SomeSing T1) - of { - (,) (SomeSing c) (SomeSing c) -> SomeSing ((SC1 c) c) } - toSing ((:&&) (b :: Demote T0) (b :: Demote T1)) - = case - ((,) (toSing b :: SomeSing T0)) (toSing b :: SomeSing T1) - of { - (,) (SomeSing c) (SomeSing c) -> SomeSing (((:%&&) c) c) } - infixr 5 `SC1` - infixr 5 :%&& - instance SingI 'N1 where - sing = SN1 - instance (SingI n, SingI n) => - SingI ('C1 (n :: T0) (n :: T1)) where - sing = (SC1 sing) sing - instance SingI (C1Sym0 :: (~>) T0 ((~>) T1 T1)) where - sing = (singFun2 @C1Sym0) SC1 - instance SingI d => SingI (C1Sym1 (d :: T0) :: (~>) T1 T1) where - sing = (singFun1 @(C1Sym1 (d :: T0))) (SC1 (sing @d)) - instance (SingI n, SingI n) => - SingI ('(:&&) (n :: T0) (n :: T1)) where - sing = ((:%&&) sing) sing - instance SingI ((:&&@#@$) :: (~>) T0 ((~>) T1 T1)) where - sing = (singFun2 @(:&&@#@$)) (:%&&) - instance SingI d => - SingI ((:&&@#@$$) (d :: T0) :: (~>) T1 T1) where - sing = (singFun1 @((:&&@#@$$) (d :: T0))) ((:%&&) (sing @d)) -Singletons/T159.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| infixr 5 :|| - infixr 5 `C2` - - data T2 = N2 | C2 T0 T2 | T0 :|| T2 |] - ======> - data T2 = N2 | C2 T0 T2 | T0 :|| T2 - infixr 5 `C2` - infixr 5 :|| - type N2Sym0 = N2 - type C2Sym2 (t0123456789876543210 :: T0) (t0123456789876543210 :: T2) = - C2 t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (C2Sym1 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) C2Sym1KindInference) ()) - data C2Sym1 (t0123456789876543210 :: T0) :: (~>) T2 T2 - where - C2Sym1KindInference :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (C2Sym1 t0123456789876543210) arg) (C2Sym2 t0123456789876543210 arg) => - C2Sym1 t0123456789876543210 t0123456789876543210 - type instance Apply (C2Sym1 t0123456789876543210) t0123456789876543210 = C2 t0123456789876543210 t0123456789876543210 - infixr 5 `C2Sym1` - instance SuppressUnusedWarnings C2Sym0 where - suppressUnusedWarnings = snd (((,) C2Sym0KindInference) ()) - data C2Sym0 :: (~>) T0 ((~>) T2 T2) - where - C2Sym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply C2Sym0 arg) (C2Sym1 arg) => - C2Sym0 t0123456789876543210 - type instance Apply C2Sym0 t0123456789876543210 = C2Sym1 t0123456789876543210 - infixr 5 `C2Sym0` - type (:||@#@$$$) (t0123456789876543210 :: T0) (t0123456789876543210 :: T2) = - (:||) t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings ((:||@#@$$) t0123456789876543210) where - suppressUnusedWarnings = snd (((,) (::||@#@$$###)) ()) - data (:||@#@$$) (t0123456789876543210 :: T0) :: (~>) T2 T2 - where - (::||@#@$$###) :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply ((:||@#@$$) t0123456789876543210) arg) ((:||@#@$$$) t0123456789876543210 arg) => - (:||@#@$$) t0123456789876543210 t0123456789876543210 - type instance Apply ((:||@#@$$) t0123456789876543210) t0123456789876543210 = (:||) t0123456789876543210 t0123456789876543210 - infixr 5 :||@#@$$ - instance SuppressUnusedWarnings (:||@#@$) where - suppressUnusedWarnings = snd (((,) (::||@#@$###)) ()) - data (:||@#@$) :: (~>) T0 ((~>) T2 T2) - where - (::||@#@$###) :: forall t0123456789876543210 - arg. SameKind (Apply (:||@#@$) arg) ((:||@#@$$) arg) => - (:||@#@$) t0123456789876543210 - type instance Apply (:||@#@$) t0123456789876543210 = (:||@#@$$) t0123456789876543210 - infixr 5 :||@#@$ - infixr 5 :%|| - infixr 5 `SC2` - data ST2 :: T2 -> GHC.Types.Type - where - SN2 :: ST2 N2 - SC2 :: forall (n :: T0) (n :: T2). - (Sing (n :: T0)) -> (Sing (n :: T2)) -> ST2 (C2 n n) - (:%||) :: forall (n :: T0) (n :: T2). - (Sing (n :: T0)) -> (Sing (n :: T2)) -> ST2 ((:||) n n) - type instance Sing @T2 = ST2 - instance SingKind T2 where - type Demote T2 = T2 - fromSing SN2 = N2 - fromSing (SC2 b b) = (C2 (fromSing b)) (fromSing b) - fromSing ((:%||) b b) = ((:||) (fromSing b)) (fromSing b) - toSing N2 = SomeSing SN2 - toSing (C2 (b :: Demote T0) (b :: Demote T2)) - = case - ((,) (toSing b :: SomeSing T0)) (toSing b :: SomeSing T2) - of { - (,) (SomeSing c) (SomeSing c) -> SomeSing ((SC2 c) c) } - toSing ((:||) (b :: Demote T0) (b :: Demote T2)) - = case - ((,) (toSing b :: SomeSing T0)) (toSing b :: SomeSing T2) - of { - (,) (SomeSing c) (SomeSing c) -> SomeSing (((:%||) c) c) } - instance SingI N2 where - sing = SN2 - instance (SingI n, SingI n) => SingI (C2 (n :: T0) (n :: T2)) where - sing = (SC2 sing) sing - instance SingI (C2Sym0 :: (~>) T0 ((~>) T2 T2)) where - sing = (singFun2 @C2Sym0) SC2 - instance SingI d => SingI (C2Sym1 (d :: T0) :: (~>) T2 T2) where - sing = (singFun1 @(C2Sym1 (d :: T0))) (SC2 (sing @d)) - instance (SingI n, SingI n) => - SingI ((:||) (n :: T0) (n :: T2)) where - sing = ((:%||) sing) sing - instance SingI ((:||@#@$) :: (~>) T0 ((~>) T2 T2)) where - sing = (singFun2 @(:||@#@$)) (:%||) - instance SingI d => - SingI ((:||@#@$$) (d :: T0) :: (~>) T2 T2) where - sing = (singFun1 @((:||@#@$$) (d :: T0))) ((:%||) (sing @d)) diff --git a/tests/compile-and-dump/Singletons/T159.hs b/tests/compile-and-dump/Singletons/T159.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T159.hs +++ /dev/null @@ -1,27 +0,0 @@ -module T159 where - -import Data.Singletons.TH - -data T0 = A | B | C | D | E | F - deriving (Show) - -data T1 = N1 | C1 T0 T1 | T0 :&& T1 - deriving (Show) - -infixr 5 `C1` -infixr 5 :&& - -genSingletons [''T0, ''T1] - -singletons [d| - data T2 = N2 | C2 T0 T2 | T0 :|| T2 - - infixr 5 `C2` - infixr 5 :|| - |] - -t1 :: T1 -t1 = fromSing $ SA `SC1` SB `SC1` SD :%&& SE :%&& SF `SC1` SN1 - -t2 :: T2 -t2 = fromSing $ SA `SC2` SB `SC2` SD :%|| SE :%|| SF `SC2` SN2 diff --git a/tests/compile-and-dump/Singletons/T160.ghc88.template b/tests/compile-and-dump/Singletons/T160.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T160.ghc88.template +++ /dev/null @@ -1,69 +0,0 @@ -Singletons/T160.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| foo :: (Num a, Eq a) => a -> a - foo x = if x == 0 then 1 else typeError $ ShowType x |] - ======> - foo :: (Num a, Eq a) => a -> a - foo x = if (x == 0) then 1 else (typeError $ ShowType x) - type Let0123456789876543210Scrutinee_0123456789876543210Sym1 x0123456789876543210 = - Let0123456789876543210Scrutinee_0123456789876543210 x0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210Scrutinee_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd - (((,) - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference) - ()) - data Let0123456789876543210Scrutinee_0123456789876543210Sym0 x0123456789876543210 - where - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference :: forall x0123456789876543210 - arg. SameKind (Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 arg) (Let0123456789876543210Scrutinee_0123456789876543210Sym1 arg) => - Let0123456789876543210Scrutinee_0123456789876543210Sym0 x0123456789876543210 - type instance Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 x0123456789876543210 = Let0123456789876543210Scrutinee_0123456789876543210 x0123456789876543210 - type family Let0123456789876543210Scrutinee_0123456789876543210 x where - Let0123456789876543210Scrutinee_0123456789876543210 x = Apply (Apply (==@#@$) x) (FromInteger 0) - type family Case_0123456789876543210 x t where - Case_0123456789876543210 x 'True = FromInteger 1 - Case_0123456789876543210 x 'False = Apply (Apply ($@#@$) TypeErrorSym0) (Apply ShowTypeSym0 x) - type FooSym1 (a0123456789876543210 :: a0123456789876543210) = - Foo a0123456789876543210 - instance SuppressUnusedWarnings FooSym0 where - suppressUnusedWarnings = snd (((,) FooSym0KindInference) ()) - data FooSym0 :: forall a0123456789876543210. - (~>) a0123456789876543210 a0123456789876543210 - where - FooSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply FooSym0 arg) (FooSym1 arg) => - FooSym0 a0123456789876543210 - type instance Apply FooSym0 a0123456789876543210 = Foo a0123456789876543210 - type family Foo (a :: a) :: a where - Foo x = Case_0123456789876543210 x (Let0123456789876543210Scrutinee_0123456789876543210Sym1 x) - sFoo :: - forall a (t :: a). - (SNum a, SEq a) => Sing t -> Sing (Apply FooSym0 t :: a) - sFoo (sX :: Sing x) - = let - sScrutinee_0123456789876543210 :: - Sing (Let0123456789876543210Scrutinee_0123456789876543210Sym1 x) - sScrutinee_0123456789876543210 - = (applySing ((applySing ((singFun2 @(==@#@$)) (%==))) sX)) - (sFromInteger (sing :: Sing 0)) - in - (id - @(Sing (Case_0123456789876543210 x (Let0123456789876543210Scrutinee_0123456789876543210Sym1 x) :: a))) - (case sScrutinee_0123456789876543210 of - STrue -> sFromInteger (sing :: Sing 1) - SFalse - -> (applySing - ((applySing ((singFun2 @($@#@$)) (%$))) - ((singFun1 @TypeErrorSym0) sTypeError))) - ((applySing ((singFun1 @ShowTypeSym0) SShowType)) sX)) - instance (SNum a, SEq a) => SingI (FooSym0 :: (~>) a a) where - sing = (singFun1 @FooSym0) sFoo - -Singletons/T160.hs:0:0: error: - • 1 - • In the expression: Refl - In an equation for ‘f’: f = Refl - | -13 | f = Refl - | ^^^^ diff --git a/tests/compile-and-dump/Singletons/T160.hs b/tests/compile-and-dump/Singletons/T160.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T160.hs +++ /dev/null @@ -1,13 +0,0 @@ -module T160 where - -import Data.Singletons.Prelude -import Data.Singletons.TH -import Data.Singletons.TypeError - -$(singletons - [d| foo :: (Num a, Eq a) => a -> a - foo x = if x == 0 then 1 else typeError $ ShowType x - |]) - -f :: Foo 1 :~: 42 -f = Refl diff --git a/tests/compile-and-dump/Singletons/T163.ghc88.template b/tests/compile-and-dump/Singletons/T163.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T163.ghc88.template +++ /dev/null @@ -1,47 +0,0 @@ -Singletons/T163.hs:0:0:: Splicing declarations - singletons [d| data a + b = L a | R b |] - ======> - data (+) a b = L a | R b - type LSym1 (t0123456789876543210 :: a0123456789876543210) = - L t0123456789876543210 - instance SuppressUnusedWarnings LSym0 where - suppressUnusedWarnings = snd (((,) LSym0KindInference) ()) - data LSym0 :: forall a0123456789876543210 b0123456789876543210. - (~>) a0123456789876543210 ((+) a0123456789876543210 b0123456789876543210) - where - LSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply LSym0 arg) (LSym1 arg) => - LSym0 t0123456789876543210 - type instance Apply LSym0 t0123456789876543210 = L t0123456789876543210 - type RSym1 (t0123456789876543210 :: b0123456789876543210) = - R t0123456789876543210 - instance SuppressUnusedWarnings RSym0 where - suppressUnusedWarnings = snd (((,) RSym0KindInference) ()) - data RSym0 :: forall b0123456789876543210 a0123456789876543210. - (~>) b0123456789876543210 ((+) a0123456789876543210 b0123456789876543210) - where - RSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply RSym0 arg) (RSym1 arg) => - RSym0 t0123456789876543210 - type instance Apply RSym0 t0123456789876543210 = R t0123456789876543210 - data (%+) :: forall a b. (+) a b -> GHC.Types.Type - where - SL :: forall a (n :: a). (Sing (n :: a)) -> (%+) (L n) - SR :: forall b (n :: b). (Sing (n :: b)) -> (%+) (R n) - type instance Sing @((+) a b) = (%+) - instance (SingKind a, SingKind b) => SingKind ((+) a b) where - type Demote ((+) a b) = (+) (Demote a) (Demote b) - fromSing (SL b) = L (fromSing b) - fromSing (SR b) = R (fromSing b) - toSing (L (b :: Demote a)) - = case toSing b :: SomeSing a of { SomeSing c -> SomeSing (SL c) } - toSing (R (b :: Demote b)) - = case toSing b :: SomeSing b of { SomeSing c -> SomeSing (SR c) } - instance SingI n => SingI (L (n :: a)) where - sing = SL sing - instance SingI (LSym0 :: (~>) a ((+) a b)) where - sing = (singFun1 @LSym0) SL - instance SingI n => SingI (R (n :: b)) where - sing = SR sing - instance SingI (RSym0 :: (~>) b ((+) a b)) where - sing = (singFun1 @RSym0) SR diff --git a/tests/compile-and-dump/Singletons/T163.hs b/tests/compile-and-dump/Singletons/T163.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T163.hs +++ /dev/null @@ -1,5 +0,0 @@ -module T163 where - -import Data.Singletons.TH - -$(singletons [d| data a + b = L a | R b |]) diff --git a/tests/compile-and-dump/Singletons/T166.ghc88.template b/tests/compile-and-dump/Singletons/T166.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T166.ghc88.template +++ /dev/null @@ -1,139 +0,0 @@ -Singletons/T166.hs:(0,0)-(0,0): Splicing declarations - singletonsOnly - [d| class Foo a where - foosPrec :: Nat -> a -> [Bool] -> [Bool] - foo :: a -> [Bool] - foo x s = foosPrec 0 x s |] - ======> - type FoosPrecSym3 (arg0123456789876543210 :: Nat) (arg0123456789876543210 :: a0123456789876543210) (arg0123456789876543210 :: [Bool]) = - FoosPrec arg0123456789876543210 arg0123456789876543210 arg0123456789876543210 - instance SuppressUnusedWarnings (FoosPrecSym2 arg0123456789876543210 arg0123456789876543210) where - suppressUnusedWarnings = snd (((,) FoosPrecSym2KindInference) ()) - data FoosPrecSym2 (arg0123456789876543210 :: Nat) (arg0123456789876543210 :: a0123456789876543210) :: (~>) [Bool] [Bool] - where - FoosPrecSym2KindInference :: forall arg0123456789876543210 - arg0123456789876543210 - arg0123456789876543210 - arg. SameKind (Apply (FoosPrecSym2 arg0123456789876543210 arg0123456789876543210) arg) (FoosPrecSym3 arg0123456789876543210 arg0123456789876543210 arg) => - FoosPrecSym2 arg0123456789876543210 arg0123456789876543210 arg0123456789876543210 - type instance Apply (FoosPrecSym2 arg0123456789876543210 arg0123456789876543210) arg0123456789876543210 = FoosPrec arg0123456789876543210 arg0123456789876543210 arg0123456789876543210 - instance SuppressUnusedWarnings (FoosPrecSym1 arg0123456789876543210) where - suppressUnusedWarnings = snd (((,) FoosPrecSym1KindInference) ()) - data FoosPrecSym1 (arg0123456789876543210 :: Nat) :: forall a0123456789876543210. - (~>) a0123456789876543210 ((~>) [Bool] [Bool]) - where - FoosPrecSym1KindInference :: forall arg0123456789876543210 - arg0123456789876543210 - arg. SameKind (Apply (FoosPrecSym1 arg0123456789876543210) arg) (FoosPrecSym2 arg0123456789876543210 arg) => - FoosPrecSym1 arg0123456789876543210 arg0123456789876543210 - type instance Apply (FoosPrecSym1 arg0123456789876543210) arg0123456789876543210 = FoosPrecSym2 arg0123456789876543210 arg0123456789876543210 - instance SuppressUnusedWarnings FoosPrecSym0 where - suppressUnusedWarnings = snd (((,) FoosPrecSym0KindInference) ()) - data FoosPrecSym0 :: forall a0123456789876543210. - (~>) Nat ((~>) a0123456789876543210 ((~>) [Bool] [Bool])) - where - FoosPrecSym0KindInference :: forall arg0123456789876543210 - arg. SameKind (Apply FoosPrecSym0 arg) (FoosPrecSym1 arg) => - FoosPrecSym0 arg0123456789876543210 - type instance Apply FoosPrecSym0 arg0123456789876543210 = FoosPrecSym1 arg0123456789876543210 - type FooSym1 (arg0123456789876543210 :: a0123456789876543210) = - Foo arg0123456789876543210 - instance SuppressUnusedWarnings FooSym0 where - suppressUnusedWarnings = snd (((,) FooSym0KindInference) ()) - data FooSym0 :: forall a0123456789876543210. - (~>) a0123456789876543210 [Bool] - where - FooSym0KindInference :: forall arg0123456789876543210 - arg. SameKind (Apply FooSym0 arg) (FooSym1 arg) => - FooSym0 arg0123456789876543210 - type instance Apply FooSym0 arg0123456789876543210 = Foo arg0123456789876543210 - type family Lambda_0123456789876543210 x t where - Lambda_0123456789876543210 x s = Apply (Apply (Apply FoosPrecSym0 (Data.Singletons.Prelude.Num.FromInteger 0)) x) s - type Lambda_0123456789876543210Sym2 x0123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 x0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 x0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall x0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 x0123456789876543210) arg) (Lambda_0123456789876543210Sym2 x0123456789876543210 arg) => - Lambda_0123456789876543210Sym1 x0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 x0123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 x0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 x0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall x0123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 x0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 x0123456789876543210 = Lambda_0123456789876543210Sym1 x0123456789876543210 - type family Foo_0123456789876543210 (a :: a) :: [Bool] where - Foo_0123456789876543210 x = Apply Lambda_0123456789876543210Sym0 x - type Foo_0123456789876543210Sym1 (a0123456789876543210 :: a0123456789876543210) = - Foo_0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Foo_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Foo_0123456789876543210Sym0KindInference) ()) - data Foo_0123456789876543210Sym0 :: forall a0123456789876543210. - (~>) a0123456789876543210 [Bool] - where - Foo_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo_0123456789876543210Sym0 arg) (Foo_0123456789876543210Sym1 arg) => - Foo_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Foo_0123456789876543210Sym0 a0123456789876543210 = Foo_0123456789876543210 a0123456789876543210 - class PFoo (a :: GHC.Types.Type) where - type FoosPrec (arg :: Nat) (arg :: a) (arg :: [Bool]) :: [Bool] - type Foo (arg :: a) :: [Bool] - type Foo a = Apply Foo_0123456789876543210Sym0 a - class SFoo a where - sFoosPrec :: - forall (t :: Nat) (t :: a) (t :: [Bool]). - Sing t - -> Sing t - -> Sing t - -> Sing (Apply (Apply (Apply FoosPrecSym0 t) t) t :: [Bool]) - sFoo :: forall (t :: a). Sing t -> Sing (Apply FooSym0 t :: [Bool]) - default sFoo :: - forall (t :: a). - ((Apply FooSym0 t :: [Bool]) - ~ Apply Foo_0123456789876543210Sym0 t) => - Sing t -> Sing (Apply FooSym0 t :: [Bool]) - sFoo (sX :: Sing x) - = (singFun1 @(Apply Lambda_0123456789876543210Sym0 x)) - (\ sS - -> case sS of { - (_ :: Sing s) - -> (applySing - ((applySing - ((applySing ((singFun3 @FoosPrecSym0) sFoosPrec)) - (Data.Singletons.Prelude.Num.sFromInteger (sing :: Sing 0)))) - sX)) - sS }) - instance SFoo a => - SingI (FoosPrecSym0 :: (~>) Nat ((~>) a ((~>) [Bool] [Bool]))) where - sing = (singFun3 @FoosPrecSym0) sFoosPrec - instance (SFoo a, SingI d) => - SingI (FoosPrecSym1 (d :: Nat) :: (~>) a ((~>) [Bool] [Bool])) where - sing = (singFun2 @(FoosPrecSym1 (d :: Nat))) (sFoosPrec (sing @d)) - instance (SFoo a, SingI d, SingI d) => - SingI (FoosPrecSym2 (d :: Nat) (d :: a) :: (~>) [Bool] [Bool]) where - sing - = (singFun1 @(FoosPrecSym2 (d :: Nat) (d :: a))) - ((sFoosPrec (sing @d)) (sing @d)) - instance SFoo a => SingI (FooSym0 :: (~>) a [Bool]) where - sing = (singFun1 @FooSym0) sFoo - -Singletons/T166.hs:0:0: error: - • Expecting one more argument to ‘Apply Lambda_0123456789876543210Sym0 x’ - Expected kind ‘[Bool]’, - but ‘Apply Lambda_0123456789876543210Sym0 x’ has kind ‘TyFun - [Bool] [Bool] - -> Type’ - • In the type ‘Apply Lambda_0123456789876543210Sym0 x’ - In the type family declaration for ‘Foo_0123456789876543210’ - | -14 | $(singletonsOnly [d| - | ^^^^^^^^^^^^^^^^^^... diff --git a/tests/compile-and-dump/Singletons/T166.hs b/tests/compile-and-dump/Singletons/T166.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T166.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -module SingletonsBug where - -import Data.Singletons.TH -import GHC.TypeLits - -$(singletonsOnly [d| - class Foo a where - foosPrec :: Nat -> a -> [Bool] -> [Bool] - foo :: a -> [Bool] - - foo x s = foosPrec 0 x s - |]) diff --git a/tests/compile-and-dump/Singletons/T167.ghc88.template b/tests/compile-and-dump/Singletons/T167.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T167.ghc88.template +++ /dev/null @@ -1,178 +0,0 @@ -Singletons/T167.hs:(0,0)-(0,0): Splicing declarations - singletonsOnly - [d| class Foo a where - foosPrec :: Nat -> a -> DiffList - fooList :: a -> DiffList - fooList = undefined - - instance Foo a => Foo [a] where - foosPrec _ = fooList |] - ======> - type FoosPrecSym3 (arg0123456789876543210 :: Nat) (arg0123456789876543210 :: a0123456789876543210) (arg0123456789876543210 :: [Bool]) = - FoosPrec arg0123456789876543210 arg0123456789876543210 arg0123456789876543210 - instance SuppressUnusedWarnings (FoosPrecSym2 arg0123456789876543210 arg0123456789876543210) where - suppressUnusedWarnings = snd (((,) FoosPrecSym2KindInference) ()) - data FoosPrecSym2 (arg0123456789876543210 :: Nat) (arg0123456789876543210 :: a0123456789876543210) :: (~>) [Bool] [Bool] - where - FoosPrecSym2KindInference :: forall arg0123456789876543210 - arg0123456789876543210 - arg0123456789876543210 - arg. SameKind (Apply (FoosPrecSym2 arg0123456789876543210 arg0123456789876543210) arg) (FoosPrecSym3 arg0123456789876543210 arg0123456789876543210 arg) => - FoosPrecSym2 arg0123456789876543210 arg0123456789876543210 arg0123456789876543210 - type instance Apply (FoosPrecSym2 arg0123456789876543210 arg0123456789876543210) arg0123456789876543210 = FoosPrec arg0123456789876543210 arg0123456789876543210 arg0123456789876543210 - instance SuppressUnusedWarnings (FoosPrecSym1 arg0123456789876543210) where - suppressUnusedWarnings = snd (((,) FoosPrecSym1KindInference) ()) - data FoosPrecSym1 (arg0123456789876543210 :: Nat) :: forall a0123456789876543210. - (~>) a0123456789876543210 ((~>) [Bool] [Bool]) - where - FoosPrecSym1KindInference :: forall arg0123456789876543210 - arg0123456789876543210 - arg. SameKind (Apply (FoosPrecSym1 arg0123456789876543210) arg) (FoosPrecSym2 arg0123456789876543210 arg) => - FoosPrecSym1 arg0123456789876543210 arg0123456789876543210 - type instance Apply (FoosPrecSym1 arg0123456789876543210) arg0123456789876543210 = FoosPrecSym2 arg0123456789876543210 arg0123456789876543210 - instance SuppressUnusedWarnings FoosPrecSym0 where - suppressUnusedWarnings = snd (((,) FoosPrecSym0KindInference) ()) - data FoosPrecSym0 :: forall a0123456789876543210. - (~>) Nat ((~>) a0123456789876543210 ((~>) [Bool] [Bool])) - where - FoosPrecSym0KindInference :: forall arg0123456789876543210 - arg. SameKind (Apply FoosPrecSym0 arg) (FoosPrecSym1 arg) => - FoosPrecSym0 arg0123456789876543210 - type instance Apply FoosPrecSym0 arg0123456789876543210 = FoosPrecSym1 arg0123456789876543210 - type FooListSym2 (arg0123456789876543210 :: a0123456789876543210) (arg0123456789876543210 :: [Bool]) = - FooList arg0123456789876543210 arg0123456789876543210 - instance SuppressUnusedWarnings (FooListSym1 arg0123456789876543210) where - suppressUnusedWarnings = snd (((,) FooListSym1KindInference) ()) - data FooListSym1 (arg0123456789876543210 :: a0123456789876543210) :: (~>) [Bool] [Bool] - where - FooListSym1KindInference :: forall arg0123456789876543210 - arg0123456789876543210 - arg. SameKind (Apply (FooListSym1 arg0123456789876543210) arg) (FooListSym2 arg0123456789876543210 arg) => - FooListSym1 arg0123456789876543210 arg0123456789876543210 - type instance Apply (FooListSym1 arg0123456789876543210) arg0123456789876543210 = FooList arg0123456789876543210 arg0123456789876543210 - instance SuppressUnusedWarnings FooListSym0 where - suppressUnusedWarnings = snd (((,) FooListSym0KindInference) ()) - data FooListSym0 :: forall a0123456789876543210. - (~>) a0123456789876543210 ((~>) [Bool] [Bool]) - where - FooListSym0KindInference :: forall arg0123456789876543210 - arg. SameKind (Apply FooListSym0 arg) (FooListSym1 arg) => - FooListSym0 arg0123456789876543210 - type instance Apply FooListSym0 arg0123456789876543210 = FooListSym1 arg0123456789876543210 - type family FooList_0123456789876543210 (a :: a) (a :: [Bool]) :: [Bool] where - FooList_0123456789876543210 a_0123456789876543210 a_0123456789876543210 = Apply (Apply UndefinedSym0 a_0123456789876543210) a_0123456789876543210 - type FooList_0123456789876543210Sym2 (a0123456789876543210 :: a0123456789876543210) (a0123456789876543210 :: [Bool]) = - FooList_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (FooList_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) FooList_0123456789876543210Sym1KindInference) ()) - data FooList_0123456789876543210Sym1 (a0123456789876543210 :: a0123456789876543210) :: (~>) [Bool] [Bool] - where - FooList_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (FooList_0123456789876543210Sym1 a0123456789876543210) arg) (FooList_0123456789876543210Sym2 a0123456789876543210 arg) => - FooList_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (FooList_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = FooList_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings FooList_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) FooList_0123456789876543210Sym0KindInference) ()) - data FooList_0123456789876543210Sym0 :: forall a0123456789876543210. - (~>) a0123456789876543210 ((~>) [Bool] [Bool]) - where - FooList_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply FooList_0123456789876543210Sym0 arg) (FooList_0123456789876543210Sym1 arg) => - FooList_0123456789876543210Sym0 a0123456789876543210 - type instance Apply FooList_0123456789876543210Sym0 a0123456789876543210 = FooList_0123456789876543210Sym1 a0123456789876543210 - class PFoo (a :: GHC.Types.Type) where - type FoosPrec (arg :: Nat) (arg :: a) (arg :: [Bool]) :: [Bool] - type FooList (arg :: a) (arg :: [Bool]) :: [Bool] - type FooList a a = Apply (Apply FooList_0123456789876543210Sym0 a) a - type family FoosPrec_0123456789876543210 (a :: Nat) (a :: [a]) (a :: [Bool]) :: [Bool] where - FoosPrec_0123456789876543210 _ a_0123456789876543210 a_0123456789876543210 = Apply (Apply FooListSym0 a_0123456789876543210) a_0123456789876543210 - type FoosPrec_0123456789876543210Sym3 (a0123456789876543210 :: Nat) (a0123456789876543210 :: [a0123456789876543210]) (a0123456789876543210 :: [Bool]) = - FoosPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (FoosPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) FoosPrec_0123456789876543210Sym2KindInference) ()) - data FoosPrec_0123456789876543210Sym2 (a0123456789876543210 :: Nat) (a0123456789876543210 :: [a0123456789876543210]) :: (~>) [Bool] [Bool] - where - FoosPrec_0123456789876543210Sym2KindInference :: forall a0123456789876543210 - a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (FoosPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) arg) (FoosPrec_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 arg) => - FoosPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (FoosPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = FoosPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (FoosPrec_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) FoosPrec_0123456789876543210Sym1KindInference) ()) - data FoosPrec_0123456789876543210Sym1 (a0123456789876543210 :: Nat) :: forall a0123456789876543210. - (~>) [a0123456789876543210] ((~>) [Bool] [Bool]) - where - FoosPrec_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (FoosPrec_0123456789876543210Sym1 a0123456789876543210) arg) (FoosPrec_0123456789876543210Sym2 a0123456789876543210 arg) => - FoosPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (FoosPrec_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = FoosPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings FoosPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) FoosPrec_0123456789876543210Sym0KindInference) ()) - data FoosPrec_0123456789876543210Sym0 :: forall a0123456789876543210. - (~>) Nat ((~>) [a0123456789876543210] ((~>) [Bool] [Bool])) - where - FoosPrec_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply FoosPrec_0123456789876543210Sym0 arg) (FoosPrec_0123456789876543210Sym1 arg) => - FoosPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply FoosPrec_0123456789876543210Sym0 a0123456789876543210 = FoosPrec_0123456789876543210Sym1 a0123456789876543210 - instance PFoo [a] where - type FoosPrec a a a = Apply (Apply (Apply FoosPrec_0123456789876543210Sym0 a) a) a - class SFoo a where - sFoosPrec :: - forall (t :: Nat) (t :: a) (t :: [Bool]). - Sing t - -> Sing t - -> Sing t - -> Sing (Apply (Apply (Apply FoosPrecSym0 t) t) t :: [Bool]) - sFooList :: - forall (t :: a) (t :: [Bool]). - Sing t -> Sing t -> Sing (Apply (Apply FooListSym0 t) t :: [Bool]) - default sFooList :: - forall (t :: a) (t :: [Bool]). - ((Apply (Apply FooListSym0 t) t :: [Bool]) - ~ Apply (Apply FooList_0123456789876543210Sym0 t) t) => - Sing t -> Sing t -> Sing (Apply (Apply FooListSym0 t) t :: [Bool]) - sFooList - (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (sUndefined sA_0123456789876543210) sA_0123456789876543210 - instance SFoo a => SFoo [a] where - sFoosPrec :: - forall (t :: Nat) (t :: [a]) (t :: [Bool]). - Sing t - -> Sing t - -> Sing t - -> Sing (Apply (Apply (Apply FoosPrecSym0 t) t) t :: [Bool]) - sFoosPrec - _ - (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @FooListSym0) sFooList)) - sA_0123456789876543210)) - sA_0123456789876543210 - instance SFoo a => - SingI (FoosPrecSym0 :: (~>) Nat ((~>) a ((~>) [Bool] [Bool]))) where - sing = (singFun3 @FoosPrecSym0) sFoosPrec - instance (SFoo a, SingI d) => - SingI (FoosPrecSym1 (d :: Nat) :: (~>) a ((~>) [Bool] [Bool])) where - sing = (singFun2 @(FoosPrecSym1 (d :: Nat))) (sFoosPrec (sing @d)) - instance (SFoo a, SingI d, SingI d) => - SingI (FoosPrecSym2 (d :: Nat) (d :: a) :: (~>) [Bool] [Bool]) where - sing - = (singFun1 @(FoosPrecSym2 (d :: Nat) (d :: a))) - ((sFoosPrec (sing @d)) (sing @d)) - instance SFoo a => - SingI (FooListSym0 :: (~>) a ((~>) [Bool] [Bool])) where - sing = (singFun2 @FooListSym0) sFooList - instance (SFoo a, SingI d) => - SingI (FooListSym1 (d :: a) :: (~>) [Bool] [Bool]) where - sing = (singFun1 @(FooListSym1 (d :: a))) (sFooList (sing @d)) diff --git a/tests/compile-and-dump/Singletons/T167.hs b/tests/compile-and-dump/Singletons/T167.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T167.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -module Singletons.T167 where - -import Data.Singletons.TH -import GHC.TypeLits - -type DiffList = [Bool] -> [Bool] - -$(singletonsOnly [d| - class Foo a where - foosPrec :: Nat -> a -> DiffList - fooList :: a -> DiffList - fooList = undefined - - instance Foo a => Foo [a] where - foosPrec _ = fooList - |]) diff --git a/tests/compile-and-dump/Singletons/T172.ghc88.template b/tests/compile-and-dump/Singletons/T172.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T172.ghc88.template +++ /dev/null @@ -1,40 +0,0 @@ -Singletons/T172.hs:(0,0)-(0,0): Splicing declarations - singletonsOnly - [d| ($>) :: Nat -> Nat -> Nat - ($>) = (+) |] - ======> - type ($>@#@$$$) (a0123456789876543210 :: Nat) (a0123456789876543210 :: Nat) = - ($>) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (($>@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (:$>@#@$$###)) ()) - data ($>@#@$$) (a0123456789876543210 :: Nat) :: (~>) Nat Nat - where - (:$>@#@$$###) :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (($>@#@$$) a0123456789876543210) arg) (($>@#@$$$) a0123456789876543210 arg) => - ($>@#@$$) a0123456789876543210 a0123456789876543210 - type instance Apply (($>@#@$$) a0123456789876543210) a0123456789876543210 = ($>) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ($>@#@$) where - suppressUnusedWarnings = snd (((,) (:$>@#@$###)) ()) - data ($>@#@$) :: (~>) Nat ((~>) Nat Nat) - where - (:$>@#@$###) :: forall a0123456789876543210 - arg. SameKind (Apply ($>@#@$) arg) (($>@#@$$) arg) => - ($>@#@$) a0123456789876543210 - type instance Apply ($>@#@$) a0123456789876543210 = ($>@#@$$) a0123456789876543210 - type family ($>) (a :: Nat) (a :: Nat) :: Nat where - ($>) a_0123456789876543210 a_0123456789876543210 = Apply (Apply (+@#@$) a_0123456789876543210) a_0123456789876543210 - (%$>) :: - forall (t :: Nat) (t :: Nat). - Sing t -> Sing t -> Sing (Apply (Apply ($>@#@$) t) t :: Nat) - (%$>) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @(+@#@$)) (%+))) sA_0123456789876543210)) - sA_0123456789876543210 - instance SingI (($>@#@$) :: (~>) Nat ((~>) Nat Nat)) where - sing = (singFun2 @($>@#@$)) (%$>) - instance SingI d => - SingI (($>@#@$$) (d :: Nat) :: (~>) Nat Nat) where - sing = (singFun1 @(($>@#@$$) (d :: Nat))) ((%$>) (sing @d)) diff --git a/tests/compile-and-dump/Singletons/T172.hs b/tests/compile-and-dump/Singletons/T172.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T172.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -module T172 where - -import Data.Singletons.Prelude -import Data.Singletons.TH -import Data.Singletons.TypeLits - -$(singletonsOnly [d| - ($>) :: Nat -> Nat -> Nat - ($>) = (+) - |]) diff --git a/tests/compile-and-dump/Singletons/T175.ghc88.template b/tests/compile-and-dump/Singletons/T175.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T175.ghc88.template +++ /dev/null @@ -1,45 +0,0 @@ -Singletons/T175.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| quux2 :: Bar2 a => a - quux2 = baz - - class Foo a where - baz :: a - class Foo a => Bar1 a where - quux1 :: a - quux1 = baz - class Foo a => Bar2 a |] - ======> - class Foo a where - baz :: a - class Foo a => Bar1 a where - quux1 :: a - quux1 = baz - class Foo a => Bar2 a - quux2 :: Bar2 a => a - quux2 = baz - type Quux2Sym0 = Quux2 - type family Quux2 :: a where - Quux2 = BazSym0 - type BazSym0 = Baz - class PFoo (a :: GHC.Types.Type) where - type Baz :: a - type Quux1Sym0 = Quux1 - type family Quux1_0123456789876543210 :: a where - Quux1_0123456789876543210 = BazSym0 - type Quux1_0123456789876543210Sym0 = Quux1_0123456789876543210 - class PBar1 (a :: GHC.Types.Type) where - type Quux1 :: a - type Quux1 = Quux1_0123456789876543210Sym0 - class PBar2 (a :: GHC.Types.Type) - sQuux2 :: forall a. SBar2 a => Sing (Quux2Sym0 :: a) - sQuux2 = sBaz - class SFoo a where - sBaz :: Sing (BazSym0 :: a) - class SFoo a => SBar1 a where - sQuux1 :: Sing (Quux1Sym0 :: a) - default sQuux1 :: - ((Quux1Sym0 :: a) ~ Quux1_0123456789876543210Sym0) => - Sing (Quux1Sym0 :: a) - sQuux1 = sBaz - class SFoo a => SBar2 a diff --git a/tests/compile-and-dump/Singletons/T175.hs b/tests/compile-and-dump/Singletons/T175.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T175.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleContexts #-} - -module T175 where - -import Data.Singletons.Prelude -import Data.Singletons.TH - -$(singletons [d| - class Foo a where - baz :: a - - class Foo a => Bar1 a where - quux1 :: a - quux1 = baz - - class Foo a => Bar2 a where - - quux2 :: Bar2 a => a - quux2 = baz - |]) diff --git a/tests/compile-and-dump/Singletons/T176.ghc88.template b/tests/compile-and-dump/Singletons/T176.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T176.ghc88.template +++ /dev/null @@ -1,167 +0,0 @@ -Singletons/T176.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| quux1 :: Foo1 a => a -> a - quux1 x = x `bar1` \ _ -> baz1 - quux2 :: Foo2 a => a -> a - quux2 x = x `bar2` baz2 - - class Foo1 a where - bar1 :: a -> (a -> b) -> b - baz1 :: a - class Foo2 a where - bar2 :: a -> b -> b - baz2 :: a |] - ======> - class Foo1 a where - bar1 :: a -> (a -> b) -> b - baz1 :: a - quux1 :: Foo1 a => a -> a - quux1 x = (x `bar1` (\ _ -> baz1)) - class Foo2 a where - bar2 :: a -> b -> b - baz2 :: a - quux2 :: Foo2 a => a -> a - quux2 x = (x `bar2` baz2) - type family Case_0123456789876543210 arg_0123456789876543210 x t where - Case_0123456789876543210 arg_0123456789876543210 x _ = Baz1Sym0 - type family Lambda_0123456789876543210 x t where - Lambda_0123456789876543210 x arg_0123456789876543210 = Case_0123456789876543210 arg_0123456789876543210 x arg_0123456789876543210 - type Lambda_0123456789876543210Sym2 x0123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 x0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 x0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall x0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 x0123456789876543210) arg) (Lambda_0123456789876543210Sym2 x0123456789876543210 arg) => - Lambda_0123456789876543210Sym1 x0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 x0123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 x0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 x0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall x0123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 x0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 x0123456789876543210 = Lambda_0123456789876543210Sym1 x0123456789876543210 - type Quux2Sym1 (a0123456789876543210 :: a0123456789876543210) = - Quux2 a0123456789876543210 - instance SuppressUnusedWarnings Quux2Sym0 where - suppressUnusedWarnings = snd (((,) Quux2Sym0KindInference) ()) - data Quux2Sym0 :: forall a0123456789876543210. - (~>) a0123456789876543210 a0123456789876543210 - where - Quux2Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Quux2Sym0 arg) (Quux2Sym1 arg) => - Quux2Sym0 a0123456789876543210 - type instance Apply Quux2Sym0 a0123456789876543210 = Quux2 a0123456789876543210 - type Quux1Sym1 (a0123456789876543210 :: a0123456789876543210) = - Quux1 a0123456789876543210 - instance SuppressUnusedWarnings Quux1Sym0 where - suppressUnusedWarnings = snd (((,) Quux1Sym0KindInference) ()) - data Quux1Sym0 :: forall a0123456789876543210. - (~>) a0123456789876543210 a0123456789876543210 - where - Quux1Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Quux1Sym0 arg) (Quux1Sym1 arg) => - Quux1Sym0 a0123456789876543210 - type instance Apply Quux1Sym0 a0123456789876543210 = Quux1 a0123456789876543210 - type family Quux2 (a :: a) :: a where - Quux2 x = Apply (Apply Bar2Sym0 x) Baz2Sym0 - type family Quux1 (a :: a) :: a where - Quux1 x = Apply (Apply Bar1Sym0 x) (Apply Lambda_0123456789876543210Sym0 x) - type Bar1Sym2 (arg0123456789876543210 :: a0123456789876543210) (arg0123456789876543210 :: (~>) a0123456789876543210 b0123456789876543210) = - Bar1 arg0123456789876543210 arg0123456789876543210 - instance SuppressUnusedWarnings (Bar1Sym1 arg0123456789876543210) where - suppressUnusedWarnings = snd (((,) Bar1Sym1KindInference) ()) - data Bar1Sym1 (arg0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210. - (~>) ((~>) a0123456789876543210 b0123456789876543210) b0123456789876543210 - where - Bar1Sym1KindInference :: forall arg0123456789876543210 - arg0123456789876543210 - arg. SameKind (Apply (Bar1Sym1 arg0123456789876543210) arg) (Bar1Sym2 arg0123456789876543210 arg) => - Bar1Sym1 arg0123456789876543210 arg0123456789876543210 - type instance Apply (Bar1Sym1 arg0123456789876543210) arg0123456789876543210 = Bar1 arg0123456789876543210 arg0123456789876543210 - instance SuppressUnusedWarnings Bar1Sym0 where - suppressUnusedWarnings = snd (((,) Bar1Sym0KindInference) ()) - data Bar1Sym0 :: forall a0123456789876543210 b0123456789876543210. - (~>) a0123456789876543210 ((~>) ((~>) a0123456789876543210 b0123456789876543210) b0123456789876543210) - where - Bar1Sym0KindInference :: forall arg0123456789876543210 - arg. SameKind (Apply Bar1Sym0 arg) (Bar1Sym1 arg) => - Bar1Sym0 arg0123456789876543210 - type instance Apply Bar1Sym0 arg0123456789876543210 = Bar1Sym1 arg0123456789876543210 - type Baz1Sym0 = Baz1 - class PFoo1 (a :: Type) where - type Bar1 (arg :: a) (arg :: (~>) a b) :: b - type Baz1 :: a - type Bar2Sym2 (arg0123456789876543210 :: a0123456789876543210) (arg0123456789876543210 :: b0123456789876543210) = - Bar2 arg0123456789876543210 arg0123456789876543210 - instance SuppressUnusedWarnings (Bar2Sym1 arg0123456789876543210) where - suppressUnusedWarnings = snd (((,) Bar2Sym1KindInference) ()) - data Bar2Sym1 (arg0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210. - (~>) b0123456789876543210 b0123456789876543210 - where - Bar2Sym1KindInference :: forall arg0123456789876543210 - arg0123456789876543210 - arg. SameKind (Apply (Bar2Sym1 arg0123456789876543210) arg) (Bar2Sym2 arg0123456789876543210 arg) => - Bar2Sym1 arg0123456789876543210 arg0123456789876543210 - type instance Apply (Bar2Sym1 arg0123456789876543210) arg0123456789876543210 = Bar2 arg0123456789876543210 arg0123456789876543210 - instance SuppressUnusedWarnings Bar2Sym0 where - suppressUnusedWarnings = snd (((,) Bar2Sym0KindInference) ()) - data Bar2Sym0 :: forall a0123456789876543210 b0123456789876543210. - (~>) a0123456789876543210 ((~>) b0123456789876543210 b0123456789876543210) - where - Bar2Sym0KindInference :: forall arg0123456789876543210 - arg. SameKind (Apply Bar2Sym0 arg) (Bar2Sym1 arg) => - Bar2Sym0 arg0123456789876543210 - type instance Apply Bar2Sym0 arg0123456789876543210 = Bar2Sym1 arg0123456789876543210 - type Baz2Sym0 = Baz2 - class PFoo2 (a :: Type) where - type Bar2 (arg :: a) (arg :: b) :: b - type Baz2 :: a - sQuux2 :: - forall a (t :: a). - SFoo2 a => Sing t -> Sing (Apply Quux2Sym0 t :: a) - sQuux1 :: - forall a (t :: a). - SFoo1 a => Sing t -> Sing (Apply Quux1Sym0 t :: a) - sQuux2 (sX :: Sing x) - = (applySing ((applySing ((singFun2 @Bar2Sym0) sBar2)) sX)) sBaz2 - sQuux1 (sX :: Sing x) - = (applySing ((applySing ((singFun2 @Bar1Sym0) sBar1)) sX)) - ((singFun1 @(Apply Lambda_0123456789876543210Sym0 x)) - (\ sArg_0123456789876543210 - -> case sArg_0123456789876543210 of { - (_ :: Sing arg_0123456789876543210) - -> (id - @(Sing (Case_0123456789876543210 arg_0123456789876543210 x arg_0123456789876543210))) - (case sArg_0123456789876543210 of { _ -> sBaz1 }) })) - instance SFoo2 a => SingI (Quux2Sym0 :: (~>) a a) where - sing = (singFun1 @Quux2Sym0) sQuux2 - instance SFoo1 a => SingI (Quux1Sym0 :: (~>) a a) where - sing = (singFun1 @Quux1Sym0) sQuux1 - class SFoo1 a where - sBar1 :: - forall b (t :: a) (t :: (~>) a b). - Sing t -> Sing t -> Sing (Apply (Apply Bar1Sym0 t) t :: b) - sBaz1 :: Sing (Baz1Sym0 :: a) - class SFoo2 a where - sBar2 :: - forall b (t :: a) (t :: b). - Sing t -> Sing t -> Sing (Apply (Apply Bar2Sym0 t) t :: b) - sBaz2 :: Sing (Baz2Sym0 :: a) - instance SFoo1 a => - SingI (Bar1Sym0 :: (~>) a ((~>) ((~>) a b) b)) where - sing = (singFun2 @Bar1Sym0) sBar1 - instance (SFoo1 a, SingI d) => - SingI (Bar1Sym1 (d :: a) :: (~>) ((~>) a b) b) where - sing = (singFun1 @(Bar1Sym1 (d :: a))) (sBar1 (sing @d)) - instance SFoo2 a => SingI (Bar2Sym0 :: (~>) a ((~>) b b)) where - sing = (singFun2 @Bar2Sym0) sBar2 - instance (SFoo2 a, SingI d) => - SingI (Bar2Sym1 (d :: a) :: (~>) b b) where - sing = (singFun1 @(Bar2Sym1 (d :: a))) (sBar2 (sing @d)) diff --git a/tests/compile-and-dump/Singletons/T176.hs b/tests/compile-and-dump/Singletons/T176.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T176.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -module T176 where - -import Data.Kind (Type) -import Data.Singletons.Prelude -import Data.Singletons.TH - -$(singletons [d| - class Foo1 a where - bar1 :: a -> (a -> b) -> b - baz1 :: a - - quux1 :: Foo1 a => a -> a - quux1 x = x `bar1` \_ -> baz1 - - class Foo2 a where - bar2 :: a -> b -> b - baz2 :: a - - quux2 :: Foo2 a => a -> a - quux2 x = x `bar2` baz2 - |]) diff --git a/tests/compile-and-dump/Singletons/T178.ghc88.template b/tests/compile-and-dump/Singletons/T178.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T178.ghc88.template +++ /dev/null @@ -1,221 +0,0 @@ -Singletons/T178.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| empty :: U - empty = [] - - data Occ - = Str | Opt | Many - deriving (Eq, Ord, Show) - type U = [(Symbol, Occ)] |] - ======> - data Occ - = Str | Opt | Many - deriving (Eq, Ord, Show) - type U = [(Symbol, Occ)] - empty :: U - empty = [] - type USym0 = U - type StrSym0 = Str - type OptSym0 = Opt - type ManySym0 = Many - type EmptySym0 = Empty - type family Empty :: [(Symbol, Occ)] where - Empty = '[] - type family Compare_0123456789876543210 (a :: Occ) (a :: Occ) :: Ordering where - Compare_0123456789876543210 Str Str = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) '[] - Compare_0123456789876543210 Opt Opt = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) '[] - Compare_0123456789876543210 Many Many = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) '[] - Compare_0123456789876543210 Str Opt = LTSym0 - Compare_0123456789876543210 Str Many = LTSym0 - Compare_0123456789876543210 Opt Str = GTSym0 - Compare_0123456789876543210 Opt Many = LTSym0 - Compare_0123456789876543210 Many Str = GTSym0 - Compare_0123456789876543210 Many Opt = GTSym0 - type Compare_0123456789876543210Sym2 (a0123456789876543210 :: Occ) (a0123456789876543210 :: Occ) = - Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Compare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym1KindInference) ()) - data Compare_0123456789876543210Sym1 (a0123456789876543210 :: Occ) :: (~>) Occ Ordering - where - Compare_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Compare_0123456789876543210Sym1 a0123456789876543210) arg) (Compare_0123456789876543210Sym2 a0123456789876543210 arg) => - Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Compare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Compare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym0KindInference) ()) - data Compare_0123456789876543210Sym0 :: (~>) Occ ((~>) Occ Ordering) - where - Compare_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Compare_0123456789876543210Sym0 arg) (Compare_0123456789876543210Sym1 arg) => - Compare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Compare_0123456789876543210Sym0 a0123456789876543210 = Compare_0123456789876543210Sym1 a0123456789876543210 - instance POrd Occ where - type Compare a a = Apply (Apply Compare_0123456789876543210Sym0 a) a - type family ShowsPrec_0123456789876543210 (a :: Nat) (a :: Occ) (a :: Symbol) :: Symbol where - ShowsPrec_0123456789876543210 _ Str a_0123456789876543210 = Apply (Apply ShowStringSym0 "Str") a_0123456789876543210 - ShowsPrec_0123456789876543210 _ Opt a_0123456789876543210 = Apply (Apply ShowStringSym0 "Opt") a_0123456789876543210 - ShowsPrec_0123456789876543210 _ Many a_0123456789876543210 = Apply (Apply ShowStringSym0 "Many") a_0123456789876543210 - type ShowsPrec_0123456789876543210Sym3 (a0123456789876543210 :: Nat) (a0123456789876543210 :: Occ) (a0123456789876543210 :: Symbol) = - ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym2KindInference) ()) - data ShowsPrec_0123456789876543210Sym2 (a0123456789876543210 :: Nat) (a0123456789876543210 :: Occ) :: (~>) Symbol Symbol - where - ShowsPrec_0123456789876543210Sym2KindInference :: forall a0123456789876543210 - a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) arg) (ShowsPrec_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 arg) => - ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym1KindInference) ()) - data ShowsPrec_0123456789876543210Sym1 (a0123456789876543210 :: Nat) :: (~>) Occ ((~>) Symbol Symbol) - where - ShowsPrec_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) arg) (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 arg) => - ShowsPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ShowsPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym0KindInference) ()) - data ShowsPrec_0123456789876543210Sym0 :: (~>) Nat ((~>) Occ ((~>) Symbol Symbol)) - where - ShowsPrec_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply ShowsPrec_0123456789876543210Sym0 arg) (ShowsPrec_0123456789876543210Sym1 arg) => - ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ShowsPrec_0123456789876543210Sym0 a0123456789876543210 = ShowsPrec_0123456789876543210Sym1 a0123456789876543210 - instance PShow Occ where - type ShowsPrec a a a = Apply (Apply (Apply ShowsPrec_0123456789876543210Sym0 a) a) a - type family Equals_0123456789876543210 (a :: Occ) (b :: Occ) :: Bool where - Equals_0123456789876543210 Str Str = TrueSym0 - Equals_0123456789876543210 Opt Opt = TrueSym0 - Equals_0123456789876543210 Many Many = TrueSym0 - Equals_0123456789876543210 (_ :: Occ) (_ :: Occ) = FalseSym0 - instance PEq Occ where - type (==) a b = Equals_0123456789876543210 a b - sEmpty :: Sing (EmptySym0 :: [(Symbol, Occ)]) - sEmpty = Data.Singletons.Prelude.Instances.SNil - data SOcc :: Occ -> GHC.Types.Type - where - SStr :: SOcc Str - SOpt :: SOcc Opt - SMany :: SOcc Many - type instance Sing @Occ = SOcc - instance SingKind Occ where - type Demote Occ = Occ - fromSing SStr = Str - fromSing SOpt = Opt - fromSing SMany = Many - toSing Str = SomeSing SStr - toSing Opt = SomeSing SOpt - toSing Many = SomeSing SMany - instance SOrd Occ where - sCompare :: - forall (t1 :: Occ) (t2 :: Occ). - Sing t1 - -> Sing t2 - -> Sing (Apply (Apply (CompareSym0 :: TyFun Occ ((~>) Occ Ordering) - -> GHC.Types.Type) t1) t2) - sCompare SStr SStr - = (applySing - ((applySing - ((applySing ((singFun3 @FoldlSym0) sFoldl)) - ((singFun2 @ThenCmpSym0) sThenCmp))) - SEQ)) - Data.Singletons.Prelude.Instances.SNil - sCompare SOpt SOpt - = (applySing - ((applySing - ((applySing ((singFun3 @FoldlSym0) sFoldl)) - ((singFun2 @ThenCmpSym0) sThenCmp))) - SEQ)) - Data.Singletons.Prelude.Instances.SNil - sCompare SMany SMany - = (applySing - ((applySing - ((applySing ((singFun3 @FoldlSym0) sFoldl)) - ((singFun2 @ThenCmpSym0) sThenCmp))) - SEQ)) - Data.Singletons.Prelude.Instances.SNil - sCompare SStr SOpt = SLT - sCompare SStr SMany = SLT - sCompare SOpt SStr = SGT - sCompare SOpt SMany = SLT - sCompare SMany SStr = SGT - sCompare SMany SOpt = SGT - instance SShow Occ where - sShowsPrec :: - forall (t1 :: Nat) (t2 :: Occ) (t3 :: Symbol). - Sing t1 - -> Sing t2 - -> Sing t3 - -> Sing (Apply (Apply (Apply (ShowsPrecSym0 :: TyFun Nat ((~>) Occ ((~>) Symbol Symbol)) - -> GHC.Types.Type) t1) t2) t3) - sShowsPrec - _ - SStr - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "Str"))) - sA_0123456789876543210 - sShowsPrec - _ - SOpt - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "Opt"))) - sA_0123456789876543210 - sShowsPrec - _ - SMany - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "Many"))) - sA_0123456789876543210 - instance SEq Occ where - (%==) SStr SStr = STrue - (%==) SStr SOpt = SFalse - (%==) SStr SMany = SFalse - (%==) SOpt SStr = SFalse - (%==) SOpt SOpt = STrue - (%==) SOpt SMany = SFalse - (%==) SMany SStr = SFalse - (%==) SMany SOpt = SFalse - (%==) SMany SMany = STrue - instance SDecide Occ where - (%~) SStr SStr = Proved Refl - (%~) SStr SOpt = Disproved (\ x -> case x of) - (%~) SStr SMany = Disproved (\ x -> case x of) - (%~) SOpt SStr = Disproved (\ x -> case x of) - (%~) SOpt SOpt = Proved Refl - (%~) SOpt SMany = Disproved (\ x -> case x of) - (%~) SMany SStr = Disproved (\ x -> case x of) - (%~) SMany SOpt = Disproved (\ x -> case x of) - (%~) SMany SMany = Proved Refl - instance Data.Type.Equality.TestEquality (SOcc :: Occ - -> GHC.Types.Type) where - Data.Type.Equality.testEquality - = Data.Singletons.Decide.decideEquality - instance Data.Type.Coercion.TestCoercion (SOcc :: Occ - -> GHC.Types.Type) where - Data.Type.Coercion.testCoercion - = Data.Singletons.Decide.decideCoercion - instance Show (SOcc (z :: Occ)) where - showsPrec _ SStr = showString "SStr" - showsPrec _ SOpt = showString "SOpt" - showsPrec _ SMany = showString "SMany" - instance SingI Str where - sing = SStr - instance SingI Opt where - sing = SOpt - instance SingI Many where - sing = SMany diff --git a/tests/compile-and-dump/Singletons/T178.hs b/tests/compile-and-dump/Singletons/T178.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T178.hs +++ /dev/null @@ -1,15 +0,0 @@ -module T178 where - -import GHC.TypeLits -import Data.Singletons.TH - -$(singletons [d| - - -- Note: Ord automatically defines "max" - data Occ = Str | Opt | Many deriving (Eq, Ord, Show) - - type U = [(Symbol,Occ)] - - empty :: U - empty = [] - |]) diff --git a/tests/compile-and-dump/Singletons/T183.ghc88.template b/tests/compile-and-dump/Singletons/T183.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T183.ghc88.template +++ /dev/null @@ -1,516 +0,0 @@ -Singletons/T183.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| f1 (x :: Maybe Bool) = (x :: Maybe Bool) - f2 (x :: Maybe a) = (x :: Maybe a) - f3 (Just a :: Maybe Bool) = "hi" - g x = case Just x of { (Just y :: Maybe Bool) -> (y :: Bool) } - foo1 :: Maybe a -> a - foo1 (Just x :: Maybe a) = (x :: a) - foo2, foo3 :: forall a. Maybe a -> a - foo2 (Just x :: Maybe a) = (x :: a) - foo3 (Just x) = (x :: a) - foo4 :: (a, b) -> (b, a) - foo4 = \ (x :: a, y :: b) -> (y :: b, x :: a) - foo5, foo6 :: Maybe (Maybe a) -> Maybe (Maybe a) - foo5 (Just (Just (x :: a) :: Maybe a) :: Maybe (Maybe a)) - = Just (Just (x :: a) :: Maybe a) :: Maybe (Maybe a) - foo6 (Just x :: Maybe (Maybe a)) - = case x :: Maybe a of { - (Just (y :: a) :: Maybe a) -> Just (Just (y :: a) :: Maybe a) } - foo7 :: a -> b -> a - foo7 (x :: a) (_ :: b) = (x :: a) - foo8 :: forall a. Maybe a -> Maybe a - foo8 x@(Just (_ :: a) :: Maybe a) = x - foo9 :: a -> a - foo9 (x :: a) - = let - g :: a -> b -> a - g y _ = y - in g x () |] - ======> - f1 (x :: Maybe Bool) = x :: Maybe Bool - f2 (x :: Maybe a) = x :: Maybe a - f3 (Just a :: Maybe Bool) = "hi" - g x = case Just x of { (Just y :: Maybe Bool) -> y :: Bool } - foo1 :: Maybe a -> a - foo1 (Just x :: Maybe a) = x :: a - foo2 :: forall a. Maybe a -> a - foo3 :: forall a. Maybe a -> a - foo2 (Just x :: Maybe a) = x :: a - foo3 (Just x) = x :: a - foo4 :: (a, b) -> (b, a) - foo4 = \ (x :: a, y :: b) -> (y :: b, x :: a) - foo5 :: Maybe (Maybe a) -> Maybe (Maybe a) - foo6 :: Maybe (Maybe a) -> Maybe (Maybe a) - foo5 (Just (Just (x :: a) :: Maybe a) :: Maybe (Maybe a)) - = Just (Just (x :: a) :: Maybe a) :: Maybe (Maybe a) - foo6 (Just x :: Maybe (Maybe a)) - = case x :: Maybe a of { - (Just (y :: a) :: Maybe a) -> Just (Just (y :: a) :: Maybe a) } - foo7 :: a -> b -> a - foo7 (x :: a) (_ :: b) = x :: a - foo8 :: forall a. Maybe a -> Maybe a - foo8 x@(Just (_ :: a) :: Maybe a) = x - foo9 :: a -> a - foo9 (x :: a) - = let - g :: a -> b -> a - g y _ = y - in (g x) () - type Let0123456789876543210GSym3 x0123456789876543210 (a0123456789876543210 :: a) (a0123456789876543210 :: b0123456789876543210) = - Let0123456789876543210G x0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210GSym2 a0123456789876543210 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210GSym2KindInference) ()) - data Let0123456789876543210GSym2 x0123456789876543210 (a0123456789876543210 :: a) :: forall b0123456789876543210. - (~>) b0123456789876543210 a - where - Let0123456789876543210GSym2KindInference :: forall x0123456789876543210 - a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Let0123456789876543210GSym2 x0123456789876543210 a0123456789876543210) arg) (Let0123456789876543210GSym3 x0123456789876543210 a0123456789876543210 arg) => - Let0123456789876543210GSym2 x0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (Let0123456789876543210GSym2 a0123456789876543210 x0123456789876543210) a0123456789876543210 = Let0123456789876543210G a0123456789876543210 x0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210GSym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210GSym1KindInference) ()) - data Let0123456789876543210GSym1 x0123456789876543210 :: forall a - b0123456789876543210. - (~>) a ((~>) b0123456789876543210 a) - where - Let0123456789876543210GSym1KindInference :: forall x0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Let0123456789876543210GSym1 x0123456789876543210) arg) (Let0123456789876543210GSym2 x0123456789876543210 arg) => - Let0123456789876543210GSym1 x0123456789876543210 a0123456789876543210 - type instance Apply (Let0123456789876543210GSym1 x0123456789876543210) a0123456789876543210 = Let0123456789876543210GSym2 x0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210GSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210GSym0KindInference) ()) - data Let0123456789876543210GSym0 x0123456789876543210 - where - Let0123456789876543210GSym0KindInference :: forall x0123456789876543210 - arg. SameKind (Apply Let0123456789876543210GSym0 arg) (Let0123456789876543210GSym1 arg) => - Let0123456789876543210GSym0 x0123456789876543210 - type instance Apply Let0123456789876543210GSym0 x0123456789876543210 = Let0123456789876543210GSym1 x0123456789876543210 - type family Let0123456789876543210G x (a :: a) (a :: b) :: a where - Let0123456789876543210G x y _ = y - type Let0123456789876543210XSym1 wild_01234567898765432100123456789876543210 = - Let0123456789876543210X wild_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210XSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210XSym0KindInference) ()) - data Let0123456789876543210XSym0 wild_01234567898765432100123456789876543210 - where - Let0123456789876543210XSym0KindInference :: forall wild_01234567898765432100123456789876543210 - arg. SameKind (Apply Let0123456789876543210XSym0 arg) (Let0123456789876543210XSym1 arg) => - Let0123456789876543210XSym0 wild_01234567898765432100123456789876543210 - type instance Apply Let0123456789876543210XSym0 wild_01234567898765432100123456789876543210 = Let0123456789876543210X wild_01234567898765432100123456789876543210 - type family Let0123456789876543210X wild_0123456789876543210 where - Let0123456789876543210X wild_0123456789876543210 = Apply JustSym0 (wild_0123456789876543210 :: a) :: Maybe a - type Let0123456789876543210Scrutinee_0123456789876543210Sym1 x0123456789876543210 = - Let0123456789876543210Scrutinee_0123456789876543210 x0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210Scrutinee_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd - (((,) - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference) - ()) - data Let0123456789876543210Scrutinee_0123456789876543210Sym0 x0123456789876543210 - where - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference :: forall x0123456789876543210 - arg. SameKind (Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 arg) (Let0123456789876543210Scrutinee_0123456789876543210Sym1 arg) => - Let0123456789876543210Scrutinee_0123456789876543210Sym0 x0123456789876543210 - type instance Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 x0123456789876543210 = Let0123456789876543210Scrutinee_0123456789876543210 x0123456789876543210 - type family Let0123456789876543210Scrutinee_0123456789876543210 x where - Let0123456789876543210Scrutinee_0123456789876543210 x = x :: Maybe a - type family Case_0123456789876543210 x t where - Case_0123456789876543210 x ('Just (y :: a) :: Maybe a) = Apply JustSym0 (Apply JustSym0 (y :: a) :: Maybe a) - type family Case_0123456789876543210 arg_0123456789876543210 a_0123456789876543210 t where - Case_0123456789876543210 arg_0123456789876543210 a_0123456789876543210 '(x :: a, - y :: b) = Apply (Apply Tuple2Sym0 (y :: b)) (x :: a) - type family Lambda_0123456789876543210 a_0123456789876543210 t where - Lambda_0123456789876543210 a_0123456789876543210 arg_0123456789876543210 = Case_0123456789876543210 arg_0123456789876543210 a_0123456789876543210 arg_0123456789876543210 - type Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall a_01234567898765432100123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 a_01234567898765432100123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall a_01234567898765432100123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 a_01234567898765432100123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210 - type Let0123456789876543210Scrutinee_0123456789876543210Sym1 x0123456789876543210 = - Let0123456789876543210Scrutinee_0123456789876543210 x0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210Scrutinee_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd - (((,) - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference) - ()) - data Let0123456789876543210Scrutinee_0123456789876543210Sym0 x0123456789876543210 - where - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference :: forall x0123456789876543210 - arg. SameKind (Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 arg) (Let0123456789876543210Scrutinee_0123456789876543210Sym1 arg) => - Let0123456789876543210Scrutinee_0123456789876543210Sym0 x0123456789876543210 - type instance Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 x0123456789876543210 = Let0123456789876543210Scrutinee_0123456789876543210 x0123456789876543210 - type family Let0123456789876543210Scrutinee_0123456789876543210 x where - Let0123456789876543210Scrutinee_0123456789876543210 x = Apply JustSym0 x - type family Case_0123456789876543210 x t where - Case_0123456789876543210 x ('Just y :: Maybe Bool) = y :: Bool - type Foo9Sym1 (a0123456789876543210 :: a0123456789876543210) = - Foo9 a0123456789876543210 - instance SuppressUnusedWarnings Foo9Sym0 where - suppressUnusedWarnings = snd (((,) Foo9Sym0KindInference) ()) - data Foo9Sym0 :: forall a0123456789876543210. - (~>) a0123456789876543210 a0123456789876543210 - where - Foo9Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo9Sym0 arg) (Foo9Sym1 arg) => - Foo9Sym0 a0123456789876543210 - type instance Apply Foo9Sym0 a0123456789876543210 = Foo9 a0123456789876543210 - type Foo8Sym1 (a0123456789876543210 :: Maybe a0123456789876543210) = - Foo8 a0123456789876543210 - instance SuppressUnusedWarnings Foo8Sym0 where - suppressUnusedWarnings = snd (((,) Foo8Sym0KindInference) ()) - data Foo8Sym0 :: forall a0123456789876543210. - (~>) (Maybe a0123456789876543210) (Maybe a0123456789876543210) - where - Foo8Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo8Sym0 arg) (Foo8Sym1 arg) => - Foo8Sym0 a0123456789876543210 - type instance Apply Foo8Sym0 a0123456789876543210 = Foo8 a0123456789876543210 - type Foo7Sym2 (a0123456789876543210 :: a0123456789876543210) (a0123456789876543210 :: b0123456789876543210) = - Foo7 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Foo7Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) Foo7Sym1KindInference) ()) - data Foo7Sym1 (a0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210. - (~>) b0123456789876543210 a0123456789876543210 - where - Foo7Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Foo7Sym1 a0123456789876543210) arg) (Foo7Sym2 a0123456789876543210 arg) => - Foo7Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Foo7Sym1 a0123456789876543210) a0123456789876543210 = Foo7 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Foo7Sym0 where - suppressUnusedWarnings = snd (((,) Foo7Sym0KindInference) ()) - data Foo7Sym0 :: forall a0123456789876543210 b0123456789876543210. - (~>) a0123456789876543210 ((~>) b0123456789876543210 a0123456789876543210) - where - Foo7Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo7Sym0 arg) (Foo7Sym1 arg) => - Foo7Sym0 a0123456789876543210 - type instance Apply Foo7Sym0 a0123456789876543210 = Foo7Sym1 a0123456789876543210 - type Foo6Sym1 (a0123456789876543210 :: Maybe (Maybe a0123456789876543210)) = - Foo6 a0123456789876543210 - instance SuppressUnusedWarnings Foo6Sym0 where - suppressUnusedWarnings = snd (((,) Foo6Sym0KindInference) ()) - data Foo6Sym0 :: forall a0123456789876543210. - (~>) (Maybe (Maybe a0123456789876543210)) (Maybe (Maybe a0123456789876543210)) - where - Foo6Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo6Sym0 arg) (Foo6Sym1 arg) => - Foo6Sym0 a0123456789876543210 - type instance Apply Foo6Sym0 a0123456789876543210 = Foo6 a0123456789876543210 - type Foo5Sym1 (a0123456789876543210 :: Maybe (Maybe a0123456789876543210)) = - Foo5 a0123456789876543210 - instance SuppressUnusedWarnings Foo5Sym0 where - suppressUnusedWarnings = snd (((,) Foo5Sym0KindInference) ()) - data Foo5Sym0 :: forall a0123456789876543210. - (~>) (Maybe (Maybe a0123456789876543210)) (Maybe (Maybe a0123456789876543210)) - where - Foo5Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo5Sym0 arg) (Foo5Sym1 arg) => - Foo5Sym0 a0123456789876543210 - type instance Apply Foo5Sym0 a0123456789876543210 = Foo5 a0123456789876543210 - type Foo4Sym1 (a0123456789876543210 :: (a0123456789876543210, - b0123456789876543210)) = - Foo4 a0123456789876543210 - instance SuppressUnusedWarnings Foo4Sym0 where - suppressUnusedWarnings = snd (((,) Foo4Sym0KindInference) ()) - data Foo4Sym0 :: forall a0123456789876543210 b0123456789876543210. - (~>) (a0123456789876543210, - b0123456789876543210) (b0123456789876543210, a0123456789876543210) - where - Foo4Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo4Sym0 arg) (Foo4Sym1 arg) => - Foo4Sym0 a0123456789876543210 - type instance Apply Foo4Sym0 a0123456789876543210 = Foo4 a0123456789876543210 - type Foo3Sym1 (a0123456789876543210 :: Maybe a0123456789876543210) = - Foo3 a0123456789876543210 - instance SuppressUnusedWarnings Foo3Sym0 where - suppressUnusedWarnings = snd (((,) Foo3Sym0KindInference) ()) - data Foo3Sym0 :: forall a0123456789876543210. - (~>) (Maybe a0123456789876543210) a0123456789876543210 - where - Foo3Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo3Sym0 arg) (Foo3Sym1 arg) => - Foo3Sym0 a0123456789876543210 - type instance Apply Foo3Sym0 a0123456789876543210 = Foo3 a0123456789876543210 - type Foo2Sym1 (a0123456789876543210 :: Maybe a0123456789876543210) = - Foo2 a0123456789876543210 - instance SuppressUnusedWarnings Foo2Sym0 where - suppressUnusedWarnings = snd (((,) Foo2Sym0KindInference) ()) - data Foo2Sym0 :: forall a0123456789876543210. - (~>) (Maybe a0123456789876543210) a0123456789876543210 - where - Foo2Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo2Sym0 arg) (Foo2Sym1 arg) => - Foo2Sym0 a0123456789876543210 - type instance Apply Foo2Sym0 a0123456789876543210 = Foo2 a0123456789876543210 - type Foo1Sym1 (a0123456789876543210 :: Maybe a0123456789876543210) = - Foo1 a0123456789876543210 - instance SuppressUnusedWarnings Foo1Sym0 where - suppressUnusedWarnings = snd (((,) Foo1Sym0KindInference) ()) - data Foo1Sym0 :: forall a0123456789876543210. - (~>) (Maybe a0123456789876543210) a0123456789876543210 - where - Foo1Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Foo1Sym0 arg) (Foo1Sym1 arg) => - Foo1Sym0 a0123456789876543210 - type instance Apply Foo1Sym0 a0123456789876543210 = Foo1 a0123456789876543210 - type GSym1 a0123456789876543210 = G a0123456789876543210 - instance SuppressUnusedWarnings GSym0 where - suppressUnusedWarnings = snd (((,) GSym0KindInference) ()) - data GSym0 a0123456789876543210 - where - GSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply GSym0 arg) (GSym1 arg) => - GSym0 a0123456789876543210 - type instance Apply GSym0 a0123456789876543210 = G a0123456789876543210 - type F3Sym1 a0123456789876543210 = F3 a0123456789876543210 - instance SuppressUnusedWarnings F3Sym0 where - suppressUnusedWarnings = snd (((,) F3Sym0KindInference) ()) - data F3Sym0 a0123456789876543210 - where - F3Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply F3Sym0 arg) (F3Sym1 arg) => - F3Sym0 a0123456789876543210 - type instance Apply F3Sym0 a0123456789876543210 = F3 a0123456789876543210 - type F2Sym1 a0123456789876543210 = F2 a0123456789876543210 - instance SuppressUnusedWarnings F2Sym0 where - suppressUnusedWarnings = snd (((,) F2Sym0KindInference) ()) - data F2Sym0 a0123456789876543210 - where - F2Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply F2Sym0 arg) (F2Sym1 arg) => - F2Sym0 a0123456789876543210 - type instance Apply F2Sym0 a0123456789876543210 = F2 a0123456789876543210 - type F1Sym1 a0123456789876543210 = F1 a0123456789876543210 - instance SuppressUnusedWarnings F1Sym0 where - suppressUnusedWarnings = snd (((,) F1Sym0KindInference) ()) - data F1Sym0 a0123456789876543210 - where - F1Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply F1Sym0 arg) (F1Sym1 arg) => - F1Sym0 a0123456789876543210 - type instance Apply F1Sym0 a0123456789876543210 = F1 a0123456789876543210 - type family Foo9 (a :: a) :: a where - Foo9 (x :: a) = Apply (Apply (Let0123456789876543210GSym1 x) x) Tuple0Sym0 - type family Foo8 (a :: Maybe a) :: Maybe a where - Foo8 ('Just (wild_0123456789876543210 :: a) :: Maybe a) = Let0123456789876543210XSym1 wild_0123456789876543210 - type family Foo7 (a :: a) (a :: b) :: a where - Foo7 (x :: a) (wild_0123456789876543210 :: b) = x :: a - type family Foo6 (a :: Maybe (Maybe a)) :: Maybe (Maybe a) where - Foo6 ('Just x :: Maybe (Maybe a)) = Case_0123456789876543210 x (Let0123456789876543210Scrutinee_0123456789876543210Sym1 x) - type family Foo5 (a :: Maybe (Maybe a)) :: Maybe (Maybe a) where - Foo5 ('Just ('Just (x :: a) :: Maybe a) :: Maybe (Maybe a)) = Apply JustSym0 (Apply JustSym0 (x :: a) :: Maybe a) :: Maybe (Maybe a) - type family Foo4 (a :: (a, b)) :: (b, a) where - Foo4 a_0123456789876543210 = Apply (Apply Lambda_0123456789876543210Sym0 a_0123456789876543210) a_0123456789876543210 - type family Foo3 (a :: Maybe a) :: a where - Foo3 ('Just x) = x :: a - type family Foo2 (a :: Maybe a) :: a where - Foo2 ('Just x :: Maybe a) = x :: a - type family Foo1 (a :: Maybe a) :: a where - Foo1 ('Just x :: Maybe a) = x :: a - type family G a where - G x = Case_0123456789876543210 x (Let0123456789876543210Scrutinee_0123456789876543210Sym1 x) - type family F3 a where - F3 ('Just a :: Maybe Bool) = "hi" - type family F2 a where - F2 (x :: Maybe a) = x :: Maybe a - type family F1 a where - F1 (x :: Maybe Bool) = x :: Maybe Bool - sFoo9 :: forall a (t :: a). Sing t -> Sing (Apply Foo9Sym0 t :: a) - sFoo8 :: - forall a (t :: Maybe a). - Sing t -> Sing (Apply Foo8Sym0 t :: Maybe a) - sFoo7 :: - forall a b (t :: a) (t :: b). - Sing t -> Sing t -> Sing (Apply (Apply Foo7Sym0 t) t :: a) - sFoo6 :: - forall a (t :: Maybe (Maybe a)). - Sing t -> Sing (Apply Foo6Sym0 t :: Maybe (Maybe a)) - sFoo5 :: - forall a (t :: Maybe (Maybe a)). - Sing t -> Sing (Apply Foo5Sym0 t :: Maybe (Maybe a)) - sFoo4 :: - forall a b (t :: (a, b)). - Sing t -> Sing (Apply Foo4Sym0 t :: (b, a)) - sFoo3 :: - forall a (t :: Maybe a). Sing t -> Sing (Apply Foo3Sym0 t :: a) - sFoo2 :: - forall a (t :: Maybe a). Sing t -> Sing (Apply Foo2Sym0 t :: a) - sFoo1 :: - forall a (t :: Maybe a). Sing t -> Sing (Apply Foo1Sym0 t :: a) - sG :: forall arg. Sing arg -> Sing (Apply GSym0 arg) - sF3 :: forall arg. Sing arg -> Sing (Apply F3Sym0 arg) - sF2 :: forall arg. Sing arg -> Sing (Apply F2Sym0 arg) - sF1 :: forall arg. Sing arg -> Sing (Apply F1Sym0 arg) - sFoo9 (sX :: Sing x) - = case sX :: Sing x of { - (_ :: Sing (x :: a)) - -> let - sG :: - forall b (t :: a) (t :: b). - Sing t - -> Sing t - -> Sing (Apply (Apply (Let0123456789876543210GSym1 x) t) t :: a) - sG (sY :: Sing y) _ = sY - in - (applySing - ((applySing ((singFun2 @(Let0123456789876543210GSym1 x)) sG)) sX)) - STuple0 } - sFoo8 - (SJust (sWild_0123456789876543210 :: Sing wild_0123456789876543210)) - = case - ((,) (sWild_0123456789876543210 :: Sing wild_0123456789876543210)) - (SJust - (sWild_0123456789876543210 :: Sing wild_0123456789876543210)) - of { - (,) (_ :: Sing (wild_0123456789876543210 :: a)) - (_ :: Sing ('Just (wild_0123456789876543210 :: a) :: Maybe a)) - -> let - sX :: Sing (Let0123456789876543210XSym1 wild_0123456789876543210) - sX - = (applySing ((singFun1 @JustSym0) SJust)) - (sWild_0123456789876543210 :: - Sing (wild_0123456789876543210 :: a)) :: - Sing (Apply JustSym0 (wild_0123456789876543210 :: a) :: Maybe a) - in sX } - sFoo7 - (sX :: Sing x) - (sWild_0123456789876543210 :: Sing wild_0123456789876543210) - = case - ((,) (sX :: Sing x)) - (sWild_0123456789876543210 :: Sing wild_0123456789876543210) - of { - (,) (_ :: Sing (x :: a)) - (_ :: Sing (wild_0123456789876543210 :: b)) - -> sX :: Sing (x :: a) } - sFoo6 (SJust (sX :: Sing x)) - = case SJust (sX :: Sing x) of { - (_ :: Sing ('Just x :: Maybe (Maybe a))) - -> let - sScrutinee_0123456789876543210 :: - Sing (Let0123456789876543210Scrutinee_0123456789876543210Sym1 x) - sScrutinee_0123456789876543210 = sX :: Sing (x :: Maybe a) - in - (id - @(Sing (Case_0123456789876543210 x (Let0123456789876543210Scrutinee_0123456789876543210Sym1 x) :: Maybe (Maybe a)))) - (case sScrutinee_0123456789876543210 of { - SJust (sY :: Sing y) - -> case ((,) (sY :: Sing y)) (SJust (sY :: Sing y)) of { - (,) (_ :: Sing (y :: a)) (_ :: Sing ('Just (y :: a) :: Maybe a)) - -> (applySing ((singFun1 @JustSym0) SJust)) - ((applySing ((singFun1 @JustSym0) SJust)) - (sY :: Sing (y :: a)) :: - Sing (Apply JustSym0 (y :: a) :: Maybe a)) } }) } - sFoo5 (SJust (SJust (sX :: Sing x))) - = case - (((,,) (sX :: Sing x)) (SJust (sX :: Sing x))) - (SJust (SJust (sX :: Sing x))) - of { - (,,) (_ :: Sing (x :: a)) - (_ :: Sing ('Just (x :: a) :: Maybe a)) - (_ :: Sing ('Just ('Just (x :: a) :: Maybe a) :: Maybe (Maybe a))) - -> (applySing ((singFun1 @JustSym0) SJust)) - ((applySing ((singFun1 @JustSym0) SJust)) (sX :: Sing (x :: a)) :: - Sing (Apply JustSym0 (x :: a) :: Maybe a)) :: - Sing (Apply JustSym0 (Apply JustSym0 (x :: a) :: Maybe a) :: Maybe (Maybe a)) } - sFoo4 (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((singFun1 - @(Apply Lambda_0123456789876543210Sym0 a_0123456789876543210)) - (\ sArg_0123456789876543210 - -> case sArg_0123456789876543210 of { - (_ :: Sing arg_0123456789876543210) - -> (id - @(Sing (Case_0123456789876543210 arg_0123456789876543210 a_0123456789876543210 arg_0123456789876543210))) - (case sArg_0123456789876543210 of { - STuple2 (sX :: Sing x) (sY :: Sing y) - -> case ((,) (sX :: Sing x)) (sY :: Sing y) of { - (,) (_ :: Sing (x :: a)) (_ :: Sing (y :: b)) - -> (applySing - ((applySing ((singFun2 @Tuple2Sym0) STuple2)) - (sY :: Sing (y :: b)))) - (sX :: Sing (x :: a)) } }) }))) - sA_0123456789876543210 - sFoo3 (SJust (sX :: Sing x)) = sX :: Sing (x :: a) - sFoo2 (SJust (sX :: Sing x)) - = case SJust (sX :: Sing x) of { - (_ :: Sing ('Just x :: Maybe a)) -> sX :: Sing (x :: a) } - sFoo1 (SJust (sX :: Sing x)) - = case SJust (sX :: Sing x) of { - (_ :: Sing ('Just x :: Maybe a)) -> sX :: Sing (x :: a) } - sG (sX :: Sing x) - = let - sScrutinee_0123456789876543210 :: - Sing (Let0123456789876543210Scrutinee_0123456789876543210Sym1 x) - sScrutinee_0123456789876543210 - = (applySing ((singFun1 @JustSym0) SJust)) sX - in - (id - @(Sing (Case_0123456789876543210 x (Let0123456789876543210Scrutinee_0123456789876543210Sym1 x)))) - (case sScrutinee_0123456789876543210 of { - SJust (sY :: Sing y) - -> case SJust (sY :: Sing y) of { - (_ :: Sing ('Just y :: Maybe Bool)) -> sY :: Sing (y :: Bool) } }) - sF3 (SJust (sA :: Sing a)) - = case SJust (sA :: Sing a) of { - (_ :: Sing ('Just a :: Maybe Bool)) -> sing :: Sing "hi" } - sF2 (sX :: Sing x) - = case sX :: Sing x of { - (_ :: Sing (x :: Maybe a)) -> sX :: Sing (x :: Maybe a) } - sF1 (sX :: Sing x) - = case sX :: Sing x of { - (_ :: Sing (x :: Maybe Bool)) -> sX :: Sing (x :: Maybe Bool) } - instance SingI (Foo9Sym0 :: (~>) a a) where - sing = (singFun1 @Foo9Sym0) sFoo9 - instance SingI (Foo8Sym0 :: (~>) (Maybe a) (Maybe a)) where - sing = (singFun1 @Foo8Sym0) sFoo8 - instance SingI (Foo7Sym0 :: (~>) a ((~>) b a)) where - sing = (singFun2 @Foo7Sym0) sFoo7 - instance SingI d => SingI (Foo7Sym1 (d :: a) :: (~>) b a) where - sing = (singFun1 @(Foo7Sym1 (d :: a))) (sFoo7 (sing @d)) - instance SingI (Foo6Sym0 :: (~>) (Maybe (Maybe a)) (Maybe (Maybe a))) where - sing = (singFun1 @Foo6Sym0) sFoo6 - instance SingI (Foo5Sym0 :: (~>) (Maybe (Maybe a)) (Maybe (Maybe a))) where - sing = (singFun1 @Foo5Sym0) sFoo5 - instance SingI (Foo4Sym0 :: (~>) (a, b) (b, a)) where - sing = (singFun1 @Foo4Sym0) sFoo4 - instance SingI (Foo3Sym0 :: (~>) (Maybe a) a) where - sing = (singFun1 @Foo3Sym0) sFoo3 - instance SingI (Foo2Sym0 :: (~>) (Maybe a) a) where - sing = (singFun1 @Foo2Sym0) sFoo2 - instance SingI (Foo1Sym0 :: (~>) (Maybe a) a) where - sing = (singFun1 @Foo1Sym0) sFoo1 - instance SingI GSym0 where - sing = (singFun1 @GSym0) sG - instance SingI F3Sym0 where - sing = (singFun1 @F3Sym0) sF3 - instance SingI F2Sym0 where - sing = (singFun1 @F2Sym0) sF2 - instance SingI F1Sym0 where - sing = (singFun1 @F1Sym0) sF1 diff --git a/tests/compile-and-dump/Singletons/T183.hs b/tests/compile-and-dump/Singletons/T183.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T183.hs +++ /dev/null @@ -1,65 +0,0 @@ -module T183 where - -import Data.Singletons.Prelude -import Data.Singletons.TH - -$(singletons [d| - ----- - -- Examples from #183 - ----- - - f1 (x :: Maybe Bool) = (x :: Maybe Bool) - f2 (x :: Maybe a) = (x :: Maybe a) - f3 (Just a :: Maybe Bool) = "hi" - - g x = case Just x of - (Just y :: Maybe Bool) -> (y :: Bool) - - ----- - -- Using explicit type signatures - ----- - - -- No explicit forall - foo1 :: Maybe a -> a - foo1 (Just x :: Maybe a) = (x :: a) - - -- Explicit forall - foo2, foo3 :: forall a. Maybe a -> a - foo2 (Just x :: Maybe a) = (x :: a) - foo3 (Just x) = (x :: a) - - ----- - -- Multiple pattern signatures - ----- - - foo4 :: (a, b) -> (b, a) - foo4 = \(x :: a, y :: b) -> (y :: b, x :: a) - - foo5, foo6 :: Maybe (Maybe a) -> Maybe (Maybe a) - foo5 (Just (Just (x :: a) :: Maybe a) :: Maybe (Maybe a)) - = Just (Just (x :: a) :: Maybe a) :: Maybe (Maybe a) - foo6 (Just x :: Maybe (Maybe a)) - = case x :: Maybe a of - (Just (y :: a) :: Maybe a) -> Just (Just (y :: a) :: Maybe a) - - ----- - -- Other pattern features - ----- - - foo7 :: a -> b -> a - foo7 (x :: a) (_ :: b) = (x :: a) - - foo8 :: forall a. Maybe a -> Maybe a - foo8 x@(Just (_ :: a) :: Maybe a) = x - -- foo8 x@(Nothing :: Maybe a) = x -- #296 - - ----- - -- Type variable scoping (vis-à-vis #297) - ----- - - foo9 :: a -> a - foo9 (x :: a) - = let g :: a -> b -> a - g y _ = y - in g x () - |]) diff --git a/tests/compile-and-dump/Singletons/T184.ghc88.template b/tests/compile-and-dump/Singletons/T184.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T184.ghc88.template +++ /dev/null @@ -1,500 +0,0 @@ -Singletons/T184.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| boogie :: Maybe a -> Maybe Bool -> Maybe a - boogie ma mb - = do a <- ma - b <- mb - guard b - return a - zip' :: [a] -> [b] -> [(a, b)] - zip' xs ys = [(x, y) | x <- xs | y <- ys] - cartProd :: [a] -> [b] -> [(a, b)] - cartProd xs ys = [(x, y) | x <- xs, y <- ys] - trues :: [Bool] -> [Bool] - trues xs = [x | x <- xs, x] |] - ======> - boogie :: Maybe a -> Maybe Bool -> Maybe a - boogie ma mb - = do a <- ma - b <- mb - guard b - return a - zip' :: [a] -> [b] -> [(a, b)] - zip' xs ys = [(x, y) | x <- xs | y <- ys] - cartProd :: [a] -> [b] -> [(a, b)] - cartProd xs ys = [(x, y) | x <- xs, y <- ys] - trues :: [Bool] -> [Bool] - trues xs = [x | x <- xs, x] - type family Lambda_0123456789876543210 xs t where - Lambda_0123456789876543210 xs x = Apply (Apply (>>@#@$) (Apply GuardSym0 x)) (Apply ReturnSym0 x) - type Lambda_0123456789876543210Sym2 xs0123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 xs0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 xs0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 xs0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall xs0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 xs0123456789876543210) arg) (Lambda_0123456789876543210Sym2 xs0123456789876543210 arg) => - Lambda_0123456789876543210Sym1 xs0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 xs0123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 xs0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 xs0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall xs0123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 xs0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 xs0123456789876543210 = Lambda_0123456789876543210Sym1 xs0123456789876543210 - type family Lambda_0123456789876543210 x xs ys t where - Lambda_0123456789876543210 x xs ys y = Apply ReturnSym0 (Apply (Apply Tuple2Sym0 x) y) - type Lambda_0123456789876543210Sym4 x0123456789876543210 xs0123456789876543210 ys0123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 x0123456789876543210 xs0123456789876543210 ys0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym3 ys0123456789876543210 xs0123456789876543210 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym3KindInference) ()) - data Lambda_0123456789876543210Sym3 x0123456789876543210 xs0123456789876543210 ys0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym3KindInference :: forall x0123456789876543210 - xs0123456789876543210 - ys0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym3 x0123456789876543210 xs0123456789876543210 ys0123456789876543210) arg) (Lambda_0123456789876543210Sym4 x0123456789876543210 xs0123456789876543210 ys0123456789876543210 arg) => - Lambda_0123456789876543210Sym3 x0123456789876543210 xs0123456789876543210 ys0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym3 ys0123456789876543210 xs0123456789876543210 x0123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 ys0123456789876543210 xs0123456789876543210 x0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 xs0123456789876543210 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 x0123456789876543210 xs0123456789876543210 ys0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall x0123456789876543210 - xs0123456789876543210 - ys0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 x0123456789876543210 xs0123456789876543210) arg) (Lambda_0123456789876543210Sym3 x0123456789876543210 xs0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 x0123456789876543210 xs0123456789876543210 ys0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 xs0123456789876543210 x0123456789876543210) ys0123456789876543210 = Lambda_0123456789876543210Sym3 xs0123456789876543210 x0123456789876543210 ys0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 x0123456789876543210 xs0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall x0123456789876543210 - xs0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 x0123456789876543210) arg) (Lambda_0123456789876543210Sym2 x0123456789876543210 arg) => - Lambda_0123456789876543210Sym1 x0123456789876543210 xs0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 x0123456789876543210) xs0123456789876543210 = Lambda_0123456789876543210Sym2 x0123456789876543210 xs0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 x0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall x0123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 x0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 x0123456789876543210 = Lambda_0123456789876543210Sym1 x0123456789876543210 - type family Lambda_0123456789876543210 xs ys t where - Lambda_0123456789876543210 xs ys x = Apply (Apply (>>=@#@$) ys) (Apply (Apply (Apply Lambda_0123456789876543210Sym0 x) xs) ys) - type Lambda_0123456789876543210Sym3 xs0123456789876543210 ys0123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 xs0123456789876543210 ys0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 ys0123456789876543210 xs0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall xs0123456789876543210 - ys0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210) arg) (Lambda_0123456789876543210Sym3 xs0123456789876543210 ys0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 ys0123456789876543210 xs0123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 ys0123456789876543210 xs0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 xs0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 xs0123456789876543210 ys0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall xs0123456789876543210 - ys0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 xs0123456789876543210) arg) (Lambda_0123456789876543210Sym2 xs0123456789876543210 arg) => - Lambda_0123456789876543210Sym1 xs0123456789876543210 ys0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 xs0123456789876543210) ys0123456789876543210 = Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 xs0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall xs0123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 xs0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 xs0123456789876543210 = Lambda_0123456789876543210Sym1 xs0123456789876543210 - type family Lambda_0123456789876543210 xs ys t where - Lambda_0123456789876543210 xs ys x = Apply ReturnSym0 x - type Lambda_0123456789876543210Sym3 xs0123456789876543210 ys0123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 xs0123456789876543210 ys0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 ys0123456789876543210 xs0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall xs0123456789876543210 - ys0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210) arg) (Lambda_0123456789876543210Sym3 xs0123456789876543210 ys0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 ys0123456789876543210 xs0123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 ys0123456789876543210 xs0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 xs0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 xs0123456789876543210 ys0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall xs0123456789876543210 - ys0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 xs0123456789876543210) arg) (Lambda_0123456789876543210Sym2 xs0123456789876543210 arg) => - Lambda_0123456789876543210Sym1 xs0123456789876543210 ys0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 xs0123456789876543210) ys0123456789876543210 = Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 xs0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall xs0123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 xs0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 xs0123456789876543210 = Lambda_0123456789876543210Sym1 xs0123456789876543210 - type family Lambda_0123456789876543210 xs ys t where - Lambda_0123456789876543210 xs ys y = Apply ReturnSym0 y - type Lambda_0123456789876543210Sym3 xs0123456789876543210 ys0123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 xs0123456789876543210 ys0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 ys0123456789876543210 xs0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall xs0123456789876543210 - ys0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210) arg) (Lambda_0123456789876543210Sym3 xs0123456789876543210 ys0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 ys0123456789876543210 xs0123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 ys0123456789876543210 xs0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 xs0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 xs0123456789876543210 ys0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall xs0123456789876543210 - ys0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 xs0123456789876543210) arg) (Lambda_0123456789876543210Sym2 xs0123456789876543210 arg) => - Lambda_0123456789876543210Sym1 xs0123456789876543210 ys0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 xs0123456789876543210) ys0123456789876543210 = Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 xs0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall xs0123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 xs0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 xs0123456789876543210 = Lambda_0123456789876543210Sym1 xs0123456789876543210 - type family Case_0123456789876543210 arg_0123456789876543210 xs ys t where - Case_0123456789876543210 arg_0123456789876543210 xs ys '(x, - y) = Apply ReturnSym0 (Apply (Apply Tuple2Sym0 x) y) - type family Lambda_0123456789876543210 xs ys t where - Lambda_0123456789876543210 xs ys arg_0123456789876543210 = Case_0123456789876543210 arg_0123456789876543210 xs ys arg_0123456789876543210 - type Lambda_0123456789876543210Sym3 xs0123456789876543210 ys0123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 xs0123456789876543210 ys0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 ys0123456789876543210 xs0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall xs0123456789876543210 - ys0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210) arg) (Lambda_0123456789876543210Sym3 xs0123456789876543210 ys0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 ys0123456789876543210 xs0123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 ys0123456789876543210 xs0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 xs0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 xs0123456789876543210 ys0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall xs0123456789876543210 - ys0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 xs0123456789876543210) arg) (Lambda_0123456789876543210Sym2 xs0123456789876543210 arg) => - Lambda_0123456789876543210Sym1 xs0123456789876543210 ys0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 xs0123456789876543210) ys0123456789876543210 = Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 xs0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall xs0123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 xs0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 xs0123456789876543210 = Lambda_0123456789876543210Sym1 xs0123456789876543210 - type family Lambda_0123456789876543210 a ma mb t where - Lambda_0123456789876543210 a ma mb b = Apply (Apply (>>@#@$) (Apply GuardSym0 b)) (Apply ReturnSym0 a) - type Lambda_0123456789876543210Sym4 a0123456789876543210 ma0123456789876543210 mb0123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 a0123456789876543210 ma0123456789876543210 mb0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym3 mb0123456789876543210 ma0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym3KindInference) ()) - data Lambda_0123456789876543210Sym3 a0123456789876543210 ma0123456789876543210 mb0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym3KindInference :: forall a0123456789876543210 - ma0123456789876543210 - mb0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym3 a0123456789876543210 ma0123456789876543210 mb0123456789876543210) arg) (Lambda_0123456789876543210Sym4 a0123456789876543210 ma0123456789876543210 mb0123456789876543210 arg) => - Lambda_0123456789876543210Sym3 a0123456789876543210 ma0123456789876543210 mb0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym3 mb0123456789876543210 ma0123456789876543210 a0123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 mb0123456789876543210 ma0123456789876543210 a0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 ma0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 a0123456789876543210 ma0123456789876543210 mb0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall a0123456789876543210 - ma0123456789876543210 - mb0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 a0123456789876543210 ma0123456789876543210) arg) (Lambda_0123456789876543210Sym3 a0123456789876543210 ma0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 a0123456789876543210 ma0123456789876543210 mb0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 ma0123456789876543210 a0123456789876543210) mb0123456789876543210 = Lambda_0123456789876543210Sym3 ma0123456789876543210 a0123456789876543210 mb0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 a0123456789876543210 ma0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - ma0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 a0123456789876543210) arg) (Lambda_0123456789876543210Sym2 a0123456789876543210 arg) => - Lambda_0123456789876543210Sym1 a0123456789876543210 ma0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 a0123456789876543210) ma0123456789876543210 = Lambda_0123456789876543210Sym2 a0123456789876543210 ma0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 a0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 a0123456789876543210 = Lambda_0123456789876543210Sym1 a0123456789876543210 - type family Lambda_0123456789876543210 ma mb t where - Lambda_0123456789876543210 ma mb a = Apply (Apply (>>=@#@$) mb) (Apply (Apply (Apply Lambda_0123456789876543210Sym0 a) ma) mb) - type Lambda_0123456789876543210Sym3 ma0123456789876543210 mb0123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 ma0123456789876543210 mb0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 mb0123456789876543210 ma0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 ma0123456789876543210 mb0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall ma0123456789876543210 - mb0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 ma0123456789876543210 mb0123456789876543210) arg) (Lambda_0123456789876543210Sym3 ma0123456789876543210 mb0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 ma0123456789876543210 mb0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 mb0123456789876543210 ma0123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 mb0123456789876543210 ma0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 ma0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 ma0123456789876543210 mb0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall ma0123456789876543210 - mb0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 ma0123456789876543210) arg) (Lambda_0123456789876543210Sym2 ma0123456789876543210 arg) => - Lambda_0123456789876543210Sym1 ma0123456789876543210 mb0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 ma0123456789876543210) mb0123456789876543210 = Lambda_0123456789876543210Sym2 ma0123456789876543210 mb0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 ma0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall ma0123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 ma0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 ma0123456789876543210 = Lambda_0123456789876543210Sym1 ma0123456789876543210 - type TruesSym1 (a0123456789876543210 :: [Bool]) = - Trues a0123456789876543210 - instance SuppressUnusedWarnings TruesSym0 where - suppressUnusedWarnings = snd (((,) TruesSym0KindInference) ()) - data TruesSym0 :: (~>) [Bool] [Bool] - where - TruesSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply TruesSym0 arg) (TruesSym1 arg) => - TruesSym0 a0123456789876543210 - type instance Apply TruesSym0 a0123456789876543210 = Trues a0123456789876543210 - type CartProdSym2 (a0123456789876543210 :: [a0123456789876543210]) (a0123456789876543210 :: [b0123456789876543210]) = - CartProd a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (CartProdSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) CartProdSym1KindInference) ()) - data CartProdSym1 (a0123456789876543210 :: [a0123456789876543210]) :: forall b0123456789876543210. - (~>) [b0123456789876543210] [(a0123456789876543210, - b0123456789876543210)] - where - CartProdSym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (CartProdSym1 a0123456789876543210) arg) (CartProdSym2 a0123456789876543210 arg) => - CartProdSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (CartProdSym1 a0123456789876543210) a0123456789876543210 = CartProd a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings CartProdSym0 where - suppressUnusedWarnings = snd (((,) CartProdSym0KindInference) ()) - data CartProdSym0 :: forall a0123456789876543210 - b0123456789876543210. - (~>) [a0123456789876543210] ((~>) [b0123456789876543210] [(a0123456789876543210, - b0123456789876543210)]) - where - CartProdSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply CartProdSym0 arg) (CartProdSym1 arg) => - CartProdSym0 a0123456789876543210 - type instance Apply CartProdSym0 a0123456789876543210 = CartProdSym1 a0123456789876543210 - type Zip'Sym2 (a0123456789876543210 :: [a0123456789876543210]) (a0123456789876543210 :: [b0123456789876543210]) = - Zip' a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Zip'Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) Zip'Sym1KindInference) ()) - data Zip'Sym1 (a0123456789876543210 :: [a0123456789876543210]) :: forall b0123456789876543210. - (~>) [b0123456789876543210] [(a0123456789876543210, - b0123456789876543210)] - where - Zip'Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Zip'Sym1 a0123456789876543210) arg) (Zip'Sym2 a0123456789876543210 arg) => - Zip'Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Zip'Sym1 a0123456789876543210) a0123456789876543210 = Zip' a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Zip'Sym0 where - suppressUnusedWarnings = snd (((,) Zip'Sym0KindInference) ()) - data Zip'Sym0 :: forall a0123456789876543210 b0123456789876543210. - (~>) [a0123456789876543210] ((~>) [b0123456789876543210] [(a0123456789876543210, - b0123456789876543210)]) - where - Zip'Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Zip'Sym0 arg) (Zip'Sym1 arg) => - Zip'Sym0 a0123456789876543210 - type instance Apply Zip'Sym0 a0123456789876543210 = Zip'Sym1 a0123456789876543210 - type BoogieSym2 (a0123456789876543210 :: Maybe a0123456789876543210) (a0123456789876543210 :: Maybe Bool) = - Boogie a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (BoogieSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) BoogieSym1KindInference) ()) - data BoogieSym1 (a0123456789876543210 :: Maybe a0123456789876543210) :: (~>) (Maybe Bool) (Maybe a0123456789876543210) - where - BoogieSym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (BoogieSym1 a0123456789876543210) arg) (BoogieSym2 a0123456789876543210 arg) => - BoogieSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (BoogieSym1 a0123456789876543210) a0123456789876543210 = Boogie a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings BoogieSym0 where - suppressUnusedWarnings = snd (((,) BoogieSym0KindInference) ()) - data BoogieSym0 :: forall a0123456789876543210. - (~>) (Maybe a0123456789876543210) ((~>) (Maybe Bool) (Maybe a0123456789876543210)) - where - BoogieSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply BoogieSym0 arg) (BoogieSym1 arg) => - BoogieSym0 a0123456789876543210 - type instance Apply BoogieSym0 a0123456789876543210 = BoogieSym1 a0123456789876543210 - type family Trues (a :: [Bool]) :: [Bool] where - Trues xs = Apply (Apply (>>=@#@$) xs) (Apply Lambda_0123456789876543210Sym0 xs) - type family CartProd (a :: [a]) (a :: [b]) :: [(a, b)] where - CartProd xs ys = Apply (Apply (>>=@#@$) xs) (Apply (Apply Lambda_0123456789876543210Sym0 xs) ys) - type family Zip' (a :: [a]) (a :: [b]) :: [(a, b)] where - Zip' xs ys = Apply (Apply (>>=@#@$) (Apply (Apply MzipSym0 (Apply (Apply (>>=@#@$) xs) (Apply (Apply Lambda_0123456789876543210Sym0 xs) ys))) (Apply (Apply (>>=@#@$) ys) (Apply (Apply Lambda_0123456789876543210Sym0 xs) ys)))) (Apply (Apply Lambda_0123456789876543210Sym0 xs) ys) - type family Boogie (a :: Maybe a) (a :: Maybe Bool) :: Maybe a where - Boogie ma mb = Apply (Apply (>>=@#@$) ma) (Apply (Apply Lambda_0123456789876543210Sym0 ma) mb) - sTrues :: - forall (t :: [Bool]). Sing t -> Sing (Apply TruesSym0 t :: [Bool]) - sCartProd :: - forall a b (t :: [a]) (t :: [b]). - Sing t - -> Sing t -> Sing (Apply (Apply CartProdSym0 t) t :: [(a, b)]) - sZip' :: - forall a b (t :: [a]) (t :: [b]). - Sing t -> Sing t -> Sing (Apply (Apply Zip'Sym0 t) t :: [(a, b)]) - sBoogie :: - forall a (t :: Maybe a) (t :: Maybe Bool). - Sing t -> Sing t -> Sing (Apply (Apply BoogieSym0 t) t :: Maybe a) - sTrues (sXs :: Sing xs) - = (applySing ((applySing ((singFun2 @(>>=@#@$)) (%>>=))) sXs)) - ((singFun1 @(Apply Lambda_0123456789876543210Sym0 xs)) - (\ sX - -> case sX of { - (_ :: Sing x) - -> (applySing - ((applySing ((singFun2 @(>>@#@$)) (%>>))) - ((applySing ((singFun1 @GuardSym0) sGuard)) sX))) - ((applySing ((singFun1 @ReturnSym0) sReturn)) sX) })) - sCartProd (sXs :: Sing xs) (sYs :: Sing ys) - = (applySing ((applySing ((singFun2 @(>>=@#@$)) (%>>=))) sXs)) - ((singFun1 @(Apply (Apply Lambda_0123456789876543210Sym0 xs) ys)) - (\ sX - -> case sX of { - (_ :: Sing x) - -> (applySing ((applySing ((singFun2 @(>>=@#@$)) (%>>=))) sYs)) - ((singFun1 - @(Apply (Apply (Apply Lambda_0123456789876543210Sym0 x) xs) ys)) - (\ sY - -> case sY of { - (_ :: Sing y) - -> (applySing ((singFun1 @ReturnSym0) sReturn)) - ((applySing - ((applySing ((singFun2 @Tuple2Sym0) STuple2)) sX)) - sY) })) })) - sZip' (sXs :: Sing xs) (sYs :: Sing ys) - = (applySing - ((applySing ((singFun2 @(>>=@#@$)) (%>>=))) - ((applySing - ((applySing ((singFun2 @MzipSym0) sMzip)) - ((applySing ((applySing ((singFun2 @(>>=@#@$)) (%>>=))) sXs)) - ((singFun1 @(Apply (Apply Lambda_0123456789876543210Sym0 xs) ys)) - (\ sX - -> case sX of { - (_ :: Sing x) - -> (applySing ((singFun1 @ReturnSym0) sReturn)) sX }))))) - ((applySing ((applySing ((singFun2 @(>>=@#@$)) (%>>=))) sYs)) - ((singFun1 @(Apply (Apply Lambda_0123456789876543210Sym0 xs) ys)) - (\ sY - -> case sY of { - (_ :: Sing y) - -> (applySing ((singFun1 @ReturnSym0) sReturn)) sY })))))) - ((singFun1 @(Apply (Apply Lambda_0123456789876543210Sym0 xs) ys)) - (\ sArg_0123456789876543210 - -> case sArg_0123456789876543210 of { - (_ :: Sing arg_0123456789876543210) - -> (id - @(Sing (Case_0123456789876543210 arg_0123456789876543210 xs ys arg_0123456789876543210))) - (case sArg_0123456789876543210 of { - STuple2 (sX :: Sing x) (sY :: Sing y) - -> (applySing ((singFun1 @ReturnSym0) sReturn)) - ((applySing ((applySing ((singFun2 @Tuple2Sym0) STuple2)) sX)) - sY) }) })) - sBoogie (sMa :: Sing ma) (sMb :: Sing mb) - = (applySing ((applySing ((singFun2 @(>>=@#@$)) (%>>=))) sMa)) - ((singFun1 @(Apply (Apply Lambda_0123456789876543210Sym0 ma) mb)) - (\ sA - -> case sA of { - (_ :: Sing a) - -> (applySing ((applySing ((singFun2 @(>>=@#@$)) (%>>=))) sMb)) - ((singFun1 - @(Apply (Apply (Apply Lambda_0123456789876543210Sym0 a) ma) mb)) - (\ sB - -> case sB of { - (_ :: Sing b) - -> (applySing - ((applySing ((singFun2 @(>>@#@$)) (%>>))) - ((applySing ((singFun1 @GuardSym0) sGuard)) sB))) - ((applySing ((singFun1 @ReturnSym0) sReturn)) - sA) })) })) - instance SingI (TruesSym0 :: (~>) [Bool] [Bool]) where - sing = (singFun1 @TruesSym0) sTrues - instance SingI (CartProdSym0 :: (~>) [a] ((~>) [b] [(a, b)])) where - sing = (singFun2 @CartProdSym0) sCartProd - instance SingI d => - SingI (CartProdSym1 (d :: [a]) :: (~>) [b] [(a, b)]) where - sing = (singFun1 @(CartProdSym1 (d :: [a]))) (sCartProd (sing @d)) - instance SingI (Zip'Sym0 :: (~>) [a] ((~>) [b] [(a, b)])) where - sing = (singFun2 @Zip'Sym0) sZip' - instance SingI d => - SingI (Zip'Sym1 (d :: [a]) :: (~>) [b] [(a, b)]) where - sing = (singFun1 @(Zip'Sym1 (d :: [a]))) (sZip' (sing @d)) - instance SingI (BoogieSym0 :: (~>) (Maybe a) ((~>) (Maybe Bool) (Maybe a))) where - sing = (singFun2 @BoogieSym0) sBoogie - instance SingI d => - SingI (BoogieSym1 (d :: Maybe a) :: (~>) (Maybe Bool) (Maybe a)) where - sing = (singFun1 @(BoogieSym1 (d :: Maybe a))) (sBoogie (sing @d)) diff --git a/tests/compile-and-dump/Singletons/T184.hs b/tests/compile-and-dump/Singletons/T184.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T184.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE ParallelListComp #-} -module T184 where - -import Control.Monad -import Data.Singletons.Prelude -import Data.Singletons.Prelude.Monad -import Data.Singletons.Prelude.Monad.Zip -import Data.Singletons.TH - -$(singletons [d| - boogie :: Maybe a -> Maybe Bool -> Maybe a - boogie ma mb = do - a <- ma - b <- mb - guard b - return a - - zip' :: [a] -> [b] -> [(a, b)] - zip' xs ys = [(x, y) | x <- xs | y <- ys] - - cartProd :: [a] -> [b] -> [(a, b)] - cartProd xs ys = [(x, y) | x <- xs, y <- ys] - - trues :: [Bool] -> [Bool] - trues xs = [x | x <- xs, x] - |]) diff --git a/tests/compile-and-dump/Singletons/T187.ghc88.template b/tests/compile-and-dump/Singletons/T187.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T187.ghc88.template +++ /dev/null @@ -1,65 +0,0 @@ -Singletons/T187.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| data Empty - - deriving instance Ord Empty - deriving instance Eq Empty |] - ======> - data Empty - deriving instance Eq Empty - deriving instance Ord Empty - type family Compare_0123456789876543210 (a :: Empty) (a :: Empty) :: Ordering where - Compare_0123456789876543210 _ _ = EQSym0 - type Compare_0123456789876543210Sym2 (a0123456789876543210 :: Empty) (a0123456789876543210 :: Empty) = - Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Compare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym1KindInference) ()) - data Compare_0123456789876543210Sym1 (a0123456789876543210 :: Empty) :: (~>) Empty Ordering - where - Compare_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Compare_0123456789876543210Sym1 a0123456789876543210) arg) (Compare_0123456789876543210Sym2 a0123456789876543210 arg) => - Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Compare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Compare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym0KindInference) ()) - data Compare_0123456789876543210Sym0 :: (~>) Empty ((~>) Empty Ordering) - where - Compare_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Compare_0123456789876543210Sym0 arg) (Compare_0123456789876543210Sym1 arg) => - Compare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Compare_0123456789876543210Sym0 a0123456789876543210 = Compare_0123456789876543210Sym1 a0123456789876543210 - instance POrd Empty where - type Compare a a = Apply (Apply Compare_0123456789876543210Sym0 a) a - type family Equals_0123456789876543210 (a :: Empty) (b :: Empty) :: Bool where - Equals_0123456789876543210 (_ :: Empty) (_ :: Empty) = TrueSym0 - instance PEq Empty where - type (==) a b = Equals_0123456789876543210 a b - data SEmpty :: Empty -> GHC.Types.Type - type instance Sing @Empty = SEmpty - instance SingKind Empty where - type Demote Empty = Empty - fromSing x = case x of - toSing x = SomeSing (case x of) - instance SOrd Empty where - sCompare :: - forall (t1 :: Empty) (t2 :: Empty). - Sing t1 - -> Sing t2 - -> Sing (Apply (Apply (CompareSym0 :: TyFun Empty ((~>) Empty Ordering) - -> GHC.Types.Type) t1) t2) - sCompare _ _ = SEQ - instance SEq Empty where - (%==) _ _ = STrue - instance SDecide Empty where - (%~) x _ = Proved (case x of) - instance Data.Type.Equality.TestEquality (SEmpty :: Empty - -> GHC.Types.Type) where - Data.Type.Equality.testEquality - = Data.Singletons.Decide.decideEquality - instance Data.Type.Coercion.TestCoercion (SEmpty :: Empty - -> GHC.Types.Type) where - Data.Type.Coercion.testCoercion - = Data.Singletons.Decide.decideCoercion diff --git a/tests/compile-and-dump/Singletons/T187.hs b/tests/compile-and-dump/Singletons/T187.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T187.hs +++ /dev/null @@ -1,8 +0,0 @@ -module T187 where - -import Data.Singletons.TH - -$(singletons[d| data Empty - deriving instance Eq Empty - deriving instance Ord Empty - |]) diff --git a/tests/compile-and-dump/Singletons/T190.ghc88.template b/tests/compile-and-dump/Singletons/T190.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T190.ghc88.template +++ /dev/null @@ -1,198 +0,0 @@ -Singletons/T190.hs:0:0:: Splicing declarations - singletons - [d| data T - = T - deriving (Eq, Ord, Enum, Bounded, Show) |] - ======> - data T - = T - deriving (Eq, Ord, Enum, Bounded, Show) - type TSym0 = T - type family Compare_0123456789876543210 (a :: T) (a :: T) :: Ordering where - Compare_0123456789876543210 T T = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) '[] - type Compare_0123456789876543210Sym2 (a0123456789876543210 :: T) (a0123456789876543210 :: T) = - Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Compare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym1KindInference) ()) - data Compare_0123456789876543210Sym1 (a0123456789876543210 :: T) :: (~>) T Ordering - where - Compare_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Compare_0123456789876543210Sym1 a0123456789876543210) arg) (Compare_0123456789876543210Sym2 a0123456789876543210 arg) => - Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Compare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Compare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym0KindInference) ()) - data Compare_0123456789876543210Sym0 :: (~>) T ((~>) T Ordering) - where - Compare_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Compare_0123456789876543210Sym0 arg) (Compare_0123456789876543210Sym1 arg) => - Compare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Compare_0123456789876543210Sym0 a0123456789876543210 = Compare_0123456789876543210Sym1 a0123456789876543210 - instance POrd T where - type Compare a a = Apply (Apply Compare_0123456789876543210Sym0 a) a - type family Case_0123456789876543210 n t where - Case_0123456789876543210 n 'True = TSym0 - Case_0123456789876543210 n 'False = Apply ErrorSym0 "toEnum: bad argument" - type family ToEnum_0123456789876543210 (a :: GHC.Types.Nat) :: T where - ToEnum_0123456789876543210 n = Case_0123456789876543210 n (Apply (Apply (==@#@$) n) (Data.Singletons.Prelude.Num.FromInteger 0)) - type ToEnum_0123456789876543210Sym1 (a0123456789876543210 :: GHC.Types.Nat) = - ToEnum_0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ToEnum_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ToEnum_0123456789876543210Sym0KindInference) ()) - data ToEnum_0123456789876543210Sym0 :: (~>) GHC.Types.Nat T - where - ToEnum_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply ToEnum_0123456789876543210Sym0 arg) (ToEnum_0123456789876543210Sym1 arg) => - ToEnum_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ToEnum_0123456789876543210Sym0 a0123456789876543210 = ToEnum_0123456789876543210 a0123456789876543210 - type family FromEnum_0123456789876543210 (a :: T) :: GHC.Types.Nat where - FromEnum_0123456789876543210 T = Data.Singletons.Prelude.Num.FromInteger 0 - type FromEnum_0123456789876543210Sym1 (a0123456789876543210 :: T) = - FromEnum_0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings FromEnum_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) FromEnum_0123456789876543210Sym0KindInference) ()) - data FromEnum_0123456789876543210Sym0 :: (~>) T GHC.Types.Nat - where - FromEnum_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply FromEnum_0123456789876543210Sym0 arg) (FromEnum_0123456789876543210Sym1 arg) => - FromEnum_0123456789876543210Sym0 a0123456789876543210 - type instance Apply FromEnum_0123456789876543210Sym0 a0123456789876543210 = FromEnum_0123456789876543210 a0123456789876543210 - instance PEnum T where - type ToEnum a = Apply ToEnum_0123456789876543210Sym0 a - type FromEnum a = Apply FromEnum_0123456789876543210Sym0 a - type family MinBound_0123456789876543210 :: T where - MinBound_0123456789876543210 = TSym0 - type MinBound_0123456789876543210Sym0 = - MinBound_0123456789876543210 - type family MaxBound_0123456789876543210 :: T where - MaxBound_0123456789876543210 = TSym0 - type MaxBound_0123456789876543210Sym0 = - MaxBound_0123456789876543210 - instance PBounded T where - type MinBound = MinBound_0123456789876543210Sym0 - type MaxBound = MaxBound_0123456789876543210Sym0 - type family ShowsPrec_0123456789876543210 (a :: GHC.Types.Nat) (a :: T) (a :: GHC.Types.Symbol) :: GHC.Types.Symbol where - ShowsPrec_0123456789876543210 _ T a_0123456789876543210 = Apply (Apply ShowStringSym0 "T") a_0123456789876543210 - type ShowsPrec_0123456789876543210Sym3 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: T) (a0123456789876543210 :: GHC.Types.Symbol) = - ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym2KindInference) ()) - data ShowsPrec_0123456789876543210Sym2 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: T) :: (~>) GHC.Types.Symbol GHC.Types.Symbol - where - ShowsPrec_0123456789876543210Sym2KindInference :: forall a0123456789876543210 - a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) arg) (ShowsPrec_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 arg) => - ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym1KindInference) ()) - data ShowsPrec_0123456789876543210Sym1 (a0123456789876543210 :: GHC.Types.Nat) :: (~>) T ((~>) GHC.Types.Symbol GHC.Types.Symbol) - where - ShowsPrec_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) arg) (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 arg) => - ShowsPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ShowsPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym0KindInference) ()) - data ShowsPrec_0123456789876543210Sym0 :: (~>) GHC.Types.Nat ((~>) T ((~>) GHC.Types.Symbol GHC.Types.Symbol)) - where - ShowsPrec_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply ShowsPrec_0123456789876543210Sym0 arg) (ShowsPrec_0123456789876543210Sym1 arg) => - ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ShowsPrec_0123456789876543210Sym0 a0123456789876543210 = ShowsPrec_0123456789876543210Sym1 a0123456789876543210 - instance PShow T where - type ShowsPrec a a a = Apply (Apply (Apply ShowsPrec_0123456789876543210Sym0 a) a) a - type family Equals_0123456789876543210 (a :: T) (b :: T) :: Bool where - Equals_0123456789876543210 T T = TrueSym0 - Equals_0123456789876543210 (_ :: T) (_ :: T) = FalseSym0 - instance PEq T where - type (==) a b = Equals_0123456789876543210 a b - data ST :: T -> GHC.Types.Type where ST :: ST T - type instance Sing @T = ST - instance SingKind T where - type Demote T = T - fromSing ST = T - toSing T = SomeSing ST - instance SOrd T where - sCompare :: - forall (t1 :: T) (t2 :: T). - Sing t1 - -> Sing t2 - -> Sing (Apply (Apply (CompareSym0 :: TyFun T ((~>) T Ordering) - -> GHC.Types.Type) t1) t2) - sCompare ST ST - = (applySing - ((applySing - ((applySing ((singFun3 @FoldlSym0) sFoldl)) - ((singFun2 @ThenCmpSym0) sThenCmp))) - SEQ)) - Data.Singletons.Prelude.Instances.SNil - instance SEnum T where - sToEnum :: - forall (t :: GHC.Types.Nat). - Sing t - -> Sing (Apply (Data.Singletons.Prelude.Enum.ToEnumSym0 :: TyFun GHC.Types.Nat T - -> GHC.Types.Type) t) - sFromEnum :: - forall (t :: T). - Sing t - -> Sing (Apply (Data.Singletons.Prelude.Enum.FromEnumSym0 :: TyFun T GHC.Types.Nat - -> GHC.Types.Type) t) - sToEnum (sN :: Sing n) - = (id - @(Sing (Case_0123456789876543210 n (Apply (Apply (==@#@$) n) (Data.Singletons.Prelude.Num.FromInteger 0))))) - (case - (applySing ((applySing ((singFun2 @(==@#@$)) (%==))) sN)) - (Data.Singletons.Prelude.Num.sFromInteger (sing :: Sing 0)) - of - STrue -> ST - SFalse -> sError (sing :: Sing "toEnum: bad argument")) - sFromEnum ST - = Data.Singletons.Prelude.Num.sFromInteger (sing :: Sing 0) - instance SBounded T where - sMinBound :: Sing (MinBoundSym0 :: T) - sMaxBound :: Sing (MaxBoundSym0 :: T) - sMinBound = ST - sMaxBound = ST - instance SShow T where - sShowsPrec :: - forall (t1 :: GHC.Types.Nat) (t2 :: T) (t3 :: GHC.Types.Symbol). - Sing t1 - -> Sing t2 - -> Sing t3 - -> Sing (Apply (Apply (Apply (ShowsPrecSym0 :: TyFun GHC.Types.Nat ((~>) T ((~>) GHC.Types.Symbol GHC.Types.Symbol)) - -> GHC.Types.Type) t1) t2) t3) - sShowsPrec - _ - ST - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "T"))) - sA_0123456789876543210 - instance SEq T where - (%==) ST ST = STrue - instance SDecide T where - (%~) ST ST = Proved Refl - instance Data.Type.Equality.TestEquality (ST :: T - -> GHC.Types.Type) where - Data.Type.Equality.testEquality - = Data.Singletons.Decide.decideEquality - instance Data.Type.Coercion.TestCoercion (ST :: T - -> GHC.Types.Type) where - Data.Type.Coercion.testCoercion - = Data.Singletons.Decide.decideCoercion - instance Show (ST (z :: T)) where - showsPrec _ ST = showString "ST" - instance SingI T where - sing = ST diff --git a/tests/compile-and-dump/Singletons/T190.hs b/tests/compile-and-dump/Singletons/T190.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T190.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -module T190 where - -import Data.Singletons.TH - -$(singletons [d| data T = T deriving (Eq, Ord, Enum, Bounded, Show) |]) diff --git a/tests/compile-and-dump/Singletons/T197.ghc88.template b/tests/compile-and-dump/Singletons/T197.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T197.ghc88.template +++ /dev/null @@ -1,43 +0,0 @@ -Singletons/T197.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| infixl 5 $$: - - ($$:) :: Bool -> Bool -> Bool - _ $$: _ = False |] - ======> - infixl 5 $$: - ($$:) :: Bool -> Bool -> Bool - ($$:) _ _ = False - type ($$:@#@$$$) (a0123456789876543210 :: Bool) (a0123456789876543210 :: Bool) = - ($$:) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (($$:@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (:$$:@#@$$###)) ()) - data ($$:@#@$$) (a0123456789876543210 :: Bool) :: (~>) Bool Bool - where - (:$$:@#@$$###) :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (($$:@#@$$) a0123456789876543210) arg) (($$:@#@$$$) a0123456789876543210 arg) => - ($$:@#@$$) a0123456789876543210 a0123456789876543210 - type instance Apply (($$:@#@$$) a0123456789876543210) a0123456789876543210 = ($$:) a0123456789876543210 a0123456789876543210 - infixl 5 $$:@#@$$ - instance SuppressUnusedWarnings ($$:@#@$) where - suppressUnusedWarnings = snd (((,) (:$$:@#@$###)) ()) - data ($$:@#@$) :: (~>) Bool ((~>) Bool Bool) - where - (:$$:@#@$###) :: forall a0123456789876543210 - arg. SameKind (Apply ($$:@#@$) arg) (($$:@#@$$) arg) => - ($$:@#@$) a0123456789876543210 - type instance Apply ($$:@#@$) a0123456789876543210 = ($$:@#@$$) a0123456789876543210 - infixl 5 $$:@#@$ - type family ($$:) (a :: Bool) (a :: Bool) :: Bool where - ($$:) _ _ = FalseSym0 - infixl 5 %$$: - (%$$:) :: - forall (t :: Bool) (t :: Bool). - Sing t -> Sing t -> Sing (Apply (Apply ($$:@#@$) t) t :: Bool) - (%$$:) _ _ = SFalse - instance SingI (($$:@#@$) :: (~>) Bool ((~>) Bool Bool)) where - sing = (singFun2 @($$:@#@$)) (%$$:) - instance SingI d => - SingI (($$:@#@$$) (d :: Bool) :: (~>) Bool Bool) where - sing = (singFun1 @(($$:@#@$$) (d :: Bool))) ((%$$:) (sing @d)) diff --git a/tests/compile-and-dump/Singletons/T197.hs b/tests/compile-and-dump/Singletons/T197.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T197.hs +++ /dev/null @@ -1,10 +0,0 @@ -module T197 where - -import Data.Singletons.Prelude -import Data.Singletons.TH - -$(singletons [d| - infixl 5 $$: - ($$:) :: Bool -> Bool -> Bool - _ $$: _ = False - |]) diff --git a/tests/compile-and-dump/Singletons/T197b.ghc88.template b/tests/compile-and-dump/Singletons/T197b.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T197b.ghc88.template +++ /dev/null @@ -1,96 +0,0 @@ -Singletons/T197b.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| infixr 9 `Pair`, `MkPair` - - data a :*: b = a :*: b - data Pair a b = MkPair a b |] - ======> - data (:*:) a b = a :*: b - data Pair a b = MkPair a b - infixr 9 `Pair` - infixr 9 `MkPair` - type (:*:@#@$$$) (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: b0123456789876543210) = - (:*:) t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings ((:*:@#@$$) t0123456789876543210) where - suppressUnusedWarnings = snd (((,) (::*:@#@$$###)) ()) - data (:*:@#@$$) (t0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210. - (~>) b0123456789876543210 ((:*:) a0123456789876543210 b0123456789876543210) - where - (::*:@#@$$###) :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply ((:*:@#@$$) t0123456789876543210) arg) ((:*:@#@$$$) t0123456789876543210 arg) => - (:*:@#@$$) t0123456789876543210 t0123456789876543210 - type instance Apply ((:*:@#@$$) t0123456789876543210) t0123456789876543210 = (:*:) t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (:*:@#@$) where - suppressUnusedWarnings = snd (((,) (::*:@#@$###)) ()) - data (:*:@#@$) :: forall a0123456789876543210 b0123456789876543210. - (~>) a0123456789876543210 ((~>) b0123456789876543210 ((:*:) a0123456789876543210 b0123456789876543210)) - where - (::*:@#@$###) :: forall t0123456789876543210 - arg. SameKind (Apply (:*:@#@$) arg) ((:*:@#@$$) arg) => - (:*:@#@$) t0123456789876543210 - type instance Apply (:*:@#@$) t0123456789876543210 = (:*:@#@$$) t0123456789876543210 - type MkPairSym2 (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: b0123456789876543210) = - MkPair t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (MkPairSym1 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) MkPairSym1KindInference) ()) - data MkPairSym1 (t0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210. - (~>) b0123456789876543210 (Pair a0123456789876543210 b0123456789876543210) - where - MkPairSym1KindInference :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (MkPairSym1 t0123456789876543210) arg) (MkPairSym2 t0123456789876543210 arg) => - MkPairSym1 t0123456789876543210 t0123456789876543210 - type instance Apply (MkPairSym1 t0123456789876543210) t0123456789876543210 = MkPair t0123456789876543210 t0123456789876543210 - infixr 9 `MkPairSym1` - instance SuppressUnusedWarnings MkPairSym0 where - suppressUnusedWarnings = snd (((,) MkPairSym0KindInference) ()) - data MkPairSym0 :: forall a0123456789876543210 - b0123456789876543210. - (~>) a0123456789876543210 ((~>) b0123456789876543210 (Pair a0123456789876543210 b0123456789876543210)) - where - MkPairSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply MkPairSym0 arg) (MkPairSym1 arg) => - MkPairSym0 t0123456789876543210 - type instance Apply MkPairSym0 t0123456789876543210 = MkPairSym1 t0123456789876543210 - infixr 9 `MkPairSym0` - infixr 9 `SMkPair` - infixr 9 `SPair` - data (%:*:) :: forall a b. (:*:) a b -> GHC.Types.Type - where - (:%*:) :: forall a b (n :: a) (n :: b). - (Sing (n :: a)) -> (Sing (n :: b)) -> (%:*:) ((:*:) n n) - type instance Sing @((:*:) a b) = (%:*:) - instance (SingKind a, SingKind b) => SingKind ((:*:) a b) where - type Demote ((:*:) a b) = (:*:) (Demote a) (Demote b) - fromSing ((:%*:) b b) = ((:*:) (fromSing b)) (fromSing b) - toSing ((:*:) (b :: Demote a) (b :: Demote b)) - = case ((,) (toSing b :: SomeSing a)) (toSing b :: SomeSing b) of { - (,) (SomeSing c) (SomeSing c) -> SomeSing (((:%*:) c) c) } - data SPair :: forall a b. Pair a b -> GHC.Types.Type - where - SMkPair :: forall a b (n :: a) (n :: b). - (Sing (n :: a)) -> (Sing (n :: b)) -> SPair (MkPair n n) - type instance Sing @(Pair a b) = SPair - instance (SingKind a, SingKind b) => SingKind (Pair a b) where - type Demote (Pair a b) = Pair (Demote a) (Demote b) - fromSing (SMkPair b b) = (MkPair (fromSing b)) (fromSing b) - toSing (MkPair (b :: Demote a) (b :: Demote b)) - = case ((,) (toSing b :: SomeSing a)) (toSing b :: SomeSing b) of { - (,) (SomeSing c) (SomeSing c) -> SomeSing ((SMkPair c) c) } - instance (SingI n, SingI n) => - SingI ((:*:) (n :: a) (n :: b)) where - sing = ((:%*:) sing) sing - instance SingI ((:*:@#@$) :: (~>) a ((~>) b ((:*:) a b))) where - sing = (singFun2 @(:*:@#@$)) (:%*:) - instance SingI d => - SingI ((:*:@#@$$) (d :: a) :: (~>) b ((:*:) a b)) where - sing = (singFun1 @((:*:@#@$$) (d :: a))) ((:%*:) (sing @d)) - instance (SingI n, SingI n) => - SingI (MkPair (n :: a) (n :: b)) where - sing = (SMkPair sing) sing - instance SingI (MkPairSym0 :: (~>) a ((~>) b (Pair a b))) where - sing = (singFun2 @MkPairSym0) SMkPair - instance SingI d => - SingI (MkPairSym1 (d :: a) :: (~>) b (Pair a b)) where - sing = (singFun1 @(MkPairSym1 (d :: a))) (SMkPair (sing @d)) diff --git a/tests/compile-and-dump/Singletons/T197b.hs b/tests/compile-and-dump/Singletons/T197b.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T197b.hs +++ /dev/null @@ -1,10 +0,0 @@ -module T197b where - -import Data.Singletons.TH - -$(singletons - [d| data a :*: b = a :*: b - - data Pair a b = MkPair a b - infixr 9 `Pair`, `MkPair` - |]) diff --git a/tests/compile-and-dump/Singletons/T200.ghc88.template b/tests/compile-and-dump/Singletons/T200.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T200.ghc88.template +++ /dev/null @@ -1,189 +0,0 @@ -Singletons/T200.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| ($$:) :: ErrorMessage -> ErrorMessage -> ErrorMessage - x $$: y = x :$$: y - (<>:) :: ErrorMessage -> ErrorMessage -> ErrorMessage - x <>: y = x :<>: y - - data ErrorMessage - = ErrorMessage :$$: ErrorMessage | - ErrorMessage :<>: ErrorMessage | - EM [Bool] |] - ======> - data ErrorMessage - = ErrorMessage :$$: ErrorMessage | - ErrorMessage :<>: ErrorMessage | - EM [Bool] - ($$:) :: ErrorMessage -> ErrorMessage -> ErrorMessage - ($$:) x y = (x :$$: y) - (<>:) :: ErrorMessage -> ErrorMessage -> ErrorMessage - (<>:) x y = (x :<>: y) - type (:$$:@#@$$$) (t0123456789876543210 :: ErrorMessage) (t0123456789876543210 :: ErrorMessage) = - (:$$:) t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings ((:$$:@#@$$) t0123456789876543210) where - suppressUnusedWarnings = snd (((,) (::$$:@#@$$###)) ()) - data (:$$:@#@$$) (t0123456789876543210 :: ErrorMessage) :: (~>) ErrorMessage ErrorMessage - where - (::$$:@#@$$###) :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply ((:$$:@#@$$) t0123456789876543210) arg) ((:$$:@#@$$$) t0123456789876543210 arg) => - (:$$:@#@$$) t0123456789876543210 t0123456789876543210 - type instance Apply ((:$$:@#@$$) t0123456789876543210) t0123456789876543210 = (:$$:) t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (:$$:@#@$) where - suppressUnusedWarnings = snd (((,) (::$$:@#@$###)) ()) - data (:$$:@#@$) :: (~>) ErrorMessage ((~>) ErrorMessage ErrorMessage) - where - (::$$:@#@$###) :: forall t0123456789876543210 - arg. SameKind (Apply (:$$:@#@$) arg) ((:$$:@#@$$) arg) => - (:$$:@#@$) t0123456789876543210 - type instance Apply (:$$:@#@$) t0123456789876543210 = (:$$:@#@$$) t0123456789876543210 - type (:<>:@#@$$$) (t0123456789876543210 :: ErrorMessage) (t0123456789876543210 :: ErrorMessage) = - (:<>:) t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings ((:<>:@#@$$) t0123456789876543210) where - suppressUnusedWarnings = snd (((,) (::<>:@#@$$###)) ()) - data (:<>:@#@$$) (t0123456789876543210 :: ErrorMessage) :: (~>) ErrorMessage ErrorMessage - where - (::<>:@#@$$###) :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply ((:<>:@#@$$) t0123456789876543210) arg) ((:<>:@#@$$$) t0123456789876543210 arg) => - (:<>:@#@$$) t0123456789876543210 t0123456789876543210 - type instance Apply ((:<>:@#@$$) t0123456789876543210) t0123456789876543210 = (:<>:) t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (:<>:@#@$) where - suppressUnusedWarnings = snd (((,) (::<>:@#@$###)) ()) - data (:<>:@#@$) :: (~>) ErrorMessage ((~>) ErrorMessage ErrorMessage) - where - (::<>:@#@$###) :: forall t0123456789876543210 - arg. SameKind (Apply (:<>:@#@$) arg) ((:<>:@#@$$) arg) => - (:<>:@#@$) t0123456789876543210 - type instance Apply (:<>:@#@$) t0123456789876543210 = (:<>:@#@$$) t0123456789876543210 - type EMSym1 (t0123456789876543210 :: [Bool]) = - EM t0123456789876543210 - instance SuppressUnusedWarnings EMSym0 where - suppressUnusedWarnings = snd (((,) EMSym0KindInference) ()) - data EMSym0 :: (~>) [Bool] ErrorMessage - where - EMSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply EMSym0 arg) (EMSym1 arg) => - EMSym0 t0123456789876543210 - type instance Apply EMSym0 t0123456789876543210 = EM t0123456789876543210 - type (<>:@#@$$$) (a0123456789876543210 :: ErrorMessage) (a0123456789876543210 :: ErrorMessage) = - (<>:) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((<>:@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (:<>:@#@$$###)) ()) - data (<>:@#@$$) (a0123456789876543210 :: ErrorMessage) :: (~>) ErrorMessage ErrorMessage - where - (:<>:@#@$$###) :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply ((<>:@#@$$) a0123456789876543210) arg) ((<>:@#@$$$) a0123456789876543210 arg) => - (<>:@#@$$) a0123456789876543210 a0123456789876543210 - type instance Apply ((<>:@#@$$) a0123456789876543210) a0123456789876543210 = (<>:) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (<>:@#@$) where - suppressUnusedWarnings = snd (((,) (:<>:@#@$###)) ()) - data (<>:@#@$) :: (~>) ErrorMessage ((~>) ErrorMessage ErrorMessage) - where - (:<>:@#@$###) :: forall a0123456789876543210 - arg. SameKind (Apply (<>:@#@$) arg) ((<>:@#@$$) arg) => - (<>:@#@$) a0123456789876543210 - type instance Apply (<>:@#@$) a0123456789876543210 = (<>:@#@$$) a0123456789876543210 - type ($$:@#@$$$) (a0123456789876543210 :: ErrorMessage) (a0123456789876543210 :: ErrorMessage) = - ($$:) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (($$:@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (:$$:@#@$$###)) ()) - data ($$:@#@$$) (a0123456789876543210 :: ErrorMessage) :: (~>) ErrorMessage ErrorMessage - where - (:$$:@#@$$###) :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (($$:@#@$$) a0123456789876543210) arg) (($$:@#@$$$) a0123456789876543210 arg) => - ($$:@#@$$) a0123456789876543210 a0123456789876543210 - type instance Apply (($$:@#@$$) a0123456789876543210) a0123456789876543210 = ($$:) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ($$:@#@$) where - suppressUnusedWarnings = snd (((,) (:$$:@#@$###)) ()) - data ($$:@#@$) :: (~>) ErrorMessage ((~>) ErrorMessage ErrorMessage) - where - (:$$:@#@$###) :: forall a0123456789876543210 - arg. SameKind (Apply ($$:@#@$) arg) (($$:@#@$$) arg) => - ($$:@#@$) a0123456789876543210 - type instance Apply ($$:@#@$) a0123456789876543210 = ($$:@#@$$) a0123456789876543210 - type family (<>:) (a :: ErrorMessage) (a :: ErrorMessage) :: ErrorMessage where - (<>:) x y = Apply (Apply (:<>:@#@$) x) y - type family ($$:) (a :: ErrorMessage) (a :: ErrorMessage) :: ErrorMessage where - ($$:) x y = Apply (Apply (:$$:@#@$) x) y - (%<>:) :: - forall (t :: ErrorMessage) (t :: ErrorMessage). - Sing t - -> Sing t -> Sing (Apply (Apply (<>:@#@$) t) t :: ErrorMessage) - (%$$:) :: - forall (t :: ErrorMessage) (t :: ErrorMessage). - Sing t - -> Sing t -> Sing (Apply (Apply ($$:@#@$) t) t :: ErrorMessage) - (%<>:) (sX :: Sing x) (sY :: Sing y) - = (applySing ((applySing ((singFun2 @(:<>:@#@$)) (:%<>:))) sX)) sY - (%$$:) (sX :: Sing x) (sY :: Sing y) - = (applySing ((applySing ((singFun2 @(:$$:@#@$)) (:%$$:))) sX)) sY - instance SingI ((<>:@#@$) :: (~>) ErrorMessage ((~>) ErrorMessage ErrorMessage)) where - sing = (singFun2 @(<>:@#@$)) (%<>:) - instance SingI d => - SingI ((<>:@#@$$) (d :: ErrorMessage) :: (~>) ErrorMessage ErrorMessage) where - sing - = (singFun1 @((<>:@#@$$) (d :: ErrorMessage))) ((%<>:) (sing @d)) - instance SingI (($$:@#@$) :: (~>) ErrorMessage ((~>) ErrorMessage ErrorMessage)) where - sing = (singFun2 @($$:@#@$)) (%$$:) - instance SingI d => - SingI (($$:@#@$$) (d :: ErrorMessage) :: (~>) ErrorMessage ErrorMessage) where - sing - = (singFun1 @(($$:@#@$$) (d :: ErrorMessage))) ((%$$:) (sing @d)) - data SErrorMessage :: ErrorMessage -> GHC.Types.Type - where - (:%$$:) :: forall (n :: ErrorMessage) (n :: ErrorMessage). - (Sing (n :: ErrorMessage)) - -> (Sing (n :: ErrorMessage)) -> SErrorMessage ((:$$:) n n) - (:%<>:) :: forall (n :: ErrorMessage) (n :: ErrorMessage). - (Sing (n :: ErrorMessage)) - -> (Sing (n :: ErrorMessage)) -> SErrorMessage ((:<>:) n n) - SEM :: forall (n :: [Bool]). - (Sing (n :: [Bool])) -> SErrorMessage (EM n) - type instance Sing @ErrorMessage = SErrorMessage - instance SingKind ErrorMessage where - type Demote ErrorMessage = ErrorMessage - fromSing ((:%$$:) b b) = ((:$$:) (fromSing b)) (fromSing b) - fromSing ((:%<>:) b b) = ((:<>:) (fromSing b)) (fromSing b) - fromSing (SEM b) = EM (fromSing b) - toSing - ((:$$:) (b :: Demote ErrorMessage) (b :: Demote ErrorMessage)) - = case - ((,) (toSing b :: SomeSing ErrorMessage)) - (toSing b :: SomeSing ErrorMessage) - of { - (,) (SomeSing c) (SomeSing c) -> SomeSing (((:%$$:) c) c) } - toSing - ((:<>:) (b :: Demote ErrorMessage) (b :: Demote ErrorMessage)) - = case - ((,) (toSing b :: SomeSing ErrorMessage)) - (toSing b :: SomeSing ErrorMessage) - of { - (,) (SomeSing c) (SomeSing c) -> SomeSing (((:%<>:) c) c) } - toSing (EM (b :: Demote [Bool])) - = case toSing b :: SomeSing [Bool] of { - SomeSing c -> SomeSing (SEM c) } - instance (SingI n, SingI n) => - SingI ((:$$:) (n :: ErrorMessage) (n :: ErrorMessage)) where - sing = ((:%$$:) sing) sing - instance SingI ((:$$:@#@$) :: (~>) ErrorMessage ((~>) ErrorMessage ErrorMessage)) where - sing = (singFun2 @(:$$:@#@$)) (:%$$:) - instance SingI d => - SingI ((:$$:@#@$$) (d :: ErrorMessage) :: (~>) ErrorMessage ErrorMessage) where - sing - = (singFun1 @((:$$:@#@$$) (d :: ErrorMessage))) ((:%$$:) (sing @d)) - instance (SingI n, SingI n) => - SingI ((:<>:) (n :: ErrorMessage) (n :: ErrorMessage)) where - sing = ((:%<>:) sing) sing - instance SingI ((:<>:@#@$) :: (~>) ErrorMessage ((~>) ErrorMessage ErrorMessage)) where - sing = (singFun2 @(:<>:@#@$)) (:%<>:) - instance SingI d => - SingI ((:<>:@#@$$) (d :: ErrorMessage) :: (~>) ErrorMessage ErrorMessage) where - sing - = (singFun1 @((:<>:@#@$$) (d :: ErrorMessage))) ((:%<>:) (sing @d)) - instance SingI n => SingI (EM (n :: [Bool])) where - sing = SEM sing - instance SingI (EMSym0 :: (~>) [Bool] ErrorMessage) where - sing = (singFun1 @EMSym0) SEM diff --git a/tests/compile-and-dump/Singletons/T200.hs b/tests/compile-and-dump/Singletons/T200.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T200.hs +++ /dev/null @@ -1,15 +0,0 @@ -module T200 where - -import Data.Singletons.TH - -$(singletons [d| - data ErrorMessage = ErrorMessage :$$: ErrorMessage - | ErrorMessage :<>: ErrorMessage - | EM [Bool] - - ($$:) :: ErrorMessage -> ErrorMessage -> ErrorMessage - x $$: y = x :$$: y - - (<>:) :: ErrorMessage -> ErrorMessage -> ErrorMessage - x <>: y = x :<>: y - |]) diff --git a/tests/compile-and-dump/Singletons/T206.ghc88.template b/tests/compile-and-dump/Singletons/T206.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T206.ghc88.template +++ /dev/null diff --git a/tests/compile-and-dump/Singletons/T206.hs b/tests/compile-and-dump/Singletons/T206.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T206.hs +++ /dev/null @@ -1,5 +0,0 @@ -module T206 where - -import Data.Singletons.Prelude - -x = SCons @Bool @True @'[False] diff --git a/tests/compile-and-dump/Singletons/T209.ghc88.template b/tests/compile-and-dump/Singletons/T209.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T209.ghc88.template +++ /dev/null @@ -1,82 +0,0 @@ -Singletons/T209.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| m :: a -> b -> Bool -> Bool - m _ _ x = x - - class C a b - data Hm - = Hm - deriving anyclass (C Bool) - - deriving anyclass instance C a a => C a (Maybe a) |] - ======> - class C a b - m :: a -> b -> Bool -> Bool - m _ _ x = x - data Hm - = Hm - deriving anyclass (C Bool) - deriving anyclass instance C a a => C a (Maybe a) - type HmSym0 = Hm - type MSym3 (a0123456789876543210 :: a0123456789876543210) (a0123456789876543210 :: b0123456789876543210) (a0123456789876543210 :: Bool) = - M a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (MSym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) MSym2KindInference) ()) - data MSym2 (a0123456789876543210 :: a0123456789876543210) (a0123456789876543210 :: b0123456789876543210) :: (~>) Bool Bool - where - MSym2KindInference :: forall a0123456789876543210 - a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (MSym2 a0123456789876543210 a0123456789876543210) arg) (MSym3 a0123456789876543210 a0123456789876543210 arg) => - MSym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (MSym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = M a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (MSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) MSym1KindInference) ()) - data MSym1 (a0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210. - (~>) b0123456789876543210 ((~>) Bool Bool) - where - MSym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (MSym1 a0123456789876543210) arg) (MSym2 a0123456789876543210 arg) => - MSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (MSym1 a0123456789876543210) a0123456789876543210 = MSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings MSym0 where - suppressUnusedWarnings = snd (((,) MSym0KindInference) ()) - data MSym0 :: forall a0123456789876543210 b0123456789876543210. - (~>) a0123456789876543210 ((~>) b0123456789876543210 ((~>) Bool Bool)) - where - MSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply MSym0 arg) (MSym1 arg) => - MSym0 a0123456789876543210 - type instance Apply MSym0 a0123456789876543210 = MSym1 a0123456789876543210 - type family M (a :: a) (a :: b) (a :: Bool) :: Bool where - M _ _ x = x - class PC (a :: GHC.Types.Type) (b :: GHC.Types.Type) - instance PC Bool Hm - instance PC a (Maybe a) - sM :: - forall a b (t :: a) (t :: b) (t :: Bool). - Sing t - -> Sing t - -> Sing t -> Sing (Apply (Apply (Apply MSym0 t) t) t :: Bool) - sM _ _ (sX :: Sing x) = sX - instance SingI (MSym0 :: (~>) a ((~>) b ((~>) Bool Bool))) where - sing = (singFun3 @MSym0) sM - instance SingI d => - SingI (MSym1 (d :: a) :: (~>) b ((~>) Bool Bool)) where - sing = (singFun2 @(MSym1 (d :: a))) (sM (sing @d)) - instance (SingI d, SingI d) => - SingI (MSym2 (d :: a) (d :: b) :: (~>) Bool Bool) where - sing - = (singFun1 @(MSym2 (d :: a) (d :: b))) ((sM (sing @d)) (sing @d)) - data SHm :: Hm -> GHC.Types.Type where SHm :: SHm Hm - type instance Sing @Hm = SHm - instance SingKind Hm where - type Demote Hm = Hm - fromSing SHm = Hm - toSing Hm = SomeSing SHm - class SC a b - instance SC Bool Hm - instance SC a a => SC a (Maybe a) - instance SingI Hm where - sing = SHm diff --git a/tests/compile-and-dump/Singletons/T209.hs b/tests/compile-and-dump/Singletons/T209.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T209.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} -module T209 where - -import Data.Singletons.TH - -$(singletons - [d| class C a b where - m :: a -> b -> Bool -> Bool - m _ _ x = x - - data Hm = Hm - deriving anyclass (C Bool) - - deriving anyclass instance C a a => C a (Maybe a) - |]) diff --git a/tests/compile-and-dump/Singletons/T216.ghc88.template b/tests/compile-and-dump/Singletons/T216.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T216.ghc88.template +++ /dev/null @@ -1,56 +0,0 @@ -Singletons/T216.hs:0:0:: Splicing declarations - genDefunSymbols [''MyProxy, ''Symmetry] - ======> - type MyProxySym2 (k0123456789876543210 :: Type) (a0123456789876543210 :: k0123456789876543210) = - MyProxy k0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (MyProxySym1 k0123456789876543210) where - suppressUnusedWarnings = snd (((,) MyProxySym1KindInference) ()) - data MyProxySym1 (k0123456789876543210 :: Type) :: (~>) k0123456789876543210 Type - where - MyProxySym1KindInference :: forall k0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (MyProxySym1 k0123456789876543210) arg) (MyProxySym2 k0123456789876543210 arg) => - MyProxySym1 k0123456789876543210 a0123456789876543210 - type instance Apply (MyProxySym1 k0123456789876543210) a0123456789876543210 = MyProxy k0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings MyProxySym0 where - suppressUnusedWarnings = snd (((,) MyProxySym0KindInference) ()) - data MyProxySym0 :: forall (k0123456789876543210 :: Type). - (~>) Type ((~>) k0123456789876543210 Type) - where - MyProxySym0KindInference :: forall k0123456789876543210 - arg. SameKind (Apply MyProxySym0 arg) (MyProxySym1 arg) => - MyProxySym0 k0123456789876543210 - type instance Apply MyProxySym0 k0123456789876543210 = MyProxySym1 k0123456789876543210 - type SymmetrySym3 (a0123456789876543210 :: t0123456789876543210) (y0123456789876543210 :: t0123456789876543210) (e0123456789876543210 :: (:~:) a0123456789876543210 y0123456789876543210) = - Symmetry a0123456789876543210 y0123456789876543210 e0123456789876543210 - instance SuppressUnusedWarnings (SymmetrySym2 y0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) SymmetrySym2KindInference) ()) - data SymmetrySym2 (a0123456789876543210 :: t0123456789876543210) (y0123456789876543210 :: t0123456789876543210) :: (~>) ((:~:) a0123456789876543210 y0123456789876543210) Type - where - SymmetrySym2KindInference :: forall a0123456789876543210 - y0123456789876543210 - e0123456789876543210 - arg. SameKind (Apply (SymmetrySym2 a0123456789876543210 y0123456789876543210) arg) (SymmetrySym3 a0123456789876543210 y0123456789876543210 arg) => - SymmetrySym2 a0123456789876543210 y0123456789876543210 e0123456789876543210 - type instance Apply (SymmetrySym2 y0123456789876543210 a0123456789876543210) e0123456789876543210 = Symmetry y0123456789876543210 a0123456789876543210 e0123456789876543210 - instance SuppressUnusedWarnings (SymmetrySym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) SymmetrySym1KindInference) ()) - data SymmetrySym1 (a0123456789876543210 :: t0123456789876543210) :: forall (y0123456789876543210 :: t0123456789876543210). - (~>) t0123456789876543210 ((~>) ((:~:) a0123456789876543210 y0123456789876543210) Type) - where - SymmetrySym1KindInference :: forall a0123456789876543210 - y0123456789876543210 - arg. SameKind (Apply (SymmetrySym1 a0123456789876543210) arg) (SymmetrySym2 a0123456789876543210 arg) => - SymmetrySym1 a0123456789876543210 y0123456789876543210 - type instance Apply (SymmetrySym1 a0123456789876543210) y0123456789876543210 = SymmetrySym2 a0123456789876543210 y0123456789876543210 - instance SuppressUnusedWarnings SymmetrySym0 where - suppressUnusedWarnings = snd (((,) SymmetrySym0KindInference) ()) - data SymmetrySym0 :: forall t0123456789876543210 - (a0123456789876543210 :: t0123456789876543210) - (y0123456789876543210 :: t0123456789876543210). - (~>) t0123456789876543210 ((~>) t0123456789876543210 ((~>) ((:~:) a0123456789876543210 y0123456789876543210) Type)) - where - SymmetrySym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply SymmetrySym0 arg) (SymmetrySym1 arg) => - SymmetrySym0 a0123456789876543210 - type instance Apply SymmetrySym0 a0123456789876543210 = SymmetrySym1 a0123456789876543210 diff --git a/tests/compile-and-dump/Singletons/T216.hs b/tests/compile-and-dump/Singletons/T216.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T216.hs +++ /dev/null @@ -1,12 +0,0 @@ -module T216 where - -import Data.Kind -import Data.Singletons.TH - -type family MyProxy k (a :: k) :: Type where - MyProxy _ a = Proxy a - -type family Symmetry (a :: t) (y :: t) (e :: a :~: y) :: Type where - Symmetry a y _ = y :~: a - -$(genDefunSymbols [''MyProxy, ''Symmetry]) diff --git a/tests/compile-and-dump/Singletons/T226.ghc88.template b/tests/compile-and-dump/Singletons/T226.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T226.ghc88.template +++ /dev/null @@ -1,6 +0,0 @@ -Singletons/T226.hs:0:0:: Splicing declarations - singletons [d| class a ~> b |] - ======> - class (~>) a b - class (#~>) (a :: GHC.Types.Type) (b :: GHC.Types.Type) - class (%~>) a b diff --git a/tests/compile-and-dump/Singletons/T226.hs b/tests/compile-and-dump/Singletons/T226.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T226.hs +++ /dev/null @@ -1,5 +0,0 @@ -module T226 where - -import Data.Singletons.TH - -$(singletons [d| class a ~> b |]) diff --git a/tests/compile-and-dump/Singletons/T229.ghc88.template b/tests/compile-and-dump/Singletons/T229.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T229.ghc88.template +++ /dev/null @@ -1,24 +0,0 @@ -Singletons/T229.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| ___foo :: Bool -> Bool - ___foo _ = True |] - ======> - ___foo :: Bool -> Bool - ___foo _ = True - type US___fooSym1 (a0123456789876543210 :: Bool) = - US___foo a0123456789876543210 - instance SuppressUnusedWarnings US___fooSym0 where - suppressUnusedWarnings = snd (((,) US___fooSym0KindInference) ()) - data US___fooSym0 :: (~>) Bool Bool - where - US___fooSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply US___fooSym0 arg) (US___fooSym1 arg) => - US___fooSym0 a0123456789876543210 - type instance Apply US___fooSym0 a0123456789876543210 = US___foo a0123456789876543210 - type family US___foo (a :: Bool) :: Bool where - US___foo _ = TrueSym0 - ___sfoo :: - forall (t :: Bool). Sing t -> Sing (Apply US___fooSym0 t :: Bool) - ___sfoo _ = STrue - instance SingI (US___fooSym0 :: (~>) Bool Bool) where - sing = (singFun1 @US___fooSym0) ___sfoo diff --git a/tests/compile-and-dump/Singletons/T229.hs b/tests/compile-and-dump/Singletons/T229.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T229.hs +++ /dev/null @@ -1,6 +0,0 @@ -module T229 where - -import Data.Singletons.TH - -$(singletons [d| ___foo :: Bool -> Bool - ___foo _ = True |]) diff --git a/tests/compile-and-dump/Singletons/T249.ghc88.template b/tests/compile-and-dump/Singletons/T249.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T249.ghc88.template +++ /dev/null @@ -1,84 +0,0 @@ -Singletons/T249.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| data Foo1 a = MkFoo1 a - data Foo2 a where MkFoo2 :: x -> Foo2 x - data Foo3 a where MkFoo3 :: forall x. x -> Foo3 x |] - ======> - data Foo1 a = MkFoo1 a - data Foo2 a where MkFoo2 :: x -> Foo2 x - data Foo3 a where MkFoo3 :: forall x. x -> Foo3 x - type MkFoo1Sym1 (t0123456789876543210 :: a0123456789876543210) = - MkFoo1 t0123456789876543210 - instance SuppressUnusedWarnings MkFoo1Sym0 where - suppressUnusedWarnings = snd (((,) MkFoo1Sym0KindInference) ()) - data MkFoo1Sym0 :: forall a0123456789876543210. - (~>) a0123456789876543210 (Foo1 a0123456789876543210) - where - MkFoo1Sym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply MkFoo1Sym0 arg) (MkFoo1Sym1 arg) => - MkFoo1Sym0 t0123456789876543210 - type instance Apply MkFoo1Sym0 t0123456789876543210 = MkFoo1 t0123456789876543210 - type MkFoo2Sym1 (t0123456789876543210 :: x0123456789876543210) = - MkFoo2 t0123456789876543210 - instance SuppressUnusedWarnings MkFoo2Sym0 where - suppressUnusedWarnings = snd (((,) MkFoo2Sym0KindInference) ()) - data MkFoo2Sym0 :: forall x0123456789876543210. - (~>) x0123456789876543210 (Foo2 x0123456789876543210) - where - MkFoo2Sym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply MkFoo2Sym0 arg) (MkFoo2Sym1 arg) => - MkFoo2Sym0 t0123456789876543210 - type instance Apply MkFoo2Sym0 t0123456789876543210 = MkFoo2 t0123456789876543210 - type MkFoo3Sym1 (t0123456789876543210 :: x0123456789876543210) = - MkFoo3 t0123456789876543210 - instance SuppressUnusedWarnings MkFoo3Sym0 where - suppressUnusedWarnings = snd (((,) MkFoo3Sym0KindInference) ()) - data MkFoo3Sym0 :: forall x0123456789876543210. - (~>) x0123456789876543210 (Foo3 x0123456789876543210) - where - MkFoo3Sym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply MkFoo3Sym0 arg) (MkFoo3Sym1 arg) => - MkFoo3Sym0 t0123456789876543210 - type instance Apply MkFoo3Sym0 t0123456789876543210 = MkFoo3 t0123456789876543210 - data SFoo1 :: forall a. Foo1 a -> Type - where - SMkFoo1 :: forall a (n :: a). (Sing (n :: a)) -> SFoo1 (MkFoo1 n) - type instance Sing @(Foo1 a) = SFoo1 - instance SingKind a => SingKind (Foo1 a) where - type Demote (Foo1 a) = Foo1 (Demote a) - fromSing (SMkFoo1 b) = MkFoo1 (fromSing b) - toSing (MkFoo1 (b :: Demote a)) - = case toSing b :: SomeSing a of { - SomeSing c -> SomeSing (SMkFoo1 c) } - data SFoo2 :: forall a. Foo2 a -> Type - where - SMkFoo2 :: forall x (n :: x). (Sing (n :: x)) -> SFoo2 (MkFoo2 n) - type instance Sing @(Foo2 a) = SFoo2 - instance SingKind a => SingKind (Foo2 a) where - type Demote (Foo2 a) = Foo2 (Demote a) - fromSing (SMkFoo2 b) = MkFoo2 (fromSing b) - toSing (MkFoo2 (b :: Demote x)) - = case toSing b :: SomeSing x of { - SomeSing c -> SomeSing (SMkFoo2 c) } - data SFoo3 :: forall a. Foo3 a -> Type - where - SMkFoo3 :: forall x (n :: x). (Sing (n :: x)) -> SFoo3 (MkFoo3 n) - type instance Sing @(Foo3 a) = SFoo3 - instance SingKind a => SingKind (Foo3 a) where - type Demote (Foo3 a) = Foo3 (Demote a) - fromSing (SMkFoo3 b) = MkFoo3 (fromSing b) - toSing (MkFoo3 (b :: Demote x)) - = case toSing b :: SomeSing x of { - SomeSing c -> SomeSing (SMkFoo3 c) } - instance SingI n => SingI (MkFoo1 (n :: a)) where - sing = SMkFoo1 sing - instance SingI (MkFoo1Sym0 :: (~>) a (Foo1 a)) where - sing = (singFun1 @MkFoo1Sym0) SMkFoo1 - instance SingI n => SingI (MkFoo2 (n :: x)) where - sing = SMkFoo2 sing - instance SingI (MkFoo2Sym0 :: (~>) x (Foo2 x)) where - sing = (singFun1 @MkFoo2Sym0) SMkFoo2 - instance SingI n => SingI (MkFoo3 (n :: x)) where - sing = SMkFoo3 sing - instance SingI (MkFoo3Sym0 :: (~>) x (Foo3 x)) where - sing = (singFun1 @MkFoo3Sym0) SMkFoo3 diff --git a/tests/compile-and-dump/Singletons/T249.hs b/tests/compile-and-dump/Singletons/T249.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T249.hs +++ /dev/null @@ -1,12 +0,0 @@ -module T249 where - -import Data.Kind -import Data.Singletons.TH - -$(singletons - [d| data Foo1 a = MkFoo1 a - data Foo2 a where - MkFoo2 :: x -> Foo2 x - data Foo3 a where - MkFoo3 :: forall x. x -> Foo3 x - |]) diff --git a/tests/compile-and-dump/Singletons/T271.ghc88.template b/tests/compile-and-dump/Singletons/T271.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T271.ghc88.template +++ /dev/null @@ -1,215 +0,0 @@ -Singletons/T271.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| newtype Constant (a :: Type) (b :: Type) - = Constant a - deriving (Eq, Ord) - data Identity :: Type -> Type - where Identity :: a -> Identity a - deriving (Eq, Ord) |] - ======> - newtype Constant (a :: Type) (b :: Type) - = Constant a - deriving (Eq, Ord) - data Identity :: Type -> Type - where Identity :: a -> Identity a - deriving (Eq, Ord) - type ConstantSym1 (t0123456789876543210 :: a0123456789876543210) = - Constant t0123456789876543210 - instance SuppressUnusedWarnings ConstantSym0 where - suppressUnusedWarnings = snd (((,) ConstantSym0KindInference) ()) - data ConstantSym0 :: forall (a0123456789876543210 :: Type) - (b0123456789876543210 :: Type). - (~>) a0123456789876543210 (Constant (a0123456789876543210 :: Type) (b0123456789876543210 :: Type)) - where - ConstantSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply ConstantSym0 arg) (ConstantSym1 arg) => - ConstantSym0 t0123456789876543210 - type instance Apply ConstantSym0 t0123456789876543210 = Constant t0123456789876543210 - type IdentitySym1 (t0123456789876543210 :: a0123456789876543210) = - Identity t0123456789876543210 - instance SuppressUnusedWarnings IdentitySym0 where - suppressUnusedWarnings = snd (((,) IdentitySym0KindInference) ()) - data IdentitySym0 :: forall a0123456789876543210. - (~>) a0123456789876543210 (Identity a0123456789876543210) - where - IdentitySym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply IdentitySym0 arg) (IdentitySym1 arg) => - IdentitySym0 t0123456789876543210 - type instance Apply IdentitySym0 t0123456789876543210 = Identity t0123456789876543210 - type family Compare_0123456789876543210 (a :: Constant a b) (a :: Constant a b) :: Ordering where - Compare_0123456789876543210 (Constant a_0123456789876543210) (Constant b_0123456789876543210) = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) '[]) - type Compare_0123456789876543210Sym2 (a0123456789876543210 :: Constant a0123456789876543210 b0123456789876543210) (a0123456789876543210 :: Constant a0123456789876543210 b0123456789876543210) = - Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Compare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym1KindInference) ()) - data Compare_0123456789876543210Sym1 (a0123456789876543210 :: Constant a0123456789876543210 b0123456789876543210) :: (~>) (Constant a0123456789876543210 b0123456789876543210) Ordering - where - Compare_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Compare_0123456789876543210Sym1 a0123456789876543210) arg) (Compare_0123456789876543210Sym2 a0123456789876543210 arg) => - Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Compare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Compare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym0KindInference) ()) - data Compare_0123456789876543210Sym0 :: forall a0123456789876543210 - b0123456789876543210. - (~>) (Constant a0123456789876543210 b0123456789876543210) ((~>) (Constant a0123456789876543210 b0123456789876543210) Ordering) - where - Compare_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Compare_0123456789876543210Sym0 arg) (Compare_0123456789876543210Sym1 arg) => - Compare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Compare_0123456789876543210Sym0 a0123456789876543210 = Compare_0123456789876543210Sym1 a0123456789876543210 - instance POrd (Constant a b) where - type Compare a a = Apply (Apply Compare_0123456789876543210Sym0 a) a - type family Compare_0123456789876543210 (a :: Identity a) (a :: Identity a) :: Ordering where - Compare_0123456789876543210 (Identity a_0123456789876543210) (Identity b_0123456789876543210) = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) '[]) - type Compare_0123456789876543210Sym2 (a0123456789876543210 :: Identity a0123456789876543210) (a0123456789876543210 :: Identity a0123456789876543210) = - Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Compare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym1KindInference) ()) - data Compare_0123456789876543210Sym1 (a0123456789876543210 :: Identity a0123456789876543210) :: (~>) (Identity a0123456789876543210) Ordering - where - Compare_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Compare_0123456789876543210Sym1 a0123456789876543210) arg) (Compare_0123456789876543210Sym2 a0123456789876543210 arg) => - Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Compare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Compare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym0KindInference) ()) - data Compare_0123456789876543210Sym0 :: forall a0123456789876543210. - (~>) (Identity a0123456789876543210) ((~>) (Identity a0123456789876543210) Ordering) - where - Compare_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Compare_0123456789876543210Sym0 arg) (Compare_0123456789876543210Sym1 arg) => - Compare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Compare_0123456789876543210Sym0 a0123456789876543210 = Compare_0123456789876543210Sym1 a0123456789876543210 - instance POrd (Identity a) where - type Compare a a = Apply (Apply Compare_0123456789876543210Sym0 a) a - type family Equals_0123456789876543210 (a :: Constant a b) (b :: Constant a b) :: Bool where - Equals_0123456789876543210 (Constant a) (Constant b) = (==) a b - Equals_0123456789876543210 (_ :: Constant a b) (_ :: Constant a b) = FalseSym0 - instance PEq (Constant a b) where - type (==) a b = Equals_0123456789876543210 a b - type family Equals_0123456789876543210 (a :: Identity a) (b :: Identity a) :: Bool where - Equals_0123456789876543210 (Identity a) (Identity b) = (==) a b - Equals_0123456789876543210 (_ :: Identity a) (_ :: Identity a) = FalseSym0 - instance PEq (Identity a) where - type (==) a b = Equals_0123456789876543210 a b - data SConstant :: forall a b. Constant a b -> Type - where - SConstant :: forall a (n :: a). - (Sing (n :: a)) -> SConstant (Constant n) - type instance Sing @(Constant a b) = SConstant - instance (SingKind a, SingKind b) => SingKind (Constant a b) where - type Demote (Constant a b) = Constant (Demote a) (Demote b) - fromSing (SConstant b) = Constant (fromSing b) - toSing (Constant (b :: Demote a)) - = case toSing b :: SomeSing a of { - SomeSing c -> SomeSing (SConstant c) } - data SIdentity :: forall a. Identity a -> Type - where - SIdentity :: forall a (n :: a). - (Sing (n :: a)) -> SIdentity (Identity n) - type instance Sing @(Identity a) = SIdentity - instance SingKind a => SingKind (Identity a) where - type Demote (Identity a) = Identity (Demote a) - fromSing (SIdentity b) = Identity (fromSing b) - toSing (Identity (b :: Demote a)) - = case toSing b :: SomeSing a of { - SomeSing c -> SomeSing (SIdentity c) } - instance SOrd a => SOrd (Constant a b) where - sCompare :: - forall (t1 :: Constant a b) (t2 :: Constant a b). - Sing t1 - -> Sing t2 - -> Sing (Apply (Apply (CompareSym0 :: TyFun (Constant a b) ((~>) (Constant a b) Ordering) - -> Type) t1) t2) - sCompare - (SConstant (sA_0123456789876543210 :: Sing a_0123456789876543210)) - (SConstant (sB_0123456789876543210 :: Sing b_0123456789876543210)) - = (applySing - ((applySing - ((applySing ((singFun3 @FoldlSym0) sFoldl)) - ((singFun2 @ThenCmpSym0) sThenCmp))) - SEQ)) - ((applySing - ((applySing - ((singFun2 @(:@#@$)) - Data.Singletons.Prelude.Instances.SCons)) - ((applySing - ((applySing ((singFun2 @CompareSym0) sCompare)) - sA_0123456789876543210)) - sB_0123456789876543210))) - Data.Singletons.Prelude.Instances.SNil) - instance SOrd a => SOrd (Identity a) where - sCompare :: - forall (t1 :: Identity a) (t2 :: Identity a). - Sing t1 - -> Sing t2 - -> Sing (Apply (Apply (CompareSym0 :: TyFun (Identity a) ((~>) (Identity a) Ordering) - -> Type) t1) t2) - sCompare - (SIdentity (sA_0123456789876543210 :: Sing a_0123456789876543210)) - (SIdentity (sB_0123456789876543210 :: Sing b_0123456789876543210)) - = (applySing - ((applySing - ((applySing ((singFun3 @FoldlSym0) sFoldl)) - ((singFun2 @ThenCmpSym0) sThenCmp))) - SEQ)) - ((applySing - ((applySing - ((singFun2 @(:@#@$)) - Data.Singletons.Prelude.Instances.SCons)) - ((applySing - ((applySing ((singFun2 @CompareSym0) sCompare)) - sA_0123456789876543210)) - sB_0123456789876543210))) - Data.Singletons.Prelude.Instances.SNil) - instance SEq a => SEq (Constant a b) where - (%==) (SConstant a) (SConstant b) = ((%==) a) b - instance SDecide a => SDecide (Constant a b) where - (%~) (SConstant a) (SConstant b) - = case ((%~) a) b of - Proved Refl -> Proved Refl - Disproved contra - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - instance SDecide a => - Data.Type.Equality.TestEquality (SConstant :: Constant a b - -> Type) where - Data.Type.Equality.testEquality - = Data.Singletons.Decide.decideEquality - instance SDecide a => - Data.Type.Coercion.TestCoercion (SConstant :: Constant a b - -> Type) where - Data.Type.Coercion.testCoercion - = Data.Singletons.Decide.decideCoercion - instance SEq a => SEq (Identity a) where - (%==) (SIdentity a) (SIdentity b) = ((%==) a) b - instance SDecide a => SDecide (Identity a) where - (%~) (SIdentity a) (SIdentity b) - = case ((%~) a) b of - Proved Refl -> Proved Refl - Disproved contra - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - instance SDecide a => - Data.Type.Equality.TestEquality (SIdentity :: Identity a - -> Type) where - Data.Type.Equality.testEquality - = Data.Singletons.Decide.decideEquality - instance SDecide a => - Data.Type.Coercion.TestCoercion (SIdentity :: Identity a - -> Type) where - Data.Type.Coercion.testCoercion - = Data.Singletons.Decide.decideCoercion - instance SingI n => SingI (Constant (n :: a)) where - sing = SConstant sing - instance SingI (ConstantSym0 :: (~>) a (Constant (a :: Type) (b :: Type))) where - sing = (singFun1 @ConstantSym0) SConstant - instance SingI n => SingI (Identity (n :: a)) where - sing = SIdentity sing - instance SingI (IdentitySym0 :: (~>) a (Identity a)) where - sing = (singFun1 @IdentitySym0) SIdentity diff --git a/tests/compile-and-dump/Singletons/T271.hs b/tests/compile-and-dump/Singletons/T271.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T271.hs +++ /dev/null @@ -1,13 +0,0 @@ -module T271 where - -import Data.Kind (Type) -import Data.Singletons.TH - -$(singletons - [d| newtype Constant (a :: Type) (b :: Type) = - Constant a deriving (Eq, Ord) - - data Identity :: Type -> Type where - Identity :: a -> Identity a - deriving (Eq, Ord) - |]) diff --git a/tests/compile-and-dump/Singletons/T287.ghc88.template b/tests/compile-and-dump/Singletons/T287.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T287.ghc88.template +++ /dev/null @@ -1,116 +0,0 @@ -Singletons/T287.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| class S a where - (<<>>) :: a -> a -> a - - instance S b => S (a -> b) where - f <<>> g = \ x -> f x <<>> g x |] - ======> - class S a where - (<<>>) :: a -> a -> a - instance S b => S (a -> b) where - (<<>>) f g = \ x -> (f x <<>> g x) - type (<<>>@#@$$$) (arg0123456789876543210 :: a0123456789876543210) (arg0123456789876543210 :: a0123456789876543210) = - (<<>>) arg0123456789876543210 arg0123456789876543210 - instance SuppressUnusedWarnings ((<<>>@#@$$) arg0123456789876543210) where - suppressUnusedWarnings = snd (((,) (:<<>>@#@$$###)) ()) - data (<<>>@#@$$) (arg0123456789876543210 :: a0123456789876543210) :: (~>) a0123456789876543210 a0123456789876543210 - where - (:<<>>@#@$$###) :: forall arg0123456789876543210 - arg0123456789876543210 - arg. SameKind (Apply ((<<>>@#@$$) arg0123456789876543210) arg) ((<<>>@#@$$$) arg0123456789876543210 arg) => - (<<>>@#@$$) arg0123456789876543210 arg0123456789876543210 - type instance Apply ((<<>>@#@$$) arg0123456789876543210) arg0123456789876543210 = (<<>>) arg0123456789876543210 arg0123456789876543210 - instance SuppressUnusedWarnings (<<>>@#@$) where - suppressUnusedWarnings = snd (((,) (:<<>>@#@$###)) ()) - data (<<>>@#@$) :: forall a0123456789876543210. - (~>) a0123456789876543210 ((~>) a0123456789876543210 a0123456789876543210) - where - (:<<>>@#@$###) :: forall arg0123456789876543210 - arg. SameKind (Apply (<<>>@#@$) arg) ((<<>>@#@$$) arg) => - (<<>>@#@$) arg0123456789876543210 - type instance Apply (<<>>@#@$) arg0123456789876543210 = (<<>>@#@$$) arg0123456789876543210 - class PS (a :: GHC.Types.Type) where - type (<<>>) (arg :: a) (arg :: a) :: a - type family Lambda_0123456789876543210 f g t where - Lambda_0123456789876543210 f g x = Apply (Apply (<<>>@#@$) (Apply f x)) (Apply g x) - type Lambda_0123456789876543210Sym3 f0123456789876543210 g0123456789876543210 t0123456789876543210 = - Lambda_0123456789876543210 f0123456789876543210 g0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 g0123456789876543210 f0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym2 f0123456789876543210 g0123456789876543210 t0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: forall f0123456789876543210 - g0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym2 f0123456789876543210 g0123456789876543210) arg) (Lambda_0123456789876543210Sym3 f0123456789876543210 g0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 f0123456789876543210 g0123456789876543210 t0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 g0123456789876543210 f0123456789876543210) t0123456789876543210 = Lambda_0123456789876543210 g0123456789876543210 f0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 f0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym1 f0123456789876543210 g0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: forall f0123456789876543210 - g0123456789876543210 - arg. SameKind (Apply (Lambda_0123456789876543210Sym1 f0123456789876543210) arg) (Lambda_0123456789876543210Sym2 f0123456789876543210 arg) => - Lambda_0123456789876543210Sym1 f0123456789876543210 g0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 f0123456789876543210) g0123456789876543210 = Lambda_0123456789876543210Sym2 f0123456789876543210 g0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym0 f0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: forall f0123456789876543210 - arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 f0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 f0123456789876543210 = Lambda_0123456789876543210Sym1 f0123456789876543210 - type family TFHelper_0123456789876543210 (a :: (~>) a b) (a :: (~>) a b) :: (~>) a b where - TFHelper_0123456789876543210 f g = Apply (Apply Lambda_0123456789876543210Sym0 f) g - type TFHelper_0123456789876543210Sym2 (a0123456789876543210 :: (~>) a0123456789876543210 b0123456789876543210) (a0123456789876543210 :: (~>) a0123456789876543210 b0123456789876543210) = - TFHelper_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (TFHelper_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) TFHelper_0123456789876543210Sym1KindInference) ()) - data TFHelper_0123456789876543210Sym1 (a0123456789876543210 :: (~>) a0123456789876543210 b0123456789876543210) :: (~>) ((~>) a0123456789876543210 b0123456789876543210) ((~>) a0123456789876543210 b0123456789876543210) - where - TFHelper_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (TFHelper_0123456789876543210Sym1 a0123456789876543210) arg) (TFHelper_0123456789876543210Sym2 a0123456789876543210 arg) => - TFHelper_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (TFHelper_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = TFHelper_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings TFHelper_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) TFHelper_0123456789876543210Sym0KindInference) ()) - data TFHelper_0123456789876543210Sym0 :: forall a0123456789876543210 - b0123456789876543210. - (~>) ((~>) a0123456789876543210 b0123456789876543210) ((~>) ((~>) a0123456789876543210 b0123456789876543210) ((~>) a0123456789876543210 b0123456789876543210)) - where - TFHelper_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply TFHelper_0123456789876543210Sym0 arg) (TFHelper_0123456789876543210Sym1 arg) => - TFHelper_0123456789876543210Sym0 a0123456789876543210 - type instance Apply TFHelper_0123456789876543210Sym0 a0123456789876543210 = TFHelper_0123456789876543210Sym1 a0123456789876543210 - instance PS ((~>) a b) where - type (<<>>) a a = Apply (Apply TFHelper_0123456789876543210Sym0 a) a - class SS a where - (%<<>>) :: - forall (t :: a) (t :: a). - Sing t -> Sing t -> Sing (Apply (Apply (<<>>@#@$) t) t :: a) - instance SS b => SS ((~>) a b) where - (%<<>>) :: - forall (t :: (~>) a b) (t :: (~>) a b). - Sing t -> Sing t -> Sing (Apply (Apply (<<>>@#@$) t) t :: (~>) a b) - (%<<>>) (sF :: Sing f) (sG :: Sing g) - = (singFun1 @(Apply (Apply Lambda_0123456789876543210Sym0 f) g)) - (\ sX - -> case sX of { - (_ :: Sing x) - -> (applySing - ((applySing ((singFun2 @(<<>>@#@$)) (%<<>>))) ((applySing sF) sX))) - ((applySing sG) sX) }) - instance SS a => SingI ((<<>>@#@$) :: (~>) a ((~>) a a)) where - sing = (singFun2 @(<<>>@#@$)) (%<<>>) - instance (SS a, SingI d) => - SingI ((<<>>@#@$$) (d :: a) :: (~>) a a) where - sing = (singFun1 @((<<>>@#@$$) (d :: a))) ((%<<>>) (sing @d)) diff --git a/tests/compile-and-dump/Singletons/T287.hs b/tests/compile-and-dump/Singletons/T287.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T287.hs +++ /dev/null @@ -1,11 +0,0 @@ -module T287 where - -import Data.Singletons.TH - -$(singletons [d| - class S a where - (<<>>) :: a -> a -> a - - instance S b => S (a -> b) where - f <<>> g = \x -> f x <<>> g x - |]) diff --git a/tests/compile-and-dump/Singletons/T29.ghc88.template b/tests/compile-and-dump/Singletons/T29.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T29.ghc88.template +++ /dev/null @@ -1,115 +0,0 @@ -Singletons/T29.hs:(0,0)-(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 |] - ======> - 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 (a0123456789876543210 :: Bool) = - Ban a0123456789876543210 - instance SuppressUnusedWarnings BanSym0 where - suppressUnusedWarnings = snd (((,) BanSym0KindInference) ()) - data BanSym0 :: (~>) Bool Bool - where - BanSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply BanSym0 arg) (BanSym1 arg) => - BanSym0 a0123456789876543210 - type instance Apply BanSym0 a0123456789876543210 = Ban a0123456789876543210 - type BazSym1 (a0123456789876543210 :: Bool) = - Baz a0123456789876543210 - instance SuppressUnusedWarnings BazSym0 where - suppressUnusedWarnings = snd (((,) BazSym0KindInference) ()) - data BazSym0 :: (~>) Bool Bool - where - BazSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply BazSym0 arg) (BazSym1 arg) => - BazSym0 a0123456789876543210 - type instance Apply BazSym0 a0123456789876543210 = Baz a0123456789876543210 - type BarSym1 (a0123456789876543210 :: Bool) = - Bar a0123456789876543210 - instance SuppressUnusedWarnings BarSym0 where - suppressUnusedWarnings = snd (((,) BarSym0KindInference) ()) - data BarSym0 :: (~>) Bool Bool - where - BarSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply BarSym0 arg) (BarSym1 arg) => - BarSym0 a0123456789876543210 - type instance Apply BarSym0 a0123456789876543210 = Bar a0123456789876543210 - type FooSym1 (a0123456789876543210 :: Bool) = - Foo a0123456789876543210 - instance SuppressUnusedWarnings FooSym0 where - suppressUnusedWarnings = snd (((,) FooSym0KindInference) ()) - data FooSym0 :: (~>) Bool Bool - where - FooSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply FooSym0 arg) (FooSym1 arg) => - FooSym0 a0123456789876543210 - type instance Apply FooSym0 a0123456789876543210 = Foo a0123456789876543210 - 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 :: Bool) - sBaz :: - forall (t :: Bool). Sing t -> Sing (Apply BazSym0 t :: Bool) - sBar :: - forall (t :: Bool). Sing t -> Sing (Apply BarSym0 t :: Bool) - sFoo :: - forall (t :: Bool). Sing t -> Sing (Apply FooSym0 t :: Bool) - sBan (sX :: Sing x) - = (applySing - ((applySing ((singFun2 @($!@#@$)) (%$!))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((singFun1 @NotSym0) sNot))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((singFun1 @NotSym0) sNot))) - ((singFun1 @NotSym0) sNot))))) - sX - sBaz (sX :: Sing x) - = (applySing - ((applySing ((singFun2 @($!@#@$)) (%$!))) - ((singFun1 @NotSym0) sNot))) - sX - sBar (sX :: Sing x) - = (applySing - ((applySing ((singFun2 @($@#@$)) (%$))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((singFun1 @NotSym0) sNot))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((singFun1 @NotSym0) sNot))) - ((singFun1 @NotSym0) sNot))))) - sX - sFoo (sX :: Sing x) - = (applySing - ((applySing ((singFun2 @($@#@$)) (%$))) - ((singFun1 @NotSym0) sNot))) - sX - instance SingI (BanSym0 :: (~>) Bool Bool) where - sing = (singFun1 @BanSym0) sBan - instance SingI (BazSym0 :: (~>) Bool Bool) where - sing = (singFun1 @BazSym0) sBaz - instance SingI (BarSym0 :: (~>) Bool Bool) where - sing = (singFun1 @BarSym0) sBar - instance SingI (FooSym0 :: (~>) Bool Bool) where - sing = (singFun1 @FooSym0) sFoo diff --git a/tests/compile-and-dump/Singletons/T29.hs b/tests/compile-and-dump/Singletons/T29.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T29.hs +++ /dev/null @@ -1,44 +0,0 @@ -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/T297.ghc88.template b/tests/compile-and-dump/Singletons/T297.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T297.ghc88.template +++ /dev/null @@ -1,59 +0,0 @@ -Singletons/T297.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| f MyProxy - = let - x = let - z :: MyProxy a - z = MyProxy - in z - in x - - data MyProxy (a :: Type) = MyProxy |] - ======> - data MyProxy (a :: Type) = MyProxy - f MyProxy - = let - x = let - z :: MyProxy a - z = MyProxy - in z - in x - type MyProxySym0 = MyProxy - type Let0123456789876543210ZSym0 = Let0123456789876543210Z - type family Let0123456789876543210Z :: MyProxy a where - Let0123456789876543210Z = MyProxySym0 - type Let0123456789876543210XSym0 = Let0123456789876543210X - type family Let0123456789876543210X where - Let0123456789876543210X = Let0123456789876543210ZSym0 - type FSym1 a0123456789876543210 = F a0123456789876543210 - instance SuppressUnusedWarnings FSym0 where - suppressUnusedWarnings = snd (((,) FSym0KindInference) ()) - data FSym0 a0123456789876543210 - where - FSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply FSym0 arg) (FSym1 arg) => - FSym0 a0123456789876543210 - type instance Apply FSym0 a0123456789876543210 = F a0123456789876543210 - type family F a where - F MyProxy = Let0123456789876543210XSym0 - sF :: forall arg. Sing arg -> Sing (Apply FSym0 arg) - sF SMyProxy - = let - sX :: Sing Let0123456789876543210XSym0 - sX - = let - sZ :: forall a. Sing (Let0123456789876543210ZSym0 :: MyProxy a) - sZ = SMyProxy - in sZ - in sX - instance SingI FSym0 where - sing = (singFun1 @FSym0) sF - data SMyProxy :: forall a. MyProxy a -> Type - where SMyProxy :: SMyProxy MyProxy - type instance Sing @(MyProxy a) = SMyProxy - instance SingKind a => SingKind (MyProxy a) where - type Demote (MyProxy a) = MyProxy (Demote a) - fromSing SMyProxy = MyProxy - toSing MyProxy = SomeSing SMyProxy - instance SingI MyProxy where - sing = SMyProxy diff --git a/tests/compile-and-dump/Singletons/T297.hs b/tests/compile-and-dump/Singletons/T297.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T297.hs +++ /dev/null @@ -1,13 +0,0 @@ -module T297 where - -import Data.Kind -import Data.Singletons.TH - -$(singletons [d| - data MyProxy (a :: Type) = MyProxy - - f MyProxy = - let x = let z :: MyProxy a -- When singled, this `a` should be explicitly quantified - z = MyProxy in z - in x - |]) diff --git a/tests/compile-and-dump/Singletons/T312.ghc88.template b/tests/compile-and-dump/Singletons/T312.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T312.ghc88.template +++ /dev/null @@ -1,215 +0,0 @@ -Singletons/T312.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| class Foo a where - bar :: a -> b -> b - bar _ x = x - baz :: forall b. a -> b -> b - baz - = h - where - h :: forall c. c -> b -> b - h _ x = x |] - ======> - class Foo a where - bar :: a -> b -> b - baz :: forall b. a -> b -> b - bar _ x = x - baz - = h - where - h :: forall c. c -> b -> b - h _ x = x - type BarSym2 (arg0123456789876543210 :: a0123456789876543210) (arg0123456789876543210 :: b0123456789876543210) = - Bar arg0123456789876543210 arg0123456789876543210 - instance SuppressUnusedWarnings (BarSym1 arg0123456789876543210) where - suppressUnusedWarnings = snd (((,) BarSym1KindInference) ()) - data BarSym1 (arg0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210. - (~>) b0123456789876543210 b0123456789876543210 - where - BarSym1KindInference :: forall arg0123456789876543210 - arg0123456789876543210 - arg. SameKind (Apply (BarSym1 arg0123456789876543210) arg) (BarSym2 arg0123456789876543210 arg) => - BarSym1 arg0123456789876543210 arg0123456789876543210 - type instance Apply (BarSym1 arg0123456789876543210) arg0123456789876543210 = Bar arg0123456789876543210 arg0123456789876543210 - instance SuppressUnusedWarnings BarSym0 where - suppressUnusedWarnings = snd (((,) BarSym0KindInference) ()) - data BarSym0 :: forall a0123456789876543210 b0123456789876543210. - (~>) a0123456789876543210 ((~>) b0123456789876543210 b0123456789876543210) - where - BarSym0KindInference :: forall arg0123456789876543210 - arg. SameKind (Apply BarSym0 arg) (BarSym1 arg) => - BarSym0 arg0123456789876543210 - type instance Apply BarSym0 arg0123456789876543210 = BarSym1 arg0123456789876543210 - type BazSym2 (arg0123456789876543210 :: a0123456789876543210) (arg0123456789876543210 :: b0123456789876543210) = - Baz arg0123456789876543210 arg0123456789876543210 - instance SuppressUnusedWarnings (BazSym1 arg0123456789876543210) where - suppressUnusedWarnings = snd (((,) BazSym1KindInference) ()) - data BazSym1 (arg0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210. - (~>) b0123456789876543210 b0123456789876543210 - where - BazSym1KindInference :: forall arg0123456789876543210 - arg0123456789876543210 - arg. SameKind (Apply (BazSym1 arg0123456789876543210) arg) (BazSym2 arg0123456789876543210 arg) => - BazSym1 arg0123456789876543210 arg0123456789876543210 - type instance Apply (BazSym1 arg0123456789876543210) arg0123456789876543210 = Baz arg0123456789876543210 arg0123456789876543210 - instance SuppressUnusedWarnings BazSym0 where - suppressUnusedWarnings = snd (((,) BazSym0KindInference) ()) - data BazSym0 :: forall a0123456789876543210 b0123456789876543210. - (~>) a0123456789876543210 ((~>) b0123456789876543210 b0123456789876543210) - where - BazSym0KindInference :: forall arg0123456789876543210 - arg. SameKind (Apply BazSym0 arg) (BazSym1 arg) => - BazSym0 arg0123456789876543210 - type instance Apply BazSym0 arg0123456789876543210 = BazSym1 arg0123456789876543210 - type family Bar_0123456789876543210 (a :: a) (a :: b) :: b where - Bar_0123456789876543210 _ x = x - type Bar_0123456789876543210Sym2 (a0123456789876543210 :: a0123456789876543210) (a0123456789876543210 :: b0123456789876543210) = - Bar_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Bar_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Bar_0123456789876543210Sym1KindInference) ()) - data Bar_0123456789876543210Sym1 (a0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210. - (~>) b0123456789876543210 b0123456789876543210 - where - Bar_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Bar_0123456789876543210Sym1 a0123456789876543210) arg) (Bar_0123456789876543210Sym2 a0123456789876543210 arg) => - Bar_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Bar_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Bar_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Bar_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Bar_0123456789876543210Sym0KindInference) ()) - data Bar_0123456789876543210Sym0 :: forall a0123456789876543210 - b0123456789876543210. - (~>) a0123456789876543210 ((~>) b0123456789876543210 b0123456789876543210) - where - Bar_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Bar_0123456789876543210Sym0 arg) (Bar_0123456789876543210Sym1 arg) => - Bar_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Bar_0123456789876543210Sym0 a0123456789876543210 = Bar_0123456789876543210Sym1 a0123456789876543210 - type Let0123456789876543210HSym4 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 (a0123456789876543210 :: c0123456789876543210) (a0123456789876543210 :: b0123456789876543210) = - Let0123456789876543210H a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210HSym3 a0123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210HSym3KindInference) ()) - data Let0123456789876543210HSym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 (a0123456789876543210 :: c0123456789876543210) :: forall b0123456789876543210. - (~>) b0123456789876543210 b0123456789876543210 - where - Let0123456789876543210HSym3KindInference :: forall a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Let0123456789876543210HSym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a0123456789876543210) arg) (Let0123456789876543210HSym4 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a0123456789876543210 arg) => - Let0123456789876543210HSym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (Let0123456789876543210HSym3 a0123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) a0123456789876543210 = Let0123456789876543210H a0123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210HSym2 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210HSym2KindInference) ()) - data Let0123456789876543210HSym2 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 :: forall c0123456789876543210 - b0123456789876543210. - (~>) c0123456789876543210 ((~>) b0123456789876543210 b0123456789876543210) - where - Let0123456789876543210HSym2KindInference :: forall a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Let0123456789876543210HSym2 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Let0123456789876543210HSym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Let0123456789876543210HSym2 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a0123456789876543210 - type instance Apply (Let0123456789876543210HSym2 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) a0123456789876543210 = Let0123456789876543210HSym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210HSym1 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210HSym1KindInference) ()) - data Let0123456789876543210HSym1 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Let0123456789876543210HSym1KindInference :: forall a_01234567898765432100123456789876543210 - a_01234567898765432100123456789876543210 - arg. SameKind (Apply (Let0123456789876543210HSym1 a_01234567898765432100123456789876543210) arg) (Let0123456789876543210HSym2 a_01234567898765432100123456789876543210 arg) => - Let0123456789876543210HSym1 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - type instance Apply (Let0123456789876543210HSym1 a_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Let0123456789876543210HSym2 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210HSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210HSym0KindInference) ()) - data Let0123456789876543210HSym0 a_01234567898765432100123456789876543210 - where - Let0123456789876543210HSym0KindInference :: forall a_01234567898765432100123456789876543210 - arg. SameKind (Apply Let0123456789876543210HSym0 arg) (Let0123456789876543210HSym1 arg) => - Let0123456789876543210HSym0 a_01234567898765432100123456789876543210 - type instance Apply Let0123456789876543210HSym0 a_01234567898765432100123456789876543210 = Let0123456789876543210HSym1 a_01234567898765432100123456789876543210 - type family Let0123456789876543210H a_0123456789876543210 a_0123456789876543210 (a :: c) (a :: b) :: b where - Let0123456789876543210H a_0123456789876543210 a_0123456789876543210 _ x = x - type family Baz_0123456789876543210 (a :: a) (a :: b) :: b where - Baz_0123456789876543210 a_0123456789876543210 a_0123456789876543210 = Apply (Apply (Let0123456789876543210HSym2 a_0123456789876543210 a_0123456789876543210) a_0123456789876543210) a_0123456789876543210 - type Baz_0123456789876543210Sym2 (a0123456789876543210 :: a0123456789876543210) (a0123456789876543210 :: b0123456789876543210) = - Baz_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Baz_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Baz_0123456789876543210Sym1KindInference) ()) - data Baz_0123456789876543210Sym1 (a0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210. - (~>) b0123456789876543210 b0123456789876543210 - where - Baz_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Baz_0123456789876543210Sym1 a0123456789876543210) arg) (Baz_0123456789876543210Sym2 a0123456789876543210 arg) => - Baz_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Baz_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Baz_0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Baz_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Baz_0123456789876543210Sym0KindInference) ()) - data Baz_0123456789876543210Sym0 :: forall a0123456789876543210 - b0123456789876543210. - (~>) a0123456789876543210 ((~>) b0123456789876543210 b0123456789876543210) - where - Baz_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Baz_0123456789876543210Sym0 arg) (Baz_0123456789876543210Sym1 arg) => - Baz_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Baz_0123456789876543210Sym0 a0123456789876543210 = Baz_0123456789876543210Sym1 a0123456789876543210 - class PFoo (a :: GHC.Types.Type) where - type Bar (arg :: a) (arg :: b) :: b - type Baz (arg :: a) (arg :: b) :: b - type Bar a a = Apply (Apply Bar_0123456789876543210Sym0 a) a - type Baz a a = Apply (Apply Baz_0123456789876543210Sym0 a) a - class SFoo a where - sBar :: - forall b (t :: a) (t :: b). - Sing t -> Sing t -> Sing (Apply (Apply BarSym0 t) t :: b) - sBaz :: - forall b (t :: a) (t :: b). - Sing t -> Sing t -> Sing (Apply (Apply BazSym0 t) t :: b) - default sBar :: - forall b (t :: a) (t :: b). - ((Apply (Apply BarSym0 t) t :: b) - ~ Apply (Apply Bar_0123456789876543210Sym0 t) t) => - Sing t -> Sing t -> Sing (Apply (Apply BarSym0 t) t :: b) - default sBaz :: - forall b (t :: a) (t :: b). - ((Apply (Apply BazSym0 t) t :: b) - ~ Apply (Apply Baz_0123456789876543210Sym0 t) t) => - Sing t -> Sing t -> Sing (Apply (Apply BazSym0 t) t :: b) - sBar _ (sX :: Sing x) = sX - sBaz - (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing - (let - sH :: - forall c (t :: c) (t :: b). - Sing t - -> Sing t - -> Sing (Apply (Apply (Let0123456789876543210HSym2 a_0123456789876543210 a_0123456789876543210) t) t :: b) - sH _ (sX :: Sing x) = sX - in - (singFun2 - @(Let0123456789876543210HSym2 a_0123456789876543210 a_0123456789876543210)) - sH)) - sA_0123456789876543210)) - sA_0123456789876543210 - instance SFoo a => SingI (BarSym0 :: (~>) a ((~>) b b)) where - sing = (singFun2 @BarSym0) sBar - instance (SFoo a, SingI d) => - SingI (BarSym1 (d :: a) :: (~>) b b) where - sing = (singFun1 @(BarSym1 (d :: a))) (sBar (sing @d)) - instance SFoo a => SingI (BazSym0 :: (~>) a ((~>) b b)) where - sing = (singFun2 @BazSym0) sBaz - instance (SFoo a, SingI d) => - SingI (BazSym1 (d :: a) :: (~>) b b) where - sing = (singFun1 @(BazSym1 (d :: a))) (sBaz (sing @d)) diff --git a/tests/compile-and-dump/Singletons/T312.hs b/tests/compile-and-dump/Singletons/T312.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T312.hs +++ /dev/null @@ -1,14 +0,0 @@ -module T312 where - -import Data.Singletons.TH - -$(singletons [d| - class Foo a where - bar :: a -> b -> b - bar _ x = x - - baz :: forall b. a -> b -> b - baz = h where - h :: forall c. c -> b -> b - h _ x = x - |]) diff --git a/tests/compile-and-dump/Singletons/T313.ghc88.template b/tests/compile-and-dump/Singletons/T313.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T313.ghc88.template +++ /dev/null @@ -1,130 +0,0 @@ -Singletons/T313.hs:(0,0)-(0,0): Splicing declarations - promote - [d| type PFoo1 a = Maybe a - type family PFoo2 a - type family PFoo3 a where - PFoo3 a = Maybe a - class PC (a :: Type) where - type PFoo4 a - type PFoo4 a = Maybe a - - type instance PFoo2 a = Maybe a - instance PC a where - type PFoo4 a = Maybe a |] - ======> - type PFoo1 a = Maybe a - type family PFoo2 a - type instance PFoo2 a = Maybe a - type family PFoo3 a where - PFoo3 a = Maybe a - class PC (a :: Type) where - type PFoo4 a - type PFoo4 a = Maybe a - instance PC a where - type PFoo4 a = Maybe a - type PFoo1Sym1 a0123456789876543210 = PFoo1 a0123456789876543210 - instance SuppressUnusedWarnings PFoo1Sym0 where - suppressUnusedWarnings = snd (((,) PFoo1Sym0KindInference) ()) - data PFoo1Sym0 a0123456789876543210 - where - PFoo1Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply PFoo1Sym0 arg) (PFoo1Sym1 arg) => - PFoo1Sym0 a0123456789876543210 - type instance Apply PFoo1Sym0 a0123456789876543210 = PFoo1 a0123456789876543210 - type PFoo3Sym1 a0123456789876543210 = PFoo3 a0123456789876543210 - instance SuppressUnusedWarnings PFoo3Sym0 where - suppressUnusedWarnings = snd (((,) PFoo3Sym0KindInference) ()) - data PFoo3Sym0 a0123456789876543210 - where - PFoo3Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply PFoo3Sym0 arg) (PFoo3Sym1 arg) => - PFoo3Sym0 a0123456789876543210 - type instance Apply PFoo3Sym0 a0123456789876543210 = PFoo3 a0123456789876543210 - type PFoo2Sym1 (a0123456789876543210 :: Type) = - PFoo2 a0123456789876543210 - instance SuppressUnusedWarnings PFoo2Sym0 where - suppressUnusedWarnings = snd (((,) PFoo2Sym0KindInference) ()) - data PFoo2Sym0 :: (~>) Type Type - where - PFoo2Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply PFoo2Sym0 arg) (PFoo2Sym1 arg) => - PFoo2Sym0 a0123456789876543210 - type instance Apply PFoo2Sym0 a0123456789876543210 = PFoo2 a0123456789876543210 - type PFoo4Sym1 (a0123456789876543210 :: Type) = - PFoo4 a0123456789876543210 - instance SuppressUnusedWarnings PFoo4Sym0 where - suppressUnusedWarnings = snd (((,) PFoo4Sym0KindInference) ()) - data PFoo4Sym0 :: (~>) Type Type - where - PFoo4Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply PFoo4Sym0 arg) (PFoo4Sym1 arg) => - PFoo4Sym0 a0123456789876543210 - type instance Apply PFoo4Sym0 a0123456789876543210 = PFoo4 a0123456789876543210 - class PPC (a :: Type) - instance PPC a -Singletons/T313.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| type SFoo1 a = Maybe a - type family SFoo2 a - type family SFoo3 a where - SFoo3 a = Maybe a - class SC (a :: Type) where - type SFoo4 a - type SFoo4 a = Maybe a - - type instance SFoo2 a = Maybe a - instance SC a where - type SFoo4 a = Maybe a |] - ======> - type SFoo1 a = Maybe a - type family SFoo2 a - type instance SFoo2 a = Maybe a - type family SFoo3 a where - SFoo3 a = Maybe a - class SC (a :: Type) where - type SFoo4 a - type SFoo4 a = Maybe a - instance SC a where - type SFoo4 a = Maybe a - type SFoo1Sym1 a0123456789876543210 = SFoo1 a0123456789876543210 - instance SuppressUnusedWarnings SFoo1Sym0 where - suppressUnusedWarnings = snd (((,) SFoo1Sym0KindInference) ()) - data SFoo1Sym0 a0123456789876543210 - where - SFoo1Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply SFoo1Sym0 arg) (SFoo1Sym1 arg) => - SFoo1Sym0 a0123456789876543210 - type instance Apply SFoo1Sym0 a0123456789876543210 = SFoo1 a0123456789876543210 - type SFoo3Sym1 a0123456789876543210 = SFoo3 a0123456789876543210 - instance SuppressUnusedWarnings SFoo3Sym0 where - suppressUnusedWarnings = snd (((,) SFoo3Sym0KindInference) ()) - data SFoo3Sym0 a0123456789876543210 - where - SFoo3Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply SFoo3Sym0 arg) (SFoo3Sym1 arg) => - SFoo3Sym0 a0123456789876543210 - type instance Apply SFoo3Sym0 a0123456789876543210 = SFoo3 a0123456789876543210 - type SFoo2Sym1 (a0123456789876543210 :: Type) = - SFoo2 a0123456789876543210 - instance SuppressUnusedWarnings SFoo2Sym0 where - suppressUnusedWarnings = snd (((,) SFoo2Sym0KindInference) ()) - data SFoo2Sym0 :: (~>) Type Type - where - SFoo2Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply SFoo2Sym0 arg) (SFoo2Sym1 arg) => - SFoo2Sym0 a0123456789876543210 - type instance Apply SFoo2Sym0 a0123456789876543210 = SFoo2 a0123456789876543210 - type SFoo4Sym1 (a0123456789876543210 :: Type) = - SFoo4 a0123456789876543210 - instance SuppressUnusedWarnings SFoo4Sym0 where - suppressUnusedWarnings = snd (((,) SFoo4Sym0KindInference) ()) - data SFoo4Sym0 :: (~>) Type Type - where - SFoo4Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply SFoo4Sym0 arg) (SFoo4Sym1 arg) => - SFoo4Sym0 a0123456789876543210 - type instance Apply SFoo4Sym0 a0123456789876543210 = SFoo4 a0123456789876543210 - class PSC (a :: Type) - instance PSC a - class SSC (a :: Type) - instance SSC a diff --git a/tests/compile-and-dump/Singletons/T313.hs b/tests/compile-and-dump/Singletons/T313.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T313.hs +++ /dev/null @@ -1,38 +0,0 @@ -module T313 where - -import Data.Kind -import Data.Singletons.TH - -$(promote [d| - type PFoo1 a = Maybe a - - type family PFoo2 a - type instance PFoo2 a = Maybe a - - type family PFoo3 a where - PFoo3 a = Maybe a - - class PC (a :: Type) where - type PFoo4 a - type PFoo4 a = Maybe a - - instance PC a where - type PFoo4 a = Maybe a - |]) - -$(singletons [d| - type SFoo1 a = Maybe a - - type family SFoo2 a - type instance SFoo2 a = Maybe a - - type family SFoo3 a where - SFoo3 a = Maybe a - - class SC (a :: Type) where - type SFoo4 a - type SFoo4 a = Maybe a - - instance SC a where - type SFoo4 a = Maybe a - |]) diff --git a/tests/compile-and-dump/Singletons/T316.ghc88.template b/tests/compile-and-dump/Singletons/T316.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T316.ghc88.template +++ /dev/null @@ -1,40 +0,0 @@ -Singletons/T316.hs:(0,0)-(0,0): Splicing declarations - promoteOnly - [d| replaceAllGTypes :: (a -> Type -> a) -> [Type] -> [a] -> [a] - replaceAllGTypes f types as = zipWith f as types |] - ======> - type ReplaceAllGTypesSym3 (a0123456789876543210 :: (~>) a0123456789876543210 ((~>) Type a0123456789876543210)) (a0123456789876543210 :: [Type]) (a0123456789876543210 :: [a0123456789876543210]) = - ReplaceAllGTypes a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ReplaceAllGTypesSym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ReplaceAllGTypesSym2KindInference) ()) - data ReplaceAllGTypesSym2 (a0123456789876543210 :: (~>) a0123456789876543210 ((~>) Type a0123456789876543210)) (a0123456789876543210 :: [Type]) :: (~>) [a0123456789876543210] [a0123456789876543210] - where - ReplaceAllGTypesSym2KindInference :: forall a0123456789876543210 - a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ReplaceAllGTypesSym2 a0123456789876543210 a0123456789876543210) arg) (ReplaceAllGTypesSym3 a0123456789876543210 a0123456789876543210 arg) => - ReplaceAllGTypesSym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (ReplaceAllGTypesSym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = ReplaceAllGTypes a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ReplaceAllGTypesSym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ReplaceAllGTypesSym1KindInference) ()) - data ReplaceAllGTypesSym1 (a0123456789876543210 :: (~>) a0123456789876543210 ((~>) Type a0123456789876543210)) :: (~>) [Type] ((~>) [a0123456789876543210] [a0123456789876543210]) - where - ReplaceAllGTypesSym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ReplaceAllGTypesSym1 a0123456789876543210) arg) (ReplaceAllGTypesSym2 a0123456789876543210 arg) => - ReplaceAllGTypesSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (ReplaceAllGTypesSym1 a0123456789876543210) a0123456789876543210 = ReplaceAllGTypesSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ReplaceAllGTypesSym0 where - suppressUnusedWarnings - = snd (((,) ReplaceAllGTypesSym0KindInference) ()) - data ReplaceAllGTypesSym0 :: forall a0123456789876543210. - (~>) ((~>) a0123456789876543210 ((~>) Type a0123456789876543210)) ((~>) [Type] ((~>) [a0123456789876543210] [a0123456789876543210])) - where - ReplaceAllGTypesSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply ReplaceAllGTypesSym0 arg) (ReplaceAllGTypesSym1 arg) => - ReplaceAllGTypesSym0 a0123456789876543210 - type instance Apply ReplaceAllGTypesSym0 a0123456789876543210 = ReplaceAllGTypesSym1 a0123456789876543210 - type family ReplaceAllGTypes (a :: (~>) a ((~>) Type a)) (a :: [Type]) (a :: [a]) :: [a] where - ReplaceAllGTypes f types as = Apply (Apply (Apply ZipWithSym0 f) as) types diff --git a/tests/compile-and-dump/Singletons/T316.hs b/tests/compile-and-dump/Singletons/T316.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T316.hs +++ /dev/null @@ -1,10 +0,0 @@ -module T316 where - -import Data.Kind -import Data.Singletons.Prelude -import Data.Singletons.TH - -$(promoteOnly [d| - replaceAllGTypes :: (a -> Type -> a) -> [Type] -> [a] -> [a] - replaceAllGTypes f types as = zipWith f as types - |]) diff --git a/tests/compile-and-dump/Singletons/T322.ghc88.template b/tests/compile-and-dump/Singletons/T322.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T322.ghc88.template +++ /dev/null @@ -1,48 +0,0 @@ -Singletons/T322.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| infixr 2 ! - - (!) :: Bool -> Bool -> Bool - (!) = (||) |] - ======> - (!) :: Bool -> Bool -> Bool - (!) = (||) - infixr 2 ! - type (!@#@$$$) (a0123456789876543210 :: Bool) (a0123456789876543210 :: Bool) = - (!) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((!@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (:!@#@$$###)) ()) - data (!@#@$$) (a0123456789876543210 :: Bool) :: (~>) Bool Bool - where - (:!@#@$$###) :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply ((!@#@$$) a0123456789876543210) arg) ((!@#@$$$) a0123456789876543210 arg) => - (!@#@$$) a0123456789876543210 a0123456789876543210 - type instance Apply ((!@#@$$) a0123456789876543210) a0123456789876543210 = (!) a0123456789876543210 a0123456789876543210 - infixr 2 !@#@$$ - instance SuppressUnusedWarnings (!@#@$) where - suppressUnusedWarnings = snd (((,) (:!@#@$###)) ()) - data (!@#@$) :: (~>) Bool ((~>) Bool Bool) - where - (:!@#@$###) :: forall a0123456789876543210 - arg. SameKind (Apply (!@#@$) arg) ((!@#@$$) arg) => - (!@#@$) a0123456789876543210 - type instance Apply (!@#@$) a0123456789876543210 = (!@#@$$) a0123456789876543210 - infixr 2 !@#@$ - type family (!) (a :: Bool) (a :: Bool) :: Bool where - (!) a_0123456789876543210 a_0123456789876543210 = Apply (Apply (||@#@$) a_0123456789876543210) a_0123456789876543210 - infixr 2 %! - (%!) :: - forall (t :: Bool) (t :: Bool). - Sing t -> Sing t -> Sing (Apply (Apply (!@#@$) t) t :: Bool) - (%!) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @(||@#@$)) (%||))) sA_0123456789876543210)) - sA_0123456789876543210 - instance SingI ((!@#@$) :: (~>) Bool ((~>) Bool Bool)) where - sing = (singFun2 @(!@#@$)) (%!) - instance SingI d => - SingI ((!@#@$$) (d :: Bool) :: (~>) Bool Bool) where - sing = (singFun1 @((!@#@$$) (d :: Bool))) ((%!) (sing @d)) diff --git a/tests/compile-and-dump/Singletons/T322.hs b/tests/compile-and-dump/Singletons/T322.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T322.hs +++ /dev/null @@ -1,13 +0,0 @@ -module T322 where - -import Data.Singletons.Prelude -import Data.Singletons.TH - -$(singletons [d| - (!) :: Bool -> Bool -> Bool - (!) = (||) - infixr 2 ! - |]) - -f1 :: (False && True ! True) :~: True -f1 = Refl diff --git a/tests/compile-and-dump/Singletons/T323.ghc88.template b/tests/compile-and-dump/Singletons/T323.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T323.ghc88.template +++ /dev/null diff --git a/tests/compile-and-dump/Singletons/T323.hs b/tests/compile-and-dump/Singletons/T323.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T323.hs +++ /dev/null @@ -1,7 +0,0 @@ -module T323 where - -import Data.Singletons.Prelude -import Data.Type.Equality - -test :: f .@#@$$$ (g .@#@$$$ h) :~: f .@#@$$$ g .@#@$$$ h -test = Refl diff --git a/tests/compile-and-dump/Singletons/T33.ghc88.template b/tests/compile-and-dump/Singletons/T33.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T33.ghc88.template +++ /dev/null @@ -1,36 +0,0 @@ -Singletons/T33.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| foo :: (Bool, Bool) -> () - foo ~(_, _) = () |] - ======> - foo :: (Bool, Bool) -> () - foo ~(_, _) = () - type FooSym1 (a0123456789876543210 :: (Bool, Bool)) = - Foo a0123456789876543210 - instance SuppressUnusedWarnings FooSym0 where - suppressUnusedWarnings = snd (((,) FooSym0KindInference) ()) - data FooSym0 :: (~>) (Bool, Bool) () - where - FooSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply FooSym0 arg) (FooSym1 arg) => - FooSym0 a0123456789876543210 - type instance Apply FooSym0 a0123456789876543210 = Foo a0123456789876543210 - type family Foo (a :: (Bool, Bool)) :: () where - Foo '(_, _) = Tuple0Sym0 - sFoo :: - forall (t :: (Bool, Bool)). Sing t -> Sing (Apply FooSym0 t :: ()) - sFoo (STuple2 _ _) = STuple0 - instance SingI (FooSym0 :: (~>) (Bool, Bool) ()) where - sing = (singFun1 @FooSym0) sFoo - -Singletons/T33.hs:0:0: warning: - Lazy pattern converted into regular pattern in promotion - | -6 | $(singletons [d| - | ^^^^^^^^^^^^^^... - -Singletons/T33.hs:0:0: warning: - Lazy pattern converted into regular pattern during singleton generation. - | -6 | $(singletons [d| - | ^^^^^^^^^^^^^^... diff --git a/tests/compile-and-dump/Singletons/T33.hs b/tests/compile-and-dump/Singletons/T33.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T33.hs +++ /dev/null @@ -1,9 +0,0 @@ -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/T332.ghc88.template b/tests/compile-and-dump/Singletons/T332.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T332.ghc88.template +++ /dev/null @@ -1,56 +0,0 @@ -Singletons/T332.hs:(0,0)-(0,0): Splicing declarations - promote - [d| f :: Foo -> () - f MkFoo {} = () - - data Foo = MkFoo |] - ======> - data Foo = MkFoo - f :: Foo -> () - f MkFoo {} = () - type FSym1 (a0123456789876543210 :: Foo) = F a0123456789876543210 - instance SuppressUnusedWarnings FSym0 where - suppressUnusedWarnings = snd (((,) FSym0KindInference) ()) - data FSym0 :: (~>) Foo () - where - FSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply FSym0 arg) (FSym1 arg) => - FSym0 a0123456789876543210 - type instance Apply FSym0 a0123456789876543210 = F a0123456789876543210 - type family F (a :: Foo) :: () where - F MkFoo = Tuple0Sym0 - type MkFooSym0 = MkFoo -Singletons/T332.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| b :: Bar -> () - b MkBar {} = () - - data Bar = MkBar |] - ======> - data Bar = MkBar - b :: Bar -> () - b MkBar {} = () - type MkBarSym0 = MkBar - type BSym1 (a0123456789876543210 :: Bar) = B a0123456789876543210 - instance SuppressUnusedWarnings BSym0 where - suppressUnusedWarnings = snd (((,) BSym0KindInference) ()) - data BSym0 :: (~>) Bar () - where - BSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply BSym0 arg) (BSym1 arg) => - BSym0 a0123456789876543210 - type instance Apply BSym0 a0123456789876543210 = B a0123456789876543210 - type family B (a :: Bar) :: () where - B MkBar = Tuple0Sym0 - sB :: forall (t :: Bar). Sing t -> Sing (Apply BSym0 t :: ()) - sB SMkBar = STuple0 - instance SingI (BSym0 :: (~>) Bar ()) where - sing = (singFun1 @BSym0) sB - data SBar :: Bar -> GHC.Types.Type where SMkBar :: SBar MkBar - type instance Sing @Bar = SBar - instance SingKind Bar where - type Demote Bar = Bar - fromSing SMkBar = MkBar - toSing MkBar = SomeSing SMkBar - instance SingI MkBar where - sing = SMkBar diff --git a/tests/compile-and-dump/Singletons/T332.hs b/tests/compile-and-dump/Singletons/T332.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T332.hs +++ /dev/null @@ -1,17 +0,0 @@ -module T332 where - -import Data.Singletons.TH - -$(promote [d| - data Foo = MkFoo - - f :: Foo -> () - f MkFoo{} = () - |]) - -$(singletons [d| - data Bar = MkBar - - b :: Bar -> () - b MkBar{} = () - |]) diff --git a/tests/compile-and-dump/Singletons/T342.ghc88.template b/tests/compile-and-dump/Singletons/T342.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T342.ghc88.template +++ /dev/null @@ -1,17 +0,0 @@ -Singletons/T342.hs:(0,0)-(0,0): Splicing declarations - do synName <- newName "MyId" - a <- newName "a" - let syn = TySynD synName [PlainTV a] (VarT a) - defuns <- withLocalDeclarations [syn] $ genDefunSymbols [synName] - pure $ syn : defuns - ======> - type MyId a = a - type MyIdSym1 a0123456789876543210 = MyId a0123456789876543210 - instance SuppressUnusedWarnings MyIdSym0 where - suppressUnusedWarnings = snd (((,) MyIdSym0KindInference) ()) - data MyIdSym0 a0123456789876543210 - where - MyIdSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply MyIdSym0 arg) (MyIdSym1 arg) => - MyIdSym0 a0123456789876543210 - type instance Apply MyIdSym0 a0123456789876543210 = MyId a0123456789876543210 diff --git a/tests/compile-and-dump/Singletons/T342.hs b/tests/compile-and-dump/Singletons/T342.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T342.hs +++ /dev/null @@ -1,12 +0,0 @@ -module T342 where - -import Data.Singletons.TH -import Language.Haskell.TH -import Language.Haskell.TH.Desugar - -$(do synName <- newName "MyId" - a <- newName "a" - let syn = TySynD synName [PlainTV a] (VarT a) - defuns <- withLocalDeclarations [syn] $ - genDefunSymbols [synName] - pure $ syn:defuns) diff --git a/tests/compile-and-dump/Singletons/T353.ghc88.template b/tests/compile-and-dump/Singletons/T353.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T353.ghc88.template +++ /dev/null @@ -1,104 +0,0 @@ -Singletons/T353.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| type family Symmetry (a :: Proxy t) (y :: Proxy t) (e :: (a :: Proxy (t :: k)) - :~: - (y :: Proxy (t :: k))) :: Type where - Symmetry a y _ = y :~: a |] - ======> - type family Symmetry (a :: Proxy t) (y :: Proxy t) (e :: (:~:) (a :: Proxy (t :: k)) (y :: Proxy (t :: k))) :: Type where - Symmetry a y _ = (:~:) y a - type SymmetrySym3 (a0123456789876543210 :: Proxy t0123456789876543210) (y0123456789876543210 :: Proxy t0123456789876543210) (e0123456789876543210 :: (:~:) (a0123456789876543210 :: Proxy (t0123456789876543210 :: k0123456789876543210)) (y0123456789876543210 :: Proxy (t0123456789876543210 :: k0123456789876543210))) = - Symmetry a0123456789876543210 y0123456789876543210 e0123456789876543210 - instance SuppressUnusedWarnings (SymmetrySym2 y0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) SymmetrySym2KindInference) ()) - data SymmetrySym2 (a0123456789876543210 :: Proxy (t0123456789876543210 :: k0123456789876543210)) (y0123456789876543210 :: Proxy (t0123456789876543210 :: k0123456789876543210)) :: (~>) ((:~:) (a0123456789876543210 :: Proxy (t0123456789876543210 :: k0123456789876543210)) (y0123456789876543210 :: Proxy (t0123456789876543210 :: k0123456789876543210))) Type - where - SymmetrySym2KindInference :: forall a0123456789876543210 - y0123456789876543210 - e0123456789876543210 - arg. SameKind (Apply (SymmetrySym2 a0123456789876543210 y0123456789876543210) arg) (SymmetrySym3 a0123456789876543210 y0123456789876543210 arg) => - SymmetrySym2 a0123456789876543210 y0123456789876543210 e0123456789876543210 - type instance Apply (SymmetrySym2 y0123456789876543210 a0123456789876543210) e0123456789876543210 = Symmetry y0123456789876543210 a0123456789876543210 e0123456789876543210 - instance SuppressUnusedWarnings (SymmetrySym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) SymmetrySym1KindInference) ()) - data SymmetrySym1 (a0123456789876543210 :: Proxy (t0123456789876543210 :: k0123456789876543210)) :: forall (y0123456789876543210 :: Proxy t0123456789876543210). - (~>) (Proxy t0123456789876543210) ((~>) ((:~:) (a0123456789876543210 :: Proxy (t0123456789876543210 :: k0123456789876543210)) (y0123456789876543210 :: Proxy (t0123456789876543210 :: k0123456789876543210))) Type) - where - SymmetrySym1KindInference :: forall a0123456789876543210 - y0123456789876543210 - arg. SameKind (Apply (SymmetrySym1 a0123456789876543210) arg) (SymmetrySym2 a0123456789876543210 arg) => - SymmetrySym1 a0123456789876543210 y0123456789876543210 - type instance Apply (SymmetrySym1 a0123456789876543210) y0123456789876543210 = SymmetrySym2 a0123456789876543210 y0123456789876543210 - instance SuppressUnusedWarnings SymmetrySym0 where - suppressUnusedWarnings = snd (((,) SymmetrySym0KindInference) ()) - data SymmetrySym0 :: forall k0123456789876543210 - (t0123456789876543210 :: k0123456789876543210) - (a0123456789876543210 :: Proxy t0123456789876543210) - (y0123456789876543210 :: Proxy t0123456789876543210). - (~>) (Proxy t0123456789876543210) ((~>) (Proxy t0123456789876543210) ((~>) ((:~:) (a0123456789876543210 :: Proxy (t0123456789876543210 :: k0123456789876543210)) (y0123456789876543210 :: Proxy (t0123456789876543210 :: k0123456789876543210))) Type)) - where - SymmetrySym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply SymmetrySym0 arg) (SymmetrySym1 arg) => - SymmetrySym0 a0123456789876543210 - type instance Apply SymmetrySym0 a0123456789876543210 = SymmetrySym1 a0123456789876543210 -Singletons/T353.hs:0:0:: Splicing declarations - genDefunSymbols [''Prod] - ======> - type MkProdSym2 (t0123456789876543210 :: f0123456789876543210 p0123456789876543210) (t0123456789876543210 :: g0123456789876543210 p0123456789876543210) = - 'MkProd t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (MkProdSym1 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) MkProdSym1KindInference) ()) - data MkProdSym1 (t0123456789876543210 :: (f0123456789876543210 :: k0123456789876543210 - -> Type) (p0123456789876543210 :: k0123456789876543210)) :: forall (g0123456789876543210 :: k0123456789876543210 - -> Type). - (~>) (g0123456789876543210 p0123456789876543210) (Prod (f0123456789876543210 :: k0123456789876543210 - -> Type) (g0123456789876543210 :: k0123456789876543210 - -> Type) (p0123456789876543210 :: k0123456789876543210)) - where - MkProdSym1KindInference :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (MkProdSym1 t0123456789876543210) arg) (MkProdSym2 t0123456789876543210 arg) => - MkProdSym1 t0123456789876543210 t0123456789876543210 - type instance Apply (MkProdSym1 t0123456789876543210) t0123456789876543210 = 'MkProd t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings MkProdSym0 where - suppressUnusedWarnings = snd (((,) MkProdSym0KindInference) ()) - data MkProdSym0 :: forall k0123456789876543210 - (f0123456789876543210 :: k0123456789876543210 -> Type) - (p0123456789876543210 :: k0123456789876543210) - (g0123456789876543210 :: k0123456789876543210 -> Type). - (~>) (f0123456789876543210 p0123456789876543210) ((~>) (g0123456789876543210 p0123456789876543210) (Prod (f0123456789876543210 :: k0123456789876543210 - -> Type) (g0123456789876543210 :: k0123456789876543210 - -> Type) (p0123456789876543210 :: k0123456789876543210))) - where - MkProdSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply MkProdSym0 arg) (MkProdSym1 arg) => - MkProdSym0 t0123456789876543210 - type instance Apply MkProdSym0 t0123456789876543210 = MkProdSym1 t0123456789876543210 -Singletons/T353.hs:0:0:: Splicing declarations - genDefunSymbols [''Foo] - ======> - type MkFooSym2 (t0123456789876543210 :: Proxy a0123456789876543210) (t0123456789876543210 :: Proxy b0123456789876543210) = - 'MkFoo t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (MkFooSym1 t0123456789876543210) where - suppressUnusedWarnings = snd (((,) MkFooSym1KindInference) ()) - data MkFooSym1 (t0123456789876543210 :: Proxy (a0123456789876543210 :: k0123456789876543210)) :: forall k0123456789876543210 - (b0123456789876543210 :: k0123456789876543210). - (~>) (Proxy b0123456789876543210) (Foo (a0123456789876543210 :: k0123456789876543210) (b0123456789876543210 :: k0123456789876543210)) - where - MkFooSym1KindInference :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (MkFooSym1 t0123456789876543210) arg) (MkFooSym2 t0123456789876543210 arg) => - MkFooSym1 t0123456789876543210 t0123456789876543210 - type instance Apply (MkFooSym1 t0123456789876543210) t0123456789876543210 = 'MkFoo t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings MkFooSym0 where - suppressUnusedWarnings = snd (((,) MkFooSym0KindInference) ()) - data MkFooSym0 :: forall k0123456789876543210 - (a0123456789876543210 :: k0123456789876543210) - k0123456789876543210 - (b0123456789876543210 :: k0123456789876543210). - (~>) (Proxy a0123456789876543210) ((~>) (Proxy b0123456789876543210) (Foo (a0123456789876543210 :: k0123456789876543210) (b0123456789876543210 :: k0123456789876543210))) - where - MkFooSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply MkFooSym0 arg) (MkFooSym1 arg) => - MkFooSym0 t0123456789876543210 - type instance Apply MkFooSym0 t0123456789876543210 = MkFooSym1 t0123456789876543210 diff --git a/tests/compile-and-dump/Singletons/T353.hs b/tests/compile-and-dump/Singletons/T353.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T353.hs +++ /dev/null @@ -1,17 +0,0 @@ -module T353 where - -import Data.Kind -import Data.Proxy -import Data.Singletons.TH - -$(singletons [d| - type family Symmetry (a :: Proxy t) (y :: Proxy t) - (e :: (a :: Proxy (t :: k)) :~: (y :: Proxy (t :: k))) :: Type where - Symmetry a y _ = y :~: a - |]) - -data Prod f g p = MkProd (f p) (g p) -$(genDefunSymbols [''Prod]) - -data Foo a b = MkFoo (Proxy a) (Proxy b) -$(genDefunSymbols [''Foo]) diff --git a/tests/compile-and-dump/Singletons/T358.ghc88.template b/tests/compile-and-dump/Singletons/T358.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T358.ghc88.template +++ /dev/null @@ -1,116 +0,0 @@ -Singletons/T358.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| class C1 (f :: k -> Type) where - method1 :: f a - class C2 a where - method2a, method2b :: forall b. b -> a - - instance C1 [] where - method1 :: [a] - method1 = [] - instance C2 [a] where - method2a _ = [] - method2b :: forall b. b -> [a] - method2b _ = [] |] - ======> - class C1 (f :: k -> Type) where - method1 :: f a - instance C1 [] where - method1 :: [a] - method1 = [] - class C2 a where - method2a :: forall b. b -> a - method2b :: forall b. b -> a - instance C2 [a] where - method2b :: forall b. b -> [a] - method2a _ = [] - method2b _ = [] - type Method1Sym0 = Method1 - class PC1 (f :: k -> Type) where - type Method1 :: f a - type Method2aSym1 (arg0123456789876543210 :: b0123456789876543210) = - Method2a arg0123456789876543210 - instance SuppressUnusedWarnings Method2aSym0 where - suppressUnusedWarnings = snd (((,) Method2aSym0KindInference) ()) - data Method2aSym0 :: forall b0123456789876543210 - a0123456789876543210. - (~>) b0123456789876543210 a0123456789876543210 - where - Method2aSym0KindInference :: forall arg0123456789876543210 - arg. SameKind (Apply Method2aSym0 arg) (Method2aSym1 arg) => - Method2aSym0 arg0123456789876543210 - type instance Apply Method2aSym0 arg0123456789876543210 = Method2a arg0123456789876543210 - type Method2bSym1 (arg0123456789876543210 :: b0123456789876543210) = - Method2b arg0123456789876543210 - instance SuppressUnusedWarnings Method2bSym0 where - suppressUnusedWarnings = snd (((,) Method2bSym0KindInference) ()) - data Method2bSym0 :: forall b0123456789876543210 - a0123456789876543210. - (~>) b0123456789876543210 a0123456789876543210 - where - Method2bSym0KindInference :: forall arg0123456789876543210 - arg. SameKind (Apply Method2bSym0 arg) (Method2bSym1 arg) => - Method2bSym0 arg0123456789876543210 - type instance Apply Method2bSym0 arg0123456789876543210 = Method2b arg0123456789876543210 - class PC2 (a :: Type) where - type Method2a (arg :: b) :: a - type Method2b (arg :: b) :: a - type family Method1_0123456789876543210 :: [a] where - Method1_0123456789876543210 = '[] - type Method1_0123456789876543210Sym0 = Method1_0123456789876543210 - instance PC1 [] where - type Method1 = Method1_0123456789876543210Sym0 - type family Method2a_0123456789876543210 (a :: b) :: [a] where - Method2a_0123456789876543210 _ = '[] - type Method2a_0123456789876543210Sym1 (a0123456789876543210 :: b0123456789876543210) = - Method2a_0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Method2a_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Method2a_0123456789876543210Sym0KindInference) ()) - data Method2a_0123456789876543210Sym0 :: forall b0123456789876543210 - a0123456789876543210. - (~>) b0123456789876543210 [a0123456789876543210] - where - Method2a_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Method2a_0123456789876543210Sym0 arg) (Method2a_0123456789876543210Sym1 arg) => - Method2a_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Method2a_0123456789876543210Sym0 a0123456789876543210 = Method2a_0123456789876543210 a0123456789876543210 - type family Method2b_0123456789876543210 (a :: b) :: [a] where - Method2b_0123456789876543210 _ = '[] - type Method2b_0123456789876543210Sym1 (a0123456789876543210 :: b0123456789876543210) = - Method2b_0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings Method2b_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Method2b_0123456789876543210Sym0KindInference) ()) - data Method2b_0123456789876543210Sym0 :: forall b0123456789876543210 - a0123456789876543210. - (~>) b0123456789876543210 [a0123456789876543210] - where - Method2b_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Method2b_0123456789876543210Sym0 arg) (Method2b_0123456789876543210Sym1 arg) => - Method2b_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Method2b_0123456789876543210Sym0 a0123456789876543210 = Method2b_0123456789876543210 a0123456789876543210 - instance PC2 [a] where - type Method2a a = Apply Method2a_0123456789876543210Sym0 a - type Method2b a = Apply Method2b_0123456789876543210Sym0 a - class SC1 (f :: k -> Type) where - sMethod1 :: forall a. Sing (Method1Sym0 :: f a) - class SC2 a where - sMethod2a :: - forall b (t :: b). Sing t -> Sing (Apply Method2aSym0 t :: a) - sMethod2b :: - forall b (t :: b). Sing t -> Sing (Apply Method2bSym0 t :: a) - instance SC1 [] where - sMethod1 :: forall a. Sing (Method1Sym0 :: [a]) - sMethod1 = Data.Singletons.Prelude.Instances.SNil - instance SC2 [a] where - sMethod2a :: - forall b (t :: b). Sing t -> Sing (Apply Method2aSym0 t :: [a]) - sMethod2b :: - forall b (t :: b). Sing t -> Sing (Apply Method2bSym0 t :: [a]) - sMethod2a _ = Data.Singletons.Prelude.Instances.SNil - sMethod2b _ = Data.Singletons.Prelude.Instances.SNil - instance SC2 a => SingI (Method2aSym0 :: (~>) b a) where - sing = (singFun1 @Method2aSym0) sMethod2a - instance SC2 a => SingI (Method2bSym0 :: (~>) b a) where - sing = (singFun1 @Method2bSym0) sMethod2b diff --git a/tests/compile-and-dump/Singletons/T358.hs b/tests/compile-and-dump/Singletons/T358.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T358.hs +++ /dev/null @@ -1,24 +0,0 @@ -module T358 where - -import Data.Kind -import Data.Singletons.TH - -$(singletons [d| - class C1 (f :: k -> Type) where - method1 :: f a - - instance C1 [] where - method1 :: [a] - method1 = [] - - class C2 a where - method2a, method2b :: forall b. b -> a - - -- Test that variables bound by instance head aren't quantified by the - -- generated InstanceSigs - instance C2 [a] where - method2a _ = [] - - method2b :: forall b. b -> [a] - method2b _ = [] - |]) diff --git a/tests/compile-and-dump/Singletons/T367.ghc88.template b/tests/compile-and-dump/Singletons/T367.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T367.ghc88.template +++ /dev/null @@ -1,39 +0,0 @@ -Singletons/T367.hs:(0,0)-(0,0): Splicing declarations - singletonsOnly - [d| const' :: a -> b -> a - const' x _ = x |] - ======> - type Const'Sym2 (a0123456789876543210 :: a0123456789876543210) (a0123456789876543210 :: b0123456789876543210) = - Const' a0123456789876543210 a0123456789876543210 - instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings (Const'Sym1 a0123456789876543210) where - Data.Singletons.SuppressUnusedWarnings.suppressUnusedWarnings - = snd (((,) Const'Sym1KindInference) ()) - data Const'Sym1 (a0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210. - (~>) b0123456789876543210 a0123456789876543210 - where - Const'Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (Const'Sym1 a0123456789876543210) arg) (Const'Sym2 a0123456789876543210 arg) => - Const'Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Const'Sym1 a0123456789876543210) a0123456789876543210 = Const' a0123456789876543210 a0123456789876543210 - instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings Const'Sym0 where - Data.Singletons.SuppressUnusedWarnings.suppressUnusedWarnings - = snd (((,) Const'Sym0KindInference) ()) - data Const'Sym0 :: forall a0123456789876543210 - b0123456789876543210. - (~>) a0123456789876543210 ((~>) b0123456789876543210 a0123456789876543210) - where - Const'Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply Const'Sym0 arg) (Const'Sym1 arg) => - Const'Sym0 a0123456789876543210 - type instance Apply Const'Sym0 a0123456789876543210 = Const'Sym1 a0123456789876543210 - type family Const' (a :: a) (a :: b) :: a where - Const' x _ = x - sConst' :: - forall a b (t :: a) (t :: b). - Sing t -> Sing t -> Sing (Apply (Apply Const'Sym0 t) t :: a) - sConst' (sX :: Sing x) _ = sX - instance SingI (Const'Sym0 :: (~>) a ((~>) b a)) where - sing = (singFun2 @Const'Sym0) sConst' - instance SingI d => SingI (Const'Sym1 (d :: a) :: (~>) b a) where - sing = (singFun1 @(Const'Sym1 (d :: a))) (sConst' (sing @d)) diff --git a/tests/compile-and-dump/Singletons/T367.hs b/tests/compile-and-dump/Singletons/T367.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T367.hs +++ /dev/null @@ -1,12 +0,0 @@ -module T367 where - -import Data.Singletons.Prelude -import Data.Singletons.TH (singletonsOnly) - -$(singletonsOnly [d| - const' :: a -> b -> a - const' x _ = x - |]) - -test :: Sing True -test = sConst' @Bool @() STrue STuple0 diff --git a/tests/compile-and-dump/Singletons/T371.ghc88.template b/tests/compile-and-dump/Singletons/T371.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T371.ghc88.template +++ /dev/null @@ -1,247 +0,0 @@ -Singletons/T371.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| data Y (a :: Type) - = Y1 | Y2 (X a) - deriving Show - data X (a :: Type) - = X1 | X2 (Y a) - deriving Show |] - ======> - data X (a :: Type) - = X1 | X2 (Y a) - deriving Show - data Y (a :: Type) - = Y1 | Y2 (X a) - deriving Show - type X1Sym0 = X1 - type X2Sym1 (t0123456789876543210 :: Y a0123456789876543210) = - X2 t0123456789876543210 - instance SuppressUnusedWarnings X2Sym0 where - suppressUnusedWarnings = snd (((,) X2Sym0KindInference) ()) - data X2Sym0 :: forall (a0123456789876543210 :: Type). - (~>) (Y a0123456789876543210) (X (a0123456789876543210 :: Type)) - where - X2Sym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply X2Sym0 arg) (X2Sym1 arg) => - X2Sym0 t0123456789876543210 - type instance Apply X2Sym0 t0123456789876543210 = X2 t0123456789876543210 - type Y1Sym0 = Y1 - type Y2Sym1 (t0123456789876543210 :: X a0123456789876543210) = - Y2 t0123456789876543210 - instance SuppressUnusedWarnings Y2Sym0 where - suppressUnusedWarnings = snd (((,) Y2Sym0KindInference) ()) - data Y2Sym0 :: forall (a0123456789876543210 :: Type). - (~>) (X a0123456789876543210) (Y (a0123456789876543210 :: Type)) - where - Y2Sym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply Y2Sym0 arg) (Y2Sym1 arg) => - Y2Sym0 t0123456789876543210 - type instance Apply Y2Sym0 t0123456789876543210 = Y2 t0123456789876543210 - type family ShowsPrec_0123456789876543210 (a :: GHC.Types.Nat) (a :: X a) (a :: GHC.Types.Symbol) :: GHC.Types.Symbol where - ShowsPrec_0123456789876543210 _ X1 a_0123456789876543210 = Apply (Apply ShowStringSym0 "X1") a_0123456789876543210 - ShowsPrec_0123456789876543210 p_0123456789876543210 (X2 arg_0123456789876543210) a_0123456789876543210 = Apply (Apply (Apply ShowParenSym0 (Apply (Apply (>@#@$) p_0123456789876543210) (Data.Singletons.Prelude.Num.FromInteger 10))) (Apply (Apply (.@#@$) (Apply ShowStringSym0 "X2 ")) (Apply (Apply ShowsPrecSym0 (Data.Singletons.Prelude.Num.FromInteger 11)) arg_0123456789876543210))) a_0123456789876543210 - type ShowsPrec_0123456789876543210Sym3 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: X a0123456789876543210) (a0123456789876543210 :: GHC.Types.Symbol) = - ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym2KindInference) ()) - data ShowsPrec_0123456789876543210Sym2 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: X a0123456789876543210) :: (~>) GHC.Types.Symbol GHC.Types.Symbol - where - ShowsPrec_0123456789876543210Sym2KindInference :: forall a0123456789876543210 - a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) arg) (ShowsPrec_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 arg) => - ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym1KindInference) ()) - data ShowsPrec_0123456789876543210Sym1 (a0123456789876543210 :: GHC.Types.Nat) :: forall a0123456789876543210. - (~>) (X a0123456789876543210) ((~>) GHC.Types.Symbol GHC.Types.Symbol) - where - ShowsPrec_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) arg) (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 arg) => - ShowsPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ShowsPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym0KindInference) ()) - data ShowsPrec_0123456789876543210Sym0 :: forall a0123456789876543210. - (~>) GHC.Types.Nat ((~>) (X a0123456789876543210) ((~>) GHC.Types.Symbol GHC.Types.Symbol)) - where - ShowsPrec_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply ShowsPrec_0123456789876543210Sym0 arg) (ShowsPrec_0123456789876543210Sym1 arg) => - ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ShowsPrec_0123456789876543210Sym0 a0123456789876543210 = ShowsPrec_0123456789876543210Sym1 a0123456789876543210 - instance PShow (X a) where - type ShowsPrec a a a = Apply (Apply (Apply ShowsPrec_0123456789876543210Sym0 a) a) a - type family ShowsPrec_0123456789876543210 (a :: GHC.Types.Nat) (a :: Y a) (a :: GHC.Types.Symbol) :: GHC.Types.Symbol where - ShowsPrec_0123456789876543210 _ Y1 a_0123456789876543210 = Apply (Apply ShowStringSym0 "Y1") a_0123456789876543210 - ShowsPrec_0123456789876543210 p_0123456789876543210 (Y2 arg_0123456789876543210) a_0123456789876543210 = Apply (Apply (Apply ShowParenSym0 (Apply (Apply (>@#@$) p_0123456789876543210) (Data.Singletons.Prelude.Num.FromInteger 10))) (Apply (Apply (.@#@$) (Apply ShowStringSym0 "Y2 ")) (Apply (Apply ShowsPrecSym0 (Data.Singletons.Prelude.Num.FromInteger 11)) arg_0123456789876543210))) a_0123456789876543210 - type ShowsPrec_0123456789876543210Sym3 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: Y a0123456789876543210) (a0123456789876543210 :: GHC.Types.Symbol) = - ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym2KindInference) ()) - data ShowsPrec_0123456789876543210Sym2 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: Y a0123456789876543210) :: (~>) GHC.Types.Symbol GHC.Types.Symbol - where - ShowsPrec_0123456789876543210Sym2KindInference :: forall a0123456789876543210 - a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) arg) (ShowsPrec_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 arg) => - ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym1KindInference) ()) - data ShowsPrec_0123456789876543210Sym1 (a0123456789876543210 :: GHC.Types.Nat) :: forall a0123456789876543210. - (~>) (Y a0123456789876543210) ((~>) GHC.Types.Symbol GHC.Types.Symbol) - where - ShowsPrec_0123456789876543210Sym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) arg) (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 arg) => - ShowsPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (ShowsPrec_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ShowsPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym0KindInference) ()) - data ShowsPrec_0123456789876543210Sym0 :: forall a0123456789876543210. - (~>) GHC.Types.Nat ((~>) (Y a0123456789876543210) ((~>) GHC.Types.Symbol GHC.Types.Symbol)) - where - ShowsPrec_0123456789876543210Sym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply ShowsPrec_0123456789876543210Sym0 arg) (ShowsPrec_0123456789876543210Sym1 arg) => - ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ShowsPrec_0123456789876543210Sym0 a0123456789876543210 = ShowsPrec_0123456789876543210Sym1 a0123456789876543210 - instance PShow (Y a) where - type ShowsPrec a a a = Apply (Apply (Apply ShowsPrec_0123456789876543210Sym0 a) a) a - data SX :: forall a. X a -> Type - where - SX1 :: SX X1 - SX2 :: forall a (n :: Y a). (Sing (n :: Y a)) -> SX (X2 n) - type instance Sing @(X a) = SX - instance SingKind a => SingKind (X a) where - type Demote (X a) = X (Demote a) - fromSing SX1 = X1 - fromSing (SX2 b) = X2 (fromSing b) - toSing X1 = SomeSing SX1 - toSing (X2 (b :: Demote (Y a))) - = case toSing b :: SomeSing (Y a) of { - SomeSing c -> SomeSing (SX2 c) } - data SY :: forall a. Y a -> Type - where - SY1 :: SY Y1 - SY2 :: forall a (n :: X a). (Sing (n :: X a)) -> SY (Y2 n) - type instance Sing @(Y a) = SY - instance SingKind a => SingKind (Y a) where - type Demote (Y a) = Y (Demote a) - fromSing SY1 = Y1 - fromSing (SY2 b) = Y2 (fromSing b) - toSing Y1 = SomeSing SY1 - toSing (Y2 (b :: Demote (X a))) - = case toSing b :: SomeSing (X a) of { - SomeSing c -> SomeSing (SY2 c) } - instance SShow (Y a) => SShow (X a) where - sShowsPrec :: - forall (t1 :: GHC.Types.Nat) (t2 :: X a) (t3 :: GHC.Types.Symbol). - Sing t1 - -> Sing t2 - -> Sing t3 - -> Sing (Apply (Apply (Apply (ShowsPrecSym0 :: TyFun GHC.Types.Nat ((~>) (X a) ((~>) GHC.Types.Symbol GHC.Types.Symbol)) - -> Type) t1) t2) t3) - sShowsPrec - _ - SX1 - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "X1"))) - sA_0123456789876543210 - sShowsPrec - (sP_0123456789876543210 :: Sing p_0123456789876543210) - (SX2 (sArg_0123456789876543210 :: Sing arg_0123456789876543210)) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing - ((applySing ((singFun3 @ShowParenSym0) sShowParen)) - ((applySing - ((applySing ((singFun2 @(>@#@$)) (%>))) sP_0123456789876543210)) - (Data.Singletons.Prelude.Num.sFromInteger (sing :: Sing 10))))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "X2 ")))) - ((applySing - ((applySing ((singFun3 @ShowsPrecSym0) sShowsPrec)) - (Data.Singletons.Prelude.Num.sFromInteger (sing :: Sing 11)))) - sArg_0123456789876543210)))) - sA_0123456789876543210 - instance SShow (X a) => SShow (Y a) where - sShowsPrec :: - forall (t1 :: GHC.Types.Nat) (t2 :: Y a) (t3 :: GHC.Types.Symbol). - Sing t1 - -> Sing t2 - -> Sing t3 - -> Sing (Apply (Apply (Apply (ShowsPrecSym0 :: TyFun GHC.Types.Nat ((~>) (Y a) ((~>) GHC.Types.Symbol GHC.Types.Symbol)) - -> Type) t1) t2) t3) - sShowsPrec - _ - SY1 - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "Y1"))) - sA_0123456789876543210 - sShowsPrec - (sP_0123456789876543210 :: Sing p_0123456789876543210) - (SY2 (sArg_0123456789876543210 :: Sing arg_0123456789876543210)) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing - ((applySing ((singFun3 @ShowParenSym0) sShowParen)) - ((applySing - ((applySing ((singFun2 @(>@#@$)) (%>))) sP_0123456789876543210)) - (Data.Singletons.Prelude.Num.sFromInteger (sing :: Sing 10))))) - ((applySing - ((applySing ((singFun3 @(.@#@$)) (%.))) - ((applySing ((singFun2 @ShowStringSym0) sShowString)) - (sing :: Sing "Y2 ")))) - ((applySing - ((applySing ((singFun3 @ShowsPrecSym0) sShowsPrec)) - (Data.Singletons.Prelude.Num.sFromInteger (sing :: Sing 11)))) - sArg_0123456789876543210)))) - sA_0123456789876543210 - instance Data.Singletons.ShowSing.ShowSing (Y a) => - Show (SX (z :: X a)) where - showsPrec _ SX1 = showString "SX1" - showsPrec - p_0123456789876543210 - (SX2 (arg_0123456789876543210 :: Sing argTy_0123456789876543210)) - = (showParen (((>) p_0123456789876543210) 10)) - (((.) (showString "SX2 ")) - ((showsPrec 11) arg_0123456789876543210)) :: - Data.Singletons.ShowSing.ShowSing' argTy_0123456789876543210 => - ShowS - instance Data.Singletons.ShowSing.ShowSing (X a) => - Show (SY (z :: Y a)) where - showsPrec _ SY1 = showString "SY1" - showsPrec - p_0123456789876543210 - (SY2 (arg_0123456789876543210 :: Sing argTy_0123456789876543210)) - = (showParen (((>) p_0123456789876543210) 10)) - (((.) (showString "SY2 ")) - ((showsPrec 11) arg_0123456789876543210)) :: - Data.Singletons.ShowSing.ShowSing' argTy_0123456789876543210 => - ShowS - instance SingI X1 where - sing = SX1 - instance SingI n => SingI (X2 (n :: Y a)) where - sing = SX2 sing - instance SingI (X2Sym0 :: (~>) (Y a) (X (a :: Type))) where - sing = (singFun1 @X2Sym0) SX2 - instance SingI Y1 where - sing = SY1 - instance SingI n => SingI (Y2 (n :: X a)) where - sing = SY2 sing - instance SingI (Y2Sym0 :: (~>) (X a) (Y (a :: Type))) where - sing = (singFun1 @Y2Sym0) SY2 diff --git a/tests/compile-and-dump/Singletons/T371.hs b/tests/compile-and-dump/Singletons/T371.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T371.hs +++ /dev/null @@ -1,16 +0,0 @@ -module T371 where - -import Data.Kind -import Data.Singletons.TH - -$(singletons [d| - data X (a :: Type) = X1 | X2 (Y a) deriving Show - data Y (a :: Type) = Y1 | Y2 (X a) deriving Show - |]) - -main :: IO () -main = do - print (sing :: Sing ('[] :: [Bool])) - print (sing :: Sing '[True]) - print (sing :: Sing (X1 :: X Bool)) - print (sing :: Sing (Y2 X1 :: Y Bool)) diff --git a/tests/compile-and-dump/Singletons/T376.ghc88.template b/tests/compile-and-dump/Singletons/T376.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T376.ghc88.template +++ /dev/null @@ -1,40 +0,0 @@ -Singletons/T376.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| f :: (() -> ()) -> (() -> ()) - f g = g :: () -> () |] - ======> - f :: (() -> ()) -> () -> () - f g = g :: () -> () - type FSym2 (a0123456789876543210 :: (~>) () ()) (a0123456789876543210 :: ()) = - F a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (FSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) FSym1KindInference) ()) - data FSym1 (a0123456789876543210 :: (~>) () ()) :: (~>) () () - where - FSym1KindInference :: forall a0123456789876543210 - a0123456789876543210 - arg. SameKind (Apply (FSym1 a0123456789876543210) arg) (FSym2 a0123456789876543210 arg) => - FSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (FSym1 a0123456789876543210) a0123456789876543210 = F a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings FSym0 where - suppressUnusedWarnings = snd (((,) FSym0KindInference) ()) - data FSym0 :: (~>) ((~>) () ()) ((~>) () ()) - where - FSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply FSym0 arg) (FSym1 arg) => - FSym0 a0123456789876543210 - type instance Apply FSym0 a0123456789876543210 = FSym1 a0123456789876543210 - type family F (a :: (~>) () ()) (a :: ()) :: () where - F g a_0123456789876543210 = Apply (g :: (~>) () ()) a_0123456789876543210 - sF :: - forall (t :: (~>) () ()) (t :: ()). - Sing t -> Sing t -> Sing (Apply (Apply FSym0 t) t :: ()) - sF - (sG :: Sing g) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing (sG :: Sing (g :: (~>) () ()))) sA_0123456789876543210 - instance SingI (FSym0 :: (~>) ((~>) () ()) ((~>) () ())) where - sing = (singFun2 @FSym0) sF - instance SingI d => - SingI (FSym1 (d :: (~>) () ()) :: (~>) () ()) where - sing = (singFun1 @(FSym1 (d :: (~>) () ()))) (sF (sing @d)) diff --git a/tests/compile-and-dump/Singletons/T376.hs b/tests/compile-and-dump/Singletons/T376.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T376.hs +++ /dev/null @@ -1,8 +0,0 @@ -module T376 where - -import Data.Singletons.TH - -$(singletons [d| - f :: (() -> ()) -> (() -> ()) - f g = g :: () -> () - |]) diff --git a/tests/compile-and-dump/Singletons/T402.ghc88.template b/tests/compile-and-dump/Singletons/T402.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T402.ghc88.template +++ /dev/null @@ -1,15 +0,0 @@ -Singletons/T402.hs:0:0:: Splicing declarations - singletons [d| type AnyOfKind (k :: Type) = Any :: k |] - ======> - type AnyOfKind (k :: Type) = Any :: k - type AnyOfKindSym1 (k0123456789876543210 :: Type) = - AnyOfKind k0123456789876543210 - instance SuppressUnusedWarnings AnyOfKindSym0 where - suppressUnusedWarnings = snd (((,) AnyOfKindSym0KindInference) ()) - data AnyOfKindSym0 :: forall (k0123456789876543210 :: Type). - (~>) Type k0123456789876543210 - where - AnyOfKindSym0KindInference :: forall k0123456789876543210 - arg. SameKind (Apply AnyOfKindSym0 arg) (AnyOfKindSym1 arg) => - AnyOfKindSym0 k0123456789876543210 - type instance Apply AnyOfKindSym0 k0123456789876543210 = AnyOfKind k0123456789876543210 diff --git a/tests/compile-and-dump/Singletons/T402.hs b/tests/compile-and-dump/Singletons/T402.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T402.hs +++ /dev/null @@ -1,7 +0,0 @@ -module T402 where - -import Data.Kind -import Data.Singletons.TH - -type family Any :: k -$(singletons [d| type AnyOfKind (k :: Type) = Any :: k |]) diff --git a/tests/compile-and-dump/Singletons/T54.ghc88.template b/tests/compile-and-dump/Singletons/T54.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T54.ghc88.template +++ /dev/null @@ -1,55 +0,0 @@ -Singletons/T54.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| g :: Bool -> Bool - g e = (case [not] of { [_] -> not }) e |] - ======> - g :: Bool -> Bool - g e = (case [not] of { [_] -> not }) e - type Let0123456789876543210Scrutinee_0123456789876543210Sym1 e0123456789876543210 = - Let0123456789876543210Scrutinee_0123456789876543210 e0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210Scrutinee_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd - (((,) - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference) - ()) - data Let0123456789876543210Scrutinee_0123456789876543210Sym0 e0123456789876543210 - where - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference :: forall e0123456789876543210 - arg. SameKind (Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 arg) (Let0123456789876543210Scrutinee_0123456789876543210Sym1 arg) => - Let0123456789876543210Scrutinee_0123456789876543210Sym0 e0123456789876543210 - type instance Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 e0123456789876543210 = Let0123456789876543210Scrutinee_0123456789876543210 e0123456789876543210 - type family Let0123456789876543210Scrutinee_0123456789876543210 e where - Let0123456789876543210Scrutinee_0123456789876543210 e = Apply (Apply (:@#@$) NotSym0) '[] - type family Case_0123456789876543210 e t where - Case_0123456789876543210 e '[_] = NotSym0 - type GSym1 (a0123456789876543210 :: Bool) = G a0123456789876543210 - instance SuppressUnusedWarnings GSym0 where - suppressUnusedWarnings = snd (((,) GSym0KindInference) ()) - data GSym0 :: (~>) Bool Bool - where - GSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply GSym0 arg) (GSym1 arg) => - GSym0 a0123456789876543210 - type instance Apply GSym0 a0123456789876543210 = G a0123456789876543210 - type family G (a :: Bool) :: Bool where - G e = Apply (Case_0123456789876543210 e (Let0123456789876543210Scrutinee_0123456789876543210Sym1 e)) e - sG :: forall (t :: Bool). Sing t -> Sing (Apply GSym0 t :: Bool) - sG (sE :: Sing e) - = (applySing - (let - sScrutinee_0123456789876543210 :: - Sing (Let0123456789876543210Scrutinee_0123456789876543210Sym1 e) - sScrutinee_0123456789876543210 - = (applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((singFun1 @NotSym0) sNot))) - SNil - in - (id - @(Sing (Case_0123456789876543210 e (Let0123456789876543210Scrutinee_0123456789876543210Sym1 e)))) - (case sScrutinee_0123456789876543210 of { - SCons _ SNil -> (singFun1 @NotSym0) sNot }))) - sE - instance SingI (GSym0 :: (~>) Bool Bool) where - sing = (singFun1 @GSym0) sG diff --git a/tests/compile-and-dump/Singletons/T54.hs b/tests/compile-and-dump/Singletons/T54.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T54.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# OPTIONS_GHC -Wno-incomplete-patterns #-} - -module Singletons.T54 where - -import Data.Singletons.TH -import Data.Singletons.Prelude - -$(singletons [d| - g :: Bool -> Bool - g e = (case [not] of - [_] -> not) e - |]) diff --git a/tests/compile-and-dump/Singletons/T78.ghc88.template b/tests/compile-and-dump/Singletons/T78.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T78.ghc88.template +++ /dev/null @@ -1,32 +0,0 @@ -Singletons/T78.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| foo :: MaybeBool -> Bool - foo (Just False) = False - foo (Just True) = True - foo Nothing = False |] - ======> - foo :: MaybeBool -> Bool - foo (Just False) = False - foo (Just True) = True - foo Nothing = False - type FooSym1 (a0123456789876543210 :: Maybe Bool) = - Foo a0123456789876543210 - instance SuppressUnusedWarnings FooSym0 where - suppressUnusedWarnings = snd (((,) FooSym0KindInference) ()) - data FooSym0 :: (~>) (Maybe Bool) Bool - where - FooSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply FooSym0 arg) (FooSym1 arg) => - FooSym0 a0123456789876543210 - type instance Apply FooSym0 a0123456789876543210 = Foo a0123456789876543210 - type family Foo (a :: Maybe Bool) :: Bool where - Foo ('Just 'False) = FalseSym0 - Foo ('Just 'True) = TrueSym0 - Foo 'Nothing = FalseSym0 - sFoo :: - forall (t :: Maybe Bool). Sing t -> Sing (Apply FooSym0 t :: Bool) - sFoo (SJust SFalse) = SFalse - sFoo (SJust STrue) = STrue - sFoo SNothing = SFalse - instance SingI (FooSym0 :: (~>) (Maybe Bool) Bool) where - sing = (singFun1 @FooSym0) sFoo diff --git a/tests/compile-and-dump/Singletons/T78.hs b/tests/compile-and-dump/Singletons/T78.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T78.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Singletons.T78 where - -import Data.Singletons.TH -import Data.Singletons.Prelude - -type MaybeBool = Maybe Bool - -$(singletons [d| - foo :: MaybeBool -> Bool - foo (Just False) = False - foo (Just True) = True - foo Nothing = False - |]) diff --git a/tests/compile-and-dump/Singletons/TopLevelPatterns.ghc88.template b/tests/compile-and-dump/Singletons/TopLevelPatterns.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/TopLevelPatterns.ghc88.template +++ /dev/null @@ -1,350 +0,0 @@ -Singletons/TopLevelPatterns.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| data Bool = False | True - data Foo = Bar Bool Bool |] - ======> - data Bool = False | True - data Foo = Bar Bool Bool - type FalseSym0 = False - type TrueSym0 = True - type BarSym2 (t0123456789876543210 :: Bool) (t0123456789876543210 :: Bool) = - Bar t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (BarSym1 t0123456789876543210) where - suppressUnusedWarnings - = Data.Tuple.snd (((,) BarSym1KindInference) ()) - data BarSym1 (t0123456789876543210 :: Bool) :: (~>) Bool Foo - where - BarSym1KindInference :: forall t0123456789876543210 - t0123456789876543210 - arg. SameKind (Apply (BarSym1 t0123456789876543210) arg) (BarSym2 t0123456789876543210 arg) => - BarSym1 t0123456789876543210 t0123456789876543210 - type instance Apply (BarSym1 t0123456789876543210) t0123456789876543210 = Bar t0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings BarSym0 where - suppressUnusedWarnings - = Data.Tuple.snd (((,) BarSym0KindInference) ()) - data BarSym0 :: (~>) Bool ((~>) Bool Foo) - where - BarSym0KindInference :: forall t0123456789876543210 - arg. SameKind (Apply BarSym0 arg) (BarSym1 arg) => - BarSym0 t0123456789876543210 - type instance Apply BarSym0 t0123456789876543210 = BarSym1 t0123456789876543210 - data SBool :: Bool -> GHC.Types.Type - where - SFalse :: SBool False - STrue :: SBool True - type instance Sing @Bool = SBool - instance SingKind Bool where - type Demote Bool = Bool - fromSing SFalse = False - fromSing STrue = True - toSing False = SomeSing SFalse - toSing True = SomeSing STrue - data SFoo :: Foo -> GHC.Types.Type - where - SBar :: forall (n :: Bool) (n :: Bool). - (Sing (n :: Bool)) -> (Sing (n :: Bool)) -> SFoo (Bar n n) - type instance Sing @Foo = SFoo - instance SingKind Foo where - type Demote Foo = Foo - fromSing (SBar b b) = (Bar (fromSing b)) (fromSing b) - toSing (Bar (b :: Demote Bool) (b :: Demote Bool)) - = case - ((,) (toSing b :: SomeSing Bool)) (toSing b :: SomeSing Bool) - of { - (,) (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 - instance SingI (BarSym0 :: (~>) Bool ((~>) Bool Foo)) where - sing = (singFun2 @BarSym0) SBar - instance SingI d => - SingI (BarSym1 (d :: Bool) :: (~>) Bool Foo) where - sing = (singFun1 @(BarSym1 (d :: Bool))) (SBar (sing @d)) -Singletons/TopLevelPatterns.hs:(0,0)-(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 - 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] |] - ======> - otherwise :: Bool - otherwise = True - id :: 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 family Case_0123456789876543210 t where - Case_0123456789876543210 '[_, - y_0123456789876543210] = y_0123456789876543210 - type family Case_0123456789876543210 t where - Case_0123456789876543210 '[y_0123456789876543210, - _] = y_0123456789876543210 - type family Case_0123456789876543210 t where - Case_0123456789876543210 ('Bar _ y_0123456789876543210) = y_0123456789876543210 - type family Case_0123456789876543210 t where - Case_0123456789876543210 ('Bar y_0123456789876543210 _) = y_0123456789876543210 - type family Case_0123456789876543210 a_0123456789876543210 t where - Case_0123456789876543210 a_0123456789876543210 '(_, - y_0123456789876543210) = y_0123456789876543210 - type family Case_0123456789876543210 a_0123456789876543210 t where - Case_0123456789876543210 a_0123456789876543210 '(y_0123456789876543210, - _) = y_0123456789876543210 - type family Case_0123456789876543210 a_0123456789876543210 t where - Case_0123456789876543210 a_0123456789876543210 '[_, - y_0123456789876543210] = y_0123456789876543210 - type family Case_0123456789876543210 a_0123456789876543210 t where - Case_0123456789876543210 a_0123456789876543210 '[y_0123456789876543210, - _] = y_0123456789876543210 - type MSym0 = M - type LSym0 = L - type X_0123456789876543210Sym0 = X_0123456789876543210 - type KSym0 = K - type JSym0 = J - type X_0123456789876543210Sym0 = X_0123456789876543210 - type ISym1 (a0123456789876543210 :: Bool) = I a0123456789876543210 - instance SuppressUnusedWarnings ISym0 where - suppressUnusedWarnings - = Data.Tuple.snd (((,) ISym0KindInference) ()) - data ISym0 :: (~>) Bool Bool - where - ISym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply ISym0 arg) (ISym1 arg) => - ISym0 a0123456789876543210 - type instance Apply ISym0 a0123456789876543210 = I a0123456789876543210 - type HSym1 (a0123456789876543210 :: Bool) = H a0123456789876543210 - instance SuppressUnusedWarnings HSym0 where - suppressUnusedWarnings - = Data.Tuple.snd (((,) HSym0KindInference) ()) - data HSym0 :: (~>) Bool Bool - where - HSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply HSym0 arg) (HSym1 arg) => - HSym0 a0123456789876543210 - type instance Apply HSym0 a0123456789876543210 = H a0123456789876543210 - type X_0123456789876543210Sym0 = X_0123456789876543210 - type GSym1 (a0123456789876543210 :: Bool) = G a0123456789876543210 - instance SuppressUnusedWarnings GSym0 where - suppressUnusedWarnings - = Data.Tuple.snd (((,) GSym0KindInference) ()) - data GSym0 :: (~>) Bool Bool - where - GSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply GSym0 arg) (GSym1 arg) => - GSym0 a0123456789876543210 - type instance Apply GSym0 a0123456789876543210 = G a0123456789876543210 - type FSym1 (a0123456789876543210 :: Bool) = F a0123456789876543210 - instance SuppressUnusedWarnings FSym0 where - suppressUnusedWarnings - = Data.Tuple.snd (((,) FSym0KindInference) ()) - data FSym0 :: (~>) Bool Bool - where - FSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply FSym0 arg) (FSym1 arg) => - FSym0 a0123456789876543210 - type instance Apply FSym0 a0123456789876543210 = F a0123456789876543210 - type X_0123456789876543210Sym0 = X_0123456789876543210 - type False_Sym0 = False_ - type NotSym1 (a0123456789876543210 :: Bool) = - Not a0123456789876543210 - instance SuppressUnusedWarnings NotSym0 where - suppressUnusedWarnings - = Data.Tuple.snd (((,) NotSym0KindInference) ()) - data NotSym0 :: (~>) Bool Bool - where - NotSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply NotSym0 arg) (NotSym1 arg) => - NotSym0 a0123456789876543210 - type instance Apply NotSym0 a0123456789876543210 = Not a0123456789876543210 - type IdSym1 (a0123456789876543210 :: a0123456789876543210) = - Id a0123456789876543210 - instance SuppressUnusedWarnings IdSym0 where - suppressUnusedWarnings - = Data.Tuple.snd (((,) IdSym0KindInference) ()) - data IdSym0 :: forall a0123456789876543210. - (~>) a0123456789876543210 a0123456789876543210 - where - IdSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply IdSym0 arg) (IdSym1 arg) => - IdSym0 a0123456789876543210 - type instance Apply IdSym0 a0123456789876543210 = Id a0123456789876543210 - type OtherwiseSym0 = Otherwise - type family M :: Bool where - M = Case_0123456789876543210 X_0123456789876543210Sym0 - type family L :: Bool where - L = Case_0123456789876543210 X_0123456789876543210Sym0 - type family X_0123456789876543210 where - X_0123456789876543210 = Apply (Apply (:@#@$) (Apply NotSym0 TrueSym0)) (Apply (Apply (:@#@$) (Apply IdSym0 FalseSym0)) '[]) - type family K :: Bool where - K = Case_0123456789876543210 X_0123456789876543210Sym0 - type family J :: Bool where - J = Case_0123456789876543210 X_0123456789876543210Sym0 - type family X_0123456789876543210 where - X_0123456789876543210 = Apply (Apply BarSym0 TrueSym0) (Apply HSym0 FalseSym0) - type family I (a :: Bool) :: Bool where - I a_0123456789876543210 = Apply (Case_0123456789876543210 a_0123456789876543210 X_0123456789876543210Sym0) a_0123456789876543210 - type family H (a :: Bool) :: Bool where - H a_0123456789876543210 = Apply (Case_0123456789876543210 a_0123456789876543210 X_0123456789876543210Sym0) a_0123456789876543210 - type family X_0123456789876543210 where - X_0123456789876543210 = Apply (Apply Tuple2Sym0 FSym0) GSym0 - type family G (a :: Bool) :: Bool where - G a_0123456789876543210 = Apply (Case_0123456789876543210 a_0123456789876543210 X_0123456789876543210Sym0) a_0123456789876543210 - type family F (a :: Bool) :: Bool where - F a_0123456789876543210 = Apply (Case_0123456789876543210 a_0123456789876543210 X_0123456789876543210Sym0) a_0123456789876543210 - type family X_0123456789876543210 where - X_0123456789876543210 = Apply (Apply (:@#@$) NotSym0) (Apply (Apply (:@#@$) IdSym0) '[]) - type family False_ where - 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 family Otherwise :: Bool where - Otherwise = TrueSym0 - sM :: Sing (MSym0 :: Bool) - sL :: Sing (LSym0 :: Bool) - sX_0123456789876543210 :: Sing X_0123456789876543210Sym0 - sK :: Sing (KSym0 :: Bool) - sJ :: Sing (JSym0 :: Bool) - sX_0123456789876543210 :: Sing X_0123456789876543210Sym0 - sI :: forall (t :: Bool). Sing t -> Sing (Apply ISym0 t :: Bool) - sH :: forall (t :: Bool). Sing t -> Sing (Apply HSym0 t :: Bool) - sX_0123456789876543210 :: Sing X_0123456789876543210Sym0 - sG :: forall (t :: Bool). Sing t -> Sing (Apply GSym0 t :: Bool) - sF :: forall (t :: Bool). Sing t -> Sing (Apply FSym0 t :: Bool) - sX_0123456789876543210 :: Sing X_0123456789876543210Sym0 - sFalse_ :: Sing False_Sym0 - sNot :: - forall (t :: Bool). Sing t -> Sing (Apply NotSym0 t :: Bool) - sId :: forall a (t :: a). Sing t -> Sing (Apply IdSym0 t :: a) - sOtherwise :: Sing (OtherwiseSym0 :: Bool) - sM - = (GHC.Base.id - @(Sing (Case_0123456789876543210 X_0123456789876543210Sym0 :: Bool))) - (case sX_0123456789876543210 of { - SCons _ - (SCons (sY_0123456789876543210 :: Sing y_0123456789876543210) SNil) - -> sY_0123456789876543210 }) - sL - = (GHC.Base.id - @(Sing (Case_0123456789876543210 X_0123456789876543210Sym0 :: Bool))) - (case sX_0123456789876543210 of { - SCons (sY_0123456789876543210 :: Sing y_0123456789876543210) - (SCons _ SNil) - -> sY_0123456789876543210 }) - sX_0123456789876543210 - = (applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing ((singFun1 @NotSym0) sNot)) STrue))) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((applySing ((singFun1 @IdSym0) sId)) SFalse))) - SNil) - sK - = (GHC.Base.id - @(Sing (Case_0123456789876543210 X_0123456789876543210Sym0 :: Bool))) - (case sX_0123456789876543210 of { - SBar _ (sY_0123456789876543210 :: Sing y_0123456789876543210) - -> sY_0123456789876543210 }) - sJ - = (GHC.Base.id - @(Sing (Case_0123456789876543210 X_0123456789876543210Sym0 :: Bool))) - (case sX_0123456789876543210 of { - SBar (sY_0123456789876543210 :: Sing y_0123456789876543210) _ - -> sY_0123456789876543210 }) - sX_0123456789876543210 - = (applySing ((applySing ((singFun2 @BarSym0) SBar)) STrue)) - ((applySing ((singFun1 @HSym0) sH)) SFalse) - sI (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((GHC.Base.id - @(Sing (Case_0123456789876543210 a_0123456789876543210 X_0123456789876543210Sym0))) - (case sX_0123456789876543210 of { - STuple2 _ (sY_0123456789876543210 :: Sing y_0123456789876543210) - -> sY_0123456789876543210 }))) - sA_0123456789876543210 - sH (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((GHC.Base.id - @(Sing (Case_0123456789876543210 a_0123456789876543210 X_0123456789876543210Sym0))) - (case sX_0123456789876543210 of { - STuple2 (sY_0123456789876543210 :: Sing y_0123456789876543210) _ - -> sY_0123456789876543210 }))) - sA_0123456789876543210 - sX_0123456789876543210 - = (applySing - ((applySing ((singFun2 @Tuple2Sym0) STuple2)) - ((singFun1 @FSym0) sF))) - ((singFun1 @GSym0) sG) - sG (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((GHC.Base.id - @(Sing (Case_0123456789876543210 a_0123456789876543210 X_0123456789876543210Sym0))) - (case sX_0123456789876543210 of { - SCons _ - (SCons (sY_0123456789876543210 :: Sing y_0123456789876543210) SNil) - -> sY_0123456789876543210 }))) - sA_0123456789876543210 - sF (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((GHC.Base.id - @(Sing (Case_0123456789876543210 a_0123456789876543210 X_0123456789876543210Sym0))) - (case sX_0123456789876543210 of { - SCons (sY_0123456789876543210 :: Sing y_0123456789876543210) - (SCons _ SNil) - -> sY_0123456789876543210 }))) - sA_0123456789876543210 - sX_0123456789876543210 - = (applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) - ((singFun1 @NotSym0) sNot))) - ((applySing - ((applySing ((singFun2 @(:@#@$)) SCons)) ((singFun1 @IdSym0) sId))) - SNil) - sFalse_ = SFalse - sNot STrue = SFalse - sNot SFalse = STrue - sId (sX :: Sing x) = sX - sOtherwise = STrue - instance SingI (ISym0 :: (~>) Bool Bool) where - sing = (singFun1 @ISym0) sI - instance SingI (HSym0 :: (~>) Bool Bool) where - sing = (singFun1 @HSym0) sH - instance SingI (GSym0 :: (~>) Bool Bool) where - sing = (singFun1 @GSym0) sG - instance SingI (FSym0 :: (~>) Bool Bool) where - sing = (singFun1 @FSym0) sF - instance SingI (NotSym0 :: (~>) Bool Bool) where - sing = (singFun1 @NotSym0) sNot - instance SingI (IdSym0 :: (~>) a a) where - sing = (singFun1 @IdSym0) sId diff --git a/tests/compile-and-dump/Singletons/TopLevelPatterns.hs b/tests/compile-and-dump/Singletons/TopLevelPatterns.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/TopLevelPatterns.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# OPTIONS_GHC -Wno-incomplete-patterns #-} - -module Singletons.TopLevelPatterns where - -import Data.Singletons -import Data.Singletons.Prelude.List -import Data.Singletons.SuppressUnusedWarnings -import Data.Singletons.TH hiding (SBool(..), 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 - - 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/TypeRepTYPE.ghc88.template b/tests/compile-and-dump/Singletons/TypeRepTYPE.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/TypeRepTYPE.ghc88.template +++ /dev/null diff --git a/tests/compile-and-dump/Singletons/TypeRepTYPE.hs b/tests/compile-and-dump/Singletons/TypeRepTYPE.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/TypeRepTYPE.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE MagicHash #-} -module TypeRepTYPE where - -import Data.Kind (Type) -import Data.Singletons.Decide -import Data.Singletons.Prelude -import Data.Singletons.TypeRepTYPE -import GHC.Exts (Char#, RuntimeRep(..), TYPE, Word#) -import Type.Reflection (Typeable, typeRep) - -eqTYPETest1 :: (Type == Type) :~: 'True -eqTYPETest1 = Refl - -eqTYPETest2 :: (Type == TYPE 'IntRep) :~: 'False -eqTYPETest2 = Refl - -f :: Sing (a :: Type) -> Maybe a -f tr - | Proved Refl <- tr %~ sing @Bool - = Just True - | Proved Refl <- tr %~ sing @Ordering - = Just EQ - | otherwise - = Nothing - -data MaybeWordRep (a :: TYPE 'WordRep) - = NothingWordRep - | JustWordRep a - -g :: Sing (a :: TYPE 'WordRep) -> MaybeWordRep a -g tr - | Proved Refl <- tr %~ sing @Word# - = JustWordRep 42## - | Proved Refl <- tr %~ sing @Char# - = JustWordRep 'j'# - | otherwise - = NothingWordRep - -h :: forall (rep :: RuntimeRep) (a :: TYPE rep). Typeable a => Sing a -h = typeRep @a diff --git a/tests/compile-and-dump/Singletons/Undef.ghc88.template b/tests/compile-and-dump/Singletons/Undef.ghc88.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Undef.ghc88.template +++ /dev/null @@ -1,47 +0,0 @@ -Singletons/Undef.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| foo :: Bool -> Bool - foo = undefined - bar :: Bool -> Bool - bar = error "urk" |] - ======> - foo :: Bool -> Bool - foo = undefined - bar :: Bool -> Bool - bar = error "urk" - type BarSym1 (a0123456789876543210 :: Bool) = - Bar a0123456789876543210 - instance SuppressUnusedWarnings BarSym0 where - suppressUnusedWarnings = snd (((,) BarSym0KindInference) ()) - data BarSym0 :: (~>) Bool Bool - where - BarSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply BarSym0 arg) (BarSym1 arg) => - BarSym0 a0123456789876543210 - type instance Apply BarSym0 a0123456789876543210 = Bar a0123456789876543210 - type FooSym1 (a0123456789876543210 :: Bool) = - Foo a0123456789876543210 - instance SuppressUnusedWarnings FooSym0 where - suppressUnusedWarnings = snd (((,) FooSym0KindInference) ()) - data FooSym0 :: (~>) Bool Bool - where - FooSym0KindInference :: forall a0123456789876543210 - arg. SameKind (Apply FooSym0 arg) (FooSym1 arg) => - FooSym0 a0123456789876543210 - type instance Apply FooSym0 a0123456789876543210 = Foo a0123456789876543210 - type family Bar (a :: Bool) :: Bool where - Bar a_0123456789876543210 = Apply (Apply ErrorSym0 "urk") a_0123456789876543210 - type family Foo (a :: Bool) :: Bool where - Foo a_0123456789876543210 = Apply UndefinedSym0 a_0123456789876543210 - sBar :: - forall (t :: Bool). Sing t -> Sing (Apply BarSym0 t :: Bool) - sFoo :: - forall (t :: Bool). Sing t -> Sing (Apply FooSym0 t :: Bool) - sBar (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (sError (sing :: Sing "urk")) sA_0123456789876543210 - sFoo (sA_0123456789876543210 :: Sing a_0123456789876543210) - = sUndefined sA_0123456789876543210 - instance SingI (BarSym0 :: (~>) Bool Bool) where - sing = (singFun1 @BarSym0) sBar - instance SingI (FooSym0 :: (~>) Bool Bool) where - sing = (singFun1 @FooSym0) sFoo diff --git a/tests/compile-and-dump/Singletons/Undef.hs b/tests/compile-and-dump/Singletons/Undef.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Undef.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -module Singletons.Undef where - -import Data.Singletons.TH - -$(singletons [d| - foo :: Bool -> Bool - foo = undefined - - bar :: Bool -> Bool - bar = error "urk" - |]) diff --git a/tests/compile-and-dump/buildGoldenFiles.awk b/tests/compile-and-dump/buildGoldenFiles.awk deleted file mode 100644 --- a/tests/compile-and-dump/buildGoldenFiles.awk +++ /dev/null @@ -1,1 +0,0 @@ -/INSERT/{while((getline line < $2) > 0 ){if(line !~ /INSERT/){print line}}close($2);next}1