diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,35 @@ -Changelog for singletons project -================================ +Changelog for the `singletons` project +====================================== + +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 --- 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,1165 +1,24 @@ -singletons 2.7 -============== - -[![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 () and -Ryan Scott (). 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 the 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 and _singling_ functions to dependently typed equivalents. -Accordingly, it exports a Prelude of promoted and singled -functions, mirroring functions and datatypes found in the `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.10.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` -* `NoCUSKs` -* `NoStarIsType` -* `PolyKinds` -* `RankNTypes` -* `ScopedTypeVariables` -* `StandaloneKindSignatures` -* `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 to consider toggling various warning flags: - -* `-Wno-redundant-constraints`. - The code that `singletons` generates uses redundant constraints, and there - seems to be no way, without a large library redesign, to avoid this. -* `-fenable-th-splice-warnings`. - By default, GHC does not run pattern-match coverage checker warnings on code - inside of Template Haskell quotes. This is an extremely common thing to do - in `singletons`, so you may consider opting in to these warnings. - -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 promoted and -singled equivalents of functions from the real `Prelude`. -Note that not all functions from original `Prelude` could be promoted or -singled. - -`Data.Singletons.Prelude.*` modules provide promoted and singled equivalents of -definitions found in several commonly used `base` library modules, including -(but not limited to) `Data.Bool`, `Data.Maybe`, `Data.Either`, `Data.List`, -`Data.Tuple`, `Data.Void` and `GHC.Base`. We also provide promoted and singled -versions of common type classes, including (but not limited to) `Eq`, `Ord`, -`Show`, `Enum`, and `Bounded`. - -`Data.Singletons.Decide` exports type classes for propositional equality. - -`Data.Singletons.TypeLits` exports definitions for working with `GHC.TypeLits`. - -Functions to generate singletons --------------------------------- - -The top-level functions used to generate promoted or singled definitions 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] -``` - -This function 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 Sing :: k -> Type -type family Sing -``` - -The type family of singleton types. A new instance of this type family is -generated for every new singleton type. - -```haskell -class SingI a where - sing :: Sing a -``` - -A class used to pass singleton values implicitly. The `sing` method produces -an explicit singleton value. - -```haskell -type SomeSing :: Type -> Type -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 -type SingKind :: Type -> Constraint -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 -type SingInstance :: k -> Type -data SingInstance a 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 `(==)` (in the `PEq` - class) and the `(%==`) method (in the `SEq` class). - 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 :: Type -> Constraint -type ShowSing k = (forall z. Show (Sing (z :: k)) -- Approximately -``` - -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 Error :: a -> k - type family Error str 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. These include (but are not limited to): - -* `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 the -"Supported Haskell constructs" section of this README for a full list. - -Promoted definitions are usually generated by calling the `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 _defunctionalization symbols_. These are required to represent -partial application at the type level. For more information, refer to the -"Promotion and partial application" section below. - -Users also have access to `Data.Singletons.Prelude` and its submodules (e.g., -`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. - -Promotion and partial application ---------------------------------- - -Promoting higher-order functions proves to be surprisingly tricky. Consider -this example: - -```hs -$(promote [d| - map :: (a -> b) -> [a] -> [b] - map _ [] = [] - map f (x:xs) = f x : map f xs - |]) -``` - -A naïve attempt to promote `map` would be: - -```hs -type Map :: (a -> b) -> [a] -> [b] -type family Map f xs where - Map _ '[] = '[] - Map f (x:xs) = f x : Map f xs -``` - -While this compiles, it is much less useful than we would like. In particular, -common idioms like `Map Id xs` will not typecheck, since GHC requires that all -invocations of type families be fully saturated. That is, the use of `Id` in -`Map Id xs` is rejected since it is not applied to one argument, which the -number of arguments that `Id` was defined with. For more information on this -point, refer to the promotion paper. - -Not having the ability to partially apply functions at the type level is rather -painful, so we do the next best thing: we _defunctionalize_ all promoted -functions so that we can emulate partial application. For example, if one were -to promote the `id` function: - -```hs -$(promote [d| - id :: a -> a - id x = x - |] -``` - -Then in addition to generating the promoted `Id` type family, two -defunctionalization symbols will be generated: - -```hs -type IdSym0 :: a ~> a -type IdSym0 x = x - -type IdSym1 (x :: a) = Id a -``` - -In general, a function that accepts N arguments generates N+1 defunctionalization -symbols when promoted. - -`IdSym1` is a _fully saturated_ defunctionalization symbol and is usually only -needed when generating code through the Template Haskell machinery. `IdSym0` -is more interesting: it has the kind `a ~> a`, which has a special arrow type -`(~>)`. Defunctionalization symbols using the `(~>)` kind are type-level -constants that can be "applied" using a special `Apply` type family: - -```hs -type Apply :: (a ~> b) -> a -> b -type family Apply f x -``` - -Every defunctionalization symbol comes with a corresponding `Apply` instance -(except for fully saturated defunctionalization symbols). For instance, here -is the `Apply` instance for `IdSym0`: - -```hs -type instance Apply IdSym0 x = IdSym1 x -``` - -The `(~>)` kind is used when promoting higher-order functions so that partially -applied arguments can be passed to them. For instance, here is our final attempt -at promoting `map`: - -```hs -type Map :: (a ~> b) -> [a] -> [b] -type family Map f xs where - Map _ '[] = '[] - Map f (x:xs) = Apply f x : Map f xs -``` - -Now `map id xs` can be promoted to `Map IdSym0 xs`, which typechecks without issue. - -## Defunctionalizing existing type families - -The most common way to defunctionalize functions is by promoting them with the -Template Haskell machinery. One can also defunctionalize existing type families, -however, by using `genDefunSymbols`. For example: - -```hs -type MyTypeFamily :: Nat -> Bool -type family MyTypeFamily n - -$(genDefunSymbols [''MyTypeFamily]) -``` - -This can be especially useful if `MyTypeFamily` needs to be implemented by -hand. Be aware of the following design limitations of `genDefunSymbols`: - -* `genDefunSymbols` only works for type-level declarations. Namely, it only - works when given the names of type classes, type families, type synonyms, - or data types. Attempting to pass the name of a term level function, - class method, data constructor, or record selector will throw an error. -* Passing the name of a data type to `genDefunSymbols` will cause its - data constructors to be defunctionalized but _not_ its record selectors. -* Passing the name of a type class to `genDefunSymbols` will cause the - class itself to be defunctionalized, but /not/ its associated type families - or methods. - -Note that the limitations above reflect the current design of -`genDefunSymbols`. As a result, they are subject to change in the future. - -## Defunctionalization and visible dependent quantification - -Unlike most other parts of `singletons`, which disallow visible dependent -quantification (VDQ), `genDefunSymbols` has limited support for VDQ. -Consider this example: - -```hs -type MyProxy :: forall (k :: Type) -> k -> Type -type family MyProxy k (a :: k) :: Type where - MyProxy k (a :: k) = Proxy a - -$(genDefunSymbols [''MyProxy]) -``` - -This will generate the following defunctionalization symbols: - -```hs -type MyProxySym0 :: Type ~> k ~> Type -type MyProxySym1 :: forall (k :: Type) -> k ~> Type -type MyProxySym2 k (a :: k) = MyProxy k a -``` - -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 this: - -```hs -type MyProxySym0 :: forall (k :: Type) ~> k ~> Type -``` - -This 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. - -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 singled 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. - -If desired, you can pick your own naming conventions by using the -`Data.Singletons.TH.Options` module. Here is an example of how this module can -be used to prefix a singled data constructor with `MyS` instead of `S`: - -```hs -import Control.Monad.Trans.Class -import Data.Singletons.TH -import Data.Singletons.TH.Options -import Language.Haskell.TH (Name, mkName, nameBase) - -$(let myPrefix :: Name -> Name - myPrefix name = mkName ("MyS" ++ nameBase name) in - - withOptions defaultOptions{singledDataConName = myPrefix} $ - singletons $ lift [d| data T = MkT |]) -``` - -Supported Haskell constructs ----------------------------- - -## Full support - -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 -* 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) -* pattern guards -* case -* let -* lambda expressions -* `!` and `~` patterns (silently but successfully ignored during promotion) -* class and instance declarations -* signatures (e.g., `(x :: Maybe a)`) in expressions -* `InstanceSigs` - -## Partial support - -The following constructs are partially supported: - -* `deriving` -* finite arithmetic sequences -* records -* signatures (e.g., `(x :: Maybe a)`) in patterns -* functional dependencies -* type families - -See the following sections for more details. - -### `deriving` - -`singletons` is slightly more conservative with respect to `deriving` than GHC is. -The only classes that `singletons` can derive without an explicit deriving -strategy are the following stock classes: - -* `Eq` -* `Ord` -* `Show` -* `Bounded` -* `Enum` -* `Functor` -* `Foldable` -* `Traversable` - -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` or `via` strategies, -as there is no equivalent of `coerce` at the type level. - -### Finite arithmetic sequences - -`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. - -### Records - -Record selectors are promoted to top-level functions, as there is no record -syntax at the type level. Record selectors are also singled to top-level -functions because embedding records directly into singleton data constructors -can result in surprising behavior (see -[this bug report](https://github.com/goldfirere/singletons/issues/364) for more -details on this point). TH-generated code is not affected by this limitation -since `singletons` desugars away most uses of record syntax. On the other hand, -it is not possible to write out code like -`SIdentity { sRunIdentity = SIdentity STrue }` by hand. - -### Signatures in patterns - -`singletons` can promote basic pattern signatures, such as in the following -examples: - -```hs -f :: forall a. a -> a -f (x :: a) = (x :: a) - -g :: forall a. a -> a -g (x :: b) = (x :: b) -- b is the same as a -``` - -What does /not/ work are more advanced uses of pattern signatures that take -advantage of the fact that type variables in pattern signatures can alias other -types. Here are some examples of functions that one cannot promote: - -* ```hs - h :: a -> a -> a - h (x :: a) (_ :: b) = x - ``` - - This typechecks by virtue of the fact that `b` aliases `a`. However, the same - trick does not work when `h` is promoted to a type family, as a type family - would consider `a` and `b` to be distinct type variables. -* ```hs - i :: Bool -> Bool - i (x :: a) = x - ``` - - This typechecks by virtue of the fact that `a` aliases `Bool`. Again, this - would not work at the type level, as a type family would consider `a` to be - a separate type from `Bool`. - -### Functional dependencies - -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. - -### Type families - -Promoting functions with types that contain type families is likely to fail due to -[GHC#12564](https://gitlab.haskell.org/ghc/ghc/issues/12564). -Note that promoting type family _declarations_ is fine -(and often desired, since that produces defunctionalization symbols for them). - -## Support for promotion, but not singling - -The following constructs are supported for promotion but not singleton generation: - -* data constructors with contexts -* overlapping patterns -* `GADTs` -* instances of poly-kinded type classes - -See the following sections for more details. - -### Data constructors with contexts - -For example, the following datatype does not single: - -```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 single 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. - -### `GADTs` - -Singling GADTs is likely to fail due to the generated `SingKind` instances -not typechecking. (See -[#150](https://github.com/goldfirere/singletons/issues/150)). -However, one can often work around the issue by suppressing the generation -of `SingKind` instances by using custom `Options`. See the `T150` test case -for an example. - -### Instances of poly-kinded type classes - -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 - -instance C [] where - method = [] -``` - -Adding a type signature for `method` in the `C []` is sufficient -to work around the issue, though: - -```haskell -instance C [] where - method :: [a] - method = [] -``` - -## Little to no support - -The following constructs are either unsupported or almost never work: - -* scoped type variables -* datatypes that store arrows, `Nat`, or `Symbol` -* rank-n types -* promoting `TypeRep`s -* `TypeApplications` - -See the following sections for more details. - -### Scoped type variables - -Promoting functions that rely on the behavior of `ScopedTypeVariables` is very -tricky—see -[this GitHub issue](https://github.com/goldfirere/singletons/issues/433) for an -extended discussion on the topic. This is not to say that promoting functions -that rely on `ScopedTypeVariables` is guaranteed to fail, but it is rather -fragile. To demonstrate how fragile this is, note that the following function -will promote successfully: - -```hs -f :: forall a. a -> a -f x = id x :: a -``` - -But this one will not: - -```hs -g :: forall a. a -> a -g x = id (x :: a) -``` - -There are usually workarounds one can use instead of `ScopedTypeVariables`: - -1. Use pattern signatures: - - ```hs - g :: forall a. a -> a - g (x :: a) = id (x :: a) - ``` -2. Use local definitions: - - ```hs - g :: forall a. a -> a - g x = id' a - where - id' :: a -> a - id' x = x - ``` - -### Arrows, `Nat`, `Symbol`, and literals - -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. Functions -working over 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. - -### Rank-n types - -`singletons` does not support type signatures that have higher-rank types. -More precisely, the only types that can be promoted or singled are -_vanilla_ types, where a vanilla function type is a type that: - -1. Only uses a `forall` at the top level, if used at all. That is to say, it - does not contain any nested or higher-rank `forall`s. - -2. Only uses a context (e.g., `c => ...`) at the top level, if used at all, - and only after the top-level `forall` if one is present. That is to say, - it does not contain any nested or higher-rank contexts. - -3. Contains no visible dependent quantification. - -### Promoting `TypeRep`s - -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. - -### `TypeApplications` - -`singletons` currently cannot handle promoting or singling code that uses -`TypeApplications` syntax, so `singletons` will simply drop any visible type -applications. For example, `id @Bool True` will be promoted to `Id True` and -singled to `sId STrue`. See -[#378](https://github.com/goldfirere/singletons/issues/378) for a discussion -of how `singletons` may support `TypeApplications` in the future. - -On the other hand, `singletons` does make an effort to preserve the order of -type variables when promoting and singling certain constructors. These include: - -* Kind signatures of promoted top-level functions -* Type signatures of singled top-level functions -* Kind signatures of singled data type declarations -* Type signatures of singled data constructors -* Kind signatures of singled class declarations -* Type signatures of singled class methods - -For example, consider this type signature: - -```haskell -const2 :: forall b a. a -> b -> a -``` - -The promoted version of `const` will have the following kind signature: - -```haskell -type Const2 :: forall b a. a -> b -> a -``` - -The singled version of `const2` will have the following type signature: - -```haskell -sConst2 :: forall b a (x :: a) (y :: a). Sing x -> Sing y -> Sing (Const x y) -``` - -Therefore, writing `const2 @T1 @T2` works just as well as writing -`Const2 @T1 @T2` or `sConst2 @T1 @T2`, since the signatures for `const2`, `Const2`, -and `sConst2` all begin with `forall b a.`, in that order. Again, it is worth -emphasizing that the TH machinery does not support promoting or singling -`const2 @T1 @T2` directly, but you can write the type applications by hand if -you so choose. - -`singletons` also has limited support for preserving the order of type variables -for the following constructs: - -* Kind signatures of defunctionalization symbols. - The order of type variables is only guaranteed to be preserved if: - - 1. The thing being defunctionalized has a standalone type (or kind) - signature. - 2. The type (or kind) signature of the thing being defunctionalized is - a vanilla type. (See the "Rank-n types" section above for what "vanilla" - means.) - - If either of these conditions do not hold, `singletons` will fall back to - a slightly different approach to generating defunctionalization symbols that - does *not* guarantee the order of type variables. As an example, consider the - following example: - - ```haskell - data T (x :: a) :: forall b. b -> Type - $(genDefunSymbols [''T]) - ``` - - The kind of `T` is `forall a. a -> forall b. b -> Type`, which is not - vanilla. Currently, `singletons` will generate the following - defunctionalization symbols for `T`: - - ```haskell - data TSym0 :: a ~> b ~> Type - data TSym1 (x :: a) :: b ~> Type - ``` - - In both symbols, the kind starts with `forall a b.` rather than quantifying - the `b` after the visible argument of kind `a`. These symbols can still be - useful even with this flaw, so `singletons` permits generating them - regardless. Be aware of this drawback if you try doing something similar - yourself! - -* Kind signatures of promoted class methods. - The order of type variables will often "just work" by happy coincidence, but - there are some situations where this does not happen. Consider the following - class: - - ```haskell - class C (b :: Type) where - m :: forall a. a -> b -> a - ``` - - The full type of `m` is `forall b. C b => forall a. a -> b -> a`, which binds - `b` before `a`. This order is preserved when singling `m`, but *not* when - promoting `m`. This is because the `C` class is promoted as follows: - - ```haskell - class PC (b :: Type) where - type M (x :: a) (y :: b) :: a - ``` - - Due to the way GHC kind-checks associated type families, the kind of `M` is - `forall a b. a -> b -> a`, which binds `b` *after* `a`. Moreover, the - `StandaloneKindSignatures` extension does not provide a way to explicitly - declare the full kind of an associated type family, so this limitation is - not easy to work around. - - The defunctionalization symbols for `M` will also follow a similar - order of type variables: - - ```haskell - type MSym0 :: forall a b. a ~> b ~> a - type MSym1 :: forall a b. a -> b ~> a - ``` +`singletons` +============ + +[![Hackage](https://img.shields.io/hackage/v/singletons.svg)](http://hackage.haskell.org/package/singletons) + +`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://cs.brynmawr.edu/~rae/papers/2012/singletons/paper.pdf), +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` +[`README`](https://github.com/goldfirere/singletons/blob/master/README.md). + +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`. 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,167 +1,77 @@ name: singletons -version: 2.7 - -- Remember to bump version in the Makefile as well -cabal-version: >= 1.10 -synopsis: A framework for generating singleton types +version: 3.0 +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.10.1 -extra-source-files: README.md, CHANGES.md, tests/README.md, - 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/*.golden, - tests/compile-and-dump/InsertionSort/*.golden, - tests/compile-and-dump/Promote/*.golden, - tests/compile-and-dump/Singletons/*.golden +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.4 + , GHC == 9.0.1 + , GHCJS==8.4 +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. + @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. () . - Version 1.0 and onwards works a lot harder to promote functions. See the - paper published at Haskell Symposium, 2014: - . + @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.7 + subdir: singletons + tag: v3.0 source-repository head type: git location: https://github.com/goldfirere/singletons.git + subdir: singletons branch: master -custom-setup - setup-depends: - base >= 4.14 && < 4.15, - Cabal >= 3.2 && < 3.3, - directory >= 1, - filepath >= 1.3 - library hs-source-dirs: src - build-depends: base >= 4.14 && < 4.15, - mtl >= 2.2.1, - ghc-boot-th, - template-haskell, - containers >= 0.5, - th-desugar >= 1.11 && < 1.12, - pretty, - syb >= 0.4, - text >= 1.2, - transformers >= 0.5.2 + build-depends: base >= 4.9 && < 4.16 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.TH.Options - 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.Proxy - 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.Ord.Disambiguation - Data.Singletons.Prelude.Semigroup.Internal - Data.Singletons.Prelude.Semigroup.Internal.Disambiguation - 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.14 && < 4.15, - bytestring >= 0.10.9, - deepseq >= 1.4.4, - 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.16, + singletons diff --git a/src/Data/Singletons.hs b/src/Data/Singletons.hs --- a/src/Data/Singletons.hs +++ b/src/Data/Singletons.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE FlexibleInstances #-} @@ -6,17 +8,25 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} -{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE ViewPatterns #-} +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE QuantifiedConstraints #-} +#else +{-# LANGUAGE TypeInType #-} +#endif + +#if __GLASGOW_HASKELL__ >= 810 +{-# LANGUAGE StandaloneKindSignatures #-} +#endif + ----------------------------------------------------------------------------- -- | -- Module : Data.Singletons @@ -26,9 +36,10 @@ -- 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@. +-- 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 @@ -61,7 +72,10 @@ -- ** Defunctionalization TyFun, type (~>), TyCon1, TyCon2, TyCon3, TyCon4, TyCon5, TyCon6, TyCon7, TyCon8, - TyCon, Apply, type (@@), ApplyTyCon, ApplyTyConAux1, ApplyTyConAux2, + 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 @@ -96,100 +110,882 @@ 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) +import Data.Kind (Constraint, Type) +import Data.Proxy (Proxy(..)) +import GHC.Exts (Proxy#) +import Unsafe.Coerce (unsafeCoerce) +-- | 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) + ---------------------------------------------------------------------- ----- SingI TyCon{N} instances ---------------------------------------- +---- Sing & friends -------------------------------------------------- ---------------------------------------------------------------------- +-- | The singleton kind-indexed type family. +#if __GLASGOW_HASKELL__ >= 810 +type Sing :: k -> Type +#endif +type family Sing :: k -> Type + {- -Generates SingI instances for TyCon1 through TyCon8: +Note [The kind of Sing] +~~~~~~~~~~~~~~~~~~~~~~~ +It is important to define Sing like this: - 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) - ... + 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. -} -$(singITyConInstances [1..8]) +-- | 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. +#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 + +-- | 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 + ---------------------------------------------------------------------- ----- SomeSing instances ---------------------------------------------- +---- WrappedSing ----------------------------------------------------- ---------------------------------------------------------------------- -instance SEq k => Eq (SomeSing k) where - SomeSing a == SomeSing b = fromSing (a %== b) - SomeSing a /= SomeSing b = fromSing (a %/= b) +-- | 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 -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) +-- | 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 +type instance Sing = SWrappedSing -instance SBounded k => Bounded (SomeSing k) where - minBound = SomeSing sMinBound - maxBound = SomeSing sMaxBound +#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 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) +instance SingKind (WrappedSing a) where + type Demote (WrappedSing a) = WrappedSing a + fromSing (SWrapSing s) = WrapSing s + toSing (WrapSing s) = SomeSing $ SWrapSing s --- 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 forall a (s :: Sing a). SingI a => SingI ('WrapSing s) where + sing = SWrapSing sing -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) +---------------------------------------------------------------------- +---- SingInstance ---------------------------------------------------- +---------------------------------------------------------------------- -instance ShowSing k => Show (SomeSing k) where - showsPrec p (SomeSing (s :: Sing a)) = - showParen (p > 10) $ showString "SomeSing " . showsPrec 11 s - :: ShowSing' a => ShowS +-- | 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 -instance SSemigroup k => Semigroup (SomeSing k) where - SomeSing a <> SomeSing b = SomeSing (a %<> b) +-- 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) -instance SMonoid k => Monoid (SomeSing k) where - mempty = SomeSing sMempty +-- | 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 -instance SIsString k => IsString (SomeSing k) where - fromString s = withSomeSing (T.pack s) (SomeSing . sFromString) +---------------------------------------------------------------------- +---- 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 +-- @@. +-- +-- 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 +type family ApplyTyCon :: (k1 -> k2) -> (k1 ~> unmatchable_fun) where +#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 +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. +-- +-- 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] +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)) +#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 -------------------- +---------------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ >= 810 +type SLambda :: (k1 ~> k2) -> Type +#endif +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) +(@@) 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' + +-- | 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 :: +#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) + +---------------------------------------------------------------------- +---- 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, ''(@@)]) +-- $(genDefunSymbols [''Demote, ''SameKind, ''KindOf, ''(~>), ''Apply, ''(@@)]) -- WrapSing, UnwrapSing, and SingFunction1 et al. are not defunctionalizable --- at the moment due to Trac #9269 +-- 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 @@ -268,7 +1064,7 @@ defunctionalized singleton @'Sing' (TakeSym :: Nat '~>' [a] '~>' [a])@: @ ->>> import Data.Singletons.Prelude.List +>>> 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,157 +0,0 @@ -{-# LANGUAGE DataKinds, TypeFamilies, KindSignatures, TemplateHaskell #-} - ------------------------------------------------------------------------------ --- | --- 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 Data.Singletons.TH.Options -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 :: OptionsMonad 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 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 _ (DConstrainedT _ _) = fail "Explicit constraint 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, StandaloneKindSignatures #-} + GADTs, TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} +#if __GLASGOW_HASKELL__ < 806 +{-# LANGUAGE TypeInType #-} +#endif + +#if __GLASGOW_HASKELL__ >= 810 +{-# LANGUAGE StandaloneKindSignatures #-} +#endif + ----------------------------------------------------------------------------- -- | -- Module : Data.Singletons.Decide @@ -26,7 +34,7 @@ ) where import Data.Kind -import Data.Singletons.Internal +import Data.Singletons import Data.Type.Coercion import Data.Type.Equality import Data.Void @@ -38,19 +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) @@ -65,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 @@ -77,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,162 +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 (nub) -import Data.Maybe (fromJust) - --- @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 - last_tv = fromJust $ 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,251 +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.TH.Options -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 :: OptionsMonad 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 :: OptionsMonad 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. OptionsMonad q - => ShowMode -> Name -> DCon - -> q DClause -mk_showsPrec_clause mode p (DCon _ _ con_name con_fields _) = go con_fields - where - go :: DConFields -> q DClause - go con_fields' = do - opts <- getOptions - - let con_name' :: Name - con_name' = case mode of - ForPromotion -> con_name - ForShowSing{} -> singledDataConName opts con_name - - case con_fields' of - - -- No fields: print just the constructor name, with no parentheses - DNormalC _ [] -> return $ - DClause [DWildP, DConP con_name' []] $ - DVarE showStringName `DAppE` dStringE (parenInfixConName con_name' "") - - -- Infix constructors have special Show treatment. - 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)) - - 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. - DRecC [] -> go (DNormalC False []) - - 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{} -> singledValueName opts 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 singleton 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 :: OptionsMonad q => ShowMode -> DType -> q DType -mk_Show_inst_ty ForPromotion ty = pure ty -mk_Show_inst_ty (ForShowSing ty_tycon) ty = do - opts <- getOptions - z <- qNewName "z" - pure $ DConT (singledDataTypeName opts 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` DConstrainedT (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,335 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} -{-# 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 qualified Data.List as 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 t@DAppT{} = do - let (f, args) = unfoldDType t - vis_args = filterDTANormals args - (_, fc) <- go f - (xrs, xcs) <- mapAndUnzipM go vis_args - let wrongArg :: q (a, Bool) - wrongArg = pure (caseWrongArg, True) - if | not (or xcs) - -> trivial -- Variable does not occur - -- At this point we know that xrs, xcs is not empty, - -- and at least one xr is True - | fc || or (init xcs) - -> wrongArg -- T (..var..) ty - | otherwise -- T (..no var..) ty - -> do itf <- isInTypeFamilyApp var f vis_args - if itf -- We can't decompose type families, so - -- error if we encounter one here. - then wrongArg - else pure (caseTyApp (last vis_args) (last xrs), True) - 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 (DConstrainedT _ t) = go t - go (DConT {}) = trivial - go DArrowT = trivial - go (DLitT {}) = trivial - go DWildCardT = trivial - - trivial :: q (a, Bool) - trivial = pure (caseTrivial, False) - --- | Detect if a Name occurs as an argument to some type family. This makes an --- effort to exclude /oversaturated/ arguments to type families. For instance, --- if one declared the following type family: --- --- @ --- type family F a :: Type -> Type --- @ --- --- Then in the type @F a b@, we would consider @a@ to be an argument to @F@, --- but not @b@. -isInTypeFamilyApp :: forall q. DsMonad q => Name -> DType -> [DType] -> q Bool -isInTypeFamilyApp name tyFun tyArgs = - case tyFun of - DConT tcName -> go tcName - _ -> pure False - where - go :: Name -> q Bool - go tcName = do - info <- dsReify tcName - case info of - Just (DTyConI dec _) - | DOpenTypeFamilyD (DTypeFamilyHead _ bndrs _ _) <- dec - -> withinFirstArgs bndrs - | DClosedTypeFamilyD (DTypeFamilyHead _ bndrs _ _) _ <- dec - -> withinFirstArgs bndrs - _ -> pure False - - withinFirstArgs :: [a] -> q Bool - withinFirstArgs bndrs = - let firstArgs = take (length bndrs) tyArgs - argFVs = foldMap fvDType firstArgs - in pure $ name `elem` argFVs - --- 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 List.\\ 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,603 +0,0 @@ -{-# LANGUAGE MagicHash, RankNTypes, PolyKinds, GADTs, DataKinds, - FlexibleContexts, FlexibleInstances, - TypeFamilies, TypeOperators, TypeFamilyDependencies, - UndecidableInstances, ConstraintKinds, - ScopedTypeVariables, TypeApplications, AllowAmbiguousTypes, - PatternSynonyms, ViewPatterns, StandaloneKindSignatures #-} - ------------------------------------------------------------------------------ --- | --- 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 :: k -> Type -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 :: k -> k -> Constraint -type SameKind a b = () - ----------------------------------------------------------------------- ----- Sing & friends -------------------------------------------------- ----------------------------------------------------------------------- - --- | The singleton kind-indexed type family. -type Sing :: k -> Type -type family Sing - -{- -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. --- 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' --- @ -type SingKind :: Type -> Constraint -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'. -type SomeSing :: Type -> Type -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)@. -type WrappedSing :: k -> Type -newtype WrappedSing a 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. -type SWrappedSing :: forall k (a :: k). WrappedSing a -> Type -newtype SWrappedSing ws where - SWrapSing :: forall k (a :: k) (ws :: WrappedSing a). - { sUnwrapSing :: Sing a } -> SWrappedSing ws -type instance Sing = SWrappedSing - -type UnwrapSing :: WrappedSing a -> Sing a -type family UnwrapSing ws 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. -type SingInstance :: k -> Type -data SingInstance a where - SingInstance :: SingI a => SingInstance a - --- dirty implementation of explicit-to-implicit conversion -type DI :: k -> Type -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. -type TyFun :: Type -> Type -> Type -data TyFun a b - --- | Something of kind `a ~> b` is a defunctionalized type function that is --- not necessarily generative or injective. -type (~>) :: Type -> Type -> Type -type a ~> b = TyFun a b -> Type -infixr 0 ~> - --- | Type level function application -type Apply :: (k1 ~> k2) -> k1 -> k2 -type family Apply f x - --- | An infix synonym for `Apply` -type (@@) :: (k1 ~> k2) -> k1 -> k2 -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. -type TyCon :: (k1 -> k2) -> unmatchable_fun -data family TyCon --- 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 ApplyTyCon :: (k1 -> k2) -> (k1 ~> unmatchable_fun) -type family ApplyTyCon 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. -type ApplyTyConAux1 :: (k1 -> k2) -> (k1 ~> k2) -data ApplyTyConAux1 f z --- | An \"internal\" defunctionalization symbol used primarily in the --- definition of 'ApplyTyCon'. -type ApplyTyConAux2 :: (k1 -> k2 -> k3) -> (k1 ~> unmatchable_fun) -data ApplyTyConAux2 f z -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 :: (k1 -> k2) -> (k1 ~> k2) -type TyCon1 = TyCon - --- | Similar to 'TyCon1', but for two-parameter type constructors. -type TyCon2 :: (k1 -> k2 -> k3) -> (k1 ~> k2 ~> k3) -type TyCon2 = TyCon - -type TyCon3 :: (k1 -> k2 -> k3 -> k4) -> (k1 ~> k2 ~> k3 ~> k4) -type TyCon3 = TyCon - -type TyCon4 :: (k1 -> k2 -> k3 -> k4 -> k5) -> (k1 ~> k2 ~> k3 ~> k4 ~> k5) -type TyCon4 = TyCon - -type TyCon5 :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6) - -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6) -type TyCon5 = TyCon - -type TyCon6 :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7) - -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7) -type TyCon6 = TyCon - -type TyCon7 :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7 -> k8) - -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7 ~> k8) -type TyCon7 = TyCon - -type TyCon8 :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7 -> k8 -> k9) - -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7 ~> k8 ~> k9) -type TyCon8 = TyCon - ----------------------------------------------------------------------- ----- Defunctionalized Sing instance and utilities -------------------- ----------------------------------------------------------------------- - -type SLambda :: (k1 ~> k2) -> Type -newtype SLambda f = - 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 :: (a1 ~> b) -> Type -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 :: (a1 ~> a2 ~> b) -> Type -type SingFunction2 f = 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 :: (a1 ~> a2 ~> a3 ~> b) -> Type -type SingFunction3 f = 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 :: (a1 ~> a2 ~> a3 ~> a4 ~> b) -> Type -type SingFunction4 f = 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 :: (a1 ~> a2 ~> a3 ~> a4 ~> a5 ~> b) -> Type -type SingFunction5 f = 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 :: (a1 ~> a2 ~> a3 ~> a4 ~> a5 ~> a6 ~> b) -> Type -type SingFunction6 f = 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 :: (a1 ~> a2 ~> a3 ~> a4 ~> a5 ~> a6 ~> a7 ~> b) -> Type -type SingFunction7 f = 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 :: (a1 ~> a2 ~> a3 ~> a4 ~> a5 ~> a6 ~> a7 ~> a8 ~> b) -> Type -type SingFunction8 f = 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) - -{-# 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,260 +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) - -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 - -boolKi :: DKind -boolKi = DConT boolName - -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 :: DType -> DType - go (DForallT fvf tvbs p) = DForallT fvf tvbs (go p) - go (DConstrainedT cxt p) = DConstrainedT (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,324 +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 Data.Singletons.TH.Options -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 mempty mempty mempty mempty mempty - mempty mempty mempty mempty - --- | Split up a @[DDec]@ into its pieces, extracting 'Ord' instances --- from deriving clauses -partitionDecs :: OptionsMonad m => [DDec] -> m PartitionedDecs -partitionDecs = concatMapM partitionDec - -partitionDec :: OptionsMonad 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 - , cd_atfs = 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 (DKiSigD {}) = pure mempty - -- There's no need to track standalone kind signatures, since we use - -- dsReifyType to look them up. -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. OptionsMonad 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. -3. We track open type families, closed type families, and associated type - families separately, as each form of type family has different kind - inference behavior. See defunTopLevelTypeDecls and - defunAssociatedTypeFamilies in D.S.Promote.Defun for how these differences - manifest. --} 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,75 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# 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, sGetConst, - 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,111 +0,0 @@ -{-# LANGUAGE TemplateHaskell, TypeOperators, DataKinds, PolyKinds, - ScopedTypeVariables, TypeFamilies, GADTs, - UndecidableInstances, BangPatterns, TypeApplications, - StandaloneKindSignatures #-} - ------------------------------------------------------------------------------ --- | --- 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` - |]) 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, StandaloneKindSignatures #-} - ------------------------------------------------------------------------------ --- | --- 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 StandaloneKindSignatures #-} -{-# 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, sGetConst, - - -- * 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 singleton type to give it. We could use either - -1. type SConst :: forall {k :: Type} (a :: Type) (b :: k). Const a b -> Type -2. type SConst :: 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 singleton type by -hand. --} -type SConst :: Const a b -> Type -data SConst c where - SConst :: 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 - -$(singletonsOnly [d| - getConst :: Const a b -> a - getConst (Const x) = x - - 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, StandaloneKindSignatures #-} - ------------------------------------------------------------------------------ --- | --- 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, StandaloneKindSignatures #-} - ------------------------------------------------------------------------------ --- | --- 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,94 +0,0 @@ -{-# LANGUAGE TypeOperators, DataKinds, PolyKinds, TypeFamilies, - RankNTypes, FlexibleContexts, TemplateHaskell, - UndecidableInstances, GADTs, DefaultSignatures, - ScopedTypeVariables, TypeApplications, StandaloneKindSignatures #-} - ------------------------------------------------------------------------------ --- | --- 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.Kind -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'. -type PEq :: Type -> Constraint -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 DefaultEq :: k -> k -> Bool -type family DefaultEq a b 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 '(%/=)'. -type SEq :: Type -> Constraint -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,676 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# 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 (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 - , GetFirstSym0, sGetFirst - , LastSym0, LastSym1, SLast - , ProductSym0(..), ProductSym1, SProduct - , SumSym0(..), SumSym1, SSum ) -import Data.Singletons.Prelude.Semigroup.Internal.Disambiguation -import Data.Singletons.Single -import Data.Singletons.TypeLits.Internal - -type Endo :: Type -> Type -newtype Endo a = Endo (a ~> a) -type SEndo :: Endo a -> Type -data SEndo e where - SEndo :: Sing x -> SEndo ('Endo x) -type instance Sing = SEndo -type EndoSym0 :: (a ~> a) ~> Endo a -data EndoSym0 tf -type instance Apply EndoSym0 x = 'Endo x - -$(singletonsOnly [d| - appEndo :: Endo a -> (a -> a) - appEndo (Endo x) = x - - instance Semigroup (Endo a) where - Endo x <> Endo y = Endo (x . y) - - instance Monoid (Endo a) where - mempty = Endo id - |]) - -$(singletons [d| - newtype MaxInternal a = MaxInternal { getMaxInternal :: Maybe a } - newtype MinInternal a = MinInternal { getMinInternal :: Maybe a } - |]) - -$(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 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 = appEndo (foldMap (Endo . f) t) 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 = appEndo (getDual (foldMap (Dual . Endo . flip f) t)) 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 = fromMaybe (errorWithoutStackTrace "maximum: empty structure") . - getMaxInternal . foldMap (MaxInternal . mkJust) - where - mkJust :: a -> Maybe a - mkJust = Just - - -- -| The least element of a non-empty structure. - minimum :: forall a . Ord a => t a -> a - minimum = fromMaybe (errorWithoutStackTrace "minimum: empty structure") . - getMinInternal . foldMap (MinInternal . mkJust) - where - mkJust :: a -> Maybe a - mkJust = Just - - -- -| The 'sum' function computes the sum of the numbers of a structure. - sum :: Num a => t a -> a - sum = getSum . foldMap sum_ - - -- -| The 'product' function computes the product of the numbers of a - -- structure. - product :: Num a => t a -> a - product = getProduct . foldMap product_ - - -- 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 Proxy where - foldMap _ _ = mempty - fold _ = mempty - foldr _ z _ = z - foldl _ z _ = z - foldl1 _ _ = errorWithoutStackTrace "foldl1: Proxy" - foldr1 _ _ = errorWithoutStackTrace "foldr1: Proxy" - - -- Why do we give length (and null) an instance signature here? If we - -- didn't, singletons would generate one for us when singling it: - -- - -- instance SFoldable Proxy where - -- sLength :: forall a (x :: Proxy a). Sing x -> Sing (Length x) - -- sLength = ... - -- - -- If you squint, you'll notice that that instance signature is actually - -- /too/ general. This is because GHC will infer that `a` should be - -- kind-polymorphic, but Length is only defined when `a` is of kind - -- `Type`! Ugh. To force GHC to come to its senses, we explicitly inform - -- it that `a :: Type` through our own instance signature. - length :: forall (a :: Type). Proxy a -> Nat - length _ = 0 - - null :: forall (a :: Type). Proxy a -> Bool - null _ = True - - elem _ _ = False - sum _ = 0 - product _ = 1 - - instance Foldable Dual where - foldMap f (Dual x) = f x - - elem = (. getDual) . (==) - foldl f z (Dual x) = f z x - foldl' f z (Dual x) = f z x - foldl1 _ = getDual - foldr f z (Dual x) = f x z - foldr' = foldr - foldr1 _ = getDual - length _ = 1 - maximum = getDual - minimum = getDual - null _ = False - product = getDual - sum = getDual - toList (Dual x) = [x] - - instance Foldable Monoid.Sum where - foldMap f (Monoid.Sum x) = f x - - elem = (. getSum) . (==) - foldl f z (Monoid.Sum x) = f z x - foldl' f z (Monoid.Sum x) = f z x - foldl1 _ = getSum - foldr f z (Monoid.Sum x) = f x z - foldr' = foldr - foldr1 _ = getSum - length _ = 1 - maximum = getSum - minimum = getSum - null _ = False - product = getSum - sum = getSum - toList (Monoid.Sum x) = [x] - - instance Foldable Monoid.Product where - foldMap f (Monoid.Product x) = f x - - elem = (. getProduct) . (==) - foldl f z (Monoid.Product x) = f z x - foldl' f z (Monoid.Product x) = f z x - foldl1 _ = getProduct - foldr f z (Monoid.Product x) = f x z - foldr' = foldr - foldr1 _ = getProduct - length _ = 1 - maximum = getProduct - minimum = getProduct - null _ = False - product = getProduct - sum = getProduct - 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 = getAll . foldMap all_ - - -- -| '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 = getAny . foldMap any_ - - -- -| Determines whether any element of the structure satisfies the predicate. - any :: Foldable t => (a -> Bool) -> t a -> Bool - any p = getAny . foldMap (any_ . p) - - -- -| Determines whether all elements of the structure satisfy the predicate. - all :: Foldable t => (a -> Bool) -> t a -> Bool - all p = getAll . foldMap (all_ . p) - - -- -| 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 = getFirst . foldMap (\ x -> First (if p x then Just x else Nothing)) - |]) - -$(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,117 +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, - StandaloneKindSignatures #-} - -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 & - |]) 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,203 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# 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 - |]) 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,115 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# 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, sRunIdentity, - - -- * 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, StandaloneKindSignatures #-} -{-# 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,61 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# 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,281 +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, - - -- * 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 - ) 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,640 +0,0 @@ -{-# LANGUAGE TypeOperators, DataKinds, PolyKinds, TypeFamilies, - TemplateHaskell, GADTs, UndecidableInstances, RankNTypes, - ScopedTypeVariables, FlexibleContexts, - TypeApplications, StandaloneKindSignatures #-} -{-# 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 - - |]) - --- 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 _ _ _ _ _ _ _ _ = [] - |]) 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, StandaloneKindSignatures #-} - -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 ( foldl', inits, insert, intersperse, isPrefixOf - , nubBy, partition, sort, sortBy, tails, transpose ) -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,549 +0,0 @@ -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TypeOperators, - TypeFamilies, GADTs, UndecidableInstances, InstanceSigs, - DataKinds, PolyKinds, TypeApplications, - StandaloneKindSignatures #-} -{-# 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, StandaloneKindSignatures #-} - ------------------------------------------------------------------------------ --- | --- 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,295 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# 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 - |]) 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 StandaloneKindSignatures #-} -{-# 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.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 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,488 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# 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.List.NonEmpty (NonEmpty(..)) -import Data.Singletons.Prelude.Base -import Data.Singletons.Prelude.Instances -import Data.Singletons.Single - -$(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 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 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 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 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 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 = (<|>) - |]) - -$(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,111 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# 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 Data.Functor.Identity -import Data.Monoid -import Data.Proxy -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.Proxy -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 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 - - instance MonadZip Proxy where - mzipWith _ _ _ = Proxy - |]) 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,213 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# 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, - sGetDual, sGetAll, sGetAny, sGetSum, sGetProduct, sGetFirst, sGetLast, - - -- ** 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, sGetFirst, GetFirstSym0, GetFirstSym1, GetFirstSym0KindInference, - GetLast, sGetLast, 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,140 +0,0 @@ -{-# LANGUAGE TemplateHaskell, PolyKinds, DataKinds, TypeFamilies, - TypeOperators, GADTs, ScopedTypeVariables, UndecidableInstances, - DefaultSignatures, FlexibleContexts, InstanceSigs, NoStarIsType, - TypeApplications, StandaloneKindSignatures - #-} - ------------------------------------------------------------------------------ --- | --- 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 - - subtract :: Num a => a -> a -> a - subtract x y = y - 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) - |]) - --- PNum instance -type SignumNat :: Nat -> Nat -type family SignumNat a 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 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,109 +0,0 @@ -{-# LANGUAGE TemplateHaskell, DataKinds, PolyKinds, ScopedTypeVariables, - TypeFamilies, TypeOperators, GADTs, UndecidableInstances, - FlexibleContexts, DefaultSignatures, InstanceSigs, - StandaloneDeriving, FlexibleInstances, TypeApplications, - StandaloneKindSignatures #-} -{-# 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(..), GetDown, sGetDown, - - -- ** 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, - GetDownSym0, GetDownSym1 - ) 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) - |]) - -$(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/Ord/Disambiguation.hs b/src/Data/Singletons/Prelude/Ord/Disambiguation.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/Ord/Disambiguation.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Ord.Disambiguation --- Copyright : (C) 2019 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Provides aliases for 'Min' and 'Max' that do not clash with the data --- types of the same names in Data.Singletons.Prelude.Semigroup. --- ----------------------------------------------------------------------------- - -module Data.Singletons.Prelude.Ord.Disambiguation where - -import Data.Singletons.Prelude.Ord -import Data.Singletons.Single - --- 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. -$(singletons [d| - min_, max_ :: Ord a => a -> a -> a - min_ = min - max_ = max - |]) diff --git a/src/Data/Singletons/Prelude/Proxy.hs b/src/Data/Singletons/Prelude/Proxy.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/Proxy.hs +++ /dev/null @@ -1,162 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Proxy --- Copyright : (C) 2020 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) --- Stability : experimental --- Portability : non-portable --- --- Exports promoted and singled versions of the definitions in "Data.Proxy". --- ------------------------------------------------------------------------------ - -module Data.Singletons.Prelude.Proxy ( - -- * The 'Proxy' singleton - Sing, SProxy(..) - , AsProxyTypeOf, sAsProxyTypeOf - - -- * Defunctionalization symbols - , ProxySym0 - , AsProxyTypeOfSym0, AsProxyTypeOfSym1, AsProxyTypeOfSym2 - ) where - -import Control.Applicative -import Control.Monad -import Data.Kind -import Data.Proxy -import Data.Semigroup (Semigroup(..)) -import Data.Singletons.Decide -import Data.Singletons.Internal -import Data.Singletons.Prelude.Base -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.Monoid -import Data.Singletons.Prelude.Ord -import Data.Singletons.Prelude.Semigroup.Internal -import Data.Singletons.Prelude.Show -import Data.Singletons.Promote -import Data.Singletons.Single -import Data.Singletons.TypeLits.Internal -import Data.Type.Coercion -import Data.Type.Equality hiding (type (==)) - -{- -In order to keep the type argument to Proxy poly-kinded, we define the -singleton version of Proxy by hand. This is very much in the spirit of the -code in D.S.Prelude.Const. (See the comments above SConst in that module -for more details on this choice.) --} -data SProxy :: forall t. Proxy t -> Type where - SProxy :: forall t. SProxy ('Proxy @t) -type instance Sing = SProxy -instance SingKind (Proxy t) where - type Demote (Proxy t) = Proxy t - fromSing SProxy = Proxy - toSing Proxy = SomeSing SProxy -instance SingI 'Proxy where - sing = SProxy - -$(genDefunSymbols [''Proxy]) - -instance SDecide (Proxy t) where - SProxy %~ SProxy = Proved Refl - -instance TestEquality SProxy where - testEquality = decideEquality - -instance TestCoercion SProxy where - testCoercion = decideCoercion - -instance Show (SProxy z) where - showsPrec _ _ = showString "SProxy" - -$(singletonsOnly [d| - deriving instance Bounded (Proxy s) - - -- It's common to use (undefined :: Proxy t) and (Proxy :: Proxy t) - -- interchangeably, so all of these instances are hand-written to be - -- lazy in Proxy arguments. - - instance Eq (Proxy s) where - _ == _ = True - - instance Ord (Proxy s) where - compare _ _ = EQ - - instance Show (Proxy s) where - showsPrec _ _ = showString "Proxy" - - instance Enum (Proxy s) where - succ _ = errorWithoutStackTrace "Proxy.succ" - pred _ = errorWithoutStackTrace "Proxy.pred" - fromEnum _ = 0 - -- toEnum 0 = Proxy - -- toEnum _ = errorWithoutStackTrace "Proxy.toEnum: 0 expected" - toEnum n = if n == 0 - then Proxy - else errorWithoutStackTrace "Proxy.toEnum: 0 expected" - -- enumFrom _ = [Proxy] - -- enumFromThen _ _ = [Proxy] - enumFromThenTo _ _ _ = [Proxy] - enumFromTo _ _ = [Proxy] - - instance Semigroup (Proxy s) where - _ <> _ = Proxy - sconcat _ = Proxy - -- stimes _ _ = Proxy - - instance Monoid (Proxy s) where - mempty = Proxy - mconcat _ = Proxy - - instance Functor Proxy where - fmap _ _ = Proxy - - instance Applicative Proxy where - pure _ = Proxy - _ <*> _ = Proxy - - instance Alternative Proxy where - empty = Proxy - _ <|> _ = Proxy - - instance Monad Proxy where - _ >>= _ = Proxy - - instance MonadPlus Proxy - - -- -| 'asProxyTypeOf' is a type-restricted version of 'const'. - -- It is usually used as an infix operator, and its typing forces its first - -- argument (which is usually overloaded) to have the same type as the tag - -- of the second. - -- - -- >>> import Data.Word - -- >>> :type asProxyTypeOf 123 (Proxy :: Proxy Word8) - -- asProxyTypeOf 123 (Proxy :: Proxy Word8) :: Word8 - -- - -- Note the lower-case @proxy@ in the definition. This allows any type - -- constructor with just one argument to be passed to the function, for example - -- we could also write - -- - -- >>> import Data.Word - -- >>> :type asProxyTypeOf 123 (Just (undefined :: Word8)) - -- asProxyTypeOf 123 (Just (undefined :: Word8)) :: Word8 - asProxyTypeOf :: a -> proxy a -> a - asProxyTypeOf = const - |]) 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,306 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# 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, - sGetMin, sGetMax, sGetFirst, sGetLast, sUnwrapMonoid, sGetDual, - sGetAll, sGetAny, sGetSum, sGetProduct, sGetOption, - - 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, sGetFirst, GetFirstSym0, GetFirstSym1, - GetLast, sGetLast, GetLastSym0, GetLastSym1) -import Data.Singletons.Prelude.Num -import Data.Singletons.Prelude.Ord hiding - (MinSym0, MinSym1, MaxSym0, MaxSym1) -import Data.Singletons.Prelude.Ord.Disambiguation -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,230 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# 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.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) - |]) - -$(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) diff --git a/src/Data/Singletons/Prelude/Semigroup/Internal/Disambiguation.hs b/src/Data/Singletons/Prelude/Semigroup/Internal/Disambiguation.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/Semigroup/Internal/Disambiguation.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Semigroup.Internal.Disambiguation --- Copyright : (C) 2019 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Provides aliases for 'All', 'Any', 'Sum', and 'Product' that do not clash --- with the promoted functions of the same names in --- Data.Singletons.Prelude.Foldable. --- ----------------------------------------------------------------------------- - -module Data.Singletons.Prelude.Semigroup.Internal.Disambiguation where - -import Data.Semigroup -import Data.Singletons.Prelude.Semigroup.Internal -import Data.Singletons.Single - --- We need these in Data.Singletons.Prelude.Foldable, as we need to promote --- code that simultaneously uses the All/Any/Sum/Product constructors and the --- all/any/sum/product functions, which have clashing defunctionalization --- symbol names. Our workaround is to simply define synonyms for --- all/any/sum/product and use those instead. -$(singletons [d| - all_ :: Bool -> All - all_ = All - - any_ :: Bool -> Any - any_ = Any - - sum_ :: a -> Sum a - sum_ = Sum - - product_ :: a -> Product a - product_ = Product - |]) 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,199 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# 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.Kind -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 :: Type -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 :: Type -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,310 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# 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.Prelude.Proxy -import Data.Singletons.Single - -type StateL :: Type -> Type -> Type -newtype StateL s a = StateL (s ~> (s, a)) -type SStateL :: forall s a. StateL s a -> Type -data SStateL state where - SStateL :: Sing x -> SStateL ('StateL x) -type instance Sing = SStateL -type StateLSym0 :: forall s a. (s ~> (s, a)) ~> StateL s a -data StateLSym0 z -type instance Apply StateLSym0 x = 'StateL x - -type StateR :: Type -> Type -> Type -newtype StateR s a = StateR (s ~> (s, a)) -type SStateR :: forall s a. StateR s a -> Type -data SStateR state where - SStateR :: Sing x -> SStateR ('StateR x) -type instance Sing = SStateR -type StateRSym0 :: forall s a. (s ~> (s, a)) ~> StateR s a -data StateRSym0 z -type instance Apply StateRSym0 x = 'StateR x - -$(singletonsOnly [d| - runStateL :: StateL s a -> (s -> (s, a)) - runStateL (StateL x) = x - - runStateR :: StateR s a -> (s -> (s, a)) - runStateR (StateR x) = 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 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) - - instance Traversable Proxy where - traverse _ _ = pure Proxy - sequenceA _ = pure Proxy - mapM _ _ = pure Proxy - sequence _ = pure Proxy - - 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 = runStateL (traverse (StateL . flip f) t) 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 = runStateR (traverse (StateR . flip f) t) 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, StandaloneKindSignatures #-} - ------------------------------------------------------------------------------ --- | --- 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,57 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# 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,1149 +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, - ScopedTypeVariables #-} - -module Data.Singletons.Promote where - -import Language.Haskell.TH hiding ( Q, cxt ) -import Language.Haskell.TH.Syntax ( NameSpace(..), Quasi(..), Uniq ) -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.TH.Options -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 Data.List (nub) -import qualified Data.Map.Strict as Map -import Data.Map.Strict ( Map ) -import Data.Maybe -import qualified GHC.LanguageExtensions.Type as LangExt - -{- -Note [Disable genQuotedDecs in genPromotions and genSingletons] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Somewhat curiously, the genPromotions and genSingletons functions set the -genQuotedDecs option to False, despite neither function accepting quoted -declarations as arguments in the first place. There is a good reason for doing -this, however. Imagine this code: - - class C a where - infixl 9 <%%> - (<%%>) :: a -> a -> a - $(genPromotions [''C]) - -If genQuotedDecs is set to True, then the (<%%>) type family will not receive -a fixity declaration (see -Note [singletons and fixity declarations] in D.S.Single.Fixity, wrinkle 1 for -more details on this point). Therefore, we set genQuotedDecs to False to avoid -this problem. --} - --- | Generate promoted definitions for each of the provided type-level --- declaration 'Name's. This is generally only useful with classes. -genPromotions :: OptionsMonad q => [Name] -> q [Dec] -genPromotions names = do - opts <- getOptions - -- See Note [Disable genQuotedDecs in genPromotions and genSingletons] - withOptions opts{genQuotedDecs = False} $ 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. --- See the --- @@ --- for further explanation. -promote :: OptionsMonad q => q [Dec] -> q [Dec] -promote qdecs = do - opts <- getOptions - withOptions opts{genQuotedDecs = True} $ promote' $ lift qdecs - --- | 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 :: OptionsMonad q => q [Dec] -> q [Dec] -promoteOnly qdecs = do - opts <- getOptions - withOptions opts{genQuotedDecs = False} $ promote' $ lift qdecs - --- The workhorse for 'promote' and 'promoteOnly'. The difference between the --- two functions is whether 'genQuotedDecs' is set to 'True' or 'False'. -promote' :: OptionsMonad q => q [Dec] -> q [Dec] -promote' qdecs = do - opts <- getOptions - decs <- qdecs - ddecs <- withLocalDeclarations decs $ dsDecs decs - promDecs <- promoteM_ decs $ promoteDecs ddecs - let origDecs | genQuotedDecs opts = decs - | otherwise = [] - return $ origDecs ++ decsToTH promDecs - --- | Generate defunctionalization symbols for each of the provided type-level --- declaration 'Name's. See the "Promotion and partial application" section of --- the @singletons@ --- @@ --- for further explanation. -genDefunSymbols :: OptionsMonad 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 :: OptionsMonad q => [Name] -> q [Dec] -promoteEqInstances = concatMapM promoteEqInstance - --- | Produce instances for 'POrd' from the given types -promoteOrdInstances :: OptionsMonad q => [Name] -> q [Dec] -promoteOrdInstances = concatMapM promoteOrdInstance - --- | Produce an instance for 'POrd' from the given type -promoteOrdInstance :: OptionsMonad q => Name -> q [Dec] -promoteOrdInstance = promoteInstance mkOrdInstance "Ord" - --- | Produce instances for 'PBounded' from the given types -promoteBoundedInstances :: OptionsMonad q => [Name] -> q [Dec] -promoteBoundedInstances = concatMapM promoteBoundedInstance - --- | Produce an instance for 'PBounded' from the given type -promoteBoundedInstance :: OptionsMonad q => Name -> q [Dec] -promoteBoundedInstance = promoteInstance mkBoundedInstance "Bounded" - --- | Produce instances for 'PEnum' from the given types -promoteEnumInstances :: OptionsMonad q => [Name] -> q [Dec] -promoteEnumInstances = concatMapM promoteEnumInstance - --- | Produce an instance for 'PEnum' from the given type -promoteEnumInstance :: OptionsMonad q => Name -> q [Dec] -promoteEnumInstance = promoteInstance mkEnumInstance "Enum" - --- | Produce instances for 'PShow' from the given types -promoteShowInstances :: OptionsMonad q => [Name] -> q [Dec] -promoteShowInstances = concatMapM promoteShowInstance - --- | Produce an instance for 'PShow' from the given type -promoteShowInstance :: OptionsMonad q => Name -> q [Dec] -promoteShowInstance = promoteInstance (mkShowInstance ForPromotion) "Show" - --- | Produce an instance for @(==)@ (type-level equality) from the given type -promoteEqInstance :: OptionsMonad 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 :: OptionsMonad 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 Map.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 - - defunTopLevelTypeDecls ty_syns c_tyfams o_tyfams - rec_sel_let_decs <- promoteDataDecs datas - -- promoteLetDecs returns LetBinds, which we don't need at top level - _ <- promoteLetDecs Nothing $ rec_sel_let_decs ++ let_decs - mapM_ promoteClassDec classes - let orig_meth_sigs = foldMap (lde_types . cd_lde) classes - cls_tvbs_map = Map.fromList $ map (\cd -> (cd_name cd, cd_tvbs cd)) classes - mapM_ (promoteInstanceDec orig_meth_sigs cls_tvbs_map) insts - mapM_ promoteDerivedEqDec derived_eq_decs - --- curious about ALetDecEnv? See the LetDecEnv module for an explanation. -promoteLetDecs :: Maybe Uniq -- let-binding unique (if locally bound) - -> [DLetDec] -> PrM ([LetBind], ALetDecEnv) - -- See Note [Promoting declarations in two stages] -promoteLetDecs mb_let_uniq decls = do - opts <- getOptions - 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 = promotedValueName opts name mb_let_uniq - sym = defunctionalizedName opts proName (length all_locals) ] - (decs, let_dec_env') <- letBind binds $ promoteLetDecEnv mb_let_uniq let_dec_env - emitDecs decs - return (binds, let_dec_env' { lde_proms = OMap.fromList binds }) - -promoteDataDecs :: [DataDecl] -> PrM [DLetDec] -promoteDataDecs = concatMapM promoteDataDec - --- "Promotes" a data type, much like D.S.Single.Data.singDataD singles a data --- type. Promoting a data type is much easier than singling it, however, since --- DataKinds automatically promotes data types and kinds and data constructors --- to types. That means that promoteDataDec only has to do three things: --- --- 1. Emit defunctionalization symbols for each data constructor, --- --- 2. Emit promoted fixity declarations for each data constructor and promoted --- record selector (assuming the originals have fixity declarations), and --- --- 3. Assemble a top-level function that mimics the behavior of its record --- selectors. Note that promoteDataDec does not actually promote this record --- selector function—it merely returns its DLetDecs. Later, the promoteDecs --- function takes these DLetDecs and promotes them (using promoteLetDecs). --- This greatly simplifies the plumbing, since this allows all DLetDecs to --- be promoted in a single location. --- See Note [singletons and record selectors] in D.S.Single.Data. -promoteDataDec :: DataDecl -> PrM [DLetDec] -promoteDataDec (DataDecl data_name tvbs ctors) = do - let arg_ty = foldTypeTvbs (DConT data_name) tvbs - rec_sel_names = nub $ concatMap extractRecSelNames ctors - -- Note the use of nub: the same record selector name can - -- be used in multiple constructors! - rec_sel_let_decs <- getRecordSelectors arg_ty ctors - ctorSyms <- buildDefunSymsDataD ctors - infix_decs <- promoteReifiedInfixDecls rec_sel_names - emitDecs $ ctorSyms ++ infix_decs - pure rec_sel_let_decs - -promoteClassDec :: UClassDecl -> PrM AClassDecl -promoteClassDec decl@(ClassDecl { cd_name = cls_name - , cd_tvbs = tvbs - , cd_fds = fundeps - , cd_atfs = atfs - , cd_lde = lde@LetDecEnv - { lde_defns = defaults - , lde_types = meth_sigs - , lde_infix = infix_decls } }) = do - opts <- getOptions - let pClsName = promotedClassName opts cls_name - forallBind cls_kvs_to_bind $ do - let meth_sigs_list = OMap.assocs meth_sigs - meth_names = map fst meth_sigs_list - defaults_list = OMap.assocs defaults - defaults_names = map fst defaults_list - mb_cls_sak <- dsReifyType cls_name - sig_decs <- mapM (uncurry promote_sig) meth_sigs_list - (default_decs, ann_rhss, prom_rhss) - <- mapAndUnzip3M (promoteMethod DefaultMethods meth_sigs) defaults_list - defunAssociatedTypeFamilies tvbs atfs - - infix_decls' <- mapMaybeM (uncurry (promoteInfixDecl Nothing)) $ - OMap.assocs infix_decls - cls_infix_decls <- promoteReifiedInfixDecls $ cls_name:meth_names - - -- no need to do anything to the fundeps. They work as is! - let pro_cls_dec = DClassD [] pClsName tvbs fundeps - (sig_decs ++ default_decs ++ infix_decls') - mb_pro_cls_sak = fmap (DKiSigD pClsName) mb_cls_sak - emitDecs $ maybeToList mb_pro_cls_sak ++ pro_cls_dec:cls_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 - opts <- getOptions - let proName = promotedTopLevelValueName opts name - -- When computing the kind to use for the defunctionalization symbols, - -- /don't/ use the type variable binders from the method's type... - (_, argKs, resK) <- promoteUnraveled ty - args <- mapM (const $ qNewName "arg") argKs - let proTvbs = zipWith DKindedTV args argKs - -- ...instead, compute the type variable binders in a left-to-right order, - -- since that is the same order that the promoted method's kind will use. - -- See Note [Promoted class methods and kind variable ordering] - meth_sak_tvbs = toposortTyVarsOf $ argKs ++ [resK] - meth_sak = ravelVanillaDType meth_sak_tvbs [] argKs resK - m_fixity <- reifyFixityWithLocals name - emitDecsM $ defunctionalize proName m_fixity $ DefunSAK meth_sak - - return $ DOpenTypeFamilyD (DTypeFamilyHead proName - proTvbs - (DKindSig resK) - Nothing) - -{- -Note [Promoted class methods and kind variable ordering] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general, we make an effort to preserve the order of type variables when -promoting type signatures, but there is an annoying corner case where this is -difficult: class methods. When promoting class methods, the order of kind -variables in their kinds will often "just work" by happy coincidence, but -there are some situations where this does not happen. Consider the following -class: - - class C (b :: Type) where - m :: forall a. a -> b -> a - -The full type of `m` is `forall b. C b => forall a. a -> b -> a`, which binds -`b` before `a`. This order is preserved when singling `m`, but *not* when -promoting `m`. This is because the `C` class is promoted as follows: - - class PC (b :: Type) where - type M (x :: a) (y :: b) :: a - -Due to the way GHC kind-checks associated type families, the kind of `M` is -`forall a b. a -> b -> a`, which binds `b` *after* `a`. Moreover, the -`StandaloneKindSignatures` extension does not provide a way to explicitly -declare the full kind of an associated type family, so this limitation is -not easy to work around. - -The defunctionalization symbols for `M` will also follow a similar -order of type variables: - - type MSym0 :: forall a b. a ~> b ~> a - type MSym1 :: forall a b. a -> b ~> a - -There is one potential hack we could use to rectify this: - - type FlipConst x y = y - class PC (b :: Type) where - type M (x :: FlipConst '(b, a) a) (y :: b) :: a - -Using `FlipConst` would cause `b` to be mentioned before `a`, which would give -`M` the kind `forall b a. FlipConst '(b, a) a -> b -> a`. While the order of -type variables would be preserved, the downside is that the ugly `FlipConst` -type synonym leaks into the kind. I'm not particularly fond of this, so I have -decided not to use this hack unless someone specifically requests it. --} - --- returns (unpromoted method name, ALetDecRHS) pairs -promoteInstanceDec :: OMap Name DType - -- Class method type signatures - -> Map Name [DTyVarBndr] - -- Class header type variable (e.g., if `class C a b` is - -- quoted, then this will have an entry for {C |-> [a, b]}) - -> UInstDecl -> PrM AInstDecl -promoteInstanceDec orig_meth_sigs cls_tvbs_map - decl@(InstDecl { id_name = cls_name - , id_arg_tys = inst_tys - , id_sigs = inst_sigs - , id_meths = meths }) = do - opts <- getOptions - cls_tvbs <- lookup_cls_tvbs - inst_kis <- mapM promoteType inst_tys - let pClsName = promotedClassName opts cls_name - cls_tvb_names = map extractTvbName cls_tvbs - kvs_to_bind = foldMap fvDType inst_kis - forallBind kvs_to_bind $ do - let subst = Map.fromList $ zip cls_tvb_names inst_kis - meth_impl = InstanceMethods inst_sigs subst - (meths', ann_rhss, _) - <- mapAndUnzip3M (promoteMethod meth_impl 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 - lookup_cls_tvbs :: PrM [DTyVarBndr] - lookup_cls_tvbs = - -- First, try consulting the map of class names to their type variables. - -- It is important to do this first to ensure that we consider locally - -- declared classes before imported ones. See #410 for what happens if - -- you don't. - case Map.lookup cls_name cls_tvbs_map of - Just tvbs -> pure tvbs - Nothing -> reify_cls_tvbs - -- If the class isn't present in this map, we try reifying the class - -- as a last resort. - - reify_cls_tvbs :: PrM [DTyVarBndr] - reify_cls_tvbs = do - opts <- getOptions - let pClsName = promotedClassName opts cls_name - mk_tvbs = extract_tvbs (dsReifyTypeNameInfo pClsName) - <|> extract_tvbs (dsReifyTypeNameInfo cls_name) - -- See Note [Using dsReifyTypeNameInfo when promoting instances] - mb_tvbs <- runMaybeT mk_tvbs - case mb_tvbs of - Just tvbs -> pure tvbs - Nothing -> fail $ "Cannot find class declaration annotation for " ++ show cls_name - - extract_tvbs :: PrM (Maybe DInfo) -> MaybeT PrM [DTyVarBndr] - extract_tvbs reify_info = do - mb_info <- lift reify_info - case mb_info of - Just (DTyConI (DClassD _ _ tvbs _ _) _) -> pure 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. --} - --- Which sort of class methods are being promoted? -data MethodSort - -- The method defaults in class declarations. - = DefaultMethods - -- The methods in instance declarations. - | InstanceMethods (OMap Name DType) -- ^ InstanceSigs - (Map Name DKind) -- ^ Instantiations for class tyvars - -- See Note [Promoted class method kinds] - deriving Show - -promoteMethod :: MethodSort - -> OMap Name DType -- method types - -> (Name, ULetDecRHS) - -> PrM (DDec, ALetDecRHS, DType) - -- returns (type instance, ALetDecRHS, promoted RHS) -promoteMethod meth_sort orig_sigs_map (meth_name, meth_rhs) = do - opts <- getOptions - (meth_tvbs, meth_arg_kis, meth_res_ki) <- promote_meth_ty - meth_arg_tvs <- replicateM (length meth_arg_kis) (qNewName "a") - let proName = promotedTopLevelValueName opts meth_name - 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 helperDefunName = defunctionalizedName0 opts helperName - (pro_decs, defun_decs, ann_rhs) - <- promoteLetDecRHS (ClassMethodRHS meth_tvbs meth_arg_kis meth_res_ki) - OMap.empty OMap.empty - Nothing helperName meth_rhs - emitDecs (pro_decs ++ defun_decs) - return ( DTySynInstD - (DTySynEqn Nothing - (foldType (DConT proName) family_args) - (foldApply (DConT helperDefunName) (map DVarT meth_arg_tvs))) - , ann_rhs - , DConT helperDefunName ) - where - -- Promote the type of a class method. For a default method, "the type" is - -- simply the type of the original method. For an instance method, - -- "the type" is like the type of the original method, but substituted for - -- the types in the instance head. (e.g., if you have `class C a` and - -- `instance C T`, then the substitution [a |-> T] must be applied to the - -- original method's type.) - promote_meth_ty :: PrM ([DTyVarBndr], [DKind], DKind) - promote_meth_ty = - case meth_sort of - DefaultMethods -> - -- No substitution for class variables is required for default - -- method type signatures, as they share type variables with the - -- class they inhabit. - lookup_meth_ty - InstanceMethods inst_sigs_map cls_subst -> - case OMap.lookup meth_name inst_sigs_map of - Just ty -> do - -- We have an InstanceSig. These are easy: we can just use the - -- instance signature's type directly, and no substitution for - -- class variables is required. - promoteUnraveled ty - Nothing -> do - -- We don't have an InstanceSig, so we must compute the kind to use - -- ourselves. - (_, arg_kis, res_ki) <- lookup_meth_ty - -- Substitute for the class variables in the method's type. - -- See Note [Promoted class method kinds] - let arg_kis' = map (substKind cls_subst) arg_kis - res_ki' = substKind cls_subst res_ki - -- Compute the type variable binders in a left-to-right - -- order, since that is the same order that the promoted - -- method's kind will use. - -- See Note [Promoted class methods and kind variable ordering] - tvbs' = toposortTyVarsOf (arg_kis' ++ [res_ki']) - pure (tvbs', arg_kis', res_ki') - - -- Attempt to look up a class method's original type. - lookup_meth_ty :: PrM ([DTyVarBndr], [DKind], DKind) - lookup_meth_ty = do - opts <- getOptions - let proName = promotedTopLevelValueName opts meth_name - case OMap.lookup meth_name orig_sigs_map of - Just ty -> do - -- The type of the method is in scope, so promote that. - promoteUnraveled ty - Nothing -> do - -- If the type of the method is not in scope, the only other option - -- is to try reifying the promoted method name. - 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 (defaultMaybeToTypeKind . extractTvbKind) tvbs - res_ki = defaultMaybeToTypeKind (resultSigToMaybeKind mb_res_ki) - -- Compute the type variable binders in a left-to-right - -- order, since that is the same order that the promoted - -- method's kind will use. - -- See Note [Promoted class methods and kind variable ordering] - tvbs' = toposortTyVarsOf (arg_kis ++ [res_ki]) - in pure (tvbs', arg_kis, res_ki) - _ -> fail $ "Cannot find type annotation for " ++ show proName - -{- -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) :: Bool - type M x y = MHelper1 x y - - instance PC [a] where - type M x y = MHelper2 x y - - type MHelper1 :: a -> Bool -> Bool - type family MHelper1 x y where ... - - type MHelper2 :: [a] -> Bool -> Bool - type family MHelper2 x y 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 :: Maybe Uniq -> ULetDecEnv -> PrM ([DDec], ALetDecEnv) -promoteLetDecEnv mb_let_uniq (LetDecEnv { lde_defns = value_env - , lde_types = type_env - , lde_infix = fix_env }) = do - infix_decls <- mapMaybeM (uncurry (promoteInfixDecl mb_let_uniq)) $ - OMap.assocs fix_env - - -- promote all the declarations, producing annotated declarations - let (names, rhss) = unzip $ OMap.assocs value_env - (pro_decs, defun_decss, ann_rhss) - <- fmap unzip3 $ - zipWithM (promoteLetDecRHS LetBindingRHS type_env fix_env mb_let_uniq) - names rhss - - emitDecs $ concat defun_decss - bound_kvs <- allBoundKindVars - let decs = concat pro_decs ++ 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') - --- Promote a fixity declaration. -promoteInfixDecl :: forall q. OptionsMonad q - => Maybe Uniq -> Name -> Fixity -> q (Maybe DDec) -promoteInfixDecl mb_let_uniq name fixity = do - opts <- getOptions - mb_ns <- reifyNameSpace name - case mb_ns of - -- If we can't find the Name for some odd reason, fall back to promote_val - Nothing -> promote_val - Just VarName -> promote_val - Just DataName -> never_mind - Just TcClsName -> do - mb_info <- dsReify name - case mb_info of - Just (DTyConI DClassD{} _) - -> finish $ promotedClassName opts name - _ -> never_mind - where - -- Produce the fixity declaration. - finish :: Name -> q (Maybe DDec) - finish = pure . Just . DLetDec . DInfixD fixity - - -- Don't produce a fixity declaration at all. This happens when promoting a - -- fixity declaration for a name whose promoted counterpart is the same as - -- the original name. - -- See Note [singletons and fixity declarations] in D.S.Single.Fixity, wrinkle 1. - never_mind :: q (Maybe DDec) - never_mind = pure Nothing - - -- Certain value names do not change when promoted (e.g., infix names). - -- Therefore, don't bother promoting their fixity declarations if - -- 'genQuotedDecs' is set to 'True', since that will run the risk of - -- generating duplicate fixity declarations. - -- See Note [singletons and fixity declarations] in D.S.Single.Fixity, wrinkle 1. - promote_val :: q (Maybe DDec) - promote_val = do - opts <- getOptions - let promoted_name :: Name - promoted_name = promotedValueName opts name mb_let_uniq - if nameBase name == nameBase promoted_name && genQuotedDecs opts - then never_mind - else finish promoted_name - --- Try producing promoted fixity declarations for Names by reifying them --- /without/ consulting quoted declarations. If reification fails, recover and --- return the empty list. --- See [singletons and fixity declarations] in D.S.Single.Fixity, wrinkle 2. -promoteReifiedInfixDecls :: forall q. OptionsMonad q => [Name] -> q [DDec] -promoteReifiedInfixDecls = mapMaybeM tryPromoteFixityDeclaration - where - tryPromoteFixityDeclaration :: Name -> q (Maybe DDec) - tryPromoteFixityDeclaration name = - qRecover (return Nothing) $ do - mFixity <- qReifyFixity name - case mFixity of - Nothing -> pure Nothing - Just fixity -> promoteInfixDecl Nothing name fixity - --- Which sort of let-bound declaration's right-hand side is being promoted? -data LetDecRHSSort - -- An ordinary (i.e., non-class-related) let-bound declaration. - = LetBindingRHS - -- The right-hand side of a class method (either a default method or a - -- method in an instance declaration). - | ClassMethodRHS - [DTyVarBndr] [DKind] DKind - -- The RHS's promoted type variable binders, argument types, and - -- result type. Needed to fix #136. - deriving Show - --- 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 :: LetDecRHSSort - -> OMap Name DType -- local type env't - -> OMap Name Fixity -- local fixity env't - -> Maybe Uniq -- let-binding unique (if locally bound) - -> Name -- name of the thing being promoted - -> ULetDecRHS -- body of the thing - -> PrM ( [DDec] -- promoted type family dec, plus the - -- SAK dec (if one exists) - , [DDec] -- defunctionalization - , ALetDecRHS ) -- annotated RHS -promoteLetDecRHS rhs_sort type_env fix_env mb_let_uniq name let_dec_rhs = do - opts <- getOptions - all_locals <- allLocals - case let_dec_rhs of - UValue exp -> do - (m_ldrki, ty_num_args) <- promote_let_dec_ty all_locals 0 - if ty_num_args == 0 - then - let proName = promotedValueName opts name mb_let_uniq - prom_fun_lhs = foldType (DConT proName) $ map DVarT all_locals in - promote_let_dec_rhs all_locals m_ldrki 0 (promoteExp exp) - (\exp' -> [DTySynEqn Nothing prom_fun_lhs exp']) - AValue - else - -- If we have a UValue with a function type, process it as though it - -- were a UFunction. promote_function_rhs will take care of - -- eta-expanding arguments as necessary. - promote_function_rhs all_locals [DClause [] exp] - UFunction clauses -> promote_function_rhs all_locals clauses - where - -- Promote the RHS of a UFunction (or a UValue with a function type). - promote_function_rhs :: [Name] - -> [DClause] -> PrM ([DDec], [DDec], ALetDecRHS) - promote_function_rhs all_locals clauses = do - opts <- getOptions - numArgs <- count_args clauses - let proName = promotedValueName opts name mb_let_uniq - prom_fun_lhs = foldType (DConT proName) $ map DVarT all_locals - (m_ldrki, ty_num_args) <- promote_let_dec_ty all_locals numArgs - expClauses <- mapM (etaContractOrExpand ty_num_args numArgs) clauses - promote_let_dec_rhs all_locals m_ldrki ty_num_args - (mapAndUnzipM (promoteClause prom_fun_lhs) expClauses) - id AFunction - - -- Promote a UValue or a UFunction. - -- Notes about type variables: - -- - -- * For UValues, `prom_a` is DType and `a` is Exp. - -- - -- * For UFunctions, `prom_a` is [DTySynEqn] and `a` is [DClause]. - promote_let_dec_rhs - :: [Name] -- Local variables bound in this scope - -> Maybe LetDecRHSKindInfo -- Information about the promoted kind (if present) - -> Int -- The number of promoted function arguments - -> PrM (prom_a, a) -- Promote the RHS - -> (prom_a -> [DTySynEqn]) -- Turn the promoted RHS into type family equations - -> (DType -> Int -> a -> ALetDecRHS) -- Build an ALetDecRHS - -> PrM ([DDec], [DDec], ALetDecRHS) - promote_let_dec_rhs all_locals m_ldrki ty_num_args - promote_thing mk_prom_eqns mk_alet_dec_rhs = do - opts <- getOptions - tyvarNames <- replicateM ty_num_args (qNewName "a") - let proName = promotedValueName opts name mb_let_uniq - local_tvbs = map DPlainTV all_locals - m_fixity = OMap.lookup name fix_env - - mk_tf_head :: [DTyVarBndr] -> DFamilyResultSig -> DTypeFamilyHead - mk_tf_head tvbs res_sig = DTypeFamilyHead proName tvbs res_sig Nothing - - (lde_kvs_to_bind, m_sak_dec, defun_ki, tf_head) = - -- There are three possible cases: - case m_ldrki of - -- 1. We have no kind information whatsoever. - Nothing -> - let all_args = local_tvbs ++ map DPlainTV tyvarNames in - ( OSet.empty - , Nothing - , DefunNoSAK all_args Nothing - , mk_tf_head all_args DNoSig - ) - -- 2. We have some kind information in the form of a LetDecRHSKindInfo. - Just (LDRKI m_sak tvbs argKs resK) -> - let all_args = local_tvbs ++ zipWith DKindedTV tyvarNames argKs - lde_kvs_to_bind' = OSet.fromList (map extractTvbName tvbs) in - case m_sak of - -- 2(a). We do not have a standalone kind signature. - Nothing -> - ( lde_kvs_to_bind' - , Nothing - , DefunNoSAK all_args (Just resK) - , mk_tf_head all_args (DKindSig resK) - ) - -- 2(b). We have a standalone kind signature. - Just sak -> - ( lde_kvs_to_bind' - , Just $ DKiSigD proName sak - , DefunSAK sak - -- If the promoted type family has a standalone kind - -- signature, then there is no need to annotate the arguments - -- or result with explicit kinds. A standalone kind signature - -- accomplishes the same thing, but better. - , mk_tf_head (map dropTvbKind all_args) DNoSig - ) - - defun_decs <- defunctionalize proName m_fixity defun_ki - (prom_thing, thing) <- forallBind lde_kvs_to_bind promote_thing - prom_fun_rhs <- lookupVarE name - return ( catMaybes [ m_sak_dec - , Just $ DClosedTypeFamilyD tf_head (mk_prom_eqns prom_thing) - ] - , defun_decs - , mk_alet_dec_rhs prom_fun_rhs ty_num_args thing ) - - promote_let_dec_ty :: [Name] -- The local variables that the let-dec closes - -- over. If this is non-empty, we cannot - -- produce a standalone kind signature. - -- See Note [No SAKs for let-decs with local variables] - -> Int -- The number of arguments to default to if the - -- type cannot be inferred. This is 0 for UValues - -- and the number of arguments in a single clause - -- for UFunctions. - -> PrM (Maybe LetDecRHSKindInfo, Int) - -- Returns two things in a pair: - -- - -- 1. Information about the promoted kind, - -- if available. - -- - -- 2. The number of arguments the let-dec has. - -- If no kind information is available from - -- which to infer this number, then this - -- will default to the earlier Int argument. - promote_let_dec_ty all_locals default_num_args = - case rhs_sort of - ClassMethodRHS tvbs arg_kis res_ki - -> -- For class method RHS helper functions, don't bother quantifying - -- any type variables in their SAKS. We could certainly try, but - -- given that these functions are only used internally, there's no - -- point in trying to get the order of type variables correct, - -- since we don't apply these functions with visible kind - -- applications. - let sak = ravelVanillaDType [] [] arg_kis res_ki in - return (Just (LDRKI (Just sak) tvbs arg_kis res_ki), length arg_kis) - LetBindingRHS - | Just ty <- OMap.lookup name type_env - -> do - -- promoteType turns rank-1 uses of (->) into (~>). So, we unravel - -- first to avoid this behavior, and then ravel back. - (tvbs, argKs, resultK) <- promoteUnraveled ty - let m_sak | null all_locals = Just $ ravelVanillaDType tvbs [] argKs resultK - -- If this let-dec closes over local variables, then - -- don't give it a SAK. - -- See Note [No SAKs for let-decs with local variables] - | otherwise = Nothing - -- invariant: count_args ty == length argKs - return (Just (LDRKI m_sak tvbs argKs resultK), length argKs) - - | otherwise - -> return (Nothing, default_num_args) - - 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] -> PrM Int - count_args (DClause pats _ : _) = return $ length pats - count_args _ = fail $ "Impossible! A function without clauses." - --- An auxiliary data type used in promoteLetDecRHS that describes information --- related to the promoted kind of a class method default or normal --- let binding. -data LetDecRHSKindInfo = - LDRKI (Maybe DKind) -- The standalone kind signature, if applicable. - -- This will be Nothing if the let-dec RHS has local - -- variables that it closes over. - -- See Note [No SAKs for let-decs with local variables] - [DTyVarBndr] -- The type variable binders of the kind. - [DKind] -- The argument kinds. - DKind -- The result kind. - -{- -Note [No SAKs for let-decs with local variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider promoting this: - - f :: Bool - f = let x = True - g :: () -> Bool - g _ = x - in g () - -Clearly, the promoted `F` type family will have the following SAK: - - type F :: () - -What about `G`? At a passing glance, it appears that you could get away with -this: - - type G :: Bool -> () - -But this isn't quite right, since `g` closes over `x = True`. The body of `G`, -therefore, has to lift `x` to be an explicit argument: - - type family G x (u :: ()) :: Bool where - G x _ = x - -At present, we don't keep track of the types of local variables like `x`, which -makes it difficult to create a SAK for things like `G`. Here are some possible -ideas, each followed by explanations for why they are infeasible: - -* Use wildcards: - - type G :: _ -> () -> Bool - - Alas, GHC currently does not allow wildcards in SAKs. See GHC#17432. - -* Use visible dependent quantification to avoid having to say what the kind - of `x` is: - - type G :: forall x -> () -> Bool - - A clever trick to be sure, but it doesn't quite do what we want, since - GHC will generalize that kind to become `forall (x :: k) -> () -> Bool`, - which is more general than we want. - -In any case, it's probably not worth bothering with SAKs for local definitions -like `g` in the first place, so we avoid generating SAKs for anything that -closes over at least one local variable for now. If someone yells about this, -we'll reconsider this design. --} - -promoteClause :: DType -- What to use as the LHS of the promoted type family - -- equation. This should consist of the promoted name of - -- the function to which the clause belongs, applied to - -- any local arguments (e.g., `Go x y z`). - -> DClause -> PrM (DTySynEqn, ADClause) -promoteClause pro_clause_fun (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 - return ( DTySynEqn Nothing (foldType pro_clause_fun types) ty - , ADClause new_vars pats' ann_exp ) - -promoteMatch :: DType -- What to use as the LHS of the promoted type family - -- equation. This should consist of the promoted name of - -- the case expression to which the match belongs, applied - -- to any local arguments (e.g., `Case x y z`). - -> DMatch -> PrM (DTySynEqn, ADMatch) -promoteMatch pro_case_fun (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 - return $ ( DTySynEqn Nothing (pro_case_fun `DAppT` 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) = do - opts <- getOptions - return (DConT $ defunctionalizedName0 opts 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 - opts <- getOptions - lambdaName <- newUniqueName "Lambda" - tyNames <- mapM mkTyName names - let var_proms = zip names tyNames - (rhs, ann_exp) <- lambdaBind var_proms $ promoteExp exp - all_locals <- allLocals - let all_args = all_locals ++ tyNames - tvbs = map DPlainTV all_args - emitDecs [DClosedTypeFamilyD (DTypeFamilyHead - lambdaName - tvbs - DNoSig - Nothing) - [DTySynEqn Nothing - (foldType (DConT lambdaName) $ - map DVarT all_args) - rhs]] - emitDecsM $ defunctionalize lambdaName Nothing $ DefunNoSAK tvbs Nothing - let promLambda = foldl apply (DConT (defunctionalizedName opts 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 prom_case) 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 - (binds, ann_env) <- promoteLetDecs (Just unique) 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,897 +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 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.TH.Options -import Data.Singletons.Util -import Control.Monad -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" - --- Defunctionalize type families defined at the top level (i.e., not associated --- with a type class). -defunTopLevelTypeDecls :: - [TySynDecl] - -> [ClosedTypeFamilyDecl] - -> [OpenTypeFamilyDecl] - -> PrM () -defunTopLevelTypeDecls 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 - --- Defunctionalize all the type families associated with a type class. -defunAssociatedTypeFamilies :: - [DTyVarBndr] -- The type variables bound by the parent class - -> [OpenTypeFamilyDecl] -- The type families associated with the parent class - -> PrM () -defunAssociatedTypeFamilies cls_tvbs atfs = do - defun_atfs <- concatMapM defun atfs - emitDecs defun_atfs - where - defun :: OpenTypeFamilyDecl -> PrM [DDec] - defun (TypeFamilyDecl tf_head) = - buildDefunSymsTypeFamilyHead ascribe_tf_tvb_kind id tf_head - - -- Maps class-bound type variables to their kind annotations (if supplied). - -- For example, `class C (a :: Bool) b (c :: Type)` will produce - -- {a |-> Bool, c |-> Type}. - cls_tvb_kind_map :: Map Name DKind - cls_tvb_kind_map = Map.fromList [ (extractTvbName tvb, tvb_kind) - | tvb <- cls_tvbs - , Just tvb_kind <- [extractTvbKind tvb] - ] - - -- If the parent class lacks a SAK, we cannot safely default kinds to - -- Type. All we can do is make use of whatever kind information that parent - -- class provides and let kind inference do the rest. - -- - -- We can sometimes learn more specific information about unannotated type - -- family binders from the parent class, as in the following example: - -- - -- class C (a :: Bool) where - -- type T a :: Type - -- - -- Here, we know that `T :: Bool -> Type` because we can infer that the `a` - -- in `type T a` should be of kind `Bool` from the class SAK. - ascribe_tf_tvb_kind :: DTyVarBndr -> DTyVarBndr - ascribe_tf_tvb_kind tvb = - case tvb of - DKindedTV{} -> tvb - DPlainTV n -> maybe tvb (DKindedTV n) $ Map.lookup n cls_tvb_kind_map - -buildDefunSyms :: DDec -> PrM [DDec] -buildDefunSyms dec = - case dec of - DDataD _new_or_data _cxt _tyName _tvbs _k ctors _derivings -> - buildDefunSymsDataD ctors - DClosedTypeFamilyD tf_head _ -> - buildDefunSymsClosedTypeFamilyD tf_head - DOpenTypeFamilyD tf_head -> - buildDefunSymsOpenTypeFamilyD tf_head - DTySynD name tvbs rhs -> - buildDefunSymsTySynD name tvbs rhs - DClassD _cxt name tvbs _fundeps _members -> - defunReify name tvbs (Just (DConT constraintName)) - _ -> fail $ "Defunctionalization symbols can only be built for " ++ - "type families and data declarations" - --- Unlike open type families, closed type families that lack SAKS do not --- default anything to Type, instead relying on kind inference to figure out --- unspecified kinds. -buildDefunSymsClosedTypeFamilyD :: DTypeFamilyHead -> PrM [DDec] -buildDefunSymsClosedTypeFamilyD = buildDefunSymsTypeFamilyHead id id - --- If an open type family lacks a SAK and has type variable binders or a result --- without explicit kinds, then they default to Type (hence the uses of --- default{Tvb,Maybe}ToTypeKind). -buildDefunSymsOpenTypeFamilyD :: DTypeFamilyHead -> PrM [DDec] -buildDefunSymsOpenTypeFamilyD = - buildDefunSymsTypeFamilyHead defaultTvbToTypeKind (Just . defaultMaybeToTypeKind) - -buildDefunSymsTypeFamilyHead - :: (DTyVarBndr -> DTyVarBndr) -- How to default each type variable binder - -> (Maybe DKind -> Maybe DKind) -- How to default the result kind - -> 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) - defunReify name arg_tvbs res_kind - -buildDefunSymsTySynD :: Name -> [DTyVarBndr] -> DType -> PrM [DDec] -buildDefunSymsTySynD name tvbs rhs = defunReify name tvbs mb_res_kind - where - -- If a type synonym lacks a SAK, we can "infer" its result kind by - -- checking for an explicit kind annotation on the right-hand side. - 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 (DCon tvbs _ name fields res_ty) = do - let arg_tys = tysOfConFields fields - arg_kis <- traverse promoteType_NC arg_tys - res_ki <- promoteType_NC res_ty - let con_ki = ravelVanillaDType tvbs [] arg_kis res_ki - m_fixity <- reifyFixityWithLocals name - defunctionalize name m_fixity $ DefunSAK con_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]) --- and dsReifyType to determine whether defunctionalization should make use --- of SAKs or not (see Note [Defunctionalization game plan]). -defunReify :: Name -- Name of the declaration to be defunctionalized - -> [DTyVarBndr] -- The declaration's type variable binders - -- (only used if the declaration lacks a SAK) - -> Maybe DKind -- The declaration's return kind, if it has one - -- (only used if the declaration lacks a SAK) - -> PrM [DDec] -defunReify name tvbs m_res_kind = do - m_fixity <- reifyFixityWithLocals name - m_sak <- dsReifyType name - let defun = defunctionalize name m_fixity - case m_sak of - Just sak -> defun $ DefunSAK sak - Nothing -> defun $ DefunNoSAK tvbs m_res_kind - --- Generate symbol data types, Apply instances, and other declarations required --- for defunctionalization. --- See Note [Defunctionalization game plan] for an overview of the design --- considerations involved. -defunctionalize :: Name - -> Maybe Fixity - -> DefunKindInfo - -> PrM [DDec] -defunctionalize name m_fixity defun_ki = do - case defun_ki of - DefunSAK sak -> - -- Even if a declaration has a SAK, its kind may not be vanilla. - case unravelVanillaDType_either sak of - -- If the kind isn't vanilla, use the fallback approach. - -- See Note [Defunctionalization game plan], - -- Wrinkle 2: Non-vanilla kinds. - Left _ -> defun_fallback [] (Just sak) - -- Otherwise, proceed with defun_vanilla_sak. - Right (sak_tvbs, _sak_cxt, sak_arg_kis, sak_res_ki) - -> defun_vanilla_sak sak_tvbs sak_arg_kis sak_res_ki - -- If a declaration lacks a SAK, it likely has a partial kind. - -- See Note [Defunctionalization game plan], Wrinkle 1: Partial kinds. - DefunNoSAK tvbs m_res -> defun_fallback tvbs m_res - where - -- Generate defunctionalization symbols for things with vanilla SAKs. - -- The symbols themselves will also be given SAKs. - defun_vanilla_sak :: [DTyVarBndr] -> [DKind] -> DKind -> PrM [DDec] - defun_vanilla_sak sak_tvbs sak_arg_kis sak_res_ki = do - opts <- getOptions - extra_name <- qNewName "arg" - -- Use noExactName below to avoid #17537. - arg_names <- replicateM (length sak_arg_kis) (noExactName <$> qNewName "a") - - let -- The inner loop. @go n arg_nks res_nks@ returns @(res_k, decls)@. - -- Using one particular example: - -- - -- @ - -- type ExampleSym2 :: a -> b -> c ~> d ~> Type - -- data ExampleSym2 x y where ... - -- type instance Apply (ExampleSym2 x y) z = ExampleSym3 x y z - -- ... - -- @ - -- - -- We have: - -- - -- * @n@ is 2. This is incremented in each iteration of `go`. - -- - -- * @arg_nks@ is [(x, a), (y, b)]. Each element in this list is a - -- (type variable name, type variable kind) pair. The kinds appear in - -- the SAK, separated by matchable arrows (->). - -- - -- * @res_tvbs@ is [(z, c), (w, d)]. Each element in this list is a - -- (type variable name, type variable kind) pair. The kinds appear in - -- @res_k@, separated by unmatchable arrows (~>). - -- - -- * @res_k@ is `c ~> d ~> Type`. @res_k@ is returned so that earlier - -- defunctionalization symbols can build on the result kinds of - -- later symbols. For instance, ExampleSym1 would get the result - -- kind `b ~> c ~> d ~> Type` by prepending `b` to ExampleSym2's - -- result kind `c ~> d ~> Type`. - -- - -- * @decls@ are all of the declarations corresponding to ExampleSym2 - -- and later defunctionalization symbols. This is the main payload of - -- the function. - -- - -- This function is quadratic because it appends a variable at the end of - -- the @arg_nks@ list at each iteration. In practice, this is unlikely - -- to be a performance bottleneck since the number of arguments rarely - -- gets to be that large. - go :: Int -> [(Name, DKind)] -> [(Name, DKind)] -> (DKind, [DDec]) - go n arg_nks res_nkss = - case res_nkss of - [] -> - let -- Somewhat surprisingly, we do *not* generate SAKs for - -- fully saturated defunctionalization symbols. - -- See Note [No SAKs for fully saturated defunctionalization symbols] - sat_decs = mk_sat_decs opts n (map (uncurry DKindedTV) arg_nks) - (Just sak_res_ki) - in (sak_res_ki, sat_decs) - res_nk:res_nks -> - let (res_ki, decs) = go (n+1) (arg_nks ++ [res_nk]) res_nks - tyfun = buildTyFunArrow (snd res_nk) res_ki - defun_sak_dec = DKiSigD (defunctionalizedName opts name n) $ - ravelVanillaDType sak_tvbs [] (map snd arg_nks) tyfun - defun_other_decs = mk_defun_decs opts n (map (DPlainTV . fst) arg_nks) - (fst res_nk) extra_name Nothing - in (tyfun, defun_sak_dec:defun_other_decs ++ decs) - - pure $ snd $ go 0 [] $ zip arg_names sak_arg_kis - - -- If defun_sak can't be used to defunctionalize something, this fallback - -- approach is used. This is used when defunctionalizing something with a - -- partial kind - -- (see Note [Defunctionalization game plan], Wrinkle 1: Partial kinds) - -- or a non-vanilla kind - -- (see Note [Defunctionalization game plan], Wrinkle 2: Non-vanilla kinds). - defun_fallback :: [DTyVarBndr] -> Maybe DKind -> PrM [DDec] - defun_fallback tvbs' m_res' = do - opts <- getOptions - extra_name <- qNewName "arg" - -- Use noExactTyVars below to avoid #11812. - (tvbs, m_res) <- eta_expand (noExactTyVars tvbs') (noExactTyVars m_res') - - let -- The inner loop. @go n arg_tvbs res_tvbs@ returns @(m_res_k, decls)@. - -- Using one particular example: - -- - -- @ - -- data ExampleSym2 (x :: a) y :: c ~> d ~> Type where ... - -- type instance Apply (ExampleSym2 x y) z = ExampleSym3 x y z - -- ... - -- @ - -- - -- This works very similarly to the `go` function in - -- `defun_vanilla_sak`. The main differences are: - -- - -- * This function does not produce any SAKs for defunctionalization - -- symbols. - -- - -- * Instead of [(Name, DKind)], this function uses [DTyVarBndr] as - -- the types of @arg_tvbs@ and @res_tvbs@. This is because the - -- kinds are not always known. By a similar token, this function - -- uses Maybe DKind, not DKind, as the type of @m_res_k@, since - -- the result kind is not always fully known. - go :: Int -> [DTyVarBndr] -> [DTyVarBndr] -> (Maybe DKind, [DDec]) - go n arg_tvbs res_tvbss = - case res_tvbss of - [] -> - let sat_decs = mk_sat_decs opts n arg_tvbs m_res - in (m_res, sat_decs) - res_tvb:res_tvbs -> - let (m_res_ki, decs) = go (n+1) (arg_tvbs ++ [res_tvb]) res_tvbs - m_tyfun = buildTyFunArrow_maybe (extractTvbKind res_tvb) - m_res_ki - defun_decs' = mk_defun_decs opts n arg_tvbs - (extractTvbName res_tvb) - extra_name m_tyfun - in (m_tyfun, defun_decs' ++ decs) - - pure $ snd $ go 0 [] tvbs - - mk_defun_decs :: Options - -> Int - -> [DTyVarBndr] - -> Name - -> Name - -> Maybe DKind - -> [DDec] - mk_defun_decs opts n arg_tvbs tyfun_name extra_name m_tyfun = - let data_name = defunctionalizedName opts name n - next_name = defunctionalizedName opts name (n+1) - con_name = prefixName "" ":" $ suffixName "KindInference" "###" data_name - arg_names = map extractTvbName arg_tvbs - params = arg_tvbs ++ [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 [] [con_eq_ct] con_name (DNormalC False []) - (foldTypeTvbs (DConT data_name) params) - data_decl = DDataD Data [] data_name args m_tyfun [con_decl] [] - where - args | isJust m_tyfun = arg_tvbs - | otherwise = params - app_data_ty = foldTypeTvbs (DConT data_name) arg_tvbs - app_eqn = DTySynEqn Nothing - (DConT applyName `DAppT` app_data_ty - `DAppT` DVarT tyfun_name) - (foldTypeTvbs (DConT next_name) - (arg_tvbs ++ [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 []])]] - - -- See Note [Fixity declarations for defunctionalization symbols] - fixity_decl = maybeToList $ fmap (mk_fix_decl data_name) m_fixity - in data_decl : app_decl : suppress : fixity_decl - - -- Generate a "fully saturated" defunction symbol, along with a fixity - -- declaration (if needed). - mk_sat_decs :: Options -> Int -> [DTyVarBndr] -> Maybe DKind -> [DDec] - mk_sat_decs opts n sat_tvbs m_sat_res = - let sat_name = defunctionalizedName opts name n - sat_dec = DTySynD sat_name sat_tvbs $ - foldTypeTvbs (DConT name) sat_tvbs `maybeSigT` m_sat_res - sat_fixity_dec = maybeToList $ fmap (mk_fix_decl sat_name) m_fixity - in sat_dec : sat_fixity_dec - - -- Generate extra kind variable binders corresponding to the number of - -- arrows in the return kind (if provided). Examples: - -- - -- >>> eta_expand [(x :: a), (y :: b)] (Just (c -> Type)) - -- ([(x :: a), (y :: b), (e :: c)], Just Type) - -- - -- >>> eta_expand [(x :: a), (y :: b)] Nothing - -- ([(x :: a), (y :: b)], Nothing) - 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 (arg_ks, result_k) = unravelDType res_kind - vis_arg_ks = filterDVisFunArgs arg_ks - extra_arg_tvbs <- traverse mk_extra_tvb vis_arg_ks - pure (m_arg_tvbs ++ extra_arg_tvbs, Just result_k) - - -- Convert a DVisFunArg to a DTyVarBndr, generating a fresh type variable - -- name if the DVisFunArg is an anonymous argument. - mk_extra_tvb :: DVisFunArg -> PrM DTyVarBndr - mk_extra_tvb vfa = - case vfa of - DVisFADep tvb -> pure tvb - DVisFAAnon k -> DKindedTV <$> qNewName "e" <*> pure k - - mk_fix_decl :: Name -> Fixity -> DDec - mk_fix_decl n f = DLetDec $ DInfixD f n - --- Indicates whether the type being defunctionalized has a standalone kind --- signature. If it does, DefunSAK contains the kind. If not, DefunNoSAK --- contains whatever information is known about its type variable binders --- and result kind. --- See Note [Defunctionalization game plan] for details on how this --- information is used. -data DefunKindInfo - = DefunSAK DKind - | DefunNoSAK [DTyVarBndr] (Maybe DKind) - --- 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 = buildTyFunArrow <$> m_k1 <*> m_k2 - -{- -Note [Defunctionalization game plan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Generating defunctionalization symbols involves a surprising amount of -complexity. This Note gives a broad overview of what happens during -defunctionalization and highlights various design considerations. -As a working example, we will use the following type family: - - type Foo :: forall c a b. a -> b -> c -> c - type family Foo x y z where ... - -We must generate a defunctionalization symbol for every number of arguments -to which Foo can be partially applied. We do so by generating the following -declarations: - - type FooSym0 :: forall c a b. a ~> b ~> c ~> c - data FooSym0 f where - FooSym0KindInference :: SameKind (Apply FooSym0 arg) (FooSym1 arg) - => FooSym0 f - type instance Apply FooSym0 x = FooSym1 x - - type FooSym1 :: forall c a b. a -> b ~> c ~> c - data FooSym1 x f where - FooSym1KindInference :: SameKind (Apply (FooSym1 a) arg) (FooSym2 a arg) - => FooSym1 a f - type instance Apply (FooSym1 x) y = FooSym2 x y - - type FooSym2 :: forall c a b. a -> b -> c ~> c - data FooSym2 x y f where - FooSym2KindInference :: SameKind (Apply (FooSym2 x y) arg) (FooSym3 x y arg) - => FooSym2 x y f - type instance Apply (FooSym2 x y) z = FooSym3 x y z - - type FooSym3 (x :: a) (y :: b) (z :: c) = Foo x y z :: c - -Some things to note: - -* Each defunctionalization symbol has its own standalone kind signature. The - number after `Sym` in each symbol indicates the number of leading -> arrows - in its kind—that is, the number of arguments to which it can be applied - directly to without the use of the Apply type family. - - See "Wrinkle 1: Partial kinds" below for what happens if the declaration - being defunctionalized does *not* have a standalone kind signature. - -* Each data declaration has a constructor with the suffix `-KindInference` - in its name. These are redundant in the particular case of Foo, where the - kind is already known. They play a more vital role when the kind of the - declaration being defunctionalized is only partially known. - See "Wrinkle 1: Partial kinds" below for more information. - -* FooSym3, the last defunctionalization symbol, is somewhat special in that - it is a type synonym, not a data type. These sorts of symbols are referred - to as "fully saturated" defunctionalization symbols. Furthermore, these - symbols are intentionally *not* given SAKs. See - Note [No SAKs for fully saturated defunctionalization symbols]. - -* If Foo had a fixity declaration (e.g., infixl 4 `Foo`), then we would also - generate fixity declarations for each defunctionalization symbol (e.g., - infixl 4 `FooSym0`). - See Note [Fixity declarations for defunctionalization symbols]. - -* Foo has a vanilla kind signature. (See - Note [Vanilla-type validity checking during promotion] in D.S.Promote.Type - for what "vanilla" means in this context.) Having a vanilla type signature is - important, as it is a property that makes it much simpler to preserve the - order of type variables (`forall c a b.`) in each of the defunctionalization - symbols. - - That being said, it is not strictly required that the kind be vanilla. There - is another approach that can be used to defunctionalize things with - non-vanilla types, at the possible expense of having different type variable - orders between different defunctionalization symbols. - See "Wrinkle 2: Non-vanilla kinds" below for more information. - ------ --- Wrinkle 1: Partial kinds ------ - -The Foo example above has a standalone kind signature, but not everything has -this much kind information. For example, consider this: - - $(singletons [d| - type family Not x where - Not False = True - Not True = False - |]) - -The inferred kind for Not is `Bool -> Bool`, but since Not was declared in TH -quotes, `singletons` has no knowledge of this. Instead, we must rely on kind -inference to give Not's defunctionalization symbols the appropriate kinds. -Here is a naïve first attempt: - - data NotSym0 f - type instance Apply NotSym0 x = NotSym1 x - - type NotSym1 x = Not x - -NotSym1 will have the inferred kind `Bool -> Bool`, but poor NotSym0 will have -the inferred kind `forall k. k -> Type`, which is far more general than we -would like. We can do slightly better by supplying additional kind information -in a data constructor, like so: - - type SameKind :: k -> k -> Constraint - class SameKind x y = () - - data NotSym0 f where - NotSym0KindInference :: SameKind (Apply NotSym0 arg) (NotSym1 arg) - => NotSym0 f - -NotSym0KindInference is not intended to ever be seen by the user. Its only -reason for existing is its existential -`SameKind (Apply NotSym0 arg) (NotSym1 arg)` context, which allows GHC to -figure out that NotSym0 has kind `Bool ~> Bool`. This is a bit of a hack, but -it works quite nicely. The only problem is that GHC is likely to warn that -NotSym0KindInference is unused, which is annoying. To work around this, we -mention the data constructor in an instance of a dummy class: - - instance SuppressUnusedWarnings NotSym0 where - suppressUnusedWarnings = snd (NotSym0KindInference, ()) - -Similarly, this SuppressUnusedWarnings class is not intended to ever be seen -by the user. As its name suggests, it only exists to help suppress "unused -data constructor" warnings. - -Some declarations have a mixture of known kinds and unknown kinds, such as in -this example: - - $(singletons [d| - type family Bar x (y :: Nat) (z :: Nat) :: Nat where ... - |]) - -We can use the known kinds to guide kind inference. In this particular example -of Bar, here are the defunctionalization symbols that would be generated: - - data BarSym0 f where ... - data BarSym1 x :: Nat ~> Nat ~> Nat where ... - data BarSym2 x (y :: Nat) :: Nat ~> Nat where ... - type BarSym3 x (y :: Nat) (z :: Nat) = Bar x y z :: Nat - ------ --- Wrinkle 2: Non-vanilla kinds ------ - -There is only limited support for defunctionalizing declarations with -non-vanilla kinds. One example of something with a non-vanilla kind is the -following, which uses a nested forall: - - $(singletons [d| - type Baz :: forall a. a -> forall b. b -> Type - data Baz x y - |]) - -One might envision generating the following defunctionalization symbols for -Baz: - - type BazSym0 :: forall a. a ~> forall b. b ~> Type - data BazSym0 f where ... - - type BarSym1 :: forall a. a -> forall b. b ~> Type - data BazSym1 x f where ... - - type family BazSym2 (x :: a) (y :: b) = Baz x y :: Type - -Unfortunately, doing so would require impredicativity, since we would have: - - forall a. a ~> forall b. b ~> Type - = forall a. (~>) a (forall b. b ~> Type) - = forall a. TyFun a (forall b. b ~> Type) -> Type - -Note that TyFun is an ordinary data type, so having its second argument be -(forall b. b ~> Type) is truly impredicative. As a result, trying to preserve -nested or higher-rank foralls is a non-starter. - -We need not reject Baz entirely, however. We can still generate perfectly -usable defunctionalization symbols if we are willing to sacrifice the exact -order of foralls. When we encounter a non-vanilla kind such as Baz's, we simply -fall back to the algorithm used when we encounter a partial kind (as described -in "Wrinkle 1: Partial kinds" above.) In other words, we generate the -following symbols: - - data BazSym0 :: a ~> b ~> Type where ... - data BazSym1 (x :: a) :: b ~> Type where ... - type BazSym2 (x :: a) (y :: b) = Baz x y :: Type - -The kinds of BazSym0 and BazSym1 both start with `forall a b.`, -whereas the `b` is quantified later in Baz itself. For most use cases, however, -this is not a huge concern. - -Another way kinds can be non-vanilla is if they contain visible dependent -quantification, like so: - - $(singletons [d| - type Quux :: forall (k :: Type) -> k -> Type - data Quux x y - |]) - -What should the kind of QuuxSym0 be? Intuitively, it should be this: - - type QuuxSym0 :: forall (k :: Type) ~> k ~> Type - -Alas, `forall (k :: Type) ~>` simply doesn't work. See #304. But there is an -acceptable compromise we can make that can give us defunctionalization symbols -for Quux. Once again, we fall back to the partial kind algorithm: - - data QuuxSym0 :: Type ~> k ~> Type where ... - data QuuxSym1 (k :: Type) :: k ~> Type where ... - type QuuxSym2 (k :: Type) (x :: k) = Quux k x :: Type - -The catch is that the kind of QuuxSym0, `forall k. Type ~> k ~> Type`, is -slightly more general than it ought to be. In practice, however, this is -unlikely to be a problem as long as you apply QuuxSym0 to arguments of the -right kinds. - -Note [No SAKs for fully saturated defunctionalization symbols] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When generating defunctionalization symbols, most of the symbols are data -types. The last one, however, is a type synonym. For example, this code: - - $(singletons [d| - type Const :: a -> b -> a - type Const x y = x - |]) - -Will generate the following symbols: - - type ConstSym0 :: a ~> b ~> a - data ConstSym0 f where ... - - type ConstSym1 :: a -> b ~> a - data ConstSym1 x f where ... - - type ConstSym2 (x :: a) (y :: b) = Const x y :: a - -ConstSym2, the sole type synonym of the bunch, is what is referred to as a -"fully saturated" defunctionaliztion symbol. - -At first glance, ConstSym2 may not seem terribly useful, since it is -effectively a thin wrapper around the original Const type. Indeed, fully -saturated symbols are never appear directly in user-written code. Instead, -they are most valuable in TH-generated code, as singletons often generates code -that directly applies a defunctionalization symbol to some number of arguments -(see, for instance, D.S.Names.promoteTySym). In theory, such code could carve -out a special case for fully saturated applications and apply the original -type instead of a defunctionalization symbol, but determining when an -application is fully saturated is often difficult in practice. As a result, it -is more convenient to just generate code that always applies FuncSymN to N -arguments, and to let fully saturated defunctionalization symbols handle the -case where N equals the number of arguments needed to fully saturate Func. - -Another curious thing about fully saturated defunctionalization symbols do -*not* get assigned SAKs, unlike their data type brethren. Why not just give -ConstSym2 a SAK like this? - - type ConstSym2 :: a -> b -> a - type ConstSym2 x y = Const x y - -This would in fact work for most use cases, but there are a handful of corner -cases where this approach would break down. Here is one such corner case: - - $(promote [d| - class Applicative f where - pure :: a -> f a - ... - (*>) :: f a -> f b -> f b - |]) - - ==> - - class PApplicative f where - type Pure (x :: a) :: f a - type (*>) (x :: f a) (y :: f b) :: f b - -What would happen if we were to defunctionalize the promoted version of (*>)? -We'd end up with the following defunctionalization symbols: - - type (*>@#@$) :: f a ~> f b ~> f b - data (*>@#@$) f where ... - - type (*>@#@$$) :: f a -> f b ~> f b - data (*>@#@$$) x f where ... - - type (*>@#@$$$) :: f a -> f b -> f b - type (*>@#@$$$) x y = (*>) x y - -It turns out, however, that (*>@#@$$$) will not kind-check. Because (*>@#@$$$) -has a standalone kind signature, it is kind-generalized *before* kind-checking -the actual definition itself. Therefore, the full kind is: - - type (*>@#@$$$) :: forall {k} (f :: k -> Type) (a :: k) (b :: k). - f a -> f b -> f b - type (*>@#@$$$) x y = (*>) x y - -However, the kind of (*>) is -`forall (f :: Type -> Type) (a :: Type) (b :: Type). f a -> f b -> f b`. -This is not general enough for (*>@#@$$$), which expects kind-polymorphic `f`, -`a`, and `b`, leading to a kind error. You might think that we could somehow -infer this information, but note the quoted definition of Applicative (and -PApplicative, as a consequence) omits the kinds of `f`, `a`, and `b` entirely. -Unless we were to implement full-blown kind inference inside of Template -Haskell (which is a tall order), the kind `f a -> f b -> f b` is about as good -as we can get. - -Note that (*>@#@$) and (*>@#@$$) are implemented as GADTs, not type synonyms. -This allows them to have kind-polymorphic `f`, `a`, and `b` in their kinds -while equating `k` to be `Type` in their data constructors, which neatly avoids -the issue that (*>@#@$$$) faces. - ------ - -In one last attempt to salvage the idea of giving SAKs to fully saturated -defunctionalization symbols, I explored an idea where we would add -"dummy constraints" to get the kinds exactly right. The idea was to first -define a type synonym for dummy contexts: - - type Dummy :: Constraint -> Constraint - type Dummy x = () ~ () - -Dummy simply ignores its argument and returns `() ~ ()`. `() ~ ()` was chosen -because it's one of the few Constraints that can currently be used at the kind -level. Dummy could, in theory, be used like this: - - type (*>@#@$) :: Dummy (PApplicative f) => f a ~> f b ~> f b - type (*>@#@$$) :: Dummy (PApplicative f) => f a -> f b ~> f b - type (*>@#@$$$) :: Dummy (PApplicative f) => f a -> f b -> f b - -The advantage to using `Dummy (PApplicative f)` is that it would constraint `f` -to be of kind `Type -> Type`, which would get the kinds exactly the way we want -them. Sounds great, right? Unfortunately, it doesn't work in practice. Consider -this example: - - $(promoteOnly [d| - class C a where - m1 :: a -> a - m1 = m2 - - m2 :: a -> a - m2 = m1 - |]) - - ==> - - class PC a where - type M1 (x :: a) :: a - type M1 x = Apply M2Sym1 x - - type M2 (x :: a) :: a - type M2 x = Apply M1Sym1 x - -The generated code would fail to compile, instead throwing this error: - - error: - • Class ‘PC’ cannot be used here - (it is defined and used in the same recursive group) - • In the first argument of ‘Dummy’, namely ‘(PC a)’ - In a standalone kind signature for ‘M2Sym1’: - forall a. Dummy (PC a) => a -> a - | - | type M2Sym1 :: forall a. Dummy (PC a) => a -> a - | ^^^^ - -Ugh. I suspect this is a GHC bug (see -https://gitlab.haskell.org/ghc/ghc/issues/15942#note_242075), but it's one -that's unlikely to be fixed any time soon. - -A slight variations on idea is to use the original class instead of the -promoted class in `Dummy` contexts, e.g., - - type M2Sym1 :: forall a. Dummy (C a) => a -> a - -This would avoid the recursive group issues, but it would introduce a new -problem: the original class is not guaranteed to exist if -`promoteOnly` or `singletonsOnly` are used to create the promoted class. -(Indeed, this is precisely the case in the `PC` example.) - ------ - -As an alternative to type synonyms, we might consider using type families to -define fully saturated defunctionalization symbols. For instance, we could try -this: - - type (*>@#@$$$) :: f a -> f b -> f b - type family (*>@#@$$$) x y where - (*>@#@$$$) x y = (*>) x y - -Like before, the full kind of (*>@#@$$$) is generalized to be -`forall {k} (f :: k -> Type) (a :: k) (b :: k)`. The difference is that the -type family equation *matches* on `k` such that the equation will only trigger -if `k` is equal to `Type`. (This is similar to the trick that (*>@#@$) and -(*>@#@$$) employ, as being GADTs allows them to constrain `k` to be `Type` in -their data constructors.) - -Alas, the type family approach is strictly less powerful than the type synonym -approach. Consider the following code: - - $(singletons [d| - data Nat = Z | S Nat - - natMinus :: Nat -> Nat -> Nat - natMinus Z _ = Z - natMinus (S a) (S b) = natMinus a b - natMinus a Z = a - |]) - -Among other things, this will generate the following declarations: - - type ZSym0 :: Nat - - type NatMinus :: Nat -> Nat -> Nat - type family NatMinus x y where - NatMinus Z _ = ZSym0 - NatMinus (S a) (S b) = NatMinus a b - NatMinus a Z = a - - sNatMinus :: SNat x -> SNat y -> SNat (NatMinus x y) - sNatMinus SZ _ = SZ - sNatMinus (SS sA) (SS sB) = sNatMinus sA sB - sNatMinus sA SZ = sA - -Shockingly, this will either succeed or fail to compile depending on whether -ZSym0 is a type synonym or a type family. If ZSym0 is a type synonym, then -the first and third equations of NatMinus will be compatible (since GHC will -be able to infer that Z ~ ZSym0), which is what allows the third equation of -sNatMinus to typecheck. If ZSym0 is a type family, however, then the third -equation of NatMinus will be incompatible with the first, which will cause -the third equation of sNatMinus to fail to typecheck: - - error: - • Could not deduce: NatMinus x 'Z ~ x - from the context: y ~ 'Z - bound by a pattern with constructor: SZ :: SNat 'Z, - in an equation for ‘sNatMinus’ - ‘x’ is a rigid type variable bound by - the type signature for: - sNatMinus :: forall (x :: Nat) (y :: Nat). - SNat x -> SNat y -> SNat (NatMinus x y) - Expected type: SNat (NatMinus x y) - Actual type: SNat x - • In the expression: sA - In an equation for ‘sNatMinus’: sNatMinus sA SZ = sA - • Relevant bindings include - sA :: SNat x - sNatMinus :: SNat x -> SNat y -> SNat (NatMinus x y) - -One could work around the issue by tweaking the third equation of natMinus -slightly: - - $(singletons [d| - ... - - natMinus :: Nat -> Nat -> Nat - natMinus Z _ = Z - natMinus (S a) (S b) = natMinus a b - natMinus a@(S _) Z = a - |]) - -But I would generally prefer to avoid having the user add extraneous pattern -matches when possible. Given the choice between expressiveness and SAKs, I give -the edge to expressiveness. - -Bottom line: don't give fully saturated defunctionalization symbols SAKs. This -is admittedly not ideal, but it's unlikely to be a sticking point in practice, -given that these symbols are almost exclusively used in autogenerated code -in the first place. If we want to support promoting code that uses visible -type application (see #378), we will need to figure out how to resolve this -issue. - -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,80 +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.TH.Options -import Data.Singletons.Util -import Control.Monad - --- produce a closed type family helper and the instance --- for (==) over the given list of ctors -mkEqTypeInstance :: OptionsMonad q => DKind -> [DCon] -> q [DDec] -mkEqTypeInstance kind cons = do - opts <- getOptions - helperName <- newUniqueName "Equals" - aName <- qNewName "a" - bName <- qNewName "b" - true_branches <- mapM (mk_branch helperName) cons - let null_branch = catch_all_case opts helperName trueName - false_branch = catch_all_case opts helperName falseName - branches | null cons = [null_branch] - | otherwise = true_branches ++ [false_branch] - -- We opt to give an explicit kind signature for the helper type family. - -- See Note [Promoted class method kinds] in Data.Singletons.Promote. - sakDec = DKiSigD helperName $ ravelVanillaDType [] [] [kind, kind] boolKi - closedFam = DClosedTypeFamilyD (DTypeFamilyHead helperName - [DPlainTV aName, DPlainTV bName] - DNoSig - 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 $ promotedClassName opts eqName) `DAppT` - kind) [eqInst] - - return [sakDec, closedFam, inst] - - where mk_branch :: OptionsMonad q => Name -> DCon -> q DTySynEqn - mk_branch helper_name con = do - opts <- getOptions - 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 opts results - return $ DTySynEqn Nothing - (DConT helper_name `DAppT` ltype `DAppT` rtype) - result - - catch_all_case :: Options -> Name -> Name -> DTySynEqn - catch_all_case opts helper_name returned_val_name = - DTySynEqn Nothing - (DConT helper_name - `DAppT` DSigT DWildCardT kind - `DAppT` DSigT DWildCardT kind) - (DConT $ defunctionalizedName0 opts returned_val_name) - - tyAll :: Options -> [DType] -> DType -- "all" at the type level - tyAll opts = go - where - go [] = DConT $ defunctionalizedName0 opts trueName - go [one] = one - go (h:t) = foldType (DConT $ promotedTopLevelValueName opts andName) - [h, (go 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,195 +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.Syntax -import Data.Singletons.TH.Options - -type LetExpansions = OMap Name DType -- from **term-level** name - --- environment during promotion -data PrEnv = - PrEnv { pr_options :: Options - , pr_lambda_bound :: OMap Name Name - , pr_let_bound :: LetExpansions - , pr_forall_bound :: OSet Name -- See Note [Explicitly binding kind variables] - , pr_local_decls :: [Dec] - } - -emptyPrEnv :: PrEnv -emptyPrEnv = PrEnv { pr_options = defaultOptions - , 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 - -instance OptionsMonad PrM where - getOptions = asks pr_options - --- 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 - opts <- getOptions - lets <- asks pr_let_bound - case OMap.lookup n lets of - Just ty -> return ty - Nothing -> return $ DConT $ defunctionalizedName0 opts 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 :: OptionsMonad q => [Dec] -> PrM a -> q (a, [DDec]) -promoteM locals (PrM rdr) = do - opts <- getOptions - other_locals <- localDeclarations - let wr = runReaderT rdr (emptyPrEnv { pr_options = opts - , pr_local_decls = other_locals ++ locals }) - q = runWriterT wr - runQ q - -promoteM_ :: OptionsMonad q => [Dec] -> PrM () -> q [DDec] -promoteM_ locals thing = do - ((), decs) <- promoteM locals thing - return decs - --- promoteM specialized to [DDec] -promoteMDecs :: OptionsMonad 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 and data -constructors, 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 :: a) - 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 :: 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 :: a) - sF = sG - where - sG :: forall a (y :: a). Sing a -> Sing (G a :: 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 :: a) - sF = sG - where - sG :: forall (y :: a). Sing a -> Sing (G a :: 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,120 +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, promoteType_NC - , promoteTypeArg_NC, promoteUnraveled - ) where - -import Language.Haskell.TH.Desugar -import Data.Singletons.Names -import Data.Singletons.Util -import Language.Haskell.TH - --- Promote a DType to the kind level. --- --- NB: 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 ty = do - checkVanillaDType ty - promoteType_NC ty - --- Promote a DType to the kind level. This is suffixed with "_NC" because --- we do not invoke checkVanillaDType here. --- See [Vanilla-type validity checking during promotion]. -promoteType_NC :: MonadFail m => DType -> m DKind -promoteType_NC = go [] - where - go :: MonadFail m => [DTypeArg] -> DType -> m DKind - go [] (DForallT fvf tvbs ty) = do - ty' <- go [] ty - pure $ DForallT fvf tvbs ty' - -- 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 [] (DConstrainedT _cxt ty) = go [] ty - 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 - --- | Promote a DTypeArg to the kind level. This is suffixed with "_NC" because --- we do not invoke checkVanillaDType here. --- See [Vanilla-type validity checking during promotion]. -promoteTypeArg_NC :: MonadFail m => DTypeArg -> m DTypeArg -promoteTypeArg_NC (DTANormal t) = DTANormal <$> promoteType_NC t -promoteTypeArg_NC ta@(DTyArg _) = pure ta -- Kinds are already promoted - --- | Promote a DType to the kind level, splitting it into its type variable --- binders, argument types, and result type in the process. -promoteUnraveled :: MonadFail m - => DType -> m ([DTyVarBndr], [DKind], DKind) -promoteUnraveled ty = do - (tvbs, _, arg_tys, res_ty) <- unravelVanillaDType ty - arg_kis <- mapM promoteType_NC arg_tys - res_ki <- promoteType_NC res_ty - return (tvbs, arg_kis, res_ki) - -{- -Note [Vanilla-type validity checking during promotion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We only support promoting (and singling) vanilla types, where a vanilla -function type is a type that: - -1. Only uses a @forall@ at the top level, if used at all. That is to say, it - does not contain any nested or higher-rank @forall@s. - -2. Only uses a context (e.g., @c => ...@) at the top level, if used at all, - and only after the top-level @forall@ if one is present. That is to say, - it does not contain any nested or higher-rank contexts. - -3. Contains no visible dependent quantification. - -The checkVanillaDType function checks if a type is vanilla. Note that it is -crucial to call checkVanillaDType on the /entire/ type. For instance, it would -be incorrect to call unravelVanillaDType and then check each argument type -individually, since that loses information about which @forall@s/constraints -are higher-rank. - -We make an effort to avoiding calling checkVanillaDType on the same type twice, -since checkVanillaDType must traverse the entire type. (It would not be -incorrect to do so, just wasteful.) For this certain, certain functions are -suffixed with "_NC" (short for "no checking") to indicate that they do not -invoke checkVanillaDType. These functions are used on types that have already -been validity-checked. --} 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,17 +1,23 @@ +{-# 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 StandaloneKindSignatures #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} +#if __GLASGOW_HASKELL__ >= 810 +{-# LANGUAGE StandaloneKindSignatures #-} +#endif +#endif + ----------------------------------------------------------------------------- -- | -- Module : Data.Singletons.ShowSing @@ -21,30 +27,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 +#if __GLASGOW_HASKELL__ >= 806 import Data.Kind -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 +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 @@ -83,23 +89,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 @@ -112,9 +117,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. +#if __GLASGOW_HASKELL__ >= 810 type ShowSing :: Type -> Constraint -class (forall (z :: k). ShowSing' z) => ShowSing k -instance (forall (z :: k). ShowSing' z) => ShowSing k +#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 @@ -128,76 +135,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. +-- 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 -class Show (Sing z) => ShowSing' z -instance Show (Sing z) => ShowSing' z +#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] @@ -259,7 +285,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 @@ -275,42 +301,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,19 +1,30 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} -{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE QuantifiedConstraints #-} +#else +{-# LANGUAGE TypeInType #-} +#endif + +#if __GLASGOW_HASKELL__ >= 810 +{-# LANGUAGE StandaloneKindSignatures #-} +#else +{-# LANGUAGE ImpredicativeTypes #-} -- See Note [Impredicative Σ?] +#endif + ----------------------------------------------------------------------------- -- | -- Module : Data.Singletons.Sigma @@ -38,45 +49,57 @@ , mapSigma, zipSigma , currySigma, uncurrySigma +#if __GLASGOW_HASKELL__ >= 806 -- * Internal utilities -- $internalutilities , ShowApply, ShowSingApply , ShowApply', ShowSingApply' +#endif ) where import Data.Kind -import Data.Singletons.Internal +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 -data Sigma s t where +#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 following definition alone: + + type Σ = Sigma + +will not typecheck without the use of ImpredicativeTypes. There isn't a +fundamental reason that this should be the case, and the only reason that GHC +currently requires this is due to GHC#13408. Thankfully, giving Σ a standalone +kind signature works around GHC#13408, so we only have to enable +ImpredicativeTypes on pre-8.10 versions of GHC. +-} + -- | The singleton type for 'Sigma'. +#if __GLASGOW_HASKELL__ >= 810 type SSigma :: Sigma s t -> Type -data SSigma sig where +#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 instance forall s t (fst :: s) (a :: Sing fst) (b :: t @@ fst). (SingI fst, SingI b) @@ -84,7 +107,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. @@ -92,8 +117,10 @@ fstSigma (a :&: _) = fromSing a -- | Project the first element out of a dependent pair. +#if __GLASGOW_HASKELL__ >= 810 type FstSigma :: Sigma s t -> s -type family FstSigma sig where +#endif +type family FstSigma (sig :: Sigma s t) :: s where FstSigma ((_ :: Sing fst) ':&: _) = fst -- | Project the second element out of a dependent pair. @@ -103,8 +130,10 @@ 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 -type family SndSigma sig where +#endif +type family SndSigma (sig :: Sigma s t) :: t @@ FstSigma sig where SndSigma (_ ':&: b) = b -- | Project the first element out of a dependent pair using @@ -161,6 +190,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 ------------------------------------------------------------ @@ -170,20 +213,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,1178 +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 #-} - -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.TH.Options -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 Control.Monad.Trans.Class -import Data.List (unzip6, zipWith4) -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 singled definitions for each of the provided type-level --- declaration 'Name's. For example, the singletons package itself uses --- --- > $(genSingletons [''Bool, ''Maybe, ''Either, ''[]]) --- --- to generate singletons for Prelude types. -genSingletons :: OptionsMonad q => [Name] -> q [Dec] -genSingletons names = do - opts <- getOptions - -- See Note [Disable genQuotedDecs in genPromotions and genSingletons] - -- in D.S.Promote - withOptions opts{genQuotedDecs = False} $ do - checkForRep names - ddecs <- concatMapM (singInfo <=< dsInfo <=< reifyWithLocals) names - return $ decsToTH ddecs - --- | Make promoted and singled versions of all declarations given, retaining --- the original declarations. See the --- @@ --- for further explanation. -singletons :: OptionsMonad q => q [Dec] -> q [Dec] -singletons qdecs = do - opts <- getOptions - withOptions opts{genQuotedDecs = True} $ singletons' $ lift qdecs - --- | Make promoted and singled 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 :: OptionsMonad q => q [Dec] -> q [Dec] -singletonsOnly qdecs = do - opts <- getOptions - withOptions opts{genQuotedDecs = False} $ singletons' $ lift qdecs - --- The workhorse for 'singletons' and 'singletonsOnly'. The difference between --- the two functions is whether 'genQuotedDecs' is set to 'True' or 'False'. -singletons' :: OptionsMonad q => q [Dec] -> q [Dec] -singletons' qdecs = do - opts <- getOptions - decs <- qdecs - ddecs <- withLocalDeclarations decs $ dsDecs decs - singDecs <- singTopLevelDecs decs ddecs - let origDecs | genQuotedDecs opts = decs - | otherwise = [] - return $ origDecs ++ decsToTH singDecs - --- | Create instances of 'SEq' and type-level @(==)@ for each type in the list -singEqInstances :: OptionsMonad q => [Name] -> q [Dec] -singEqInstances = concatMapM singEqInstance - --- | Create instance of 'SEq' and type-level @(==)@ for the given type -singEqInstance :: OptionsMonad 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 :: OptionsMonad 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 :: OptionsMonad q => Name -> q [Dec] -singEqInstanceOnly name = singEqualityInstance sEqClassDesc name - --- | Create instances of 'SDecide', 'TestEquality', and 'TestCoercion' for each --- type in the list. -singDecideInstances :: OptionsMonad q => [Name] -> q [Dec] -singDecideInstances = concatMapM singDecideInstance - --- | Create instance of 'SDecide', 'TestEquality', and 'TestCoercion' for the --- given type. -singDecideInstance :: OptionsMonad q => Name -> q [Dec] -singDecideInstance name = singEqualityInstance sDecideClassDesc name - --- generalized function for creating equality instances -singEqualityInstance :: OptionsMonad 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 :: OptionsMonad q => [Name] -> q [Dec] -singOrdInstances = concatMapM singOrdInstance - --- | Create instance of 'SOrd' for the given type -singOrdInstance :: OptionsMonad q => Name -> q [Dec] -singOrdInstance = singInstance mkOrdInstance "Ord" - --- | Create instances of 'SBounded' for the given types -singBoundedInstances :: OptionsMonad q => [Name] -> q [Dec] -singBoundedInstances = concatMapM singBoundedInstance - --- | Create instance of 'SBounded' for the given type -singBoundedInstance :: OptionsMonad q => Name -> q [Dec] -singBoundedInstance = singInstance mkBoundedInstance "Bounded" - --- | Create instances of 'SEnum' for the given types -singEnumInstances :: OptionsMonad q => [Name] -> q [Dec] -singEnumInstances = concatMapM singEnumInstance - --- | Create instance of 'SEnum' for the given type -singEnumInstance :: OptionsMonad q => Name -> q [Dec] -singEnumInstance = singInstance mkEnumInstance "Enum" - --- | Create instance of 'SShow' for the given type --- --- (Not to be confused with 'showShowInstance'.) -singShowInstance :: OptionsMonad q => Name -> q [Dec] -singShowInstance = singInstance (mkShowInstance ForPromotion) "Show" - --- | Create instances of 'SShow' for the given types --- --- (Not to be confused with 'showSingInstances'.) -singShowInstances :: OptionsMonad q => [Name] -> q [Dec] -singShowInstances = concatMapM singShowInstance - --- | Create instance of 'Show' for the given singleton type --- --- (Not to be confused with 'singShowInstance'.) -showSingInstance :: OptionsMonad 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 :: OptionsMonad 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 = ravelVanillaDType [] [] (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 ForallInvis (map DPlainTV as) $ - DConstrainedT (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 :: OptionsMonad 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 Map.empty raw_inst - decs' <- singDecsM [] $ (:[]) <$> singInstD a_inst - return $ decsToTH (decs ++ decs') - -singInfo :: OptionsMonad 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 :: OptionsMonad 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 - defunTopLevelTypeDecls ty_syns c_tyfams o_tyfams - recSelLetDecls <- promoteDataDecs datas - (_, letDecEnv) <- promoteLetDecs Nothing $ recSelLetDecls ++ letDecls - classes' <- mapM promoteClassDec classes - let meth_sigs = foldMap (lde_types . cd_lde) classes - cls_tvbs_map = Map.fromList $ map (\cd -> (cd_name cd, cd_tvbs cd)) classes - insts' <- mapM (promoteInstanceDec meth_sigs cls_tvbs_map) insts - mapM_ promoteDerivedEqDec derivedEqDecs - return (letDecEnv, classes', insts') - - singDecsM locals $ do - dataLetBinds <- concatMapM buildDataLets datas - methLetBinds <- concatMapM buildMethLets classes - let letBinds = dataLetBinds ++ methLetBinds - (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 :: OptionsMonad q => DataDecl -> q [(Name, DExp)] -buildDataLets (DataDecl _name _tvbs cons) = do - opts <- getOptions - pure $ concatMap (con_num_args opts) cons - where - con_num_args :: Options -> DCon -> [(Name, DExp)] - con_num_args opts (DCon _tvbs _cxt name fields _rty) = - (name, wrapSingFun (length (tysOfConFields fields)) - (DConT $ defunctionalizedName0 opts name) - (DConE $ singledDataConName opts name)) - : rec_selectors opts fields - - rec_selectors :: Options -> DConFields -> [(Name, DExp)] - rec_selectors _ (DNormalC {}) = [] - rec_selectors opts (DRecC fields) = - let names = map fstOf3 fields in - [ (name, wrapSingFun 1 (DConT $ defunctionalizedName0 opts name) - (DVarE $ singledValueName opts name)) - | name <- names ] - --- see comment at top of file -buildMethLets :: OptionsMonad q => UClassDecl -> q [(Name, DExp)] -buildMethLets (ClassDecl { cd_lde = LetDecEnv { lde_types = meth_sigs } }) = do - opts <- getOptions - pure $ map (mk_bind opts) (OMap.assocs meth_sigs) - where - mk_bind opts (meth_name, meth_ty) = - ( meth_name - , wrapSingFun (countArgs meth_ty) (DConT $ defunctionalizedName0 opts meth_name) - (DVarE $ singledValueName opts 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 - opts <- getOptions - mb_cls_sak <- dsReifyType cls_name - let sing_cls_name = singledClassName opts cls_name - mb_sing_cls_sak = fmap (DKiSigD sing_cls_name) mb_cls_sak - cls_infix_decls <- singReifiedInfixDecls $ cls_name:meth_names - (sing_sigs, _, tyvar_names, cxts, res_kis, singIDefunss) - <- unzip6 <$> zipWithM (singTySig no_meth_defns meth_sigs meth_bound_kvs) - meth_names - (map (DConT . defunctionalizedName0 opts) meth_names) - emitDecs $ maybeToList mb_sing_cls_sak ++ cls_infix_decls ++ concat singIDefunss - let default_sigs = catMaybes $ - zipWith4 (mk_default_sig opts) 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' <- mapMaybeM (uncurry singInfixDecl) $ OMap.assocs fixities - cls_cxt' <- mapM singPred cls_cxt - return $ DClassD cls_cxt' - sing_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 opts meth_name (DSigD s_name sty) bound_kvs (Just res_ki) = - DDefaultSigD s_name <$> add_constraints opts meth_name sty bound_kvs res_ki - mk_default_sig _ _ _ _ _ = error "Internal error: a singled signature isn't a signature." - - add_constraints opts meth_name sty (_, bound_kvs) res_ki = do -- Maybe monad - (tvbs, cxt, args, res) <- unravelVanillaDType sty - prom_dflt <- OMap.lookup meth_name promoted_defaults - - -- 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. - let tvs = map tvbToType $ - filter (\tvb -> extractTvbName tvb `Set.member` bound_kv_set) tvbs - prom_meth = DConT $ defunctionalizedName0 opts meth_name - default_pred = foldType (DConT equalityName) - -- NB: Need the res_ki here to prevent ambiguous - -- kinds in result-inferred default methods. - -- See #175 - [ foldApply prom_meth tvs `DSigT` res_ki - , foldApply prom_dflt tvs ] - return $ ravelVanillaDType tvbs (default_pred : cxt) args res - where - bound_kv_set = Set.fromList bound_kvs - -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 - opts <- getOptions - let s_inst_name = singledClassName opts inst_name - 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 - sing_meth :: Name -> ALetDecRHS -> SgM [DDec] - sing_meth name rhs = do - opts <- getOptions - mb_s_info <- dsReify (singledValueName opts 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 (DConT $ defunctionalizedName0 opts 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 (DConstrainedT _cls_pred s_ty)) _) -> do - (sing_tvbs, ctxt, _args, res_ty) <- unravelVanillaDType s_ty - let subst = mk_subst cls_tvbs - 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 - (DConstrainedT _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 (singledValueName opts 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' <- mapMaybeM (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 = do - opts <- getOptions - let sName = singledValueName opts name - 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") - -- If there are no arguments, use `Sing @_` instead of `Sing`. - -- See Note [Disable kind generalization for local functions if possible] - let sing_w_wildcard | n == 0 = singFamily `DAppKindT` DWildCardT - | otherwise = singFamily - return ( ravelVanillaDType - (map DPlainTV arg_names) - [] - (map (\nm -> singFamily `DAppT` DVarT nm) arg_names) - (sing_w_wildcard `DAppT` - (foldl apply prom_ty (map DVarT arg_names))) - , arg_names ) - -{- -Note [Disable kind generalization for local functions if possible] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this example (from #296): - - f :: forall a. MyProxy a -> MyProxy a - f MyProxy = - let x = let z :: MyProxy a - z = MyProxy in z - in x - -A naïve attempt at singling `f` is as follows: - - type LetZ :: MyProxy a - type family LetZ where - LetZ = 'MyProxy - - type family LetX where - LetX = LetZ - - type F :: forall a. MyProxy a -> MyProxy a - type family F x where - F 'MyProxy = LetX - - sF :: forall a (t :: MyProxy a). Sing t -> Sing (F t :: MyProxy a) - sF SMyProxy = - let sX :: Sing LetX - sX = let sZ :: Sing (LetZ :: MyProxy a) - sZ = SMyProxy in sZ - in sX - -This will not typecheck, however. The is because the return kind of -`LetX` (in `let sX :: Sing LetX`) will get generalized by virtue of `sX` -having a type signature. It's as if one had written this: - - sF :: forall a (t :: MyProxy a). Sing t -> Sing (F t :: MyProxy a) - sF SMyProxy = - let sX :: forall a1. Sing (LetX :: MyProxy a1) - sX = ... - -This is too general, since `sX` will only typecheck if the return kind of -`LetX` is `MyProxy a`, not `MyProxy a1`. In order to avoid this problem, -we need to avoid kind generalization when kind-checking the type of `sX`. -To accomplish this, we borrow a trick from -Note [The id hack; or, how singletons learned to stop worrying and avoid kind generalization] -and use TypeApplications plus a wildcard type. That is, we generate this code -for `sF`: - - sF :: forall a (t :: MyProxy a). Sing t -> Sing (F t :: MyProxy a) - sF SMyProxy = - let sX :: Sing @_ LetX - sX = ... - -The presence of the wildcard type disables kind generalization, which allows -GHC's kind inference to deduce that the return kind of `LetX` should be `a`. -Now `sF` typechecks, and since we only use wildcards within visible kind -applications, we don't even have to force users to enable -PartialTypeSignatures. Hooray! - -Question: where should we put wildcard types when singling? One possible answer -is: put a wildcard in any type signature that gets generated when singling a -function that lacks a type signature. Unfortunately, this is a step too far. -This will break singling the `foldr` function: - - foldr :: (a -> b -> b) -> b -> [a] -> b - foldr k z = go - where - go [] = z - go (y:ys) = y `k` go ys - -If the type of `sGo` is given a wildcard, then it will fail to typecheck. This -is because `sGo` is polymorphically recursive, so disabling kind generalization -forces GHC to infer `sGo`'s type. Attempting to infer a polymorphically -recursive type, unsurprisingly, leads to failure. - -To avoid this sort of situation, where adopt a simple metric: if a function -lacks a type signature, only put @_ in its singled type signature if it has -zero arguments. This allows `sX` to typecheck without breaking things like -`sGo`. This metric is a bit conservative, however, since it means that this -small tweak to `x` still would not typecheck: - - f :: forall a. MyProxy a -> MyProxy a - f MyProxy = - let x () = let z :: MyProxy a - z = MyProxy in z - in x () - -We need not let perfect be the enemy of good, however. It is extremely -common for local definitions to have zero arguments, so it makes good sense -to optimize for that special case. In fact, this special treatment is the only -reason that `foo8` from the `T183` test case singles successfully, since -the as-patterns in `foo8` desugar to code very similar to the `f` example -above. --} - -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 = do - opts <- getOptions - bindContext (Map.findWithDefault [] name cxts) $ - case ld_rhs of - AValue prom num_arrows exp -> - DValD (DVarP (singledValueName opts 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 (singledValueName opts 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 - opts <- getOptions - tyname <- case Map.lookup name var_proms of - Nothing -> - fail "Internal error: unknown variable when singling pattern" - Just tyname -> return tyname - pure $ DVarP (singledValueName opts name) - `DSigP` (singFamily `DAppT` DVarT tyname) - go (ADConP name pats) = do - opts <- getOptions - DConP (singledDataConName opts 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 = do opts <- getOptions - DAppE (DVarE (singledValueName opts 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 - opts <- getOptions - let sNames = map (singledValueName opts) 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) - -{- -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,347 +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.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 Data.Singletons.TH.Options -import Control.Monad - --- 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 - opts <- getOptions - let tvbNames = map extractTvbName tvbs - ctor_names = map extractName ctors - rec_sel_names = concatMap extractRecSelNames ctors - k <- promoteType (foldType (DConT name) (map DVarT tvbNames)) - mb_data_sak <- dsReifyType name - ctors' <- mapM (singCtor name) ctors - fixityDecs <- singReifiedInfixDecls $ ctor_names ++ rec_sel_names - -- 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 = singledDataTypeName opts name - -- e.g. type instance Sing @Nat = SNat - singSynInst = - DTySynInstD $ DTySynEqn Nothing - (DConT singFamilyName `DAppKindT` k) - (DConT singDataName) - - mk_data_dec tvbs' mb_kind = - DDataD Data [] singDataName tvbs' mb_kind ctors' [] - - data_decs <- - case mb_data_sak of - -- No standalone kind signature. Try to figure out the order of kind - -- variables on a best-effort basis. - Nothing -> do - ki <- promoteType $ foldType (DConT name) (map dTyVarBndrToDType tvbs) - let sing_tvbs = toposortTyVarsOf [k] - kinded_sing_ty = DForallT ForallInvis sing_tvbs $ - DArrowT `DAppT` ki `DAppT` DConT typeKindName - pure [mk_data_dec [] (Just kinded_sing_ty)] - - -- A standalone kind signature is provided, so use that to determine the - -- order of kind variables. - Just data_sak -> do - let (args, _) = unravelDType data_sak - vis_args = filterDVisFunArgs args - invis_tvbs = filterInvisTvbArgs args - vis_tvbs = zipWith replaceTvbKind vis_args tvbs - ki <- promoteType $ foldType (DConT name) (map dTyVarBndrToDType vis_tvbs) - z <- qNewName "z" - let sing_data_sak = DForallT ForallInvis (invis_tvbs ++ vis_tvbs) $ - DArrowT `DAppT` ki `DAppT` DConT typeKindName - pure [ DKiSigD singDataName sing_data_sak - , mk_data_dec [DPlainTV z] Nothing - ] - - return $ data_decs ++ - singSynInst : - [singKindInst | genSingKindInsts opts] ++ - fixityDecs - 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 - opts <- getOptions - let (cname, numArgs) = extractNameArgs c - cname' <- mkConName cname - varNames <- replicateM numArgs (qNewName "b") - return $ DClause [DConP (singledDataConName opts 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 - opts <- getOptions - 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 (singledDataConName opts 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) [] - --- Single 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 con_tvbs cxt name fields rty) - | not (null cxt) - = fail "Singling of constrained constructors not yet supported" - | otherwise - = do - opts <- getOptions - let types = tysOfConFields fields - sName = singledDataConName opts name - sCon = DConE sName - pCon = DConT name - checkVanillaDType $ ravelVanillaDType con_tvbs [] types rty - indexNames <- mapM (const $ qNewName "n") types - kinds <- mapM promoteType_NC types - rty' <- promoteType_NC rty - let indices = map DVarT indexNames - kindedIndices = zipWith DSigT indices kinds - kvbs = singTypeKVBs con_tvbs kinds [] rty' mempty - all_tvbs = kvbs ++ zipWith DKindedTV indexNames 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 - args = map ((noBang,) . DAppT singFamily) indices - conFields = case fields of - DNormalC dInfix _ -> DNormalC dInfix args - DRecC _ -> DNormalC False args - -- Don't bother looking at record selectors, as they are - -- handled separately in singTopLevelDecs. - -- See Note [singletons and record selectors] - return $ DCon all_tvbs [] sName conFields - (DConT (singledDataTypeName opts dataName) `DAppT` - (foldType pCon indices `DSigT` rty')) - -- Make sure to include an explicit `rty'` kind annotation. - -- See Note [Preserve the order of type variables during singling], - -- wrinkle 3, in D.S.Single.Type. - -{- -Note [singletons and record selectors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Record selectors are annoying to deal with in singletons for various reasons: - -1. There is no record syntax at the type level, so promoting code that involves - records in some way is not straightforward. -2. One can define record selectors for singled data types, but they're rife - with peril. Some pitfalls include: - - * Singling record updates often produces code that does not typecheck. For - example, this works: - - let i = Identity True in i { runIdentity = False } - - But this does /not/ work: - - let si = SIdentity STrue in si { sRunIdentity = SFalse } - - error: - • Record update for insufficiently polymorphic field: - sRunIdentity :: Sing n - • In the expression: si {sRunIdentity = SFalse} - In the expression: - let si = SIdentity STrue in si {sRunIdentity = SFalse} - - Ugh. See GHC#16501. - - * Singling a data type with multiple constructors that share a record - selector name will /also/ not typecheck. While this works: - - data X = X1 {y :: Bool} | X2 {y :: Bool} - - This does not: - - data SX :: X -> Type where - SX1 :: { sY :: Sing n } -> SX ('X1 n) - SY1 :: { sY :: Sing n } -> SX ('X2 n) - - error: - • Constructors SX1 and SX2 have a common field ‘sY’, - but have different result types - • In the data type declaration for ‘SX’ - - Double ugh. See GHC#8673/GHC#12159. - - * Even if a data type only has a single constructor with record selectors, - singling it can induce headaches. One might be tempted to single this type: - - newtype Unit = MkUnit { runUnit :: () } - - With this code: - - data SUnit :: Unit -> Type where - SMkUnit :: { sRunUnit :: Sing u } -> SUnit (MkUnit u) - - Somewhat surprisingly, the type of sRunUnit: - - sRunUnit :: Sing (MkUnit u) -> Sing u - - Is not general enough to handle common uses of record selectors. For - example, if you try to single this function: - - f :: Unit -> () - f = runUnit - - Then the resulting code: - - sF :: Sing (x :: Unit) -> Sing (F x :: ()) - sF = sRunUnit - - Will not typecheck. Note that sRunUnit expects an argument of type - `Sing (MkUnit u)`, but there is no way to know a priori that the `x` in - `Sing (x :: Unit)` is `MkUnit u` without pattern-matching on SMkUnit. - -Hopefully I have convinced you that handling records in singletons is a bit of -a nightmare. Thankfully, there is a simple trick to avoid most of the pitfalls -above: just desugar code (using th-desugar) to avoid records! -In more concrete terms, we do the following: - -* A record constructions desugars to a normal constructor application. For example: - - MkT{a = x, b = y} - - ==> - - MkT x y - - Something similar occurs for record syntax in patterns. - -* A record update desugars to a case expression. For example: - - t{a = x} - - ==> - - case t of MkT _ y => MkT x y - -We can't easily desugar away all uses of records, however. After all, records -can be used as ordinary functions as well. We leave such uses of records alone -when desugaring and accommodate them during promotion and singling by generating -"manual" record selectors. As a running example, consider the earlier Unit example: - - newtype Unit = MkUnit { runUnit :: () } - -When singling Unit, we do not give SMkUnit a record selector: - - data SUnit :: Unit -> Type where - SMkUnit :: Sing u -> SUnit (MkUnit u) - -Instead, we generate a top-level function that behaves equivalently to runUnit. -This function then gets promoted and singled (in D.S.Promote.promoteDecs and -D.S.Single.singTopLevelDecs): - - type family RunUnit (x :: Unit) :: () where - RunUnit (MkUnit x) = x - - sRunUnit :: Sing (x :: Unit) -> Sing (RunUnit x :: ()) - sRunUnit (SMkUnit sx) = sx - -Now promoting/singling uses of runUnit as an ordinary function work as expected -since the types of RunUnit/sRunUnit are sufficiently general. This technique also -scales up to data types with multiple constructors sharing a record selector name. -For instance, in the earlier X example: - - data X = X1 {y :: Bool} | X2 {y :: Bool} - -We would promote/single `y` like so: - - type family Y (x :: X) :: Bool where - Y (X1 y) = y - Y (X2 y) = y - - sY :: Sing (x :: X) -> Sing (Y x :: Bool) - sY (SX1 sy) = sy - sY (SX2 sy) = sy - -Manual record selectors cannot be used in record constructions or updates, but -for most use cases this won't be an issue, since singletons makes an effort to -desugar away fancy uses of records anyway. The only time this would bite is if -you wanted to use record syntax in hand-written singletons code. --} 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,199 +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 Control.Monad -import Data.Foldable -import Data.Singletons.Names -import Data.Singletons.Promote.Defun -import Data.Singletons.Single.Monad -import Data.Singletons.Single.Type -import Data.Singletons.TH.Options -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 opts <- getOptions - sty_ctxt <- mapM singPred ty_ctxt - names <- replicateM (length mb_ty_args) $ qNewName "d" - let tvbs = zipWith inferMaybeKindTV names mb_ty_args - (_, insts) = go opts 0 sty_ctxt [] tvbs - pure insts - where - num_ty_args :: Int - num_ty_args = length mb_ty_args - - -- The inner loop. @go n ctxt arg_tvbs res_tvbs@ returns @(m_result, insts)@. - -- Using one particular example: - -- - -- @ - -- instance (SingI a, SingI b, SEq c, SEq d) => - -- SingI (ExampleSym2 (x :: a) (y :: b) :: c ~> d ~> Type) where ... - -- @ - -- - -- We have: - -- - -- * @n@ is 2. This is incremented in each iteration of `go`. - -- - -- * @ctxt@ is (SEq c, SEq d). The (SingI a, SingI b) part of the instance - -- context is added separately. - -- - -- * @arg_tvbs@ is [(x :: a), (y :: b)]. - -- - -- * @res_tvbs@ is [(z :: c), (w :: d)]. The kinds of these type variable - -- binders appear in the result kind. - -- - -- * @m_result@ is `Just (c ~> d ~> Type)`. @m_result@ is returned so - -- that earlier defunctionalization symbols can build on the result - -- kinds of later symbols. For instance, ExampleSym1 would get the - -- result kind `b ~> c ~> d ~> Type` by prepending `b` to ExampleSym2's - -- result kind `c ~> d ~> Type`. - -- - -- * @insts@ are all of the instance declarations corresponding to - -- ExampleSym2 and later defunctionalization symbols. This is the main - -- payload of the function. - -- - -- This function is quadratic because it appends a variable at the end of - -- the @arg_tvbs@ list at each iteration. In practice, this is unlikely - -- to be a performance bottleneck since the number of arguments rarely - -- gets to be that large. - go :: Options -> Int -> DCxt -> [DTyVarBndr] -> [DTyVarBndr] - -> (Maybe DKind, [DDec]) - go _ _ _ _ [] = (mb_ty_res, []) - go opts sym_num sty_ctxt arg_tvbs (res_tvb:res_tvbs) = - (mb_new_res, new_inst:insts) - where - mb_res :: Maybe DKind - insts :: [DDec] - (mb_res, insts) = go opts (sym_num + 1) sty_ctxt (arg_tvbs ++ [res_tvb]) res_tvbs - - mb_new_res :: Maybe DKind - mb_new_res = mk_inst_kind res_tvb mb_res - - 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 arg_tvbs) - - singI_ctxt :: DCxt - singI_ctxt = map (DAppT (DConT singIName) . tvbToType) arg_tvbs - - mk_inst_ty :: DType -> DType - mk_inst_ty inst_head - = case mb_new_res of - Just inst_kind -> inst_head `DSigT` inst_kind - Nothing -> inst_head - - arg_tvb_tys :: [DType] - arg_tvb_tys = map dTyVarBndrToDType arg_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] - mk_inst_kind :: DTyVarBndr -> Maybe DKind -> Maybe DKind - mk_inst_kind tvb' = buildTyFunArrow_maybe (extractTvbKind tvb') - - new_inst :: DDec - new_inst = 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 (defunctionalizedName opts n sym_num)) - arg_tvb_tys - - sing_exp :: DExp - sing_exp = case ns of - DataName -> DConE $ singledDataConName opts n - _ -> DVarE $ singledValueName opts 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,149 +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.TH.Options -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 :: OptionsMonad 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 :: OptionsMonad 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 - opts <- getOptions - constraints <- inferConstraintsDef mb_ctxt (DConT sDecideClassName) k ctors - pure $ DInstanceD Nothing Nothing - constraints - (DAppT (DConT tiClassName) - (DConT (singledDataTypeName opts 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 :: OptionsMonad q => (DCon, DCon) -> q DClause -mkEqMethClause (c1, c2) - | lname == rname = do - opts <- getOptions - 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 opts (zipWith (\l r -> foldExp (DVarE sEqMethName) [l, r]) - lvars rvars)) - | otherwise = do - opts <- getOptions - return $ DClause - [DConP lname (replicate lNumArgs DWildP), - DConP rname (replicate rNumArgs DWildP)] - (DConE $ singledDataConName opts falseName) - where allExp :: Options -> [DExp] -> DExp - allExp opts = go - where - go [] = DConE $ singledDataConName opts trueName - go [one] = one - go (h:t) = DAppE (DAppE (DVarE $ singledValueName opts andName) h) (go 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,171 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -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.TH.Options -import Data.Singletons.Util -import Language.Haskell.TH.Desugar - --- Single a fixity declaration. -singInfixDecl :: forall q. OptionsMonad q => Name -> Fixity -> q (Maybe DLetDec) -singInfixDecl name fixity = do - opts <- getOptions - mb_ns <- reifyNameSpace name - case mb_ns of - -- If we can't find the Name for some odd reason, - -- fall back to singValName - Nothing -> finish $ singledValueName opts name - Just VarName -> finish $ singledValueName opts name - Just DataName -> finish $ singledDataConName opts name - Just TcClsName -> do - mb_info <- dsReify name - case mb_info of - Just (DTyConI DClassD{} _) - -> finish $ singledClassName opts name - _ -> pure Nothing - -- Don't produce anything for other type constructors (type synonyms, - -- type families, data types, etc.). - -- See [singletons and fixity declarations], wrinkle 1. - where - finish :: Name -> q (Maybe DLetDec) - finish = pure . Just . DInfixD fixity - --- Try producing singled fixity declarations for Names by reifying them --- /without/ consulting quoted declarations. If reification fails, recover and --- return the empty list. --- See [singletons and fixity declarations], wrinkle 2. -singReifiedInfixDecls :: forall q. OptionsMonad q => [Name] -> q [DDec] -singReifiedInfixDecls = mapMaybeM trySingFixityDeclaration - where - trySingFixityDeclaration :: Name -> q (Maybe DDec) - trySingFixityDeclaration name = - qRecover (return Nothing) $ do - mFixity <- qReifyFixity name - case mFixity of - Nothing -> pure Nothing - Just fixity -> fmap (fmap DLetDec) $ singInfixDecl name fixity - -{- -Note [singletons and fixity declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Promoting and singling fixity declarations is surprisingly tricky to get right. -This Note serves as a place to document the insights learned after getting this -wrong at various points. - -As a general rule, when promoting something with a fixity declaration like this -one: - - infixl 5 `foo` - -singletons will produce promoted and singled versions of them: - - infixl 5 `Foo` - infixl 5 `sFoo` - -singletons will also produce fixity declarations for its defunctionalization -symbols (see Note [Fixity declarations for defunctionalization symbols] in -D.S.Promote.Defun): - - infixl 5 `FooSym0` - infixl 5 `FooSym1` - ... - ------ --- Wrinkle 1: When not to promote/single fixity declarations ------ - -Rules are meant to be broken, and the general rule above is no exception. There -are certain cases where singletons does *not* produce promoted or singled -versions of fixity declarations: - -* During promotion, fixity declarations for the following sorts of names will - not receive promoted counterparts: - - - Data types - - Type synonyms - - Type families - - Data constructors - - Infix values - - We exclude the first four because the promoted versions of these names are - the same as the originals, so generating an extra fixity declaration for them - would run the risk of having duplicates, which GHC would reject with an error. - - We exclude infix value because while their promoted versions are different, - they share the same name base. In concrete terms, this: - - $(promote [d| - infixl 4 ### - (###) :: a -> a -> a - |]) - - Is promoted to the following: - - type family (###) (x :: a) (y :: a) :: a where ... - - So giving the type-level (###) a fixity declaration would clash with the - existing one for the value-level (###). - - There *is* a scenario where we should generate a fixity declaration for the - type-level (###), however. Imagine the above example used the `promoteOnly` - function instead of `promote`. Then the type-level (###) would lack a fixity - declaration altogether because the original fixity declaration was discarded - by `promoteOnly`! The same problem would arise if one had to choose between - the `singletons` and `singletonsOnly` functions. - - The difference between `promote` and `promoteOnly` (as well as `singletons` - and `singletonsOnly`) is whether the `genQuotedDecs` option is set to `True` - or `False`, respectively. Therefore, if `genQuotedDecs` is set to `False` - when promoting the fixity declaration for an infix value, we opt to generate - a fixity declaration (with the same name base) so that the type-level version - of that value gets one. - -* During singling, the following things will not have their fixity declarations - singled: - - - Type synonyms or type families. This is because singletons does not - generate singled versions of them in the first place (they only receive - defunctionalization symbols). - - - Data types. This is because the singled version of a data type T is - always of the form: - - data ST :: forall a_1 ... a_n. T a_1 ... a_n -> Type where ... - - Regardless of how many arguments T has, ST will have exactly one argument. - This makes is rather pointless to generate a fixity declaration for it. - ------ --- Wrinkle 2: Making sure fixity declarations are promoted/singled properly ------ - -There are two situations where singletons must promote/single fixity -declarations: - -1. When quoting code, i.e., with `promote` or `singletons`. -2. When reifying code, i.e., with `genPromotions` or `genSingletons`. - -In the case of (1), singletons stores the quoted fixity declarations in the -lde_infix field of LetDecEnv. Therefore, it suffices to call -promoteInfixDecl/singleInfixDecl when processing LetDecEnvs. - -In the case of (2), there is no LetDecEnv to use, so we must instead reify -the fixity declarations and promote/single those. See D.S.Single.Data.singDataD -(which singles data constructors) for a place that does this—we will use -singDataD as a running example for the rest of this section. - -One complication is that code paths like singDataD are invoked in both (1) and -(2). This runs the risk that singletons will generate duplicate infix -declarations for data constructors in situation (1), as it will try to single -their fixity declarations once when processing them in LetDecEnvs and again -when reifying them in singDataD. - -To avoid this pitfall, when reifying declarations in singDataD we take care -*not* to consult any quoted declarations when reifying (i.e., we do not use -reifyWithLocals for functions like it). Therefore, it we are in situation (1), -then the reification in singDataD will fail (and recover gracefully), so it -will not produce any singled fixity declarations. Therefore, the only singled -fixity declarations will be produced by processing LetDecEnvs. --} 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,195 +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.TH.Options -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_options :: Options - , 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_options = defaultOptions - , 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, Quasi ) - -instance DsMonad SgM where - localDeclarations = asks sg_local_decls - -instance OptionsMonad SgM where - getOptions = asks sg_options - -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 name = do - opts <- getOptions - lookup_var_con (singledValueName opts) - (DVarE . singledValueName opts) name - -lookupConE :: Name -> SgM DExp -lookupConE name = do - opts <- getOptions - lookup_var_con (singledDataConName opts) - (DConE . singledDataConName opts) name - -lookup_var_con :: (Name -> Name) -> (Name -> DExp) -> Name -> SgM DExp -lookup_var_con mk_sing_name mk_exp name = do - opts <- getOptions - 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 (DConT $ defunctionalizedName0 opts 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 :: OptionsMonad q => [Dec] -> SgM a -> q (a, [DDec]) -singM locals (SgM rdr) = do - opts <- getOptions - other_locals <- localDeclarations - let wr = runReaderT rdr (emptySgEnv { sg_options = opts - , sg_local_decls = other_locals ++ locals }) - q = runWriterT wr - runQ q - -singDecsM :: OptionsMonad 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,300 +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 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.TH.Options -import Data.Singletons.Util -import Control.Monad -import Data.Foldable -import Data.Function -import Data.List (deleteFirstsBy) - -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 - (orig_tvbs, cxt, args, res) <- unravelVanillaDType ty - let num_args = length args - cxt' <- mapM singPred_NC cxt - arg_names <- replicateM num_args (qNewName "t") - prom_args <- mapM promoteType_NC args - prom_res <- promoteType_NC res - let args' = map (\n -> singFamily `DAppT` (DVarT n)) arg_names - res' = singFamily `DAppT` (foldl apply prom (map DVarT arg_names) `DSigT` prom_res) - -- Make sure to include an explicit `prom_res` kind annotation. - -- See Note [Preserve the order of type variables during singling], - -- wrinkle 3. - kvbs = singTypeKVBs orig_tvbs prom_args cxt' prom_res bound_kvs - all_tvbs = kvbs ++ zipWith DKindedTV arg_names prom_args - ty' = ravelVanillaDType all_tvbs cxt' args' res' - return (ty', num_args, arg_names, cxt, prom_args, prom_res) - --- Compute the kind variable binders to use in the singled version of a type --- signature. This has two main call sites: singType and D.S.Single.Data.singCtor. --- --- This implements the advice documented in --- Note [Preserve the order of type variables during singling], wrinkle 1. -singTypeKVBs :: - [DTyVarBndr] -- ^ The bound type variables from the original type signature. - -> [DType] -- ^ The argument types of the signature (promoted). - -> DCxt -- ^ The context of the signature (singled). - -> DType -- ^ The result type of the signature (promoted). - -> OSet Name -- ^ The type variables previously bound in the current scope. - -> [DTyVarBndr] -- ^ The kind variables for the singled type signature. -singTypeKVBs orig_tvbs prom_args sing_ctxt prom_res bound_tvbs - | null orig_tvbs - -- There are no explicitly `forall`ed type variable binders, so we must - -- infer them ourselves. - = deleteFirstsBy - ((==) `on` extractTvbName) - (toposortTyVarsOf $ prom_args ++ sing_ctxt ++ [prom_res]) - (map DPlainTV $ toList bound_tvbs) - -- Make sure to subtract out the bound variables currently in scope, - -- lest we accidentally shadow them in this type signature. - -- See Note [Explicitly binding kind variables] in D.S.Promote.Monad. - | otherwise - -- There is an explicit `forall`, so this case is easy. - = orig_tvbs - --- Single a DPred, checking that it is a vanilla type in the process. --- See [Vanilla-type validity checking during promotion] --- in Data.Singletons.Promote.Type. -singPred :: DPred -> SgM DPred -singPred p = do - checkVanillaDType p - singPred_NC p - --- Single a DPred. Does not check if the argument is a vanilla type. --- See [Vanilla-type validity checking during promotion] --- in Data.Singletons.Promote.Type. -singPred_NC :: DPred -> SgM DPred -singPred_NC = singPredRec [] - --- The workhorse for singPred_NC. -singPredRec :: [DTypeArg] -> DPred -> SgM DPred -singPredRec _cxt (DForallT {}) = - fail "Singling of quantified constraints not yet supported" -singPredRec _cxt (DConstrainedT {}) = - 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 - opts <- getOptions - kis <- mapM promoteTypeArg_NC ctx - let sName = singledClassName opts 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" - -{- -Note [Preserve the order of type variables during singling] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -singletons does its best to preseve the order in which users write type -variables in type signatures for functions and data constructors. They are -"preserved" in the sense that if one writes `foo @T1 @T2`, one should be -able to write out `sFoo @T1 @T2` by hand and have the same order of visible -type applications still work. Accomplishing this is surprisingly nontrivial, -so this Note documents the various wrinkles one must iron out to get this -working. - ------ --- Wrinkle 1: Dealing with the presence (and absence) of `forall` ------ - -If we single a function that has an explicit `forall`, such as this example: - - const2 :: forall b a. a -> b -> a - const2 x _ = x - -Then our job is easy, as the exact order of type variables has already been -spelled out in advance. We single this to: - - sConst2 :: forall b a (x :: a) (y :: b). Sing x -> Sing y -> Sing (Const2 x y :: a) - sConst2 = ... - -What happens if there is no explicit `forall`, as in this example? - - data V a - - absurd :: V a -> b - absurd v = case v of {} - -This time, the order of type variables vis-à-vis TypeApplications is determined -by their left-to-right order of appearance in the type signature. It's tempting -to think that since there is no explicit `forall` in the original type -signature, we could get away without an explicit `forall` in the singled type -signature. That is, one could write: - - sAbsurd :: Sing (v :: V a) -> Sing (Absurd :: b) - -This would have the right type variable order, but unfortunately, this approach -does not play well with singletons' style of code generation. Consider the code -that would be generated for the body of sAbsurd: - - sAbsurd :: Sing (v :: V a) -> Sing (Absurd :: b) - sAbsurd (sV :: Sing v) = id @(Case v v :: b) (case sV of {}) - -Note the use of the type `Case v v :: b` in the right-hand side of sAbsurd. -However, because `b` was not bound by a top-level `forall`, it won't be in -scope here, resulting in an error! - -(Why do we generate the code `id @(Case v v :: b)` in the first place? See -Note [The id hack; or, how singletons learned to stop worrying and avoid kind generalization] -in D.S.Single.) - -The simplest approach is to just always generate singled type signatures with -explicit `forall`s. In the event that the original type signature lacks an -explicit `forall`, we inferr the correct type variable ordering ourselves and -synthesize a `forall` with that order. The `singTypeKVBs` function implements -this logic. - ------ --- Wrinkle 2: The TH reification swamp ------ - -There is another issue with type signatures that lack explicit `forall`s, one -which the current design of Template Haskell does not make simple to fix. -If we single code that is wrapped in TH quotes, such as in the following example: - - $(singletons [d| - data Proxy (a :: k) where - MkProxy :: Proxy a - |]) - -Then our job is made much easier when singling MkProxy, since we know that the -only type variable that must be quantified is `a`, as that is the only one -specified in the type signature. - -However, this is not the only possible way to single MkProxy. One can -alternatively use $(genSingletons [''Proxy]), which uses TH reification to -infer the type of MkProxy. There is perilous, however, because this is how -TH reifies MkProxy: - - ForallC [KindedTV k StarT,KindedTV a (VarT k)] [] - (GadtC [MkProxy] [] (AppT (ConT Proxy) (VarT a))) - -In terms of actual Haskell code, that's: - - MkProxy :: forall k (a :: k). Proxy a - -This is subtly different than before, as `k` is now specified. Contrast this -with `MkProxy :: Proxy a`, where `k` is invisible. In other words, if you -single MkProxy using genSingletons, then `Proxy @True` will typecheck but -`SMkProxy @True` will /not/ typecheck—you'd have to use `SMkProxy @_ @True` -instead. Urk! - -At present, Template Haskell does not have a way to distinguish specified from -inferred type variables—see GHC #17159—and it is unclear how one could work -around this issue withouf first fixing #17159 upstream. Thankfully, it is -only likely to bite in situations where the original type signature uses -inferred variables, so the damage is somewhat minimal. - ------ --- Wrinkle 3: Where to put explicit kind annotations ------ - -Type variable binders are only part of the story—we must also determine what -the body of the type signature will be singled to. As a general rule, if the -original type signature is of the form: - - f :: forall a_1 ... a_m. (C_1, ..., C_n) - => T_1 -> ... -> T_p -> R - -Then the singled type signature will be: - - sF :: forall a_1 ... a_m (x_1 :: PT_1) ... (x_p :: PT_p). (SC_1, ..., SC_n) - => Sing x1 -> ... -> Sing x_p -> SRes (F x1 ... x_p :: PR) - -Where: - -* x_i is a fresh type variable of kind PT_i. -* PT_i is the promoted version of the type T_i, and PR is the promoted version - of the type R. -* SC_i is the singled version of the constraint SC_i. -* SRes is either `Sing` if dealing with a function, or a singled data type if - dealing with a data constructor. For instance, SRes is `SBool` in - `STrue :: SBool (True :: Bool)`. - -One aspect of this worth pointing out is the explicit `:: PR` kind annotation -in the result type `Sing (F x1 ... x_p :: PR)`. As it turns out, this kind -annotation is mandatory, as omitting can result in singled type signatures -with the wrong semantics. For instance, consider the `Nothing` data -constructor: - - Nothing :: forall a. Maybe a - -Consider what would happen if it were singled to this type: - - SNothing :: forall a. SMaybe Nothing - -This is not what we want at all, since the `a` has no connection to the -`Nothing` in the result type. It's as if we had written this: - - SNothing :: forall {t} a. SMaybe (Nothing :: Maybe t) - -If we instead generate `forall a. SMaybe (Nothing :: Maybe a)`, then this issue -is handily avoided. - -You might wonder if it would be cleaner to use visible kind applications -instead: - - SNothing :: forall a. SMaybe (Nothing @a) - -This does work for many cases, but there are also some corner cases where this -approach fails. Recall the `MkProxy` example from Wrinkle 2 above: - - data Proxy (a :: k) where - MkProxy :: Proxy a - $(genSingletons [''Proxy]) - -Due to the design of Template Haskell (discussed in Wrinkle 2), `MkProxy` will -be reified with the type of `forall k (a :: k). Proxy a`. This means that -if we used visible kind applications in the result type, we would end up with -this: - - SMkProxy :: forall k (a :: k). SProxy (MkProxy @k @a) - -This will not kind-check because MkProxy only accepts /one/ visible kind argument, -whereas this supplies it with two. To avoid this issue, we instead use the type -`forall k (a :: k). SProxy (MkProxy :: Proxy a)`. Granted, this type is /still/ -technically wrong due to the fact that it explicitly quantifies `k`, but at the -very least it typechecks. If GHC #17159 were fixed, we could revisit this -design choice. - -Finally, note that we need only write `Sing x_1 -> ... -> Sing x_p`, and not -`Sing (x_1 :: PT_1) -> ... Sing (x_p :: PT_p)`. This is simply because we -always use explicit `forall`s in singled type signatures, and therefore always -explicitly bind `(x_1 :: PT_1) ... (x_p :: PT_p)`, which fully determine the -kinds of `x_1 ... x_p`. It wouldn't be wrong to add extra kind annotations to -`Sing x_1 -> ... -> Sing x_p`, just redundant. --} 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,21 +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, StandaloneKindSignatures #-} - -module Data.Singletons.SuppressUnusedWarnings where - -import Data.Kind - --- | 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. -type SuppressUnusedWarnings :: k -> Constraint -class SuppressUnusedWarnings t 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,244 +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 - , cd_atfs :: [OpenTypeFamilyDecl] - -- Associated type families. Only recorded for - -- defunctionalization purposes. - -- See Note [Partitioning, type synonyms, and type families] - -- in D.S.Partition. - } - -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,195 +0,0 @@ -{-# LANGUAGE ExplicitNamespaces #-} - ------------------------------------------------------------------------------ --- | --- 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 (.@#@$$$$), - NilSym0, (:@#@$), (:@#@$$), (:@#@$$$), - - 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.TH.Options -import Data.Singletons.TypeLits -import Data.Singletons.SuppressUnusedWarnings -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 :: OptionsMonad 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 - opts <- getOptions - dinfo <- dsReify tyName - case dinfo of - Just (DTyConI (DDataD _ _ _ _ _ ctors _) _) -> - let ctor_stuff = map (first (singledDataConName opts) . 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/TH/Options.hs b/src/Data/Singletons/TH/Options.hs deleted file mode 100644 --- a/src/Data/Singletons/TH/Options.hs +++ /dev/null @@ -1,270 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TemplateHaskell #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TH.Options --- Copyright : (C) 2019 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- This module defines 'Options' that control finer details of how the Template --- Haskell machinery works, as well as an @mtl@-like 'OptionsMonad' class --- and an 'OptionsM' monad transformer. --- ----------------------------------------------------------------------------- - -module Data.Singletons.TH.Options - ( -- * Options - Options, defaultOptions - -- ** Options record selectors - , genQuotedDecs - , genSingKindInsts - , promotedClassName - , promotedValueName - , singledDataTypeName - , singledClassName - , singledDataConName - , singledValueName - , defunctionalizedName - -- ** Derived functions over Options - , promotedTopLevelValueName - , promotedLetBoundValueName - , defunctionalizedName0 - - -- * OptionsMonad - , OptionsMonad(..), OptionsM, withOptions - ) where - -import Control.Applicative -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Reader (ReaderT(..), ask) -import Control.Monad.RWS (RWST) -import Control.Monad.State (StateT) -import Control.Monad.Trans.Class (MonadTrans(..)) -import Control.Monad.Writer (WriterT) -import Data.Singletons.Names ( consName, listName, nilName - , mk_name_tc, mkTupleDataName, mkTupleTypeName - , sconsName, sListName, snilName - , splitUnderscores - ) -import Data.Singletons.Util -import Language.Haskell.TH.Desugar -import Language.Haskell.TH.Syntax hiding (Lift(..)) - --- | Options that control the finer details of how @singletons@' Template --- Haskell machinery works. -data Options = Options - { genQuotedDecs :: Bool - -- ^ If 'True', then quoted declarations will be generated alongside their - -- promoted and singled counterparts. If 'False', then quoted - -- declarations will be discarded. - , genSingKindInsts :: Bool - -- ^ If 'True', then 'SingKind' instances will be generated. If 'False', - -- they will be omitted entirely. This can be useful in scenarios where - -- TH-generated 'SingKind' instances do not typecheck (for instance, - -- when generating singletons for GADTs). - , promotedClassName :: Name -> Name - -- ^ Given the name of the original, unrefined class, produces the name of - -- the promoted equivalent of the class. - , promotedValueName :: Name -> Maybe Uniq -> Name - -- ^ Given the name of the original, unrefined value, produces the name of - -- the promoted equivalent of the value. This is used for both top-level - -- and @let@-bound names, and the difference is encoded in the - -- @'Maybe' 'Uniq'@ argument. If promoting a top-level name, the argument - -- is 'Nothing'. If promoting a @let@-bound name, the argument is - -- @Just uniq@, where @uniq@ is a globally unique number that can be used - -- to distinguish the name from other local definitions of the same name - -- (e.g., if two functions both use @let x = ... in x@). - , singledDataTypeName :: Name -> Name - -- ^ Given the name of the original, unrefined data type, produces the name - -- of the corresponding singleton type. - , singledClassName :: Name -> Name - -- ^ Given the name of the original, unrefined class, produces the name of - -- the singled equivalent of the class. - , singledDataConName :: Name -> Name - -- ^ Given the name of the original, unrefined data constructor, produces - -- the name of the corresponding singleton data constructor. - , singledValueName :: Name -> Name - -- ^ Given the name of the original, unrefined value, produces the name of - -- the singled equivalent of the value. - , defunctionalizedName :: Name -> Int -> Name - -- ^ Given the original name and the number of parameters it is applied to - -- (the 'Int' argument), produces a type-level function name that can be - -- partially applied when given the same number of parameters. - -- - -- Note that defunctionalization works over both term-level names - -- (producing symbols for the promoted name) and type-level names - -- (producing symbols directly for the name itself). As a result, this - -- callback is used for names in both the term and type namespaces. - } - --- | Sensible default 'Options'. --- --- 'genQuotedDecs' defaults to 'True'. --- That is, quoted declarations are generated alongside their promoted and --- singled counterparts. --- --- 'genSingKindInsts' defaults to 'True'. --- That is, 'SingKind' instances are generated. --- --- The default behaviors for 'promotedClassName', 'promotedValueNamePrefix', --- 'singledDataTypeName', 'singledClassName', 'singledDataConName', --- 'singledValueName', and 'defunctionalizedName' are described in the --- \"On names\" section of the @singletons@ --- @@. -defaultOptions :: Options -defaultOptions = Options - { genQuotedDecs = True - , genSingKindInsts = True - , promotedClassName = promoteClassName - , promotedValueName = promoteValNameLhs - , singledDataTypeName = singTyConName - , singledClassName = singClassName - , singledDataConName = singDataConName - , singledValueName = singValName - , defunctionalizedName = promoteTySym - } - --- | Given the name of the original, unrefined, top-level value, produces the --- name of the promoted equivalent of the value. -promotedTopLevelValueName :: Options -> Name -> Name -promotedTopLevelValueName opts name = promotedValueName opts name Nothing - --- | Given the name of the original, unrefined, @let@-bound value and its --- globally unique number, produces the name of the promoted equivalent of the --- value. -promotedLetBoundValueName :: Options -> Name -> Uniq -> Name -promotedLetBoundValueName opts name = promotedValueName opts name . Just - --- | Given the original name of a function (term- or type-level), produces a --- type-level function name that can be partially applied even without being --- given any arguments (i.e., @0@ arguments). -defunctionalizedName0 :: Options -> Name -> Name -defunctionalizedName0 opts name = defunctionalizedName opts name 0 - --- | Class that describes monads that contain 'Options'. -class DsMonad m => OptionsMonad m where - getOptions :: m Options - -instance OptionsMonad Q where - getOptions = pure defaultOptions - -instance OptionsMonad m => OptionsMonad (DsM m) where - getOptions = lift getOptions - -instance (OptionsMonad q, Monoid m) => OptionsMonad (QWithAux m q) where - getOptions = lift getOptions - -instance OptionsMonad m => OptionsMonad (ReaderT r m) where - getOptions = lift getOptions - -instance OptionsMonad m => OptionsMonad (StateT s m) where - getOptions = lift getOptions - -instance (OptionsMonad m, Monoid w) => OptionsMonad (WriterT w m) where - getOptions = lift getOptions - -instance (OptionsMonad m, Monoid w) => OptionsMonad (RWST r w s m) where - getOptions = lift getOptions - --- | A convenient implementation of the 'OptionsMonad' class. Use by calling --- 'withOptions'. -newtype OptionsM m a = OptionsM (ReaderT Options m a) - deriving ( Functor, Applicative, Monad, MonadTrans - , Quasi, MonadFail, MonadIO, DsMonad ) - --- | Turn any 'DsMonad' into an 'OptionsMonad'. -instance DsMonad m => OptionsMonad (OptionsM m) where - getOptions = OptionsM ask - --- | Declare the 'Options' that a TH computation should use. -withOptions :: Options -> OptionsM m a -> m a -withOptions opts (OptionsM x) = runReaderT x opts - --- Used when a value name appears in a pattern context. --- Works only for proper variables (lower-case names). --- --- If the Maybe Uniq argument is Nothing, then the name is top-level (and --- thus globally unique on its own). --- If the Maybe Uniq argument is `Just uniq`, then the name is let-bound and --- should use `uniq` to make the promoted name globally unique. -promoteValNameLhs :: Name -> Maybe Uniq -> Name -promoteValNameLhs n mb_let_uniq - -- 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 - where - pres = maybe noPrefix (uniquePrefixes "Let" "<<<") mb_let_uniq - (alpha, _) = pres - --- 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 <|> - 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" "#" - --- 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 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,179 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# 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'. -type ErrorMessage' :: Type -> Type -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 :: Type -type ErrorMessage = ErrorMessage' Text.Text - --- | A type-level `ErrorMessage'` which uses 'Symbol' as its text kind. -type PErrorMessage :: Type -type PErrorMessage = ErrorMessage' Symbol - -type SErrorMessage :: PErrorMessage -> Type -data SErrorMessage em 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 ConvertPErrorMessage :: PErrorMessage -> TL.ErrorMessage -type family ConvertPErrorMessage a 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 TypeError :: PErrorMessage -> a -type family TypeError a 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, StandaloneKindSignatures #-} - ------------------------------------------------------------------------------ --- | --- 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,231 +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, StandaloneKindSignatures #-} -{-# 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.Kind -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 --------------------------------------------- ----------------------------------------------------------------------- - -type SNat :: Nat -> Type -data SNat n = 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) - -type SSymbol :: Symbol -> Type -data SSymbol n = 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 Error :: k0 -> k -type family Error str 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 ErrorWithoutStackTrace :: k0 -> k -type family ErrorWithoutStackTrace str 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 Undefined :: k -type family Undefined 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,98 +0,0 @@ -{-# LANGUAGE RankNTypes, TypeFamilies, FlexibleInstances, - GADTs, UndecidableInstances, ScopedTypeVariables, - MagicHash, TypeOperators, PolyKinds, TypeApplications, - StandaloneKindSignatures #-} -{-# 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@). -type SomeTypeRepTYPE :: RuntimeRep -> Type -data SomeTypeRepTYPE r 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,625 +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, ScopedTypeVariables, - FlexibleContexts #-} - -module Data.Singletons.Util where - -import Prelude hiding ( exp, foldl, concat, mapM, any, pred ) -import Language.Haskell.TH ( pprint ) -import Language.Haskell.TH.Syntax hiding ( lift ) -import Language.Haskell.TH.Desugar -import Data.Char -import Control.Monad hiding ( mapM ) -import Control.Monad.Except hiding ( mapM ) -import Control.Monad.Reader hiding ( mapM ) -import Control.Monad.Writer 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 - -recSelsOfConFields :: DConFields -> [Name] -recSelsOfConFields DNormalC{} = [] -recSelsOfConFields (DRecC vstys) = map (\(n,_,_) -> n) vstys - --- Extract a data constructor's name and the number of arguments it accepts. -extractNameArgs :: DCon -> (Name, Int) -extractNameArgs (DCon _ _ n fields _) = (n, length (tysOfConFields fields)) - --- Extract a data constructor's name. -extractName :: DCon -> Name -extractName (DCon _ _ n _ _) = n - --- Extract the names of a data constructor's record selectors. -extractRecSelNames :: DCon -> [Name] -extractRecSelNames (DCon _ _ _ fields _) = recSelsOfConFields fields - --- | 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 - --- If a type variable binder lacks an explicit kind, pick a default kind of --- Type. Otherwise, leave the binder alone. -defaultTvbToTypeKind :: DTyVarBndr -> DTyVarBndr -defaultTvbToTypeKind (DPlainTV tvname) = DKindedTV tvname $ DConT typeKindName -defaultTvbToTypeKind tvb = tvb - --- If @Nothing@, return @Type@. If @Just k@, return @k@. -defaultMaybeToTypeKind :: Maybe DKind -> DKind -defaultMaybeToTypeKind (Just k) = k -defaultMaybeToTypeKind Nothing = DConT typeKindName - -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 - -maybeKindToResultSig :: Maybe DKind -> DFamilyResultSig -maybeKindToResultSig = maybe DNoSig DKindSig - -maybeSigT :: DType -> Maybe DKind -> DType -maybeSigT ty Nothing = ty -maybeSigT ty (Just ki) = ty `DSigT` ki - --- Reconstruct a vanilla function type from its individual type variable --- binders, constraints, argument types, and result type. (See --- Note [Vanilla-type validity checking during promotion] in --- Data.Singletons.Promote.Type for what "vanilla" means.) -ravelVanillaDType :: [DTyVarBndr] -> DCxt -> [DType] -> DType -> DType -ravelVanillaDType tvbs ctxt args res = - ifNonEmpty tvbs (DForallT ForallInvis) $ - ifNonEmpty ctxt DConstrainedT $ - go args - where - ifNonEmpty :: [a] -> ([a] -> b -> b) -> b -> b - ifNonEmpty [] _ z = z - ifNonEmpty l f z = f l z - - go :: [DType] -> DType - go [] = res - go (h:t) = DAppT (DAppT DArrowT h) (go t) - --- Decompose a vanilla function type into its type variables, its context, its --- argument types, and its result type. (See --- Note [Vanilla-type validity checking during promotion] in --- Data.Singletons.Promote.Type for what "vanilla" means.) --- If a non-vanilla construct is encountered while decomposing the function --- type, an error is thrown monadically. --- --- This should be contrasted with the 'unravelDType' function from --- @th-desugar@, which supports the full gamut of function types. @singletons@ --- only supports a subset of these types, which is why this function is used --- to decompose them instead. -unravelVanillaDType :: forall m. MonadFail m - => DType -> m ([DTyVarBndr], DCxt, [DType], DType) -unravelVanillaDType ty = - case unravelVanillaDType_either ty of - Left err -> fail err - Right payload -> pure payload - --- Ensures that a 'DType' is a vanilla type. (See --- Note [Vanilla-type validity checking during promotion] in --- Data.Singletons.Promote.Type for what "vanilla" means.) --- --- The only monadic thing that this function can do is 'fail', which it does --- if a non-vanilla construct is encountered. -checkVanillaDType :: forall m. MonadFail m => DType -> m () -checkVanillaDType ty = - case unravelVanillaDType_either ty of - Left err -> fail err - Right _ -> pure () - --- The workhorse that powers unravelVanillaDType and checkVanillaDType. --- Returns @Right payload@ upon success, and @Left error_msg@ upon failure. -unravelVanillaDType_either :: - DType -> Either String ([DTyVarBndr], DCxt, [DType], DType) -unravelVanillaDType_either ty = - runIdentity $ flip runReaderT True $ runExceptT $ runUnravelM $ go_ty ty - where - go_ty :: DType -> UnravelM ([DTyVarBndr], DCxt, [DType], DType) - go_ty typ = do - let (args1, res) = unravelDType typ - (args2, tvbs) <- take_tvbs args1 - (args3, ctxt) <- take_ctxt args2 - anons <- take_anons args3 - pure (tvbs, ctxt, anons, res) - - -- Process a type in a higher-order position (e.g., the @forall a. a -> a@ in - -- @(forall a. a -> a) -> b -> b@). This is only done to check for the - -- presence of higher-rank foralls or constraints, which are not permitted - -- in vanilla types. - go_higher_order_ty :: DType -> UnravelM () - go_higher_order_ty typ = () <$ local (const False) (go_ty typ) - - take_tvbs :: DFunArgs -> UnravelM (DFunArgs, [DTyVarBndr]) - take_tvbs (DFAForalls ForallInvis tvbs args) = do - rank_1 <- ask - unless rank_1 $ fail_forall "higher-rank" - _ <- traverse_ (traverse_ go_higher_order_ty . extractTvbKind) tvbs - (args', tvbs') <- take_tvbs args - pure (args', tvbs ++ tvbs') - take_tvbs (DFAForalls ForallVis _ _) = fail_vdq - take_tvbs args = pure (args, []) - - take_ctxt :: DFunArgs -> UnravelM (DFunArgs, DCxt) - take_ctxt (DFACxt ctxt args) = do - rank_1 <- ask - unless rank_1 $ fail_ctxt "higher-rank" - traverse_ go_higher_order_ty ctxt - (args', ctxt') <- take_ctxt args - pure (args', ctxt ++ ctxt') - take_ctxt (DFAForalls fvf _ _) = - case fvf of - ForallInvis -> fail_forall "nested" - ForallVis -> fail_vdq - take_ctxt args = pure (args, []) - - take_anons :: DFunArgs -> UnravelM [DType] - take_anons (DFAAnon anon args) = do - go_higher_order_ty anon - anons <- take_anons args - pure (anon:anons) - take_anons (DFAForalls fvf _ _) = - case fvf of - ForallInvis -> fail_forall "nested" - ForallVis -> fail_vdq - take_anons (DFACxt _ _) = fail_ctxt "nested" - take_anons DFANil = pure [] - - failWith :: MonadError String m => String -> m a - failWith thing = throwError $ unlines - [ "`singletons` does not support " ++ thing - , "In the type: " ++ pprint (sweeten ty) - ] - - fail_forall :: MonadError String m => String -> m a - fail_forall sort = failWith $ sort ++ " `forall`s" - - fail_vdq :: MonadError String m => m a - fail_vdq = failWith "visible dependent quantification" - - fail_ctxt :: MonadError String m => String -> m a - fail_ctxt sort = failWith $ sort ++ " contexts" - --- The monad that powers the internals of unravelVanillaDType_either. --- --- * ExceptT String: records the error message upon failure. --- --- * Reader Bool: True if we are in a rank-1 position in a type, False otherwise -newtype UnravelM a = UnravelM { runUnravelM :: ExceptT String (Reader Bool) a } - deriving (Functor, Applicative, Monad, MonadError String, MonadReader Bool) - --- count the number of arguments in a type -countArgs :: DType -> Int -countArgs ty = length $ filterDVisFunArgs args - where (args, _) = unravelDType ty - --- Collect the invisible type variable binders from a sequence of DFunArgs. -filterInvisTvbArgs :: DFunArgs -> [DTyVarBndr] -filterInvisTvbArgs DFANil = [] -filterInvisTvbArgs (DFACxt _ args) = filterInvisTvbArgs args -filterInvisTvbArgs (DFAAnon _ args) = filterInvisTvbArgs args -filterInvisTvbArgs (DFAForalls fvf tvbs' args) = - let res = filterInvisTvbArgs args in - case fvf of - ForallVis -> res - ForallInvis -> tvbs' ++ res - --- Infer the kind of a DTyVarBndr by using information from a DVisFunArg. -replaceTvbKind :: DVisFunArg -> DTyVarBndr -> DTyVarBndr -replaceTvbKind (DVisFADep tvb) _ = tvb -replaceTvbKind (DVisFAAnon k) tvb = DKindedTV (extractTvbName tvb) k - --- changes all TyVars not to be NameU's. Workaround for GHC#11812/#17537 -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 - - fix_tvb (DPlainTV n) = DPlainTV (noExactName n) - fix_tvb (DKindedTV n k) = DKindedTV (noExactName n) k - - fix_ty (DVarT n) = DVarT (noExactName n) - fix_ty ty = ty - - fix_inj_ann (InjectivityAnn lhs rhs) - = InjectivityAnn (noExactName lhs) (map noExactName rhs) - --- changes a Name not to be a NameU. Workaround for GHC#11812/#17537 -noExactName :: Name -> Name -noExactName (Name (OccName occ) (NameU unique)) = mkName (occ ++ show unique) -noExactName n = n - -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 fvf tvbs inner_ty) - = DForallT fvf tvbs' inner_ty' - where - (subst', tvbs') = mapAccumL subst_tvb subst tvbs - inner_ty' = substType subst' inner_ty -substType subst (DConstrainedT cxt inner_ty) = - DConstrainedT (map (substType subst) cxt) (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)) - -dropTvbKind :: DTyVarBndr -> DTyVarBndr -dropTvbKind tvb@(DPlainTV {}) = tvb -dropTvbKind (DKindedTV n _) = DPlainTV n - --- 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] - --- 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, Quasi, DsMonad ) - --- 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 - --- like GHC's -mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b] -mapMaybeM _ [] = return [] -mapMaybeM f (x:xs) = do - y <- f x - ys <- mapMaybeM f xs - return $ case y of - Nothing -> ys - Just z -> z : ys - --- 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,75 +14,71 @@ FlexibleInstances, FlexibleContexts, UndecidableInstances, RankNTypes, TypeOperators, MultiParamTypeClasses, FunctionalDependencies, ScopedTypeVariables, - LambdaCase, TemplateHaskell, EmptyCase, - TypeApplications, EmptyCase, StandaloneKindSignatures - #-} + LambdaCase, EmptyCase, + TypeApplications, EmptyCase, CPP #-} +#if __GLASGOW_HASKELL__ < 806 +{-# LANGUAGE TypeInType #-} +#endif + +#if __GLASGOW_HASKELL__ >= 810 +{-# LANGUAGE StandaloneKindSignatures #-} +#endif module ByHand where import Data.Kind -import Prelude hiding (Bool, False, True, Maybe, Just, Nothing, Either, Left, Right, map, zipWith, - (&&), (||), (+), (-)) -import Unsafe.Coerce - import Data.Type.Equality hiding (type (==), apply) import Data.Proxy - import Data.Singletons import Data.Singletons.Decide +import Prelude hiding ((+), (-), map, zipWith) +import Unsafe.Coerce ----------------------------------- -- Original ADTs ------------------ ----------------------------------- +#if __GLASGOW_HASKELL__ >= 810 type Nat :: Type +#endif data Nat where Zero :: Nat Succ :: Nat -> Nat deriving Eq -type Bool :: Type -data Bool where - False :: Bool - True :: Bool - -type Maybe :: Type -> Type -data Maybe a 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 -data List a where +#endif +data List :: Type -> Type where Nil :: List a Cons :: a -> List a -> List a deriving Eq -type Either :: Type -> Type -> Type -data Either a b 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 %/= +#if __GLASGOW_HASKELL__ >= 810 type If :: Bool -> a -> a -> a -type family If cond tru fls where +#endif +type family If (cond :: Bool) (tru :: a) (fls :: a) :: a where If True tru fls = tru If False tru fls = fls @@ -96,18 +92,24 @@ -- Nat +#if __GLASGOW_HASKELL__ >= 810 type SNat :: Nat -> Type -data SNat n where +#endif +data SNat :: Nat -> Type where SZero :: SNat Zero SSucc :: SNat n -> SNat (Succ n) type instance Sing = SNat +#if __GLASGOW_HASKELL__ >= 810 type SuccSym0 :: Nat ~> Nat -data SuccSym0 tf +#endif +data SuccSym0 :: Nat ~> Nat type instance Apply SuccSym0 x = Succ x +#if __GLASGOW_HASKELL__ >= 810 type EqualsNat :: Nat -> Nat -> Bool -type family EqualsNat a b where +#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 @@ -142,18 +144,24 @@ -- Bool +#if __GLASGOW_HASKELL__ >= 810 type SBool :: Bool -> Type -data SBool b where +#endif +data SBool :: Bool -> Type where SFalse :: SBool False STrue :: SBool True type instance Sing = SBool +{- (&&) :: Bool -> Bool -> Bool False && _ = False True && x = x +-} +#if __GLASGOW_HASKELL__ >= 810 type (&&) :: Bool -> Bool -> Bool -type family a && b where +#endif +type family (a :: Bool) && (b :: Bool) :: Bool where False && _ = False True && x = x @@ -176,14 +184,18 @@ -- Maybe -type SMaybe :: Maybe k -> Type -data SMaybe m where +#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__ >= 810 type EqualsMaybe :: Maybe k -> Maybe k -> Bool -type family EqualsMaybe a b where +#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 @@ -220,28 +232,36 @@ -- List -type SList :: List k -> Type -data SList l where +#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__ >= 810 type NilSym0 :: List a -type NilSym0 = Nil +#endif +type family NilSym0 :: List a where + NilSym0 = Nil -type ConsSym0 :: a ~> List a ~> List a -data ConsSym0 tf +#if __GLASGOW_HASKELL__ >= 810 +type ConsSym0 :: forall a. a ~> List a ~> List a +type ConsSym1 :: forall a. a -> List a ~> List a +type ConsSym2 :: forall a. a -> List a -> List a +#endif +data ConsSym0 :: forall a. a ~> List a ~> List a +data ConsSym1 :: forall a. a -> List a ~> List a +type family ConsSym2 (x :: a) (y :: List a) :: List a where + ConsSym2 x y = Cons x y type instance Apply ConsSym0 a = ConsSym1 a - -type ConsSym1 :: a -> List a ~> List a -data ConsSym1 a tf -type instance Apply (ConsSym1 a) b = ConsSym2 a b - -type ConsSym2 :: a -> List a -> List a -type ConsSym2 a b = Cons a b +type instance Apply (ConsSym1 a) b = Cons a b +#if __GLASGOW_HASKELL__ >= 810 type EqualsList :: List k -> List k -> Bool -type family EqualsList a b where +#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 @@ -281,8 +301,10 @@ -- Either -type SEither :: Either k1 k2 -> Type -data SEither e where +#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 @@ -316,12 +338,16 @@ -- Composite +#if __GLASGOW_HASKELL__ >= 810 type Composite :: Type -> Type -> Type -data Composite a b where +#endif +data Composite :: Type -> Type -> Type where MkComp :: Either (Maybe a) b -> Composite a b -type SComposite :: Composite k1 k2 -> Type -data SComposite c where +#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 @@ -343,10 +369,16 @@ -- Empty +#if __GLASGOW_HASKELL__ >= 810 type Empty :: Type +#endif data Empty + +#if __GLASGOW_HASKELL__ >= 810 type SEmpty :: Empty -> Type -data SEmpty e +#endif +data SEmpty :: Empty -> Type + type instance Sing = SEmpty instance SingKind Empty where type Demote Empty = Empty @@ -355,16 +387,22 @@ -- Type +#if __GLASGOW_HASKELL__ >= 810 type Vec :: Type -> Nat -> Type -data Vec a n where +#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 -data SRep r where +#endif +data SRep :: Type -> Type where SNat :: SRep Nat SMaybe :: SRep a -> SRep (Maybe a) SVec :: SRep a -> SNat n -> SRep (Vec a n) @@ -411,8 +449,10 @@ (Disproved contra, _) -> Disproved (\Refl -> contra Refl) (_, Disproved contra) -> Disproved (\Refl -> contra Refl) +#if __GLASGOW_HASKELL__ >= 810 type EqualsType :: Type -> Type -> Bool -type family EqualsType a b where +#endif +type family EqualsType (a :: Type) (b :: Type) :: Bool where EqualsType a a = True EqualsType _ _ = False instance PEq Type where @@ -432,14 +472,18 @@ isJust Nothing = False isJust (Just _) = True +#if __GLASGOW_HASKELL__ >= 810 type IsJust :: Maybe k -> Bool -type family IsJust a where +#endif +type family IsJust (a :: Maybe k) :: Bool where IsJust Nothing = False IsJust (Just a) = True -- defunctionalization symbols -type IsJustSym0 :: Maybe a ~> Bool -data IsJustSym0 tf +#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) @@ -450,13 +494,17 @@ pred Zero = Zero pred (Succ n) = n +#if __GLASGOW_HASKELL__ >= 810 type Pred :: Nat -> Nat -type family Pred a where +#endif +type family Pred (a :: Nat) :: Nat where Pred Zero = Zero Pred (Succ n) = n +#if __GLASGOW_HASKELL__ >= 810 type PredSym0 :: Nat ~> Nat -data PredSym0 tf +#endif +data PredSym0 :: Nat ~> Nat type instance Apply PredSym0 a = Pred a sPred :: forall (t :: Nat). Sing t -> Sing (Pred t) @@ -467,18 +515,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 -type family Map f l where +#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 -type MapSym1 :: (a ~> b) -> List a ~> List b -data MapSym1 f tf -type MapSym0 :: (a ~> b) ~> List a ~> List b -data MapSym0 tf -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) @@ -503,28 +555,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 +#if __GLASGOW_HASKELL__ >= 810 type ZipWith :: (a ~> b ~> c) -> List a -> List b -> List c -type family ZipWith k1 k2 k3 where +#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 -type ZipWithSym2 :: (a ~> b ~> c) -> List a -> List b ~> List c -data ZipWithSym2 f xs tf -type ZipWithSym1 :: (a ~> b ~> c) -> List a ~> List b ~> List c -data ZipWithSym1 f tf -type ZipWithSym0 :: (a ~> b ~> c) ~> List a ~> List b ~> List c -data ZipWithSym0 tf -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). @@ -539,21 +595,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 -type family Either_ l r e where +#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 -type Either_Sym2 :: (a ~> c) -> (b ~> c) -> Either a b ~> c -data Either_Sym2 k1 k2 tf -type Either_Sym1 :: (a ~> c) -> (b ~> c) ~> Either a b ~> c -data Either_Sym1 f tf -type Either_Sym0 :: (a ~> c) ~> (b ~> c) ~> Either a b ~> c -data Either_Sym0 tf -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) @@ -592,8 +652,10 @@ eitherToNat (Left x) = x eitherToNat (Right x) = x +#if __GLASGOW_HASKELL__ >= 810 type EitherToNat :: Either Nat Nat -> Nat -type family EitherToNat e where +#endif +type family EitherToNat (e :: Either Nat Nat) :: Nat where EitherToNat (Left x) = x EitherToNat (Right x) = x @@ -605,17 +667,21 @@ liftMaybe _ Nothing = Nothing liftMaybe f (Just a) = Just (f a) +#if __GLASGOW_HASKELL__ >= 810 type LiftMaybe :: (a ~> b) -> Maybe a -> Maybe b -type family LiftMaybe f x where +#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) -type LiftMaybeSym1 :: (a ~> b) -> Maybe a ~> Maybe b -data LiftMaybeSym1 f tf -type LiftMaybeSym0 :: (a ~> b) ~> Maybe a ~> Maybe b -data LiftMaybeSym0 tf -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)) -> @@ -627,18 +693,22 @@ Zero + x = x (Succ x) + y = Succ (x + y) +#if __GLASGOW_HASKELL__ >= 810 type (+) :: Nat -> Nat -> Nat -type family (+) m n where +#endif +type family (+) (m :: Nat) (n :: Nat) :: Nat where Zero + x = x (Succ x) + y = Succ (x + y) -- defunctionalization symbols -type (+$$) :: Nat -> Nat ~> Nat -data (+$$) k1 tf -type (+$) :: Nat ~> Nat ~> Nat -data (+$) tf -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 @@ -649,18 +719,22 @@ (Succ x) - Zero = Succ x (Succ x) - (Succ y) = x - y +#if __GLASGOW_HASKELL__ >= 810 type (-) :: Nat -> Nat -> Nat -type family (-) m n where +#endif +type family (-) (m :: Nat) (n :: Nat) :: Nat where Zero - x = Zero (Succ x) - Zero = Succ x (Succ x) - (Succ y) = x - y -type (-$$) :: Nat -> Nat ~> Nat -data (-$$) k1 tf -type (-$) :: Nat ~> Nat ~> Nat -data (-$) tf -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 @@ -670,54 +744,66 @@ isZero :: Nat -> Bool isZero n = if n == Zero then True else False +#if __GLASGOW_HASKELL__ >= 810 type IsZero :: Nat -> Bool -type family IsZero n where +#endif +type family IsZero (n :: Nat) :: Bool where IsZero n = If (n == Zero) True False +#if __GLASGOW_HASKELL__ >= 810 type IsZeroSym0 :: Nat ~> Bool -data IsZeroSym0 tf +#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 -type family a || b where +#endif +type family (a :: Bool) || (b :: Bool) :: Bool where False || x = x True || x = True -type (||$$) :: Bool -> Bool ~> Bool -data (||$$) a tf -type (||$) :: Bool ~> Bool ~> Bool -data (||$) tf -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 -type family Contains a b where +#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) -type ContainsSym1 :: a -> List a ~> Bool -data ContainsSym1 a tf -type ContainsSym0 :: a ~> List a ~> Bool -data ContainsSym0 tf -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 => @@ -740,15 +826,15 @@ 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 -type family Cont where +#endif +type family Cont :: a ~> List a ~> Bool where Cont = Lambda10Sym0 data Lambda10Sym0 f where @@ -770,21 +856,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) @@ -797,27 +884,17 @@ 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 -type family FindIndices f ls where +#endif +type family FindIndices (f :: a ~> Bool) (ls :: List a) :: List Nat where FindIndices p ls = (Let123LoopSym2 p ls) @@ Zero @@ ls type family Let123Loop p ls (arg1 :: Nat) (arg2 :: List a) :: List Nat where @@ -838,9 +915,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 @@ -852,9 +930,10 @@ 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 @@ -900,9 +979,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 @@ -928,11 +1008,15 @@ ------------------------------------------------------------ +#if __GLASGOW_HASKELL__ >= 810 type G :: Type -> Type -data G a where +#endif +data G :: Type -> Type where MkG :: G Bool -type SG :: G a -> Type -data SG g where +#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 diff --git a/tests/ByHand2.hs b/tests/ByHand2.hs --- a/tests/ByHand2.hs +++ b/tests/ByHand2.hs @@ -1,27 +1,79 @@ {-# LANGUAGE DataKinds, PolyKinds, TypeFamilies, GADTs, TypeOperators, DefaultSignatures, ScopedTypeVariables, InstanceSigs, MultiParamTypeClasses, FunctionalDependencies, - UndecidableInstances, StandaloneKindSignatures #-} + UndecidableInstances, CPP #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} + +#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 import Data.Singletons (Sing) +#if __GLASGOW_HASKELL__ >= 810 type Nat :: Type +#endif data Nat = Zero | Succ Nat +#if __GLASGOW_HASKELL__ >= 810 +type SNat :: Nat -> Type +#endif +data SNat :: Nat -> Type where + SZero :: SNat 'Zero + SSucc :: SNat n -> SNat ('Succ n) +type instance Sing = SNat + +{- type Bool :: Type data Bool = False | True +-} +#if __GLASGOW_HASKELL__ >= 810 +type SBool :: Bool -> Type +#endif +data SBool :: Bool -> Type where + SFalse :: SBool 'False + STrue :: SBool 'True +type instance Sing = SBool + +{- type Ordering :: Type data Ordering = LT | EQ | GT +-} +#if __GLASGOW_HASKELL__ >= 810 +type SOrdering :: Ordering -> Type +#endif +data SOrdering :: Ordering -> Type where + SLT :: SOrdering 'LT + SEQ :: SOrdering 'EQ + SGT :: SOrdering 'GT +type instance Sing = SOrdering + +{- not :: Bool -> Bool -not False = True not True = False +not False = True +-} +#if __GLASGOW_HASKELL__ >= 810 +type Not :: Bool -> Bool +#endif +type family Not (x :: Bool) :: Bool where + Not 'True = 'False + Not 'False = 'True + +sNot :: Sing b -> Sing (Not b) +sNot STrue = SFalse +sNot SFalse = STrue + +{- type Eq :: Type -> Constraint class Eq a where (==) :: a -> a -> Bool @@ -30,35 +82,11 @@ x == y = not (x /= y) x /= y = not (x == y) - -instance Eq Nat where - Zero == Zero = True - Zero == Succ _ = False - Succ _ == Zero = False - Succ x == Succ y = x == y - -type SBool :: Bool -> Type -data SBool b where - SFalse :: SBool 'False - STrue :: SBool 'True -type instance Sing = SBool - -type SNat :: Nat -> Type -data SNat n where - SZero :: SNat 'Zero - SSucc :: SNat n -> SNat ('Succ n) -type instance Sing = SNat - -type Not :: Bool -> Bool -type family Not x where - Not 'True = 'False - Not 'False = 'True - -sNot :: Sing b -> Sing (Not b) -sNot STrue = SFalse -sNot SFalse = STrue +-} +#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 @@ -66,13 +94,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) @@ -83,6 +107,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 @@ -90,6 +126,7 @@ SZero %== SSucc _ = SFalse SSucc x %== SSucc y = x %== y +{- instance Eq Ordering where LT == LT = True LT == EQ = False @@ -100,39 +137,7 @@ GT == LT = False GT == EQ = False GT == GT = True - -type Ord :: Type -> Constraint -class Eq a => Ord a where - compare :: a -> a -> Ordering - (<) :: a -> a -> Bool - - x < y = compare x y == LT - -type POrd :: Type -> Constraint -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 - -type SOrdering :: Ordering -> Type -data SOrdering o where - SLT :: SOrdering 'LT - SEQ :: SOrdering 'EQ - SGT :: SOrdering 'GT -type instance Sing = SOrdering +-} instance PEq Ordering where type 'LT == 'LT = 'True @@ -156,7 +161,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) @@ -164,21 +189,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) @@ -193,7 +236,9 @@ -------------------------------- +#if __GLASGOW_HASKELL__ >= 810 type FD :: Type -> Type -> Constraint +#endif class FD a b | a -> b where meth :: a -> a l2r :: a -> b @@ -206,7 +251,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 @@ -216,13 +263,16 @@ type L2r 'False = 'Zero type L2r 'True = 'Succ 'Zero -type T1 :: Bool type T1 = Meth 'True +#if __GLASGOW_HASKELL__ >= 810 type T2 :: Nat -type T2 = L2r 'False +#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) diff --git a/tests/README.md b/tests/README.md deleted file mode 100644 --- a/tests/README.md +++ /dev/null @@ -1,71 +0,0 @@ -`singletons` testsuite notes -============================ - -The `singletons` testsuite is built using the -[`tasty`](http://hackage.haskell.org/package/tasty) testing framework. Aside -from the standard `HUnit` and `QuickCheck` tests, it contains a number of -compile-and-dump tests. These tests run GHC to compile a test file that uses -the `singletons` library and compare the generated Template Haskell splices -against expected output saved in a "golden" file. Below are some details about -these tests: - - * GHC uses the in-tree `singletons` library. This means there is no need to - install the library in your system before running the tests. You can simply - run the tests with: - - ```bash - cabal test - ``` - - * Compile-and-dump tests are stored in the subdirectories of the - `tests/compile-and-dump/` directory. Files with a `.golden` extension store - the expected output. Running the testsuite produces files with an `.actual` - extension which contain the actual output produced by GHC. These files are - not deleted by the testsuite, which allows one to inspect them in case a - test fails. To remove the `.actual` files, run: - - ```bash - make clean-tests - ``` - - * Running the testsuite requires `diff`, as `diff` is used to compare golden - and actual files. - - * Each compile-and-dump test requires a set of GHC options to be used for - compilation. The testsuite defines a default set of options that enable all - of the language extensions required by `singletons`. This makes writing - tests easier since there is no need to put all the extensions into a source - file. The default options also enable `-ddump-splices` (which dumps splices - generated by Template Haskell), `-dsuppress-uniques` (which avoids test - failures due to unique identifiers), `-v0` (which silences GHC's build - output) and `-fforce-recomp` (which forces recompilation each time a - testsuite is run). There is a convenience function (`compileAndDumpTest`) - that creates a test with the standard GHC options defined by the testsuite. - - * Because `singletons` only supports one version of GHC, the `.golden` files - should not be assumed to be portable across multiple versions of GHC. Beware - of this should you try testing `singletons` against GHC HEAD. - - * You can run single tests or groups of tests whose name match a regexp using - tasty's pattern feature. For example: - - ```bash - cabal test --test-options="--pattern=Testsuite/Singletons/*" - ``` - - runs all tests in the `Testsuite/Singletons` branch of the test tree. - The `SingletonsTestSuite` module defines the structure of the test tree. - - * If you modify `singletons`, you may cause the actual output of some tests to - change. If these changes are what you intended, you can accept the new - output by running the following command: - - ```bash - cabal test --test-options="--accept" - ``` - -## ByHand files - -`tests` directory contains `ByHand.hs` and `ByHandAux.hs` files. They are -intended as a sandbox where all the definitions generated by `singletons` are -written by hand. diff --git a/tests/SingletonsTestSuite.hs b/tests/SingletonsTestSuite.hs --- a/tests/SingletonsTestSuite.hs +++ b/tests/SingletonsTestSuite.hs @@ -1,154 +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" - , afterSingletonsNat . - compileAndDumpStdTest "T150" - , 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 "T204" - , compileAndDumpStdTest "T206" - , compileAndDumpStdTest "T209" - , compileAndDumpStdTest "T216" - , compileAndDumpStdTest "T226" - , compileAndDumpStdTest "T229" - , compileAndDumpStdTest "T249" - , compileAndDumpStdTest "OverloadedStrings" - , compileAndDumpStdTest "T271" - , compileAndDumpStdTest "T287" - , compileAndDumpStdTest "TypeRepTYPE" - , compileAndDumpStdTest "T296" - , compileAndDumpStdTest "T297" - , compileAndDumpStdTest "T312" - , compileAndDumpStdTest "T313" - , compileAndDumpStdTest "T316" - , compileAndDumpStdTest "T322" - , compileAndDumpStdTest "T326" - , compileAndDumpStdTest "NatSymbolReflexive" - , compileAndDumpStdTest "T323" - , compileAndDumpStdTest "T332" - , compileAndDumpStdTest "T342" - , compileAndDumpStdTest "FunctorLikeDeriving" - , compileAndDumpStdTest "T353" - , compileAndDumpStdTest "T358" - , compileAndDumpStdTest "T367" - , compileAndDumpStdTest "T371" - , compileAndDumpStdTest "T376" - , compileAndDumpStdTest "T378a" - , compileAndDumpStdTest "T401" - , compileAndDumpStdTest "T401b" - , compileAndDumpStdTest "T402" - , compileAndDumpStdTest "T410" - , compileAndDumpStdTest "T412" - , compileAndDumpStdTest "T414" - ], - 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,179 +0,0 @@ -{-# 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 ) -import Data.Foldable ( asum ) -import Data.Text ( Text ) -import Data.String ( IsString(fromString) ) -import System.FilePath ( takeBaseName, pathSeparator ) -import System.FilePath ( () ) -import System.IO ( IOMode(..), openFile ) -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/" - --- 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" - , "-XStandaloneKindSignatures" - ] - --- 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" - 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] - 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 the compilation of a source file fails. We could find out -whether that happened by inspecting the exit code of the `ghc` process. But it -would be tricky to get a helpful message from the failing test; we would need -to display the stderr that 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 inserting comments into test files 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 - -cleanFiles :: IO () -cleanFiles = callCommand $ "rm -f " ++ rootDir "tests/compile-and-dump/*/*.{hi,o}" diff --git a/tests/compile-and-dump/GradingClient/Database.golden b/tests/compile-and-dump/GradingClient/Database.golden deleted file mode 100644 --- a/tests/compile-and-dump/GradingClient/Database.golden +++ /dev/null @@ -1,2656 +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 :: Nat - type SuccSym0 :: (~>) Nat Nat - data SuccSym0 a0123456789876543210 - where - SuccSym0KindInference :: SameKind (Apply SuccSym0 arg) (SuccSym1 arg) => - SuccSym0 a0123456789876543210 - type instance Apply SuccSym0 a0123456789876543210 = SuccSym1 a0123456789876543210 - instance SuppressUnusedWarnings SuccSym0 where - suppressUnusedWarnings = snd (((,) SuccSym0KindInference) ()) - type SuccSym1 (a0123456789876543210 :: Nat) = - Succ a0123456789876543210 :: Nat - type Compare_0123456789876543210 :: Nat -> Nat -> Ordering - type family Compare_0123456789876543210 a a where - Compare_0123456789876543210 Zero Zero = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) NilSym0 - Compare_0123456789876543210 (Succ a_0123456789876543210) (Succ b_0123456789876543210) = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) NilSym0) - Compare_0123456789876543210 Zero (Succ _) = LTSym0 - Compare_0123456789876543210 (Succ _) Zero = GTSym0 - type Compare_0123456789876543210Sym0 :: (~>) Nat ((~>) Nat Ordering) - data Compare_0123456789876543210Sym0 a0123456789876543210 - where - Compare_0123456789876543210Sym0KindInference :: SameKind (Apply Compare_0123456789876543210Sym0 arg) (Compare_0123456789876543210Sym1 arg) => - Compare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Compare_0123456789876543210Sym0 a0123456789876543210 = Compare_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Compare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym0KindInference) ()) - type Compare_0123456789876543210Sym1 :: Nat -> (~>) Nat Ordering - data Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - Compare_0123456789876543210Sym1KindInference :: SameKind (Apply (Compare_0123456789876543210Sym1 a0123456789876543210) arg) (Compare_0123456789876543210Sym2 a0123456789876543210 arg) => - Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Compare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Compare_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Compare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym1KindInference) ()) - type Compare_0123456789876543210Sym2 (a0123456789876543210 :: Nat) (a0123456789876543210 :: Nat) = - Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 :: Ordering - instance POrd Nat where - type Compare a a = Apply (Apply Compare_0123456789876543210Sym0 a) a - type Equals_0123456789876543210 :: Nat -> Nat -> Bool - type family Equals_0123456789876543210 a b 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 :: Nat) - SSucc :: forall (n :: Nat). (Sing n) -> SNat (Succ n :: Nat) - 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 :: U - type STRINGSym0 = STRING :: U - type NATSym0 = NAT :: U - type VECSym0 :: (~>) U ((~>) Nat U) - data VECSym0 a0123456789876543210 - where - VECSym0KindInference :: SameKind (Apply VECSym0 arg) (VECSym1 arg) => - VECSym0 a0123456789876543210 - type instance Apply VECSym0 a0123456789876543210 = VECSym1 a0123456789876543210 - instance SuppressUnusedWarnings VECSym0 where - suppressUnusedWarnings = snd (((,) VECSym0KindInference) ()) - type VECSym1 :: U -> (~>) Nat U - data VECSym1 a0123456789876543210 a0123456789876543210 - where - VECSym1KindInference :: SameKind (Apply (VECSym1 a0123456789876543210) arg) (VECSym2 a0123456789876543210 arg) => - VECSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (VECSym1 a0123456789876543210) a0123456789876543210 = VECSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (VECSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) VECSym1KindInference) ()) - type VECSym2 (a0123456789876543210 :: U) (a0123456789876543210 :: Nat) = - VEC a0123456789876543210 a0123456789876543210 :: U - type CASym0 = CA :: AChar - type CBSym0 = CB :: AChar - type CCSym0 = CC :: AChar - type CDSym0 = CD :: AChar - type CESym0 = CE :: AChar - type CFSym0 = CF :: AChar - type CGSym0 = CG :: AChar - type CHSym0 = CH :: AChar - type CISym0 = CI :: AChar - type CJSym0 = CJ :: AChar - type CKSym0 = CK :: AChar - type CLSym0 = CL :: AChar - type CMSym0 = CM :: AChar - type CNSym0 = CN :: AChar - type COSym0 = CO :: AChar - type CPSym0 = CP :: AChar - type CQSym0 = CQ :: AChar - type CRSym0 = CR :: AChar - type CSSym0 = CS :: AChar - type CTSym0 = CT :: AChar - type CUSym0 = CU :: AChar - type CVSym0 = CV :: AChar - type CWSym0 = CW :: AChar - type CXSym0 = CX :: AChar - type CYSym0 = CY :: AChar - type CZSym0 = CZ :: AChar - type AttrSym0 :: (~>) [AChar] ((~>) U Attribute) - data AttrSym0 a0123456789876543210 - where - AttrSym0KindInference :: SameKind (Apply AttrSym0 arg) (AttrSym1 arg) => - AttrSym0 a0123456789876543210 - type instance Apply AttrSym0 a0123456789876543210 = AttrSym1 a0123456789876543210 - instance SuppressUnusedWarnings AttrSym0 where - suppressUnusedWarnings = snd (((,) AttrSym0KindInference) ()) - type AttrSym1 :: [AChar] -> (~>) U Attribute - data AttrSym1 a0123456789876543210 a0123456789876543210 - where - AttrSym1KindInference :: SameKind (Apply (AttrSym1 a0123456789876543210) arg) (AttrSym2 a0123456789876543210 arg) => - AttrSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (AttrSym1 a0123456789876543210) a0123456789876543210 = AttrSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (AttrSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) AttrSym1KindInference) ()) - type AttrSym2 (a0123456789876543210 :: [AChar]) (a0123456789876543210 :: U) = - Attr a0123456789876543210 a0123456789876543210 :: Attribute - type SchSym0 :: (~>) [Attribute] Schema - data SchSym0 a0123456789876543210 - where - SchSym0KindInference :: SameKind (Apply SchSym0 arg) (SchSym1 arg) => - SchSym0 a0123456789876543210 - type instance Apply SchSym0 a0123456789876543210 = SchSym1 a0123456789876543210 - instance SuppressUnusedWarnings SchSym0 where - suppressUnusedWarnings = snd (((,) SchSym0KindInference) ()) - type SchSym1 (a0123456789876543210 :: [Attribute]) = - Sch a0123456789876543210 :: Schema - data Let0123456789876543210Scrutinee_0123456789876543210Sym0 name0123456789876543210 - where - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference :: SameKind (Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 arg) (Let0123456789876543210Scrutinee_0123456789876543210Sym1 arg) => - Let0123456789876543210Scrutinee_0123456789876543210Sym0 name0123456789876543210 - type instance Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 name0123456789876543210 = Let0123456789876543210Scrutinee_0123456789876543210Sym1 name0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210Scrutinee_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd - (((,) - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference) - ()) - data Let0123456789876543210Scrutinee_0123456789876543210Sym1 name0123456789876543210 name'0123456789876543210 - where - Let0123456789876543210Scrutinee_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 name0123456789876543210) where - suppressUnusedWarnings - = snd - (((,) - Let0123456789876543210Scrutinee_0123456789876543210Sym1KindInference) - ()) - data Let0123456789876543210Scrutinee_0123456789876543210Sym2 name0123456789876543210 name'0123456789876543210 u0123456789876543210 - where - Let0123456789876543210Scrutinee_0123456789876543210Sym2KindInference :: 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 name0123456789876543210 name'0123456789876543210) u0123456789876543210 = Let0123456789876543210Scrutinee_0123456789876543210Sym3 name0123456789876543210 name'0123456789876543210 u0123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210Scrutinee_0123456789876543210Sym2 name0123456789876543210 name'0123456789876543210) where - suppressUnusedWarnings - = snd - (((,) - Let0123456789876543210Scrutinee_0123456789876543210Sym2KindInference) - ()) - data Let0123456789876543210Scrutinee_0123456789876543210Sym3 name0123456789876543210 name'0123456789876543210 u0123456789876543210 attrs0123456789876543210 - where - Let0123456789876543210Scrutinee_0123456789876543210Sym3KindInference :: 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 name0123456789876543210 name'0123456789876543210 u0123456789876543210) attrs0123456789876543210 = Let0123456789876543210Scrutinee_0123456789876543210Sym4 name0123456789876543210 name'0123456789876543210 u0123456789876543210 attrs0123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210Scrutinee_0123456789876543210Sym3 name0123456789876543210 name'0123456789876543210 u0123456789876543210) where - suppressUnusedWarnings - = snd - (((,) - Let0123456789876543210Scrutinee_0123456789876543210Sym3KindInference) - ()) - type Let0123456789876543210Scrutinee_0123456789876543210Sym4 name0123456789876543210 name'0123456789876543210 u0123456789876543210 attrs0123456789876543210 = - Let0123456789876543210Scrutinee_0123456789876543210 name0123456789876543210 name'0123456789876543210 u0123456789876543210 attrs0123456789876543210 - 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 LookupSym0 :: (~>) [AChar] ((~>) Schema U) - data LookupSym0 a0123456789876543210 - where - LookupSym0KindInference :: SameKind (Apply LookupSym0 arg) (LookupSym1 arg) => - LookupSym0 a0123456789876543210 - type instance Apply LookupSym0 a0123456789876543210 = LookupSym1 a0123456789876543210 - instance SuppressUnusedWarnings LookupSym0 where - suppressUnusedWarnings = snd (((,) LookupSym0KindInference) ()) - type LookupSym1 :: [AChar] -> (~>) Schema U - data LookupSym1 a0123456789876543210 a0123456789876543210 - where - LookupSym1KindInference :: SameKind (Apply (LookupSym1 a0123456789876543210) arg) (LookupSym2 a0123456789876543210 arg) => - LookupSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (LookupSym1 a0123456789876543210) a0123456789876543210 = LookupSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (LookupSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) LookupSym1KindInference) ()) - type LookupSym2 (a0123456789876543210 :: [AChar]) (a0123456789876543210 :: Schema) = - Lookup a0123456789876543210 a0123456789876543210 :: U - type OccursSym0 :: (~>) [AChar] ((~>) Schema Bool) - data OccursSym0 a0123456789876543210 - where - OccursSym0KindInference :: SameKind (Apply OccursSym0 arg) (OccursSym1 arg) => - OccursSym0 a0123456789876543210 - type instance Apply OccursSym0 a0123456789876543210 = OccursSym1 a0123456789876543210 - instance SuppressUnusedWarnings OccursSym0 where - suppressUnusedWarnings = snd (((,) OccursSym0KindInference) ()) - type OccursSym1 :: [AChar] -> (~>) Schema Bool - data OccursSym1 a0123456789876543210 a0123456789876543210 - where - OccursSym1KindInference :: SameKind (Apply (OccursSym1 a0123456789876543210) arg) (OccursSym2 a0123456789876543210 arg) => - OccursSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (OccursSym1 a0123456789876543210) a0123456789876543210 = OccursSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (OccursSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) OccursSym1KindInference) ()) - type OccursSym2 (a0123456789876543210 :: [AChar]) (a0123456789876543210 :: Schema) = - Occurs a0123456789876543210 a0123456789876543210 :: Bool - type DisjointSym0 :: (~>) Schema ((~>) Schema Bool) - data DisjointSym0 a0123456789876543210 - where - DisjointSym0KindInference :: SameKind (Apply DisjointSym0 arg) (DisjointSym1 arg) => - DisjointSym0 a0123456789876543210 - type instance Apply DisjointSym0 a0123456789876543210 = DisjointSym1 a0123456789876543210 - instance SuppressUnusedWarnings DisjointSym0 where - suppressUnusedWarnings = snd (((,) DisjointSym0KindInference) ()) - type DisjointSym1 :: Schema -> (~>) Schema Bool - data DisjointSym1 a0123456789876543210 a0123456789876543210 - where - DisjointSym1KindInference :: SameKind (Apply (DisjointSym1 a0123456789876543210) arg) (DisjointSym2 a0123456789876543210 arg) => - DisjointSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (DisjointSym1 a0123456789876543210) a0123456789876543210 = DisjointSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (DisjointSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) DisjointSym1KindInference) ()) - type DisjointSym2 (a0123456789876543210 :: Schema) (a0123456789876543210 :: Schema) = - Disjoint a0123456789876543210 a0123456789876543210 :: Bool - type AttrNotInSym0 :: (~>) Attribute ((~>) Schema Bool) - data AttrNotInSym0 a0123456789876543210 - where - AttrNotInSym0KindInference :: SameKind (Apply AttrNotInSym0 arg) (AttrNotInSym1 arg) => - AttrNotInSym0 a0123456789876543210 - type instance Apply AttrNotInSym0 a0123456789876543210 = AttrNotInSym1 a0123456789876543210 - instance SuppressUnusedWarnings AttrNotInSym0 where - suppressUnusedWarnings = snd (((,) AttrNotInSym0KindInference) ()) - type AttrNotInSym1 :: Attribute -> (~>) Schema Bool - data AttrNotInSym1 a0123456789876543210 a0123456789876543210 - where - AttrNotInSym1KindInference :: SameKind (Apply (AttrNotInSym1 a0123456789876543210) arg) (AttrNotInSym2 a0123456789876543210 arg) => - AttrNotInSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (AttrNotInSym1 a0123456789876543210) a0123456789876543210 = AttrNotInSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (AttrNotInSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) AttrNotInSym1KindInference) ()) - type AttrNotInSym2 (a0123456789876543210 :: Attribute) (a0123456789876543210 :: Schema) = - AttrNotIn a0123456789876543210 a0123456789876543210 :: Bool - type AppendSym0 :: (~>) Schema ((~>) Schema Schema) - data AppendSym0 a0123456789876543210 - where - AppendSym0KindInference :: SameKind (Apply AppendSym0 arg) (AppendSym1 arg) => - AppendSym0 a0123456789876543210 - type instance Apply AppendSym0 a0123456789876543210 = AppendSym1 a0123456789876543210 - instance SuppressUnusedWarnings AppendSym0 where - suppressUnusedWarnings = snd (((,) AppendSym0KindInference) ()) - type AppendSym1 :: Schema -> (~>) Schema Schema - data AppendSym1 a0123456789876543210 a0123456789876543210 - where - AppendSym1KindInference :: SameKind (Apply (AppendSym1 a0123456789876543210) arg) (AppendSym2 a0123456789876543210 arg) => - AppendSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (AppendSym1 a0123456789876543210) a0123456789876543210 = AppendSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (AppendSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) AppendSym1KindInference) ()) - type AppendSym2 (a0123456789876543210 :: Schema) (a0123456789876543210 :: Schema) = - Append a0123456789876543210 a0123456789876543210 :: Schema - type Lookup :: [AChar] -> Schema -> U - type family Lookup a a where - Lookup _ (Sch '[]) = UndefinedSym0 - Lookup name (Sch ('(:) (Attr name' u) attrs)) = Case_0123456789876543210 name name' u attrs (Let0123456789876543210Scrutinee_0123456789876543210Sym4 name name' u attrs) - type Occurs :: [AChar] -> Schema -> Bool - type family Occurs a a where - Occurs _ (Sch '[]) = FalseSym0 - Occurs name (Sch ('(:) (Attr name' _) attrs)) = Apply (Apply (||@#@$) (Apply (Apply (==@#@$) name) name')) (Apply (Apply OccursSym0 name) (Apply SchSym0 attrs)) - type Disjoint :: Schema -> Schema -> Bool - type family Disjoint a a where - Disjoint (Sch '[]) _ = TrueSym0 - Disjoint (Sch ('(:) h t)) s = Apply (Apply (&&@#@$) (Apply (Apply AttrNotInSym0 h) s)) (Apply (Apply DisjointSym0 (Apply SchSym0 t)) s) - type AttrNotIn :: Attribute -> Schema -> Bool - type family AttrNotIn a a 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 Append :: Schema -> Schema -> Schema - type family Append a a where - Append (Sch s1) (Sch s2) = Apply SchSym0 (Apply (Apply (++@#@$) s1) s2) - type ShowsPrec_0123456789876543210 :: GHC.Types.Nat - -> U -> Symbol -> Symbol - type family ShowsPrec_0123456789876543210 a a a 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_0123456789876543210Sym0 :: (~>) GHC.Types.Nat ((~>) U ((~>) Symbol Symbol)) - data ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym0KindInference :: SameKind (Apply ShowsPrec_0123456789876543210Sym0 arg) (ShowsPrec_0123456789876543210Sym1 arg) => - ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ShowsPrec_0123456789876543210Sym0 a0123456789876543210 = ShowsPrec_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings ShowsPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym0KindInference) ()) - type ShowsPrec_0123456789876543210Sym1 :: GHC.Types.Nat - -> (~>) U ((~>) Symbol Symbol) - data ShowsPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym1KindInference) ()) - type ShowsPrec_0123456789876543210Sym2 :: GHC.Types.Nat - -> U -> (~>) Symbol Symbol - data ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym2KindInference :: 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_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym2KindInference) ()) - type ShowsPrec_0123456789876543210Sym3 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: U) (a0123456789876543210 :: Symbol) = - ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 :: Symbol - instance PShow U where - type ShowsPrec a a a = Apply (Apply (Apply ShowsPrec_0123456789876543210Sym0 a) a) a - type ShowsPrec_0123456789876543210 :: GHC.Types.Nat - -> AChar -> Symbol -> Symbol - type family ShowsPrec_0123456789876543210 a a a 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_0123456789876543210Sym0 :: (~>) GHC.Types.Nat ((~>) AChar ((~>) Symbol Symbol)) - data ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym0KindInference :: SameKind (Apply ShowsPrec_0123456789876543210Sym0 arg) (ShowsPrec_0123456789876543210Sym1 arg) => - ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ShowsPrec_0123456789876543210Sym0 a0123456789876543210 = ShowsPrec_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings ShowsPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym0KindInference) ()) - type ShowsPrec_0123456789876543210Sym1 :: GHC.Types.Nat - -> (~>) AChar ((~>) Symbol Symbol) - data ShowsPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym1KindInference) ()) - type ShowsPrec_0123456789876543210Sym2 :: GHC.Types.Nat - -> AChar -> (~>) Symbol Symbol - data ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym2KindInference :: 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_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym2KindInference) ()) - type ShowsPrec_0123456789876543210Sym3 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: AChar) (a0123456789876543210 :: Symbol) = - ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 :: Symbol - instance PShow AChar where - type ShowsPrec a a a = Apply (Apply (Apply ShowsPrec_0123456789876543210Sym0 a) a) a - type Equals_0123456789876543210 :: U -> U -> Bool - type family Equals_0123456789876543210 a b 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 Equals_0123456789876543210 :: AChar -> AChar -> Bool - type family Equals_0123456789876543210 a b 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 :: U) - SSTRING :: SU (STRING :: U) - SNAT :: SU (NAT :: U) - SVEC :: forall (n :: U) (n :: Nat). - (Sing n) -> (Sing n) -> SU (VEC n n :: U) - 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 :: AChar) - SCB :: SAChar (CB :: AChar) - SCC :: SAChar (CC :: AChar) - SCD :: SAChar (CD :: AChar) - SCE :: SAChar (CE :: AChar) - SCF :: SAChar (CF :: AChar) - SCG :: SAChar (CG :: AChar) - SCH :: SAChar (CH :: AChar) - SCI :: SAChar (CI :: AChar) - SCJ :: SAChar (CJ :: AChar) - SCK :: SAChar (CK :: AChar) - SCL :: SAChar (CL :: AChar) - SCM :: SAChar (CM :: AChar) - SCN :: SAChar (CN :: AChar) - SCO :: SAChar (CO :: AChar) - SCP :: SAChar (CP :: AChar) - SCQ :: SAChar (CQ :: AChar) - SCR :: SAChar (CR :: AChar) - SCS :: SAChar (CS :: AChar) - SCT :: SAChar (CT :: AChar) - SCU :: SAChar (CU :: AChar) - SCV :: SAChar (CV :: AChar) - SCW :: SAChar (CW :: AChar) - SCX :: SAChar (CX :: AChar) - SCY :: SAChar (CY :: AChar) - SCZ :: SAChar (CZ :: AChar) - 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) -> (Sing n) -> SAttribute (Attr n n :: Attribute) - 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) -> SSchema (Sch n :: Schema) - 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.golden b/tests/compile-and-dump/GradingClient/Main.golden deleted file mode 100644 --- a/tests/compile-and-dump/GradingClient/Main.golden +++ /dev/null @@ -1,130 +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 :: Schema - type GradingSchemaSym0 = GradingSchema :: Schema - type MajorNameSym0 = MajorName :: [AChar] - type GradeNameSym0 = GradeName :: [AChar] - type YearNameSym0 = YearName :: [AChar] - type FirstNameSym0 = FirstName :: [AChar] - type LastNameSym0 = LastName :: [AChar] - type Names :: Schema - type family Names where - Names = Apply SchSym0 (Apply (Apply (:@#@$) (Apply (Apply AttrSym0 FirstNameSym0) STRINGSym0)) (Apply (Apply (:@#@$) (Apply (Apply AttrSym0 LastNameSym0) STRINGSym0)) NilSym0)) - type GradingSchema :: Schema - type family GradingSchema 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)) NilSym0))))) - type MajorName :: [AChar] - type family MajorName where - MajorName = Apply (Apply (:@#@$) CMSym0) (Apply (Apply (:@#@$) CASym0) (Apply (Apply (:@#@$) CJSym0) (Apply (Apply (:@#@$) COSym0) (Apply (Apply (:@#@$) CRSym0) NilSym0)))) - type GradeName :: [AChar] - type family GradeName where - GradeName = Apply (Apply (:@#@$) CGSym0) (Apply (Apply (:@#@$) CRSym0) (Apply (Apply (:@#@$) CASym0) (Apply (Apply (:@#@$) CDSym0) (Apply (Apply (:@#@$) CESym0) NilSym0)))) - type YearName :: [AChar] - type family YearName where - YearName = Apply (Apply (:@#@$) CYSym0) (Apply (Apply (:@#@$) CESym0) (Apply (Apply (:@#@$) CASym0) (Apply (Apply (:@#@$) CRSym0) NilSym0))) - type FirstName :: [AChar] - type family FirstName where - FirstName = Apply (Apply (:@#@$) CFSym0) (Apply (Apply (:@#@$) CISym0) (Apply (Apply (:@#@$) CRSym0) (Apply (Apply (:@#@$) CSSym0) (Apply (Apply (:@#@$) CTSym0) NilSym0)))) - type LastName :: [AChar] - type family LastName where - LastName = Apply (Apply (:@#@$) CLSym0) (Apply (Apply (:@#@$) CASym0) (Apply (Apply (:@#@$) CSSym0) (Apply (Apply (:@#@$) CTSym0) NilSym0))) - 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.golden b/tests/compile-and-dump/InsertionSort/InsertionSortImp.golden deleted file mode 100644 --- a/tests/compile-and-dump/InsertionSort/InsertionSortImp.golden +++ /dev/null @@ -1,206 +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 :: Nat - type SuccSym0 :: (~>) Nat Nat - data SuccSym0 a0123456789876543210 - where - SuccSym0KindInference :: SameKind (Apply SuccSym0 arg) (SuccSym1 arg) => - SuccSym0 a0123456789876543210 - type instance Apply SuccSym0 a0123456789876543210 = SuccSym1 a0123456789876543210 - instance SuppressUnusedWarnings SuccSym0 where - suppressUnusedWarnings = snd (((,) SuccSym0KindInference) ()) - type SuccSym1 (a0123456789876543210 :: Nat) = - Succ a0123456789876543210 :: Nat - data SNat :: Nat -> Type - where - SZero :: SNat (Zero :: Nat) - SSucc :: forall (n :: Nat). (Sing n) -> SNat (Succ n :: Nat) - 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) - data Let0123456789876543210Scrutinee_0123456789876543210Sym0 n0123456789876543210 - where - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference :: SameKind (Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 arg) (Let0123456789876543210Scrutinee_0123456789876543210Sym1 arg) => - Let0123456789876543210Scrutinee_0123456789876543210Sym0 n0123456789876543210 - type instance Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 n0123456789876543210 = Let0123456789876543210Scrutinee_0123456789876543210Sym1 n0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210Scrutinee_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd - (((,) - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference) - ()) - data Let0123456789876543210Scrutinee_0123456789876543210Sym1 n0123456789876543210 h0123456789876543210 - where - Let0123456789876543210Scrutinee_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 n0123456789876543210) where - suppressUnusedWarnings - = snd - (((,) - Let0123456789876543210Scrutinee_0123456789876543210Sym1KindInference) - ()) - data Let0123456789876543210Scrutinee_0123456789876543210Sym2 n0123456789876543210 h0123456789876543210 t0123456789876543210 - where - Let0123456789876543210Scrutinee_0123456789876543210Sym2KindInference :: SameKind (Apply (Let0123456789876543210Scrutinee_0123456789876543210Sym2 n0123456789876543210 h0123456789876543210) arg) (Let0123456789876543210Scrutinee_0123456789876543210Sym3 n0123456789876543210 h0123456789876543210 arg) => - Let0123456789876543210Scrutinee_0123456789876543210Sym2 n0123456789876543210 h0123456789876543210 t0123456789876543210 - type instance Apply (Let0123456789876543210Scrutinee_0123456789876543210Sym2 n0123456789876543210 h0123456789876543210) t0123456789876543210 = Let0123456789876543210Scrutinee_0123456789876543210Sym3 n0123456789876543210 h0123456789876543210 t0123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210Scrutinee_0123456789876543210Sym2 n0123456789876543210 h0123456789876543210) where - suppressUnusedWarnings - = snd - (((,) - Let0123456789876543210Scrutinee_0123456789876543210Sym2KindInference) - ()) - type Let0123456789876543210Scrutinee_0123456789876543210Sym3 n0123456789876543210 h0123456789876543210 t0123456789876543210 = - Let0123456789876543210Scrutinee_0123456789876543210 n0123456789876543210 h0123456789876543210 t0123456789876543210 - 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 InsertionSortSym0 :: (~>) [Nat] [Nat] - data InsertionSortSym0 a0123456789876543210 - where - InsertionSortSym0KindInference :: SameKind (Apply InsertionSortSym0 arg) (InsertionSortSym1 arg) => - InsertionSortSym0 a0123456789876543210 - type instance Apply InsertionSortSym0 a0123456789876543210 = InsertionSortSym1 a0123456789876543210 - instance SuppressUnusedWarnings InsertionSortSym0 where - suppressUnusedWarnings - = snd (((,) InsertionSortSym0KindInference) ()) - type InsertionSortSym1 (a0123456789876543210 :: [Nat]) = - InsertionSort a0123456789876543210 :: [Nat] - type InsertSym0 :: (~>) Nat ((~>) [Nat] [Nat]) - data InsertSym0 a0123456789876543210 - where - InsertSym0KindInference :: SameKind (Apply InsertSym0 arg) (InsertSym1 arg) => - InsertSym0 a0123456789876543210 - type instance Apply InsertSym0 a0123456789876543210 = InsertSym1 a0123456789876543210 - instance SuppressUnusedWarnings InsertSym0 where - suppressUnusedWarnings = snd (((,) InsertSym0KindInference) ()) - type InsertSym1 :: Nat -> (~>) [Nat] [Nat] - data InsertSym1 a0123456789876543210 a0123456789876543210 - where - InsertSym1KindInference :: SameKind (Apply (InsertSym1 a0123456789876543210) arg) (InsertSym2 a0123456789876543210 arg) => - InsertSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (InsertSym1 a0123456789876543210) a0123456789876543210 = InsertSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (InsertSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) InsertSym1KindInference) ()) - type InsertSym2 (a0123456789876543210 :: Nat) (a0123456789876543210 :: [Nat]) = - Insert a0123456789876543210 a0123456789876543210 :: [Nat] - type LeqSym0 :: (~>) Nat ((~>) Nat Bool) - data LeqSym0 a0123456789876543210 - where - LeqSym0KindInference :: SameKind (Apply LeqSym0 arg) (LeqSym1 arg) => - LeqSym0 a0123456789876543210 - type instance Apply LeqSym0 a0123456789876543210 = LeqSym1 a0123456789876543210 - instance SuppressUnusedWarnings LeqSym0 where - suppressUnusedWarnings = snd (((,) LeqSym0KindInference) ()) - type LeqSym1 :: Nat -> (~>) Nat Bool - data LeqSym1 a0123456789876543210 a0123456789876543210 - where - LeqSym1KindInference :: SameKind (Apply (LeqSym1 a0123456789876543210) arg) (LeqSym2 a0123456789876543210 arg) => - LeqSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (LeqSym1 a0123456789876543210) a0123456789876543210 = LeqSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (LeqSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) LeqSym1KindInference) ()) - type LeqSym2 (a0123456789876543210 :: Nat) (a0123456789876543210 :: Nat) = - Leq a0123456789876543210 a0123456789876543210 :: Bool - type InsertionSort :: [Nat] -> [Nat] - type family InsertionSort a where - InsertionSort '[] = NilSym0 - InsertionSort ('(:) h t) = Apply (Apply InsertSym0 h) (Apply InsertionSortSym0 t) - type Insert :: Nat -> [Nat] -> [Nat] - type family Insert a a where - Insert n '[] = Apply (Apply (:@#@$) n) NilSym0 - Insert n ('(:) h t) = Case_0123456789876543210 n h t (Let0123456789876543210Scrutinee_0123456789876543210Sym3 n h t) - type Leq :: Nat -> Nat -> Bool - type family Leq a a 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.golden b/tests/compile-and-dump/Promote/Constructors.golden deleted file mode 100644 --- a/tests/compile-and-dump/Promote/Constructors.golden +++ /dev/null @@ -1,69 +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 :: Foo - type (:+@#@$) :: (~>) Foo ((~>) Foo Foo) - data (:+@#@$) a0123456789876543210 - where - (::+@#@$###) :: SameKind (Apply (:+@#@$) arg) ((:+@#@$$) arg) => - (:+@#@$) a0123456789876543210 - type instance Apply (:+@#@$) a0123456789876543210 = (:+@#@$$) a0123456789876543210 - instance SuppressUnusedWarnings (:+@#@$) where - suppressUnusedWarnings = snd (((,) (::+@#@$###)) ()) - type (:+@#@$$) :: Foo -> (~>) Foo Foo - data (:+@#@$$) a0123456789876543210 a0123456789876543210 - where - (::+@#@$$###) :: SameKind (Apply ((:+@#@$$) a0123456789876543210) arg) ((:+@#@$$$) a0123456789876543210 arg) => - (:+@#@$$) a0123456789876543210 a0123456789876543210 - type instance Apply ((:+@#@$$) a0123456789876543210) a0123456789876543210 = (:+@#@$$$) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((:+@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (::+@#@$$###)) ()) - type (:+@#@$$$) (a0123456789876543210 :: Foo) (a0123456789876543210 :: Foo) = - (:+) a0123456789876543210 a0123456789876543210 :: Foo - type BarSym0 :: (~>) Bar ((~>) Bar ((~>) Bar ((~>) Bar ((~>) Foo Bar)))) - data BarSym0 a0123456789876543210 - where - BarSym0KindInference :: SameKind (Apply BarSym0 arg) (BarSym1 arg) => - BarSym0 a0123456789876543210 - type instance Apply BarSym0 a0123456789876543210 = BarSym1 a0123456789876543210 - instance SuppressUnusedWarnings BarSym0 where - suppressUnusedWarnings = snd (((,) BarSym0KindInference) ()) - type BarSym1 :: Bar - -> (~>) Bar ((~>) Bar ((~>) Bar ((~>) Foo Bar))) - data BarSym1 a0123456789876543210 a0123456789876543210 - where - BarSym1KindInference :: SameKind (Apply (BarSym1 a0123456789876543210) arg) (BarSym2 a0123456789876543210 arg) => - BarSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (BarSym1 a0123456789876543210) a0123456789876543210 = BarSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (BarSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) BarSym1KindInference) ()) - type BarSym2 :: Bar -> Bar -> (~>) Bar ((~>) Bar ((~>) Foo Bar)) - data BarSym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - BarSym2KindInference :: SameKind (Apply (BarSym2 a0123456789876543210 a0123456789876543210) arg) (BarSym3 a0123456789876543210 a0123456789876543210 arg) => - BarSym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (BarSym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = BarSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (BarSym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) BarSym2KindInference) ()) - type BarSym3 :: Bar -> Bar -> Bar -> (~>) Bar ((~>) Foo Bar) - data BarSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - BarSym3KindInference :: SameKind (Apply (BarSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210) arg) (BarSym4 a0123456789876543210 a0123456789876543210 a0123456789876543210 arg) => - BarSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (BarSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210) a0123456789876543210 = BarSym4 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (BarSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) BarSym3KindInference) ()) - type BarSym4 :: Bar -> Bar -> Bar -> Bar -> (~>) Foo Bar - data BarSym4 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - BarSym4KindInference :: SameKind (Apply (BarSym4 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210) arg) (BarSym5 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 arg) => - BarSym4 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (BarSym4 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210) a0123456789876543210 = BarSym5 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (BarSym4 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) BarSym4KindInference) ()) - type BarSym5 (a0123456789876543210 :: Bar) (a0123456789876543210 :: Bar) (a0123456789876543210 :: Bar) (a0123456789876543210 :: Bar) (a0123456789876543210 :: Foo) = - Bar a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 :: Bar 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.golden b/tests/compile-and-dump/Promote/GenDefunSymbols.golden deleted file mode 100644 --- a/tests/compile-and-dump/Promote/GenDefunSymbols.golden +++ /dev/null @@ -1,52 +0,0 @@ -Promote/GenDefunSymbols.hs:0:0:: Splicing declarations - genDefunSymbols [''LiftMaybe, ''NatT, ''(:+)] - ======> - type LiftMaybeSym0 :: forall (a :: Type) (b :: Type). - (~>) ((~>) a b) ((~>) (Maybe a) (Maybe b)) - data LiftMaybeSym0 a0123456789876543210 - where - LiftMaybeSym0KindInference :: Data.Singletons.Internal.SameKind (Apply LiftMaybeSym0 arg) (LiftMaybeSym1 arg) => - LiftMaybeSym0 a0123456789876543210 - type instance Apply LiftMaybeSym0 a0123456789876543210 = LiftMaybeSym1 a0123456789876543210 - instance SuppressUnusedWarnings LiftMaybeSym0 where - suppressUnusedWarnings = snd (((,) LiftMaybeSym0KindInference) ()) - type LiftMaybeSym1 :: forall (a :: Type) (b :: Type). - (~>) a b -> (~>) (Maybe a) (Maybe b) - data LiftMaybeSym1 a0123456789876543210 a0123456789876543210 - where - LiftMaybeSym1KindInference :: Data.Singletons.Internal.SameKind (Apply (LiftMaybeSym1 a0123456789876543210) arg) (LiftMaybeSym2 a0123456789876543210 arg) => - LiftMaybeSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (LiftMaybeSym1 a0123456789876543210) a0123456789876543210 = LiftMaybeSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (LiftMaybeSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) LiftMaybeSym1KindInference) ()) - type LiftMaybeSym2 (a0123456789876543210 :: (~>) a b) (a0123456789876543210 :: Maybe a) = - LiftMaybe a0123456789876543210 a0123456789876543210 :: Maybe b - type ZeroSym0 = 'Zero :: NatT - type SuccSym0 :: (~>) NatT NatT - data SuccSym0 a0123456789876543210 - where - SuccSym0KindInference :: Data.Singletons.Internal.SameKind (Apply SuccSym0 arg) (SuccSym1 arg) => - SuccSym0 a0123456789876543210 - type instance Apply SuccSym0 a0123456789876543210 = SuccSym1 a0123456789876543210 - instance SuppressUnusedWarnings SuccSym0 where - suppressUnusedWarnings = snd (((,) SuccSym0KindInference) ()) - type SuccSym1 (a0123456789876543210 :: NatT) = - 'Succ a0123456789876543210 :: NatT - type (:+@#@$) :: (~>) Nat ((~>) Nat Nat) - data (:+@#@$) a0123456789876543210 - where - (::+@#@$###) :: Data.Singletons.Internal.SameKind (Apply (:+@#@$) arg) ((:+@#@$$) arg) => - (:+@#@$) a0123456789876543210 - type instance Apply (:+@#@$) a0123456789876543210 = (:+@#@$$) a0123456789876543210 - instance SuppressUnusedWarnings (:+@#@$) where - suppressUnusedWarnings = snd (((,) (::+@#@$###)) ()) - type (:+@#@$$) :: Nat -> (~>) Nat Nat - data (:+@#@$$) a0123456789876543210 a0123456789876543210 - where - (::+@#@$$###) :: Data.Singletons.Internal.SameKind (Apply ((:+@#@$$) a0123456789876543210) arg) ((:+@#@$$$) a0123456789876543210 arg) => - (:+@#@$$) a0123456789876543210 a0123456789876543210 - type instance Apply ((:+@#@$$) a0123456789876543210) a0123456789876543210 = (:+@#@$$$) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((:+@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (::+@#@$$###)) ()) - type (:+@#@$$$) (a0123456789876543210 :: Nat) (a0123456789876543210 :: Nat) = - (:+) a0123456789876543210 a0123456789876543210 :: Nat 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.golden b/tests/compile-and-dump/Promote/Newtypes.golden deleted file mode 100644 --- a/tests/compile-and-dump/Promote/Newtypes.golden +++ /dev/null @@ -1,50 +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 FooSym0 :: (~>) Nat Foo - data FooSym0 a0123456789876543210 - where - FooSym0KindInference :: SameKind (Apply FooSym0 arg) (FooSym1 arg) => - FooSym0 a0123456789876543210 - type instance Apply FooSym0 a0123456789876543210 = FooSym1 a0123456789876543210 - instance SuppressUnusedWarnings FooSym0 where - suppressUnusedWarnings = snd (((,) FooSym0KindInference) ()) - type FooSym1 (a0123456789876543210 :: Nat) = - Foo a0123456789876543210 :: Foo - type BarSym0 :: (~>) Nat Bar - data BarSym0 a0123456789876543210 - where - BarSym0KindInference :: SameKind (Apply BarSym0 arg) (BarSym1 arg) => - BarSym0 a0123456789876543210 - type instance Apply BarSym0 a0123456789876543210 = BarSym1 a0123456789876543210 - instance SuppressUnusedWarnings BarSym0 where - suppressUnusedWarnings = snd (((,) BarSym0KindInference) ()) - type BarSym1 (a0123456789876543210 :: Nat) = - Bar a0123456789876543210 :: Bar - type UnBarSym0 :: (~>) Bar Nat - data UnBarSym0 a0123456789876543210 - where - UnBarSym0KindInference :: SameKind (Apply UnBarSym0 arg) (UnBarSym1 arg) => - UnBarSym0 a0123456789876543210 - type instance Apply UnBarSym0 a0123456789876543210 = UnBarSym1 a0123456789876543210 - instance SuppressUnusedWarnings UnBarSym0 where - suppressUnusedWarnings = snd (((,) UnBarSym0KindInference) ()) - type UnBarSym1 (a0123456789876543210 :: Bar) = - UnBar a0123456789876543210 :: Nat - type UnBar :: Bar -> Nat - type family UnBar a where - UnBar (Bar field) = field - type Equals_0123456789876543210 :: Foo -> Foo -> Bool - type family Equals_0123456789876543210 a b 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 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.golden b/tests/compile-and-dump/Promote/Pragmas.golden deleted file mode 100644 --- a/tests/compile-and-dump/Promote/Pragmas.golden +++ /dev/null @@ -1,13 +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 :: Bool - type Foo :: Bool - type family Foo 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.golden b/tests/compile-and-dump/Promote/Prelude.golden deleted file mode 100644 --- a/tests/compile-and-dump/Promote/Prelude.golden +++ /dev/null @@ -1,20 +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 OddSym0 :: (~>) Nat Bool - data OddSym0 a0123456789876543210 - where - OddSym0KindInference :: SameKind (Apply OddSym0 arg) (OddSym1 arg) => - OddSym0 a0123456789876543210 - type instance Apply OddSym0 a0123456789876543210 = OddSym1 a0123456789876543210 - instance SuppressUnusedWarnings OddSym0 where - suppressUnusedWarnings = snd (((,) OddSym0KindInference) ()) - type OddSym1 (a0123456789876543210 :: Nat) = - Odd a0123456789876543210 :: Bool - type Odd :: Nat -> Bool - type family Odd a 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.golden b/tests/compile-and-dump/Promote/T180.golden deleted file mode 100644 --- a/tests/compile-and-dump/Promote/T180.golden +++ /dev/null @@ -1,55 +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 X1Sym0 :: (~>) Symbol X - data X1Sym0 a0123456789876543210 - where - X1Sym0KindInference :: SameKind (Apply X1Sym0 arg) (X1Sym1 arg) => - X1Sym0 a0123456789876543210 - type instance Apply X1Sym0 a0123456789876543210 = X1Sym1 a0123456789876543210 - instance SuppressUnusedWarnings X1Sym0 where - suppressUnusedWarnings = snd (((,) X1Sym0KindInference) ()) - type X1Sym1 (a0123456789876543210 :: Symbol) = - X1 a0123456789876543210 :: X - type X2Sym0 :: (~>) Symbol X - data X2Sym0 a0123456789876543210 - where - X2Sym0KindInference :: SameKind (Apply X2Sym0 arg) (X2Sym1 arg) => - X2Sym0 a0123456789876543210 - type instance Apply X2Sym0 a0123456789876543210 = X2Sym1 a0123456789876543210 - instance SuppressUnusedWarnings X2Sym0 where - suppressUnusedWarnings = snd (((,) X2Sym0KindInference) ()) - type X2Sym1 (a0123456789876543210 :: Symbol) = - X2 a0123456789876543210 :: X - data ZSym0 a0123456789876543210 - where - ZSym0KindInference :: SameKind (Apply ZSym0 arg) (ZSym1 arg) => - ZSym0 a0123456789876543210 - type instance Apply ZSym0 a0123456789876543210 = ZSym1 a0123456789876543210 - instance SuppressUnusedWarnings ZSym0 where - suppressUnusedWarnings = snd (((,) ZSym0KindInference) ()) - type ZSym1 a0123456789876543210 = Z a0123456789876543210 - type YSym0 :: (~>) X Symbol - data YSym0 a0123456789876543210 - where - YSym0KindInference :: SameKind (Apply YSym0 arg) (YSym1 arg) => - YSym0 a0123456789876543210 - type instance Apply YSym0 a0123456789876543210 = YSym1 a0123456789876543210 - instance SuppressUnusedWarnings YSym0 where - suppressUnusedWarnings = snd (((,) YSym0KindInference) ()) - type YSym1 (a0123456789876543210 :: X) = - Y a0123456789876543210 :: Symbol - type family Z a where - Z (X1 x) = x - Z (X2 x) = x - type Y :: X -> Symbol - type family Y a where - Y (X1 field) = field - Y (X2 field) = field 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.golden b/tests/compile-and-dump/Promote/T361.golden deleted file mode 100644 --- a/tests/compile-and-dump/Promote/T361.golden +++ /dev/null @@ -1,24 +0,0 @@ -Promote/T361.hs:0:0:: Splicing declarations - genDefunSymbols [''Proxy] - ======> - type ProxySym0 = 'Proxy :: Proxy (t :: k) -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 FSym0 :: (~>) (Proxy 1) (Proxy 2) - data FSym0 a0123456789876543210 - where - FSym0KindInference :: SameKind (Apply FSym0 arg) (FSym1 arg) => - FSym0 a0123456789876543210 - type instance Apply FSym0 a0123456789876543210 = FSym1 a0123456789876543210 - instance SuppressUnusedWarnings FSym0 where - suppressUnusedWarnings = snd (((,) FSym0KindInference) ()) - type FSym1 (a0123456789876543210 :: Proxy 1) = - F a0123456789876543210 :: Proxy 2 - type F :: Proxy 1 -> Proxy 2 - type family F a 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.golden b/tests/compile-and-dump/Singletons/AsPattern.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/AsPattern.golden +++ /dev/null @@ -1,381 +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 BazSym0 :: (~>) Nat ((~>) Nat ((~>) Nat Baz)) - data BazSym0 a0123456789876543210 - where - BazSym0KindInference :: SameKind (Apply BazSym0 arg) (BazSym1 arg) => - BazSym0 a0123456789876543210 - type instance Apply BazSym0 a0123456789876543210 = BazSym1 a0123456789876543210 - instance SuppressUnusedWarnings BazSym0 where - suppressUnusedWarnings = snd (((,) BazSym0KindInference) ()) - type BazSym1 :: Nat -> (~>) Nat ((~>) Nat Baz) - data BazSym1 a0123456789876543210 a0123456789876543210 - where - BazSym1KindInference :: SameKind (Apply (BazSym1 a0123456789876543210) arg) (BazSym2 a0123456789876543210 arg) => - BazSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (BazSym1 a0123456789876543210) a0123456789876543210 = BazSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (BazSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) BazSym1KindInference) ()) - type BazSym2 :: Nat -> Nat -> (~>) Nat Baz - data BazSym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - BazSym2KindInference :: SameKind (Apply (BazSym2 a0123456789876543210 a0123456789876543210) arg) (BazSym3 a0123456789876543210 a0123456789876543210 arg) => - BazSym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (BazSym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = BazSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (BazSym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) BazSym2KindInference) ()) - type BazSym3 (a0123456789876543210 :: Nat) (a0123456789876543210 :: Nat) (a0123456789876543210 :: Nat) = - Baz a0123456789876543210 a0123456789876543210 a0123456789876543210 :: Baz - type Let0123456789876543210PSym0 = Let0123456789876543210P - type family Let0123456789876543210P where - Let0123456789876543210P = NilSym0 - data Let0123456789876543210PSym0 wild_01234567898765432100123456789876543210 - where - Let0123456789876543210PSym0KindInference :: SameKind (Apply Let0123456789876543210PSym0 arg) (Let0123456789876543210PSym1 arg) => - Let0123456789876543210PSym0 wild_01234567898765432100123456789876543210 - type instance Apply Let0123456789876543210PSym0 wild_01234567898765432100123456789876543210 = Let0123456789876543210PSym1 wild_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210PSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210PSym0KindInference) ()) - type Let0123456789876543210PSym1 wild_01234567898765432100123456789876543210 = - Let0123456789876543210P wild_01234567898765432100123456789876543210 - type family Let0123456789876543210P wild_0123456789876543210 where - Let0123456789876543210P wild_0123456789876543210 = Apply (Apply (:@#@$) wild_0123456789876543210) NilSym0 - data Let0123456789876543210PSym0 wild_01234567898765432100123456789876543210 - where - Let0123456789876543210PSym0KindInference :: SameKind (Apply Let0123456789876543210PSym0 arg) (Let0123456789876543210PSym1 arg) => - Let0123456789876543210PSym0 wild_01234567898765432100123456789876543210 - type instance Apply Let0123456789876543210PSym0 wild_01234567898765432100123456789876543210 = Let0123456789876543210PSym1 wild_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210PSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210PSym0KindInference) ()) - data Let0123456789876543210PSym1 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 - where - Let0123456789876543210PSym1KindInference :: 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 (Let0123456789876543210PSym1 wild_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210PSym1KindInference) ()) - data Let0123456789876543210PSym2 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 - where - Let0123456789876543210PSym2KindInference :: 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 = Let0123456789876543210PSym3 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210PSym2 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210PSym2KindInference) ()) - type Let0123456789876543210PSym3 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 = - Let0123456789876543210P wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 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) - data Let0123456789876543210PSym0 wild_01234567898765432100123456789876543210 - where - Let0123456789876543210PSym0KindInference :: SameKind (Apply Let0123456789876543210PSym0 arg) (Let0123456789876543210PSym1 arg) => - Let0123456789876543210PSym0 wild_01234567898765432100123456789876543210 - type instance Apply Let0123456789876543210PSym0 wild_01234567898765432100123456789876543210 = Let0123456789876543210PSym1 wild_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210PSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210PSym0KindInference) ()) - data Let0123456789876543210PSym1 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 - where - Let0123456789876543210PSym1KindInference :: 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 (Let0123456789876543210PSym1 wild_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210PSym1KindInference) ()) - type Let0123456789876543210PSym2 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 = - Let0123456789876543210P wild_01234567898765432100123456789876543210 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 - data Let0123456789876543210PSym0 wild_01234567898765432100123456789876543210 - where - Let0123456789876543210PSym0KindInference :: SameKind (Apply Let0123456789876543210PSym0 arg) (Let0123456789876543210PSym1 arg) => - Let0123456789876543210PSym0 wild_01234567898765432100123456789876543210 - type instance Apply Let0123456789876543210PSym0 wild_01234567898765432100123456789876543210 = Let0123456789876543210PSym1 wild_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210PSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210PSym0KindInference) ()) - data Let0123456789876543210PSym1 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 - where - Let0123456789876543210PSym1KindInference :: 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 (Let0123456789876543210PSym1 wild_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210PSym1KindInference) ()) - data Let0123456789876543210PSym2 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 - where - Let0123456789876543210PSym2KindInference :: 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 = Let0123456789876543210PSym3 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210PSym2 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210PSym2KindInference) ()) - type Let0123456789876543210PSym3 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 = - Let0123456789876543210P wild_01234567898765432100123456789876543210 wild_01234567898765432100123456789876543210 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) - data Let0123456789876543210XSym0 wild_01234567898765432100123456789876543210 - where - Let0123456789876543210XSym0KindInference :: SameKind (Apply Let0123456789876543210XSym0 arg) (Let0123456789876543210XSym1 arg) => - Let0123456789876543210XSym0 wild_01234567898765432100123456789876543210 - type instance Apply Let0123456789876543210XSym0 wild_01234567898765432100123456789876543210 = Let0123456789876543210XSym1 wild_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210XSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210XSym0KindInference) ()) - type Let0123456789876543210XSym1 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 FooSym0 :: (~>) [Nat] [Nat] - data FooSym0 a0123456789876543210 - where - FooSym0KindInference :: SameKind (Apply FooSym0 arg) (FooSym1 arg) => - FooSym0 a0123456789876543210 - type instance Apply FooSym0 a0123456789876543210 = FooSym1 a0123456789876543210 - instance SuppressUnusedWarnings FooSym0 where - suppressUnusedWarnings = snd (((,) FooSym0KindInference) ()) - type FooSym1 (a0123456789876543210 :: [Nat]) = - Foo a0123456789876543210 :: [Nat] - type TupSym0 :: (~>) (Nat, Nat) (Nat, Nat) - data TupSym0 a0123456789876543210 - where - TupSym0KindInference :: SameKind (Apply TupSym0 arg) (TupSym1 arg) => - TupSym0 a0123456789876543210 - type instance Apply TupSym0 a0123456789876543210 = TupSym1 a0123456789876543210 - instance SuppressUnusedWarnings TupSym0 where - suppressUnusedWarnings = snd (((,) TupSym0KindInference) ()) - type TupSym1 (a0123456789876543210 :: (Nat, Nat)) = - Tup a0123456789876543210 :: (Nat, Nat) - type Baz_Sym0 :: (~>) (Maybe Baz) (Maybe Baz) - data Baz_Sym0 a0123456789876543210 - where - Baz_Sym0KindInference :: SameKind (Apply Baz_Sym0 arg) (Baz_Sym1 arg) => - Baz_Sym0 a0123456789876543210 - type instance Apply Baz_Sym0 a0123456789876543210 = Baz_Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Baz_Sym0 where - suppressUnusedWarnings = snd (((,) Baz_Sym0KindInference) ()) - type Baz_Sym1 (a0123456789876543210 :: Maybe Baz) = - Baz_ a0123456789876543210 :: Maybe Baz - type BarSym0 :: (~>) (Maybe Nat) (Maybe Nat) - data BarSym0 a0123456789876543210 - where - BarSym0KindInference :: SameKind (Apply BarSym0 arg) (BarSym1 arg) => - BarSym0 a0123456789876543210 - type instance Apply BarSym0 a0123456789876543210 = BarSym1 a0123456789876543210 - instance SuppressUnusedWarnings BarSym0 where - suppressUnusedWarnings = snd (((,) BarSym0KindInference) ()) - type BarSym1 (a0123456789876543210 :: Maybe Nat) = - Bar a0123456789876543210 :: Maybe Nat - type MaybePlusSym0 :: (~>) (Maybe Nat) (Maybe Nat) - data MaybePlusSym0 a0123456789876543210 - where - MaybePlusSym0KindInference :: SameKind (Apply MaybePlusSym0 arg) (MaybePlusSym1 arg) => - MaybePlusSym0 a0123456789876543210 - type instance Apply MaybePlusSym0 a0123456789876543210 = MaybePlusSym1 a0123456789876543210 - instance SuppressUnusedWarnings MaybePlusSym0 where - suppressUnusedWarnings = snd (((,) MaybePlusSym0KindInference) ()) - type MaybePlusSym1 (a0123456789876543210 :: Maybe Nat) = - MaybePlus a0123456789876543210 :: Maybe Nat - type Foo :: [Nat] -> [Nat] - type family Foo a where - Foo '[] = Let0123456789876543210PSym0 - Foo '[wild_0123456789876543210] = Let0123456789876543210PSym1 wild_0123456789876543210 - Foo ('(:) wild_0123456789876543210 ('(:) wild_0123456789876543210 wild_0123456789876543210)) = Let0123456789876543210PSym3 wild_0123456789876543210 wild_0123456789876543210 wild_0123456789876543210 - type Tup :: (Nat, Nat) -> (Nat, Nat) - type family Tup a where - Tup '(wild_0123456789876543210, - wild_0123456789876543210) = Let0123456789876543210PSym2 wild_0123456789876543210 wild_0123456789876543210 - type Baz_ :: Maybe Baz -> Maybe Baz - type family Baz_ a where - Baz_ 'Nothing = Let0123456789876543210PSym0 - Baz_ ('Just (Baz wild_0123456789876543210 wild_0123456789876543210 wild_0123456789876543210)) = Let0123456789876543210PSym3 wild_0123456789876543210 wild_0123456789876543210 wild_0123456789876543210 - type Bar :: Maybe Nat -> Maybe Nat - type family Bar a where - Bar ('Just wild_0123456789876543210) = Let0123456789876543210XSym1 wild_0123456789876543210 - Bar 'Nothing = NothingSym0 - type MaybePlus :: Maybe Nat -> Maybe Nat - type family MaybePlus a 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) -> (Sing n) -> (Sing n) -> SBaz (Baz n n n :: Baz) - 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.golden b/tests/compile-and-dump/Singletons/BadBoundedDeriving.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/BadBoundedDeriving.golden +++ /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.golden b/tests/compile-and-dump/Singletons/BadEnumDeriving.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/BadEnumDeriving.golden +++ /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.golden b/tests/compile-and-dump/Singletons/BoundedDeriving.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/BoundedDeriving.golden +++ /dev/null @@ -1,253 +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 :: Foo1 - type ASym0 = A :: Foo2 - type BSym0 = B :: Foo2 - type CSym0 = C :: Foo2 - type DSym0 = D :: Foo2 - type ESym0 = E :: Foo2 - type Foo3Sym0 :: forall a. (~>) a (Foo3 a) - data Foo3Sym0 a0123456789876543210 - where - Foo3Sym0KindInference :: SameKind (Apply Foo3Sym0 arg) (Foo3Sym1 arg) => - Foo3Sym0 a0123456789876543210 - type instance Apply Foo3Sym0 a0123456789876543210 = Foo3Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo3Sym0 where - suppressUnusedWarnings = snd (((,) Foo3Sym0KindInference) ()) - type Foo3Sym1 (a0123456789876543210 :: a) = - Foo3 a0123456789876543210 :: Foo3 a - type Foo41Sym0 = Foo41 :: Foo4 (a :: Type) (b :: Type) - type Foo42Sym0 = Foo42 :: Foo4 (a :: Type) (b :: Type) - type PairSym0 :: (~>) Bool ((~>) Bool Pair) - data PairSym0 a0123456789876543210 - where - PairSym0KindInference :: SameKind (Apply PairSym0 arg) (PairSym1 arg) => - PairSym0 a0123456789876543210 - type instance Apply PairSym0 a0123456789876543210 = PairSym1 a0123456789876543210 - instance SuppressUnusedWarnings PairSym0 where - suppressUnusedWarnings = snd (((,) PairSym0KindInference) ()) - type PairSym1 :: Bool -> (~>) Bool Pair - data PairSym1 a0123456789876543210 a0123456789876543210 - where - PairSym1KindInference :: SameKind (Apply (PairSym1 a0123456789876543210) arg) (PairSym2 a0123456789876543210 arg) => - PairSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (PairSym1 a0123456789876543210) a0123456789876543210 = PairSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (PairSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) PairSym1KindInference) ()) - type PairSym2 (a0123456789876543210 :: Bool) (a0123456789876543210 :: Bool) = - Pair a0123456789876543210 a0123456789876543210 :: Pair - type MinBound_0123456789876543210 :: Foo1 - type family MinBound_0123456789876543210 where - MinBound_0123456789876543210 = Foo1Sym0 - type MinBound_0123456789876543210Sym0 = - MinBound_0123456789876543210 :: Foo1 - type MaxBound_0123456789876543210 :: Foo1 - type family MaxBound_0123456789876543210 where - MaxBound_0123456789876543210 = Foo1Sym0 - type MaxBound_0123456789876543210Sym0 = - MaxBound_0123456789876543210 :: Foo1 - instance PBounded Foo1 where - type MinBound = MinBound_0123456789876543210Sym0 - type MaxBound = MaxBound_0123456789876543210Sym0 - type MinBound_0123456789876543210 :: Foo2 - type family MinBound_0123456789876543210 where - MinBound_0123456789876543210 = ASym0 - type MinBound_0123456789876543210Sym0 = - MinBound_0123456789876543210 :: Foo2 - type MaxBound_0123456789876543210 :: Foo2 - type family MaxBound_0123456789876543210 where - MaxBound_0123456789876543210 = ESym0 - type MaxBound_0123456789876543210Sym0 = - MaxBound_0123456789876543210 :: Foo2 - instance PBounded Foo2 where - type MinBound = MinBound_0123456789876543210Sym0 - type MaxBound = MaxBound_0123456789876543210Sym0 - type MinBound_0123456789876543210 :: Foo3 a - type family MinBound_0123456789876543210 where - MinBound_0123456789876543210 = Apply Foo3Sym0 MinBoundSym0 - type MinBound_0123456789876543210Sym0 = - MinBound_0123456789876543210 :: Foo3 a - type MaxBound_0123456789876543210 :: Foo3 a - type family MaxBound_0123456789876543210 where - MaxBound_0123456789876543210 = Apply Foo3Sym0 MaxBoundSym0 - type MaxBound_0123456789876543210Sym0 = - MaxBound_0123456789876543210 :: Foo3 a - instance PBounded (Foo3 a) where - type MinBound = MinBound_0123456789876543210Sym0 - type MaxBound = MaxBound_0123456789876543210Sym0 - type MinBound_0123456789876543210 :: Foo4 a b - type family MinBound_0123456789876543210 where - MinBound_0123456789876543210 = Foo41Sym0 - type MinBound_0123456789876543210Sym0 = - MinBound_0123456789876543210 :: Foo4 a b - type MaxBound_0123456789876543210 :: Foo4 a b - type family MaxBound_0123456789876543210 where - MaxBound_0123456789876543210 = Foo42Sym0 - type MaxBound_0123456789876543210Sym0 = - MaxBound_0123456789876543210 :: Foo4 a b - instance PBounded (Foo4 a b) where - type MinBound = MinBound_0123456789876543210Sym0 - type MaxBound = MaxBound_0123456789876543210Sym0 - type MinBound_0123456789876543210 :: Pair - type family MinBound_0123456789876543210 where - MinBound_0123456789876543210 = Apply (Apply PairSym0 MinBoundSym0) MinBoundSym0 - type MinBound_0123456789876543210Sym0 = - MinBound_0123456789876543210 :: Pair - type MaxBound_0123456789876543210 :: Pair - type family MaxBound_0123456789876543210 where - MaxBound_0123456789876543210 = Apply (Apply PairSym0 MaxBoundSym0) MaxBoundSym0 - type MaxBound_0123456789876543210Sym0 = - MaxBound_0123456789876543210 :: Pair - instance PBounded Pair where - type MinBound = MinBound_0123456789876543210Sym0 - type MaxBound = MaxBound_0123456789876543210Sym0 - data SFoo1 :: Foo1 -> Type where SFoo1 :: SFoo1 (Foo1 :: 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 :: Foo2) - SB :: SFoo2 (B :: Foo2) - SC :: SFoo2 (C :: Foo2) - SD :: SFoo2 (D :: Foo2) - SE :: SFoo2 (E :: Foo2) - 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) -> SFoo3 (Foo3 n :: Foo3 a) - 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 :: Type) (b :: Type) -> Type - where - SFoo41 :: forall (a :: Type) (b :: Type). - SFoo4 (Foo41 :: Foo4 (a :: Type) (b :: Type)) - SFoo42 :: forall (a :: Type) (b :: Type). - SFoo4 (Foo42 :: Foo4 (a :: Type) (b :: Type)) - 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) -> (Sing n) -> SPair (Pair n n :: Pair) - 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.golden b/tests/compile-and-dump/Singletons/BoxUnBox.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/BoxUnBox.golden +++ /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 FBoxSym0 :: forall a. (~>) a (Box a) - data FBoxSym0 a0123456789876543210 - where - FBoxSym0KindInference :: SameKind (Apply FBoxSym0 arg) (FBoxSym1 arg) => - FBoxSym0 a0123456789876543210 - type instance Apply FBoxSym0 a0123456789876543210 = FBoxSym1 a0123456789876543210 - instance SuppressUnusedWarnings FBoxSym0 where - suppressUnusedWarnings = snd (((,) FBoxSym0KindInference) ()) - type FBoxSym1 (a0123456789876543210 :: a) = - FBox a0123456789876543210 :: Box a - type UnBoxSym0 :: (~>) (Box a) a - data UnBoxSym0 a0123456789876543210 - where - UnBoxSym0KindInference :: SameKind (Apply UnBoxSym0 arg) (UnBoxSym1 arg) => - UnBoxSym0 a0123456789876543210 - type instance Apply UnBoxSym0 a0123456789876543210 = UnBoxSym1 a0123456789876543210 - instance SuppressUnusedWarnings UnBoxSym0 where - suppressUnusedWarnings = snd (((,) UnBoxSym0KindInference) ()) - type UnBoxSym1 (a0123456789876543210 :: Box a) = - UnBox a0123456789876543210 :: a - type UnBox :: Box a -> a - type family UnBox 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) -> SBox (FBox n :: Box a) - 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.golden b/tests/compile-and-dump/Singletons/CaseExpressions.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/CaseExpressions.golden +++ /dev/null @@ -1,307 +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 arg_0123456789876543210 where - Lambda_0123456789876543210 y x arg_0123456789876543210 = Case_0123456789876543210 arg_0123456789876543210 y x arg_0123456789876543210 - data Lambda_0123456789876543210Sym0 y0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 y0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 y0123456789876543210 = Lambda_0123456789876543210Sym1 y0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 y0123456789876543210 x0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 y0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 y0123456789876543210 x0123456789876543210 arg_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym2 y0123456789876543210 x0123456789876543210) arg) (Lambda_0123456789876543210Sym3 y0123456789876543210 x0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 y0123456789876543210 x0123456789876543210 arg_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 y0123456789876543210 x0123456789876543210) arg_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym3 y0123456789876543210 x0123456789876543210 arg_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 y0123456789876543210 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - type Lambda_0123456789876543210Sym3 y0123456789876543210 x0123456789876543210 arg_01234567898765432100123456789876543210 = - Lambda_0123456789876543210 y0123456789876543210 x0123456789876543210 arg_01234567898765432100123456789876543210 - type family Case_0123456789876543210 x t where - Case_0123456789876543210 x y = Apply (Apply (Apply Lambda_0123456789876543210Sym0 y) x) y - data Let0123456789876543210ZSym0 y0123456789876543210 - where - Let0123456789876543210ZSym0KindInference :: SameKind (Apply Let0123456789876543210ZSym0 arg) (Let0123456789876543210ZSym1 arg) => - Let0123456789876543210ZSym0 y0123456789876543210 - type instance Apply Let0123456789876543210ZSym0 y0123456789876543210 = Let0123456789876543210ZSym1 y0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210ZSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210ZSym0KindInference) ()) - data Let0123456789876543210ZSym1 y0123456789876543210 x0123456789876543210 - where - Let0123456789876543210ZSym1KindInference :: SameKind (Apply (Let0123456789876543210ZSym1 y0123456789876543210) arg) (Let0123456789876543210ZSym2 y0123456789876543210 arg) => - Let0123456789876543210ZSym1 y0123456789876543210 x0123456789876543210 - type instance Apply (Let0123456789876543210ZSym1 y0123456789876543210) x0123456789876543210 = Let0123456789876543210ZSym2 y0123456789876543210 x0123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210ZSym1 y0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210ZSym1KindInference) ()) - type Let0123456789876543210ZSym2 y0123456789876543210 x0123456789876543210 = - Let0123456789876543210Z y0123456789876543210 x0123456789876543210 :: a0123456789876543210 - 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 - data Let0123456789876543210Scrutinee_0123456789876543210Sym0 a0123456789876543210 - where - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference :: SameKind (Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 arg) (Let0123456789876543210Scrutinee_0123456789876543210Sym1 arg) => - Let0123456789876543210Scrutinee_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 a0123456789876543210 = Let0123456789876543210Scrutinee_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210Scrutinee_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd - (((,) - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference) - ()) - data Let0123456789876543210Scrutinee_0123456789876543210Sym1 a0123456789876543210 b0123456789876543210 - where - Let0123456789876543210Scrutinee_0123456789876543210Sym1KindInference :: SameKind (Apply (Let0123456789876543210Scrutinee_0123456789876543210Sym1 a0123456789876543210) arg) (Let0123456789876543210Scrutinee_0123456789876543210Sym2 a0123456789876543210 arg) => - Let0123456789876543210Scrutinee_0123456789876543210Sym1 a0123456789876543210 b0123456789876543210 - type instance Apply (Let0123456789876543210Scrutinee_0123456789876543210Sym1 a0123456789876543210) b0123456789876543210 = Let0123456789876543210Scrutinee_0123456789876543210Sym2 a0123456789876543210 b0123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210Scrutinee_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd - (((,) - Let0123456789876543210Scrutinee_0123456789876543210Sym1KindInference) - ()) - type Let0123456789876543210Scrutinee_0123456789876543210Sym2 a0123456789876543210 b0123456789876543210 = - Let0123456789876543210Scrutinee_0123456789876543210 a0123456789876543210 b0123456789876543210 - 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 - data Let0123456789876543210Scrutinee_0123456789876543210Sym0 d0123456789876543210 - where - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference :: SameKind (Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 arg) (Let0123456789876543210Scrutinee_0123456789876543210Sym1 arg) => - Let0123456789876543210Scrutinee_0123456789876543210Sym0 d0123456789876543210 - type instance Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 d0123456789876543210 = Let0123456789876543210Scrutinee_0123456789876543210Sym1 d0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210Scrutinee_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd - (((,) - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference) - ()) - type Let0123456789876543210Scrutinee_0123456789876543210Sym1 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 Foo5Sym0 :: (~>) a a - data Foo5Sym0 a0123456789876543210 - where - Foo5Sym0KindInference :: SameKind (Apply Foo5Sym0 arg) (Foo5Sym1 arg) => - Foo5Sym0 a0123456789876543210 - type instance Apply Foo5Sym0 a0123456789876543210 = Foo5Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo5Sym0 where - suppressUnusedWarnings = snd (((,) Foo5Sym0KindInference) ()) - type Foo5Sym1 (a0123456789876543210 :: a) = - Foo5 a0123456789876543210 :: a - type Foo4Sym0 :: forall a. (~>) a a - data Foo4Sym0 a0123456789876543210 - where - Foo4Sym0KindInference :: SameKind (Apply Foo4Sym0 arg) (Foo4Sym1 arg) => - Foo4Sym0 a0123456789876543210 - type instance Apply Foo4Sym0 a0123456789876543210 = Foo4Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo4Sym0 where - suppressUnusedWarnings = snd (((,) Foo4Sym0KindInference) ()) - type Foo4Sym1 (a0123456789876543210 :: a) = - Foo4 a0123456789876543210 :: a - type Foo3Sym0 :: (~>) a ((~>) b a) - data Foo3Sym0 a0123456789876543210 - where - Foo3Sym0KindInference :: SameKind (Apply Foo3Sym0 arg) (Foo3Sym1 arg) => - Foo3Sym0 a0123456789876543210 - type instance Apply Foo3Sym0 a0123456789876543210 = Foo3Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo3Sym0 where - suppressUnusedWarnings = snd (((,) Foo3Sym0KindInference) ()) - type Foo3Sym1 :: a -> (~>) b a - data Foo3Sym1 a0123456789876543210 a0123456789876543210 - where - Foo3Sym1KindInference :: SameKind (Apply (Foo3Sym1 a0123456789876543210) arg) (Foo3Sym2 a0123456789876543210 arg) => - Foo3Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Foo3Sym1 a0123456789876543210) a0123456789876543210 = Foo3Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Foo3Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) Foo3Sym1KindInference) ()) - type Foo3Sym2 (a0123456789876543210 :: a) (a0123456789876543210 :: b) = - Foo3 a0123456789876543210 a0123456789876543210 :: a - type Foo2Sym0 :: (~>) a ((~>) (Maybe a) a) - data Foo2Sym0 a0123456789876543210 - where - Foo2Sym0KindInference :: SameKind (Apply Foo2Sym0 arg) (Foo2Sym1 arg) => - Foo2Sym0 a0123456789876543210 - type instance Apply Foo2Sym0 a0123456789876543210 = Foo2Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo2Sym0 where - suppressUnusedWarnings = snd (((,) Foo2Sym0KindInference) ()) - type Foo2Sym1 :: a -> (~>) (Maybe a) a - data Foo2Sym1 a0123456789876543210 a0123456789876543210 - where - Foo2Sym1KindInference :: SameKind (Apply (Foo2Sym1 a0123456789876543210) arg) (Foo2Sym2 a0123456789876543210 arg) => - Foo2Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Foo2Sym1 a0123456789876543210) a0123456789876543210 = Foo2Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Foo2Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) Foo2Sym1KindInference) ()) - type Foo2Sym2 (a0123456789876543210 :: a) (a0123456789876543210 :: Maybe a) = - Foo2 a0123456789876543210 a0123456789876543210 :: a - type Foo1Sym0 :: (~>) a ((~>) (Maybe a) a) - data Foo1Sym0 a0123456789876543210 - where - Foo1Sym0KindInference :: SameKind (Apply Foo1Sym0 arg) (Foo1Sym1 arg) => - Foo1Sym0 a0123456789876543210 - type instance Apply Foo1Sym0 a0123456789876543210 = Foo1Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo1Sym0 where - suppressUnusedWarnings = snd (((,) Foo1Sym0KindInference) ()) - type Foo1Sym1 :: a -> (~>) (Maybe a) a - data Foo1Sym1 a0123456789876543210 a0123456789876543210 - where - Foo1Sym1KindInference :: SameKind (Apply (Foo1Sym1 a0123456789876543210) arg) (Foo1Sym2 a0123456789876543210 arg) => - Foo1Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Foo1Sym1 a0123456789876543210) a0123456789876543210 = Foo1Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Foo1Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) Foo1Sym1KindInference) ()) - type Foo1Sym2 (a0123456789876543210 :: a) (a0123456789876543210 :: Maybe a) = - Foo1 a0123456789876543210 a0123456789876543210 :: a - type Foo5 :: a -> a - type family Foo5 a where - Foo5 x = Case_0123456789876543210 x x - type Foo4 :: forall a. a -> a - type family Foo4 a where - Foo4 x = Case_0123456789876543210 x x - type Foo3 :: a -> b -> a - type family Foo3 a a where - Foo3 a b = Case_0123456789876543210 a b (Let0123456789876543210Scrutinee_0123456789876543210Sym2 a b) - type Foo2 :: a -> Maybe a -> a - type family Foo2 a a where - Foo2 d _ = Case_0123456789876543210 d (Let0123456789876543210Scrutinee_0123456789876543210Sym1 d) - type Foo1 :: a -> Maybe a -> a - type family Foo1 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.golden b/tests/compile-and-dump/Singletons/Classes.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Classes.golden +++ /dev/null @@ -1,571 +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 :: Foo - type BSym0 = B :: Foo - type FSym0 = F :: Foo2 - type GSym0 = G :: Foo2 - type FooCompareSym0 :: (~>) Foo ((~>) Foo Ordering) - data FooCompareSym0 a0123456789876543210 - where - FooCompareSym0KindInference :: SameKind (Apply FooCompareSym0 arg) (FooCompareSym1 arg) => - FooCompareSym0 a0123456789876543210 - type instance Apply FooCompareSym0 a0123456789876543210 = FooCompareSym1 a0123456789876543210 - instance SuppressUnusedWarnings FooCompareSym0 where - suppressUnusedWarnings = snd (((,) FooCompareSym0KindInference) ()) - type FooCompareSym1 :: Foo -> (~>) Foo Ordering - data FooCompareSym1 a0123456789876543210 a0123456789876543210 - where - FooCompareSym1KindInference :: SameKind (Apply (FooCompareSym1 a0123456789876543210) arg) (FooCompareSym2 a0123456789876543210 arg) => - FooCompareSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (FooCompareSym1 a0123456789876543210) a0123456789876543210 = FooCompareSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (FooCompareSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) FooCompareSym1KindInference) ()) - type FooCompareSym2 (a0123456789876543210 :: Foo) (a0123456789876543210 :: Foo) = - FooCompare a0123456789876543210 a0123456789876543210 :: Ordering - type ConstSym0 :: (~>) a ((~>) b a) - data ConstSym0 a0123456789876543210 - where - ConstSym0KindInference :: SameKind (Apply ConstSym0 arg) (ConstSym1 arg) => - ConstSym0 a0123456789876543210 - type instance Apply ConstSym0 a0123456789876543210 = ConstSym1 a0123456789876543210 - instance SuppressUnusedWarnings ConstSym0 where - suppressUnusedWarnings = snd (((,) ConstSym0KindInference) ()) - type ConstSym1 :: a -> (~>) b a - data ConstSym1 a0123456789876543210 a0123456789876543210 - where - ConstSym1KindInference :: SameKind (Apply (ConstSym1 a0123456789876543210) arg) (ConstSym2 a0123456789876543210 arg) => - ConstSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (ConstSym1 a0123456789876543210) a0123456789876543210 = ConstSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ConstSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) ConstSym1KindInference) ()) - type ConstSym2 (a0123456789876543210 :: a) (a0123456789876543210 :: b) = - Const a0123456789876543210 a0123456789876543210 :: a - type FooCompare :: Foo -> Foo -> Ordering - type family FooCompare a a where - FooCompare A A = EQSym0 - FooCompare A B = LTSym0 - FooCompare B B = GTSym0 - FooCompare B A = EQSym0 - type Const :: a -> b -> a - type family Const a a where - Const x _ = x - type MycompareSym0 :: forall a. (~>) a ((~>) a Ordering) - data MycompareSym0 a0123456789876543210 - where - MycompareSym0KindInference :: SameKind (Apply MycompareSym0 arg) (MycompareSym1 arg) => - MycompareSym0 a0123456789876543210 - type instance Apply MycompareSym0 a0123456789876543210 = MycompareSym1 a0123456789876543210 - instance SuppressUnusedWarnings MycompareSym0 where - suppressUnusedWarnings = snd (((,) MycompareSym0KindInference) ()) - type MycompareSym1 :: forall a. a -> (~>) a Ordering - data MycompareSym1 a0123456789876543210 a0123456789876543210 - where - MycompareSym1KindInference :: SameKind (Apply (MycompareSym1 a0123456789876543210) arg) (MycompareSym2 a0123456789876543210 arg) => - MycompareSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (MycompareSym1 a0123456789876543210) a0123456789876543210 = MycompareSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (MycompareSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) MycompareSym1KindInference) ()) - type MycompareSym2 (a0123456789876543210 :: a) (a0123456789876543210 :: a) = - Mycompare a0123456789876543210 a0123456789876543210 :: Ordering - type (<=>@#@$) :: forall a. (~>) a ((~>) a Ordering) - data (<=>@#@$) a0123456789876543210 - where - (:<=>@#@$###) :: SameKind (Apply (<=>@#@$) arg) ((<=>@#@$$) arg) => - (<=>@#@$) a0123456789876543210 - type instance Apply (<=>@#@$) a0123456789876543210 = (<=>@#@$$) a0123456789876543210 - instance SuppressUnusedWarnings (<=>@#@$) where - suppressUnusedWarnings = snd (((,) (:<=>@#@$###)) ()) - infix 4 <=>@#@$ - type (<=>@#@$$) :: forall a. a -> (~>) a Ordering - data (<=>@#@$$) a0123456789876543210 a0123456789876543210 - where - (:<=>@#@$$###) :: SameKind (Apply ((<=>@#@$$) a0123456789876543210) arg) ((<=>@#@$$$) a0123456789876543210 arg) => - (<=>@#@$$) a0123456789876543210 a0123456789876543210 - type instance Apply ((<=>@#@$$) a0123456789876543210) a0123456789876543210 = (<=>@#@$$$) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((<=>@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (:<=>@#@$$###)) ()) - infix 4 <=>@#@$$ - type (<=>@#@$$$) (a0123456789876543210 :: a) (a0123456789876543210 :: a) = - (<=>) a0123456789876543210 a0123456789876543210 :: Ordering - infix 4 <=>@#@$$$ - type TFHelper_0123456789876543210 :: a -> a -> Ordering - type family TFHelper_0123456789876543210 a a where - TFHelper_0123456789876543210 a_0123456789876543210 a_0123456789876543210 = Apply (Apply MycompareSym0 a_0123456789876543210) a_0123456789876543210 - type TFHelper_0123456789876543210Sym0 :: (~>) a ((~>) a Ordering) - data TFHelper_0123456789876543210Sym0 a0123456789876543210 - where - TFHelper_0123456789876543210Sym0KindInference :: SameKind (Apply TFHelper_0123456789876543210Sym0 arg) (TFHelper_0123456789876543210Sym1 arg) => - TFHelper_0123456789876543210Sym0 a0123456789876543210 - type instance Apply TFHelper_0123456789876543210Sym0 a0123456789876543210 = TFHelper_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings TFHelper_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) TFHelper_0123456789876543210Sym0KindInference) ()) - type TFHelper_0123456789876543210Sym1 :: a -> (~>) a Ordering - data TFHelper_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - TFHelper_0123456789876543210Sym1KindInference :: SameKind (Apply (TFHelper_0123456789876543210Sym1 a0123456789876543210) arg) (TFHelper_0123456789876543210Sym2 a0123456789876543210 arg) => - TFHelper_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (TFHelper_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = TFHelper_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (TFHelper_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) TFHelper_0123456789876543210Sym1KindInference) ()) - type TFHelper_0123456789876543210Sym2 (a0123456789876543210 :: a) (a0123456789876543210 :: a) = - TFHelper_0123456789876543210 a0123456789876543210 a0123456789876543210 :: Ordering - class PMyOrd a where - type Mycompare (arg :: a) (arg :: a) :: Ordering - type (<=>) (arg :: a) (arg :: a) :: Ordering - type (<=>) a a = Apply (Apply TFHelper_0123456789876543210Sym0 a) a - type Mycompare_0123456789876543210 :: Nat -> Nat -> Ordering - type family Mycompare_0123456789876543210 a a 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_0123456789876543210Sym0 :: (~>) Nat ((~>) Nat Ordering) - data Mycompare_0123456789876543210Sym0 a0123456789876543210 - where - Mycompare_0123456789876543210Sym0KindInference :: SameKind (Apply Mycompare_0123456789876543210Sym0 arg) (Mycompare_0123456789876543210Sym1 arg) => - Mycompare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Mycompare_0123456789876543210Sym0 a0123456789876543210 = Mycompare_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Mycompare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Mycompare_0123456789876543210Sym0KindInference) ()) - type Mycompare_0123456789876543210Sym1 :: Nat -> (~>) Nat Ordering - data Mycompare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - Mycompare_0123456789876543210Sym1KindInference :: SameKind (Apply (Mycompare_0123456789876543210Sym1 a0123456789876543210) arg) (Mycompare_0123456789876543210Sym2 a0123456789876543210 arg) => - Mycompare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Mycompare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Mycompare_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Mycompare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Mycompare_0123456789876543210Sym1KindInference) ()) - type Mycompare_0123456789876543210Sym2 (a0123456789876543210 :: Nat) (a0123456789876543210 :: Nat) = - Mycompare_0123456789876543210 a0123456789876543210 a0123456789876543210 :: Ordering - instance PMyOrd Nat where - type Mycompare a a = Apply (Apply Mycompare_0123456789876543210Sym0 a) a - type Mycompare_0123456789876543210 :: () -> () -> Ordering - type family Mycompare_0123456789876543210 a a where - Mycompare_0123456789876543210 _ a_0123456789876543210 = Apply (Apply ConstSym0 EQSym0) a_0123456789876543210 - type Mycompare_0123456789876543210Sym0 :: (~>) () ((~>) () Ordering) - data Mycompare_0123456789876543210Sym0 a0123456789876543210 - where - Mycompare_0123456789876543210Sym0KindInference :: SameKind (Apply Mycompare_0123456789876543210Sym0 arg) (Mycompare_0123456789876543210Sym1 arg) => - Mycompare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Mycompare_0123456789876543210Sym0 a0123456789876543210 = Mycompare_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Mycompare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Mycompare_0123456789876543210Sym0KindInference) ()) - type Mycompare_0123456789876543210Sym1 :: () -> (~>) () Ordering - data Mycompare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - Mycompare_0123456789876543210Sym1KindInference :: SameKind (Apply (Mycompare_0123456789876543210Sym1 a0123456789876543210) arg) (Mycompare_0123456789876543210Sym2 a0123456789876543210 arg) => - Mycompare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Mycompare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Mycompare_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Mycompare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Mycompare_0123456789876543210Sym1KindInference) ()) - type Mycompare_0123456789876543210Sym2 (a0123456789876543210 :: ()) (a0123456789876543210 :: ()) = - Mycompare_0123456789876543210 a0123456789876543210 a0123456789876543210 :: Ordering - instance PMyOrd () where - type Mycompare a a = Apply (Apply Mycompare_0123456789876543210Sym0 a) a - type Mycompare_0123456789876543210 :: Foo -> Foo -> Ordering - type family Mycompare_0123456789876543210 a a where - Mycompare_0123456789876543210 a_0123456789876543210 a_0123456789876543210 = Apply (Apply FooCompareSym0 a_0123456789876543210) a_0123456789876543210 - type Mycompare_0123456789876543210Sym0 :: (~>) Foo ((~>) Foo Ordering) - data Mycompare_0123456789876543210Sym0 a0123456789876543210 - where - Mycompare_0123456789876543210Sym0KindInference :: SameKind (Apply Mycompare_0123456789876543210Sym0 arg) (Mycompare_0123456789876543210Sym1 arg) => - Mycompare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Mycompare_0123456789876543210Sym0 a0123456789876543210 = Mycompare_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Mycompare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Mycompare_0123456789876543210Sym0KindInference) ()) - type Mycompare_0123456789876543210Sym1 :: Foo -> (~>) Foo Ordering - data Mycompare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - Mycompare_0123456789876543210Sym1KindInference :: SameKind (Apply (Mycompare_0123456789876543210Sym1 a0123456789876543210) arg) (Mycompare_0123456789876543210Sym2 a0123456789876543210 arg) => - Mycompare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Mycompare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Mycompare_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Mycompare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Mycompare_0123456789876543210Sym1KindInference) ()) - type Mycompare_0123456789876543210Sym2 (a0123456789876543210 :: Foo) (a0123456789876543210 :: Foo) = - Mycompare_0123456789876543210 a0123456789876543210 a0123456789876543210 :: Ordering - instance PMyOrd Foo where - type Mycompare a a = Apply (Apply Mycompare_0123456789876543210Sym0 a) a - type TFHelper_0123456789876543210 :: Foo2 -> Foo2 -> Bool - type family TFHelper_0123456789876543210 a a where - TFHelper_0123456789876543210 F F = TrueSym0 - TFHelper_0123456789876543210 G G = TrueSym0 - TFHelper_0123456789876543210 F G = FalseSym0 - TFHelper_0123456789876543210 G F = FalseSym0 - type TFHelper_0123456789876543210Sym0 :: (~>) Foo2 ((~>) Foo2 Bool) - data TFHelper_0123456789876543210Sym0 a0123456789876543210 - where - TFHelper_0123456789876543210Sym0KindInference :: SameKind (Apply TFHelper_0123456789876543210Sym0 arg) (TFHelper_0123456789876543210Sym1 arg) => - TFHelper_0123456789876543210Sym0 a0123456789876543210 - type instance Apply TFHelper_0123456789876543210Sym0 a0123456789876543210 = TFHelper_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings TFHelper_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) TFHelper_0123456789876543210Sym0KindInference) ()) - type TFHelper_0123456789876543210Sym1 :: Foo2 -> (~>) Foo2 Bool - data TFHelper_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - TFHelper_0123456789876543210Sym1KindInference :: SameKind (Apply (TFHelper_0123456789876543210Sym1 a0123456789876543210) arg) (TFHelper_0123456789876543210Sym2 a0123456789876543210 arg) => - TFHelper_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (TFHelper_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = TFHelper_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (TFHelper_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) TFHelper_0123456789876543210Sym1KindInference) ()) - type TFHelper_0123456789876543210Sym2 (a0123456789876543210 :: Foo2) (a0123456789876543210 :: Foo2) = - TFHelper_0123456789876543210 a0123456789876543210 a0123456789876543210 :: Bool - 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 :: Foo) - SB :: SFoo (B :: Foo) - 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 :: Foo2) - SG :: SFoo2 (G :: Foo2) - 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 Mycompare_0123456789876543210 :: Foo2 -> Foo2 -> Ordering - type family Mycompare_0123456789876543210 a a where - Mycompare_0123456789876543210 'F 'F = EQSym0 - Mycompare_0123456789876543210 'F _ = LTSym0 - Mycompare_0123456789876543210 _ _ = GTSym0 - type Mycompare_0123456789876543210Sym0 :: (~>) Foo2 ((~>) Foo2 Ordering) - data Mycompare_0123456789876543210Sym0 a0123456789876543210 - where - Mycompare_0123456789876543210Sym0KindInference :: SameKind (Apply Mycompare_0123456789876543210Sym0 arg) (Mycompare_0123456789876543210Sym1 arg) => - Mycompare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Mycompare_0123456789876543210Sym0 a0123456789876543210 = Mycompare_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Mycompare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Mycompare_0123456789876543210Sym0KindInference) ()) - type Mycompare_0123456789876543210Sym1 :: Foo2 - -> (~>) Foo2 Ordering - data Mycompare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - Mycompare_0123456789876543210Sym1KindInference :: SameKind (Apply (Mycompare_0123456789876543210Sym1 a0123456789876543210) arg) (Mycompare_0123456789876543210Sym2 a0123456789876543210 arg) => - Mycompare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Mycompare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Mycompare_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Mycompare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Mycompare_0123456789876543210Sym1KindInference) ()) - type Mycompare_0123456789876543210Sym2 (a0123456789876543210 :: Foo2) (a0123456789876543210 :: Foo2) = - Mycompare_0123456789876543210 a0123456789876543210 a0123456789876543210 :: Ordering - instance PMyOrd Foo2 where - type Mycompare a a = Apply (Apply Mycompare_0123456789876543210Sym0 a) a - type Compare_0123456789876543210 :: Foo2 -> Foo2 -> Ordering - type family Compare_0123456789876543210 a a where - Compare_0123456789876543210 'F 'F = EQSym0 - Compare_0123456789876543210 'F _ = LTSym0 - Compare_0123456789876543210 _ _ = GTSym0 - type Compare_0123456789876543210Sym0 :: (~>) Foo2 ((~>) Foo2 Ordering) - data Compare_0123456789876543210Sym0 a0123456789876543210 - where - Compare_0123456789876543210Sym0KindInference :: SameKind (Apply Compare_0123456789876543210Sym0 arg) (Compare_0123456789876543210Sym1 arg) => - Compare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Compare_0123456789876543210Sym0 a0123456789876543210 = Compare_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Compare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym0KindInference) ()) - type Compare_0123456789876543210Sym1 :: Foo2 -> (~>) Foo2 Ordering - data Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - Compare_0123456789876543210Sym1KindInference :: SameKind (Apply (Compare_0123456789876543210Sym1 a0123456789876543210) arg) (Compare_0123456789876543210Sym2 a0123456789876543210 arg) => - Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Compare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Compare_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Compare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym1KindInference) ()) - type Compare_0123456789876543210Sym2 (a0123456789876543210 :: Foo2) (a0123456789876543210 :: Foo2) = - Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 :: Ordering - 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' :: Nat' - type Succ'Sym0 :: (~>) Nat' Nat' - data Succ'Sym0 a0123456789876543210 - where - Succ'Sym0KindInference :: SameKind (Apply Succ'Sym0 arg) (Succ'Sym1 arg) => - Succ'Sym0 a0123456789876543210 - type instance Apply Succ'Sym0 a0123456789876543210 = Succ'Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Succ'Sym0 where - suppressUnusedWarnings = snd (((,) Succ'Sym0KindInference) ()) - type Succ'Sym1 (a0123456789876543210 :: Nat') = - Succ' a0123456789876543210 :: Nat' - type Mycompare_0123456789876543210 :: Nat' -> Nat' -> Ordering - type family Mycompare_0123456789876543210 a a 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_0123456789876543210Sym0 :: (~>) Nat' ((~>) Nat' Ordering) - data Mycompare_0123456789876543210Sym0 a0123456789876543210 - where - Mycompare_0123456789876543210Sym0KindInference :: SameKind (Apply Mycompare_0123456789876543210Sym0 arg) (Mycompare_0123456789876543210Sym1 arg) => - Mycompare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Mycompare_0123456789876543210Sym0 a0123456789876543210 = Mycompare_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Mycompare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Mycompare_0123456789876543210Sym0KindInference) ()) - type Mycompare_0123456789876543210Sym1 :: Nat' - -> (~>) Nat' Ordering - data Mycompare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - Mycompare_0123456789876543210Sym1KindInference :: SameKind (Apply (Mycompare_0123456789876543210Sym1 a0123456789876543210) arg) (Mycompare_0123456789876543210Sym2 a0123456789876543210 arg) => - Mycompare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Mycompare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Mycompare_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Mycompare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Mycompare_0123456789876543210Sym1KindInference) ()) - type Mycompare_0123456789876543210Sym2 (a0123456789876543210 :: Nat') (a0123456789876543210 :: Nat') = - Mycompare_0123456789876543210 a0123456789876543210 a0123456789876543210 :: Ordering - instance PMyOrd Nat' where - type Mycompare a a = Apply (Apply Mycompare_0123456789876543210Sym0 a) a - data SNat' :: Nat' -> GHC.Types.Type - where - SZero' :: SNat' (Zero' :: Nat') - SSucc' :: forall (n :: Nat'). (Sing n) -> SNat' (Succ' n :: Nat') - 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.golden b/tests/compile-and-dump/Singletons/Classes2.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Classes2.golden +++ /dev/null @@ -1,90 +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 :: NatFoo - type SuccFooSym0 :: (~>) NatFoo NatFoo - data SuccFooSym0 a0123456789876543210 - where - SuccFooSym0KindInference :: SameKind (Apply SuccFooSym0 arg) (SuccFooSym1 arg) => - SuccFooSym0 a0123456789876543210 - type instance Apply SuccFooSym0 a0123456789876543210 = SuccFooSym1 a0123456789876543210 - instance SuppressUnusedWarnings SuccFooSym0 where - suppressUnusedWarnings = snd (((,) SuccFooSym0KindInference) ()) - type SuccFooSym1 (a0123456789876543210 :: NatFoo) = - SuccFoo a0123456789876543210 :: NatFoo - type Mycompare_0123456789876543210 :: NatFoo -> NatFoo -> Ordering - type family Mycompare_0123456789876543210 a a 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_0123456789876543210Sym0 :: (~>) NatFoo ((~>) NatFoo Ordering) - data Mycompare_0123456789876543210Sym0 a0123456789876543210 - where - Mycompare_0123456789876543210Sym0KindInference :: SameKind (Apply Mycompare_0123456789876543210Sym0 arg) (Mycompare_0123456789876543210Sym1 arg) => - Mycompare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Mycompare_0123456789876543210Sym0 a0123456789876543210 = Mycompare_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Mycompare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Mycompare_0123456789876543210Sym0KindInference) ()) - type Mycompare_0123456789876543210Sym1 :: NatFoo - -> (~>) NatFoo Ordering - data Mycompare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - Mycompare_0123456789876543210Sym1KindInference :: SameKind (Apply (Mycompare_0123456789876543210Sym1 a0123456789876543210) arg) (Mycompare_0123456789876543210Sym2 a0123456789876543210 arg) => - Mycompare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Mycompare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Mycompare_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Mycompare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Mycompare_0123456789876543210Sym1KindInference) ()) - type Mycompare_0123456789876543210Sym2 (a0123456789876543210 :: NatFoo) (a0123456789876543210 :: NatFoo) = - Mycompare_0123456789876543210 a0123456789876543210 a0123456789876543210 :: Ordering - instance PMyOrd NatFoo where - type Mycompare a a = Apply (Apply Mycompare_0123456789876543210Sym0 a) a - data SNatFoo :: NatFoo -> GHC.Types.Type - where - SZeroFoo :: SNatFoo (ZeroFoo :: NatFoo) - SSuccFoo :: forall (n :: NatFoo). - (Sing n) -> SNatFoo (SuccFoo n :: NatFoo) - 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.golden b/tests/compile-and-dump/Singletons/Contains.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Contains.golden +++ /dev/null @@ -1,49 +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 ContainsSym0 :: (~>) a ((~>) [a] Bool) - data ContainsSym0 a0123456789876543210 - where - ContainsSym0KindInference :: SameKind (Apply ContainsSym0 arg) (ContainsSym1 arg) => - ContainsSym0 a0123456789876543210 - type instance Apply ContainsSym0 a0123456789876543210 = ContainsSym1 a0123456789876543210 - instance SuppressUnusedWarnings ContainsSym0 where - suppressUnusedWarnings = snd (((,) ContainsSym0KindInference) ()) - type ContainsSym1 :: a -> (~>) [a] Bool - data ContainsSym1 a0123456789876543210 a0123456789876543210 - where - ContainsSym1KindInference :: SameKind (Apply (ContainsSym1 a0123456789876543210) arg) (ContainsSym2 a0123456789876543210 arg) => - ContainsSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (ContainsSym1 a0123456789876543210) a0123456789876543210 = ContainsSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ContainsSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) ContainsSym1KindInference) ()) - type ContainsSym2 (a0123456789876543210 :: a) (a0123456789876543210 :: [a]) = - Contains a0123456789876543210 a0123456789876543210 :: Bool - type Contains :: a -> [a] -> Bool - type family Contains a a 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.golden b/tests/compile-and-dump/Singletons/DataValues.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/DataValues.golden +++ /dev/null @@ -1,187 +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 PairSym0 :: forall a b. (~>) a ((~>) b (Pair a b)) - data PairSym0 a0123456789876543210 - where - PairSym0KindInference :: SameKind (Apply PairSym0 arg) (PairSym1 arg) => - PairSym0 a0123456789876543210 - type instance Apply PairSym0 a0123456789876543210 = PairSym1 a0123456789876543210 - instance SuppressUnusedWarnings PairSym0 where - suppressUnusedWarnings = snd (((,) PairSym0KindInference) ()) - type PairSym1 :: forall a b. a -> (~>) b (Pair a b) - data PairSym1 a0123456789876543210 a0123456789876543210 - where - PairSym1KindInference :: SameKind (Apply (PairSym1 a0123456789876543210) arg) (PairSym2 a0123456789876543210 arg) => - PairSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (PairSym1 a0123456789876543210) a0123456789876543210 = PairSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (PairSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) PairSym1KindInference) ()) - type PairSym2 (a0123456789876543210 :: a) (a0123456789876543210 :: b) = - Pair a0123456789876543210 a0123456789876543210 :: Pair a b - 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))) NilSym0)) - 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) NilSym0) - type ShowsPrec_0123456789876543210 :: GHC.Types.Nat - -> Pair a b -> Symbol -> Symbol - type family ShowsPrec_0123456789876543210 a a a 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_0123456789876543210Sym0 :: (~>) GHC.Types.Nat ((~>) (Pair a b) ((~>) Symbol Symbol)) - data ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym0KindInference :: SameKind (Apply ShowsPrec_0123456789876543210Sym0 arg) (ShowsPrec_0123456789876543210Sym1 arg) => - ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ShowsPrec_0123456789876543210Sym0 a0123456789876543210 = ShowsPrec_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings ShowsPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym0KindInference) ()) - type ShowsPrec_0123456789876543210Sym1 :: GHC.Types.Nat - -> (~>) (Pair a b) ((~>) Symbol Symbol) - data ShowsPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym1KindInference) ()) - type ShowsPrec_0123456789876543210Sym2 :: GHC.Types.Nat - -> Pair a b -> (~>) Symbol Symbol - data ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym2KindInference :: 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_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym2KindInference) ()) - type ShowsPrec_0123456789876543210Sym3 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: Pair a b) (a0123456789876543210 :: Symbol) = - ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 :: Symbol - 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) -> (Sing n) -> SPair (Pair n n :: Pair a b) - 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.golden b/tests/compile-and-dump/Singletons/Empty.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Empty.golden +++ /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.golden b/tests/compile-and-dump/Singletons/EmptyShowDeriving.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/EmptyShowDeriving.golden +++ /dev/null @@ -1,71 +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 ShowsPrec_0123456789876543210 :: GHC.Types.Nat - -> Foo -> GHC.Types.Symbol -> GHC.Types.Symbol - type family ShowsPrec_0123456789876543210 a a a where - ShowsPrec_0123456789876543210 _ v_0123456789876543210 a_0123456789876543210 = Apply (Case_0123456789876543210 v_0123456789876543210 a_0123456789876543210 v_0123456789876543210) a_0123456789876543210 - type ShowsPrec_0123456789876543210Sym0 :: (~>) GHC.Types.Nat ((~>) Foo ((~>) GHC.Types.Symbol GHC.Types.Symbol)) - data ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym0KindInference :: SameKind (Apply ShowsPrec_0123456789876543210Sym0 arg) (ShowsPrec_0123456789876543210Sym1 arg) => - ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ShowsPrec_0123456789876543210Sym0 a0123456789876543210 = ShowsPrec_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings ShowsPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym0KindInference) ()) - type ShowsPrec_0123456789876543210Sym1 :: GHC.Types.Nat - -> (~>) Foo ((~>) GHC.Types.Symbol GHC.Types.Symbol) - data ShowsPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym1KindInference) ()) - type ShowsPrec_0123456789876543210Sym2 :: GHC.Types.Nat - -> Foo -> (~>) GHC.Types.Symbol GHC.Types.Symbol - data ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym2KindInference :: 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_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym2KindInference) ()) - type ShowsPrec_0123456789876543210Sym3 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: Foo) (a0123456789876543210 :: GHC.Types.Symbol) = - ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 :: GHC.Types.Symbol - 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.golden b/tests/compile-and-dump/Singletons/EnumDeriving.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/EnumDeriving.golden +++ /dev/null @@ -1,208 +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 :: Foo - type BazSym0 = Baz :: Foo - type BumSym0 = Bum :: Foo - type Q1Sym0 = Q1 :: Quux - type Q2Sym0 = Q2 :: Quux - 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 ToEnum_0123456789876543210 :: GHC.Types.Nat -> Foo - type family ToEnum_0123456789876543210 a where - ToEnum_0123456789876543210 n = Case_0123456789876543210 n (Apply (Apply (==@#@$) n) (Data.Singletons.Prelude.Num.FromInteger 0)) - type ToEnum_0123456789876543210Sym0 :: (~>) GHC.Types.Nat Foo - data ToEnum_0123456789876543210Sym0 a0123456789876543210 - where - ToEnum_0123456789876543210Sym0KindInference :: SameKind (Apply ToEnum_0123456789876543210Sym0 arg) (ToEnum_0123456789876543210Sym1 arg) => - ToEnum_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ToEnum_0123456789876543210Sym0 a0123456789876543210 = ToEnum_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings ToEnum_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ToEnum_0123456789876543210Sym0KindInference) ()) - type ToEnum_0123456789876543210Sym1 (a0123456789876543210 :: GHC.Types.Nat) = - ToEnum_0123456789876543210 a0123456789876543210 :: Foo - type FromEnum_0123456789876543210 :: Foo -> GHC.Types.Nat - type family FromEnum_0123456789876543210 a 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_0123456789876543210Sym0 :: (~>) Foo GHC.Types.Nat - data FromEnum_0123456789876543210Sym0 a0123456789876543210 - where - FromEnum_0123456789876543210Sym0KindInference :: SameKind (Apply FromEnum_0123456789876543210Sym0 arg) (FromEnum_0123456789876543210Sym1 arg) => - FromEnum_0123456789876543210Sym0 a0123456789876543210 - type instance Apply FromEnum_0123456789876543210Sym0 a0123456789876543210 = FromEnum_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings FromEnum_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) FromEnum_0123456789876543210Sym0KindInference) ()) - type FromEnum_0123456789876543210Sym1 (a0123456789876543210 :: Foo) = - FromEnum_0123456789876543210 a0123456789876543210 :: GHC.Types.Nat - 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 :: Foo) - SBaz :: SFoo (Baz :: Foo) - SBum :: SFoo (Bum :: Foo) - 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 :: Quux) - SQ2 :: SQuux (Q2 :: Quux) - 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 ToEnum_0123456789876543210 :: GHC.Types.Nat -> Quux - type family ToEnum_0123456789876543210 a where - ToEnum_0123456789876543210 n = Case_0123456789876543210 n (Apply (Apply (==@#@$) n) (Data.Singletons.Prelude.Num.FromInteger 0)) - type ToEnum_0123456789876543210Sym0 :: (~>) GHC.Types.Nat Quux - data ToEnum_0123456789876543210Sym0 a0123456789876543210 - where - ToEnum_0123456789876543210Sym0KindInference :: SameKind (Apply ToEnum_0123456789876543210Sym0 arg) (ToEnum_0123456789876543210Sym1 arg) => - ToEnum_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ToEnum_0123456789876543210Sym0 a0123456789876543210 = ToEnum_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings ToEnum_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ToEnum_0123456789876543210Sym0KindInference) ()) - type ToEnum_0123456789876543210Sym1 (a0123456789876543210 :: GHC.Types.Nat) = - ToEnum_0123456789876543210 a0123456789876543210 :: Quux - type FromEnum_0123456789876543210 :: Quux -> GHC.Types.Nat - type family FromEnum_0123456789876543210 a where - FromEnum_0123456789876543210 'Q1 = Data.Singletons.Prelude.Num.FromInteger 0 - FromEnum_0123456789876543210 'Q2 = Data.Singletons.Prelude.Num.FromInteger 1 - type FromEnum_0123456789876543210Sym0 :: (~>) Quux GHC.Types.Nat - data FromEnum_0123456789876543210Sym0 a0123456789876543210 - where - FromEnum_0123456789876543210Sym0KindInference :: SameKind (Apply FromEnum_0123456789876543210Sym0 arg) (FromEnum_0123456789876543210Sym1 arg) => - FromEnum_0123456789876543210Sym0 a0123456789876543210 - type instance Apply FromEnum_0123456789876543210Sym0 a0123456789876543210 = FromEnum_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings FromEnum_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) FromEnum_0123456789876543210Sym0KindInference) ()) - type FromEnum_0123456789876543210Sym1 (a0123456789876543210 :: Quux) = - FromEnum_0123456789876543210 a0123456789876543210 :: GHC.Types.Nat - 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.golden b/tests/compile-and-dump/Singletons/EqInstances.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/EqInstances.golden +++ /dev/null @@ -1,23 +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 Equals_0123456789876543210 :: Foo -> Foo -> Bool - type family Equals_0123456789876543210 a b 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 Equals_0123456789876543210 :: Empty -> Empty -> Bool - type family Equals_0123456789876543210 a b 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.golden b/tests/compile-and-dump/Singletons/Error.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Error.golden +++ /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 HeadSym0 :: (~>) [a] a - data HeadSym0 a0123456789876543210 - where - HeadSym0KindInference :: SameKind (Apply HeadSym0 arg) (HeadSym1 arg) => - HeadSym0 a0123456789876543210 - type instance Apply HeadSym0 a0123456789876543210 = HeadSym1 a0123456789876543210 - instance SuppressUnusedWarnings HeadSym0 where - suppressUnusedWarnings = snd (((,) HeadSym0KindInference) ()) - type HeadSym1 (a0123456789876543210 :: [a]) = - Head a0123456789876543210 :: a - type Head :: [a] -> a - type family Head 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.golden b/tests/compile-and-dump/Singletons/Fixity.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Fixity.golden +++ /dev/null @@ -1,85 +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 (====@#@$) :: (~>) a ((~>) a a) - data (====@#@$) a0123456789876543210 - where - (:====@#@$###) :: SameKind (Apply (====@#@$) arg) ((====@#@$$) arg) => - (====@#@$) a0123456789876543210 - type instance Apply (====@#@$) a0123456789876543210 = (====@#@$$) a0123456789876543210 - instance SuppressUnusedWarnings (====@#@$) where - suppressUnusedWarnings = snd (((,) (:====@#@$###)) ()) - infix 4 ====@#@$ - type (====@#@$$) :: a -> (~>) a a - data (====@#@$$) a0123456789876543210 a0123456789876543210 - where - (:====@#@$$###) :: SameKind (Apply ((====@#@$$) a0123456789876543210) arg) ((====@#@$$$) a0123456789876543210 arg) => - (====@#@$$) a0123456789876543210 a0123456789876543210 - type instance Apply ((====@#@$$) a0123456789876543210) a0123456789876543210 = (====@#@$$$) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((====@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (:====@#@$$###)) ()) - infix 4 ====@#@$$ - type (====@#@$$$) (a0123456789876543210 :: a) (a0123456789876543210 :: a) = - (====) a0123456789876543210 a0123456789876543210 :: a - infix 4 ====@#@$$$ - type (====) :: a -> a -> a - type family (====) a a where - (====) a _ = a - type (<=>@#@$) :: forall a. (~>) a ((~>) a Ordering) - data (<=>@#@$) a0123456789876543210 - where - (:<=>@#@$###) :: SameKind (Apply (<=>@#@$) arg) ((<=>@#@$$) arg) => - (<=>@#@$) a0123456789876543210 - type instance Apply (<=>@#@$) a0123456789876543210 = (<=>@#@$$) a0123456789876543210 - instance SuppressUnusedWarnings (<=>@#@$) where - suppressUnusedWarnings = snd (((,) (:<=>@#@$###)) ()) - infix 4 <=>@#@$ - type (<=>@#@$$) :: forall a. a -> (~>) a Ordering - data (<=>@#@$$) a0123456789876543210 a0123456789876543210 - where - (:<=>@#@$$###) :: SameKind (Apply ((<=>@#@$$) a0123456789876543210) arg) ((<=>@#@$$$) a0123456789876543210 arg) => - (<=>@#@$$) a0123456789876543210 a0123456789876543210 - type instance Apply ((<=>@#@$$) a0123456789876543210) a0123456789876543210 = (<=>@#@$$$) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((<=>@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (:<=>@#@$$###)) ()) - infix 4 <=>@#@$$ - type (<=>@#@$$$) (a0123456789876543210 :: a) (a0123456789876543210 :: a) = - (<=>) a0123456789876543210 a0123456789876543210 :: Ordering - infix 4 <=>@#@$$$ - class PMyOrd a 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.golden b/tests/compile-and-dump/Singletons/FunDeps.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/FunDeps.golden +++ /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 MethSym0 :: forall a. (~>) a a - data MethSym0 a0123456789876543210 - where - MethSym0KindInference :: SameKind (Apply MethSym0 arg) (MethSym1 arg) => - MethSym0 a0123456789876543210 - type instance Apply MethSym0 a0123456789876543210 = MethSym1 a0123456789876543210 - instance SuppressUnusedWarnings MethSym0 where - suppressUnusedWarnings = snd (((,) MethSym0KindInference) ()) - type MethSym1 (a0123456789876543210 :: a) = - Meth a0123456789876543210 :: a - type L2rSym0 :: forall a b. (~>) a b - data L2rSym0 a0123456789876543210 - where - L2rSym0KindInference :: SameKind (Apply L2rSym0 arg) (L2rSym1 arg) => - L2rSym0 a0123456789876543210 - type instance Apply L2rSym0 a0123456789876543210 = L2rSym1 a0123456789876543210 - instance SuppressUnusedWarnings L2rSym0 where - suppressUnusedWarnings = snd (((,) L2rSym0KindInference) ()) - type L2rSym1 (a0123456789876543210 :: a) = - L2r a0123456789876543210 :: b - class PFD a b | a -> b where - type Meth (arg :: a) :: a - type L2r (arg :: a) :: b - type Meth_0123456789876543210 :: Bool -> Bool - type family Meth_0123456789876543210 a where - Meth_0123456789876543210 a_0123456789876543210 = Apply NotSym0 a_0123456789876543210 - type Meth_0123456789876543210Sym0 :: (~>) Bool Bool - data Meth_0123456789876543210Sym0 a0123456789876543210 - where - Meth_0123456789876543210Sym0KindInference :: SameKind (Apply Meth_0123456789876543210Sym0 arg) (Meth_0123456789876543210Sym1 arg) => - Meth_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Meth_0123456789876543210Sym0 a0123456789876543210 = Meth_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Meth_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Meth_0123456789876543210Sym0KindInference) ()) - type Meth_0123456789876543210Sym1 (a0123456789876543210 :: Bool) = - Meth_0123456789876543210 a0123456789876543210 :: Bool - type L2r_0123456789876543210 :: Bool -> Nat - type family L2r_0123456789876543210 a where - L2r_0123456789876543210 'False = FromInteger 0 - L2r_0123456789876543210 'True = FromInteger 1 - type L2r_0123456789876543210Sym0 :: (~>) Bool Nat - data L2r_0123456789876543210Sym0 a0123456789876543210 - where - L2r_0123456789876543210Sym0KindInference :: SameKind (Apply L2r_0123456789876543210Sym0 arg) (L2r_0123456789876543210Sym1 arg) => - L2r_0123456789876543210Sym0 a0123456789876543210 - type instance Apply L2r_0123456789876543210Sym0 a0123456789876543210 = L2r_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings L2r_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) L2r_0123456789876543210Sym0KindInference) ()) - type L2r_0123456789876543210Sym1 (a0123456789876543210 :: Bool) = - L2r_0123456789876543210 a0123456789876543210 :: Nat - 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.golden b/tests/compile-and-dump/Singletons/FunctorLikeDeriving.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/FunctorLikeDeriving.golden +++ /dev/null @@ -1,1319 +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 MkT1Sym0 :: forall x a. - (~>) x ((~>) a ((~>) (Maybe a) ((~>) (Maybe (Maybe a)) (T x a)))) - data MkT1Sym0 a0123456789876543210 - where - MkT1Sym0KindInference :: SameKind (Apply MkT1Sym0 arg) (MkT1Sym1 arg) => - MkT1Sym0 a0123456789876543210 - type instance Apply MkT1Sym0 a0123456789876543210 = MkT1Sym1 a0123456789876543210 - instance SuppressUnusedWarnings MkT1Sym0 where - suppressUnusedWarnings = snd (((,) MkT1Sym0KindInference) ()) - type MkT1Sym1 :: forall x a. - x -> (~>) a ((~>) (Maybe a) ((~>) (Maybe (Maybe a)) (T x a))) - data MkT1Sym1 a0123456789876543210 a0123456789876543210 - where - MkT1Sym1KindInference :: SameKind (Apply (MkT1Sym1 a0123456789876543210) arg) (MkT1Sym2 a0123456789876543210 arg) => - MkT1Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (MkT1Sym1 a0123456789876543210) a0123456789876543210 = MkT1Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (MkT1Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) MkT1Sym1KindInference) ()) - type MkT1Sym2 :: forall x a. - x -> a -> (~>) (Maybe a) ((~>) (Maybe (Maybe a)) (T x a)) - data MkT1Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - MkT1Sym2KindInference :: SameKind (Apply (MkT1Sym2 a0123456789876543210 a0123456789876543210) arg) (MkT1Sym3 a0123456789876543210 a0123456789876543210 arg) => - MkT1Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (MkT1Sym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = MkT1Sym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (MkT1Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) MkT1Sym2KindInference) ()) - type MkT1Sym3 :: forall x a. - x -> a -> Maybe a -> (~>) (Maybe (Maybe a)) (T x a) - data MkT1Sym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - MkT1Sym3KindInference :: SameKind (Apply (MkT1Sym3 a0123456789876543210 a0123456789876543210 a0123456789876543210) arg) (MkT1Sym4 a0123456789876543210 a0123456789876543210 a0123456789876543210 arg) => - MkT1Sym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (MkT1Sym3 a0123456789876543210 a0123456789876543210 a0123456789876543210) a0123456789876543210 = MkT1Sym4 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (MkT1Sym3 a0123456789876543210 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) MkT1Sym3KindInference) ()) - type MkT1Sym4 (a0123456789876543210 :: x) (a0123456789876543210 :: a) (a0123456789876543210 :: Maybe a) (a0123456789876543210 :: Maybe (Maybe a)) = - MkT1 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 :: T x a - type MkT2Sym0 :: forall x a. (~>) (Maybe x) (T x a) - data MkT2Sym0 a0123456789876543210 - where - MkT2Sym0KindInference :: SameKind (Apply MkT2Sym0 arg) (MkT2Sym1 arg) => - MkT2Sym0 a0123456789876543210 - type instance Apply MkT2Sym0 a0123456789876543210 = MkT2Sym1 a0123456789876543210 - instance SuppressUnusedWarnings MkT2Sym0 where - suppressUnusedWarnings = snd (((,) MkT2Sym0KindInference) ()) - type MkT2Sym1 (a0123456789876543210 :: Maybe x) = - MkT2 a0123456789876543210 :: T x a - type family Lambda_0123456789876543210 _f_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 n_0123456789876543210 where - Lambda_0123456789876543210 _f_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 n_0123456789876543210 = n_0123456789876543210 - data Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: 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 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym3KindInference :: 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 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym3KindInference) ()) - data Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym4KindInference :: 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 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym4KindInference) ()) - data Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym5KindInference :: 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 n_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) n_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym6 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym5KindInference) ()) - type Lambda_0123456789876543210Sym6 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n_01234567898765432100123456789876543210 = - Lambda_0123456789876543210 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n_01234567898765432100123456789876543210 - type family Lambda_0123456789876543210 _f_0123456789876543210 a_0123456789876543210 n_0123456789876543210 where - Lambda_0123456789876543210 _f_0123456789876543210 a_0123456789876543210 n_0123456789876543210 = n_0123456789876543210 - data Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) n_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - type Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n_01234567898765432100123456789876543210 = - Lambda_0123456789876543210 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n_01234567898765432100123456789876543210 - type Fmap_0123456789876543210 :: (~>) a b -> T x a -> T x b - type family Fmap_0123456789876543210 a a 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_0123456789876543210Sym0 :: (~>) ((~>) a b) ((~>) (T x a) (T x b)) - data Fmap_0123456789876543210Sym0 a0123456789876543210 - where - Fmap_0123456789876543210Sym0KindInference :: SameKind (Apply Fmap_0123456789876543210Sym0 arg) (Fmap_0123456789876543210Sym1 arg) => - Fmap_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Fmap_0123456789876543210Sym0 a0123456789876543210 = Fmap_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Fmap_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Fmap_0123456789876543210Sym0KindInference) ()) - type Fmap_0123456789876543210Sym1 :: (~>) a b - -> (~>) (T x a) (T x b) - data Fmap_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - Fmap_0123456789876543210Sym1KindInference :: SameKind (Apply (Fmap_0123456789876543210Sym1 a0123456789876543210) arg) (Fmap_0123456789876543210Sym2 a0123456789876543210 arg) => - Fmap_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Fmap_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Fmap_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Fmap_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Fmap_0123456789876543210Sym1KindInference) ()) - type Fmap_0123456789876543210Sym2 (a0123456789876543210 :: (~>) a b) (a0123456789876543210 :: T x a) = - Fmap_0123456789876543210 a0123456789876543210 a0123456789876543210 :: T x b - type family Lambda_0123456789876543210 _z_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 n_0123456789876543210 where - Lambda_0123456789876543210 _z_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 n_0123456789876543210 = n_0123456789876543210 - data Lambda_0123456789876543210Sym0 _z_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 _z_01234567898765432100123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 _z_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym1 _z_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 _z_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: 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 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym3 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym3 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym3KindInference :: 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 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym4 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym3 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym3KindInference) ()) - data Lambda_0123456789876543210Sym4 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym4KindInference :: 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 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym5 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym4 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym4KindInference) ()) - data Lambda_0123456789876543210Sym5 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym5KindInference :: 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 n_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym5 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) n_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym6 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym5 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym5KindInference) ()) - type Lambda_0123456789876543210Sym6 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n_01234567898765432100123456789876543210 = - Lambda_0123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n_01234567898765432100123456789876543210 - type family Lambda_0123456789876543210 _z_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 n_0123456789876543210 where - Lambda_0123456789876543210 _z_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 n_0123456789876543210 = _z_0123456789876543210 - data Lambda_0123456789876543210Sym0 _z_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 _z_01234567898765432100123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 _z_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym1 _z_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 _z_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: 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 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym3 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym3 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym3KindInference :: 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 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym4 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym3 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym3KindInference) ()) - data Lambda_0123456789876543210Sym4 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym4KindInference :: 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 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym5 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym4 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym4KindInference) ()) - data Lambda_0123456789876543210Sym5 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym5KindInference :: 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 n_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym5 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) n_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym6 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym5 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym5KindInference) ()) - type Lambda_0123456789876543210Sym6 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n_01234567898765432100123456789876543210 = - Lambda_0123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n_01234567898765432100123456789876543210 - type family Lambda_0123456789876543210 _z_0123456789876543210 a_0123456789876543210 n_0123456789876543210 where - Lambda_0123456789876543210 _z_0123456789876543210 a_0123456789876543210 n_0123456789876543210 = n_0123456789876543210 - data Lambda_0123456789876543210Sym0 _z_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 _z_01234567898765432100123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 _z_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym1 _z_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 _z_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym2 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym3 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym2 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) n_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym3 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - type Lambda_0123456789876543210Sym3 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n_01234567898765432100123456789876543210 = - Lambda_0123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n_01234567898765432100123456789876543210 - type TFHelper_0123456789876543210 :: a -> T x b -> T x a - type family TFHelper_0123456789876543210 a a 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_0123456789876543210Sym0 :: (~>) a ((~>) (T x b) (T x a)) - data TFHelper_0123456789876543210Sym0 a0123456789876543210 - where - TFHelper_0123456789876543210Sym0KindInference :: SameKind (Apply TFHelper_0123456789876543210Sym0 arg) (TFHelper_0123456789876543210Sym1 arg) => - TFHelper_0123456789876543210Sym0 a0123456789876543210 - type instance Apply TFHelper_0123456789876543210Sym0 a0123456789876543210 = TFHelper_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings TFHelper_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) TFHelper_0123456789876543210Sym0KindInference) ()) - type TFHelper_0123456789876543210Sym1 :: a -> (~>) (T x b) (T x a) - data TFHelper_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - TFHelper_0123456789876543210Sym1KindInference :: SameKind (Apply (TFHelper_0123456789876543210Sym1 a0123456789876543210) arg) (TFHelper_0123456789876543210Sym2 a0123456789876543210 arg) => - TFHelper_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (TFHelper_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = TFHelper_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (TFHelper_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) TFHelper_0123456789876543210Sym1KindInference) ()) - type TFHelper_0123456789876543210Sym2 (a0123456789876543210 :: a) (a0123456789876543210 :: T x b) = - TFHelper_0123456789876543210 a0123456789876543210 a0123456789876543210 :: T x a - 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 n_0123456789876543210 where - Lambda_0123456789876543210 _f_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 n_0123456789876543210 = MemptySym0 - data Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: 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 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym3KindInference :: 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 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym3KindInference) ()) - data Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym4KindInference :: 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 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym4KindInference) ()) - data Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym5KindInference :: 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 n_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) n_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym6 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym5KindInference) ()) - type Lambda_0123456789876543210Sym6 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n_01234567898765432100123456789876543210 = - Lambda_0123456789876543210 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n_01234567898765432100123456789876543210 - type family Lambda_0123456789876543210 _f_0123456789876543210 a_0123456789876543210 n_0123456789876543210 where - Lambda_0123456789876543210 _f_0123456789876543210 a_0123456789876543210 n_0123456789876543210 = MemptySym0 - data Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) n_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - type Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n_01234567898765432100123456789876543210 = - Lambda_0123456789876543210 _f_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n_01234567898765432100123456789876543210 - type FoldMap_0123456789876543210 :: (~>) a m -> T x a -> m - type family FoldMap_0123456789876543210 a a 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_0123456789876543210Sym0 :: (~>) ((~>) a m) ((~>) (T x a) m) - data FoldMap_0123456789876543210Sym0 a0123456789876543210 - where - FoldMap_0123456789876543210Sym0KindInference :: SameKind (Apply FoldMap_0123456789876543210Sym0 arg) (FoldMap_0123456789876543210Sym1 arg) => - FoldMap_0123456789876543210Sym0 a0123456789876543210 - type instance Apply FoldMap_0123456789876543210Sym0 a0123456789876543210 = FoldMap_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings FoldMap_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) FoldMap_0123456789876543210Sym0KindInference) ()) - type FoldMap_0123456789876543210Sym1 :: (~>) a m -> (~>) (T x a) m - data FoldMap_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - FoldMap_0123456789876543210Sym1KindInference :: SameKind (Apply (FoldMap_0123456789876543210Sym1 a0123456789876543210) arg) (FoldMap_0123456789876543210Sym2 a0123456789876543210 arg) => - FoldMap_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (FoldMap_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = FoldMap_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (FoldMap_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) FoldMap_0123456789876543210Sym1KindInference) ()) - type FoldMap_0123456789876543210Sym2 (a0123456789876543210 :: (~>) a m) (a0123456789876543210 :: T x a) = - FoldMap_0123456789876543210 a0123456789876543210 a0123456789876543210 :: m - type family Lambda_0123456789876543210 _f_0123456789876543210 _z_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 n1_0123456789876543210 n2_0123456789876543210 where - Lambda_0123456789876543210 _f_0123456789876543210 _z_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 n1_0123456789876543210 n2_0123456789876543210 = n2_0123456789876543210 - data Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: 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 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym3KindInference :: 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 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym3KindInference) ()) - data Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym4KindInference :: 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 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym4KindInference) ()) - data Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym5KindInference :: 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 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym6 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym5KindInference) ()) - data Lambda_0123456789876543210Sym6 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym6KindInference :: 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 n1_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym6 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) n1_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym7 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym6 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym6KindInference) ()) - data Lambda_0123456789876543210Sym7 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym7KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym7 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym8 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym7 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym7 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210) n2_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym8 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym7 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym7KindInference) ()) - type Lambda_0123456789876543210Sym8 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 = - Lambda_0123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 - type family Lambda_0123456789876543210 _f_0123456789876543210 _z_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 n1_0123456789876543210 n2_0123456789876543210 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 - data Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: 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 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym3KindInference :: 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 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym3KindInference) ()) - data Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym4KindInference :: 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 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym4KindInference) ()) - data Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym5KindInference :: 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 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym6 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym5KindInference) ()) - data Lambda_0123456789876543210Sym6 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym6KindInference :: 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 n1_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym6 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) n1_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym7 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym6 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym6KindInference) ()) - data Lambda_0123456789876543210Sym7 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym7KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym7 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym8 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym7 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym7 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210) n2_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym8 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym7 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym7KindInference) ()) - type Lambda_0123456789876543210Sym8 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 = - Lambda_0123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 - type family Lambda_0123456789876543210 n1_0123456789876543210 n2_0123456789876543210 _f_0123456789876543210 _z_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 n1_0123456789876543210 n2_0123456789876543210 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 - data Lambda_0123456789876543210Sym0 n1_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 n1_01234567898765432100123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 n1_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym1 n1_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 n1_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: 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 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210) _f_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym3 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym3 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym3KindInference :: 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 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) _z_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym4 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym3 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym3KindInference) ()) - data Lambda_0123456789876543210Sym4 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym4KindInference :: 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 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym5 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym4 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym4KindInference) ()) - data Lambda_0123456789876543210Sym5 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym5KindInference :: 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 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym6 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym5 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym5KindInference) ()) - data Lambda_0123456789876543210Sym6 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym6KindInference :: 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 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym7 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym6 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym6KindInference) ()) - data Lambda_0123456789876543210Sym7 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym7KindInference :: 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 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym8 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym7 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym7KindInference) ()) - data Lambda_0123456789876543210Sym8 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym8KindInference :: 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 n1_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym8 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) n1_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym9 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym8 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym8KindInference) ()) - data Lambda_0123456789876543210Sym9 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym9KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym9 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym10 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym9 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym9 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210) n2_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym10 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym9 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym9KindInference) ()) - type Lambda_0123456789876543210Sym10 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 = - Lambda_0123456789876543210 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 - type family Lambda_0123456789876543210 _f_0123456789876543210 _z_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 n1_0123456789876543210 n2_0123456789876543210 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 - data Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: 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 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym3KindInference :: 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 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym3KindInference) ()) - data Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym4KindInference :: 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 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym4KindInference) ()) - data Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym5KindInference :: 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 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym6 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym5KindInference) ()) - data Lambda_0123456789876543210Sym6 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym6KindInference :: 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 n1_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym6 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) n1_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym7 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym6 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym6KindInference) ()) - data Lambda_0123456789876543210Sym7 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym7KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym7 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym8 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym7 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym7 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210) n2_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym8 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym7 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym7KindInference) ()) - type Lambda_0123456789876543210Sym8 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 = - Lambda_0123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 - type family Lambda_0123456789876543210 _f_0123456789876543210 _z_0123456789876543210 a_0123456789876543210 n1_0123456789876543210 n2_0123456789876543210 where - Lambda_0123456789876543210 _f_0123456789876543210 _z_0123456789876543210 a_0123456789876543210 n1_0123456789876543210 n2_0123456789876543210 = n2_0123456789876543210 - data Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 _f_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 _f_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: 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 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210) a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym3KindInference :: 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 n1_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) n1_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym3 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym3KindInference) ()) - data Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym4KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210) n2_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym4 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym4KindInference) ()) - type Lambda_0123456789876543210Sym5 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 = - Lambda_0123456789876543210 _f_01234567898765432100123456789876543210 _z_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n1_01234567898765432100123456789876543210 n2_01234567898765432100123456789876543210 - type Foldr_0123456789876543210 :: (~>) a ((~>) b b) - -> b -> T x a -> b - type family Foldr_0123456789876543210 a a a 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_0123456789876543210Sym0 :: (~>) ((~>) a ((~>) b b)) ((~>) b ((~>) (T x a) b)) - data Foldr_0123456789876543210Sym0 a0123456789876543210 - where - Foldr_0123456789876543210Sym0KindInference :: SameKind (Apply Foldr_0123456789876543210Sym0 arg) (Foldr_0123456789876543210Sym1 arg) => - Foldr_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Foldr_0123456789876543210Sym0 a0123456789876543210 = Foldr_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foldr_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Foldr_0123456789876543210Sym0KindInference) ()) - type Foldr_0123456789876543210Sym1 :: (~>) a ((~>) b b) - -> (~>) b ((~>) (T x a) b) - data Foldr_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - Foldr_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Foldr_0123456789876543210Sym1KindInference) ()) - type Foldr_0123456789876543210Sym2 :: (~>) a ((~>) b b) - -> b -> (~>) (T x a) b - data Foldr_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - Foldr_0123456789876543210Sym2KindInference :: 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_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Foldr_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Foldr_0123456789876543210Sym2KindInference) ()) - type Foldr_0123456789876543210Sym3 (a0123456789876543210 :: (~>) a ((~>) b b)) (a0123456789876543210 :: b) (a0123456789876543210 :: T x a) = - Foldr_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 :: b - 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 Traverse_0123456789876543210 :: (~>) a (f b) - -> T x a -> f (T x b) - type family Traverse_0123456789876543210 a a 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_0123456789876543210Sym0 :: (~>) ((~>) a (f b)) ((~>) (T x a) (f (T x b))) - data Traverse_0123456789876543210Sym0 a0123456789876543210 - where - Traverse_0123456789876543210Sym0KindInference :: SameKind (Apply Traverse_0123456789876543210Sym0 arg) (Traverse_0123456789876543210Sym1 arg) => - Traverse_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Traverse_0123456789876543210Sym0 a0123456789876543210 = Traverse_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Traverse_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Traverse_0123456789876543210Sym0KindInference) ()) - type Traverse_0123456789876543210Sym1 :: (~>) a (f b) - -> (~>) (T x a) (f (T x b)) - data Traverse_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - Traverse_0123456789876543210Sym1KindInference :: SameKind (Apply (Traverse_0123456789876543210Sym1 a0123456789876543210) arg) (Traverse_0123456789876543210Sym2 a0123456789876543210 arg) => - Traverse_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Traverse_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Traverse_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Traverse_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Traverse_0123456789876543210Sym1KindInference) ()) - type Traverse_0123456789876543210Sym2 (a0123456789876543210 :: (~>) a (f b)) (a0123456789876543210 :: T x a) = - Traverse_0123456789876543210 a0123456789876543210 a0123456789876543210 :: f (T x b) - instance PTraversable (T x) where - type Traverse a a = Apply (Apply Traverse_0123456789876543210Sym0 a) a - type family Case_0123456789876543210 v_0123456789876543210 t where - type Fmap_0123456789876543210 :: (~>) a b -> Empty a -> Empty b - type family Fmap_0123456789876543210 a a where - Fmap_0123456789876543210 _ v_0123456789876543210 = Case_0123456789876543210 v_0123456789876543210 v_0123456789876543210 - type Fmap_0123456789876543210Sym0 :: (~>) ((~>) a b) ((~>) (Empty a) (Empty b)) - data Fmap_0123456789876543210Sym0 a0123456789876543210 - where - Fmap_0123456789876543210Sym0KindInference :: SameKind (Apply Fmap_0123456789876543210Sym0 arg) (Fmap_0123456789876543210Sym1 arg) => - Fmap_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Fmap_0123456789876543210Sym0 a0123456789876543210 = Fmap_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Fmap_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Fmap_0123456789876543210Sym0KindInference) ()) - type Fmap_0123456789876543210Sym1 :: (~>) a b - -> (~>) (Empty a) (Empty b) - data Fmap_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - Fmap_0123456789876543210Sym1KindInference :: SameKind (Apply (Fmap_0123456789876543210Sym1 a0123456789876543210) arg) (Fmap_0123456789876543210Sym2 a0123456789876543210 arg) => - Fmap_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Fmap_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Fmap_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Fmap_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Fmap_0123456789876543210Sym1KindInference) ()) - type Fmap_0123456789876543210Sym2 (a0123456789876543210 :: (~>) a b) (a0123456789876543210 :: Empty a) = - Fmap_0123456789876543210 a0123456789876543210 a0123456789876543210 :: Empty b - type family Case_0123456789876543210 v_0123456789876543210 t where - type TFHelper_0123456789876543210 :: a -> Empty b -> Empty a - type family TFHelper_0123456789876543210 a a where - TFHelper_0123456789876543210 _ v_0123456789876543210 = Case_0123456789876543210 v_0123456789876543210 v_0123456789876543210 - type TFHelper_0123456789876543210Sym0 :: (~>) a ((~>) (Empty b) (Empty a)) - data TFHelper_0123456789876543210Sym0 a0123456789876543210 - where - TFHelper_0123456789876543210Sym0KindInference :: SameKind (Apply TFHelper_0123456789876543210Sym0 arg) (TFHelper_0123456789876543210Sym1 arg) => - TFHelper_0123456789876543210Sym0 a0123456789876543210 - type instance Apply TFHelper_0123456789876543210Sym0 a0123456789876543210 = TFHelper_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings TFHelper_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) TFHelper_0123456789876543210Sym0KindInference) ()) - type TFHelper_0123456789876543210Sym1 :: a - -> (~>) (Empty b) (Empty a) - data TFHelper_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - TFHelper_0123456789876543210Sym1KindInference :: SameKind (Apply (TFHelper_0123456789876543210Sym1 a0123456789876543210) arg) (TFHelper_0123456789876543210Sym2 a0123456789876543210 arg) => - TFHelper_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (TFHelper_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = TFHelper_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (TFHelper_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) TFHelper_0123456789876543210Sym1KindInference) ()) - type TFHelper_0123456789876543210Sym2 (a0123456789876543210 :: a) (a0123456789876543210 :: Empty b) = - TFHelper_0123456789876543210 a0123456789876543210 a0123456789876543210 :: Empty a - instance PFunctor Empty where - type Fmap a a = Apply (Apply Fmap_0123456789876543210Sym0 a) a - type (<$) a a = Apply (Apply TFHelper_0123456789876543210Sym0 a) a - type FoldMap_0123456789876543210 :: (~>) a m -> Empty a -> m - type family FoldMap_0123456789876543210 a a where - FoldMap_0123456789876543210 _ _ = MemptySym0 - type FoldMap_0123456789876543210Sym0 :: (~>) ((~>) a m) ((~>) (Empty a) m) - data FoldMap_0123456789876543210Sym0 a0123456789876543210 - where - FoldMap_0123456789876543210Sym0KindInference :: SameKind (Apply FoldMap_0123456789876543210Sym0 arg) (FoldMap_0123456789876543210Sym1 arg) => - FoldMap_0123456789876543210Sym0 a0123456789876543210 - type instance Apply FoldMap_0123456789876543210Sym0 a0123456789876543210 = FoldMap_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings FoldMap_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) FoldMap_0123456789876543210Sym0KindInference) ()) - type FoldMap_0123456789876543210Sym1 :: (~>) a m - -> (~>) (Empty a) m - data FoldMap_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - FoldMap_0123456789876543210Sym1KindInference :: SameKind (Apply (FoldMap_0123456789876543210Sym1 a0123456789876543210) arg) (FoldMap_0123456789876543210Sym2 a0123456789876543210 arg) => - FoldMap_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (FoldMap_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = FoldMap_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (FoldMap_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) FoldMap_0123456789876543210Sym1KindInference) ()) - type FoldMap_0123456789876543210Sym2 (a0123456789876543210 :: (~>) a m) (a0123456789876543210 :: Empty a) = - FoldMap_0123456789876543210 a0123456789876543210 a0123456789876543210 :: m - instance PFoldable Empty where - type FoldMap a a = Apply (Apply FoldMap_0123456789876543210Sym0 a) a - type family Case_0123456789876543210 v_0123456789876543210 t where - type Traverse_0123456789876543210 :: (~>) a (f b) - -> Empty a -> f (Empty b) - type family Traverse_0123456789876543210 a a where - Traverse_0123456789876543210 _ v_0123456789876543210 = Apply PureSym0 (Case_0123456789876543210 v_0123456789876543210 v_0123456789876543210) - type Traverse_0123456789876543210Sym0 :: (~>) ((~>) a (f b)) ((~>) (Empty a) (f (Empty b))) - data Traverse_0123456789876543210Sym0 a0123456789876543210 - where - Traverse_0123456789876543210Sym0KindInference :: SameKind (Apply Traverse_0123456789876543210Sym0 arg) (Traverse_0123456789876543210Sym1 arg) => - Traverse_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Traverse_0123456789876543210Sym0 a0123456789876543210 = Traverse_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Traverse_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Traverse_0123456789876543210Sym0KindInference) ()) - type Traverse_0123456789876543210Sym1 :: (~>) a (f b) - -> (~>) (Empty a) (f (Empty b)) - data Traverse_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - Traverse_0123456789876543210Sym1KindInference :: SameKind (Apply (Traverse_0123456789876543210Sym1 a0123456789876543210) arg) (Traverse_0123456789876543210Sym2 a0123456789876543210 arg) => - Traverse_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Traverse_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Traverse_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Traverse_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Traverse_0123456789876543210Sym1KindInference) ()) - type Traverse_0123456789876543210Sym2 (a0123456789876543210 :: (~>) a (f b)) (a0123456789876543210 :: Empty a) = - Traverse_0123456789876543210 a0123456789876543210 a0123456789876543210 :: f (Empty b) - 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) - -> (Sing n) -> (Sing n) -> (Sing n) -> ST (MkT1 n n n n :: T x a) - SMkT2 :: forall x a (n :: Maybe x). - (Sing n) -> ST (MkT2 n :: T x a) - 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 - 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.golden b/tests/compile-and-dump/Singletons/HigherOrder.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/HigherOrder.golden +++ /dev/null @@ -1,447 +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 LeftSym0 :: forall a b. (~>) a (Either a b) - data LeftSym0 a0123456789876543210 - where - LeftSym0KindInference :: SameKind (Apply LeftSym0 arg) (LeftSym1 arg) => - LeftSym0 a0123456789876543210 - type instance Apply LeftSym0 a0123456789876543210 = LeftSym1 a0123456789876543210 - instance SuppressUnusedWarnings LeftSym0 where - suppressUnusedWarnings = snd (((,) LeftSym0KindInference) ()) - type LeftSym1 (a0123456789876543210 :: a) = - Left a0123456789876543210 :: Either a b - type RightSym0 :: forall a b. (~>) b (Either a b) - data RightSym0 a0123456789876543210 - where - RightSym0KindInference :: SameKind (Apply RightSym0 arg) (RightSym1 arg) => - RightSym0 a0123456789876543210 - type instance Apply RightSym0 a0123456789876543210 = RightSym1 a0123456789876543210 - instance SuppressUnusedWarnings RightSym0 where - suppressUnusedWarnings = snd (((,) RightSym0KindInference) ()) - type RightSym1 (a0123456789876543210 :: b) = - Right a0123456789876543210 :: Either a b - 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 n b where - Lambda_0123456789876543210 a_0123456789876543210 a_0123456789876543210 n b = Case_0123456789876543210 n b a_0123456789876543210 a_0123456789876543210 b - data Lambda_0123456789876543210Sym0 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 a_01234567898765432100123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) n0123456789876543210 = Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n0123456789876543210 b0123456789876543210 - where - Lambda_0123456789876543210Sym3KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n0123456789876543210) arg) (Lambda_0123456789876543210Sym4 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n0123456789876543210 arg) => - Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n0123456789876543210 b0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n0123456789876543210) b0123456789876543210 = Lambda_0123456789876543210Sym4 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n0123456789876543210 b0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym3KindInference) ()) - type Lambda_0123456789876543210Sym4 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n0123456789876543210 b0123456789876543210 = - Lambda_0123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 n0123456789876543210 b0123456789876543210 - 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 n b where - Lambda_0123456789876543210 ns bs n b = Case_0123456789876543210 n b ns bs b - data Lambda_0123456789876543210Sym0 ns0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 ns0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 ns0123456789876543210 = Lambda_0123456789876543210Sym1 ns0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 ns0123456789876543210 bs0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 ns0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 ns0123456789876543210 bs0123456789876543210 n0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym2 ns0123456789876543210 bs0123456789876543210) arg) (Lambda_0123456789876543210Sym3 ns0123456789876543210 bs0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 ns0123456789876543210 bs0123456789876543210 n0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 ns0123456789876543210 bs0123456789876543210) n0123456789876543210 = Lambda_0123456789876543210Sym3 ns0123456789876543210 bs0123456789876543210 n0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 ns0123456789876543210 bs0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym3 ns0123456789876543210 bs0123456789876543210 n0123456789876543210 b0123456789876543210 - where - Lambda_0123456789876543210Sym3KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym3 ns0123456789876543210 bs0123456789876543210 n0123456789876543210) arg) (Lambda_0123456789876543210Sym4 ns0123456789876543210 bs0123456789876543210 n0123456789876543210 arg) => - Lambda_0123456789876543210Sym3 ns0123456789876543210 bs0123456789876543210 n0123456789876543210 b0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym3 ns0123456789876543210 bs0123456789876543210 n0123456789876543210) b0123456789876543210 = Lambda_0123456789876543210Sym4 ns0123456789876543210 bs0123456789876543210 n0123456789876543210 b0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym3 ns0123456789876543210 bs0123456789876543210 n0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym3KindInference) ()) - type Lambda_0123456789876543210Sym4 ns0123456789876543210 bs0123456789876543210 n0123456789876543210 b0123456789876543210 = - Lambda_0123456789876543210 ns0123456789876543210 bs0123456789876543210 n0123456789876543210 b0123456789876543210 - type EtadSym0 :: (~>) [Nat] ((~>) [Bool] [Nat]) - data EtadSym0 a0123456789876543210 - where - EtadSym0KindInference :: SameKind (Apply EtadSym0 arg) (EtadSym1 arg) => - EtadSym0 a0123456789876543210 - type instance Apply EtadSym0 a0123456789876543210 = EtadSym1 a0123456789876543210 - instance SuppressUnusedWarnings EtadSym0 where - suppressUnusedWarnings = snd (((,) EtadSym0KindInference) ()) - type EtadSym1 :: [Nat] -> (~>) [Bool] [Nat] - data EtadSym1 a0123456789876543210 a0123456789876543210 - where - EtadSym1KindInference :: SameKind (Apply (EtadSym1 a0123456789876543210) arg) (EtadSym2 a0123456789876543210 arg) => - EtadSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (EtadSym1 a0123456789876543210) a0123456789876543210 = EtadSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (EtadSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) EtadSym1KindInference) ()) - type EtadSym2 (a0123456789876543210 :: [Nat]) (a0123456789876543210 :: [Bool]) = - Etad a0123456789876543210 a0123456789876543210 :: [Nat] - type SplungeSym0 :: (~>) [Nat] ((~>) [Bool] [Nat]) - data SplungeSym0 a0123456789876543210 - where - SplungeSym0KindInference :: SameKind (Apply SplungeSym0 arg) (SplungeSym1 arg) => - SplungeSym0 a0123456789876543210 - type instance Apply SplungeSym0 a0123456789876543210 = SplungeSym1 a0123456789876543210 - instance SuppressUnusedWarnings SplungeSym0 where - suppressUnusedWarnings = snd (((,) SplungeSym0KindInference) ()) - type SplungeSym1 :: [Nat] -> (~>) [Bool] [Nat] - data SplungeSym1 a0123456789876543210 a0123456789876543210 - where - SplungeSym1KindInference :: SameKind (Apply (SplungeSym1 a0123456789876543210) arg) (SplungeSym2 a0123456789876543210 arg) => - SplungeSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (SplungeSym1 a0123456789876543210) a0123456789876543210 = SplungeSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (SplungeSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) SplungeSym1KindInference) ()) - type SplungeSym2 (a0123456789876543210 :: [Nat]) (a0123456789876543210 :: [Bool]) = - Splunge a0123456789876543210 a0123456789876543210 :: [Nat] - type FooSym0 :: (~>) ((~>) ((~>) a b) ((~>) a b)) ((~>) ((~>) a b) ((~>) a b)) - data FooSym0 a0123456789876543210 - where - FooSym0KindInference :: SameKind (Apply FooSym0 arg) (FooSym1 arg) => - FooSym0 a0123456789876543210 - type instance Apply FooSym0 a0123456789876543210 = FooSym1 a0123456789876543210 - instance SuppressUnusedWarnings FooSym0 where - suppressUnusedWarnings = snd (((,) FooSym0KindInference) ()) - type FooSym1 :: (~>) ((~>) a b) ((~>) a b) - -> (~>) ((~>) a b) ((~>) a b) - data FooSym1 a0123456789876543210 a0123456789876543210 - where - FooSym1KindInference :: SameKind (Apply (FooSym1 a0123456789876543210) arg) (FooSym2 a0123456789876543210 arg) => - FooSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (FooSym1 a0123456789876543210) a0123456789876543210 = FooSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (FooSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) FooSym1KindInference) ()) - type FooSym2 :: (~>) ((~>) a b) ((~>) a b) -> (~>) a b -> (~>) a b - data FooSym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - FooSym2KindInference :: SameKind (Apply (FooSym2 a0123456789876543210 a0123456789876543210) arg) (FooSym3 a0123456789876543210 a0123456789876543210 arg) => - FooSym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (FooSym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = FooSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (FooSym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) FooSym2KindInference) ()) - type FooSym3 (a0123456789876543210 :: (~>) ((~>) a b) ((~>) a b)) (a0123456789876543210 :: (~>) a b) (a0123456789876543210 :: a) = - Foo a0123456789876543210 a0123456789876543210 a0123456789876543210 :: b - type ZipWithSym0 :: (~>) ((~>) a ((~>) b c)) ((~>) [a] ((~>) [b] [c])) - data ZipWithSym0 a0123456789876543210 - where - ZipWithSym0KindInference :: SameKind (Apply ZipWithSym0 arg) (ZipWithSym1 arg) => - ZipWithSym0 a0123456789876543210 - type instance Apply ZipWithSym0 a0123456789876543210 = ZipWithSym1 a0123456789876543210 - instance SuppressUnusedWarnings ZipWithSym0 where - suppressUnusedWarnings = snd (((,) ZipWithSym0KindInference) ()) - type ZipWithSym1 :: (~>) a ((~>) b c) -> (~>) [a] ((~>) [b] [c]) - data ZipWithSym1 a0123456789876543210 a0123456789876543210 - where - ZipWithSym1KindInference :: SameKind (Apply (ZipWithSym1 a0123456789876543210) arg) (ZipWithSym2 a0123456789876543210 arg) => - ZipWithSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (ZipWithSym1 a0123456789876543210) a0123456789876543210 = ZipWithSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ZipWithSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) ZipWithSym1KindInference) ()) - type ZipWithSym2 :: (~>) a ((~>) b c) -> [a] -> (~>) [b] [c] - data ZipWithSym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - ZipWithSym2KindInference :: SameKind (Apply (ZipWithSym2 a0123456789876543210 a0123456789876543210) arg) (ZipWithSym3 a0123456789876543210 a0123456789876543210 arg) => - ZipWithSym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (ZipWithSym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = ZipWithSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ZipWithSym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) ZipWithSym2KindInference) ()) - type ZipWithSym3 (a0123456789876543210 :: (~>) a ((~>) b c)) (a0123456789876543210 :: [a]) (a0123456789876543210 :: [b]) = - ZipWith a0123456789876543210 a0123456789876543210 a0123456789876543210 :: [c] - type LiftMaybeSym0 :: (~>) ((~>) a b) ((~>) (Maybe a) (Maybe b)) - data LiftMaybeSym0 a0123456789876543210 - where - LiftMaybeSym0KindInference :: SameKind (Apply LiftMaybeSym0 arg) (LiftMaybeSym1 arg) => - LiftMaybeSym0 a0123456789876543210 - type instance Apply LiftMaybeSym0 a0123456789876543210 = LiftMaybeSym1 a0123456789876543210 - instance SuppressUnusedWarnings LiftMaybeSym0 where - suppressUnusedWarnings = snd (((,) LiftMaybeSym0KindInference) ()) - type LiftMaybeSym1 :: (~>) a b -> (~>) (Maybe a) (Maybe b) - data LiftMaybeSym1 a0123456789876543210 a0123456789876543210 - where - LiftMaybeSym1KindInference :: SameKind (Apply (LiftMaybeSym1 a0123456789876543210) arg) (LiftMaybeSym2 a0123456789876543210 arg) => - LiftMaybeSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (LiftMaybeSym1 a0123456789876543210) a0123456789876543210 = LiftMaybeSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (LiftMaybeSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) LiftMaybeSym1KindInference) ()) - type LiftMaybeSym2 (a0123456789876543210 :: (~>) a b) (a0123456789876543210 :: Maybe a) = - LiftMaybe a0123456789876543210 a0123456789876543210 :: Maybe b - type MapSym0 :: (~>) ((~>) a b) ((~>) [a] [b]) - data MapSym0 a0123456789876543210 - where - MapSym0KindInference :: SameKind (Apply MapSym0 arg) (MapSym1 arg) => - MapSym0 a0123456789876543210 - type instance Apply MapSym0 a0123456789876543210 = MapSym1 a0123456789876543210 - instance SuppressUnusedWarnings MapSym0 where - suppressUnusedWarnings = snd (((,) MapSym0KindInference) ()) - type MapSym1 :: (~>) a b -> (~>) [a] [b] - data MapSym1 a0123456789876543210 a0123456789876543210 - where - MapSym1KindInference :: SameKind (Apply (MapSym1 a0123456789876543210) arg) (MapSym2 a0123456789876543210 arg) => - MapSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (MapSym1 a0123456789876543210) a0123456789876543210 = MapSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (MapSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) MapSym1KindInference) ()) - type MapSym2 (a0123456789876543210 :: (~>) a b) (a0123456789876543210 :: [a]) = - Map a0123456789876543210 a0123456789876543210 :: [b] - type Etad :: [Nat] -> [Bool] -> [Nat] - type family Etad a a where - Etad a_0123456789876543210 a_0123456789876543210 = Apply (Apply (Apply ZipWithSym0 (Apply (Apply Lambda_0123456789876543210Sym0 a_0123456789876543210) a_0123456789876543210)) a_0123456789876543210) a_0123456789876543210 - type Splunge :: [Nat] -> [Bool] -> [Nat] - type family Splunge a a where - Splunge ns bs = Apply (Apply (Apply ZipWithSym0 (Apply (Apply Lambda_0123456789876543210Sym0 ns) bs)) ns) bs - type Foo :: (~>) ((~>) a b) ((~>) a b) -> (~>) a b -> a -> b - type family Foo a a a where - Foo f g a = Apply (Apply f g) a - type ZipWith :: (~>) a ((~>) b c) -> [a] -> [b] -> [c] - type family ZipWith a a a where - ZipWith f ('(:) x xs) ('(:) y ys) = Apply (Apply (:@#@$) (Apply (Apply f x) y)) (Apply (Apply (Apply ZipWithSym0 f) xs) ys) - ZipWith _ '[] '[] = NilSym0 - ZipWith _ ('(:) _ _) '[] = NilSym0 - ZipWith _ '[] ('(:) _ _) = NilSym0 - type LiftMaybe :: (~>) a b -> Maybe a -> Maybe b - type family LiftMaybe a a where - LiftMaybe f ('Just x) = Apply JustSym0 (Apply f x) - LiftMaybe _ 'Nothing = NothingSym0 - type Map :: (~>) a b -> [a] -> [b] - type family Map a a where - Map _ '[] = NilSym0 - 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 b (n :: a). - (Sing n) -> SEither (Left n :: Either a b) - SRight :: forall a b (n :: b). - (Sing n) -> SEither (Right n :: Either a b) - 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.golden b/tests/compile-and-dump/Singletons/LambdaCase.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/LambdaCase.golden +++ /dev/null @@ -1,236 +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 x_0123456789876543210 where - Lambda_0123456789876543210 a b x_0123456789876543210 = Case_0123456789876543210 x_0123456789876543210 a b x_0123456789876543210 - data Lambda_0123456789876543210Sym0 a0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 a0123456789876543210 = Lambda_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 a0123456789876543210 b0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 a0123456789876543210 b0123456789876543210 x_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym2 a0123456789876543210 b0123456789876543210) arg) (Lambda_0123456789876543210Sym3 a0123456789876543210 b0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 a0123456789876543210 b0123456789876543210 x_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 a0123456789876543210 b0123456789876543210) x_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym3 a0123456789876543210 b0123456789876543210 x_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 a0123456789876543210 b0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - type Lambda_0123456789876543210Sym3 a0123456789876543210 b0123456789876543210 x_01234567898765432100123456789876543210 = - Lambda_0123456789876543210 a0123456789876543210 b0123456789876543210 x_01234567898765432100123456789876543210 - 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 x_0123456789876543210 where - Lambda_0123456789876543210 d x_0123456789876543210 = Case_0123456789876543210 x_0123456789876543210 d x_0123456789876543210 - data Lambda_0123456789876543210Sym0 d0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 d0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 d0123456789876543210 = Lambda_0123456789876543210Sym1 d0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 d0123456789876543210 x_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym1 d0123456789876543210) arg) (Lambda_0123456789876543210Sym2 d0123456789876543210 arg) => - Lambda_0123456789876543210Sym1 d0123456789876543210 x_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 d0123456789876543210) x_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym2 d0123456789876543210 x_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 d0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - type Lambda_0123456789876543210Sym2 d0123456789876543210 x_01234567898765432100123456789876543210 = - Lambda_0123456789876543210 d0123456789876543210 x_01234567898765432100123456789876543210 - 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 x_0123456789876543210 where - Lambda_0123456789876543210 d x x_0123456789876543210 = Case_0123456789876543210 x_0123456789876543210 d x x_0123456789876543210 - data Lambda_0123456789876543210Sym0 d0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 d0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 d0123456789876543210 = Lambda_0123456789876543210Sym1 d0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 d0123456789876543210 x0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 d0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 d0123456789876543210 x0123456789876543210 x_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym2 d0123456789876543210 x0123456789876543210) arg) (Lambda_0123456789876543210Sym3 d0123456789876543210 x0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 d0123456789876543210 x0123456789876543210 x_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 d0123456789876543210 x0123456789876543210) x_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym3 d0123456789876543210 x0123456789876543210 x_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 d0123456789876543210 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - type Lambda_0123456789876543210Sym3 d0123456789876543210 x0123456789876543210 x_01234567898765432100123456789876543210 = - Lambda_0123456789876543210 d0123456789876543210 x0123456789876543210 x_01234567898765432100123456789876543210 - type Foo3Sym0 :: (~>) a ((~>) b a) - data Foo3Sym0 a0123456789876543210 - where - Foo3Sym0KindInference :: SameKind (Apply Foo3Sym0 arg) (Foo3Sym1 arg) => - Foo3Sym0 a0123456789876543210 - type instance Apply Foo3Sym0 a0123456789876543210 = Foo3Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo3Sym0 where - suppressUnusedWarnings = snd (((,) Foo3Sym0KindInference) ()) - type Foo3Sym1 :: a -> (~>) b a - data Foo3Sym1 a0123456789876543210 a0123456789876543210 - where - Foo3Sym1KindInference :: SameKind (Apply (Foo3Sym1 a0123456789876543210) arg) (Foo3Sym2 a0123456789876543210 arg) => - Foo3Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Foo3Sym1 a0123456789876543210) a0123456789876543210 = Foo3Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Foo3Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) Foo3Sym1KindInference) ()) - type Foo3Sym2 (a0123456789876543210 :: a) (a0123456789876543210 :: b) = - Foo3 a0123456789876543210 a0123456789876543210 :: a - type Foo2Sym0 :: (~>) a ((~>) (Maybe a) a) - data Foo2Sym0 a0123456789876543210 - where - Foo2Sym0KindInference :: SameKind (Apply Foo2Sym0 arg) (Foo2Sym1 arg) => - Foo2Sym0 a0123456789876543210 - type instance Apply Foo2Sym0 a0123456789876543210 = Foo2Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo2Sym0 where - suppressUnusedWarnings = snd (((,) Foo2Sym0KindInference) ()) - type Foo2Sym1 :: a -> (~>) (Maybe a) a - data Foo2Sym1 a0123456789876543210 a0123456789876543210 - where - Foo2Sym1KindInference :: SameKind (Apply (Foo2Sym1 a0123456789876543210) arg) (Foo2Sym2 a0123456789876543210 arg) => - Foo2Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Foo2Sym1 a0123456789876543210) a0123456789876543210 = Foo2Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Foo2Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) Foo2Sym1KindInference) ()) - type Foo2Sym2 (a0123456789876543210 :: a) (a0123456789876543210 :: Maybe a) = - Foo2 a0123456789876543210 a0123456789876543210 :: a - type Foo1Sym0 :: (~>) a ((~>) (Maybe a) a) - data Foo1Sym0 a0123456789876543210 - where - Foo1Sym0KindInference :: SameKind (Apply Foo1Sym0 arg) (Foo1Sym1 arg) => - Foo1Sym0 a0123456789876543210 - type instance Apply Foo1Sym0 a0123456789876543210 = Foo1Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo1Sym0 where - suppressUnusedWarnings = snd (((,) Foo1Sym0KindInference) ()) - type Foo1Sym1 :: a -> (~>) (Maybe a) a - data Foo1Sym1 a0123456789876543210 a0123456789876543210 - where - Foo1Sym1KindInference :: SameKind (Apply (Foo1Sym1 a0123456789876543210) arg) (Foo1Sym2 a0123456789876543210 arg) => - Foo1Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Foo1Sym1 a0123456789876543210) a0123456789876543210 = Foo1Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Foo1Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) Foo1Sym1KindInference) ()) - type Foo1Sym2 (a0123456789876543210 :: a) (a0123456789876543210 :: Maybe a) = - Foo1 a0123456789876543210 a0123456789876543210 :: a - type Foo3 :: a -> b -> a - type family Foo3 a a where - Foo3 a b = Apply (Apply (Apply Lambda_0123456789876543210Sym0 a) b) (Apply (Apply Tuple2Sym0 a) b) - type Foo2 :: a -> Maybe a -> a - type family Foo2 a a where - Foo2 d _ = Apply (Apply Lambda_0123456789876543210Sym0 d) (Apply JustSym0 d) - type Foo1 :: a -> Maybe a -> a - type family Foo1 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.golden b/tests/compile-and-dump/Singletons/Lambdas.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Lambdas.golden +++ /dev/null @@ -1,738 +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 FooSym0 :: forall a b. (~>) a ((~>) b (Foo a b)) - data FooSym0 a0123456789876543210 - where - FooSym0KindInference :: SameKind (Apply FooSym0 arg) (FooSym1 arg) => - FooSym0 a0123456789876543210 - type instance Apply FooSym0 a0123456789876543210 = FooSym1 a0123456789876543210 - instance SuppressUnusedWarnings FooSym0 where - suppressUnusedWarnings = snd (((,) FooSym0KindInference) ()) - type FooSym1 :: forall a b. a -> (~>) b (Foo a b) - data FooSym1 a0123456789876543210 a0123456789876543210 - where - FooSym1KindInference :: SameKind (Apply (FooSym1 a0123456789876543210) arg) (FooSym2 a0123456789876543210 arg) => - FooSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (FooSym1 a0123456789876543210) a0123456789876543210 = FooSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (FooSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) FooSym1KindInference) ()) - type FooSym2 (a0123456789876543210 :: a) (a0123456789876543210 :: b) = - Foo a0123456789876543210 a0123456789876543210 :: Foo a b - type family Case_0123456789876543210 arg_0123456789876543210 x t where - Case_0123456789876543210 arg_0123456789876543210 x (Foo a _) = a - type family Lambda_0123456789876543210 x arg_0123456789876543210 where - Lambda_0123456789876543210 x arg_0123456789876543210 = Case_0123456789876543210 arg_0123456789876543210 x arg_0123456789876543210 - data Lambda_0123456789876543210Sym0 x0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 x0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 x0123456789876543210 = Lambda_0123456789876543210Sym1 x0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 x0123456789876543210 arg_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym1 x0123456789876543210) arg) (Lambda_0123456789876543210Sym2 x0123456789876543210 arg) => - Lambda_0123456789876543210Sym1 x0123456789876543210 arg_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 x0123456789876543210) arg_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym2 x0123456789876543210 arg_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - type Lambda_0123456789876543210Sym2 x0123456789876543210 arg_01234567898765432100123456789876543210 = - Lambda_0123456789876543210 x0123456789876543210 arg_01234567898765432100123456789876543210 - type family Case_0123456789876543210 arg_0123456789876543210 x y t where - Case_0123456789876543210 arg_0123456789876543210 x y '(_, b) = b - type family Lambda_0123456789876543210 x y arg_0123456789876543210 where - Lambda_0123456789876543210 x y arg_0123456789876543210 = Case_0123456789876543210 arg_0123456789876543210 x y arg_0123456789876543210 - data Lambda_0123456789876543210Sym0 x0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 x0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 x0123456789876543210 = Lambda_0123456789876543210Sym1 x0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 x0123456789876543210 y0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210 arg_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210) arg) (Lambda_0123456789876543210Sym3 x0123456789876543210 y0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210 arg_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210) arg_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym3 x0123456789876543210 y0123456789876543210 arg_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - type Lambda_0123456789876543210Sym3 x0123456789876543210 y0123456789876543210 arg_01234567898765432100123456789876543210 = - Lambda_0123456789876543210 x0123456789876543210 y0123456789876543210 arg_01234567898765432100123456789876543210 - 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 arg_0123456789876543210 where - Lambda_0123456789876543210 x a b arg_0123456789876543210 = Case_0123456789876543210 arg_0123456789876543210 x a b arg_0123456789876543210 - data Lambda_0123456789876543210Sym0 x0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 x0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 x0123456789876543210 = Lambda_0123456789876543210Sym1 x0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 x0123456789876543210 a0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 x0123456789876543210 a0123456789876543210 b0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym2 x0123456789876543210 a0123456789876543210) arg) (Lambda_0123456789876543210Sym3 x0123456789876543210 a0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 x0123456789876543210 a0123456789876543210 b0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 x0123456789876543210 a0123456789876543210) b0123456789876543210 = Lambda_0123456789876543210Sym3 x0123456789876543210 a0123456789876543210 b0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 x0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym3 x0123456789876543210 a0123456789876543210 b0123456789876543210 arg_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym3KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym3 x0123456789876543210 a0123456789876543210 b0123456789876543210) arg) (Lambda_0123456789876543210Sym4 x0123456789876543210 a0123456789876543210 b0123456789876543210 arg) => - Lambda_0123456789876543210Sym3 x0123456789876543210 a0123456789876543210 b0123456789876543210 arg_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym3 x0123456789876543210 a0123456789876543210 b0123456789876543210) arg_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym4 x0123456789876543210 a0123456789876543210 b0123456789876543210 arg_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym3 x0123456789876543210 a0123456789876543210 b0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym3KindInference) ()) - type Lambda_0123456789876543210Sym4 x0123456789876543210 a0123456789876543210 b0123456789876543210 arg_01234567898765432100123456789876543210 = - Lambda_0123456789876543210 x0123456789876543210 a0123456789876543210 b0123456789876543210 arg_01234567898765432100123456789876543210 - type family Lambda_0123456789876543210 a b x where - Lambda_0123456789876543210 a b x = Apply (Apply (Apply Lambda_0123456789876543210Sym0 x) a) b - data Lambda_0123456789876543210Sym0 a0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 a0123456789876543210 = Lambda_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 a0123456789876543210 b0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 a0123456789876543210 b0123456789876543210 x0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym2 a0123456789876543210 b0123456789876543210) arg) (Lambda_0123456789876543210Sym3 a0123456789876543210 b0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 a0123456789876543210 b0123456789876543210 x0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 a0123456789876543210 b0123456789876543210) x0123456789876543210 = Lambda_0123456789876543210Sym3 a0123456789876543210 b0123456789876543210 x0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 a0123456789876543210 b0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - type Lambda_0123456789876543210Sym3 a0123456789876543210 b0123456789876543210 x0123456789876543210 = - Lambda_0123456789876543210 a0123456789876543210 b0123456789876543210 x0123456789876543210 - type family Lambda_0123456789876543210 x y x where - Lambda_0123456789876543210 x y x = x - data Lambda_0123456789876543210Sym0 x0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 x0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 x0123456789876543210 = Lambda_0123456789876543210Sym1 x0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 x0123456789876543210 y0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210 x0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210) arg) (Lambda_0123456789876543210Sym3 x0123456789876543210 y0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210 x0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210) x0123456789876543210 = Lambda_0123456789876543210Sym3 x0123456789876543210 y0123456789876543210 x0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - type Lambda_0123456789876543210Sym3 x0123456789876543210 y0123456789876543210 x0123456789876543210 = - Lambda_0123456789876543210 x0123456789876543210 y0123456789876543210 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 arg_0123456789876543210 arg_0123456789876543210 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) - data Lambda_0123456789876543210Sym0 x0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 x0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 x0123456789876543210 = Lambda_0123456789876543210Sym1 x0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 x0123456789876543210 y0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210 z0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210) arg) (Lambda_0123456789876543210Sym3 x0123456789876543210 y0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210 z0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210) z0123456789876543210 = Lambda_0123456789876543210Sym3 x0123456789876543210 y0123456789876543210 z0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym3 x0123456789876543210 y0123456789876543210 z0123456789876543210 arg_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym3KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym3 x0123456789876543210 y0123456789876543210 z0123456789876543210) arg) (Lambda_0123456789876543210Sym4 x0123456789876543210 y0123456789876543210 z0123456789876543210 arg) => - Lambda_0123456789876543210Sym3 x0123456789876543210 y0123456789876543210 z0123456789876543210 arg_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym3 x0123456789876543210 y0123456789876543210 z0123456789876543210) arg_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym4 x0123456789876543210 y0123456789876543210 z0123456789876543210 arg_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym3 x0123456789876543210 y0123456789876543210 z0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym3KindInference) ()) - data Lambda_0123456789876543210Sym4 x0123456789876543210 y0123456789876543210 z0123456789876543210 arg_01234567898765432100123456789876543210 arg_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym4KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym4 x0123456789876543210 y0123456789876543210 z0123456789876543210 arg_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym5 x0123456789876543210 y0123456789876543210 z0123456789876543210 arg_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym4 x0123456789876543210 y0123456789876543210 z0123456789876543210 arg_01234567898765432100123456789876543210 arg_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym4 x0123456789876543210 y0123456789876543210 z0123456789876543210 arg_01234567898765432100123456789876543210) arg_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym5 x0123456789876543210 y0123456789876543210 z0123456789876543210 arg_01234567898765432100123456789876543210 arg_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym4 x0123456789876543210 y0123456789876543210 z0123456789876543210 arg_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym4KindInference) ()) - type Lambda_0123456789876543210Sym5 x0123456789876543210 y0123456789876543210 z0123456789876543210 arg_01234567898765432100123456789876543210 arg_01234567898765432100123456789876543210 = - Lambda_0123456789876543210 x0123456789876543210 y0123456789876543210 z0123456789876543210 arg_01234567898765432100123456789876543210 arg_01234567898765432100123456789876543210 - type family Lambda_0123456789876543210 x y where - Lambda_0123456789876543210 x y = y - data Lambda_0123456789876543210Sym0 x0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 x0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 x0123456789876543210 = Lambda_0123456789876543210Sym1 x0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 x0123456789876543210 y0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - type Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210 = - Lambda_0123456789876543210 x0123456789876543210 y0123456789876543210 - type family Case_0123456789876543210 arg_0123456789876543210 x y t where - Case_0123456789876543210 arg_0123456789876543210 x y _ = x - type family Lambda_0123456789876543210 x y arg_0123456789876543210 where - Lambda_0123456789876543210 x y arg_0123456789876543210 = Case_0123456789876543210 arg_0123456789876543210 x y arg_0123456789876543210 - data Lambda_0123456789876543210Sym0 x0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 x0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 x0123456789876543210 = Lambda_0123456789876543210Sym1 x0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 x0123456789876543210 y0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210 arg_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210) arg) (Lambda_0123456789876543210Sym3 x0123456789876543210 y0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210 arg_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210) arg_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym3 x0123456789876543210 y0123456789876543210 arg_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - type Lambda_0123456789876543210Sym3 x0123456789876543210 y0123456789876543210 arg_01234567898765432100123456789876543210 = - Lambda_0123456789876543210 x0123456789876543210 y0123456789876543210 arg_01234567898765432100123456789876543210 - 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 arg_0123456789876543210 where - Lambda_0123456789876543210 x a_0123456789876543210 arg_0123456789876543210 = Case_0123456789876543210 arg_0123456789876543210 x a_0123456789876543210 arg_0123456789876543210 - data Lambda_0123456789876543210Sym0 x0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 x0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 x0123456789876543210 = Lambda_0123456789876543210Sym1 x0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 x0123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 x0123456789876543210 a_01234567898765432100123456789876543210 arg_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym2 x0123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym3 x0123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym2 x0123456789876543210 a_01234567898765432100123456789876543210 arg_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 x0123456789876543210 a_01234567898765432100123456789876543210) arg_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym3 x0123456789876543210 a_01234567898765432100123456789876543210 arg_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 x0123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - type Lambda_0123456789876543210Sym3 x0123456789876543210 a_01234567898765432100123456789876543210 arg_01234567898765432100123456789876543210 = - Lambda_0123456789876543210 x0123456789876543210 a_01234567898765432100123456789876543210 arg_01234567898765432100123456789876543210 - type family Lambda_0123456789876543210 a_0123456789876543210 a_0123456789876543210 x y where - Lambda_0123456789876543210 a_0123456789876543210 a_0123456789876543210 x y = x - data Lambda_0123456789876543210Sym0 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 a_01234567898765432100123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 x0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 x0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) x0123456789876543210 = Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 x0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 x0123456789876543210 y0123456789876543210 - where - Lambda_0123456789876543210Sym3KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 x0123456789876543210) arg) (Lambda_0123456789876543210Sym4 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 x0123456789876543210 arg) => - Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 x0123456789876543210 y0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 x0123456789876543210) y0123456789876543210 = Lambda_0123456789876543210Sym4 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 x0123456789876543210 y0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym3KindInference) ()) - type Lambda_0123456789876543210Sym4 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 x0123456789876543210 y0123456789876543210 = - Lambda_0123456789876543210 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 x0123456789876543210 y0123456789876543210 - type Foo8Sym0 :: (~>) (Foo a b) a - data Foo8Sym0 a0123456789876543210 - where - Foo8Sym0KindInference :: SameKind (Apply Foo8Sym0 arg) (Foo8Sym1 arg) => - Foo8Sym0 a0123456789876543210 - type instance Apply Foo8Sym0 a0123456789876543210 = Foo8Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo8Sym0 where - suppressUnusedWarnings = snd (((,) Foo8Sym0KindInference) ()) - type Foo8Sym1 (a0123456789876543210 :: Foo a b) = - Foo8 a0123456789876543210 :: a - type Foo7Sym0 :: (~>) a ((~>) b b) - data Foo7Sym0 a0123456789876543210 - where - Foo7Sym0KindInference :: SameKind (Apply Foo7Sym0 arg) (Foo7Sym1 arg) => - Foo7Sym0 a0123456789876543210 - type instance Apply Foo7Sym0 a0123456789876543210 = Foo7Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo7Sym0 where - suppressUnusedWarnings = snd (((,) Foo7Sym0KindInference) ()) - type Foo7Sym1 :: a -> (~>) b b - data Foo7Sym1 a0123456789876543210 a0123456789876543210 - where - Foo7Sym1KindInference :: SameKind (Apply (Foo7Sym1 a0123456789876543210) arg) (Foo7Sym2 a0123456789876543210 arg) => - Foo7Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Foo7Sym1 a0123456789876543210) a0123456789876543210 = Foo7Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Foo7Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) Foo7Sym1KindInference) ()) - type Foo7Sym2 (a0123456789876543210 :: a) (a0123456789876543210 :: b) = - Foo7 a0123456789876543210 a0123456789876543210 :: b - type Foo6Sym0 :: (~>) a ((~>) b a) - data Foo6Sym0 a0123456789876543210 - where - Foo6Sym0KindInference :: SameKind (Apply Foo6Sym0 arg) (Foo6Sym1 arg) => - Foo6Sym0 a0123456789876543210 - type instance Apply Foo6Sym0 a0123456789876543210 = Foo6Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo6Sym0 where - suppressUnusedWarnings = snd (((,) Foo6Sym0KindInference) ()) - type Foo6Sym1 :: a -> (~>) b a - data Foo6Sym1 a0123456789876543210 a0123456789876543210 - where - Foo6Sym1KindInference :: SameKind (Apply (Foo6Sym1 a0123456789876543210) arg) (Foo6Sym2 a0123456789876543210 arg) => - Foo6Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Foo6Sym1 a0123456789876543210) a0123456789876543210 = Foo6Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Foo6Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) Foo6Sym1KindInference) ()) - type Foo6Sym2 (a0123456789876543210 :: a) (a0123456789876543210 :: b) = - Foo6 a0123456789876543210 a0123456789876543210 :: a - type Foo5Sym0 :: (~>) a ((~>) b b) - data Foo5Sym0 a0123456789876543210 - where - Foo5Sym0KindInference :: SameKind (Apply Foo5Sym0 arg) (Foo5Sym1 arg) => - Foo5Sym0 a0123456789876543210 - type instance Apply Foo5Sym0 a0123456789876543210 = Foo5Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo5Sym0 where - suppressUnusedWarnings = snd (((,) Foo5Sym0KindInference) ()) - type Foo5Sym1 :: a -> (~>) b b - data Foo5Sym1 a0123456789876543210 a0123456789876543210 - where - Foo5Sym1KindInference :: SameKind (Apply (Foo5Sym1 a0123456789876543210) arg) (Foo5Sym2 a0123456789876543210 arg) => - Foo5Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Foo5Sym1 a0123456789876543210) a0123456789876543210 = Foo5Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Foo5Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) Foo5Sym1KindInference) ()) - type Foo5Sym2 (a0123456789876543210 :: a) (a0123456789876543210 :: b) = - Foo5 a0123456789876543210 a0123456789876543210 :: b - type Foo4Sym0 :: (~>) a ((~>) b ((~>) c a)) - data Foo4Sym0 a0123456789876543210 - where - Foo4Sym0KindInference :: SameKind (Apply Foo4Sym0 arg) (Foo4Sym1 arg) => - Foo4Sym0 a0123456789876543210 - type instance Apply Foo4Sym0 a0123456789876543210 = Foo4Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo4Sym0 where - suppressUnusedWarnings = snd (((,) Foo4Sym0KindInference) ()) - type Foo4Sym1 :: a -> (~>) b ((~>) c a) - data Foo4Sym1 a0123456789876543210 a0123456789876543210 - where - Foo4Sym1KindInference :: SameKind (Apply (Foo4Sym1 a0123456789876543210) arg) (Foo4Sym2 a0123456789876543210 arg) => - Foo4Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Foo4Sym1 a0123456789876543210) a0123456789876543210 = Foo4Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Foo4Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) Foo4Sym1KindInference) ()) - type Foo4Sym2 :: a -> b -> (~>) c a - data Foo4Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - Foo4Sym2KindInference :: SameKind (Apply (Foo4Sym2 a0123456789876543210 a0123456789876543210) arg) (Foo4Sym3 a0123456789876543210 a0123456789876543210 arg) => - Foo4Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (Foo4Sym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = Foo4Sym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Foo4Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) Foo4Sym2KindInference) ()) - type Foo4Sym3 (a0123456789876543210 :: a) (a0123456789876543210 :: b) (a0123456789876543210 :: c) = - Foo4 a0123456789876543210 a0123456789876543210 a0123456789876543210 :: a - type Foo3Sym0 :: (~>) a a - data Foo3Sym0 a0123456789876543210 - where - Foo3Sym0KindInference :: SameKind (Apply Foo3Sym0 arg) (Foo3Sym1 arg) => - Foo3Sym0 a0123456789876543210 - type instance Apply Foo3Sym0 a0123456789876543210 = Foo3Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo3Sym0 where - suppressUnusedWarnings = snd (((,) Foo3Sym0KindInference) ()) - type Foo3Sym1 (a0123456789876543210 :: a) = - Foo3 a0123456789876543210 :: a - type Foo2Sym0 :: (~>) a ((~>) b a) - data Foo2Sym0 a0123456789876543210 - where - Foo2Sym0KindInference :: SameKind (Apply Foo2Sym0 arg) (Foo2Sym1 arg) => - Foo2Sym0 a0123456789876543210 - type instance Apply Foo2Sym0 a0123456789876543210 = Foo2Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo2Sym0 where - suppressUnusedWarnings = snd (((,) Foo2Sym0KindInference) ()) - type Foo2Sym1 :: a -> (~>) b a - data Foo2Sym1 a0123456789876543210 a0123456789876543210 - where - Foo2Sym1KindInference :: SameKind (Apply (Foo2Sym1 a0123456789876543210) arg) (Foo2Sym2 a0123456789876543210 arg) => - Foo2Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Foo2Sym1 a0123456789876543210) a0123456789876543210 = Foo2Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Foo2Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) Foo2Sym1KindInference) ()) - type Foo2Sym2 (a0123456789876543210 :: a) (a0123456789876543210 :: b) = - Foo2 a0123456789876543210 a0123456789876543210 :: a - type Foo1Sym0 :: (~>) a ((~>) b a) - data Foo1Sym0 a0123456789876543210 - where - Foo1Sym0KindInference :: SameKind (Apply Foo1Sym0 arg) (Foo1Sym1 arg) => - Foo1Sym0 a0123456789876543210 - type instance Apply Foo1Sym0 a0123456789876543210 = Foo1Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo1Sym0 where - suppressUnusedWarnings = snd (((,) Foo1Sym0KindInference) ()) - type Foo1Sym1 :: a -> (~>) b a - data Foo1Sym1 a0123456789876543210 a0123456789876543210 - where - Foo1Sym1KindInference :: SameKind (Apply (Foo1Sym1 a0123456789876543210) arg) (Foo1Sym2 a0123456789876543210 arg) => - Foo1Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Foo1Sym1 a0123456789876543210) a0123456789876543210 = Foo1Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Foo1Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) Foo1Sym1KindInference) ()) - type Foo1Sym2 (a0123456789876543210 :: a) (a0123456789876543210 :: b) = - Foo1 a0123456789876543210 a0123456789876543210 :: a - type Foo0Sym0 :: (~>) a ((~>) b a) - data Foo0Sym0 a0123456789876543210 - where - Foo0Sym0KindInference :: SameKind (Apply Foo0Sym0 arg) (Foo0Sym1 arg) => - Foo0Sym0 a0123456789876543210 - type instance Apply Foo0Sym0 a0123456789876543210 = Foo0Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo0Sym0 where - suppressUnusedWarnings = snd (((,) Foo0Sym0KindInference) ()) - type Foo0Sym1 :: a -> (~>) b a - data Foo0Sym1 a0123456789876543210 a0123456789876543210 - where - Foo0Sym1KindInference :: SameKind (Apply (Foo0Sym1 a0123456789876543210) arg) (Foo0Sym2 a0123456789876543210 arg) => - Foo0Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Foo0Sym1 a0123456789876543210) a0123456789876543210 = Foo0Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Foo0Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) Foo0Sym1KindInference) ()) - type Foo0Sym2 (a0123456789876543210 :: a) (a0123456789876543210 :: b) = - Foo0 a0123456789876543210 a0123456789876543210 :: a - type Foo8 :: Foo a b -> a - type family Foo8 a where - Foo8 x = Apply (Apply Lambda_0123456789876543210Sym0 x) x - type Foo7 :: a -> b -> b - type family Foo7 a a where - Foo7 x y = Apply (Apply (Apply Lambda_0123456789876543210Sym0 x) y) (Apply (Apply Tuple2Sym0 x) y) - type Foo6 :: a -> b -> a - type family Foo6 a a where - Foo6 a b = Apply (Apply (Apply (Apply Lambda_0123456789876543210Sym0 a) b) a) b - type Foo5 :: a -> b -> b - type family Foo5 a a where - Foo5 x y = Apply (Apply (Apply Lambda_0123456789876543210Sym0 x) y) y - type Foo4 :: a -> b -> c -> a - type family Foo4 a a a where - Foo4 x y z = Apply (Apply (Apply (Apply (Apply Lambda_0123456789876543210Sym0 x) y) z) y) z - type Foo3 :: a -> a - type family Foo3 a where - Foo3 x = Apply (Apply Lambda_0123456789876543210Sym0 x) x - type Foo2 :: a -> b -> a - type family Foo2 a a where - Foo2 x y = Apply (Apply (Apply Lambda_0123456789876543210Sym0 x) y) y - type Foo1 :: a -> b -> a - type family Foo1 a a where - Foo1 x a_0123456789876543210 = Apply (Apply (Apply Lambda_0123456789876543210Sym0 x) a_0123456789876543210) a_0123456789876543210 - type Foo0 :: a -> b -> a - type family Foo0 a 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) -> (Sing n) -> SFoo (Foo n n :: Foo a b) - 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.golden b/tests/compile-and-dump/Singletons/LambdasComprehensive.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/LambdasComprehensive.golden +++ /dev/null @@ -1,72 +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 x where - Lambda_0123456789876543210 x = Apply (Apply (Apply Either_Sym0 PredSym0) SuccSym0) x - data Lambda_0123456789876543210Sym0 x0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 x0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 x0123456789876543210 = Lambda_0123456789876543210Sym1 x0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - type Lambda_0123456789876543210Sym1 x0123456789876543210 = - Lambda_0123456789876543210 x0123456789876543210 - type BarSym0 = Bar :: [Nat] - type FooSym0 = Foo :: [Nat] - type Bar :: [Nat] - type family Bar where - Bar = Apply (Apply MapSym0 (Apply (Apply Either_Sym0 PredSym0) SuccSym0)) (Apply (Apply (:@#@$) (Apply LeftSym0 ZeroSym0)) (Apply (Apply (:@#@$) (Apply RightSym0 (Apply SuccSym0 ZeroSym0))) NilSym0)) - type Foo :: [Nat] - type family Foo where - Foo = Apply (Apply MapSym0 Lambda_0123456789876543210Sym0) (Apply (Apply (:@#@$) (Apply LeftSym0 ZeroSym0)) (Apply (Apply (:@#@$) (Apply RightSym0 (Apply SuccSym0 ZeroSym0))) NilSym0)) - 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.golden b/tests/compile-and-dump/Singletons/LetStatements.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/LetStatements.golden +++ /dev/null @@ -1,965 +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 - data Let0123456789876543210ZSym0 x0123456789876543210 - where - Let0123456789876543210ZSym0KindInference :: SameKind (Apply Let0123456789876543210ZSym0 arg) (Let0123456789876543210ZSym1 arg) => - Let0123456789876543210ZSym0 x0123456789876543210 - type instance Apply Let0123456789876543210ZSym0 x0123456789876543210 = Let0123456789876543210ZSym1 x0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210ZSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210ZSym0KindInference) ()) - type Let0123456789876543210ZSym1 x0123456789876543210 = - Let0123456789876543210Z x0123456789876543210 - data Let0123456789876543210YSym0 x0123456789876543210 - where - Let0123456789876543210YSym0KindInference :: SameKind (Apply Let0123456789876543210YSym0 arg) (Let0123456789876543210YSym1 arg) => - Let0123456789876543210YSym0 x0123456789876543210 - type instance Apply Let0123456789876543210YSym0 x0123456789876543210 = Let0123456789876543210YSym1 x0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210YSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210YSym0KindInference) ()) - type Let0123456789876543210YSym1 x0123456789876543210 = - Let0123456789876543210Y x0123456789876543210 - data Let0123456789876543210X_0123456789876543210Sym0 x0123456789876543210 - where - Let0123456789876543210X_0123456789876543210Sym0KindInference :: SameKind (Apply Let0123456789876543210X_0123456789876543210Sym0 arg) (Let0123456789876543210X_0123456789876543210Sym1 arg) => - Let0123456789876543210X_0123456789876543210Sym0 x0123456789876543210 - type instance Apply Let0123456789876543210X_0123456789876543210Sym0 x0123456789876543210 = Let0123456789876543210X_0123456789876543210Sym1 x0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210X_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd - (((,) Let0123456789876543210X_0123456789876543210Sym0KindInference) - ()) - type Let0123456789876543210X_0123456789876543210Sym1 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 - data Let0123456789876543210BarSym0 x0123456789876543210 - where - Let0123456789876543210BarSym0KindInference :: SameKind (Apply Let0123456789876543210BarSym0 arg) (Let0123456789876543210BarSym1 arg) => - Let0123456789876543210BarSym0 x0123456789876543210 - type instance Apply Let0123456789876543210BarSym0 x0123456789876543210 = Let0123456789876543210BarSym1 x0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210BarSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210BarSym0KindInference) ()) - type Let0123456789876543210BarSym1 x0123456789876543210 = - Let0123456789876543210Bar x0123456789876543210 :: a0123456789876543210 - type family Let0123456789876543210Bar x :: a where - Let0123456789876543210Bar x = x - data (<<<%%%%%%%%%%%%%%%%%%%%@#@$) x0123456789876543210 - where - (:<<<%%%%%%%%%%%%%%%%%%%%@#@$###) :: SameKind (Apply (<<<%%%%%%%%%%%%%%%%%%%%@#@$) arg) ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) arg) => - (<<<%%%%%%%%%%%%%%%%%%%%@#@$) x0123456789876543210 - type instance Apply (<<<%%%%%%%%%%%%%%%%%%%%@#@$) x0123456789876543210 = (<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210 - instance SuppressUnusedWarnings (<<<%%%%%%%%%%%%%%%%%%%%@#@$) where - suppressUnusedWarnings - = snd (((,) (:<<<%%%%%%%%%%%%%%%%%%%%@#@$###)) ()) - data (<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210 :: (~>) Nat ((~>) Nat Nat) - where - (:<<<%%%%%%%%%%%%%%%%%%%%@#@$$###) :: SameKind (Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210) arg) ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 arg) => - (<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210 a0123456789876543210 - type instance Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210) a0123456789876543210 = (<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) (:<<<%%%%%%%%%%%%%%%%%%%%@#@$$###)) ()) - data (<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 (a0123456789876543210 :: Nat) :: (~>) Nat Nat - where - (:<<<%%%%%%%%%%%%%%%%%%%%@#@$$$###) :: SameKind (Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 a0123456789876543210) arg) ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$$$) x0123456789876543210 a0123456789876543210 arg) => - (<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 a0123456789876543210) a0123456789876543210 = (<<<%%%%%%%%%%%%%%%%%%%%@#@$$$$) x0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) (:<<<%%%%%%%%%%%%%%%%%%%%@#@$$$###)) ()) - type (<<<%%%%%%%%%%%%%%%%%%%%@#@$$$$) x0123456789876543210 (a0123456789876543210 :: Nat) (a0123456789876543210 :: Nat) = - (<<<%%%%%%%%%%%%%%%%%%%%) x0123456789876543210 a0123456789876543210 a0123456789876543210 :: Nat - type family (<<<%%%%%%%%%%%%%%%%%%%%) x (a :: Nat) (a :: Nat) :: Nat where - (<<<%%%%%%%%%%%%%%%%%%%%) x 'Zero m = m - (<<<%%%%%%%%%%%%%%%%%%%%) x ('Succ n) m = Apply SuccSym0 (Apply (Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x) n) x) - data Let0123456789876543210ZSym0 x0123456789876543210 - where - Let0123456789876543210ZSym0KindInference :: SameKind (Apply Let0123456789876543210ZSym0 arg) (Let0123456789876543210ZSym1 arg) => - Let0123456789876543210ZSym0 x0123456789876543210 - type instance Apply Let0123456789876543210ZSym0 x0123456789876543210 = Let0123456789876543210ZSym1 x0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210ZSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210ZSym0KindInference) ()) - type Let0123456789876543210ZSym1 x0123456789876543210 = - Let0123456789876543210Z x0123456789876543210 :: Nat - data (<<<%%%%%%%%%%%%%%%%%%%%@#@$) x0123456789876543210 - where - (:<<<%%%%%%%%%%%%%%%%%%%%@#@$###) :: SameKind (Apply (<<<%%%%%%%%%%%%%%%%%%%%@#@$) arg) ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) arg) => - (<<<%%%%%%%%%%%%%%%%%%%%@#@$) x0123456789876543210 - type instance Apply (<<<%%%%%%%%%%%%%%%%%%%%@#@$) x0123456789876543210 = (<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210 - instance SuppressUnusedWarnings (<<<%%%%%%%%%%%%%%%%%%%%@#@$) where - suppressUnusedWarnings - = snd (((,) (:<<<%%%%%%%%%%%%%%%%%%%%@#@$###)) ()) - data (<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210 :: (~>) Nat ((~>) Nat Nat) - where - (:<<<%%%%%%%%%%%%%%%%%%%%@#@$$###) :: SameKind (Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210) arg) ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 arg) => - (<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210 a0123456789876543210 - type instance Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210) a0123456789876543210 = (<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) (:<<<%%%%%%%%%%%%%%%%%%%%@#@$$###)) ()) - data (<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 (a0123456789876543210 :: Nat) :: (~>) Nat Nat - where - (:<<<%%%%%%%%%%%%%%%%%%%%@#@$$$###) :: SameKind (Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 a0123456789876543210) arg) ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$$$) x0123456789876543210 a0123456789876543210 arg) => - (<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 a0123456789876543210) a0123456789876543210 = (<<<%%%%%%%%%%%%%%%%%%%%@#@$$$$) x0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) (:<<<%%%%%%%%%%%%%%%%%%%%@#@$$$###)) ()) - type (<<<%%%%%%%%%%%%%%%%%%%%@#@$$$$) x0123456789876543210 (a0123456789876543210 :: Nat) (a0123456789876543210 :: Nat) = - (<<<%%%%%%%%%%%%%%%%%%%%) x0123456789876543210 a0123456789876543210 a0123456789876543210 :: Nat - 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) - data (<<<%%%%%%%%%%%%%%%%%%%%@#@$) x0123456789876543210 - where - (:<<<%%%%%%%%%%%%%%%%%%%%@#@$###) :: SameKind (Apply (<<<%%%%%%%%%%%%%%%%%%%%@#@$) arg) ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) arg) => - (<<<%%%%%%%%%%%%%%%%%%%%@#@$) x0123456789876543210 - type instance Apply (<<<%%%%%%%%%%%%%%%%%%%%@#@$) x0123456789876543210 = (<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210 - instance SuppressUnusedWarnings (<<<%%%%%%%%%%%%%%%%%%%%@#@$) where - suppressUnusedWarnings - = snd (((,) (:<<<%%%%%%%%%%%%%%%%%%%%@#@$###)) ()) - data (<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210 :: (~>) Nat ((~>) Nat Nat) - where - (:<<<%%%%%%%%%%%%%%%%%%%%@#@$$###) :: SameKind (Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210) arg) ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 arg) => - (<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210 a0123456789876543210 - type instance Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210) a0123456789876543210 = (<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) (:<<<%%%%%%%%%%%%%%%%%%%%@#@$$###)) ()) - data (<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 (a0123456789876543210 :: Nat) :: (~>) Nat Nat - where - (:<<<%%%%%%%%%%%%%%%%%%%%@#@$$$###) :: SameKind (Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 a0123456789876543210) arg) ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$$$) x0123456789876543210 a0123456789876543210 arg) => - (<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 a0123456789876543210) a0123456789876543210 = (<<<%%%%%%%%%%%%%%%%%%%%@#@$$$$) x0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$$) x0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) (:<<<%%%%%%%%%%%%%%%%%%%%@#@$$$###)) ()) - type (<<<%%%%%%%%%%%%%%%%%%%%@#@$$$$) x0123456789876543210 (a0123456789876543210 :: Nat) (a0123456789876543210 :: Nat) = - (<<<%%%%%%%%%%%%%%%%%%%%) x0123456789876543210 a0123456789876543210 a0123456789876543210 :: Nat - 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 x where - Lambda_0123456789876543210 a_0123456789876543210 x x = x - data Lambda_0123456789876543210Sym0 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 a_01234567898765432100123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210 x0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 x0123456789876543210 x0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 x0123456789876543210) arg) (Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 x0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 x0123456789876543210 x0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 x0123456789876543210) x0123456789876543210 = Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 x0123456789876543210 x0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - type Lambda_0123456789876543210Sym3 a_01234567898765432100123456789876543210 x0123456789876543210 x0123456789876543210 = - Lambda_0123456789876543210 a_01234567898765432100123456789876543210 x0123456789876543210 x0123456789876543210 - data Let0123456789876543210ZSym0 x0123456789876543210 - where - Let0123456789876543210ZSym0KindInference :: SameKind (Apply Let0123456789876543210ZSym0 arg) (Let0123456789876543210ZSym1 arg) => - Let0123456789876543210ZSym0 x0123456789876543210 - type instance Apply Let0123456789876543210ZSym0 x0123456789876543210 = Let0123456789876543210ZSym1 x0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210ZSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210ZSym0KindInference) ()) - data Let0123456789876543210ZSym1 x0123456789876543210 :: (~>) Nat Nat - where - Let0123456789876543210ZSym1KindInference :: SameKind (Apply (Let0123456789876543210ZSym1 x0123456789876543210) arg) (Let0123456789876543210ZSym2 x0123456789876543210 arg) => - Let0123456789876543210ZSym1 x0123456789876543210 a0123456789876543210 - type instance Apply (Let0123456789876543210ZSym1 x0123456789876543210) a0123456789876543210 = Let0123456789876543210ZSym2 x0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210ZSym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210ZSym1KindInference) ()) - type Let0123456789876543210ZSym2 x0123456789876543210 (a0123456789876543210 :: Nat) = - Let0123456789876543210Z x0123456789876543210 a0123456789876543210 :: Nat - 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 x where - Lambda_0123456789876543210 x x = x - data Lambda_0123456789876543210Sym0 x0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 x0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 x0123456789876543210 = Lambda_0123456789876543210Sym1 x0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 x0123456789876543210 x0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym1 x0123456789876543210) arg) (Lambda_0123456789876543210Sym2 x0123456789876543210 arg) => - Lambda_0123456789876543210Sym1 x0123456789876543210 x0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 x0123456789876543210) x0123456789876543210 = Lambda_0123456789876543210Sym2 x0123456789876543210 x0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - type Lambda_0123456789876543210Sym2 x0123456789876543210 x0123456789876543210 = - Lambda_0123456789876543210 x0123456789876543210 x0123456789876543210 - data Let0123456789876543210ZSym0 x0123456789876543210 - where - Let0123456789876543210ZSym0KindInference :: SameKind (Apply Let0123456789876543210ZSym0 arg) (Let0123456789876543210ZSym1 arg) => - Let0123456789876543210ZSym0 x0123456789876543210 - type instance Apply Let0123456789876543210ZSym0 x0123456789876543210 = Let0123456789876543210ZSym1 x0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210ZSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210ZSym0KindInference) ()) - type Let0123456789876543210ZSym1 x0123456789876543210 = - Let0123456789876543210Z x0123456789876543210 :: Nat - type family Let0123456789876543210Z x :: Nat where - Let0123456789876543210Z x = Apply (Apply Lambda_0123456789876543210Sym0 x) ZeroSym0 - data Let0123456789876543210XSym0 x0123456789876543210 - where - Let0123456789876543210XSym0KindInference :: SameKind (Apply Let0123456789876543210XSym0 arg) (Let0123456789876543210XSym1 arg) => - Let0123456789876543210XSym0 x0123456789876543210 - type instance Apply Let0123456789876543210XSym0 x0123456789876543210 = Let0123456789876543210XSym1 x0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210XSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210XSym0KindInference) ()) - type Let0123456789876543210XSym1 x0123456789876543210 = - Let0123456789876543210X x0123456789876543210 :: Nat - type family Let0123456789876543210X x :: Nat where - Let0123456789876543210X x = ZeroSym0 - data Let0123456789876543210FSym0 x0123456789876543210 - where - Let0123456789876543210FSym0KindInference :: SameKind (Apply Let0123456789876543210FSym0 arg) (Let0123456789876543210FSym1 arg) => - Let0123456789876543210FSym0 x0123456789876543210 - type instance Apply Let0123456789876543210FSym0 x0123456789876543210 = Let0123456789876543210FSym1 x0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210FSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210FSym0KindInference) ()) - data Let0123456789876543210FSym1 x0123456789876543210 :: (~>) Nat Nat - where - Let0123456789876543210FSym1KindInference :: SameKind (Apply (Let0123456789876543210FSym1 x0123456789876543210) arg) (Let0123456789876543210FSym2 x0123456789876543210 arg) => - Let0123456789876543210FSym1 x0123456789876543210 a0123456789876543210 - type instance Apply (Let0123456789876543210FSym1 x0123456789876543210) a0123456789876543210 = Let0123456789876543210FSym2 x0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210FSym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210FSym1KindInference) ()) - type Let0123456789876543210FSym2 x0123456789876543210 (a0123456789876543210 :: Nat) = - Let0123456789876543210F x0123456789876543210 a0123456789876543210 :: Nat - type family Let0123456789876543210F x (a :: Nat) :: Nat where - Let0123456789876543210F x y = Apply SuccSym0 y - data Let0123456789876543210ZSym0 x0123456789876543210 - where - Let0123456789876543210ZSym0KindInference :: SameKind (Apply Let0123456789876543210ZSym0 arg) (Let0123456789876543210ZSym1 arg) => - Let0123456789876543210ZSym0 x0123456789876543210 - type instance Apply Let0123456789876543210ZSym0 x0123456789876543210 = Let0123456789876543210ZSym1 x0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210ZSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210ZSym0KindInference) ()) - type Let0123456789876543210ZSym1 x0123456789876543210 = - Let0123456789876543210Z x0123456789876543210 :: Nat - type family Let0123456789876543210Z x :: Nat where - Let0123456789876543210Z x = Apply (Let0123456789876543210FSym1 x) x - data Let0123456789876543210ZSym0 y0123456789876543210 - where - Let0123456789876543210ZSym0KindInference :: SameKind (Apply Let0123456789876543210ZSym0 arg) (Let0123456789876543210ZSym1 arg) => - Let0123456789876543210ZSym0 y0123456789876543210 - type instance Apply Let0123456789876543210ZSym0 y0123456789876543210 = Let0123456789876543210ZSym1 y0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210ZSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210ZSym0KindInference) ()) - data Let0123456789876543210ZSym1 y0123456789876543210 x0123456789876543210 - where - Let0123456789876543210ZSym1KindInference :: SameKind (Apply (Let0123456789876543210ZSym1 y0123456789876543210) arg) (Let0123456789876543210ZSym2 y0123456789876543210 arg) => - Let0123456789876543210ZSym1 y0123456789876543210 x0123456789876543210 - type instance Apply (Let0123456789876543210ZSym1 y0123456789876543210) x0123456789876543210 = Let0123456789876543210ZSym2 y0123456789876543210 x0123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210ZSym1 y0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210ZSym1KindInference) ()) - type Let0123456789876543210ZSym2 y0123456789876543210 x0123456789876543210 = - Let0123456789876543210Z y0123456789876543210 x0123456789876543210 :: Nat - type family Let0123456789876543210Z y x :: Nat where - Let0123456789876543210Z y x = Apply SuccSym0 y - data Let0123456789876543210FSym0 x0123456789876543210 - where - Let0123456789876543210FSym0KindInference :: SameKind (Apply Let0123456789876543210FSym0 arg) (Let0123456789876543210FSym1 arg) => - Let0123456789876543210FSym0 x0123456789876543210 - type instance Apply Let0123456789876543210FSym0 x0123456789876543210 = Let0123456789876543210FSym1 x0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210FSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210FSym0KindInference) ()) - data Let0123456789876543210FSym1 x0123456789876543210 :: (~>) Nat Nat - where - Let0123456789876543210FSym1KindInference :: SameKind (Apply (Let0123456789876543210FSym1 x0123456789876543210) arg) (Let0123456789876543210FSym2 x0123456789876543210 arg) => - Let0123456789876543210FSym1 x0123456789876543210 a0123456789876543210 - type instance Apply (Let0123456789876543210FSym1 x0123456789876543210) a0123456789876543210 = Let0123456789876543210FSym2 x0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210FSym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210FSym1KindInference) ()) - type Let0123456789876543210FSym2 x0123456789876543210 (a0123456789876543210 :: Nat) = - Let0123456789876543210F x0123456789876543210 a0123456789876543210 :: Nat - type family Let0123456789876543210F x (a :: Nat) :: Nat where - Let0123456789876543210F x y = Apply SuccSym0 (Let0123456789876543210ZSym2 y x) - data Let0123456789876543210FSym0 x0123456789876543210 - where - Let0123456789876543210FSym0KindInference :: SameKind (Apply Let0123456789876543210FSym0 arg) (Let0123456789876543210FSym1 arg) => - Let0123456789876543210FSym0 x0123456789876543210 - type instance Apply Let0123456789876543210FSym0 x0123456789876543210 = Let0123456789876543210FSym1 x0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210FSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210FSym0KindInference) ()) - data Let0123456789876543210FSym1 x0123456789876543210 :: (~>) Nat Nat - where - Let0123456789876543210FSym1KindInference :: SameKind (Apply (Let0123456789876543210FSym1 x0123456789876543210) arg) (Let0123456789876543210FSym2 x0123456789876543210 arg) => - Let0123456789876543210FSym1 x0123456789876543210 a0123456789876543210 - type instance Apply (Let0123456789876543210FSym1 x0123456789876543210) a0123456789876543210 = Let0123456789876543210FSym2 x0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210FSym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210FSym1KindInference) ()) - type Let0123456789876543210FSym2 x0123456789876543210 (a0123456789876543210 :: Nat) = - Let0123456789876543210F x0123456789876543210 a0123456789876543210 :: Nat - type family Let0123456789876543210F x (a :: Nat) :: Nat where - Let0123456789876543210F x y = Apply SuccSym0 y - data Let0123456789876543210YSym0 x0123456789876543210 - where - Let0123456789876543210YSym0KindInference :: SameKind (Apply Let0123456789876543210YSym0 arg) (Let0123456789876543210YSym1 arg) => - Let0123456789876543210YSym0 x0123456789876543210 - type instance Apply Let0123456789876543210YSym0 x0123456789876543210 = Let0123456789876543210YSym1 x0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210YSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210YSym0KindInference) ()) - type Let0123456789876543210YSym1 x0123456789876543210 = - Let0123456789876543210Y x0123456789876543210 :: Nat - 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 - data Let0123456789876543210YSym0 x0123456789876543210 - where - Let0123456789876543210YSym0KindInference :: SameKind (Apply Let0123456789876543210YSym0 arg) (Let0123456789876543210YSym1 arg) => - Let0123456789876543210YSym0 x0123456789876543210 - type instance Apply Let0123456789876543210YSym0 x0123456789876543210 = Let0123456789876543210YSym1 x0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210YSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210YSym0KindInference) ()) - type Let0123456789876543210YSym1 x0123456789876543210 = - Let0123456789876543210Y x0123456789876543210 :: Nat - type family Let0123456789876543210Y x :: Nat where - Let0123456789876543210Y x = Apply SuccSym0 ZeroSym0 - type Foo14Sym0 :: (~>) Nat (Nat, Nat) - data Foo14Sym0 a0123456789876543210 - where - Foo14Sym0KindInference :: SameKind (Apply Foo14Sym0 arg) (Foo14Sym1 arg) => - Foo14Sym0 a0123456789876543210 - type instance Apply Foo14Sym0 a0123456789876543210 = Foo14Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo14Sym0 where - suppressUnusedWarnings = snd (((,) Foo14Sym0KindInference) ()) - type Foo14Sym1 (a0123456789876543210 :: Nat) = - Foo14 a0123456789876543210 :: (Nat, Nat) - type Foo13_Sym0 :: (~>) a a - data Foo13_Sym0 a0123456789876543210 - where - Foo13_Sym0KindInference :: SameKind (Apply Foo13_Sym0 arg) (Foo13_Sym1 arg) => - Foo13_Sym0 a0123456789876543210 - type instance Apply Foo13_Sym0 a0123456789876543210 = Foo13_Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo13_Sym0 where - suppressUnusedWarnings = snd (((,) Foo13_Sym0KindInference) ()) - type Foo13_Sym1 (a0123456789876543210 :: a) = - Foo13_ a0123456789876543210 :: a - type Foo13Sym0 :: forall a. (~>) a a - data Foo13Sym0 a0123456789876543210 - where - Foo13Sym0KindInference :: SameKind (Apply Foo13Sym0 arg) (Foo13Sym1 arg) => - Foo13Sym0 a0123456789876543210 - type instance Apply Foo13Sym0 a0123456789876543210 = Foo13Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo13Sym0 where - suppressUnusedWarnings = snd (((,) Foo13Sym0KindInference) ()) - type Foo13Sym1 (a0123456789876543210 :: a) = - Foo13 a0123456789876543210 :: a - type Foo12Sym0 :: (~>) Nat Nat - data Foo12Sym0 a0123456789876543210 - where - Foo12Sym0KindInference :: SameKind (Apply Foo12Sym0 arg) (Foo12Sym1 arg) => - Foo12Sym0 a0123456789876543210 - type instance Apply Foo12Sym0 a0123456789876543210 = Foo12Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo12Sym0 where - suppressUnusedWarnings = snd (((,) Foo12Sym0KindInference) ()) - type Foo12Sym1 (a0123456789876543210 :: Nat) = - Foo12 a0123456789876543210 :: Nat - type Foo11Sym0 :: (~>) Nat Nat - data Foo11Sym0 a0123456789876543210 - where - Foo11Sym0KindInference :: SameKind (Apply Foo11Sym0 arg) (Foo11Sym1 arg) => - Foo11Sym0 a0123456789876543210 - type instance Apply Foo11Sym0 a0123456789876543210 = Foo11Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo11Sym0 where - suppressUnusedWarnings = snd (((,) Foo11Sym0KindInference) ()) - type Foo11Sym1 (a0123456789876543210 :: Nat) = - Foo11 a0123456789876543210 :: Nat - type Foo10Sym0 :: (~>) Nat Nat - data Foo10Sym0 a0123456789876543210 - where - Foo10Sym0KindInference :: SameKind (Apply Foo10Sym0 arg) (Foo10Sym1 arg) => - Foo10Sym0 a0123456789876543210 - type instance Apply Foo10Sym0 a0123456789876543210 = Foo10Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo10Sym0 where - suppressUnusedWarnings = snd (((,) Foo10Sym0KindInference) ()) - type Foo10Sym1 (a0123456789876543210 :: Nat) = - Foo10 a0123456789876543210 :: Nat - type Foo9Sym0 :: (~>) Nat Nat - data Foo9Sym0 a0123456789876543210 - where - Foo9Sym0KindInference :: SameKind (Apply Foo9Sym0 arg) (Foo9Sym1 arg) => - Foo9Sym0 a0123456789876543210 - type instance Apply Foo9Sym0 a0123456789876543210 = Foo9Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo9Sym0 where - suppressUnusedWarnings = snd (((,) Foo9Sym0KindInference) ()) - type Foo9Sym1 (a0123456789876543210 :: Nat) = - Foo9 a0123456789876543210 :: Nat - type Foo8Sym0 :: (~>) Nat Nat - data Foo8Sym0 a0123456789876543210 - where - Foo8Sym0KindInference :: SameKind (Apply Foo8Sym0 arg) (Foo8Sym1 arg) => - Foo8Sym0 a0123456789876543210 - type instance Apply Foo8Sym0 a0123456789876543210 = Foo8Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo8Sym0 where - suppressUnusedWarnings = snd (((,) Foo8Sym0KindInference) ()) - type Foo8Sym1 (a0123456789876543210 :: Nat) = - Foo8 a0123456789876543210 :: Nat - type Foo7Sym0 :: (~>) Nat Nat - data Foo7Sym0 a0123456789876543210 - where - Foo7Sym0KindInference :: SameKind (Apply Foo7Sym0 arg) (Foo7Sym1 arg) => - Foo7Sym0 a0123456789876543210 - type instance Apply Foo7Sym0 a0123456789876543210 = Foo7Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo7Sym0 where - suppressUnusedWarnings = snd (((,) Foo7Sym0KindInference) ()) - type Foo7Sym1 (a0123456789876543210 :: Nat) = - Foo7 a0123456789876543210 :: Nat - type Foo6Sym0 :: (~>) Nat Nat - data Foo6Sym0 a0123456789876543210 - where - Foo6Sym0KindInference :: SameKind (Apply Foo6Sym0 arg) (Foo6Sym1 arg) => - Foo6Sym0 a0123456789876543210 - type instance Apply Foo6Sym0 a0123456789876543210 = Foo6Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo6Sym0 where - suppressUnusedWarnings = snd (((,) Foo6Sym0KindInference) ()) - type Foo6Sym1 (a0123456789876543210 :: Nat) = - Foo6 a0123456789876543210 :: Nat - type Foo5Sym0 :: (~>) Nat Nat - data Foo5Sym0 a0123456789876543210 - where - Foo5Sym0KindInference :: SameKind (Apply Foo5Sym0 arg) (Foo5Sym1 arg) => - Foo5Sym0 a0123456789876543210 - type instance Apply Foo5Sym0 a0123456789876543210 = Foo5Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo5Sym0 where - suppressUnusedWarnings = snd (((,) Foo5Sym0KindInference) ()) - type Foo5Sym1 (a0123456789876543210 :: Nat) = - Foo5 a0123456789876543210 :: Nat - type Foo4Sym0 :: (~>) Nat Nat - data Foo4Sym0 a0123456789876543210 - where - Foo4Sym0KindInference :: SameKind (Apply Foo4Sym0 arg) (Foo4Sym1 arg) => - Foo4Sym0 a0123456789876543210 - type instance Apply Foo4Sym0 a0123456789876543210 = Foo4Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo4Sym0 where - suppressUnusedWarnings = snd (((,) Foo4Sym0KindInference) ()) - type Foo4Sym1 (a0123456789876543210 :: Nat) = - Foo4 a0123456789876543210 :: Nat - type Foo3Sym0 :: (~>) Nat Nat - data Foo3Sym0 a0123456789876543210 - where - Foo3Sym0KindInference :: SameKind (Apply Foo3Sym0 arg) (Foo3Sym1 arg) => - Foo3Sym0 a0123456789876543210 - type instance Apply Foo3Sym0 a0123456789876543210 = Foo3Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo3Sym0 where - suppressUnusedWarnings = snd (((,) Foo3Sym0KindInference) ()) - type Foo3Sym1 (a0123456789876543210 :: Nat) = - Foo3 a0123456789876543210 :: Nat - type Foo2Sym0 = Foo2 :: Nat - type Foo1Sym0 :: (~>) Nat Nat - data Foo1Sym0 a0123456789876543210 - where - Foo1Sym0KindInference :: SameKind (Apply Foo1Sym0 arg) (Foo1Sym1 arg) => - Foo1Sym0 a0123456789876543210 - type instance Apply Foo1Sym0 a0123456789876543210 = Foo1Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo1Sym0 where - suppressUnusedWarnings = snd (((,) Foo1Sym0KindInference) ()) - type Foo1Sym1 (a0123456789876543210 :: Nat) = - Foo1 a0123456789876543210 :: Nat - type Foo14 :: Nat -> (Nat, Nat) - type family Foo14 a where - Foo14 x = Apply (Apply Tuple2Sym0 (Let0123456789876543210ZSym1 x)) (Let0123456789876543210YSym1 x) - type Foo13_ :: a -> a - type family Foo13_ a where - Foo13_ y = y - type Foo13 :: forall a. a -> a - type family Foo13 a where - Foo13 x = Apply Foo13_Sym0 (Let0123456789876543210BarSym1 x) - type Foo12 :: Nat -> Nat - type family Foo12 a where - Foo12 x = Apply (Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x) x) (Apply SuccSym0 (Apply SuccSym0 ZeroSym0)) - type Foo11 :: Nat -> Nat - type family Foo11 a where - Foo11 x = Apply (Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x) (Apply SuccSym0 ZeroSym0)) (Let0123456789876543210ZSym1 x) - type Foo10 :: Nat -> Nat - type family Foo10 a where - Foo10 x = Apply (Apply ((<<<%%%%%%%%%%%%%%%%%%%%@#@$$) x) (Apply SuccSym0 ZeroSym0)) x - type Foo9 :: Nat -> Nat - type family Foo9 a where - Foo9 x = Apply (Let0123456789876543210ZSym1 x) x - type Foo8 :: Nat -> Nat - type family Foo8 a where - Foo8 x = Let0123456789876543210ZSym1 x - type Foo7 :: Nat -> Nat - type family Foo7 a where - Foo7 x = Let0123456789876543210XSym1 x - type Foo6 :: Nat -> Nat - type family Foo6 a where - Foo6 x = Let0123456789876543210ZSym1 x - type Foo5 :: Nat -> Nat - type family Foo5 a where - Foo5 x = Apply (Let0123456789876543210FSym1 x) x - type Foo4 :: Nat -> Nat - type family Foo4 a where - Foo4 x = Apply (Let0123456789876543210FSym1 x) x - type Foo3 :: Nat -> Nat - type family Foo3 a where - Foo3 x = Let0123456789876543210YSym1 x - type Foo2 :: Nat - type family Foo2 where - Foo2 = Let0123456789876543210ZSym0 - type Foo1 :: Nat -> Nat - type family Foo1 a 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.golden b/tests/compile-and-dump/Singletons/Maybe.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Maybe.golden +++ /dev/null @@ -1,156 +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 :: Maybe a - type JustSym0 :: forall a. (~>) a (Maybe a) - data JustSym0 a0123456789876543210 - where - JustSym0KindInference :: SameKind (Apply JustSym0 arg) (JustSym1 arg) => - JustSym0 a0123456789876543210 - type instance Apply JustSym0 a0123456789876543210 = JustSym1 a0123456789876543210 - instance SuppressUnusedWarnings JustSym0 where - suppressUnusedWarnings = snd (((,) JustSym0KindInference) ()) - type JustSym1 (a0123456789876543210 :: a) = - Just a0123456789876543210 :: Maybe a - type ShowsPrec_0123456789876543210 :: GHC.Types.Nat - -> Maybe a -> GHC.Types.Symbol -> GHC.Types.Symbol - type family ShowsPrec_0123456789876543210 a a a 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_0123456789876543210Sym0 :: (~>) GHC.Types.Nat ((~>) (Maybe a) ((~>) GHC.Types.Symbol GHC.Types.Symbol)) - data ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym0KindInference :: SameKind (Apply ShowsPrec_0123456789876543210Sym0 arg) (ShowsPrec_0123456789876543210Sym1 arg) => - ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ShowsPrec_0123456789876543210Sym0 a0123456789876543210 = ShowsPrec_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings ShowsPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym0KindInference) ()) - type ShowsPrec_0123456789876543210Sym1 :: GHC.Types.Nat - -> (~>) (Maybe a) ((~>) GHC.Types.Symbol GHC.Types.Symbol) - data ShowsPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym1KindInference) ()) - type ShowsPrec_0123456789876543210Sym2 :: GHC.Types.Nat - -> Maybe a -> (~>) GHC.Types.Symbol GHC.Types.Symbol - data ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym2KindInference :: 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_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym2KindInference) ()) - type ShowsPrec_0123456789876543210Sym3 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: Maybe a) (a0123456789876543210 :: GHC.Types.Symbol) = - ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 :: GHC.Types.Symbol - instance PShow (Maybe a) where - type ShowsPrec a a a = Apply (Apply (Apply ShowsPrec_0123456789876543210Sym0 a) a) a - type Equals_0123456789876543210 :: Maybe a -> Maybe a -> Bool - type family Equals_0123456789876543210 a b 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 :: forall a. SMaybe (Nothing :: Maybe a) - SJust :: forall a (n :: a). (Sing n) -> SMaybe (Just n :: Maybe a) - 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.golden b/tests/compile-and-dump/Singletons/Nat.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Nat.golden +++ /dev/null @@ -1,286 +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 :: Nat - type SuccSym0 :: (~>) Nat Nat - data SuccSym0 a0123456789876543210 - where - SuccSym0KindInference :: SameKind (Apply SuccSym0 arg) (SuccSym1 arg) => - SuccSym0 a0123456789876543210 - type instance Apply SuccSym0 a0123456789876543210 = SuccSym1 a0123456789876543210 - instance SuppressUnusedWarnings SuccSym0 where - suppressUnusedWarnings = snd (((,) SuccSym0KindInference) ()) - type SuccSym1 (a0123456789876543210 :: Nat) = - Succ a0123456789876543210 :: Nat - type PredSym0 :: (~>) Nat Nat - data PredSym0 a0123456789876543210 - where - PredSym0KindInference :: SameKind (Apply PredSym0 arg) (PredSym1 arg) => - PredSym0 a0123456789876543210 - type instance Apply PredSym0 a0123456789876543210 = PredSym1 a0123456789876543210 - instance SuppressUnusedWarnings PredSym0 where - suppressUnusedWarnings = snd (((,) PredSym0KindInference) ()) - type PredSym1 (a0123456789876543210 :: Nat) = - Pred a0123456789876543210 :: Nat - type PlusSym0 :: (~>) Nat ((~>) Nat Nat) - data PlusSym0 a0123456789876543210 - where - PlusSym0KindInference :: SameKind (Apply PlusSym0 arg) (PlusSym1 arg) => - PlusSym0 a0123456789876543210 - type instance Apply PlusSym0 a0123456789876543210 = PlusSym1 a0123456789876543210 - instance SuppressUnusedWarnings PlusSym0 where - suppressUnusedWarnings = snd (((,) PlusSym0KindInference) ()) - type PlusSym1 :: Nat -> (~>) Nat Nat - data PlusSym1 a0123456789876543210 a0123456789876543210 - where - PlusSym1KindInference :: SameKind (Apply (PlusSym1 a0123456789876543210) arg) (PlusSym2 a0123456789876543210 arg) => - PlusSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (PlusSym1 a0123456789876543210) a0123456789876543210 = PlusSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (PlusSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) PlusSym1KindInference) ()) - type PlusSym2 (a0123456789876543210 :: Nat) (a0123456789876543210 :: Nat) = - Plus a0123456789876543210 a0123456789876543210 :: Nat - type Pred :: Nat -> Nat - type family Pred a where - Pred Zero = ZeroSym0 - Pred (Succ n) = n - type Plus :: Nat -> Nat -> Nat - type family Plus a a where - Plus Zero m = m - Plus (Succ n) m = Apply SuccSym0 (Apply (Apply PlusSym0 n) m) - type ShowsPrec_0123456789876543210 :: GHC.Types.Nat - -> Nat -> GHC.Types.Symbol -> GHC.Types.Symbol - type family ShowsPrec_0123456789876543210 a a a 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_0123456789876543210Sym0 :: (~>) GHC.Types.Nat ((~>) Nat ((~>) GHC.Types.Symbol GHC.Types.Symbol)) - data ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym0KindInference :: SameKind (Apply ShowsPrec_0123456789876543210Sym0 arg) (ShowsPrec_0123456789876543210Sym1 arg) => - ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ShowsPrec_0123456789876543210Sym0 a0123456789876543210 = ShowsPrec_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings ShowsPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym0KindInference) ()) - type ShowsPrec_0123456789876543210Sym1 :: GHC.Types.Nat - -> (~>) Nat ((~>) GHC.Types.Symbol GHC.Types.Symbol) - data ShowsPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym1KindInference) ()) - type ShowsPrec_0123456789876543210Sym2 :: GHC.Types.Nat - -> Nat -> (~>) GHC.Types.Symbol GHC.Types.Symbol - data ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym2KindInference :: 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_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym2KindInference) ()) - type ShowsPrec_0123456789876543210Sym3 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: Nat) (a0123456789876543210 :: GHC.Types.Symbol) = - ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 :: GHC.Types.Symbol - instance PShow Nat where - type ShowsPrec a a a = Apply (Apply (Apply ShowsPrec_0123456789876543210Sym0 a) a) a - type Compare_0123456789876543210 :: Nat -> Nat -> Ordering - type family Compare_0123456789876543210 a a where - Compare_0123456789876543210 Zero Zero = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) NilSym0 - Compare_0123456789876543210 (Succ a_0123456789876543210) (Succ b_0123456789876543210) = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) NilSym0) - Compare_0123456789876543210 Zero (Succ _) = LTSym0 - Compare_0123456789876543210 (Succ _) Zero = GTSym0 - type Compare_0123456789876543210Sym0 :: (~>) Nat ((~>) Nat Ordering) - data Compare_0123456789876543210Sym0 a0123456789876543210 - where - Compare_0123456789876543210Sym0KindInference :: SameKind (Apply Compare_0123456789876543210Sym0 arg) (Compare_0123456789876543210Sym1 arg) => - Compare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Compare_0123456789876543210Sym0 a0123456789876543210 = Compare_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Compare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym0KindInference) ()) - type Compare_0123456789876543210Sym1 :: Nat -> (~>) Nat Ordering - data Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - Compare_0123456789876543210Sym1KindInference :: SameKind (Apply (Compare_0123456789876543210Sym1 a0123456789876543210) arg) (Compare_0123456789876543210Sym2 a0123456789876543210 arg) => - Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Compare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Compare_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Compare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym1KindInference) ()) - type Compare_0123456789876543210Sym2 (a0123456789876543210 :: Nat) (a0123456789876543210 :: Nat) = - Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 :: Ordering - instance POrd Nat where - type Compare a a = Apply (Apply Compare_0123456789876543210Sym0 a) a - type Equals_0123456789876543210 :: Nat -> Nat -> Bool - type family Equals_0123456789876543210 a b 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 :: Nat) - SSucc :: forall (n :: Nat). (Sing n) -> SNat (Succ n :: Nat) - 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.golden b/tests/compile-and-dump/Singletons/NatSymbolReflexive.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/NatSymbolReflexive.golden +++ /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.golden b/tests/compile-and-dump/Singletons/Operators.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Operators.golden +++ /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 :: Foo - type (:+:@#@$) :: (~>) Foo ((~>) Foo Foo) - data (:+:@#@$) a0123456789876543210 - where - (::+:@#@$###) :: SameKind (Apply (:+:@#@$) arg) ((:+:@#@$$) arg) => - (:+:@#@$) a0123456789876543210 - type instance Apply (:+:@#@$) a0123456789876543210 = (:+:@#@$$) a0123456789876543210 - instance SuppressUnusedWarnings (:+:@#@$) where - suppressUnusedWarnings = snd (((,) (::+:@#@$###)) ()) - type (:+:@#@$$) :: Foo -> (~>) Foo Foo - data (:+:@#@$$) a0123456789876543210 a0123456789876543210 - where - (::+:@#@$$###) :: SameKind (Apply ((:+:@#@$$) a0123456789876543210) arg) ((:+:@#@$$$) a0123456789876543210 arg) => - (:+:@#@$$) a0123456789876543210 a0123456789876543210 - type instance Apply ((:+:@#@$$) a0123456789876543210) a0123456789876543210 = (:+:@#@$$$) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((:+:@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (::+:@#@$$###)) ()) - type (:+:@#@$$$) (a0123456789876543210 :: Foo) (a0123456789876543210 :: Foo) = - (:+:) a0123456789876543210 a0123456789876543210 :: Foo - type (+@#@$) :: (~>) Nat ((~>) Nat Nat) - data (+@#@$) a0123456789876543210 - where - (:+@#@$###) :: SameKind (Apply (+@#@$) arg) ((+@#@$$) arg) => - (+@#@$) a0123456789876543210 - type instance Apply (+@#@$) a0123456789876543210 = (+@#@$$) a0123456789876543210 - instance SuppressUnusedWarnings (+@#@$) where - suppressUnusedWarnings = snd (((,) (:+@#@$###)) ()) - type (+@#@$$) :: Nat -> (~>) Nat Nat - data (+@#@$$) a0123456789876543210 a0123456789876543210 - where - (:+@#@$$###) :: SameKind (Apply ((+@#@$$) a0123456789876543210) arg) ((+@#@$$$) a0123456789876543210 arg) => - (+@#@$$) a0123456789876543210 a0123456789876543210 - type instance Apply ((+@#@$$) a0123456789876543210) a0123456789876543210 = (+@#@$$$) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((+@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (:+@#@$$###)) ()) - type (+@#@$$$) (a0123456789876543210 :: Nat) (a0123456789876543210 :: Nat) = - (+) a0123456789876543210 a0123456789876543210 :: Nat - type ChildSym0 :: (~>) Foo Foo - data ChildSym0 a0123456789876543210 - where - ChildSym0KindInference :: SameKind (Apply ChildSym0 arg) (ChildSym1 arg) => - ChildSym0 a0123456789876543210 - type instance Apply ChildSym0 a0123456789876543210 = ChildSym1 a0123456789876543210 - instance SuppressUnusedWarnings ChildSym0 where - suppressUnusedWarnings = snd (((,) ChildSym0KindInference) ()) - type ChildSym1 (a0123456789876543210 :: Foo) = - Child a0123456789876543210 :: Foo - type (+) :: Nat -> Nat -> Nat - type family (+) a a where - (+) 'Zero m = m - (+) ('Succ n) m = Apply SuccSym0 (Apply (Apply (+@#@$) n) m) - type Child :: Foo -> Foo - type family Child a 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 :: Foo) - (:%+:) :: forall (n :: Foo) (n :: Foo). - (Sing n) -> (Sing n) -> SFoo ((:+:) n n :: Foo) - 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.golden b/tests/compile-and-dump/Singletons/OrdDeriving.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/OrdDeriving.golden +++ /dev/null @@ -1,1086 +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 :: Nat - type SuccSym0 :: (~>) Nat Nat - data SuccSym0 a0123456789876543210 - where - SuccSym0KindInference :: SameKind (Apply SuccSym0 arg) (SuccSym1 arg) => - SuccSym0 a0123456789876543210 - type instance Apply SuccSym0 a0123456789876543210 = SuccSym1 a0123456789876543210 - instance SuppressUnusedWarnings SuccSym0 where - suppressUnusedWarnings = snd (((,) SuccSym0KindInference) ()) - type SuccSym1 (a0123456789876543210 :: Nat) = - Succ a0123456789876543210 :: Nat - type ASym0 :: forall a b c d. - (~>) a ((~>) b ((~>) c ((~>) d (Foo a b c d)))) - data ASym0 a0123456789876543210 - where - ASym0KindInference :: SameKind (Apply ASym0 arg) (ASym1 arg) => - ASym0 a0123456789876543210 - type instance Apply ASym0 a0123456789876543210 = ASym1 a0123456789876543210 - instance SuppressUnusedWarnings ASym0 where - suppressUnusedWarnings = snd (((,) ASym0KindInference) ()) - type ASym1 :: forall a b c d. - a -> (~>) b ((~>) c ((~>) d (Foo a b c d))) - data ASym1 a0123456789876543210 a0123456789876543210 - where - ASym1KindInference :: SameKind (Apply (ASym1 a0123456789876543210) arg) (ASym2 a0123456789876543210 arg) => - ASym1 a0123456789876543210 a0123456789876543210 - type instance Apply (ASym1 a0123456789876543210) a0123456789876543210 = ASym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ASym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) ASym1KindInference) ()) - type ASym2 :: forall a b c d. - a -> b -> (~>) c ((~>) d (Foo a b c d)) - data ASym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - ASym2KindInference :: SameKind (Apply (ASym2 a0123456789876543210 a0123456789876543210) arg) (ASym3 a0123456789876543210 a0123456789876543210 arg) => - ASym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (ASym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = ASym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ASym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) ASym2KindInference) ()) - type ASym3 :: forall a b c d. a -> b -> c -> (~>) d (Foo a b c d) - data ASym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - ASym3KindInference :: SameKind (Apply (ASym3 a0123456789876543210 a0123456789876543210 a0123456789876543210) arg) (ASym4 a0123456789876543210 a0123456789876543210 a0123456789876543210 arg) => - ASym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (ASym3 a0123456789876543210 a0123456789876543210 a0123456789876543210) a0123456789876543210 = ASym4 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ASym3 a0123456789876543210 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) ASym3KindInference) ()) - type ASym4 (a0123456789876543210 :: a) (a0123456789876543210 :: b) (a0123456789876543210 :: c) (a0123456789876543210 :: d) = - A a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 :: Foo a b c d - type BSym0 :: forall a b c d. - (~>) a ((~>) b ((~>) c ((~>) d (Foo a b c d)))) - data BSym0 a0123456789876543210 - where - BSym0KindInference :: SameKind (Apply BSym0 arg) (BSym1 arg) => - BSym0 a0123456789876543210 - type instance Apply BSym0 a0123456789876543210 = BSym1 a0123456789876543210 - instance SuppressUnusedWarnings BSym0 where - suppressUnusedWarnings = snd (((,) BSym0KindInference) ()) - type BSym1 :: forall a b c d. - a -> (~>) b ((~>) c ((~>) d (Foo a b c d))) - data BSym1 a0123456789876543210 a0123456789876543210 - where - BSym1KindInference :: SameKind (Apply (BSym1 a0123456789876543210) arg) (BSym2 a0123456789876543210 arg) => - BSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (BSym1 a0123456789876543210) a0123456789876543210 = BSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (BSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) BSym1KindInference) ()) - type BSym2 :: forall a b c d. - a -> b -> (~>) c ((~>) d (Foo a b c d)) - data BSym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - BSym2KindInference :: SameKind (Apply (BSym2 a0123456789876543210 a0123456789876543210) arg) (BSym3 a0123456789876543210 a0123456789876543210 arg) => - BSym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (BSym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = BSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (BSym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) BSym2KindInference) ()) - type BSym3 :: forall a b c d. a -> b -> c -> (~>) d (Foo a b c d) - data BSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - BSym3KindInference :: SameKind (Apply (BSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210) arg) (BSym4 a0123456789876543210 a0123456789876543210 a0123456789876543210 arg) => - BSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (BSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210) a0123456789876543210 = BSym4 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (BSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) BSym3KindInference) ()) - type BSym4 (a0123456789876543210 :: a) (a0123456789876543210 :: b) (a0123456789876543210 :: c) (a0123456789876543210 :: d) = - B a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 :: Foo a b c d - type CSym0 :: forall a b c d. - (~>) a ((~>) b ((~>) c ((~>) d (Foo a b c d)))) - data CSym0 a0123456789876543210 - where - CSym0KindInference :: SameKind (Apply CSym0 arg) (CSym1 arg) => - CSym0 a0123456789876543210 - type instance Apply CSym0 a0123456789876543210 = CSym1 a0123456789876543210 - instance SuppressUnusedWarnings CSym0 where - suppressUnusedWarnings = snd (((,) CSym0KindInference) ()) - type CSym1 :: forall a b c d. - a -> (~>) b ((~>) c ((~>) d (Foo a b c d))) - data CSym1 a0123456789876543210 a0123456789876543210 - where - CSym1KindInference :: SameKind (Apply (CSym1 a0123456789876543210) arg) (CSym2 a0123456789876543210 arg) => - CSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (CSym1 a0123456789876543210) a0123456789876543210 = CSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (CSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) CSym1KindInference) ()) - type CSym2 :: forall a b c d. - a -> b -> (~>) c ((~>) d (Foo a b c d)) - data CSym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - CSym2KindInference :: SameKind (Apply (CSym2 a0123456789876543210 a0123456789876543210) arg) (CSym3 a0123456789876543210 a0123456789876543210 arg) => - CSym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (CSym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = CSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (CSym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) CSym2KindInference) ()) - type CSym3 :: forall a b c d. a -> b -> c -> (~>) d (Foo a b c d) - data CSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - CSym3KindInference :: SameKind (Apply (CSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210) arg) (CSym4 a0123456789876543210 a0123456789876543210 a0123456789876543210 arg) => - CSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (CSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210) a0123456789876543210 = CSym4 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (CSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) CSym3KindInference) ()) - type CSym4 (a0123456789876543210 :: a) (a0123456789876543210 :: b) (a0123456789876543210 :: c) (a0123456789876543210 :: d) = - C a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 :: Foo a b c d - type DSym0 :: forall a b c d. - (~>) a ((~>) b ((~>) c ((~>) d (Foo a b c d)))) - data DSym0 a0123456789876543210 - where - DSym0KindInference :: SameKind (Apply DSym0 arg) (DSym1 arg) => - DSym0 a0123456789876543210 - type instance Apply DSym0 a0123456789876543210 = DSym1 a0123456789876543210 - instance SuppressUnusedWarnings DSym0 where - suppressUnusedWarnings = snd (((,) DSym0KindInference) ()) - type DSym1 :: forall a b c d. - a -> (~>) b ((~>) c ((~>) d (Foo a b c d))) - data DSym1 a0123456789876543210 a0123456789876543210 - where - DSym1KindInference :: SameKind (Apply (DSym1 a0123456789876543210) arg) (DSym2 a0123456789876543210 arg) => - DSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (DSym1 a0123456789876543210) a0123456789876543210 = DSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (DSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) DSym1KindInference) ()) - type DSym2 :: forall a b c d. - a -> b -> (~>) c ((~>) d (Foo a b c d)) - data DSym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - DSym2KindInference :: SameKind (Apply (DSym2 a0123456789876543210 a0123456789876543210) arg) (DSym3 a0123456789876543210 a0123456789876543210 arg) => - DSym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (DSym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = DSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (DSym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) DSym2KindInference) ()) - type DSym3 :: forall a b c d. a -> b -> c -> (~>) d (Foo a b c d) - data DSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - DSym3KindInference :: SameKind (Apply (DSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210) arg) (DSym4 a0123456789876543210 a0123456789876543210 a0123456789876543210 arg) => - DSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (DSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210) a0123456789876543210 = DSym4 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (DSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) DSym3KindInference) ()) - type DSym4 (a0123456789876543210 :: a) (a0123456789876543210 :: b) (a0123456789876543210 :: c) (a0123456789876543210 :: d) = - D a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 :: Foo a b c d - type ESym0 :: forall a b c d. - (~>) a ((~>) b ((~>) c ((~>) d (Foo a b c d)))) - data ESym0 a0123456789876543210 - where - ESym0KindInference :: SameKind (Apply ESym0 arg) (ESym1 arg) => - ESym0 a0123456789876543210 - type instance Apply ESym0 a0123456789876543210 = ESym1 a0123456789876543210 - instance SuppressUnusedWarnings ESym0 where - suppressUnusedWarnings = snd (((,) ESym0KindInference) ()) - type ESym1 :: forall a b c d. - a -> (~>) b ((~>) c ((~>) d (Foo a b c d))) - data ESym1 a0123456789876543210 a0123456789876543210 - where - ESym1KindInference :: SameKind (Apply (ESym1 a0123456789876543210) arg) (ESym2 a0123456789876543210 arg) => - ESym1 a0123456789876543210 a0123456789876543210 - type instance Apply (ESym1 a0123456789876543210) a0123456789876543210 = ESym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ESym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) ESym1KindInference) ()) - type ESym2 :: forall a b c d. - a -> b -> (~>) c ((~>) d (Foo a b c d)) - data ESym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - ESym2KindInference :: SameKind (Apply (ESym2 a0123456789876543210 a0123456789876543210) arg) (ESym3 a0123456789876543210 a0123456789876543210 arg) => - ESym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (ESym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = ESym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ESym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) ESym2KindInference) ()) - type ESym3 :: forall a b c d. a -> b -> c -> (~>) d (Foo a b c d) - data ESym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - ESym3KindInference :: SameKind (Apply (ESym3 a0123456789876543210 a0123456789876543210 a0123456789876543210) arg) (ESym4 a0123456789876543210 a0123456789876543210 a0123456789876543210 arg) => - ESym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (ESym3 a0123456789876543210 a0123456789876543210 a0123456789876543210) a0123456789876543210 = ESym4 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ESym3 a0123456789876543210 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) ESym3KindInference) ()) - type ESym4 (a0123456789876543210 :: a) (a0123456789876543210 :: b) (a0123456789876543210 :: c) (a0123456789876543210 :: d) = - E a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 :: Foo a b c d - type FSym0 :: forall a b c d. - (~>) a ((~>) b ((~>) c ((~>) d (Foo a b c d)))) - data FSym0 a0123456789876543210 - where - FSym0KindInference :: SameKind (Apply FSym0 arg) (FSym1 arg) => - FSym0 a0123456789876543210 - type instance Apply FSym0 a0123456789876543210 = FSym1 a0123456789876543210 - instance SuppressUnusedWarnings FSym0 where - suppressUnusedWarnings = snd (((,) FSym0KindInference) ()) - type FSym1 :: forall a b c d. - a -> (~>) b ((~>) c ((~>) d (Foo a b c d))) - data FSym1 a0123456789876543210 a0123456789876543210 - where - FSym1KindInference :: SameKind (Apply (FSym1 a0123456789876543210) arg) (FSym2 a0123456789876543210 arg) => - FSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (FSym1 a0123456789876543210) a0123456789876543210 = FSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (FSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) FSym1KindInference) ()) - type FSym2 :: forall a b c d. - a -> b -> (~>) c ((~>) d (Foo a b c d)) - data FSym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - FSym2KindInference :: SameKind (Apply (FSym2 a0123456789876543210 a0123456789876543210) arg) (FSym3 a0123456789876543210 a0123456789876543210 arg) => - FSym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (FSym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = FSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (FSym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) FSym2KindInference) ()) - type FSym3 :: forall a b c d. a -> b -> c -> (~>) d (Foo a b c d) - data FSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - FSym3KindInference :: SameKind (Apply (FSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210) arg) (FSym4 a0123456789876543210 a0123456789876543210 a0123456789876543210 arg) => - FSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (FSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210) a0123456789876543210 = FSym4 a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (FSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) FSym3KindInference) ()) - type FSym4 (a0123456789876543210 :: a) (a0123456789876543210 :: b) (a0123456789876543210 :: c) (a0123456789876543210 :: d) = - F a0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 :: Foo a b c d - type Compare_0123456789876543210 :: Nat -> Nat -> Ordering - type family Compare_0123456789876543210 a a where - Compare_0123456789876543210 Zero Zero = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) NilSym0 - Compare_0123456789876543210 (Succ a_0123456789876543210) (Succ b_0123456789876543210) = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) NilSym0) - Compare_0123456789876543210 Zero (Succ _) = LTSym0 - Compare_0123456789876543210 (Succ _) Zero = GTSym0 - type Compare_0123456789876543210Sym0 :: (~>) Nat ((~>) Nat Ordering) - data Compare_0123456789876543210Sym0 a0123456789876543210 - where - Compare_0123456789876543210Sym0KindInference :: SameKind (Apply Compare_0123456789876543210Sym0 arg) (Compare_0123456789876543210Sym1 arg) => - Compare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Compare_0123456789876543210Sym0 a0123456789876543210 = Compare_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Compare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym0KindInference) ()) - type Compare_0123456789876543210Sym1 :: Nat -> (~>) Nat Ordering - data Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - Compare_0123456789876543210Sym1KindInference :: SameKind (Apply (Compare_0123456789876543210Sym1 a0123456789876543210) arg) (Compare_0123456789876543210Sym2 a0123456789876543210 arg) => - Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Compare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Compare_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Compare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym1KindInference) ()) - type Compare_0123456789876543210Sym2 (a0123456789876543210 :: Nat) (a0123456789876543210 :: Nat) = - Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 :: Ordering - instance POrd Nat where - type Compare a a = Apply (Apply Compare_0123456789876543210Sym0 a) a - type Compare_0123456789876543210 :: Foo a b c d - -> Foo a b c d -> Ordering - type family Compare_0123456789876543210 a a 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)) NilSym0)))) - 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)) NilSym0)))) - 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)) NilSym0)))) - 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)) NilSym0)))) - 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)) NilSym0)))) - 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)) NilSym0)))) - 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_0123456789876543210Sym0 :: (~>) (Foo a b c d) ((~>) (Foo a b c d) Ordering) - data Compare_0123456789876543210Sym0 a0123456789876543210 - where - Compare_0123456789876543210Sym0KindInference :: SameKind (Apply Compare_0123456789876543210Sym0 arg) (Compare_0123456789876543210Sym1 arg) => - Compare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Compare_0123456789876543210Sym0 a0123456789876543210 = Compare_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Compare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym0KindInference) ()) - type Compare_0123456789876543210Sym1 :: Foo a b c d - -> (~>) (Foo a b c d) Ordering - data Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - Compare_0123456789876543210Sym1KindInference :: SameKind (Apply (Compare_0123456789876543210Sym1 a0123456789876543210) arg) (Compare_0123456789876543210Sym2 a0123456789876543210 arg) => - Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Compare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Compare_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Compare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym1KindInference) ()) - type Compare_0123456789876543210Sym2 (a0123456789876543210 :: Foo a b c d) (a0123456789876543210 :: Foo a b c d) = - Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 :: Ordering - instance POrd (Foo a b c d) where - type Compare a a = Apply (Apply Compare_0123456789876543210Sym0 a) a - type Equals_0123456789876543210 :: Nat -> Nat -> Bool - type family Equals_0123456789876543210 a b 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 Equals_0123456789876543210 :: Foo a b c d - -> Foo a b c d -> Bool - type family Equals_0123456789876543210 a b 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 :: Nat) - SSucc :: forall (n :: Nat). (Sing n) -> SNat (Succ n :: Nat) - 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) - -> (Sing n) - -> (Sing n) -> (Sing n) -> SFoo (A n n n n :: Foo a b c d) - SB :: forall a b c d (n :: a) (n :: b) (n :: c) (n :: d). - (Sing n) - -> (Sing n) - -> (Sing n) -> (Sing n) -> SFoo (B n n n n :: Foo a b c d) - SC :: forall a b c d (n :: a) (n :: b) (n :: c) (n :: d). - (Sing n) - -> (Sing n) - -> (Sing n) -> (Sing n) -> SFoo (C n n n n :: Foo a b c d) - SD :: forall a b c d (n :: a) (n :: b) (n :: c) (n :: d). - (Sing n) - -> (Sing n) - -> (Sing n) -> (Sing n) -> SFoo (D n n n n :: Foo a b c d) - SE :: forall a b c d (n :: a) (n :: b) (n :: c) (n :: d). - (Sing n) - -> (Sing n) - -> (Sing n) -> (Sing n) -> SFoo (E n n n n :: Foo a b c d) - SF :: forall a b c d (n :: a) (n :: b) (n :: c) (n :: d). - (Sing n) - -> (Sing n) - -> (Sing n) -> (Sing n) -> SFoo (F n n n n :: Foo a b c d) - 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.golden b/tests/compile-and-dump/Singletons/OverloadedStrings.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/OverloadedStrings.golden +++ /dev/null @@ -1,37 +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 :: Symbol - type SymIdSym0 :: (~>) Symbol Symbol - data SymIdSym0 a0123456789876543210 - where - SymIdSym0KindInference :: SameKind (Apply SymIdSym0 arg) (SymIdSym1 arg) => - SymIdSym0 a0123456789876543210 - type instance Apply SymIdSym0 a0123456789876543210 = SymIdSym1 a0123456789876543210 - instance SuppressUnusedWarnings SymIdSym0 where - suppressUnusedWarnings = snd (((,) SymIdSym0KindInference) ()) - type SymIdSym1 (a0123456789876543210 :: Symbol) = - SymId a0123456789876543210 :: Symbol - type Foo :: Symbol - type family Foo where - Foo = Apply SymIdSym0 (Data.Singletons.Prelude.IsString.FromString "foo") - type SymId :: Symbol -> Symbol - type family SymId a 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.golden b/tests/compile-and-dump/Singletons/PatternMatching.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/PatternMatching.golden +++ /dev/null @@ -1,555 +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 PairSym0 :: forall a b. (~>) a ((~>) b (Pair a b)) - data PairSym0 a0123456789876543210 - where - PairSym0KindInference :: SameKind (Apply PairSym0 arg) (PairSym1 arg) => - PairSym0 a0123456789876543210 - type instance Apply PairSym0 a0123456789876543210 = PairSym1 a0123456789876543210 - instance SuppressUnusedWarnings PairSym0 where - suppressUnusedWarnings = snd (((,) PairSym0KindInference) ()) - type PairSym1 :: forall a b. a -> (~>) b (Pair a b) - data PairSym1 a0123456789876543210 a0123456789876543210 - where - PairSym1KindInference :: SameKind (Apply (PairSym1 a0123456789876543210) arg) (PairSym2 a0123456789876543210 arg) => - PairSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (PairSym1 a0123456789876543210) a0123456789876543210 = PairSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (PairSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) PairSym1KindInference) ()) - type PairSym2 (a0123456789876543210 :: a) (a0123456789876543210 :: b) = - Pair a0123456789876543210 a0123456789876543210 :: Pair a b - 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))) NilSym0)) - 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) NilSym0) - type ShowsPrec_0123456789876543210 :: GHC.Types.Nat - -> Pair a b -> Symbol -> Symbol - type family ShowsPrec_0123456789876543210 a a a 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_0123456789876543210Sym0 :: (~>) GHC.Types.Nat ((~>) (Pair a b) ((~>) Symbol Symbol)) - data ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym0KindInference :: SameKind (Apply ShowsPrec_0123456789876543210Sym0 arg) (ShowsPrec_0123456789876543210Sym1 arg) => - ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ShowsPrec_0123456789876543210Sym0 a0123456789876543210 = ShowsPrec_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings ShowsPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym0KindInference) ()) - type ShowsPrec_0123456789876543210Sym1 :: GHC.Types.Nat - -> (~>) (Pair a b) ((~>) Symbol Symbol) - data ShowsPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym1KindInference) ()) - type ShowsPrec_0123456789876543210Sym2 :: GHC.Types.Nat - -> Pair a b -> (~>) Symbol Symbol - data ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym2KindInference :: 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_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym2KindInference) ()) - type ShowsPrec_0123456789876543210Sym3 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: Pair a b) (a0123456789876543210 :: Symbol) = - ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 :: Symbol - 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) -> (Sing n) -> SPair (Pair n n :: Pair a b) - 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 - data Let0123456789876543210TSym0 x0123456789876543210 - where - Let0123456789876543210TSym0KindInference :: SameKind (Apply Let0123456789876543210TSym0 arg) (Let0123456789876543210TSym1 arg) => - Let0123456789876543210TSym0 x0123456789876543210 - type instance Apply Let0123456789876543210TSym0 x0123456789876543210 = Let0123456789876543210TSym1 x0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210TSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210TSym0KindInference) ()) - data Let0123456789876543210TSym1 x0123456789876543210 y0123456789876543210 - where - Let0123456789876543210TSym1KindInference :: SameKind (Apply (Let0123456789876543210TSym1 x0123456789876543210) arg) (Let0123456789876543210TSym2 x0123456789876543210 arg) => - Let0123456789876543210TSym1 x0123456789876543210 y0123456789876543210 - type instance Apply (Let0123456789876543210TSym1 x0123456789876543210) y0123456789876543210 = Let0123456789876543210TSym2 x0123456789876543210 y0123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210TSym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210TSym1KindInference) ()) - type Let0123456789876543210TSym2 x0123456789876543210 y0123456789876543210 = - Let0123456789876543210T x0123456789876543210 y0123456789876543210 - 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 arg_0123456789876543210 where - Lambda_0123456789876543210 a b x y arg_0123456789876543210 = Case_0123456789876543210 arg_0123456789876543210 a b x y arg_0123456789876543210 - data Lambda_0123456789876543210Sym0 a0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 a0123456789876543210 = Lambda_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 a0123456789876543210 b0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 a0123456789876543210 b0123456789876543210 x0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym2 a0123456789876543210 b0123456789876543210) arg) (Lambda_0123456789876543210Sym3 a0123456789876543210 b0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 a0123456789876543210 b0123456789876543210 x0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 a0123456789876543210 b0123456789876543210) x0123456789876543210 = Lambda_0123456789876543210Sym3 a0123456789876543210 b0123456789876543210 x0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 a0123456789876543210 b0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym3 a0123456789876543210 b0123456789876543210 x0123456789876543210 y0123456789876543210 - where - Lambda_0123456789876543210Sym3KindInference :: 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 a0123456789876543210 b0123456789876543210 x0123456789876543210) y0123456789876543210 = Lambda_0123456789876543210Sym4 a0123456789876543210 b0123456789876543210 x0123456789876543210 y0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym3 a0123456789876543210 b0123456789876543210 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym3KindInference) ()) - data Lambda_0123456789876543210Sym4 a0123456789876543210 b0123456789876543210 x0123456789876543210 y0123456789876543210 arg_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym4KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym4 a0123456789876543210 b0123456789876543210 x0123456789876543210 y0123456789876543210) arg) (Lambda_0123456789876543210Sym5 a0123456789876543210 b0123456789876543210 x0123456789876543210 y0123456789876543210 arg) => - Lambda_0123456789876543210Sym4 a0123456789876543210 b0123456789876543210 x0123456789876543210 y0123456789876543210 arg_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym4 a0123456789876543210 b0123456789876543210 x0123456789876543210 y0123456789876543210) arg_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym5 a0123456789876543210 b0123456789876543210 x0123456789876543210 y0123456789876543210 arg_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym4 a0123456789876543210 b0123456789876543210 x0123456789876543210 y0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym4KindInference) ()) - type Lambda_0123456789876543210Sym5 a0123456789876543210 b0123456789876543210 x0123456789876543210 y0123456789876543210 arg_01234567898765432100123456789876543210 = - Lambda_0123456789876543210 a0123456789876543210 b0123456789876543210 x0123456789876543210 y0123456789876543210 arg_01234567898765432100123456789876543210 - 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 arg_0123456789876543210 where - Lambda_0123456789876543210 x y arg_0123456789876543210 = Case_0123456789876543210 arg_0123456789876543210 x y arg_0123456789876543210 - data Lambda_0123456789876543210Sym0 x0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 x0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 x0123456789876543210 = Lambda_0123456789876543210Sym1 x0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 x0123456789876543210 y0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210 arg_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210) arg) (Lambda_0123456789876543210Sym3 x0123456789876543210 y0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210 arg_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210) arg_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym3 x0123456789876543210 y0123456789876543210 arg_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 x0123456789876543210 y0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - type Lambda_0123456789876543210Sym3 x0123456789876543210 y0123456789876543210 arg_01234567898765432100123456789876543210 = - Lambda_0123456789876543210 x0123456789876543210 y0123456789876543210 arg_01234567898765432100123456789876543210 - 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 SillySym0 :: (~>) a () - data SillySym0 a0123456789876543210 - where - SillySym0KindInference :: SameKind (Apply SillySym0 arg) (SillySym1 arg) => - SillySym0 a0123456789876543210 - type instance Apply SillySym0 a0123456789876543210 = SillySym1 a0123456789876543210 - instance SuppressUnusedWarnings SillySym0 where - suppressUnusedWarnings = snd (((,) SillySym0KindInference) ()) - type SillySym1 (a0123456789876543210 :: a) = - Silly a0123456789876543210 :: () - type Foo2Sym0 :: (~>) (a, b) a - data Foo2Sym0 a0123456789876543210 - where - Foo2Sym0KindInference :: SameKind (Apply Foo2Sym0 arg) (Foo2Sym1 arg) => - Foo2Sym0 a0123456789876543210 - type instance Apply Foo2Sym0 a0123456789876543210 = Foo2Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo2Sym0 where - suppressUnusedWarnings = snd (((,) Foo2Sym0KindInference) ()) - type Foo2Sym1 (a0123456789876543210 :: (a, b)) = - Foo2 a0123456789876543210 :: a - type Foo1Sym0 :: (~>) (a, b) a - data Foo1Sym0 a0123456789876543210 - where - Foo1Sym0KindInference :: SameKind (Apply Foo1Sym0 arg) (Foo1Sym1 arg) => - Foo1Sym0 a0123456789876543210 - type instance Apply Foo1Sym0 a0123456789876543210 = Foo1Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo1Sym0 where - suppressUnusedWarnings = snd (((,) Foo1Sym0KindInference) ()) - type Foo1Sym1 (a0123456789876543210 :: (a, b)) = - Foo1 a0123456789876543210 :: a - type BlimySym0 = Blimy - type LszSym0 = Lsz :: Nat - type X_0123456789876543210Sym0 = X_0123456789876543210 - type TtSym0 = Tt - type TjzSym0 = Tjz - type TfSym0 = Tf - type X_0123456789876543210Sym0 = X_0123456789876543210 - type FlsSym0 = Fls :: Bool - type ZzSym0 = Zz - type JzSym0 = Jz - type X_0123456789876543210Sym0 = X_0123456789876543210 - type LzSym0 = Lz - type SzSym0 = Sz - type X_0123456789876543210Sym0 = X_0123456789876543210 - type Silly :: a -> () - type family Silly a where - Silly x = Case_0123456789876543210 x x - type Foo2 :: (a, b) -> a - type family Foo2 a where - Foo2 '(x, - y) = Case_0123456789876543210 x y (Let0123456789876543210TSym2 x y) - type Foo1 :: (a, b) -> a - type family Foo1 a where - Foo1 '(x, - y) = Apply (Apply (Apply Lambda_0123456789876543210Sym0 x) y) y - type family Blimy where - Blimy = Case_0123456789876543210 X_0123456789876543210Sym0 - type Lsz :: Nat - type family Lsz 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 Fls :: Bool - type family Fls 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.golden b/tests/compile-and-dump/Singletons/PolyKinds.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/PolyKinds.golden +++ /dev/null @@ -1,26 +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 FffSym0 :: forall k (a :: k). (~>) (Proxy (a :: k)) () - data FffSym0 a0123456789876543210 - where - FffSym0KindInference :: SameKind (Apply FffSym0 arg) (FffSym1 arg) => - FffSym0 a0123456789876543210 - type instance Apply FffSym0 a0123456789876543210 = FffSym1 a0123456789876543210 - instance SuppressUnusedWarnings FffSym0 where - suppressUnusedWarnings = snd (((,) FffSym0KindInference) ()) - type FffSym1 (a0123456789876543210 :: Proxy (a :: k)) = - Fff a0123456789876543210 :: () - 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.golden b/tests/compile-and-dump/Singletons/PolyKindsApp.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/PolyKindsApp.golden +++ /dev/null @@ -1,13 +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 :: (a :: k -> Type) (b :: k) - class PCls (a :: k -> Type) where - type Fff :: (a :: k -> Type) (b :: k) - class SCls (a :: k -> Type) where - sFff :: - forall (b :: k). 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.golden b/tests/compile-and-dump/Singletons/Records.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Records.golden +++ /dev/null @@ -1,81 +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 MkRecordSym0 :: forall a. (~>) a ((~>) Bool (Record a)) - data MkRecordSym0 a0123456789876543210 - where - MkRecordSym0KindInference :: SameKind (Apply MkRecordSym0 arg) (MkRecordSym1 arg) => - MkRecordSym0 a0123456789876543210 - type instance Apply MkRecordSym0 a0123456789876543210 = MkRecordSym1 a0123456789876543210 - instance SuppressUnusedWarnings MkRecordSym0 where - suppressUnusedWarnings = snd (((,) MkRecordSym0KindInference) ()) - type MkRecordSym1 :: forall a. a -> (~>) Bool (Record a) - data MkRecordSym1 a0123456789876543210 a0123456789876543210 - where - MkRecordSym1KindInference :: SameKind (Apply (MkRecordSym1 a0123456789876543210) arg) (MkRecordSym2 a0123456789876543210 arg) => - MkRecordSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (MkRecordSym1 a0123456789876543210) a0123456789876543210 = MkRecordSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (MkRecordSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) MkRecordSym1KindInference) ()) - type MkRecordSym2 (a0123456789876543210 :: a) (a0123456789876543210 :: Bool) = - MkRecord a0123456789876543210 a0123456789876543210 :: Record a - type Field2Sym0 :: forall a. (~>) (Record a) Bool - data Field2Sym0 a0123456789876543210 - where - Field2Sym0KindInference :: SameKind (Apply Field2Sym0 arg) (Field2Sym1 arg) => - Field2Sym0 a0123456789876543210 - type instance Apply Field2Sym0 a0123456789876543210 = Field2Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Field2Sym0 where - suppressUnusedWarnings = snd (((,) Field2Sym0KindInference) ()) - type Field2Sym1 (a0123456789876543210 :: Record a) = - Field2 a0123456789876543210 :: Bool - type Field1Sym0 :: forall a. (~>) (Record a) a - data Field1Sym0 a0123456789876543210 - where - Field1Sym0KindInference :: SameKind (Apply Field1Sym0 arg) (Field1Sym1 arg) => - Field1Sym0 a0123456789876543210 - type instance Apply Field1Sym0 a0123456789876543210 = Field1Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Field1Sym0 where - suppressUnusedWarnings = snd (((,) Field1Sym0KindInference) ()) - type Field1Sym1 (a0123456789876543210 :: Record a) = - Field1 a0123456789876543210 :: a - type Field2 :: forall a. Record a -> Bool - type family Field2 a where - Field2 (MkRecord _ field) = field - type Field1 :: forall a. Record a -> a - type family Field1 a where - Field1 (MkRecord field _) = field - sField2 :: - forall a (t :: Record a). - Sing t -> Sing (Apply Field2Sym0 t :: Bool) - sField1 :: - forall a (t :: Record a). Sing t -> Sing (Apply Field1Sym0 t :: a) - sField2 (SMkRecord _ (sField :: Sing field)) = sField - sField1 (SMkRecord (sField :: Sing field) _) = sField - instance SingI (Field2Sym0 :: (~>) (Record a) Bool) where - sing = (singFun1 @Field2Sym0) sField2 - instance SingI (Field1Sym0 :: (~>) (Record a) a) where - sing = (singFun1 @Field1Sym0) sField1 - data SRecord :: forall a. Record a -> GHC.Types.Type - where - SMkRecord :: forall a (n :: a) (n :: Bool). - (Sing n) -> (Sing n) -> SRecord (MkRecord n n :: Record a) - 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.golden b/tests/compile-and-dump/Singletons/ReturnFunc.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/ReturnFunc.golden +++ /dev/null @@ -1,96 +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 IdFooSym0 :: (~>) c ((~>) a a) - data IdFooSym0 a0123456789876543210 - where - IdFooSym0KindInference :: SameKind (Apply IdFooSym0 arg) (IdFooSym1 arg) => - IdFooSym0 a0123456789876543210 - type instance Apply IdFooSym0 a0123456789876543210 = IdFooSym1 a0123456789876543210 - instance SuppressUnusedWarnings IdFooSym0 where - suppressUnusedWarnings = snd (((,) IdFooSym0KindInference) ()) - type IdFooSym1 :: c -> (~>) a a - data IdFooSym1 a0123456789876543210 a0123456789876543210 - where - IdFooSym1KindInference :: SameKind (Apply (IdFooSym1 a0123456789876543210) arg) (IdFooSym2 a0123456789876543210 arg) => - IdFooSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (IdFooSym1 a0123456789876543210) a0123456789876543210 = IdFooSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (IdFooSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) IdFooSym1KindInference) ()) - type IdFooSym2 (a0123456789876543210 :: c) (a0123456789876543210 :: a) = - IdFoo a0123456789876543210 a0123456789876543210 :: a - type IdSym0 :: (~>) a a - data IdSym0 a0123456789876543210 - where - IdSym0KindInference :: SameKind (Apply IdSym0 arg) (IdSym1 arg) => - IdSym0 a0123456789876543210 - type instance Apply IdSym0 a0123456789876543210 = IdSym1 a0123456789876543210 - instance SuppressUnusedWarnings IdSym0 where - suppressUnusedWarnings = snd (((,) IdSym0KindInference) ()) - type IdSym1 (a0123456789876543210 :: a) = - Id a0123456789876543210 :: a - type ReturnFuncSym0 :: (~>) Nat ((~>) Nat Nat) - data ReturnFuncSym0 a0123456789876543210 - where - ReturnFuncSym0KindInference :: SameKind (Apply ReturnFuncSym0 arg) (ReturnFuncSym1 arg) => - ReturnFuncSym0 a0123456789876543210 - type instance Apply ReturnFuncSym0 a0123456789876543210 = ReturnFuncSym1 a0123456789876543210 - instance SuppressUnusedWarnings ReturnFuncSym0 where - suppressUnusedWarnings = snd (((,) ReturnFuncSym0KindInference) ()) - type ReturnFuncSym1 :: Nat -> (~>) Nat Nat - data ReturnFuncSym1 a0123456789876543210 a0123456789876543210 - where - ReturnFuncSym1KindInference :: SameKind (Apply (ReturnFuncSym1 a0123456789876543210) arg) (ReturnFuncSym2 a0123456789876543210 arg) => - ReturnFuncSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (ReturnFuncSym1 a0123456789876543210) a0123456789876543210 = ReturnFuncSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ReturnFuncSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) ReturnFuncSym1KindInference) ()) - type ReturnFuncSym2 (a0123456789876543210 :: Nat) (a0123456789876543210 :: Nat) = - ReturnFunc a0123456789876543210 a0123456789876543210 :: Nat - type IdFoo :: c -> a -> a - type family IdFoo a a where - IdFoo _ a_0123456789876543210 = Apply IdSym0 a_0123456789876543210 - type Id :: a -> a - type family Id a where - Id x = x - type ReturnFunc :: Nat -> Nat -> Nat - type family ReturnFunc a a 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.golden b/tests/compile-and-dump/Singletons/Sections.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Sections.golden +++ /dev/null @@ -1,124 +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 lhs_0123456789876543210 where - Lambda_0123456789876543210 lhs_0123456789876543210 = Apply (Apply (+@#@$) lhs_0123456789876543210) (Apply SuccSym0 ZeroSym0) - data Lambda_0123456789876543210Sym0 lhs_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 lhs_01234567898765432100123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 lhs_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym1 lhs_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - type Lambda_0123456789876543210Sym1 lhs_01234567898765432100123456789876543210 = - Lambda_0123456789876543210 lhs_01234567898765432100123456789876543210 - type Foo3Sym0 = Foo3 :: [Nat] - type Foo2Sym0 = Foo2 :: [Nat] - type Foo1Sym0 = Foo1 :: [Nat] - type (+@#@$) :: (~>) Nat ((~>) Nat Nat) - data (+@#@$) a0123456789876543210 - where - (:+@#@$###) :: SameKind (Apply (+@#@$) arg) ((+@#@$$) arg) => - (+@#@$) a0123456789876543210 - type instance Apply (+@#@$) a0123456789876543210 = (+@#@$$) a0123456789876543210 - instance SuppressUnusedWarnings (+@#@$) where - suppressUnusedWarnings = snd (((,) (:+@#@$###)) ()) - type (+@#@$$) :: Nat -> (~>) Nat Nat - data (+@#@$$) a0123456789876543210 a0123456789876543210 - where - (:+@#@$$###) :: SameKind (Apply ((+@#@$$) a0123456789876543210) arg) ((+@#@$$$) a0123456789876543210 arg) => - (+@#@$$) a0123456789876543210 a0123456789876543210 - type instance Apply ((+@#@$$) a0123456789876543210) a0123456789876543210 = (+@#@$$$) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((+@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (:+@#@$$###)) ()) - type (+@#@$$$) (a0123456789876543210 :: Nat) (a0123456789876543210 :: Nat) = - (+) a0123456789876543210 a0123456789876543210 :: Nat - type Foo3 :: [Nat] - type family Foo3 where - Foo3 = Apply (Apply (Apply ZipWithSym0 (+@#@$)) (Apply (Apply (:@#@$) (Apply SuccSym0 ZeroSym0)) (Apply (Apply (:@#@$) (Apply SuccSym0 ZeroSym0)) NilSym0))) (Apply (Apply (:@#@$) ZeroSym0) (Apply (Apply (:@#@$) (Apply SuccSym0 ZeroSym0)) NilSym0)) - type Foo2 :: [Nat] - type family Foo2 where - Foo2 = Apply (Apply MapSym0 Lambda_0123456789876543210Sym0) (Apply (Apply (:@#@$) ZeroSym0) (Apply (Apply (:@#@$) (Apply SuccSym0 ZeroSym0)) NilSym0)) - type Foo1 :: [Nat] - type family Foo1 where - Foo1 = Apply (Apply MapSym0 (Apply (+@#@$) (Apply SuccSym0 ZeroSym0))) (Apply (Apply (:@#@$) ZeroSym0) (Apply (Apply (:@#@$) (Apply SuccSym0 ZeroSym0)) NilSym0)) - type (+) :: Nat -> Nat -> Nat - type family (+) a a 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.golden b/tests/compile-and-dump/Singletons/ShowDeriving.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/ShowDeriving.golden +++ /dev/null @@ -1,625 +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 MkFoo1Sym0 = MkFoo1 :: Foo1 - type MkFoo2aSym0 :: forall a. (~>) a ((~>) a (Foo2 a)) - data MkFoo2aSym0 a0123456789876543210 - where - MkFoo2aSym0KindInference :: SameKind (Apply MkFoo2aSym0 arg) (MkFoo2aSym1 arg) => - MkFoo2aSym0 a0123456789876543210 - type instance Apply MkFoo2aSym0 a0123456789876543210 = MkFoo2aSym1 a0123456789876543210 - instance SuppressUnusedWarnings MkFoo2aSym0 where - suppressUnusedWarnings = snd (((,) MkFoo2aSym0KindInference) ()) - type MkFoo2aSym1 :: forall a. a -> (~>) a (Foo2 a) - data MkFoo2aSym1 a0123456789876543210 a0123456789876543210 - where - MkFoo2aSym1KindInference :: SameKind (Apply (MkFoo2aSym1 a0123456789876543210) arg) (MkFoo2aSym2 a0123456789876543210 arg) => - MkFoo2aSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (MkFoo2aSym1 a0123456789876543210) a0123456789876543210 = MkFoo2aSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (MkFoo2aSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) MkFoo2aSym1KindInference) ()) - type MkFoo2aSym2 (a0123456789876543210 :: a) (a0123456789876543210 :: a) = - MkFoo2a a0123456789876543210 a0123456789876543210 :: Foo2 a - type MkFoo2bSym0 :: forall a. (~>) a ((~>) a (Foo2 a)) - data MkFoo2bSym0 a0123456789876543210 - where - MkFoo2bSym0KindInference :: SameKind (Apply MkFoo2bSym0 arg) (MkFoo2bSym1 arg) => - MkFoo2bSym0 a0123456789876543210 - type instance Apply MkFoo2bSym0 a0123456789876543210 = MkFoo2bSym1 a0123456789876543210 - instance SuppressUnusedWarnings MkFoo2bSym0 where - suppressUnusedWarnings = snd (((,) MkFoo2bSym0KindInference) ()) - infixl 5 `MkFoo2bSym0` - type MkFoo2bSym1 :: forall a. a -> (~>) a (Foo2 a) - data MkFoo2bSym1 a0123456789876543210 a0123456789876543210 - where - MkFoo2bSym1KindInference :: SameKind (Apply (MkFoo2bSym1 a0123456789876543210) arg) (MkFoo2bSym2 a0123456789876543210 arg) => - MkFoo2bSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (MkFoo2bSym1 a0123456789876543210) a0123456789876543210 = MkFoo2bSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (MkFoo2bSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) MkFoo2bSym1KindInference) ()) - infixl 5 `MkFoo2bSym1` - type MkFoo2bSym2 (a0123456789876543210 :: a) (a0123456789876543210 :: a) = - MkFoo2b a0123456789876543210 a0123456789876543210 :: Foo2 a - infixl 5 `MkFoo2bSym2` - type (:*:@#@$) :: forall a. (~>) a ((~>) a (Foo2 a)) - data (:*:@#@$) a0123456789876543210 - where - (::*:@#@$###) :: SameKind (Apply (:*:@#@$) arg) ((:*:@#@$$) arg) => - (:*:@#@$) a0123456789876543210 - type instance Apply (:*:@#@$) a0123456789876543210 = (:*:@#@$$) a0123456789876543210 - instance SuppressUnusedWarnings (:*:@#@$) where - suppressUnusedWarnings = snd (((,) (::*:@#@$###)) ()) - infixl 5 :*:@#@$ - type (:*:@#@$$) :: forall a. a -> (~>) a (Foo2 a) - data (:*:@#@$$) a0123456789876543210 a0123456789876543210 - where - (::*:@#@$$###) :: SameKind (Apply ((:*:@#@$$) a0123456789876543210) arg) ((:*:@#@$$$) a0123456789876543210 arg) => - (:*:@#@$$) a0123456789876543210 a0123456789876543210 - type instance Apply ((:*:@#@$$) a0123456789876543210) a0123456789876543210 = (:*:@#@$$$) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((:*:@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (::*:@#@$$###)) ()) - infixl 5 :*:@#@$$ - type (:*:@#@$$$) (a0123456789876543210 :: a) (a0123456789876543210 :: a) = - (:*:) a0123456789876543210 a0123456789876543210 :: Foo2 a - infixl 5 :*:@#@$$$ - type (:&:@#@$) :: forall a. (~>) a ((~>) a (Foo2 a)) - data (:&:@#@$) a0123456789876543210 - where - (::&:@#@$###) :: SameKind (Apply (:&:@#@$) arg) ((:&:@#@$$) arg) => - (:&:@#@$) a0123456789876543210 - type instance Apply (:&:@#@$) a0123456789876543210 = (:&:@#@$$) a0123456789876543210 - instance SuppressUnusedWarnings (:&:@#@$) where - suppressUnusedWarnings = snd (((,) (::&:@#@$###)) ()) - infixl 5 :&:@#@$ - type (:&:@#@$$) :: forall a. a -> (~>) a (Foo2 a) - data (:&:@#@$$) a0123456789876543210 a0123456789876543210 - where - (::&:@#@$$###) :: SameKind (Apply ((:&:@#@$$) a0123456789876543210) arg) ((:&:@#@$$$) a0123456789876543210 arg) => - (:&:@#@$$) a0123456789876543210 a0123456789876543210 - type instance Apply ((:&:@#@$$) a0123456789876543210) a0123456789876543210 = (:&:@#@$$$) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((:&:@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (::&:@#@$$###)) ()) - infixl 5 :&:@#@$$ - type (:&:@#@$$$) (a0123456789876543210 :: a) (a0123456789876543210 :: a) = - (:&:) a0123456789876543210 a0123456789876543210 :: Foo2 a - infixl 5 :&:@#@$$$ - type MkFoo3Sym0 :: (~>) Bool ((~>) Bool Foo3) - data MkFoo3Sym0 a0123456789876543210 - where - MkFoo3Sym0KindInference :: SameKind (Apply MkFoo3Sym0 arg) (MkFoo3Sym1 arg) => - MkFoo3Sym0 a0123456789876543210 - type instance Apply MkFoo3Sym0 a0123456789876543210 = MkFoo3Sym1 a0123456789876543210 - instance SuppressUnusedWarnings MkFoo3Sym0 where - suppressUnusedWarnings = snd (((,) MkFoo3Sym0KindInference) ()) - type MkFoo3Sym1 :: Bool -> (~>) Bool Foo3 - data MkFoo3Sym1 a0123456789876543210 a0123456789876543210 - where - MkFoo3Sym1KindInference :: SameKind (Apply (MkFoo3Sym1 a0123456789876543210) arg) (MkFoo3Sym2 a0123456789876543210 arg) => - MkFoo3Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (MkFoo3Sym1 a0123456789876543210) a0123456789876543210 = MkFoo3Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (MkFoo3Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) MkFoo3Sym1KindInference) ()) - type MkFoo3Sym2 (a0123456789876543210 :: Bool) (a0123456789876543210 :: Bool) = - MkFoo3 a0123456789876543210 a0123456789876543210 :: Foo3 - type (***@#@$) :: (~>) Foo3 Bool - data (***@#@$) a0123456789876543210 - where - (:***@#@$###) :: SameKind (Apply (***@#@$) arg) ((***@#@$$) arg) => - (***@#@$) a0123456789876543210 - type instance Apply (***@#@$) a0123456789876543210 = (***@#@$$) a0123456789876543210 - instance SuppressUnusedWarnings (***@#@$) where - suppressUnusedWarnings = snd (((,) (:***@#@$###)) ()) - type (***@#@$$) (a0123456789876543210 :: Foo3) = - (***) a0123456789876543210 :: Bool - type GetFoo3aSym0 :: (~>) Foo3 Bool - data GetFoo3aSym0 a0123456789876543210 - where - GetFoo3aSym0KindInference :: SameKind (Apply GetFoo3aSym0 arg) (GetFoo3aSym1 arg) => - GetFoo3aSym0 a0123456789876543210 - type instance Apply GetFoo3aSym0 a0123456789876543210 = GetFoo3aSym1 a0123456789876543210 - instance SuppressUnusedWarnings GetFoo3aSym0 where - suppressUnusedWarnings = snd (((,) GetFoo3aSym0KindInference) ()) - type GetFoo3aSym1 (a0123456789876543210 :: Foo3) = - GetFoo3a a0123456789876543210 :: Bool - type (***) :: Foo3 -> Bool - type family (***) a where - (***) (MkFoo3 _ field) = field - type GetFoo3a :: Foo3 -> Bool - type family GetFoo3a a where - GetFoo3a (MkFoo3 field _) = field - type ShowsPrec_0123456789876543210 :: GHC.Types.Nat - -> Foo1 -> Symbol -> Symbol - type family ShowsPrec_0123456789876543210 a a a where - ShowsPrec_0123456789876543210 _ MkFoo1 a_0123456789876543210 = Apply (Apply ShowStringSym0 "MkFoo1") a_0123456789876543210 - type ShowsPrec_0123456789876543210Sym0 :: (~>) GHC.Types.Nat ((~>) Foo1 ((~>) Symbol Symbol)) - data ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym0KindInference :: SameKind (Apply ShowsPrec_0123456789876543210Sym0 arg) (ShowsPrec_0123456789876543210Sym1 arg) => - ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ShowsPrec_0123456789876543210Sym0 a0123456789876543210 = ShowsPrec_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings ShowsPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym0KindInference) ()) - type ShowsPrec_0123456789876543210Sym1 :: GHC.Types.Nat - -> (~>) Foo1 ((~>) Symbol Symbol) - data ShowsPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym1KindInference) ()) - type ShowsPrec_0123456789876543210Sym2 :: GHC.Types.Nat - -> Foo1 -> (~>) Symbol Symbol - data ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym2KindInference :: 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_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym2KindInference) ()) - type ShowsPrec_0123456789876543210Sym3 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: Foo1) (a0123456789876543210 :: Symbol) = - ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 :: Symbol - instance PShow Foo1 where - type ShowsPrec a a a = Apply (Apply (Apply ShowsPrec_0123456789876543210Sym0 a) a) a - type ShowsPrec_0123456789876543210 :: GHC.Types.Nat - -> Foo2 a -> Symbol -> Symbol - type family ShowsPrec_0123456789876543210 a a a 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_0123456789876543210Sym0 :: (~>) GHC.Types.Nat ((~>) (Foo2 a) ((~>) Symbol Symbol)) - data ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym0KindInference :: SameKind (Apply ShowsPrec_0123456789876543210Sym0 arg) (ShowsPrec_0123456789876543210Sym1 arg) => - ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ShowsPrec_0123456789876543210Sym0 a0123456789876543210 = ShowsPrec_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings ShowsPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym0KindInference) ()) - type ShowsPrec_0123456789876543210Sym1 :: GHC.Types.Nat - -> (~>) (Foo2 a) ((~>) Symbol Symbol) - data ShowsPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym1KindInference) ()) - type ShowsPrec_0123456789876543210Sym2 :: GHC.Types.Nat - -> Foo2 a -> (~>) Symbol Symbol - data ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym2KindInference :: 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_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym2KindInference) ()) - type ShowsPrec_0123456789876543210Sym3 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: Foo2 a) (a0123456789876543210 :: Symbol) = - ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 :: Symbol - instance PShow (Foo2 a) where - type ShowsPrec a a a = Apply (Apply (Apply ShowsPrec_0123456789876543210Sym0 a) a) a - type ShowsPrec_0123456789876543210 :: GHC.Types.Nat - -> Foo3 -> Symbol -> Symbol - type family ShowsPrec_0123456789876543210 a a a 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_0123456789876543210Sym0 :: (~>) GHC.Types.Nat ((~>) Foo3 ((~>) Symbol Symbol)) - data ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym0KindInference :: SameKind (Apply ShowsPrec_0123456789876543210Sym0 arg) (ShowsPrec_0123456789876543210Sym1 arg) => - ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ShowsPrec_0123456789876543210Sym0 a0123456789876543210 = ShowsPrec_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings ShowsPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym0KindInference) ()) - type ShowsPrec_0123456789876543210Sym1 :: GHC.Types.Nat - -> (~>) Foo3 ((~>) Symbol Symbol) - data ShowsPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym1KindInference) ()) - type ShowsPrec_0123456789876543210Sym2 :: GHC.Types.Nat - -> Foo3 -> (~>) Symbol Symbol - data ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym2KindInference :: 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_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym2KindInference) ()) - type ShowsPrec_0123456789876543210Sym3 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: Foo3) (a0123456789876543210 :: Symbol) = - ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 :: Symbol - instance PShow Foo3 where - type ShowsPrec a a a = Apply (Apply (Apply ShowsPrec_0123456789876543210Sym0 a) a) a - infixl 5 :%&: - infixl 5 :%*: - infixl 5 `SMkFoo2b` - (%***) :: - forall (t :: Foo3). Sing t -> Sing (Apply (***@#@$) t :: Bool) - sGetFoo3a :: - forall (t :: Foo3). Sing t -> Sing (Apply GetFoo3aSym0 t :: Bool) - (%***) (SMkFoo3 _ (sField :: Sing field)) = sField - sGetFoo3a (SMkFoo3 (sField :: Sing field) _) = sField - instance SingI ((***@#@$) :: (~>) Foo3 Bool) where - sing = (singFun1 @(***@#@$)) (%***) - instance SingI (GetFoo3aSym0 :: (~>) Foo3 Bool) where - sing = (singFun1 @GetFoo3aSym0) sGetFoo3a - data SFoo1 :: Foo1 -> GHC.Types.Type - where SMkFoo1 :: SFoo1 (MkFoo1 :: Foo1) - 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) -> (Sing n) -> SFoo2 (MkFoo2a n n :: Foo2 a) - SMkFoo2b :: forall a (n :: a) (n :: a). - (Sing n) -> (Sing n) -> SFoo2 (MkFoo2b n n :: Foo2 a) - (:%*:) :: forall a (n :: a) (n :: a). - (Sing n) -> (Sing n) -> SFoo2 ((:*:) n n :: Foo2 a) - (:%&:) :: forall a (n :: a) (n :: a). - (Sing n) -> (Sing n) -> SFoo2 ((:&:) n n :: Foo2 a) - 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). - (Sing n) -> (Sing n) -> SFoo3 (MkFoo3 n n :: Foo3) - 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.golden b/tests/compile-and-dump/Singletons/StandaloneDeriving.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/StandaloneDeriving.golden +++ /dev/null @@ -1,479 +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 (:*:@#@$) :: forall a b. (~>) a ((~>) b (T a b)) - data (:*:@#@$) a0123456789876543210 - where - (::*:@#@$###) :: SameKind (Apply (:*:@#@$) arg) ((:*:@#@$$) arg) => - (:*:@#@$) a0123456789876543210 - type instance Apply (:*:@#@$) a0123456789876543210 = (:*:@#@$$) a0123456789876543210 - instance SuppressUnusedWarnings (:*:@#@$) where - suppressUnusedWarnings = snd (((,) (::*:@#@$###)) ()) - infixl 6 :*:@#@$ - type (:*:@#@$$) :: forall a b. a -> (~>) b (T a b) - data (:*:@#@$$) a0123456789876543210 a0123456789876543210 - where - (::*:@#@$$###) :: SameKind (Apply ((:*:@#@$$) a0123456789876543210) arg) ((:*:@#@$$$) a0123456789876543210 arg) => - (:*:@#@$$) a0123456789876543210 a0123456789876543210 - type instance Apply ((:*:@#@$$) a0123456789876543210) a0123456789876543210 = (:*:@#@$$$) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((:*:@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (::*:@#@$$###)) ()) - infixl 6 :*:@#@$$ - type (:*:@#@$$$) (a0123456789876543210 :: a) (a0123456789876543210 :: b) = - (:*:) a0123456789876543210 a0123456789876543210 :: T a b - infixl 6 :*:@#@$$$ - type S1Sym0 = S1 :: S - type S2Sym0 = S2 :: S - type Compare_0123456789876543210 :: T a () -> T a () -> Ordering - type family Compare_0123456789876543210 a a 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)) NilSym0)) - type Compare_0123456789876543210Sym0 :: (~>) (T a ()) ((~>) (T a ()) Ordering) - data Compare_0123456789876543210Sym0 a0123456789876543210 - where - Compare_0123456789876543210Sym0KindInference :: SameKind (Apply Compare_0123456789876543210Sym0 arg) (Compare_0123456789876543210Sym1 arg) => - Compare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Compare_0123456789876543210Sym0 a0123456789876543210 = Compare_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Compare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym0KindInference) ()) - type Compare_0123456789876543210Sym1 :: T a () - -> (~>) (T a ()) Ordering - data Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - Compare_0123456789876543210Sym1KindInference :: SameKind (Apply (Compare_0123456789876543210Sym1 a0123456789876543210) arg) (Compare_0123456789876543210Sym2 a0123456789876543210 arg) => - Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Compare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Compare_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Compare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym1KindInference) ()) - type Compare_0123456789876543210Sym2 (a0123456789876543210 :: T a ()) (a0123456789876543210 :: T a ()) = - Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 :: Ordering - instance POrd (T a ()) where - type Compare a a = Apply (Apply Compare_0123456789876543210Sym0 a) a - type ShowsPrec_0123456789876543210 :: GHC.Types.Nat - -> T a () -> Symbol -> Symbol - type family ShowsPrec_0123456789876543210 a a a 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_0123456789876543210Sym0 :: (~>) GHC.Types.Nat ((~>) (T a ()) ((~>) Symbol Symbol)) - data ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym0KindInference :: SameKind (Apply ShowsPrec_0123456789876543210Sym0 arg) (ShowsPrec_0123456789876543210Sym1 arg) => - ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ShowsPrec_0123456789876543210Sym0 a0123456789876543210 = ShowsPrec_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings ShowsPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym0KindInference) ()) - type ShowsPrec_0123456789876543210Sym1 :: GHC.Types.Nat - -> (~>) (T a ()) ((~>) Symbol Symbol) - data ShowsPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym1KindInference) ()) - type ShowsPrec_0123456789876543210Sym2 :: GHC.Types.Nat - -> T a () -> (~>) Symbol Symbol - data ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym2KindInference :: 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_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym2KindInference) ()) - type ShowsPrec_0123456789876543210Sym3 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: T a ()) (a0123456789876543210 :: Symbol) = - ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 :: Symbol - instance PShow (T a ()) where - type ShowsPrec a a a = Apply (Apply (Apply ShowsPrec_0123456789876543210Sym0 a) a) a - type Compare_0123456789876543210 :: S -> S -> Ordering - type family Compare_0123456789876543210 a a where - Compare_0123456789876543210 S1 S1 = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) NilSym0 - Compare_0123456789876543210 S2 S2 = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) NilSym0 - Compare_0123456789876543210 S1 S2 = LTSym0 - Compare_0123456789876543210 S2 S1 = GTSym0 - type Compare_0123456789876543210Sym0 :: (~>) S ((~>) S Ordering) - data Compare_0123456789876543210Sym0 a0123456789876543210 - where - Compare_0123456789876543210Sym0KindInference :: SameKind (Apply Compare_0123456789876543210Sym0 arg) (Compare_0123456789876543210Sym1 arg) => - Compare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Compare_0123456789876543210Sym0 a0123456789876543210 = Compare_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Compare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym0KindInference) ()) - type Compare_0123456789876543210Sym1 :: S -> (~>) S Ordering - data Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - Compare_0123456789876543210Sym1KindInference :: SameKind (Apply (Compare_0123456789876543210Sym1 a0123456789876543210) arg) (Compare_0123456789876543210Sym2 a0123456789876543210 arg) => - Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Compare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Compare_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Compare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym1KindInference) ()) - type Compare_0123456789876543210Sym2 (a0123456789876543210 :: S) (a0123456789876543210 :: S) = - Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 :: Ordering - instance POrd S where - type Compare a a = Apply (Apply Compare_0123456789876543210Sym0 a) a - type ShowsPrec_0123456789876543210 :: GHC.Types.Nat - -> S -> Symbol -> Symbol - type family ShowsPrec_0123456789876543210 a a a 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_0123456789876543210Sym0 :: (~>) GHC.Types.Nat ((~>) S ((~>) Symbol Symbol)) - data ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym0KindInference :: SameKind (Apply ShowsPrec_0123456789876543210Sym0 arg) (ShowsPrec_0123456789876543210Sym1 arg) => - ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ShowsPrec_0123456789876543210Sym0 a0123456789876543210 = ShowsPrec_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings ShowsPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym0KindInference) ()) - type ShowsPrec_0123456789876543210Sym1 :: GHC.Types.Nat - -> (~>) S ((~>) Symbol Symbol) - data ShowsPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym1KindInference) ()) - type ShowsPrec_0123456789876543210Sym2 :: GHC.Types.Nat - -> S -> (~>) Symbol Symbol - data ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym2KindInference :: 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_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym2KindInference) ()) - type ShowsPrec_0123456789876543210Sym3 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: S) (a0123456789876543210 :: Symbol) = - ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 :: Symbol - instance PShow S where - type ShowsPrec a a a = Apply (Apply (Apply ShowsPrec_0123456789876543210Sym0 a) a) a - type MinBound_0123456789876543210 :: S - type family MinBound_0123456789876543210 where - MinBound_0123456789876543210 = S1Sym0 - type MinBound_0123456789876543210Sym0 = - MinBound_0123456789876543210 :: S - type MaxBound_0123456789876543210 :: S - type family MaxBound_0123456789876543210 where - MaxBound_0123456789876543210 = S2Sym0 - type MaxBound_0123456789876543210Sym0 = - MaxBound_0123456789876543210 :: S - 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 ToEnum_0123456789876543210 :: GHC.Types.Nat -> S - type family ToEnum_0123456789876543210 a where - ToEnum_0123456789876543210 n = Case_0123456789876543210 n (Apply (Apply (==@#@$) n) (FromInteger 0)) - type ToEnum_0123456789876543210Sym0 :: (~>) GHC.Types.Nat S - data ToEnum_0123456789876543210Sym0 a0123456789876543210 - where - ToEnum_0123456789876543210Sym0KindInference :: SameKind (Apply ToEnum_0123456789876543210Sym0 arg) (ToEnum_0123456789876543210Sym1 arg) => - ToEnum_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ToEnum_0123456789876543210Sym0 a0123456789876543210 = ToEnum_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings ToEnum_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ToEnum_0123456789876543210Sym0KindInference) ()) - type ToEnum_0123456789876543210Sym1 (a0123456789876543210 :: GHC.Types.Nat) = - ToEnum_0123456789876543210 a0123456789876543210 :: S - type FromEnum_0123456789876543210 :: S -> GHC.Types.Nat - type family FromEnum_0123456789876543210 a where - FromEnum_0123456789876543210 S1 = FromInteger 0 - FromEnum_0123456789876543210 S2 = FromInteger 1 - type FromEnum_0123456789876543210Sym0 :: (~>) S GHC.Types.Nat - data FromEnum_0123456789876543210Sym0 a0123456789876543210 - where - FromEnum_0123456789876543210Sym0KindInference :: SameKind (Apply FromEnum_0123456789876543210Sym0 arg) (FromEnum_0123456789876543210Sym1 arg) => - FromEnum_0123456789876543210Sym0 a0123456789876543210 - type instance Apply FromEnum_0123456789876543210Sym0 a0123456789876543210 = FromEnum_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings FromEnum_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) FromEnum_0123456789876543210Sym0KindInference) ()) - type FromEnum_0123456789876543210Sym1 (a0123456789876543210 :: S) = - FromEnum_0123456789876543210 a0123456789876543210 :: GHC.Types.Nat - instance PEnum S where - type ToEnum a = Apply ToEnum_0123456789876543210Sym0 a - type FromEnum a = Apply FromEnum_0123456789876543210Sym0 a - type Equals_0123456789876543210 :: T a () -> T a () -> Bool - type family Equals_0123456789876543210 a b 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 Equals_0123456789876543210 :: S -> S -> Bool - type family Equals_0123456789876543210 a b 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) -> (Sing n) -> ST ((:*:) n n :: T a b) - 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 :: S) - SS2 :: SS (S2 :: S) - 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.golden b/tests/compile-and-dump/Singletons/Star.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Star.golden +++ /dev/null @@ -1,422 +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 - type IntSym0 = Int :: Type - type StringSym0 = String :: Type - type MaybeSym0 :: (~>) Type Type - data MaybeSym0 a0123456789876543210 - where - MaybeSym0KindInference :: SameKind (Apply MaybeSym0 arg) (MaybeSym1 arg) => - MaybeSym0 a0123456789876543210 - type instance Apply MaybeSym0 a0123456789876543210 = MaybeSym1 a0123456789876543210 - instance SuppressUnusedWarnings MaybeSym0 where - suppressUnusedWarnings = snd (((,) MaybeSym0KindInference) ()) - type MaybeSym1 (a0123456789876543210 :: Type) = - Maybe a0123456789876543210 :: Type - type VecSym0 :: (~>) Type ((~>) Nat Type) - data VecSym0 a0123456789876543210 - where - VecSym0KindInference :: SameKind (Apply VecSym0 arg) (VecSym1 arg) => - VecSym0 a0123456789876543210 - type instance Apply VecSym0 a0123456789876543210 = VecSym1 a0123456789876543210 - instance SuppressUnusedWarnings VecSym0 where - suppressUnusedWarnings = snd (((,) VecSym0KindInference) ()) - type VecSym1 :: Type -> (~>) Nat Type - data VecSym1 a0123456789876543210 a0123456789876543210 - where - VecSym1KindInference :: SameKind (Apply (VecSym1 a0123456789876543210) arg) (VecSym2 a0123456789876543210 arg) => - VecSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (VecSym1 a0123456789876543210) a0123456789876543210 = VecSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (VecSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) VecSym1KindInference) ()) - type VecSym2 (a0123456789876543210 :: Type) (a0123456789876543210 :: Nat) = - Vec a0123456789876543210 a0123456789876543210 :: Type - type Equals_0123456789876543210 :: Type -> Type -> Bool - type family Equals_0123456789876543210 a b 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 Compare_0123456789876543210 :: Type -> Type -> Ordering - type family Compare_0123456789876543210 a a where - Compare_0123456789876543210 Nat Nat = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) NilSym0 - Compare_0123456789876543210 Int Int = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) NilSym0 - Compare_0123456789876543210 String String = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) NilSym0 - Compare_0123456789876543210 (Maybe a_0123456789876543210) (Maybe b_0123456789876543210) = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) NilSym0) - 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)) NilSym0)) - 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_0123456789876543210Sym0 :: (~>) Type ((~>) Type Ordering) - data Compare_0123456789876543210Sym0 a0123456789876543210 - where - Compare_0123456789876543210Sym0KindInference :: SameKind (Apply Compare_0123456789876543210Sym0 arg) (Compare_0123456789876543210Sym1 arg) => - Compare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Compare_0123456789876543210Sym0 a0123456789876543210 = Compare_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Compare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym0KindInference) ()) - type Compare_0123456789876543210Sym1 :: Type -> (~>) Type Ordering - data Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - Compare_0123456789876543210Sym1KindInference :: SameKind (Apply (Compare_0123456789876543210Sym1 a0123456789876543210) arg) (Compare_0123456789876543210Sym2 a0123456789876543210 arg) => - Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Compare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Compare_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Compare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym1KindInference) ()) - type Compare_0123456789876543210Sym2 (a0123456789876543210 :: Type) (a0123456789876543210 :: Type) = - Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 :: Ordering - instance POrd Type where - type Compare a a = Apply (Apply Compare_0123456789876543210Sym0 a) a - type ShowsPrec_0123456789876543210 :: GHC.Types.Nat - -> Type -> Symbol -> Symbol - type family ShowsPrec_0123456789876543210 a a a 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_0123456789876543210Sym0 :: (~>) GHC.Types.Nat ((~>) Type ((~>) Symbol Symbol)) - data ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym0KindInference :: SameKind (Apply ShowsPrec_0123456789876543210Sym0 arg) (ShowsPrec_0123456789876543210Sym1 arg) => - ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ShowsPrec_0123456789876543210Sym0 a0123456789876543210 = ShowsPrec_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings ShowsPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym0KindInference) ()) - type ShowsPrec_0123456789876543210Sym1 :: GHC.Types.Nat - -> (~>) Type ((~>) Symbol Symbol) - data ShowsPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym1KindInference) ()) - type ShowsPrec_0123456789876543210Sym2 :: GHC.Types.Nat - -> Type -> (~>) Symbol Symbol - data ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym2KindInference :: 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_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym2KindInference) ()) - type ShowsPrec_0123456789876543210Sym3 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: Type) (a0123456789876543210 :: Symbol) = - ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 :: Symbol - 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 :: Type) - SInt :: SRep (Int :: Type) - SString :: SRep (String :: Type) - SMaybe :: forall (n :: Type). (Sing n) -> SRep (Maybe n :: Type) - SVec :: forall (n :: Type) (n :: Nat). - (Sing n) -> (Sing n) -> SRep (Vec n n :: Type) - 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.golden b/tests/compile-and-dump/Singletons/T124.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T124.golden +++ /dev/null @@ -1,34 +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 FooSym0 :: (~>) Bool () - data FooSym0 a0123456789876543210 - where - FooSym0KindInference :: SameKind (Apply FooSym0 arg) (FooSym1 arg) => - FooSym0 a0123456789876543210 - type instance Apply FooSym0 a0123456789876543210 = FooSym1 a0123456789876543210 - instance SuppressUnusedWarnings FooSym0 where - suppressUnusedWarnings = snd (((,) FooSym0KindInference) ()) - type FooSym1 (a0123456789876543210 :: Bool) = - Foo a0123456789876543210 :: () - type Foo :: Bool -> () - type family Foo a 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.golden b/tests/compile-and-dump/Singletons/T136.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T136.golden +++ /dev/null @@ -1,178 +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 Succ_0123456789876543210 :: [Bool] -> [Bool] - type family Succ_0123456789876543210 a where - Succ_0123456789876543210 '[] = Apply (Apply (:@#@$) TrueSym0) NilSym0 - Succ_0123456789876543210 ('(:) 'False as) = Apply (Apply (:@#@$) TrueSym0) as - Succ_0123456789876543210 ('(:) 'True as) = Apply (Apply (:@#@$) FalseSym0) (Apply SuccSym0 as) - type Succ_0123456789876543210Sym0 :: (~>) [Bool] [Bool] - data Succ_0123456789876543210Sym0 a0123456789876543210 - where - Succ_0123456789876543210Sym0KindInference :: SameKind (Apply Succ_0123456789876543210Sym0 arg) (Succ_0123456789876543210Sym1 arg) => - Succ_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Succ_0123456789876543210Sym0 a0123456789876543210 = Succ_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Succ_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Succ_0123456789876543210Sym0KindInference) ()) - type Succ_0123456789876543210Sym1 (a0123456789876543210 :: [Bool]) = - Succ_0123456789876543210 a0123456789876543210 :: [Bool] - type Pred_0123456789876543210 :: [Bool] -> [Bool] - type family Pred_0123456789876543210 a 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_0123456789876543210Sym0 :: (~>) [Bool] [Bool] - data Pred_0123456789876543210Sym0 a0123456789876543210 - where - Pred_0123456789876543210Sym0KindInference :: SameKind (Apply Pred_0123456789876543210Sym0 arg) (Pred_0123456789876543210Sym1 arg) => - Pred_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Pred_0123456789876543210Sym0 a0123456789876543210 = Pred_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Pred_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Pred_0123456789876543210Sym0KindInference) ()) - type Pred_0123456789876543210Sym1 (a0123456789876543210 :: [Bool]) = - Pred_0123456789876543210 a0123456789876543210 :: [Bool] - type family Case_0123456789876543210 i arg_0123456789876543210 t where - Case_0123456789876543210 i arg_0123456789876543210 'True = NilSym0 - 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 ToEnum_0123456789876543210 :: GHC.Types.Nat -> [Bool] - type family ToEnum_0123456789876543210 a where - ToEnum_0123456789876543210 arg_0123456789876543210 = Case_0123456789876543210 arg_0123456789876543210 arg_0123456789876543210 - type ToEnum_0123456789876543210Sym0 :: (~>) GHC.Types.Nat [Bool] - data ToEnum_0123456789876543210Sym0 a0123456789876543210 - where - ToEnum_0123456789876543210Sym0KindInference :: SameKind (Apply ToEnum_0123456789876543210Sym0 arg) (ToEnum_0123456789876543210Sym1 arg) => - ToEnum_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ToEnum_0123456789876543210Sym0 a0123456789876543210 = ToEnum_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings ToEnum_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ToEnum_0123456789876543210Sym0KindInference) ()) - type ToEnum_0123456789876543210Sym1 (a0123456789876543210 :: GHC.Types.Nat) = - ToEnum_0123456789876543210 a0123456789876543210 :: [Bool] - type FromEnum_0123456789876543210 :: [Bool] -> GHC.Types.Nat - type family FromEnum_0123456789876543210 a 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_0123456789876543210Sym0 :: (~>) [Bool] GHC.Types.Nat - data FromEnum_0123456789876543210Sym0 a0123456789876543210 - where - FromEnum_0123456789876543210Sym0KindInference :: SameKind (Apply FromEnum_0123456789876543210Sym0 arg) (FromEnum_0123456789876543210Sym1 arg) => - FromEnum_0123456789876543210Sym0 a0123456789876543210 - type instance Apply FromEnum_0123456789876543210Sym0 a0123456789876543210 = FromEnum_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings FromEnum_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) FromEnum_0123456789876543210Sym0KindInference) ()) - type FromEnum_0123456789876543210Sym1 (a0123456789876543210 :: [Bool]) = - FromEnum_0123456789876543210 a0123456789876543210 :: GHC.Types.Nat - 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.golden b/tests/compile-and-dump/Singletons/T136b.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T136b.golden +++ /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 MethSym0 :: forall a. (~>) a a - data MethSym0 a0123456789876543210 - where - MethSym0KindInference :: SameKind (Apply MethSym0 arg) (MethSym1 arg) => - MethSym0 a0123456789876543210 - type instance Apply MethSym0 a0123456789876543210 = MethSym1 a0123456789876543210 - instance SuppressUnusedWarnings MethSym0 where - suppressUnusedWarnings = snd (((,) MethSym0KindInference) ()) - type MethSym1 (a0123456789876543210 :: a) = - Meth a0123456789876543210 :: a - class PC a 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 Meth_0123456789876543210 :: Bool -> Bool - type family Meth_0123456789876543210 a where - Meth_0123456789876543210 a_0123456789876543210 = Apply NotSym0 a_0123456789876543210 - type Meth_0123456789876543210Sym0 :: (~>) Bool Bool - data Meth_0123456789876543210Sym0 a0123456789876543210 - where - Meth_0123456789876543210Sym0KindInference :: SameKind (Apply Meth_0123456789876543210Sym0 arg) (Meth_0123456789876543210Sym1 arg) => - Meth_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Meth_0123456789876543210Sym0 a0123456789876543210 = Meth_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Meth_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Meth_0123456789876543210Sym0KindInference) ()) - type Meth_0123456789876543210Sym1 (a0123456789876543210 :: Bool) = - Meth_0123456789876543210 a0123456789876543210 :: Bool - 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.golden b/tests/compile-and-dump/Singletons/T145.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T145.golden +++ /dev/null @@ -1,37 +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 ColSym0 :: forall f a. (~>) (f a) ((~>) a Bool) - data ColSym0 a0123456789876543210 - where - ColSym0KindInference :: SameKind (Apply ColSym0 arg) (ColSym1 arg) => - ColSym0 a0123456789876543210 - type instance Apply ColSym0 a0123456789876543210 = ColSym1 a0123456789876543210 - instance SuppressUnusedWarnings ColSym0 where - suppressUnusedWarnings = snd (((,) ColSym0KindInference) ()) - type ColSym1 :: forall f a. f a -> (~>) a Bool - data ColSym1 a0123456789876543210 a0123456789876543210 - where - ColSym1KindInference :: SameKind (Apply (ColSym1 a0123456789876543210) arg) (ColSym2 a0123456789876543210 arg) => - ColSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (ColSym1 a0123456789876543210) a0123456789876543210 = ColSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ColSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) ColSym1KindInference) ()) - type ColSym2 (a0123456789876543210 :: f a) (a0123456789876543210 :: a) = - Col a0123456789876543210 a0123456789876543210 :: Bool - 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/T150.golden b/tests/compile-and-dump/Singletons/T150.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T150.golden +++ /dev/null @@ -1,363 +0,0 @@ -Singletons/T150.hs:(0,0)-(0,0): Splicing declarations - withOptions defaultOptions {genSingKindInsts = False} - $ singletons - $ lift - [d| headVec :: Vec (Succ n) a -> a - headVec (VCons x _) = x - tailVec :: Vec (Succ n) a -> Vec n a - tailVec (VCons _ xs) = xs - (!) :: Vec n a -> Fin n -> a - VCons x _ ! FZ = x - VCons _ xs ! FS n = xs ! n - VNil ! n = case n of - mapVec :: (a -> b) -> Vec n a -> Vec n b - mapVec _ VNil = VNil - mapVec f (VCons x xs) = VCons (f x) (mapVec f xs) - symmetry :: Equal a b -> Equal b a - symmetry Reflexive = Reflexive - transitivity :: Equal a b -> Equal b c -> Equal a c - transitivity Reflexive Reflexive = Reflexive - - data Fin :: Nat -> Type - where - FZ :: Fin (Succ n) - FS :: Fin n -> Fin (Succ n) - data Foo :: Type -> Type - where - MkFoo1 :: Foo Bool - MkFoo2 :: Foo Ordering - data Vec :: Nat -> Type -> Type - where - VNil :: Vec Zero a - VCons :: a -> Vec n a -> Vec (Succ n) a - data Equal :: Type -> Type -> Type where Reflexive :: Equal a a - data HList :: [Type] -> Type - where - HNil :: HList '[] - HCons :: x -> HList xs -> HList (x : xs) - data Obj :: Type where Obj :: a -> Obj |] - ======> - data Fin :: Nat -> Type - where - FZ :: Fin ('Succ n) - FS :: (Fin n) -> Fin ('Succ n) - data Foo :: Type -> Type - where - MkFoo1 :: Foo Bool - MkFoo2 :: Foo Ordering - data Vec :: Nat -> Type -> Type - where - VNil :: Vec 'Zero a - VCons :: a -> (Vec n a) -> Vec ('Succ n) a - headVec :: Vec ('Succ n) a -> a - headVec (VCons x _) = x - tailVec :: Vec ('Succ n) a -> Vec n a - tailVec (VCons _ xs) = xs - (!) :: Vec n a -> Fin n -> a - (!) (VCons x _) FZ = x - (!) (VCons _ xs) (FS n) = (xs ! n) - (!) VNil n = case n of - mapVec :: (a -> b) -> Vec n a -> Vec n b - mapVec _ VNil = VNil - mapVec f (VCons x xs) = (VCons (f x)) ((mapVec f) xs) - data Equal :: Type -> Type -> Type where Reflexive :: Equal a a - symmetry :: Equal a b -> Equal b a - symmetry Reflexive = Reflexive - transitivity :: Equal a b -> Equal b c -> Equal a c - transitivity Reflexive Reflexive = Reflexive - data HList :: [Type] -> Type - where - HNil :: HList '[] - HCons :: x -> (HList xs) -> HList ('(:) x xs) - data Obj :: Type where Obj :: a -> Obj - type FZSym0 = FZ :: Fin ('Succ n) - type FSSym0 :: (~>) (Fin n) (Fin ('Succ n)) - data FSSym0 a0123456789876543210 - where - FSSym0KindInference :: SameKind (Apply FSSym0 arg) (FSSym1 arg) => - FSSym0 a0123456789876543210 - type instance Apply FSSym0 a0123456789876543210 = FSSym1 a0123456789876543210 - instance SuppressUnusedWarnings FSSym0 where - suppressUnusedWarnings = snd (((,) FSSym0KindInference) ()) - type FSSym1 (a0123456789876543210 :: Fin n) = - FS a0123456789876543210 :: Fin ('Succ n) - type MkFoo1Sym0 = MkFoo1 :: Foo Bool - type MkFoo2Sym0 = MkFoo2 :: Foo Ordering - type VNilSym0 = VNil :: Vec 'Zero a - type VConsSym0 :: (~>) a ((~>) (Vec n a) (Vec ('Succ n) a)) - data VConsSym0 a0123456789876543210 - where - VConsSym0KindInference :: SameKind (Apply VConsSym0 arg) (VConsSym1 arg) => - VConsSym0 a0123456789876543210 - type instance Apply VConsSym0 a0123456789876543210 = VConsSym1 a0123456789876543210 - instance SuppressUnusedWarnings VConsSym0 where - suppressUnusedWarnings = snd (((,) VConsSym0KindInference) ()) - type VConsSym1 :: a -> (~>) (Vec n a) (Vec ('Succ n) a) - data VConsSym1 a0123456789876543210 a0123456789876543210 - where - VConsSym1KindInference :: SameKind (Apply (VConsSym1 a0123456789876543210) arg) (VConsSym2 a0123456789876543210 arg) => - VConsSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (VConsSym1 a0123456789876543210) a0123456789876543210 = VConsSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (VConsSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) VConsSym1KindInference) ()) - type VConsSym2 (a0123456789876543210 :: a) (a0123456789876543210 :: Vec n a) = - VCons a0123456789876543210 a0123456789876543210 :: Vec ('Succ n) a - type ReflexiveSym0 = Reflexive :: Equal a a - type HNilSym0 = HNil :: HList '[] - type HConsSym0 :: (~>) x ((~>) (HList xs) (HList ('(:) x xs))) - data HConsSym0 a0123456789876543210 - where - HConsSym0KindInference :: SameKind (Apply HConsSym0 arg) (HConsSym1 arg) => - HConsSym0 a0123456789876543210 - type instance Apply HConsSym0 a0123456789876543210 = HConsSym1 a0123456789876543210 - instance SuppressUnusedWarnings HConsSym0 where - suppressUnusedWarnings = snd (((,) HConsSym0KindInference) ()) - type HConsSym1 :: x -> (~>) (HList xs) (HList ('(:) x xs)) - data HConsSym1 a0123456789876543210 a0123456789876543210 - where - HConsSym1KindInference :: SameKind (Apply (HConsSym1 a0123456789876543210) arg) (HConsSym2 a0123456789876543210 arg) => - HConsSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (HConsSym1 a0123456789876543210) a0123456789876543210 = HConsSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (HConsSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) HConsSym1KindInference) ()) - type HConsSym2 (a0123456789876543210 :: x) (a0123456789876543210 :: HList xs) = - HCons a0123456789876543210 a0123456789876543210 :: HList ('(:) x xs) - type ObjSym0 :: (~>) a Obj - data ObjSym0 a0123456789876543210 - where - ObjSym0KindInference :: SameKind (Apply ObjSym0 arg) (ObjSym1 arg) => - ObjSym0 a0123456789876543210 - type instance Apply ObjSym0 a0123456789876543210 = ObjSym1 a0123456789876543210 - instance SuppressUnusedWarnings ObjSym0 where - suppressUnusedWarnings = snd (((,) ObjSym0KindInference) ()) - type ObjSym1 (a0123456789876543210 :: a) = - Obj a0123456789876543210 :: Obj - type family Case_0123456789876543210 n t where - type TransitivitySym0 :: (~>) (Equal a b) ((~>) (Equal b c) (Equal a c)) - data TransitivitySym0 a0123456789876543210 - where - TransitivitySym0KindInference :: SameKind (Apply TransitivitySym0 arg) (TransitivitySym1 arg) => - TransitivitySym0 a0123456789876543210 - type instance Apply TransitivitySym0 a0123456789876543210 = TransitivitySym1 a0123456789876543210 - instance SuppressUnusedWarnings TransitivitySym0 where - suppressUnusedWarnings - = snd (((,) TransitivitySym0KindInference) ()) - type TransitivitySym1 :: Equal a b -> (~>) (Equal b c) (Equal a c) - data TransitivitySym1 a0123456789876543210 a0123456789876543210 - where - TransitivitySym1KindInference :: SameKind (Apply (TransitivitySym1 a0123456789876543210) arg) (TransitivitySym2 a0123456789876543210 arg) => - TransitivitySym1 a0123456789876543210 a0123456789876543210 - type instance Apply (TransitivitySym1 a0123456789876543210) a0123456789876543210 = TransitivitySym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (TransitivitySym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) TransitivitySym1KindInference) ()) - type TransitivitySym2 (a0123456789876543210 :: Equal a b) (a0123456789876543210 :: Equal b c) = - Transitivity a0123456789876543210 a0123456789876543210 :: Equal a c - type SymmetrySym0 :: (~>) (Equal a b) (Equal b a) - data SymmetrySym0 a0123456789876543210 - where - SymmetrySym0KindInference :: SameKind (Apply SymmetrySym0 arg) (SymmetrySym1 arg) => - SymmetrySym0 a0123456789876543210 - type instance Apply SymmetrySym0 a0123456789876543210 = SymmetrySym1 a0123456789876543210 - instance SuppressUnusedWarnings SymmetrySym0 where - suppressUnusedWarnings = snd (((,) SymmetrySym0KindInference) ()) - type SymmetrySym1 (a0123456789876543210 :: Equal a b) = - Symmetry a0123456789876543210 :: Equal b a - type MapVecSym0 :: (~>) ((~>) a b) ((~>) (Vec n a) (Vec n b)) - data MapVecSym0 a0123456789876543210 - where - MapVecSym0KindInference :: SameKind (Apply MapVecSym0 arg) (MapVecSym1 arg) => - MapVecSym0 a0123456789876543210 - type instance Apply MapVecSym0 a0123456789876543210 = MapVecSym1 a0123456789876543210 - instance SuppressUnusedWarnings MapVecSym0 where - suppressUnusedWarnings = snd (((,) MapVecSym0KindInference) ()) - type MapVecSym1 :: (~>) a b -> (~>) (Vec n a) (Vec n b) - data MapVecSym1 a0123456789876543210 a0123456789876543210 - where - MapVecSym1KindInference :: SameKind (Apply (MapVecSym1 a0123456789876543210) arg) (MapVecSym2 a0123456789876543210 arg) => - MapVecSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (MapVecSym1 a0123456789876543210) a0123456789876543210 = MapVecSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (MapVecSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) MapVecSym1KindInference) ()) - type MapVecSym2 (a0123456789876543210 :: (~>) a b) (a0123456789876543210 :: Vec n a) = - MapVec a0123456789876543210 a0123456789876543210 :: Vec n b - type (!@#@$) :: (~>) (Vec n a) ((~>) (Fin n) a) - data (!@#@$) a0123456789876543210 - where - (:!@#@$###) :: SameKind (Apply (!@#@$) arg) ((!@#@$$) arg) => - (!@#@$) a0123456789876543210 - type instance Apply (!@#@$) a0123456789876543210 = (!@#@$$) a0123456789876543210 - instance SuppressUnusedWarnings (!@#@$) where - suppressUnusedWarnings = snd (((,) (:!@#@$###)) ()) - type (!@#@$$) :: Vec n a -> (~>) (Fin n) a - data (!@#@$$) a0123456789876543210 a0123456789876543210 - where - (:!@#@$$###) :: SameKind (Apply ((!@#@$$) a0123456789876543210) arg) ((!@#@$$$) a0123456789876543210 arg) => - (!@#@$$) a0123456789876543210 a0123456789876543210 - type instance Apply ((!@#@$$) a0123456789876543210) a0123456789876543210 = (!@#@$$$) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((!@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (:!@#@$$###)) ()) - type (!@#@$$$) (a0123456789876543210 :: Vec n a) (a0123456789876543210 :: Fin n) = - (!) a0123456789876543210 a0123456789876543210 :: a - type TailVecSym0 :: (~>) (Vec ('Succ n) a) (Vec n a) - data TailVecSym0 a0123456789876543210 - where - TailVecSym0KindInference :: SameKind (Apply TailVecSym0 arg) (TailVecSym1 arg) => - TailVecSym0 a0123456789876543210 - type instance Apply TailVecSym0 a0123456789876543210 = TailVecSym1 a0123456789876543210 - instance SuppressUnusedWarnings TailVecSym0 where - suppressUnusedWarnings = snd (((,) TailVecSym0KindInference) ()) - type TailVecSym1 (a0123456789876543210 :: Vec ('Succ n) a) = - TailVec a0123456789876543210 :: Vec n a - type HeadVecSym0 :: (~>) (Vec ('Succ n) a) a - data HeadVecSym0 a0123456789876543210 - where - HeadVecSym0KindInference :: SameKind (Apply HeadVecSym0 arg) (HeadVecSym1 arg) => - HeadVecSym0 a0123456789876543210 - type instance Apply HeadVecSym0 a0123456789876543210 = HeadVecSym1 a0123456789876543210 - instance SuppressUnusedWarnings HeadVecSym0 where - suppressUnusedWarnings = snd (((,) HeadVecSym0KindInference) ()) - type HeadVecSym1 (a0123456789876543210 :: Vec ('Succ n) a) = - HeadVec a0123456789876543210 :: a - type Transitivity :: Equal a b -> Equal b c -> Equal a c - type family Transitivity a a where - Transitivity Reflexive Reflexive = ReflexiveSym0 - type Symmetry :: Equal a b -> Equal b a - type family Symmetry a where - Symmetry Reflexive = ReflexiveSym0 - type MapVec :: (~>) a b -> Vec n a -> Vec n b - type family MapVec a a where - MapVec _ VNil = VNilSym0 - MapVec f (VCons x xs) = Apply (Apply VConsSym0 (Apply f x)) (Apply (Apply MapVecSym0 f) xs) - type (!) :: Vec n a -> Fin n -> a - type family (!) a a where - (!) (VCons x _) FZ = x - (!) (VCons _ xs) (FS n) = Apply (Apply (!@#@$) xs) n - (!) VNil n = Case_0123456789876543210 n n - type TailVec :: Vec ('Succ n) a -> Vec n a - type family TailVec a where - TailVec (VCons _ xs) = xs - type HeadVec :: Vec ('Succ n) a -> a - type family HeadVec a where - HeadVec (VCons x _) = x - sTransitivity :: - forall a b c (t :: Equal a b) (t :: Equal b c). - Sing t - -> Sing t -> Sing (Apply (Apply TransitivitySym0 t) t :: Equal a c) - sSymmetry :: - forall a b (t :: Equal a b). - Sing t -> Sing (Apply SymmetrySym0 t :: Equal b a) - sMapVec :: - forall a b n (t :: (~>) a b) (t :: Vec n a). - Sing t -> Sing t -> Sing (Apply (Apply MapVecSym0 t) t :: Vec n b) - (%!) :: - forall n a (t :: Vec n a) (t :: Fin n). - Sing t -> Sing t -> Sing (Apply (Apply (!@#@$) t) t :: a) - sTailVec :: - forall n a (t :: Vec ('Succ n) a). - Sing t -> Sing (Apply TailVecSym0 t :: Vec n a) - sHeadVec :: - forall n a (t :: Vec ('Succ n) a). - Sing t -> Sing (Apply HeadVecSym0 t :: a) - sTransitivity SReflexive SReflexive = SReflexive - sSymmetry SReflexive = SReflexive - sMapVec _ SVNil = SVNil - sMapVec (sF :: Sing f) (SVCons (sX :: Sing x) (sXs :: Sing xs)) - = (applySing - ((applySing ((singFun2 @VConsSym0) SVCons)) ((applySing sF) sX))) - ((applySing ((applySing ((singFun2 @MapVecSym0) sMapVec)) sF)) sXs) - (%!) (SVCons (sX :: Sing x) _) SFZ = sX - (%!) (SVCons _ (sXs :: Sing xs)) (SFS (sN :: Sing n)) - = (applySing ((applySing ((singFun2 @(!@#@$)) (%!))) sXs)) sN - (%!) SVNil (sN :: Sing n) - = (id @(Sing (Case_0123456789876543210 n n :: a))) (case sN of) - sTailVec (SVCons _ (sXs :: Sing xs)) = sXs - sHeadVec (SVCons (sX :: Sing x) _) = sX - instance SingI (TransitivitySym0 :: (~>) (Equal a b) ((~>) (Equal b c) (Equal a c))) where - sing = (singFun2 @TransitivitySym0) sTransitivity - instance SingI d => - SingI (TransitivitySym1 (d :: Equal a b) :: (~>) (Equal b c) (Equal a c)) where - sing - = (singFun1 @(TransitivitySym1 (d :: Equal a b))) - (sTransitivity (sing @d)) - instance SingI (SymmetrySym0 :: (~>) (Equal a b) (Equal b a)) where - sing = (singFun1 @SymmetrySym0) sSymmetry - instance SingI (MapVecSym0 :: (~>) ((~>) a b) ((~>) (Vec n a) (Vec n b))) where - sing = (singFun2 @MapVecSym0) sMapVec - instance SingI d => - SingI (MapVecSym1 (d :: (~>) a b) :: (~>) (Vec n a) (Vec n b)) where - sing = (singFun1 @(MapVecSym1 (d :: (~>) a b))) (sMapVec (sing @d)) - instance SingI ((!@#@$) :: (~>) (Vec n a) ((~>) (Fin n) a)) where - sing = (singFun2 @(!@#@$)) (%!) - instance SingI d => - SingI ((!@#@$$) (d :: Vec n a) :: (~>) (Fin n) a) where - sing = (singFun1 @((!@#@$$) (d :: Vec n a))) ((%!) (sing @d)) - instance SingI (TailVecSym0 :: (~>) (Vec ('Succ n) a) (Vec n a)) where - sing = (singFun1 @TailVecSym0) sTailVec - instance SingI (HeadVecSym0 :: (~>) (Vec ('Succ n) a) a) where - sing = (singFun1 @HeadVecSym0) sHeadVec - data SFin :: forall a. Fin (a :: Nat) -> Type - where - SFZ :: forall n. SFin (FZ :: Fin ('Succ n)) - SFS :: forall n (n :: Fin n). - (Sing n) -> SFin (FS n :: Fin ('Succ n)) - type instance Sing @(Fin a) = SFin - data SFoo :: forall a. Foo (a :: Type) -> Type - where - SMkFoo1 :: SFoo (MkFoo1 :: Foo Bool) - SMkFoo2 :: SFoo (MkFoo2 :: Foo Ordering) - type instance Sing @(Foo a) = SFoo - data SVec :: forall a a. Vec (a :: Nat) (a :: Type) -> Type - where - SVNil :: forall a. SVec (VNil :: Vec 'Zero a) - SVCons :: forall a n (n :: a) (n :: Vec n a). - (Sing n) -> (Sing n) -> SVec (VCons n n :: Vec ('Succ n) a) - type instance Sing @(Vec a a) = SVec - data SEqual :: forall a a. Equal (a :: Type) (a :: Type) -> Type - where SReflexive :: forall a. SEqual (Reflexive :: Equal a a) - type instance Sing @(Equal a a) = SEqual - data SHList :: forall a. HList (a :: [Type]) -> Type - where - SHNil :: SHList (HNil :: HList '[]) - SHCons :: forall x xs (n :: x) (n :: HList xs). - (Sing n) -> (Sing n) -> SHList (HCons n n :: HList ('(:) x xs)) - type instance Sing @(HList a) = SHList - data SObj :: Obj -> Type - where SObj :: forall a (n :: a). (Sing n) -> SObj (Obj n :: Obj) - type instance Sing @Obj = SObj - instance SingI FZ where - sing = SFZ - instance SingI n => SingI (FS (n :: Fin n)) where - sing = SFS sing - instance SingI (FSSym0 :: (~>) (Fin n) (Fin ('Succ n))) where - sing = (singFun1 @FSSym0) SFS - instance SingI MkFoo1 where - sing = SMkFoo1 - instance SingI MkFoo2 where - sing = SMkFoo2 - instance SingI VNil where - sing = SVNil - instance (SingI n, SingI n) => - SingI (VCons (n :: a) (n :: Vec n a)) where - sing = (SVCons sing) sing - instance SingI (VConsSym0 :: (~>) a ((~>) (Vec n a) (Vec ('Succ n) a))) where - sing = (singFun2 @VConsSym0) SVCons - instance SingI d => - SingI (VConsSym1 (d :: a) :: (~>) (Vec n a) (Vec ('Succ n) a)) where - sing = (singFun1 @(VConsSym1 (d :: a))) (SVCons (sing @d)) - instance SingI Reflexive where - sing = SReflexive - instance SingI HNil where - sing = SHNil - instance (SingI n, SingI n) => - SingI (HCons (n :: x) (n :: HList xs)) where - sing = (SHCons sing) sing - instance SingI (HConsSym0 :: (~>) x ((~>) (HList xs) (HList ('(:) x xs)))) where - sing = (singFun2 @HConsSym0) SHCons - instance SingI d => - SingI (HConsSym1 (d :: x) :: (~>) (HList xs) (HList ('(:) x xs))) where - sing = (singFun1 @(HConsSym1 (d :: x))) (SHCons (sing @d)) - instance SingI n => SingI (Obj (n :: a)) where - sing = SObj sing - instance SingI (ObjSym0 :: (~>) a Obj) where - sing = (singFun1 @ObjSym0) SObj diff --git a/tests/compile-and-dump/Singletons/T150.hs b/tests/compile-and-dump/Singletons/T150.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T150.hs +++ /dev/null @@ -1,53 +0,0 @@ -module T150 where - -import Control.Monad.Trans.Class -import Data.Kind -import Data.Singletons.TH -import Data.Singletons.TH.Options -import Singletons.Nat - -$(withOptions defaultOptions{genSingKindInsts = False} $ - singletons $ lift - [d| data Fin :: Nat -> Type where - FZ :: Fin (Succ n) - FS :: Fin n -> Fin (Succ n) - - data Foo :: Type -> Type where - MkFoo1 :: Foo Bool - MkFoo2 :: Foo Ordering - - data Vec :: Nat -> Type -> Type where - VNil :: Vec Zero a - VCons :: a -> Vec n a -> Vec (Succ n) a - - headVec :: Vec (Succ n) a -> a - headVec (VCons x _) = x - - tailVec :: Vec (Succ n) a -> Vec n a - tailVec (VCons _ xs) = xs - - (!) :: Vec n a -> Fin n -> a - VCons x _ ! FZ = x - VCons _ xs ! FS n = xs ! n - VNil ! n = case n of {} - - mapVec :: (a -> b) -> Vec n a -> Vec n b - mapVec _ VNil = VNil - mapVec f (VCons x xs) = VCons (f x) (mapVec f xs) - - data Equal :: Type -> Type -> Type where - Reflexive :: Equal a a - - symmetry :: Equal a b -> Equal b a - symmetry Reflexive = Reflexive - - transitivity :: Equal a b -> Equal b c -> Equal a c - transitivity Reflexive Reflexive = Reflexive - - data HList :: [Type] -> Type where - HNil :: HList '[] - HCons :: x -> HList xs -> HList (x:xs) - - data Obj :: Type where - Obj :: a -> Obj - |]) diff --git a/tests/compile-and-dump/Singletons/T153.golden b/tests/compile-and-dump/Singletons/T153.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T153.golden +++ /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.golden b/tests/compile-and-dump/Singletons/T157.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T157.golden +++ /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.golden b/tests/compile-and-dump/Singletons/T159.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T159.golden +++ /dev/null @@ -1,227 +0,0 @@ -Singletons/T159.hs:0:0:: Splicing declarations - genSingletons [''T0, ''T1] - ======> - type ASym0 = 'A :: T0 - type BSym0 = 'B :: T0 - type CSym0 = 'C :: T0 - type DSym0 = 'D :: T0 - type ESym0 = 'E :: T0 - type FSym0 = 'F :: T0 - type ST0 :: T0 -> GHC.Types.Type - data ST0 z - where - SA :: ST0 ('A :: T0) - SB :: ST0 ('B :: T0) - SC :: ST0 ('C :: T0) - SD :: ST0 ('D :: T0) - SE :: ST0 ('E :: T0) - SF :: ST0 ('F :: T0) - 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 :: T1 - type C1Sym0 :: (~>) T0 ((~>) T1 T1) - data C1Sym0 a0123456789876543210 - where - C1Sym0KindInference :: SameKind (Apply C1Sym0 arg) (C1Sym1 arg) => - C1Sym0 a0123456789876543210 - type instance Apply C1Sym0 a0123456789876543210 = C1Sym1 a0123456789876543210 - instance SuppressUnusedWarnings C1Sym0 where - suppressUnusedWarnings = snd (((,) C1Sym0KindInference) ()) - infixr 5 `C1Sym0` - type C1Sym1 :: T0 -> (~>) T1 T1 - data C1Sym1 a0123456789876543210 a0123456789876543210 - where - C1Sym1KindInference :: SameKind (Apply (C1Sym1 a0123456789876543210) arg) (C1Sym2 a0123456789876543210 arg) => - C1Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (C1Sym1 a0123456789876543210) a0123456789876543210 = C1Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (C1Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) C1Sym1KindInference) ()) - infixr 5 `C1Sym1` - type C1Sym2 (a0123456789876543210 :: T0) (a0123456789876543210 :: T1) = - 'C1 a0123456789876543210 a0123456789876543210 :: T1 - infixr 5 `C1Sym2` - type (:&&@#@$) :: (~>) T0 ((~>) T1 T1) - data (:&&@#@$) a0123456789876543210 - where - (::&&@#@$###) :: SameKind (Apply (:&&@#@$) arg) ((:&&@#@$$) arg) => - (:&&@#@$) a0123456789876543210 - type instance Apply (:&&@#@$) a0123456789876543210 = (:&&@#@$$) a0123456789876543210 - instance SuppressUnusedWarnings (:&&@#@$) where - suppressUnusedWarnings = snd (((,) (::&&@#@$###)) ()) - infixr 5 :&&@#@$ - type (:&&@#@$$) :: T0 -> (~>) T1 T1 - data (:&&@#@$$) a0123456789876543210 a0123456789876543210 - where - (::&&@#@$$###) :: SameKind (Apply ((:&&@#@$$) a0123456789876543210) arg) ((:&&@#@$$$) a0123456789876543210 arg) => - (:&&@#@$$) a0123456789876543210 a0123456789876543210 - type instance Apply ((:&&@#@$$) a0123456789876543210) a0123456789876543210 = (:&&@#@$$$) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((:&&@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (::&&@#@$$###)) ()) - infixr 5 :&&@#@$$ - type (:&&@#@$$$) (a0123456789876543210 :: T0) (a0123456789876543210 :: T1) = - '(:&&) a0123456789876543210 a0123456789876543210 :: T1 - infixr 5 :&&@#@$$$ - type ST1 :: T1 -> GHC.Types.Type - data ST1 z - where - SN1 :: ST1 ('N1 :: T1) - SC1 :: forall (n :: T0) (n :: T1). - (Sing n) -> (Sing n) -> ST1 ('C1 n n :: T1) - (:%&&) :: forall (n :: T0) (n :: T1). - (Sing n) -> (Sing n) -> ST1 ('(:&&) n n :: T1) - 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 :: T2 - type C2Sym0 :: (~>) T0 ((~>) T2 T2) - data C2Sym0 a0123456789876543210 - where - C2Sym0KindInference :: SameKind (Apply C2Sym0 arg) (C2Sym1 arg) => - C2Sym0 a0123456789876543210 - type instance Apply C2Sym0 a0123456789876543210 = C2Sym1 a0123456789876543210 - instance SuppressUnusedWarnings C2Sym0 where - suppressUnusedWarnings = snd (((,) C2Sym0KindInference) ()) - infixr 5 `C2Sym0` - type C2Sym1 :: T0 -> (~>) T2 T2 - data C2Sym1 a0123456789876543210 a0123456789876543210 - where - C2Sym1KindInference :: SameKind (Apply (C2Sym1 a0123456789876543210) arg) (C2Sym2 a0123456789876543210 arg) => - C2Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (C2Sym1 a0123456789876543210) a0123456789876543210 = C2Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (C2Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) C2Sym1KindInference) ()) - infixr 5 `C2Sym1` - type C2Sym2 (a0123456789876543210 :: T0) (a0123456789876543210 :: T2) = - C2 a0123456789876543210 a0123456789876543210 :: T2 - infixr 5 `C2Sym2` - type (:||@#@$) :: (~>) T0 ((~>) T2 T2) - data (:||@#@$) a0123456789876543210 - where - (::||@#@$###) :: SameKind (Apply (:||@#@$) arg) ((:||@#@$$) arg) => - (:||@#@$) a0123456789876543210 - type instance Apply (:||@#@$) a0123456789876543210 = (:||@#@$$) a0123456789876543210 - instance SuppressUnusedWarnings (:||@#@$) where - suppressUnusedWarnings = snd (((,) (::||@#@$###)) ()) - infixr 5 :||@#@$ - type (:||@#@$$) :: T0 -> (~>) T2 T2 - data (:||@#@$$) a0123456789876543210 a0123456789876543210 - where - (::||@#@$$###) :: SameKind (Apply ((:||@#@$$) a0123456789876543210) arg) ((:||@#@$$$) a0123456789876543210 arg) => - (:||@#@$$) a0123456789876543210 a0123456789876543210 - type instance Apply ((:||@#@$$) a0123456789876543210) a0123456789876543210 = (:||@#@$$$) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((:||@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (::||@#@$$###)) ()) - infixr 5 :||@#@$$ - type (:||@#@$$$) (a0123456789876543210 :: T0) (a0123456789876543210 :: T2) = - (:||) a0123456789876543210 a0123456789876543210 :: T2 - infixr 5 :||@#@$$$ - infixr 5 :%|| - infixr 5 `SC2` - data ST2 :: T2 -> GHC.Types.Type - where - SN2 :: ST2 (N2 :: T2) - SC2 :: forall (n :: T0) (n :: T2). - (Sing n) -> (Sing n) -> ST2 (C2 n n :: T2) - (:%||) :: forall (n :: T0) (n :: T2). - (Sing n) -> (Sing n) -> ST2 ((:||) n n :: T2) - 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.golden b/tests/compile-and-dump/Singletons/T160.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T160.golden +++ /dev/null @@ -1,68 +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) - data Let0123456789876543210Scrutinee_0123456789876543210Sym0 x0123456789876543210 - where - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference :: SameKind (Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 arg) (Let0123456789876543210Scrutinee_0123456789876543210Sym1 arg) => - Let0123456789876543210Scrutinee_0123456789876543210Sym0 x0123456789876543210 - type instance Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 x0123456789876543210 = Let0123456789876543210Scrutinee_0123456789876543210Sym1 x0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210Scrutinee_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd - (((,) - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference) - ()) - type Let0123456789876543210Scrutinee_0123456789876543210Sym1 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 FooSym0 :: (~>) a a - data FooSym0 a0123456789876543210 - where - FooSym0KindInference :: SameKind (Apply FooSym0 arg) (FooSym1 arg) => - FooSym0 a0123456789876543210 - type instance Apply FooSym0 a0123456789876543210 = FooSym1 a0123456789876543210 - instance SuppressUnusedWarnings FooSym0 where - suppressUnusedWarnings = snd (((,) FooSym0KindInference) ()) - type FooSym1 (a0123456789876543210 :: a) = - Foo a0123456789876543210 :: a - type Foo :: a -> a - type family Foo 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.golden b/tests/compile-and-dump/Singletons/T163.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T163.golden +++ /dev/null @@ -1,45 +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 LSym0 :: forall a b. (~>) a ((+) a b) - data LSym0 a0123456789876543210 - where - LSym0KindInference :: SameKind (Apply LSym0 arg) (LSym1 arg) => - LSym0 a0123456789876543210 - type instance Apply LSym0 a0123456789876543210 = LSym1 a0123456789876543210 - instance SuppressUnusedWarnings LSym0 where - suppressUnusedWarnings = snd (((,) LSym0KindInference) ()) - type LSym1 (a0123456789876543210 :: a) = - L a0123456789876543210 :: (+) a b - type RSym0 :: forall a b. (~>) b ((+) a b) - data RSym0 a0123456789876543210 - where - RSym0KindInference :: SameKind (Apply RSym0 arg) (RSym1 arg) => - RSym0 a0123456789876543210 - type instance Apply RSym0 a0123456789876543210 = RSym1 a0123456789876543210 - instance SuppressUnusedWarnings RSym0 where - suppressUnusedWarnings = snd (((,) RSym0KindInference) ()) - type RSym1 (a0123456789876543210 :: b) = - R a0123456789876543210 :: (+) a b - data (%+) :: forall a b. (+) a b -> GHC.Types.Type - where - SL :: forall a b (n :: a). (Sing n) -> (%+) (L n :: (+) a b) - SR :: forall a b (n :: b). (Sing n) -> (%+) (R n :: (+) a b) - 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.golden b/tests/compile-and-dump/Singletons/T166.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T166.golden +++ /dev/null @@ -1,131 +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 FoosPrecSym0 :: forall a. - (~>) Nat ((~>) a ((~>) [Bool] [Bool])) - data FoosPrecSym0 a0123456789876543210 - where - FoosPrecSym0KindInference :: SameKind (Apply FoosPrecSym0 arg) (FoosPrecSym1 arg) => - FoosPrecSym0 a0123456789876543210 - type instance Apply FoosPrecSym0 a0123456789876543210 = FoosPrecSym1 a0123456789876543210 - instance SuppressUnusedWarnings FoosPrecSym0 where - suppressUnusedWarnings = snd (((,) FoosPrecSym0KindInference) ()) - type FoosPrecSym1 :: forall a. Nat -> (~>) a ((~>) [Bool] [Bool]) - data FoosPrecSym1 a0123456789876543210 a0123456789876543210 - where - FoosPrecSym1KindInference :: SameKind (Apply (FoosPrecSym1 a0123456789876543210) arg) (FoosPrecSym2 a0123456789876543210 arg) => - FoosPrecSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (FoosPrecSym1 a0123456789876543210) a0123456789876543210 = FoosPrecSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (FoosPrecSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) FoosPrecSym1KindInference) ()) - type FoosPrecSym2 :: forall a. Nat -> a -> (~>) [Bool] [Bool] - data FoosPrecSym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - FoosPrecSym2KindInference :: SameKind (Apply (FoosPrecSym2 a0123456789876543210 a0123456789876543210) arg) (FoosPrecSym3 a0123456789876543210 a0123456789876543210 arg) => - FoosPrecSym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (FoosPrecSym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = FoosPrecSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (FoosPrecSym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) FoosPrecSym2KindInference) ()) - type FoosPrecSym3 (a0123456789876543210 :: Nat) (a0123456789876543210 :: a) (a0123456789876543210 :: [Bool]) = - FoosPrec a0123456789876543210 a0123456789876543210 a0123456789876543210 :: [Bool] - type FooSym0 :: forall a. (~>) a [Bool] - data FooSym0 a0123456789876543210 - where - FooSym0KindInference :: SameKind (Apply FooSym0 arg) (FooSym1 arg) => - FooSym0 a0123456789876543210 - type instance Apply FooSym0 a0123456789876543210 = FooSym1 a0123456789876543210 - instance SuppressUnusedWarnings FooSym0 where - suppressUnusedWarnings = snd (((,) FooSym0KindInference) ()) - type FooSym1 (a0123456789876543210 :: a) = - Foo a0123456789876543210 :: [Bool] - type family Lambda_0123456789876543210 x s where - Lambda_0123456789876543210 x s = Apply (Apply (Apply FoosPrecSym0 (Data.Singletons.Prelude.Num.FromInteger 0)) x) s - data Lambda_0123456789876543210Sym0 x0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 x0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 x0123456789876543210 = Lambda_0123456789876543210Sym1 x0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 x0123456789876543210 s0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym1 x0123456789876543210) arg) (Lambda_0123456789876543210Sym2 x0123456789876543210 arg) => - Lambda_0123456789876543210Sym1 x0123456789876543210 s0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 x0123456789876543210) s0123456789876543210 = Lambda_0123456789876543210Sym2 x0123456789876543210 s0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - type Lambda_0123456789876543210Sym2 x0123456789876543210 s0123456789876543210 = - Lambda_0123456789876543210 x0123456789876543210 s0123456789876543210 - type Foo_0123456789876543210 :: a -> [Bool] - type family Foo_0123456789876543210 a where - Foo_0123456789876543210 x = Apply Lambda_0123456789876543210Sym0 x - type Foo_0123456789876543210Sym0 :: (~>) a [Bool] - data Foo_0123456789876543210Sym0 a0123456789876543210 - where - Foo_0123456789876543210Sym0KindInference :: SameKind (Apply Foo_0123456789876543210Sym0 arg) (Foo_0123456789876543210Sym1 arg) => - Foo_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Foo_0123456789876543210Sym0 a0123456789876543210 = Foo_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Foo_0123456789876543210Sym0KindInference) ()) - type Foo_0123456789876543210Sym1 (a0123456789876543210 :: a) = - Foo_0123456789876543210 a0123456789876543210 :: [Bool] - class PFoo a 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.golden b/tests/compile-and-dump/Singletons/T167.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T167.golden +++ /dev/null @@ -1,169 +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 FoosPrecSym0 :: forall a. - (~>) Nat ((~>) a ((~>) [Bool] [Bool])) - data FoosPrecSym0 a0123456789876543210 - where - FoosPrecSym0KindInference :: SameKind (Apply FoosPrecSym0 arg) (FoosPrecSym1 arg) => - FoosPrecSym0 a0123456789876543210 - type instance Apply FoosPrecSym0 a0123456789876543210 = FoosPrecSym1 a0123456789876543210 - instance SuppressUnusedWarnings FoosPrecSym0 where - suppressUnusedWarnings = snd (((,) FoosPrecSym0KindInference) ()) - type FoosPrecSym1 :: forall a. Nat -> (~>) a ((~>) [Bool] [Bool]) - data FoosPrecSym1 a0123456789876543210 a0123456789876543210 - where - FoosPrecSym1KindInference :: SameKind (Apply (FoosPrecSym1 a0123456789876543210) arg) (FoosPrecSym2 a0123456789876543210 arg) => - FoosPrecSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (FoosPrecSym1 a0123456789876543210) a0123456789876543210 = FoosPrecSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (FoosPrecSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) FoosPrecSym1KindInference) ()) - type FoosPrecSym2 :: forall a. Nat -> a -> (~>) [Bool] [Bool] - data FoosPrecSym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - FoosPrecSym2KindInference :: SameKind (Apply (FoosPrecSym2 a0123456789876543210 a0123456789876543210) arg) (FoosPrecSym3 a0123456789876543210 a0123456789876543210 arg) => - FoosPrecSym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (FoosPrecSym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = FoosPrecSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (FoosPrecSym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) FoosPrecSym2KindInference) ()) - type FoosPrecSym3 (a0123456789876543210 :: Nat) (a0123456789876543210 :: a) (a0123456789876543210 :: [Bool]) = - FoosPrec a0123456789876543210 a0123456789876543210 a0123456789876543210 :: [Bool] - type FooListSym0 :: forall a. (~>) a ((~>) [Bool] [Bool]) - data FooListSym0 a0123456789876543210 - where - FooListSym0KindInference :: SameKind (Apply FooListSym0 arg) (FooListSym1 arg) => - FooListSym0 a0123456789876543210 - type instance Apply FooListSym0 a0123456789876543210 = FooListSym1 a0123456789876543210 - instance SuppressUnusedWarnings FooListSym0 where - suppressUnusedWarnings = snd (((,) FooListSym0KindInference) ()) - type FooListSym1 :: forall a. a -> (~>) [Bool] [Bool] - data FooListSym1 a0123456789876543210 a0123456789876543210 - where - FooListSym1KindInference :: SameKind (Apply (FooListSym1 a0123456789876543210) arg) (FooListSym2 a0123456789876543210 arg) => - FooListSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (FooListSym1 a0123456789876543210) a0123456789876543210 = FooListSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (FooListSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) FooListSym1KindInference) ()) - type FooListSym2 (a0123456789876543210 :: a) (a0123456789876543210 :: [Bool]) = - FooList a0123456789876543210 a0123456789876543210 :: [Bool] - type FooList_0123456789876543210 :: a -> [Bool] -> [Bool] - type family FooList_0123456789876543210 a a where - FooList_0123456789876543210 a_0123456789876543210 a_0123456789876543210 = Apply (Apply UndefinedSym0 a_0123456789876543210) a_0123456789876543210 - type FooList_0123456789876543210Sym0 :: (~>) a ((~>) [Bool] [Bool]) - data FooList_0123456789876543210Sym0 a0123456789876543210 - where - FooList_0123456789876543210Sym0KindInference :: SameKind (Apply FooList_0123456789876543210Sym0 arg) (FooList_0123456789876543210Sym1 arg) => - FooList_0123456789876543210Sym0 a0123456789876543210 - type instance Apply FooList_0123456789876543210Sym0 a0123456789876543210 = FooList_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings FooList_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) FooList_0123456789876543210Sym0KindInference) ()) - type FooList_0123456789876543210Sym1 :: a -> (~>) [Bool] [Bool] - data FooList_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - FooList_0123456789876543210Sym1KindInference :: SameKind (Apply (FooList_0123456789876543210Sym1 a0123456789876543210) arg) (FooList_0123456789876543210Sym2 a0123456789876543210 arg) => - FooList_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (FooList_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = FooList_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (FooList_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) FooList_0123456789876543210Sym1KindInference) ()) - type FooList_0123456789876543210Sym2 (a0123456789876543210 :: a) (a0123456789876543210 :: [Bool]) = - FooList_0123456789876543210 a0123456789876543210 a0123456789876543210 :: [Bool] - class PFoo a 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 FoosPrec_0123456789876543210 :: Nat -> [a] -> [Bool] -> [Bool] - type family FoosPrec_0123456789876543210 a a a where - FoosPrec_0123456789876543210 _ a_0123456789876543210 a_0123456789876543210 = Apply (Apply FooListSym0 a_0123456789876543210) a_0123456789876543210 - type FoosPrec_0123456789876543210Sym0 :: (~>) Nat ((~>) [a] ((~>) [Bool] [Bool])) - data FoosPrec_0123456789876543210Sym0 a0123456789876543210 - where - FoosPrec_0123456789876543210Sym0KindInference :: SameKind (Apply FoosPrec_0123456789876543210Sym0 arg) (FoosPrec_0123456789876543210Sym1 arg) => - FoosPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply FoosPrec_0123456789876543210Sym0 a0123456789876543210 = FoosPrec_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings FoosPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) FoosPrec_0123456789876543210Sym0KindInference) ()) - type FoosPrec_0123456789876543210Sym1 :: Nat - -> (~>) [a] ((~>) [Bool] [Bool]) - data FoosPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - FoosPrec_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) FoosPrec_0123456789876543210Sym1KindInference) ()) - type FoosPrec_0123456789876543210Sym2 :: Nat - -> [a] -> (~>) [Bool] [Bool] - data FoosPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - FoosPrec_0123456789876543210Sym2KindInference :: 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_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (FoosPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) FoosPrec_0123456789876543210Sym2KindInference) ()) - type FoosPrec_0123456789876543210Sym3 (a0123456789876543210 :: Nat) (a0123456789876543210 :: [a]) (a0123456789876543210 :: [Bool]) = - FoosPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 :: [Bool] - 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.golden b/tests/compile-and-dump/Singletons/T172.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T172.golden +++ /dev/null @@ -1,40 +0,0 @@ -Singletons/T172.hs:(0,0)-(0,0): Splicing declarations - singletonsOnly - [d| ($>) :: Nat -> Nat -> Nat - ($>) = (+) |] - ======> - type ($>@#@$) :: (~>) Nat ((~>) Nat Nat) - data ($>@#@$) a0123456789876543210 - where - (:$>@#@$###) :: SameKind (Apply ($>@#@$) arg) (($>@#@$$) arg) => - ($>@#@$) a0123456789876543210 - type instance Apply ($>@#@$) a0123456789876543210 = ($>@#@$$) a0123456789876543210 - instance SuppressUnusedWarnings ($>@#@$) where - suppressUnusedWarnings = snd (((,) (:$>@#@$###)) ()) - type ($>@#@$$) :: Nat -> (~>) Nat Nat - data ($>@#@$$) a0123456789876543210 a0123456789876543210 - where - (:$>@#@$$###) :: SameKind (Apply (($>@#@$$) a0123456789876543210) arg) (($>@#@$$$) a0123456789876543210 arg) => - ($>@#@$$) a0123456789876543210 a0123456789876543210 - type instance Apply (($>@#@$$) a0123456789876543210) a0123456789876543210 = ($>@#@$$$) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (($>@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (:$>@#@$$###)) ()) - type ($>@#@$$$) (a0123456789876543210 :: Nat) (a0123456789876543210 :: Nat) = - ($>) a0123456789876543210 a0123456789876543210 :: Nat - type ($>) :: Nat -> Nat -> Nat - type family ($>) a a 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.golden b/tests/compile-and-dump/Singletons/T175.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T175.golden +++ /dev/null @@ -1,47 +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 :: a - type Quux2 :: a - type family Quux2 where - Quux2 = BazSym0 - type BazSym0 = Baz :: a - class PFoo a where - type Baz :: a - type Quux1Sym0 = Quux1 :: a - type Quux1_0123456789876543210 :: a - type family Quux1_0123456789876543210 where - Quux1_0123456789876543210 = BazSym0 - type Quux1_0123456789876543210Sym0 = Quux1_0123456789876543210 :: a - class PBar1 a where - type Quux1 :: a - type Quux1 = Quux1_0123456789876543210Sym0 - class PBar2 a - 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.golden b/tests/compile-and-dump/Singletons/T176.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T176.golden +++ /dev/null @@ -1,158 +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 arg_0123456789876543210 where - Lambda_0123456789876543210 x arg_0123456789876543210 = Case_0123456789876543210 arg_0123456789876543210 x arg_0123456789876543210 - data Lambda_0123456789876543210Sym0 x0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 x0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 x0123456789876543210 = Lambda_0123456789876543210Sym1 x0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 x0123456789876543210 arg_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym1 x0123456789876543210) arg) (Lambda_0123456789876543210Sym2 x0123456789876543210 arg) => - Lambda_0123456789876543210Sym1 x0123456789876543210 arg_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 x0123456789876543210) arg_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym2 x0123456789876543210 arg_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - type Lambda_0123456789876543210Sym2 x0123456789876543210 arg_01234567898765432100123456789876543210 = - Lambda_0123456789876543210 x0123456789876543210 arg_01234567898765432100123456789876543210 - type Quux2Sym0 :: (~>) a a - data Quux2Sym0 a0123456789876543210 - where - Quux2Sym0KindInference :: SameKind (Apply Quux2Sym0 arg) (Quux2Sym1 arg) => - Quux2Sym0 a0123456789876543210 - type instance Apply Quux2Sym0 a0123456789876543210 = Quux2Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Quux2Sym0 where - suppressUnusedWarnings = snd (((,) Quux2Sym0KindInference) ()) - type Quux2Sym1 (a0123456789876543210 :: a) = - Quux2 a0123456789876543210 :: a - type Quux1Sym0 :: (~>) a a - data Quux1Sym0 a0123456789876543210 - where - Quux1Sym0KindInference :: SameKind (Apply Quux1Sym0 arg) (Quux1Sym1 arg) => - Quux1Sym0 a0123456789876543210 - type instance Apply Quux1Sym0 a0123456789876543210 = Quux1Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Quux1Sym0 where - suppressUnusedWarnings = snd (((,) Quux1Sym0KindInference) ()) - type Quux1Sym1 (a0123456789876543210 :: a) = - Quux1 a0123456789876543210 :: a - type Quux2 :: a -> a - type family Quux2 a where - Quux2 x = Apply (Apply Bar2Sym0 x) Baz2Sym0 - type Quux1 :: a -> a - type family Quux1 a where - Quux1 x = Apply (Apply Bar1Sym0 x) (Apply Lambda_0123456789876543210Sym0 x) - type Bar1Sym0 :: forall a b. (~>) a ((~>) ((~>) a b) b) - data Bar1Sym0 a0123456789876543210 - where - Bar1Sym0KindInference :: SameKind (Apply Bar1Sym0 arg) (Bar1Sym1 arg) => - Bar1Sym0 a0123456789876543210 - type instance Apply Bar1Sym0 a0123456789876543210 = Bar1Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Bar1Sym0 where - suppressUnusedWarnings = snd (((,) Bar1Sym0KindInference) ()) - type Bar1Sym1 :: forall a b. a -> (~>) ((~>) a b) b - data Bar1Sym1 a0123456789876543210 a0123456789876543210 - where - Bar1Sym1KindInference :: SameKind (Apply (Bar1Sym1 a0123456789876543210) arg) (Bar1Sym2 a0123456789876543210 arg) => - Bar1Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Bar1Sym1 a0123456789876543210) a0123456789876543210 = Bar1Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Bar1Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) Bar1Sym1KindInference) ()) - type Bar1Sym2 (a0123456789876543210 :: a) (a0123456789876543210 :: (~>) a b) = - Bar1 a0123456789876543210 a0123456789876543210 :: b - type Baz1Sym0 = Baz1 :: a - class PFoo1 a where - type Bar1 (arg :: a) (arg :: (~>) a b) :: b - type Baz1 :: a - type Bar2Sym0 :: forall a b. (~>) a ((~>) b b) - data Bar2Sym0 a0123456789876543210 - where - Bar2Sym0KindInference :: SameKind (Apply Bar2Sym0 arg) (Bar2Sym1 arg) => - Bar2Sym0 a0123456789876543210 - type instance Apply Bar2Sym0 a0123456789876543210 = Bar2Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Bar2Sym0 where - suppressUnusedWarnings = snd (((,) Bar2Sym0KindInference) ()) - type Bar2Sym1 :: forall a b. a -> (~>) b b - data Bar2Sym1 a0123456789876543210 a0123456789876543210 - where - Bar2Sym1KindInference :: SameKind (Apply (Bar2Sym1 a0123456789876543210) arg) (Bar2Sym2 a0123456789876543210 arg) => - Bar2Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Bar2Sym1 a0123456789876543210) a0123456789876543210 = Bar2Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Bar2Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) Bar2Sym1KindInference) ()) - type Bar2Sym2 (a0123456789876543210 :: a) (a0123456789876543210 :: b) = - Bar2 a0123456789876543210 a0123456789876543210 :: b - type Baz2Sym0 = Baz2 :: a - class PFoo2 a 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.golden b/tests/compile-and-dump/Singletons/T178.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T178.golden +++ /dev/null @@ -1,224 +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 :: Occ - type OptSym0 = Opt :: Occ - type ManySym0 = Many :: Occ - type EmptySym0 = Empty :: [(Symbol, Occ)] - type Empty :: [(Symbol, Occ)] - type family Empty where - Empty = NilSym0 - type Compare_0123456789876543210 :: Occ -> Occ -> Ordering - type family Compare_0123456789876543210 a a where - Compare_0123456789876543210 Str Str = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) NilSym0 - Compare_0123456789876543210 Opt Opt = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) NilSym0 - Compare_0123456789876543210 Many Many = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) NilSym0 - 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_0123456789876543210Sym0 :: (~>) Occ ((~>) Occ Ordering) - data Compare_0123456789876543210Sym0 a0123456789876543210 - where - Compare_0123456789876543210Sym0KindInference :: SameKind (Apply Compare_0123456789876543210Sym0 arg) (Compare_0123456789876543210Sym1 arg) => - Compare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Compare_0123456789876543210Sym0 a0123456789876543210 = Compare_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Compare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym0KindInference) ()) - type Compare_0123456789876543210Sym1 :: Occ -> (~>) Occ Ordering - data Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - Compare_0123456789876543210Sym1KindInference :: SameKind (Apply (Compare_0123456789876543210Sym1 a0123456789876543210) arg) (Compare_0123456789876543210Sym2 a0123456789876543210 arg) => - Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Compare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Compare_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Compare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym1KindInference) ()) - type Compare_0123456789876543210Sym2 (a0123456789876543210 :: Occ) (a0123456789876543210 :: Occ) = - Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 :: Ordering - instance POrd Occ where - type Compare a a = Apply (Apply Compare_0123456789876543210Sym0 a) a - type ShowsPrec_0123456789876543210 :: Nat - -> Occ -> Symbol -> Symbol - type family ShowsPrec_0123456789876543210 a a a 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_0123456789876543210Sym0 :: (~>) Nat ((~>) Occ ((~>) Symbol Symbol)) - data ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym0KindInference :: SameKind (Apply ShowsPrec_0123456789876543210Sym0 arg) (ShowsPrec_0123456789876543210Sym1 arg) => - ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ShowsPrec_0123456789876543210Sym0 a0123456789876543210 = ShowsPrec_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings ShowsPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym0KindInference) ()) - type ShowsPrec_0123456789876543210Sym1 :: Nat - -> (~>) Occ ((~>) Symbol Symbol) - data ShowsPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym1KindInference) ()) - type ShowsPrec_0123456789876543210Sym2 :: Nat - -> Occ -> (~>) Symbol Symbol - data ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym2KindInference :: 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_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym2KindInference) ()) - type ShowsPrec_0123456789876543210Sym3 (a0123456789876543210 :: Nat) (a0123456789876543210 :: Occ) (a0123456789876543210 :: Symbol) = - ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 :: Symbol - instance PShow Occ where - type ShowsPrec a a a = Apply (Apply (Apply ShowsPrec_0123456789876543210Sym0 a) a) a - type Equals_0123456789876543210 :: Occ -> Occ -> Bool - type family Equals_0123456789876543210 a b 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 :: Occ) - SOpt :: SOcc (Opt :: Occ) - SMany :: SOcc (Many :: Occ) - 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.golden b/tests/compile-and-dump/Singletons/T183.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T183.golden +++ /dev/null @@ -1,506 +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 - foo8 x@(Nothing :: 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 - foo8 x@(Nothing :: Maybe a) = x - foo9 :: a -> a - foo9 (x :: a) - = let - g :: a -> b -> a - g y _ = y - in (g x) () - data Let0123456789876543210GSym0 x0123456789876543210 - where - Let0123456789876543210GSym0KindInference :: SameKind (Apply Let0123456789876543210GSym0 arg) (Let0123456789876543210GSym1 arg) => - Let0123456789876543210GSym0 x0123456789876543210 - type instance Apply Let0123456789876543210GSym0 x0123456789876543210 = Let0123456789876543210GSym1 x0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210GSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210GSym0KindInference) ()) - data Let0123456789876543210GSym1 x0123456789876543210 :: (~>) a ((~>) b0123456789876543210 a) - where - Let0123456789876543210GSym1KindInference :: SameKind (Apply (Let0123456789876543210GSym1 x0123456789876543210) arg) (Let0123456789876543210GSym2 x0123456789876543210 arg) => - Let0123456789876543210GSym1 x0123456789876543210 a0123456789876543210 - type instance Apply (Let0123456789876543210GSym1 x0123456789876543210) a0123456789876543210 = Let0123456789876543210GSym2 x0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210GSym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210GSym1KindInference) ()) - data Let0123456789876543210GSym2 x0123456789876543210 (a0123456789876543210 :: a) :: (~>) b0123456789876543210 a - where - Let0123456789876543210GSym2KindInference :: SameKind (Apply (Let0123456789876543210GSym2 x0123456789876543210 a0123456789876543210) arg) (Let0123456789876543210GSym3 x0123456789876543210 a0123456789876543210 arg) => - Let0123456789876543210GSym2 x0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (Let0123456789876543210GSym2 x0123456789876543210 a0123456789876543210) a0123456789876543210 = Let0123456789876543210GSym3 x0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210GSym2 x0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210GSym2KindInference) ()) - type Let0123456789876543210GSym3 x0123456789876543210 (a0123456789876543210 :: a) (a0123456789876543210 :: b0123456789876543210) = - Let0123456789876543210G x0123456789876543210 a0123456789876543210 a0123456789876543210 :: a - type family Let0123456789876543210G x (a :: a) (a :: b) :: a where - Let0123456789876543210G x y _ = y - data Let0123456789876543210XSym0 wild_01234567898765432100123456789876543210 - where - Let0123456789876543210XSym0KindInference :: SameKind (Apply Let0123456789876543210XSym0 arg) (Let0123456789876543210XSym1 arg) => - Let0123456789876543210XSym0 wild_01234567898765432100123456789876543210 - type instance Apply Let0123456789876543210XSym0 wild_01234567898765432100123456789876543210 = Let0123456789876543210XSym1 wild_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210XSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210XSym0KindInference) ()) - type Let0123456789876543210XSym1 wild_01234567898765432100123456789876543210 = - Let0123456789876543210X wild_01234567898765432100123456789876543210 - type family Let0123456789876543210X wild_0123456789876543210 where - Let0123456789876543210X wild_0123456789876543210 = Apply JustSym0 (wild_0123456789876543210 :: a) :: Maybe a - type Let0123456789876543210XSym0 = Let0123456789876543210X - type family Let0123456789876543210X where - Let0123456789876543210X = NothingSym0 :: Maybe a - data Let0123456789876543210Scrutinee_0123456789876543210Sym0 x0123456789876543210 - where - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference :: SameKind (Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 arg) (Let0123456789876543210Scrutinee_0123456789876543210Sym1 arg) => - Let0123456789876543210Scrutinee_0123456789876543210Sym0 x0123456789876543210 - type instance Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 x0123456789876543210 = Let0123456789876543210Scrutinee_0123456789876543210Sym1 x0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210Scrutinee_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd - (((,) - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference) - ()) - type Let0123456789876543210Scrutinee_0123456789876543210Sym1 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 arg_0123456789876543210 where - Lambda_0123456789876543210 a_0123456789876543210 arg_0123456789876543210 = Case_0123456789876543210 arg_0123456789876543210 a_0123456789876543210 arg_0123456789876543210 - data Lambda_0123456789876543210Sym0 a_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 a_01234567898765432100123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 a_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210 arg_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210) arg) (Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 arg) => - Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210 arg_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210) arg_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 arg_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - type Lambda_0123456789876543210Sym2 a_01234567898765432100123456789876543210 arg_01234567898765432100123456789876543210 = - Lambda_0123456789876543210 a_01234567898765432100123456789876543210 arg_01234567898765432100123456789876543210 - data Let0123456789876543210Scrutinee_0123456789876543210Sym0 x0123456789876543210 - where - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference :: SameKind (Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 arg) (Let0123456789876543210Scrutinee_0123456789876543210Sym1 arg) => - Let0123456789876543210Scrutinee_0123456789876543210Sym0 x0123456789876543210 - type instance Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 x0123456789876543210 = Let0123456789876543210Scrutinee_0123456789876543210Sym1 x0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210Scrutinee_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd - (((,) - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference) - ()) - type Let0123456789876543210Scrutinee_0123456789876543210Sym1 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 Foo9Sym0 :: (~>) a a - data Foo9Sym0 a0123456789876543210 - where - Foo9Sym0KindInference :: SameKind (Apply Foo9Sym0 arg) (Foo9Sym1 arg) => - Foo9Sym0 a0123456789876543210 - type instance Apply Foo9Sym0 a0123456789876543210 = Foo9Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo9Sym0 where - suppressUnusedWarnings = snd (((,) Foo9Sym0KindInference) ()) - type Foo9Sym1 (a0123456789876543210 :: a) = - Foo9 a0123456789876543210 :: a - type Foo8Sym0 :: forall a. (~>) (Maybe a) (Maybe a) - data Foo8Sym0 a0123456789876543210 - where - Foo8Sym0KindInference :: SameKind (Apply Foo8Sym0 arg) (Foo8Sym1 arg) => - Foo8Sym0 a0123456789876543210 - type instance Apply Foo8Sym0 a0123456789876543210 = Foo8Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo8Sym0 where - suppressUnusedWarnings = snd (((,) Foo8Sym0KindInference) ()) - type Foo8Sym1 (a0123456789876543210 :: Maybe a) = - Foo8 a0123456789876543210 :: Maybe a - type Foo7Sym0 :: (~>) a ((~>) b a) - data Foo7Sym0 a0123456789876543210 - where - Foo7Sym0KindInference :: SameKind (Apply Foo7Sym0 arg) (Foo7Sym1 arg) => - Foo7Sym0 a0123456789876543210 - type instance Apply Foo7Sym0 a0123456789876543210 = Foo7Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo7Sym0 where - suppressUnusedWarnings = snd (((,) Foo7Sym0KindInference) ()) - type Foo7Sym1 :: a -> (~>) b a - data Foo7Sym1 a0123456789876543210 a0123456789876543210 - where - Foo7Sym1KindInference :: SameKind (Apply (Foo7Sym1 a0123456789876543210) arg) (Foo7Sym2 a0123456789876543210 arg) => - Foo7Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Foo7Sym1 a0123456789876543210) a0123456789876543210 = Foo7Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Foo7Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) Foo7Sym1KindInference) ()) - type Foo7Sym2 (a0123456789876543210 :: a) (a0123456789876543210 :: b) = - Foo7 a0123456789876543210 a0123456789876543210 :: a - type Foo6Sym0 :: (~>) (Maybe (Maybe a)) (Maybe (Maybe a)) - data Foo6Sym0 a0123456789876543210 - where - Foo6Sym0KindInference :: SameKind (Apply Foo6Sym0 arg) (Foo6Sym1 arg) => - Foo6Sym0 a0123456789876543210 - type instance Apply Foo6Sym0 a0123456789876543210 = Foo6Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo6Sym0 where - suppressUnusedWarnings = snd (((,) Foo6Sym0KindInference) ()) - type Foo6Sym1 (a0123456789876543210 :: Maybe (Maybe a)) = - Foo6 a0123456789876543210 :: Maybe (Maybe a) - type Foo5Sym0 :: (~>) (Maybe (Maybe a)) (Maybe (Maybe a)) - data Foo5Sym0 a0123456789876543210 - where - Foo5Sym0KindInference :: SameKind (Apply Foo5Sym0 arg) (Foo5Sym1 arg) => - Foo5Sym0 a0123456789876543210 - type instance Apply Foo5Sym0 a0123456789876543210 = Foo5Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo5Sym0 where - suppressUnusedWarnings = snd (((,) Foo5Sym0KindInference) ()) - type Foo5Sym1 (a0123456789876543210 :: Maybe (Maybe a)) = - Foo5 a0123456789876543210 :: Maybe (Maybe a) - type Foo4Sym0 :: (~>) (a, b) (b, a) - data Foo4Sym0 a0123456789876543210 - where - Foo4Sym0KindInference :: SameKind (Apply Foo4Sym0 arg) (Foo4Sym1 arg) => - Foo4Sym0 a0123456789876543210 - type instance Apply Foo4Sym0 a0123456789876543210 = Foo4Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo4Sym0 where - suppressUnusedWarnings = snd (((,) Foo4Sym0KindInference) ()) - type Foo4Sym1 (a0123456789876543210 :: (a, b)) = - Foo4 a0123456789876543210 :: (b, a) - type Foo3Sym0 :: forall a. (~>) (Maybe a) a - data Foo3Sym0 a0123456789876543210 - where - Foo3Sym0KindInference :: SameKind (Apply Foo3Sym0 arg) (Foo3Sym1 arg) => - Foo3Sym0 a0123456789876543210 - type instance Apply Foo3Sym0 a0123456789876543210 = Foo3Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo3Sym0 where - suppressUnusedWarnings = snd (((,) Foo3Sym0KindInference) ()) - type Foo3Sym1 (a0123456789876543210 :: Maybe a) = - Foo3 a0123456789876543210 :: a - type Foo2Sym0 :: forall a. (~>) (Maybe a) a - data Foo2Sym0 a0123456789876543210 - where - Foo2Sym0KindInference :: SameKind (Apply Foo2Sym0 arg) (Foo2Sym1 arg) => - Foo2Sym0 a0123456789876543210 - type instance Apply Foo2Sym0 a0123456789876543210 = Foo2Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo2Sym0 where - suppressUnusedWarnings = snd (((,) Foo2Sym0KindInference) ()) - type Foo2Sym1 (a0123456789876543210 :: Maybe a) = - Foo2 a0123456789876543210 :: a - type Foo1Sym0 :: (~>) (Maybe a) a - data Foo1Sym0 a0123456789876543210 - where - Foo1Sym0KindInference :: SameKind (Apply Foo1Sym0 arg) (Foo1Sym1 arg) => - Foo1Sym0 a0123456789876543210 - type instance Apply Foo1Sym0 a0123456789876543210 = Foo1Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Foo1Sym0 where - suppressUnusedWarnings = snd (((,) Foo1Sym0KindInference) ()) - type Foo1Sym1 (a0123456789876543210 :: Maybe a) = - Foo1 a0123456789876543210 :: a - data GSym0 a0123456789876543210 - where - GSym0KindInference :: SameKind (Apply GSym0 arg) (GSym1 arg) => - GSym0 a0123456789876543210 - type instance Apply GSym0 a0123456789876543210 = GSym1 a0123456789876543210 - instance SuppressUnusedWarnings GSym0 where - suppressUnusedWarnings = snd (((,) GSym0KindInference) ()) - type GSym1 a0123456789876543210 = G a0123456789876543210 - data F3Sym0 a0123456789876543210 - where - F3Sym0KindInference :: SameKind (Apply F3Sym0 arg) (F3Sym1 arg) => - F3Sym0 a0123456789876543210 - type instance Apply F3Sym0 a0123456789876543210 = F3Sym1 a0123456789876543210 - instance SuppressUnusedWarnings F3Sym0 where - suppressUnusedWarnings = snd (((,) F3Sym0KindInference) ()) - type F3Sym1 a0123456789876543210 = F3 a0123456789876543210 - data F2Sym0 a0123456789876543210 - where - F2Sym0KindInference :: SameKind (Apply F2Sym0 arg) (F2Sym1 arg) => - F2Sym0 a0123456789876543210 - type instance Apply F2Sym0 a0123456789876543210 = F2Sym1 a0123456789876543210 - instance SuppressUnusedWarnings F2Sym0 where - suppressUnusedWarnings = snd (((,) F2Sym0KindInference) ()) - type F2Sym1 a0123456789876543210 = F2 a0123456789876543210 - data F1Sym0 a0123456789876543210 - where - F1Sym0KindInference :: SameKind (Apply F1Sym0 arg) (F1Sym1 arg) => - F1Sym0 a0123456789876543210 - type instance Apply F1Sym0 a0123456789876543210 = F1Sym1 a0123456789876543210 - instance SuppressUnusedWarnings F1Sym0 where - suppressUnusedWarnings = snd (((,) F1Sym0KindInference) ()) - type F1Sym1 a0123456789876543210 = F1 a0123456789876543210 - type Foo9 :: a -> a - type family Foo9 a where - Foo9 (x :: a) = Apply (Apply (Let0123456789876543210GSym1 x) x) Tuple0Sym0 - type Foo8 :: forall a. Maybe a -> Maybe a - type family Foo8 a where - Foo8 ('Just (wild_0123456789876543210 :: a) :: Maybe a) = Let0123456789876543210XSym1 wild_0123456789876543210 - Foo8 ('Nothing :: Maybe a) = Let0123456789876543210XSym0 - type Foo7 :: a -> b -> a - type family Foo7 a a where - Foo7 (x :: a) (wild_0123456789876543210 :: b) = x :: a - type Foo6 :: Maybe (Maybe a) -> Maybe (Maybe a) - type family Foo6 a where - Foo6 ('Just x :: Maybe (Maybe a)) = Case_0123456789876543210 x (Let0123456789876543210Scrutinee_0123456789876543210Sym1 x) - type Foo5 :: Maybe (Maybe a) -> Maybe (Maybe a) - type family Foo5 a where - Foo5 ('Just ('Just (x :: a) :: Maybe a) :: Maybe (Maybe a)) = Apply JustSym0 (Apply JustSym0 (x :: a) :: Maybe a) :: Maybe (Maybe a) - type Foo4 :: (a, b) -> (b, a) - type family Foo4 a where - Foo4 a_0123456789876543210 = Apply (Apply Lambda_0123456789876543210Sym0 a_0123456789876543210) a_0123456789876543210 - type Foo3 :: forall a. Maybe a -> a - type family Foo3 a where - Foo3 ('Just x) = x :: a - type Foo2 :: forall a. Maybe a -> a - type family Foo2 a where - Foo2 ('Just x :: Maybe a) = x :: a - type Foo1 :: Maybe a -> a - type family Foo1 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 } - sFoo8 SNothing - = case SNothing of { - (_ :: Sing ('Nothing :: Maybe a)) - -> let - sX :: Sing @_ Let0123456789876543210XSym0 - sX = SNothing :: Sing (NothingSym0 :: 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 - - ----- - -- 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.golden b/tests/compile-and-dump/Singletons/T184.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T184.golden +++ /dev/null @@ -1,438 +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 x where - Lambda_0123456789876543210 xs x = Apply (Apply (>>@#@$) (Apply GuardSym0 x)) (Apply ReturnSym0 x) - data Lambda_0123456789876543210Sym0 xs0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 xs0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 xs0123456789876543210 = Lambda_0123456789876543210Sym1 xs0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 xs0123456789876543210 x0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym1 xs0123456789876543210) arg) (Lambda_0123456789876543210Sym2 xs0123456789876543210 arg) => - Lambda_0123456789876543210Sym1 xs0123456789876543210 x0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym1 xs0123456789876543210) x0123456789876543210 = Lambda_0123456789876543210Sym2 xs0123456789876543210 x0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym1 xs0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - type Lambda_0123456789876543210Sym2 xs0123456789876543210 x0123456789876543210 = - Lambda_0123456789876543210 xs0123456789876543210 x0123456789876543210 - type family Lambda_0123456789876543210 x xs ys y where - Lambda_0123456789876543210 x xs ys y = Apply ReturnSym0 (Apply (Apply Tuple2Sym0 x) y) - data Lambda_0123456789876543210Sym0 x0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 x0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 x0123456789876543210 = Lambda_0123456789876543210Sym1 x0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 x0123456789876543210 xs0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 x0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 x0123456789876543210 xs0123456789876543210 ys0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym2 x0123456789876543210 xs0123456789876543210) arg) (Lambda_0123456789876543210Sym3 x0123456789876543210 xs0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 x0123456789876543210 xs0123456789876543210 ys0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 x0123456789876543210 xs0123456789876543210) ys0123456789876543210 = Lambda_0123456789876543210Sym3 x0123456789876543210 xs0123456789876543210 ys0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 x0123456789876543210 xs0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym3 x0123456789876543210 xs0123456789876543210 ys0123456789876543210 y0123456789876543210 - where - Lambda_0123456789876543210Sym3KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym3 x0123456789876543210 xs0123456789876543210 ys0123456789876543210) arg) (Lambda_0123456789876543210Sym4 x0123456789876543210 xs0123456789876543210 ys0123456789876543210 arg) => - Lambda_0123456789876543210Sym3 x0123456789876543210 xs0123456789876543210 ys0123456789876543210 y0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym3 x0123456789876543210 xs0123456789876543210 ys0123456789876543210) y0123456789876543210 = Lambda_0123456789876543210Sym4 x0123456789876543210 xs0123456789876543210 ys0123456789876543210 y0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym3 x0123456789876543210 xs0123456789876543210 ys0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym3KindInference) ()) - type Lambda_0123456789876543210Sym4 x0123456789876543210 xs0123456789876543210 ys0123456789876543210 y0123456789876543210 = - Lambda_0123456789876543210 x0123456789876543210 xs0123456789876543210 ys0123456789876543210 y0123456789876543210 - type family Lambda_0123456789876543210 xs ys x where - Lambda_0123456789876543210 xs ys x = Apply (Apply (>>=@#@$) ys) (Apply (Apply (Apply Lambda_0123456789876543210Sym0 x) xs) ys) - data Lambda_0123456789876543210Sym0 xs0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 xs0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 xs0123456789876543210 = Lambda_0123456789876543210Sym1 xs0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 xs0123456789876543210 ys0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 xs0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210 x0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210) arg) (Lambda_0123456789876543210Sym3 xs0123456789876543210 ys0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210 x0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210) x0123456789876543210 = Lambda_0123456789876543210Sym3 xs0123456789876543210 ys0123456789876543210 x0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - type Lambda_0123456789876543210Sym3 xs0123456789876543210 ys0123456789876543210 x0123456789876543210 = - Lambda_0123456789876543210 xs0123456789876543210 ys0123456789876543210 x0123456789876543210 - type family Lambda_0123456789876543210 xs ys x where - Lambda_0123456789876543210 xs ys x = Apply ReturnSym0 x - data Lambda_0123456789876543210Sym0 xs0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 xs0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 xs0123456789876543210 = Lambda_0123456789876543210Sym1 xs0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 xs0123456789876543210 ys0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 xs0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210 x0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210) arg) (Lambda_0123456789876543210Sym3 xs0123456789876543210 ys0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210 x0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210) x0123456789876543210 = Lambda_0123456789876543210Sym3 xs0123456789876543210 ys0123456789876543210 x0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - type Lambda_0123456789876543210Sym3 xs0123456789876543210 ys0123456789876543210 x0123456789876543210 = - Lambda_0123456789876543210 xs0123456789876543210 ys0123456789876543210 x0123456789876543210 - type family Lambda_0123456789876543210 xs ys y where - Lambda_0123456789876543210 xs ys y = Apply ReturnSym0 y - data Lambda_0123456789876543210Sym0 xs0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 xs0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 xs0123456789876543210 = Lambda_0123456789876543210Sym1 xs0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 xs0123456789876543210 ys0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 xs0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210 y0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210) arg) (Lambda_0123456789876543210Sym3 xs0123456789876543210 ys0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210 y0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210) y0123456789876543210 = Lambda_0123456789876543210Sym3 xs0123456789876543210 ys0123456789876543210 y0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - type Lambda_0123456789876543210Sym3 xs0123456789876543210 ys0123456789876543210 y0123456789876543210 = - Lambda_0123456789876543210 xs0123456789876543210 ys0123456789876543210 y0123456789876543210 - 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 arg_0123456789876543210 where - Lambda_0123456789876543210 xs ys arg_0123456789876543210 = Case_0123456789876543210 arg_0123456789876543210 xs ys arg_0123456789876543210 - data Lambda_0123456789876543210Sym0 xs0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 xs0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 xs0123456789876543210 = Lambda_0123456789876543210Sym1 xs0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 xs0123456789876543210 ys0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 xs0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210 arg_01234567898765432100123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210) arg) (Lambda_0123456789876543210Sym3 xs0123456789876543210 ys0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210 arg_01234567898765432100123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210) arg_01234567898765432100123456789876543210 = Lambda_0123456789876543210Sym3 xs0123456789876543210 ys0123456789876543210 arg_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 xs0123456789876543210 ys0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - type Lambda_0123456789876543210Sym3 xs0123456789876543210 ys0123456789876543210 arg_01234567898765432100123456789876543210 = - Lambda_0123456789876543210 xs0123456789876543210 ys0123456789876543210 arg_01234567898765432100123456789876543210 - type family Lambda_0123456789876543210 a ma mb b where - Lambda_0123456789876543210 a ma mb b = Apply (Apply (>>@#@$) (Apply GuardSym0 b)) (Apply ReturnSym0 a) - data Lambda_0123456789876543210Sym0 a0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 a0123456789876543210 = Lambda_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 a0123456789876543210 ma0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 a0123456789876543210 ma0123456789876543210 mb0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym2 a0123456789876543210 ma0123456789876543210) arg) (Lambda_0123456789876543210Sym3 a0123456789876543210 ma0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 a0123456789876543210 ma0123456789876543210 mb0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 a0123456789876543210 ma0123456789876543210) mb0123456789876543210 = Lambda_0123456789876543210Sym3 a0123456789876543210 ma0123456789876543210 mb0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 a0123456789876543210 ma0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - data Lambda_0123456789876543210Sym3 a0123456789876543210 ma0123456789876543210 mb0123456789876543210 b0123456789876543210 - where - Lambda_0123456789876543210Sym3KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym3 a0123456789876543210 ma0123456789876543210 mb0123456789876543210) arg) (Lambda_0123456789876543210Sym4 a0123456789876543210 ma0123456789876543210 mb0123456789876543210 arg) => - Lambda_0123456789876543210Sym3 a0123456789876543210 ma0123456789876543210 mb0123456789876543210 b0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym3 a0123456789876543210 ma0123456789876543210 mb0123456789876543210) b0123456789876543210 = Lambda_0123456789876543210Sym4 a0123456789876543210 ma0123456789876543210 mb0123456789876543210 b0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym3 a0123456789876543210 ma0123456789876543210 mb0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym3KindInference) ()) - type Lambda_0123456789876543210Sym4 a0123456789876543210 ma0123456789876543210 mb0123456789876543210 b0123456789876543210 = - Lambda_0123456789876543210 a0123456789876543210 ma0123456789876543210 mb0123456789876543210 b0123456789876543210 - type family Lambda_0123456789876543210 ma mb a where - Lambda_0123456789876543210 ma mb a = Apply (Apply (>>=@#@$) mb) (Apply (Apply (Apply Lambda_0123456789876543210Sym0 a) ma) mb) - data Lambda_0123456789876543210Sym0 ma0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 ma0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 ma0123456789876543210 = Lambda_0123456789876543210Sym1 ma0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 ma0123456789876543210 mb0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 ma0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 ma0123456789876543210 mb0123456789876543210 a0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym2 ma0123456789876543210 mb0123456789876543210) arg) (Lambda_0123456789876543210Sym3 ma0123456789876543210 mb0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 ma0123456789876543210 mb0123456789876543210 a0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 ma0123456789876543210 mb0123456789876543210) a0123456789876543210 = Lambda_0123456789876543210Sym3 ma0123456789876543210 mb0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 ma0123456789876543210 mb0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - type Lambda_0123456789876543210Sym3 ma0123456789876543210 mb0123456789876543210 a0123456789876543210 = - Lambda_0123456789876543210 ma0123456789876543210 mb0123456789876543210 a0123456789876543210 - type TruesSym0 :: (~>) [Bool] [Bool] - data TruesSym0 a0123456789876543210 - where - TruesSym0KindInference :: SameKind (Apply TruesSym0 arg) (TruesSym1 arg) => - TruesSym0 a0123456789876543210 - type instance Apply TruesSym0 a0123456789876543210 = TruesSym1 a0123456789876543210 - instance SuppressUnusedWarnings TruesSym0 where - suppressUnusedWarnings = snd (((,) TruesSym0KindInference) ()) - type TruesSym1 (a0123456789876543210 :: [Bool]) = - Trues a0123456789876543210 :: [Bool] - type CartProdSym0 :: (~>) [a] ((~>) [b] [(a, b)]) - data CartProdSym0 a0123456789876543210 - where - CartProdSym0KindInference :: SameKind (Apply CartProdSym0 arg) (CartProdSym1 arg) => - CartProdSym0 a0123456789876543210 - type instance Apply CartProdSym0 a0123456789876543210 = CartProdSym1 a0123456789876543210 - instance SuppressUnusedWarnings CartProdSym0 where - suppressUnusedWarnings = snd (((,) CartProdSym0KindInference) ()) - type CartProdSym1 :: [a] -> (~>) [b] [(a, b)] - data CartProdSym1 a0123456789876543210 a0123456789876543210 - where - CartProdSym1KindInference :: SameKind (Apply (CartProdSym1 a0123456789876543210) arg) (CartProdSym2 a0123456789876543210 arg) => - CartProdSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (CartProdSym1 a0123456789876543210) a0123456789876543210 = CartProdSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (CartProdSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) CartProdSym1KindInference) ()) - type CartProdSym2 (a0123456789876543210 :: [a]) (a0123456789876543210 :: [b]) = - CartProd a0123456789876543210 a0123456789876543210 :: [(a, b)] - type Zip'Sym0 :: (~>) [a] ((~>) [b] [(a, b)]) - data Zip'Sym0 a0123456789876543210 - where - Zip'Sym0KindInference :: SameKind (Apply Zip'Sym0 arg) (Zip'Sym1 arg) => - Zip'Sym0 a0123456789876543210 - type instance Apply Zip'Sym0 a0123456789876543210 = Zip'Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Zip'Sym0 where - suppressUnusedWarnings = snd (((,) Zip'Sym0KindInference) ()) - type Zip'Sym1 :: [a] -> (~>) [b] [(a, b)] - data Zip'Sym1 a0123456789876543210 a0123456789876543210 - where - Zip'Sym1KindInference :: SameKind (Apply (Zip'Sym1 a0123456789876543210) arg) (Zip'Sym2 a0123456789876543210 arg) => - Zip'Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Zip'Sym1 a0123456789876543210) a0123456789876543210 = Zip'Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Zip'Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) Zip'Sym1KindInference) ()) - type Zip'Sym2 (a0123456789876543210 :: [a]) (a0123456789876543210 :: [b]) = - Zip' a0123456789876543210 a0123456789876543210 :: [(a, b)] - type BoogieSym0 :: (~>) (Maybe a) ((~>) (Maybe Bool) (Maybe a)) - data BoogieSym0 a0123456789876543210 - where - BoogieSym0KindInference :: SameKind (Apply BoogieSym0 arg) (BoogieSym1 arg) => - BoogieSym0 a0123456789876543210 - type instance Apply BoogieSym0 a0123456789876543210 = BoogieSym1 a0123456789876543210 - instance SuppressUnusedWarnings BoogieSym0 where - suppressUnusedWarnings = snd (((,) BoogieSym0KindInference) ()) - type BoogieSym1 :: Maybe a -> (~>) (Maybe Bool) (Maybe a) - data BoogieSym1 a0123456789876543210 a0123456789876543210 - where - BoogieSym1KindInference :: SameKind (Apply (BoogieSym1 a0123456789876543210) arg) (BoogieSym2 a0123456789876543210 arg) => - BoogieSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (BoogieSym1 a0123456789876543210) a0123456789876543210 = BoogieSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (BoogieSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) BoogieSym1KindInference) ()) - type BoogieSym2 (a0123456789876543210 :: Maybe a) (a0123456789876543210 :: Maybe Bool) = - Boogie a0123456789876543210 a0123456789876543210 :: Maybe a - type Trues :: [Bool] -> [Bool] - type family Trues a where - Trues xs = Apply (Apply (>>=@#@$) xs) (Apply Lambda_0123456789876543210Sym0 xs) - type CartProd :: [a] -> [b] -> [(a, b)] - type family CartProd a a where - CartProd xs ys = Apply (Apply (>>=@#@$) xs) (Apply (Apply Lambda_0123456789876543210Sym0 xs) ys) - type Zip' :: [a] -> [b] -> [(a, b)] - type family Zip' a a 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 Boogie :: Maybe a -> Maybe Bool -> Maybe a - type family Boogie a 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.golden b/tests/compile-and-dump/Singletons/T187.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T187.golden +++ /dev/null @@ -1,67 +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 Compare_0123456789876543210 :: Empty -> Empty -> Ordering - type family Compare_0123456789876543210 a a where - Compare_0123456789876543210 _ _ = EQSym0 - type Compare_0123456789876543210Sym0 :: (~>) Empty ((~>) Empty Ordering) - data Compare_0123456789876543210Sym0 a0123456789876543210 - where - Compare_0123456789876543210Sym0KindInference :: SameKind (Apply Compare_0123456789876543210Sym0 arg) (Compare_0123456789876543210Sym1 arg) => - Compare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Compare_0123456789876543210Sym0 a0123456789876543210 = Compare_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Compare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym0KindInference) ()) - type Compare_0123456789876543210Sym1 :: Empty - -> (~>) Empty Ordering - data Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - Compare_0123456789876543210Sym1KindInference :: SameKind (Apply (Compare_0123456789876543210Sym1 a0123456789876543210) arg) (Compare_0123456789876543210Sym2 a0123456789876543210 arg) => - Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Compare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Compare_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Compare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym1KindInference) ()) - type Compare_0123456789876543210Sym2 (a0123456789876543210 :: Empty) (a0123456789876543210 :: Empty) = - Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 :: Ordering - instance POrd Empty where - type Compare a a = Apply (Apply Compare_0123456789876543210Sym0 a) a - type Equals_0123456789876543210 :: Empty -> Empty -> Bool - type family Equals_0123456789876543210 a b 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.golden b/tests/compile-and-dump/Singletons/T190.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T190.golden +++ /dev/null @@ -1,204 +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 :: T - type Compare_0123456789876543210 :: T -> T -> Ordering - type family Compare_0123456789876543210 a a where - Compare_0123456789876543210 T T = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) NilSym0 - type Compare_0123456789876543210Sym0 :: (~>) T ((~>) T Ordering) - data Compare_0123456789876543210Sym0 a0123456789876543210 - where - Compare_0123456789876543210Sym0KindInference :: SameKind (Apply Compare_0123456789876543210Sym0 arg) (Compare_0123456789876543210Sym1 arg) => - Compare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Compare_0123456789876543210Sym0 a0123456789876543210 = Compare_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Compare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym0KindInference) ()) - type Compare_0123456789876543210Sym1 :: T -> (~>) T Ordering - data Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - Compare_0123456789876543210Sym1KindInference :: SameKind (Apply (Compare_0123456789876543210Sym1 a0123456789876543210) arg) (Compare_0123456789876543210Sym2 a0123456789876543210 arg) => - Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Compare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Compare_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Compare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym1KindInference) ()) - type Compare_0123456789876543210Sym2 (a0123456789876543210 :: T) (a0123456789876543210 :: T) = - Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 :: Ordering - 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 ToEnum_0123456789876543210 :: GHC.Types.Nat -> T - type family ToEnum_0123456789876543210 a where - ToEnum_0123456789876543210 n = Case_0123456789876543210 n (Apply (Apply (==@#@$) n) (Data.Singletons.Prelude.Num.FromInteger 0)) - type ToEnum_0123456789876543210Sym0 :: (~>) GHC.Types.Nat T - data ToEnum_0123456789876543210Sym0 a0123456789876543210 - where - ToEnum_0123456789876543210Sym0KindInference :: SameKind (Apply ToEnum_0123456789876543210Sym0 arg) (ToEnum_0123456789876543210Sym1 arg) => - ToEnum_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ToEnum_0123456789876543210Sym0 a0123456789876543210 = ToEnum_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings ToEnum_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ToEnum_0123456789876543210Sym0KindInference) ()) - type ToEnum_0123456789876543210Sym1 (a0123456789876543210 :: GHC.Types.Nat) = - ToEnum_0123456789876543210 a0123456789876543210 :: T - type FromEnum_0123456789876543210 :: T -> GHC.Types.Nat - type family FromEnum_0123456789876543210 a where - FromEnum_0123456789876543210 T = Data.Singletons.Prelude.Num.FromInteger 0 - type FromEnum_0123456789876543210Sym0 :: (~>) T GHC.Types.Nat - data FromEnum_0123456789876543210Sym0 a0123456789876543210 - where - FromEnum_0123456789876543210Sym0KindInference :: SameKind (Apply FromEnum_0123456789876543210Sym0 arg) (FromEnum_0123456789876543210Sym1 arg) => - FromEnum_0123456789876543210Sym0 a0123456789876543210 - type instance Apply FromEnum_0123456789876543210Sym0 a0123456789876543210 = FromEnum_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings FromEnum_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) FromEnum_0123456789876543210Sym0KindInference) ()) - type FromEnum_0123456789876543210Sym1 (a0123456789876543210 :: T) = - FromEnum_0123456789876543210 a0123456789876543210 :: GHC.Types.Nat - instance PEnum T where - type ToEnum a = Apply ToEnum_0123456789876543210Sym0 a - type FromEnum a = Apply FromEnum_0123456789876543210Sym0 a - type MinBound_0123456789876543210 :: T - type family MinBound_0123456789876543210 where - MinBound_0123456789876543210 = TSym0 - type MinBound_0123456789876543210Sym0 = - MinBound_0123456789876543210 :: T - type MaxBound_0123456789876543210 :: T - type family MaxBound_0123456789876543210 where - MaxBound_0123456789876543210 = TSym0 - type MaxBound_0123456789876543210Sym0 = - MaxBound_0123456789876543210 :: T - instance PBounded T where - type MinBound = MinBound_0123456789876543210Sym0 - type MaxBound = MaxBound_0123456789876543210Sym0 - type ShowsPrec_0123456789876543210 :: GHC.Types.Nat - -> T -> GHC.Types.Symbol -> GHC.Types.Symbol - type family ShowsPrec_0123456789876543210 a a a where - ShowsPrec_0123456789876543210 _ T a_0123456789876543210 = Apply (Apply ShowStringSym0 "T") a_0123456789876543210 - type ShowsPrec_0123456789876543210Sym0 :: (~>) GHC.Types.Nat ((~>) T ((~>) GHC.Types.Symbol GHC.Types.Symbol)) - data ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym0KindInference :: SameKind (Apply ShowsPrec_0123456789876543210Sym0 arg) (ShowsPrec_0123456789876543210Sym1 arg) => - ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ShowsPrec_0123456789876543210Sym0 a0123456789876543210 = ShowsPrec_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings ShowsPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym0KindInference) ()) - type ShowsPrec_0123456789876543210Sym1 :: GHC.Types.Nat - -> (~>) T ((~>) GHC.Types.Symbol GHC.Types.Symbol) - data ShowsPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym1KindInference) ()) - type ShowsPrec_0123456789876543210Sym2 :: GHC.Types.Nat - -> T -> (~>) GHC.Types.Symbol GHC.Types.Symbol - data ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym2KindInference :: 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_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym2KindInference) ()) - type ShowsPrec_0123456789876543210Sym3 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: T) (a0123456789876543210 :: GHC.Types.Symbol) = - ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 :: GHC.Types.Symbol - instance PShow T where - type ShowsPrec a a a = Apply (Apply (Apply ShowsPrec_0123456789876543210Sym0 a) a) a - type Equals_0123456789876543210 :: T -> T -> Bool - type family Equals_0123456789876543210 a b 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 :: 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.golden b/tests/compile-and-dump/Singletons/T197.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T197.golden +++ /dev/null @@ -1,44 +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 ($$:@#@$) :: (~>) Bool ((~>) Bool Bool) - data ($$:@#@$) a0123456789876543210 - where - (:$$:@#@$###) :: SameKind (Apply ($$:@#@$) arg) (($$:@#@$$) arg) => - ($$:@#@$) a0123456789876543210 - type instance Apply ($$:@#@$) a0123456789876543210 = ($$:@#@$$) a0123456789876543210 - instance SuppressUnusedWarnings ($$:@#@$) where - suppressUnusedWarnings = snd (((,) (:$$:@#@$###)) ()) - infixl 5 $$:@#@$ - type ($$:@#@$$) :: Bool -> (~>) Bool Bool - data ($$:@#@$$) a0123456789876543210 a0123456789876543210 - where - (:$$:@#@$$###) :: SameKind (Apply (($$:@#@$$) a0123456789876543210) arg) (($$:@#@$$$) a0123456789876543210 arg) => - ($$:@#@$$) a0123456789876543210 a0123456789876543210 - type instance Apply (($$:@#@$$) a0123456789876543210) a0123456789876543210 = ($$:@#@$$$) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (($$:@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (:$$:@#@$$###)) ()) - infixl 5 $$:@#@$$ - type ($$:@#@$$$) (a0123456789876543210 :: Bool) (a0123456789876543210 :: Bool) = - ($$:) a0123456789876543210 a0123456789876543210 :: Bool - infixl 5 $$:@#@$$$ - type ($$:) :: Bool -> Bool -> Bool - type family ($$:) a a 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.golden b/tests/compile-and-dump/Singletons/T197b.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T197b.golden +++ /dev/null @@ -1,89 +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 (:*:@#@$) :: forall a b. (~>) a ((~>) b ((:*:) a b)) - data (:*:@#@$) a0123456789876543210 - where - (::*:@#@$###) :: SameKind (Apply (:*:@#@$) arg) ((:*:@#@$$) arg) => - (:*:@#@$) a0123456789876543210 - type instance Apply (:*:@#@$) a0123456789876543210 = (:*:@#@$$) a0123456789876543210 - instance SuppressUnusedWarnings (:*:@#@$) where - suppressUnusedWarnings = snd (((,) (::*:@#@$###)) ()) - type (:*:@#@$$) :: forall a b. a -> (~>) b ((:*:) a b) - data (:*:@#@$$) a0123456789876543210 a0123456789876543210 - where - (::*:@#@$$###) :: SameKind (Apply ((:*:@#@$$) a0123456789876543210) arg) ((:*:@#@$$$) a0123456789876543210 arg) => - (:*:@#@$$) a0123456789876543210 a0123456789876543210 - type instance Apply ((:*:@#@$$) a0123456789876543210) a0123456789876543210 = (:*:@#@$$$) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((:*:@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (::*:@#@$$###)) ()) - type (:*:@#@$$$) (a0123456789876543210 :: a) (a0123456789876543210 :: b) = - (:*:) a0123456789876543210 a0123456789876543210 :: (:*:) a b - type MkPairSym0 :: forall a b. (~>) a ((~>) b (Pair a b)) - data MkPairSym0 a0123456789876543210 - where - MkPairSym0KindInference :: SameKind (Apply MkPairSym0 arg) (MkPairSym1 arg) => - MkPairSym0 a0123456789876543210 - type instance Apply MkPairSym0 a0123456789876543210 = MkPairSym1 a0123456789876543210 - instance SuppressUnusedWarnings MkPairSym0 where - suppressUnusedWarnings = snd (((,) MkPairSym0KindInference) ()) - infixr 9 `MkPairSym0` - type MkPairSym1 :: forall a b. a -> (~>) b (Pair a b) - data MkPairSym1 a0123456789876543210 a0123456789876543210 - where - MkPairSym1KindInference :: SameKind (Apply (MkPairSym1 a0123456789876543210) arg) (MkPairSym2 a0123456789876543210 arg) => - MkPairSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (MkPairSym1 a0123456789876543210) a0123456789876543210 = MkPairSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (MkPairSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) MkPairSym1KindInference) ()) - infixr 9 `MkPairSym1` - type MkPairSym2 (a0123456789876543210 :: a) (a0123456789876543210 :: b) = - MkPair a0123456789876543210 a0123456789876543210 :: Pair a b - infixr 9 `MkPairSym2` - infixr 9 `SMkPair` - data (%:*:) :: forall a b. (:*:) a b -> GHC.Types.Type - where - (:%*:) :: forall a b (n :: a) (n :: b). - (Sing n) -> (Sing n) -> (%:*:) ((:*:) n n :: (:*:) a b) - 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) -> (Sing n) -> SPair (MkPair n n :: Pair a b) - 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.golden b/tests/compile-and-dump/Singletons/T200.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T200.golden +++ /dev/null @@ -1,185 +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 (:$$:@#@$) :: (~>) ErrorMessage ((~>) ErrorMessage ErrorMessage) - data (:$$:@#@$) a0123456789876543210 - where - (::$$:@#@$###) :: SameKind (Apply (:$$:@#@$) arg) ((:$$:@#@$$) arg) => - (:$$:@#@$) a0123456789876543210 - type instance Apply (:$$:@#@$) a0123456789876543210 = (:$$:@#@$$) a0123456789876543210 - instance SuppressUnusedWarnings (:$$:@#@$) where - suppressUnusedWarnings = snd (((,) (::$$:@#@$###)) ()) - type (:$$:@#@$$) :: ErrorMessage -> (~>) ErrorMessage ErrorMessage - data (:$$:@#@$$) a0123456789876543210 a0123456789876543210 - where - (::$$:@#@$$###) :: SameKind (Apply ((:$$:@#@$$) a0123456789876543210) arg) ((:$$:@#@$$$) a0123456789876543210 arg) => - (:$$:@#@$$) a0123456789876543210 a0123456789876543210 - type instance Apply ((:$$:@#@$$) a0123456789876543210) a0123456789876543210 = (:$$:@#@$$$) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((:$$:@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (::$$:@#@$$###)) ()) - type (:$$:@#@$$$) (a0123456789876543210 :: ErrorMessage) (a0123456789876543210 :: ErrorMessage) = - (:$$:) a0123456789876543210 a0123456789876543210 :: ErrorMessage - type (:<>:@#@$) :: (~>) ErrorMessage ((~>) ErrorMessage ErrorMessage) - data (:<>:@#@$) a0123456789876543210 - where - (::<>:@#@$###) :: SameKind (Apply (:<>:@#@$) arg) ((:<>:@#@$$) arg) => - (:<>:@#@$) a0123456789876543210 - type instance Apply (:<>:@#@$) a0123456789876543210 = (:<>:@#@$$) a0123456789876543210 - instance SuppressUnusedWarnings (:<>:@#@$) where - suppressUnusedWarnings = snd (((,) (::<>:@#@$###)) ()) - type (:<>:@#@$$) :: ErrorMessage -> (~>) ErrorMessage ErrorMessage - data (:<>:@#@$$) a0123456789876543210 a0123456789876543210 - where - (::<>:@#@$$###) :: SameKind (Apply ((:<>:@#@$$) a0123456789876543210) arg) ((:<>:@#@$$$) a0123456789876543210 arg) => - (:<>:@#@$$) a0123456789876543210 a0123456789876543210 - type instance Apply ((:<>:@#@$$) a0123456789876543210) a0123456789876543210 = (:<>:@#@$$$) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((:<>:@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (::<>:@#@$$###)) ()) - type (:<>:@#@$$$) (a0123456789876543210 :: ErrorMessage) (a0123456789876543210 :: ErrorMessage) = - (:<>:) a0123456789876543210 a0123456789876543210 :: ErrorMessage - type EMSym0 :: (~>) [Bool] ErrorMessage - data EMSym0 a0123456789876543210 - where - EMSym0KindInference :: SameKind (Apply EMSym0 arg) (EMSym1 arg) => - EMSym0 a0123456789876543210 - type instance Apply EMSym0 a0123456789876543210 = EMSym1 a0123456789876543210 - instance SuppressUnusedWarnings EMSym0 where - suppressUnusedWarnings = snd (((,) EMSym0KindInference) ()) - type EMSym1 (a0123456789876543210 :: [Bool]) = - EM a0123456789876543210 :: ErrorMessage - type (<>:@#@$) :: (~>) ErrorMessage ((~>) ErrorMessage ErrorMessage) - data (<>:@#@$) a0123456789876543210 - where - (:<>:@#@$###) :: SameKind (Apply (<>:@#@$) arg) ((<>:@#@$$) arg) => - (<>:@#@$) a0123456789876543210 - type instance Apply (<>:@#@$) a0123456789876543210 = (<>:@#@$$) a0123456789876543210 - instance SuppressUnusedWarnings (<>:@#@$) where - suppressUnusedWarnings = snd (((,) (:<>:@#@$###)) ()) - type (<>:@#@$$) :: ErrorMessage -> (~>) ErrorMessage ErrorMessage - data (<>:@#@$$) a0123456789876543210 a0123456789876543210 - where - (:<>:@#@$$###) :: SameKind (Apply ((<>:@#@$$) a0123456789876543210) arg) ((<>:@#@$$$) a0123456789876543210 arg) => - (<>:@#@$$) a0123456789876543210 a0123456789876543210 - type instance Apply ((<>:@#@$$) a0123456789876543210) a0123456789876543210 = (<>:@#@$$$) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((<>:@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (:<>:@#@$$###)) ()) - type (<>:@#@$$$) (a0123456789876543210 :: ErrorMessage) (a0123456789876543210 :: ErrorMessage) = - (<>:) a0123456789876543210 a0123456789876543210 :: ErrorMessage - type ($$:@#@$) :: (~>) ErrorMessage ((~>) ErrorMessage ErrorMessage) - data ($$:@#@$) a0123456789876543210 - where - (:$$:@#@$###) :: SameKind (Apply ($$:@#@$) arg) (($$:@#@$$) arg) => - ($$:@#@$) a0123456789876543210 - type instance Apply ($$:@#@$) a0123456789876543210 = ($$:@#@$$) a0123456789876543210 - instance SuppressUnusedWarnings ($$:@#@$) where - suppressUnusedWarnings = snd (((,) (:$$:@#@$###)) ()) - type ($$:@#@$$) :: ErrorMessage -> (~>) ErrorMessage ErrorMessage - data ($$:@#@$$) a0123456789876543210 a0123456789876543210 - where - (:$$:@#@$$###) :: SameKind (Apply (($$:@#@$$) a0123456789876543210) arg) (($$:@#@$$$) a0123456789876543210 arg) => - ($$:@#@$$) a0123456789876543210 a0123456789876543210 - type instance Apply (($$:@#@$$) a0123456789876543210) a0123456789876543210 = ($$:@#@$$$) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (($$:@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (:$$:@#@$$###)) ()) - type ($$:@#@$$$) (a0123456789876543210 :: ErrorMessage) (a0123456789876543210 :: ErrorMessage) = - ($$:) a0123456789876543210 a0123456789876543210 :: ErrorMessage - type (<>:) :: ErrorMessage -> ErrorMessage -> ErrorMessage - type family (<>:) a a where - (<>:) x y = Apply (Apply (:<>:@#@$) x) y - type ($$:) :: ErrorMessage -> ErrorMessage -> ErrorMessage - type family ($$:) a a 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) -> (Sing n) -> SErrorMessage ((:$$:) n n :: ErrorMessage) - (:%<>:) :: forall (n :: ErrorMessage) (n :: ErrorMessage). - (Sing n) -> (Sing n) -> SErrorMessage ((:<>:) n n :: ErrorMessage) - SEM :: forall (n :: [Bool]). - (Sing n) -> SErrorMessage (EM n :: ErrorMessage) - 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/T204.golden b/tests/compile-and-dump/Singletons/T204.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T204.golden +++ /dev/null @@ -1,90 +0,0 @@ -Singletons/T204.hs:(0,0)-(0,0): Splicing declarations - let - sing_data_con_name :: Name -> Name - sing_data_con_name n - = case nameBase n of - ':' : '%' : rest -> mkName $ ":^%" ++ rest - _ -> singledDataConName defaultOptions n - in - withOptions - defaultOptions {singledDataConName = sing_data_con_name} - $ singletons - $ lift - [d| data Ratio1 a = a :% a - data Ratio2 a = a :%% a |] - ======> - data Ratio1 a = a :% a - data Ratio2 a = a :%% a - type (:%@#@$) :: forall a. (~>) a ((~>) a (Ratio1 a)) - data (:%@#@$) a0123456789876543210 - where - (::%@#@$###) :: SameKind (Apply (:%@#@$) arg) ((:%@#@$$) arg) => - (:%@#@$) a0123456789876543210 - type instance Apply (:%@#@$) a0123456789876543210 = (:%@#@$$) a0123456789876543210 - instance SuppressUnusedWarnings (:%@#@$) where - suppressUnusedWarnings = snd (((,) (::%@#@$###)) ()) - type (:%@#@$$) :: forall a. a -> (~>) a (Ratio1 a) - data (:%@#@$$) a0123456789876543210 a0123456789876543210 - where - (::%@#@$$###) :: SameKind (Apply ((:%@#@$$) a0123456789876543210) arg) ((:%@#@$$$) a0123456789876543210 arg) => - (:%@#@$$) a0123456789876543210 a0123456789876543210 - type instance Apply ((:%@#@$$) a0123456789876543210) a0123456789876543210 = (:%@#@$$$) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((:%@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (::%@#@$$###)) ()) - type (:%@#@$$$) (a0123456789876543210 :: a) (a0123456789876543210 :: a) = - (:%) a0123456789876543210 a0123456789876543210 :: Ratio1 a - type (:%%@#@$) :: forall a. (~>) a ((~>) a (Ratio2 a)) - data (:%%@#@$) a0123456789876543210 - where - (::%%@#@$###) :: SameKind (Apply (:%%@#@$) arg) ((:%%@#@$$) arg) => - (:%%@#@$) a0123456789876543210 - type instance Apply (:%%@#@$) a0123456789876543210 = (:%%@#@$$) a0123456789876543210 - instance SuppressUnusedWarnings (:%%@#@$) where - suppressUnusedWarnings = snd (((,) (::%%@#@$###)) ()) - type (:%%@#@$$) :: forall a. a -> (~>) a (Ratio2 a) - data (:%%@#@$$) a0123456789876543210 a0123456789876543210 - where - (::%%@#@$$###) :: SameKind (Apply ((:%%@#@$$) a0123456789876543210) arg) ((:%%@#@$$$) a0123456789876543210 arg) => - (:%%@#@$$) a0123456789876543210 a0123456789876543210 - type instance Apply ((:%%@#@$$) a0123456789876543210) a0123456789876543210 = (:%%@#@$$$) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((:%%@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (::%%@#@$$###)) ()) - type (:%%@#@$$$) (a0123456789876543210 :: a) (a0123456789876543210 :: a) = - (:%%) a0123456789876543210 a0123456789876543210 :: Ratio2 a - data SRatio1 :: forall a. Ratio1 a -> GHC.Types.Type - where - (:^%) :: forall a (n :: a) (n :: a). - (Sing n) -> (Sing n) -> SRatio1 ((:%) n n :: Ratio1 a) - type instance Sing @(Ratio1 a) = SRatio1 - instance SingKind a => SingKind (Ratio1 a) where - type Demote (Ratio1 a) = Ratio1 (Demote a) - fromSing ((:^%) b b) = ((:%) (fromSing b)) (fromSing b) - 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 SRatio2 :: forall a. Ratio2 a -> GHC.Types.Type - where - (:^%%) :: forall a (n :: a) (n :: a). - (Sing n) -> (Sing n) -> SRatio2 ((:%%) n n :: Ratio2 a) - type instance Sing @(Ratio2 a) = SRatio2 - instance SingKind a => SingKind (Ratio2 a) where - type Demote (Ratio2 a) = Ratio2 (Demote a) - fromSing ((:^%%) b b) = ((:%%) (fromSing b)) (fromSing b) - toSing ((:%%) (b :: Demote a) (b :: Demote a)) - = case ((,) (toSing b :: SomeSing a)) (toSing b :: SomeSing a) of { - (,) (SomeSing c) (SomeSing c) -> SomeSing (((:^%%) c) c) } - instance (SingI n, SingI n) => SingI ((:%) (n :: a) (n :: a)) where - sing = ((:^%) sing) sing - instance SingI ((:%@#@$) :: (~>) a ((~>) a (Ratio1 a))) where - sing = (singFun2 @(:%@#@$)) (:^%) - instance SingI d => - SingI ((:%@#@$$) (d :: a) :: (~>) a (Ratio1 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 (Ratio2 a))) where - sing = (singFun2 @(:%%@#@$)) (:^%%) - instance SingI d => - SingI ((:%%@#@$$) (d :: a) :: (~>) a (Ratio2 a)) where - sing = (singFun1 @((:%%@#@$$) (d :: a))) ((:^%%) (sing @d)) diff --git a/tests/compile-and-dump/Singletons/T204.hs b/tests/compile-and-dump/Singletons/T204.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T204.hs +++ /dev/null @@ -1,17 +0,0 @@ -module T204 where - -import Control.Monad.Trans.Class -import Data.Singletons.TH -import Data.Singletons.TH.Options -import Language.Haskell.TH - -$(let sing_data_con_name :: Name -> Name - sing_data_con_name n = - case nameBase n of - ':':'%':rest -> mkName $ ":^%" ++ rest - _ -> singledDataConName defaultOptions n in - withOptions defaultOptions{singledDataConName = sing_data_con_name} $ - singletons $ lift - [d| data Ratio1 a = a :% a - data Ratio2 a = a :%% a - |]) diff --git a/tests/compile-and-dump/Singletons/T206.golden b/tests/compile-and-dump/Singletons/T206.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T206.golden +++ /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.golden b/tests/compile-and-dump/Singletons/T209.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T209.golden +++ /dev/null @@ -1,78 +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 :: Hm - type MSym0 :: (~>) a ((~>) b ((~>) Bool Bool)) - data MSym0 a0123456789876543210 - where - MSym0KindInference :: SameKind (Apply MSym0 arg) (MSym1 arg) => - MSym0 a0123456789876543210 - type instance Apply MSym0 a0123456789876543210 = MSym1 a0123456789876543210 - instance SuppressUnusedWarnings MSym0 where - suppressUnusedWarnings = snd (((,) MSym0KindInference) ()) - type MSym1 :: a -> (~>) b ((~>) Bool Bool) - data MSym1 a0123456789876543210 a0123456789876543210 - where - MSym1KindInference :: SameKind (Apply (MSym1 a0123456789876543210) arg) (MSym2 a0123456789876543210 arg) => - MSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (MSym1 a0123456789876543210) a0123456789876543210 = MSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (MSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) MSym1KindInference) ()) - type MSym2 :: a -> b -> (~>) Bool Bool - data MSym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - MSym2KindInference :: SameKind (Apply (MSym2 a0123456789876543210 a0123456789876543210) arg) (MSym3 a0123456789876543210 a0123456789876543210 arg) => - MSym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (MSym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = MSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (MSym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) MSym2KindInference) ()) - type MSym3 (a0123456789876543210 :: a) (a0123456789876543210 :: b) (a0123456789876543210 :: Bool) = - M a0123456789876543210 a0123456789876543210 a0123456789876543210 :: Bool - type M :: a -> b -> Bool -> Bool - type family M a a a where - M _ _ x = x - class PC a b - 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 :: 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.golden b/tests/compile-and-dump/Singletons/T216.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T216.golden +++ /dev/null @@ -1,42 +0,0 @@ -Singletons/T216.hs:0:0:: Splicing declarations - genDefunSymbols [''MyProxy, ''Symmetry] - ======> - data MyProxySym0 :: (~>) Type ((~>) k0123456789876543210 Type) - where - MyProxySym0KindInference :: SameKind (Apply MyProxySym0 arg) (MyProxySym1 arg) => - MyProxySym0 k0123456789876543210 - type instance Apply MyProxySym0 k0123456789876543210 = MyProxySym1 k0123456789876543210 - instance SuppressUnusedWarnings MyProxySym0 where - suppressUnusedWarnings = snd (((,) MyProxySym0KindInference) ()) - data MyProxySym1 (k0123456789876543210 :: Type) :: (~>) k0123456789876543210 Type - where - MyProxySym1KindInference :: SameKind (Apply (MyProxySym1 k0123456789876543210) arg) (MyProxySym2 k0123456789876543210 arg) => - MyProxySym1 k0123456789876543210 e - type instance Apply (MyProxySym1 k0123456789876543210) e = MyProxySym2 k0123456789876543210 e - instance SuppressUnusedWarnings (MyProxySym1 k0123456789876543210) where - suppressUnusedWarnings = snd (((,) MyProxySym1KindInference) ()) - type MyProxySym2 (k0123456789876543210 :: Type) (e :: k0123456789876543210) = - MyProxy k0123456789876543210 e :: Type - data SymmetrySym0 :: (~>) t0123456789876543210 ((~>) t0123456789876543210 ((~>) ((:~:) a0123456789876543210 y0123456789876543210) Type)) - where - SymmetrySym0KindInference :: SameKind (Apply SymmetrySym0 arg) (SymmetrySym1 arg) => - SymmetrySym0 a0123456789876543210 - type instance Apply SymmetrySym0 a0123456789876543210 = SymmetrySym1 a0123456789876543210 - instance SuppressUnusedWarnings SymmetrySym0 where - suppressUnusedWarnings = snd (((,) SymmetrySym0KindInference) ()) - data SymmetrySym1 (a0123456789876543210 :: t0123456789876543210) :: (~>) t0123456789876543210 ((~>) ((:~:) a0123456789876543210 y0123456789876543210) Type) - where - SymmetrySym1KindInference :: SameKind (Apply (SymmetrySym1 a0123456789876543210) arg) (SymmetrySym2 a0123456789876543210 arg) => - SymmetrySym1 a0123456789876543210 y0123456789876543210 - type instance Apply (SymmetrySym1 a0123456789876543210) y0123456789876543210 = SymmetrySym2 a0123456789876543210 y0123456789876543210 - instance SuppressUnusedWarnings (SymmetrySym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) SymmetrySym1KindInference) ()) - data SymmetrySym2 (a0123456789876543210 :: t0123456789876543210) (y0123456789876543210 :: t0123456789876543210) :: (~>) ((:~:) a0123456789876543210 y0123456789876543210) Type - where - SymmetrySym2KindInference :: SameKind (Apply (SymmetrySym2 a0123456789876543210 y0123456789876543210) arg) (SymmetrySym3 a0123456789876543210 y0123456789876543210 arg) => - SymmetrySym2 a0123456789876543210 y0123456789876543210 e - type instance Apply (SymmetrySym2 a0123456789876543210 y0123456789876543210) e = SymmetrySym3 a0123456789876543210 y0123456789876543210 e - instance SuppressUnusedWarnings (SymmetrySym2 a0123456789876543210 y0123456789876543210) where - suppressUnusedWarnings = snd (((,) SymmetrySym2KindInference) ()) - type SymmetrySym3 (a0123456789876543210 :: t0123456789876543210) (y0123456789876543210 :: t0123456789876543210) (e :: (:~:) a0123456789876543210 y0123456789876543210) = - Symmetry a0123456789876543210 y0123456789876543210 e :: Type 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.golden b/tests/compile-and-dump/Singletons/T226.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T226.golden +++ /dev/null @@ -1,6 +0,0 @@ -Singletons/T226.hs:0:0:: Splicing declarations - singletons [d| class a ~> b |] - ======> - class (~>) a b - class (#~>) a b - 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.golden b/tests/compile-and-dump/Singletons/T229.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T229.golden +++ /dev/null @@ -1,25 +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___fooSym0 :: (~>) Bool Bool - data US___fooSym0 a0123456789876543210 - where - US___fooSym0KindInference :: SameKind (Apply US___fooSym0 arg) (US___fooSym1 arg) => - US___fooSym0 a0123456789876543210 - type instance Apply US___fooSym0 a0123456789876543210 = US___fooSym1 a0123456789876543210 - instance SuppressUnusedWarnings US___fooSym0 where - suppressUnusedWarnings = snd (((,) US___fooSym0KindInference) ()) - type US___fooSym1 (a0123456789876543210 :: Bool) = - US___foo a0123456789876543210 :: Bool - type US___foo :: Bool -> Bool - type family US___foo a 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.golden b/tests/compile-and-dump/Singletons/T249.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T249.golden +++ /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 MkFoo1Sym0 :: forall a. (~>) a (Foo1 a) - data MkFoo1Sym0 a0123456789876543210 - where - MkFoo1Sym0KindInference :: SameKind (Apply MkFoo1Sym0 arg) (MkFoo1Sym1 arg) => - MkFoo1Sym0 a0123456789876543210 - type instance Apply MkFoo1Sym0 a0123456789876543210 = MkFoo1Sym1 a0123456789876543210 - instance SuppressUnusedWarnings MkFoo1Sym0 where - suppressUnusedWarnings = snd (((,) MkFoo1Sym0KindInference) ()) - type MkFoo1Sym1 (a0123456789876543210 :: a) = - MkFoo1 a0123456789876543210 :: Foo1 a - type MkFoo2Sym0 :: (~>) x (Foo2 x) - data MkFoo2Sym0 a0123456789876543210 - where - MkFoo2Sym0KindInference :: SameKind (Apply MkFoo2Sym0 arg) (MkFoo2Sym1 arg) => - MkFoo2Sym0 a0123456789876543210 - type instance Apply MkFoo2Sym0 a0123456789876543210 = MkFoo2Sym1 a0123456789876543210 - instance SuppressUnusedWarnings MkFoo2Sym0 where - suppressUnusedWarnings = snd (((,) MkFoo2Sym0KindInference) ()) - type MkFoo2Sym1 (a0123456789876543210 :: x) = - MkFoo2 a0123456789876543210 :: Foo2 x - type MkFoo3Sym0 :: forall x. (~>) x (Foo3 x) - data MkFoo3Sym0 a0123456789876543210 - where - MkFoo3Sym0KindInference :: SameKind (Apply MkFoo3Sym0 arg) (MkFoo3Sym1 arg) => - MkFoo3Sym0 a0123456789876543210 - type instance Apply MkFoo3Sym0 a0123456789876543210 = MkFoo3Sym1 a0123456789876543210 - instance SuppressUnusedWarnings MkFoo3Sym0 where - suppressUnusedWarnings = snd (((,) MkFoo3Sym0KindInference) ()) - type MkFoo3Sym1 (a0123456789876543210 :: x) = - MkFoo3 a0123456789876543210 :: Foo3 x - data SFoo1 :: forall a. Foo1 a -> Type - where - SMkFoo1 :: forall a (n :: a). - (Sing n) -> SFoo1 (MkFoo1 n :: Foo1 a) - 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) -> SFoo2 (MkFoo2 n :: Foo2 x) - 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) -> SFoo3 (MkFoo3 n :: Foo3 x) - 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.golden b/tests/compile-and-dump/Singletons/T271.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T271.golden +++ /dev/null @@ -1,219 +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 ConstantSym0 :: forall (a :: Type) (b :: Type). - (~>) a (Constant (a :: Type) (b :: Type)) - data ConstantSym0 a0123456789876543210 - where - ConstantSym0KindInference :: SameKind (Apply ConstantSym0 arg) (ConstantSym1 arg) => - ConstantSym0 a0123456789876543210 - type instance Apply ConstantSym0 a0123456789876543210 = ConstantSym1 a0123456789876543210 - instance SuppressUnusedWarnings ConstantSym0 where - suppressUnusedWarnings = snd (((,) ConstantSym0KindInference) ()) - type ConstantSym1 (a0123456789876543210 :: a) = - Constant a0123456789876543210 :: Constant (a :: Type) (b :: Type) - type IdentitySym0 :: (~>) a (Identity a) - data IdentitySym0 a0123456789876543210 - where - IdentitySym0KindInference :: SameKind (Apply IdentitySym0 arg) (IdentitySym1 arg) => - IdentitySym0 a0123456789876543210 - type instance Apply IdentitySym0 a0123456789876543210 = IdentitySym1 a0123456789876543210 - instance SuppressUnusedWarnings IdentitySym0 where - suppressUnusedWarnings = snd (((,) IdentitySym0KindInference) ()) - type IdentitySym1 (a0123456789876543210 :: a) = - Identity a0123456789876543210 :: Identity a - type Compare_0123456789876543210 :: Constant a b - -> Constant a b -> Ordering - type family Compare_0123456789876543210 a a where - Compare_0123456789876543210 (Constant a_0123456789876543210) (Constant b_0123456789876543210) = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) NilSym0) - type Compare_0123456789876543210Sym0 :: (~>) (Constant a b) ((~>) (Constant a b) Ordering) - data Compare_0123456789876543210Sym0 a0123456789876543210 - where - Compare_0123456789876543210Sym0KindInference :: SameKind (Apply Compare_0123456789876543210Sym0 arg) (Compare_0123456789876543210Sym1 arg) => - Compare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Compare_0123456789876543210Sym0 a0123456789876543210 = Compare_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Compare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym0KindInference) ()) - type Compare_0123456789876543210Sym1 :: Constant a b - -> (~>) (Constant a b) Ordering - data Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - Compare_0123456789876543210Sym1KindInference :: SameKind (Apply (Compare_0123456789876543210Sym1 a0123456789876543210) arg) (Compare_0123456789876543210Sym2 a0123456789876543210 arg) => - Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Compare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Compare_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Compare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym1KindInference) ()) - type Compare_0123456789876543210Sym2 (a0123456789876543210 :: Constant a b) (a0123456789876543210 :: Constant a b) = - Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 :: Ordering - instance POrd (Constant a b) where - type Compare a a = Apply (Apply Compare_0123456789876543210Sym0 a) a - type Compare_0123456789876543210 :: Identity a - -> Identity a -> Ordering - type family Compare_0123456789876543210 a a where - Compare_0123456789876543210 (Identity a_0123456789876543210) (Identity b_0123456789876543210) = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) (Apply (Apply (:@#@$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) NilSym0) - type Compare_0123456789876543210Sym0 :: (~>) (Identity a) ((~>) (Identity a) Ordering) - data Compare_0123456789876543210Sym0 a0123456789876543210 - where - Compare_0123456789876543210Sym0KindInference :: SameKind (Apply Compare_0123456789876543210Sym0 arg) (Compare_0123456789876543210Sym1 arg) => - Compare_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Compare_0123456789876543210Sym0 a0123456789876543210 = Compare_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Compare_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym0KindInference) ()) - type Compare_0123456789876543210Sym1 :: Identity a - -> (~>) (Identity a) Ordering - data Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - Compare_0123456789876543210Sym1KindInference :: SameKind (Apply (Compare_0123456789876543210Sym1 a0123456789876543210) arg) (Compare_0123456789876543210Sym2 a0123456789876543210 arg) => - Compare_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Compare_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Compare_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Compare_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Compare_0123456789876543210Sym1KindInference) ()) - type Compare_0123456789876543210Sym2 (a0123456789876543210 :: Identity a) (a0123456789876543210 :: Identity a) = - Compare_0123456789876543210 a0123456789876543210 a0123456789876543210 :: Ordering - instance POrd (Identity a) where - type Compare a a = Apply (Apply Compare_0123456789876543210Sym0 a) a - type Equals_0123456789876543210 :: Constant a b - -> Constant a b -> Bool - type family Equals_0123456789876543210 a b 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 Equals_0123456789876543210 :: Identity a -> Identity a -> Bool - type family Equals_0123456789876543210 a b 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 :: Type) (b :: Type) -> Type - where - SConstant :: forall (a :: Type) (b :: Type) (n :: a). - (Sing n) - -> SConstant (Constant n :: Constant (a :: Type) (b :: Type)) - 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) -> Type - where - SIdentity :: forall a (n :: a). - (Sing n) -> SIdentity (Identity n :: Identity a) - 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.golden b/tests/compile-and-dump/Singletons/T287.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T287.golden +++ /dev/null @@ -1,108 +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 (<<>>@#@$) :: forall a. (~>) a ((~>) a a) - data (<<>>@#@$) a0123456789876543210 - where - (:<<>>@#@$###) :: SameKind (Apply (<<>>@#@$) arg) ((<<>>@#@$$) arg) => - (<<>>@#@$) a0123456789876543210 - type instance Apply (<<>>@#@$) a0123456789876543210 = (<<>>@#@$$) a0123456789876543210 - instance SuppressUnusedWarnings (<<>>@#@$) where - suppressUnusedWarnings = snd (((,) (:<<>>@#@$###)) ()) - type (<<>>@#@$$) :: forall a. a -> (~>) a a - data (<<>>@#@$$) a0123456789876543210 a0123456789876543210 - where - (:<<>>@#@$$###) :: SameKind (Apply ((<<>>@#@$$) a0123456789876543210) arg) ((<<>>@#@$$$) a0123456789876543210 arg) => - (<<>>@#@$$) a0123456789876543210 a0123456789876543210 - type instance Apply ((<<>>@#@$$) a0123456789876543210) a0123456789876543210 = (<<>>@#@$$$) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((<<>>@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (:<<>>@#@$$###)) ()) - type (<<>>@#@$$$) (a0123456789876543210 :: a) (a0123456789876543210 :: a) = - (<<>>) a0123456789876543210 a0123456789876543210 :: a - class PS a where - type (<<>>) (arg :: a) (arg :: a) :: a - type family Lambda_0123456789876543210 f g x where - Lambda_0123456789876543210 f g x = Apply (Apply (<<>>@#@$) (Apply f x)) (Apply g x) - data Lambda_0123456789876543210Sym0 f0123456789876543210 - where - Lambda_0123456789876543210Sym0KindInference :: SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0 f0123456789876543210 - type instance Apply Lambda_0123456789876543210Sym0 f0123456789876543210 = Lambda_0123456789876543210Sym1 f0123456789876543210 - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym0KindInference) ()) - data Lambda_0123456789876543210Sym1 f0123456789876543210 g0123456789876543210 - where - Lambda_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 f0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym1KindInference) ()) - data Lambda_0123456789876543210Sym2 f0123456789876543210 g0123456789876543210 x0123456789876543210 - where - Lambda_0123456789876543210Sym2KindInference :: SameKind (Apply (Lambda_0123456789876543210Sym2 f0123456789876543210 g0123456789876543210) arg) (Lambda_0123456789876543210Sym3 f0123456789876543210 g0123456789876543210 arg) => - Lambda_0123456789876543210Sym2 f0123456789876543210 g0123456789876543210 x0123456789876543210 - type instance Apply (Lambda_0123456789876543210Sym2 f0123456789876543210 g0123456789876543210) x0123456789876543210 = Lambda_0123456789876543210Sym3 f0123456789876543210 g0123456789876543210 x0123456789876543210 - instance SuppressUnusedWarnings (Lambda_0123456789876543210Sym2 f0123456789876543210 g0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Lambda_0123456789876543210Sym2KindInference) ()) - type Lambda_0123456789876543210Sym3 f0123456789876543210 g0123456789876543210 x0123456789876543210 = - Lambda_0123456789876543210 f0123456789876543210 g0123456789876543210 x0123456789876543210 - type TFHelper_0123456789876543210 :: (~>) a b - -> (~>) a b -> (~>) a b - type family TFHelper_0123456789876543210 a a where - TFHelper_0123456789876543210 f g = Apply (Apply Lambda_0123456789876543210Sym0 f) g - type TFHelper_0123456789876543210Sym0 :: (~>) ((~>) a b) ((~>) ((~>) a b) ((~>) a b)) - data TFHelper_0123456789876543210Sym0 a0123456789876543210 - where - TFHelper_0123456789876543210Sym0KindInference :: SameKind (Apply TFHelper_0123456789876543210Sym0 arg) (TFHelper_0123456789876543210Sym1 arg) => - TFHelper_0123456789876543210Sym0 a0123456789876543210 - type instance Apply TFHelper_0123456789876543210Sym0 a0123456789876543210 = TFHelper_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings TFHelper_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) TFHelper_0123456789876543210Sym0KindInference) ()) - type TFHelper_0123456789876543210Sym1 :: (~>) a b - -> (~>) ((~>) a b) ((~>) a b) - data TFHelper_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - TFHelper_0123456789876543210Sym1KindInference :: SameKind (Apply (TFHelper_0123456789876543210Sym1 a0123456789876543210) arg) (TFHelper_0123456789876543210Sym2 a0123456789876543210 arg) => - TFHelper_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (TFHelper_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = TFHelper_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (TFHelper_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) TFHelper_0123456789876543210Sym1KindInference) ()) - type TFHelper_0123456789876543210Sym2 (a0123456789876543210 :: (~>) a b) (a0123456789876543210 :: (~>) a b) = - TFHelper_0123456789876543210 a0123456789876543210 a0123456789876543210 :: (~>) a b - 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.golden b/tests/compile-and-dump/Singletons/T29.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T29.golden +++ /dev/null @@ -1,119 +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 BanSym0 :: (~>) Bool Bool - data BanSym0 a0123456789876543210 - where - BanSym0KindInference :: SameKind (Apply BanSym0 arg) (BanSym1 arg) => - BanSym0 a0123456789876543210 - type instance Apply BanSym0 a0123456789876543210 = BanSym1 a0123456789876543210 - instance SuppressUnusedWarnings BanSym0 where - suppressUnusedWarnings = snd (((,) BanSym0KindInference) ()) - type BanSym1 (a0123456789876543210 :: Bool) = - Ban a0123456789876543210 :: Bool - type BazSym0 :: (~>) Bool Bool - data BazSym0 a0123456789876543210 - where - BazSym0KindInference :: SameKind (Apply BazSym0 arg) (BazSym1 arg) => - BazSym0 a0123456789876543210 - type instance Apply BazSym0 a0123456789876543210 = BazSym1 a0123456789876543210 - instance SuppressUnusedWarnings BazSym0 where - suppressUnusedWarnings = snd (((,) BazSym0KindInference) ()) - type BazSym1 (a0123456789876543210 :: Bool) = - Baz a0123456789876543210 :: Bool - type BarSym0 :: (~>) Bool Bool - data BarSym0 a0123456789876543210 - where - BarSym0KindInference :: SameKind (Apply BarSym0 arg) (BarSym1 arg) => - BarSym0 a0123456789876543210 - type instance Apply BarSym0 a0123456789876543210 = BarSym1 a0123456789876543210 - instance SuppressUnusedWarnings BarSym0 where - suppressUnusedWarnings = snd (((,) BarSym0KindInference) ()) - type BarSym1 (a0123456789876543210 :: Bool) = - Bar a0123456789876543210 :: Bool - type FooSym0 :: (~>) Bool Bool - data FooSym0 a0123456789876543210 - where - FooSym0KindInference :: SameKind (Apply FooSym0 arg) (FooSym1 arg) => - FooSym0 a0123456789876543210 - type instance Apply FooSym0 a0123456789876543210 = FooSym1 a0123456789876543210 - instance SuppressUnusedWarnings FooSym0 where - suppressUnusedWarnings = snd (((,) FooSym0KindInference) ()) - type FooSym1 (a0123456789876543210 :: Bool) = - Foo a0123456789876543210 :: Bool - type Ban :: Bool -> Bool - type family Ban a where - Ban x = Apply (Apply ($!@#@$) (Apply (Apply (.@#@$) NotSym0) (Apply (Apply (.@#@$) NotSym0) NotSym0))) x - type Baz :: Bool -> Bool - type family Baz a where - Baz x = Apply (Apply ($!@#@$) NotSym0) x - type Bar :: Bool -> Bool - type family Bar a where - Bar x = Apply (Apply ($@#@$) (Apply (Apply (.@#@$) NotSym0) (Apply (Apply (.@#@$) NotSym0) NotSym0))) x - type Foo :: Bool -> Bool - type family Foo a 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/T296.golden b/tests/compile-and-dump/Singletons/T296.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T296.golden +++ /dev/null @@ -1,69 +0,0 @@ -Singletons/T296.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| f :: forall a. MyProxy a -> MyProxy a - 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 :: forall a. MyProxy a -> MyProxy a - f MyProxy - = let - x = let - z :: MyProxy a - z = MyProxy - in z - in x - type MyProxySym0 = MyProxy :: MyProxy (a :: Type) - type Let0123456789876543210ZSym0 = - Let0123456789876543210Z :: MyProxy a - type Let0123456789876543210Z :: MyProxy a - type family Let0123456789876543210Z where - Let0123456789876543210Z = MyProxySym0 - type Let0123456789876543210XSym0 = Let0123456789876543210X - type family Let0123456789876543210X where - Let0123456789876543210X = Let0123456789876543210ZSym0 - type FSym0 :: forall a. (~>) (MyProxy a) (MyProxy a) - data FSym0 a0123456789876543210 - where - FSym0KindInference :: SameKind (Apply FSym0 arg) (FSym1 arg) => - FSym0 a0123456789876543210 - type instance Apply FSym0 a0123456789876543210 = FSym1 a0123456789876543210 - instance SuppressUnusedWarnings FSym0 where - suppressUnusedWarnings = snd (((,) FSym0KindInference) ()) - type FSym1 (a0123456789876543210 :: MyProxy a) = - F a0123456789876543210 :: MyProxy a - type F :: forall a. MyProxy a -> MyProxy a - type family F a where - F MyProxy = Let0123456789876543210XSym0 - sF :: - forall a (t :: MyProxy a). - Sing t -> Sing (Apply FSym0 t :: MyProxy a) - sF SMyProxy - = let - sX :: Sing @_ Let0123456789876543210XSym0 - sX - = let - sZ :: Sing (Let0123456789876543210ZSym0 :: MyProxy a) - sZ = SMyProxy - in sZ - in sX - instance SingI (FSym0 :: (~>) (MyProxy a) (MyProxy a)) where - sing = (singFun1 @FSym0) sF - data SMyProxy :: forall a. MyProxy (a :: Type) -> Type - where - SMyProxy :: forall (a :: Type). - SMyProxy (MyProxy :: MyProxy (a :: Type)) - 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/T296.hs b/tests/compile-and-dump/Singletons/T296.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T296.hs +++ /dev/null @@ -1,14 +0,0 @@ -module T296 where - -import Data.Kind -import Data.Singletons.TH - -$(singletons [d| - data MyProxy (a :: Type) = MyProxy - - f :: forall a. MyProxy a -> MyProxy a - f MyProxy = - let x = let z :: MyProxy a - z = MyProxy in z - in x - |]) diff --git a/tests/compile-and-dump/Singletons/T297.golden b/tests/compile-and-dump/Singletons/T297.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T297.golden +++ /dev/null @@ -1,62 +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 :: MyProxy (a :: Type) - type Let0123456789876543210ZSym0 = - Let0123456789876543210Z :: MyProxy a - type Let0123456789876543210Z :: MyProxy a - type family Let0123456789876543210Z where - Let0123456789876543210Z = MyProxySym0 - type Let0123456789876543210XSym0 = Let0123456789876543210X - type family Let0123456789876543210X where - Let0123456789876543210X = Let0123456789876543210ZSym0 - data FSym0 a0123456789876543210 - where - FSym0KindInference :: SameKind (Apply FSym0 arg) (FSym1 arg) => - FSym0 a0123456789876543210 - type instance Apply FSym0 a0123456789876543210 = FSym1 a0123456789876543210 - instance SuppressUnusedWarnings FSym0 where - suppressUnusedWarnings = snd (((,) FSym0KindInference) ()) - type FSym1 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) -> Type - where - SMyProxy :: forall (a :: Type). - SMyProxy (MyProxy :: MyProxy (a :: Type)) - 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.golden b/tests/compile-and-dump/Singletons/T312.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T312.golden +++ /dev/null @@ -1,190 +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 BarSym0 :: forall a b. (~>) a ((~>) b b) - data BarSym0 a0123456789876543210 - where - BarSym0KindInference :: SameKind (Apply BarSym0 arg) (BarSym1 arg) => - BarSym0 a0123456789876543210 - type instance Apply BarSym0 a0123456789876543210 = BarSym1 a0123456789876543210 - instance SuppressUnusedWarnings BarSym0 where - suppressUnusedWarnings = snd (((,) BarSym0KindInference) ()) - type BarSym1 :: forall a b. a -> (~>) b b - data BarSym1 a0123456789876543210 a0123456789876543210 - where - BarSym1KindInference :: SameKind (Apply (BarSym1 a0123456789876543210) arg) (BarSym2 a0123456789876543210 arg) => - BarSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (BarSym1 a0123456789876543210) a0123456789876543210 = BarSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (BarSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) BarSym1KindInference) ()) - type BarSym2 (a0123456789876543210 :: a) (a0123456789876543210 :: b) = - Bar a0123456789876543210 a0123456789876543210 :: b - type BazSym0 :: forall a b. (~>) a ((~>) b b) - data BazSym0 a0123456789876543210 - where - BazSym0KindInference :: SameKind (Apply BazSym0 arg) (BazSym1 arg) => - BazSym0 a0123456789876543210 - type instance Apply BazSym0 a0123456789876543210 = BazSym1 a0123456789876543210 - instance SuppressUnusedWarnings BazSym0 where - suppressUnusedWarnings = snd (((,) BazSym0KindInference) ()) - type BazSym1 :: forall a b. a -> (~>) b b - data BazSym1 a0123456789876543210 a0123456789876543210 - where - BazSym1KindInference :: SameKind (Apply (BazSym1 a0123456789876543210) arg) (BazSym2 a0123456789876543210 arg) => - BazSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (BazSym1 a0123456789876543210) a0123456789876543210 = BazSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (BazSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) BazSym1KindInference) ()) - type BazSym2 (a0123456789876543210 :: a) (a0123456789876543210 :: b) = - Baz a0123456789876543210 a0123456789876543210 :: b - type Bar_0123456789876543210 :: a -> b -> b - type family Bar_0123456789876543210 a a where - Bar_0123456789876543210 _ x = x - type Bar_0123456789876543210Sym0 :: (~>) a ((~>) b b) - data Bar_0123456789876543210Sym0 a0123456789876543210 - where - Bar_0123456789876543210Sym0KindInference :: SameKind (Apply Bar_0123456789876543210Sym0 arg) (Bar_0123456789876543210Sym1 arg) => - Bar_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Bar_0123456789876543210Sym0 a0123456789876543210 = Bar_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Bar_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Bar_0123456789876543210Sym0KindInference) ()) - type Bar_0123456789876543210Sym1 :: a -> (~>) b b - data Bar_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - Bar_0123456789876543210Sym1KindInference :: SameKind (Apply (Bar_0123456789876543210Sym1 a0123456789876543210) arg) (Bar_0123456789876543210Sym2 a0123456789876543210 arg) => - Bar_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Bar_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Bar_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Bar_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Bar_0123456789876543210Sym1KindInference) ()) - type Bar_0123456789876543210Sym2 (a0123456789876543210 :: a) (a0123456789876543210 :: b) = - Bar_0123456789876543210 a0123456789876543210 a0123456789876543210 :: b - data Let0123456789876543210HSym0 a_01234567898765432100123456789876543210 - where - Let0123456789876543210HSym0KindInference :: SameKind (Apply Let0123456789876543210HSym0 arg) (Let0123456789876543210HSym1 arg) => - Let0123456789876543210HSym0 a_01234567898765432100123456789876543210 - type instance Apply Let0123456789876543210HSym0 a_01234567898765432100123456789876543210 = Let0123456789876543210HSym1 a_01234567898765432100123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210HSym0 where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210HSym0KindInference) ()) - data Let0123456789876543210HSym1 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 - where - Let0123456789876543210HSym1KindInference :: 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 (Let0123456789876543210HSym1 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210HSym1KindInference) ()) - data Let0123456789876543210HSym2 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 :: (~>) c0123456789876543210 ((~>) b0123456789876543210 b0123456789876543210) - where - Let0123456789876543210HSym2KindInference :: 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 (Let0123456789876543210HSym2 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210) where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210HSym2KindInference) ()) - data Let0123456789876543210HSym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 (a0123456789876543210 :: c0123456789876543210) :: (~>) b0123456789876543210 b0123456789876543210 - where - Let0123456789876543210HSym3KindInference :: 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 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a0123456789876543210) a0123456789876543210 = Let0123456789876543210HSym4 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Let0123456789876543210HSym3 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Let0123456789876543210HSym3KindInference) ()) - type Let0123456789876543210HSym4 a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 (a0123456789876543210 :: c0123456789876543210) (a0123456789876543210 :: b0123456789876543210) = - Let0123456789876543210H a_01234567898765432100123456789876543210 a_01234567898765432100123456789876543210 a0123456789876543210 a0123456789876543210 :: b0123456789876543210 - type family Let0123456789876543210H a_0123456789876543210 a_0123456789876543210 (a :: c) (a :: b) :: b where - Let0123456789876543210H a_0123456789876543210 a_0123456789876543210 _ x = x - type Baz_0123456789876543210 :: a -> b -> b - type family Baz_0123456789876543210 a a where - Baz_0123456789876543210 a_0123456789876543210 a_0123456789876543210 = Apply (Apply (Let0123456789876543210HSym2 a_0123456789876543210 a_0123456789876543210) a_0123456789876543210) a_0123456789876543210 - type Baz_0123456789876543210Sym0 :: (~>) a ((~>) b b) - data Baz_0123456789876543210Sym0 a0123456789876543210 - where - Baz_0123456789876543210Sym0KindInference :: SameKind (Apply Baz_0123456789876543210Sym0 arg) (Baz_0123456789876543210Sym1 arg) => - Baz_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Baz_0123456789876543210Sym0 a0123456789876543210 = Baz_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Baz_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Baz_0123456789876543210Sym0KindInference) ()) - type Baz_0123456789876543210Sym1 :: a -> (~>) b b - data Baz_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - Baz_0123456789876543210Sym1KindInference :: SameKind (Apply (Baz_0123456789876543210Sym1 a0123456789876543210) arg) (Baz_0123456789876543210Sym2 a0123456789876543210 arg) => - Baz_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Baz_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Baz_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (Baz_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) Baz_0123456789876543210Sym1KindInference) ()) - type Baz_0123456789876543210Sym2 (a0123456789876543210 :: a) (a0123456789876543210 :: b) = - Baz_0123456789876543210 a0123456789876543210 a0123456789876543210 :: b - class PFoo a 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.golden b/tests/compile-and-dump/Singletons/T313.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T313.golden +++ /dev/null @@ -1,122 +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 - data PFoo1Sym0 a0123456789876543210 - where - PFoo1Sym0KindInference :: SameKind (Apply PFoo1Sym0 arg) (PFoo1Sym1 arg) => - PFoo1Sym0 a0123456789876543210 - type instance Apply PFoo1Sym0 a0123456789876543210 = PFoo1Sym1 a0123456789876543210 - instance SuppressUnusedWarnings PFoo1Sym0 where - suppressUnusedWarnings = snd (((,) PFoo1Sym0KindInference) ()) - type PFoo1Sym1 a0123456789876543210 = PFoo1 a0123456789876543210 - data PFoo3Sym0 a0123456789876543210 - where - PFoo3Sym0KindInference :: SameKind (Apply PFoo3Sym0 arg) (PFoo3Sym1 arg) => - PFoo3Sym0 a0123456789876543210 - type instance Apply PFoo3Sym0 a0123456789876543210 = PFoo3Sym1 a0123456789876543210 - instance SuppressUnusedWarnings PFoo3Sym0 where - suppressUnusedWarnings = snd (((,) PFoo3Sym0KindInference) ()) - type PFoo3Sym1 a0123456789876543210 = PFoo3 a0123456789876543210 - data PFoo2Sym0 :: (~>) Type Type - where - PFoo2Sym0KindInference :: SameKind (Apply PFoo2Sym0 arg) (PFoo2Sym1 arg) => - PFoo2Sym0 a0123456789876543210 - type instance Apply PFoo2Sym0 a0123456789876543210 = PFoo2Sym1 a0123456789876543210 - instance SuppressUnusedWarnings PFoo2Sym0 where - suppressUnusedWarnings = snd (((,) PFoo2Sym0KindInference) ()) - type PFoo2Sym1 (a0123456789876543210 :: Type) = - PFoo2 a0123456789876543210 :: Type - data PFoo4Sym0 a0123456789876543210 - where - PFoo4Sym0KindInference :: SameKind (Apply PFoo4Sym0 arg) (PFoo4Sym1 arg) => - PFoo4Sym0 a0123456789876543210 - type instance Apply PFoo4Sym0 a0123456789876543210 = PFoo4Sym1 a0123456789876543210 - instance SuppressUnusedWarnings PFoo4Sym0 where - suppressUnusedWarnings = snd (((,) PFoo4Sym0KindInference) ()) - type PFoo4Sym1 (a0123456789876543210 :: Type) = - 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 - data SFoo1Sym0 a0123456789876543210 - where - SFoo1Sym0KindInference :: SameKind (Apply SFoo1Sym0 arg) (SFoo1Sym1 arg) => - SFoo1Sym0 a0123456789876543210 - type instance Apply SFoo1Sym0 a0123456789876543210 = SFoo1Sym1 a0123456789876543210 - instance SuppressUnusedWarnings SFoo1Sym0 where - suppressUnusedWarnings = snd (((,) SFoo1Sym0KindInference) ()) - type SFoo1Sym1 a0123456789876543210 = SFoo1 a0123456789876543210 - data SFoo3Sym0 a0123456789876543210 - where - SFoo3Sym0KindInference :: SameKind (Apply SFoo3Sym0 arg) (SFoo3Sym1 arg) => - SFoo3Sym0 a0123456789876543210 - type instance Apply SFoo3Sym0 a0123456789876543210 = SFoo3Sym1 a0123456789876543210 - instance SuppressUnusedWarnings SFoo3Sym0 where - suppressUnusedWarnings = snd (((,) SFoo3Sym0KindInference) ()) - type SFoo3Sym1 a0123456789876543210 = SFoo3 a0123456789876543210 - data SFoo2Sym0 :: (~>) Type Type - where - SFoo2Sym0KindInference :: SameKind (Apply SFoo2Sym0 arg) (SFoo2Sym1 arg) => - SFoo2Sym0 a0123456789876543210 - type instance Apply SFoo2Sym0 a0123456789876543210 = SFoo2Sym1 a0123456789876543210 - instance SuppressUnusedWarnings SFoo2Sym0 where - suppressUnusedWarnings = snd (((,) SFoo2Sym0KindInference) ()) - type SFoo2Sym1 (a0123456789876543210 :: Type) = - SFoo2 a0123456789876543210 :: Type - data SFoo4Sym0 a0123456789876543210 - where - SFoo4Sym0KindInference :: SameKind (Apply SFoo4Sym0 arg) (SFoo4Sym1 arg) => - SFoo4Sym0 a0123456789876543210 - type instance Apply SFoo4Sym0 a0123456789876543210 = SFoo4Sym1 a0123456789876543210 - instance SuppressUnusedWarnings SFoo4Sym0 where - suppressUnusedWarnings = snd (((,) SFoo4Sym0KindInference) ()) - type SFoo4Sym1 (a0123456789876543210 :: Type) = - 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.golden b/tests/compile-and-dump/Singletons/T316.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T316.golden +++ /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 ReplaceAllGTypesSym0 :: (~>) ((~>) a ((~>) Type a)) ((~>) [Type] ((~>) [a] [a])) - data ReplaceAllGTypesSym0 a0123456789876543210 - where - ReplaceAllGTypesSym0KindInference :: SameKind (Apply ReplaceAllGTypesSym0 arg) (ReplaceAllGTypesSym1 arg) => - ReplaceAllGTypesSym0 a0123456789876543210 - type instance Apply ReplaceAllGTypesSym0 a0123456789876543210 = ReplaceAllGTypesSym1 a0123456789876543210 - instance SuppressUnusedWarnings ReplaceAllGTypesSym0 where - suppressUnusedWarnings - = snd (((,) ReplaceAllGTypesSym0KindInference) ()) - type ReplaceAllGTypesSym1 :: (~>) a ((~>) Type a) - -> (~>) [Type] ((~>) [a] [a]) - data ReplaceAllGTypesSym1 a0123456789876543210 a0123456789876543210 - where - ReplaceAllGTypesSym1KindInference :: SameKind (Apply (ReplaceAllGTypesSym1 a0123456789876543210) arg) (ReplaceAllGTypesSym2 a0123456789876543210 arg) => - ReplaceAllGTypesSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (ReplaceAllGTypesSym1 a0123456789876543210) a0123456789876543210 = ReplaceAllGTypesSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ReplaceAllGTypesSym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ReplaceAllGTypesSym1KindInference) ()) - type ReplaceAllGTypesSym2 :: (~>) a ((~>) Type a) - -> [Type] -> (~>) [a] [a] - data ReplaceAllGTypesSym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - ReplaceAllGTypesSym2KindInference :: SameKind (Apply (ReplaceAllGTypesSym2 a0123456789876543210 a0123456789876543210) arg) (ReplaceAllGTypesSym3 a0123456789876543210 a0123456789876543210 arg) => - ReplaceAllGTypesSym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - type instance Apply (ReplaceAllGTypesSym2 a0123456789876543210 a0123456789876543210) a0123456789876543210 = ReplaceAllGTypesSym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ReplaceAllGTypesSym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ReplaceAllGTypesSym2KindInference) ()) - type ReplaceAllGTypesSym3 (a0123456789876543210 :: (~>) a ((~>) Type a)) (a0123456789876543210 :: [Type]) (a0123456789876543210 :: [a]) = - ReplaceAllGTypes a0123456789876543210 a0123456789876543210 a0123456789876543210 :: [a] - type ReplaceAllGTypes :: (~>) a ((~>) Type a) - -> [Type] -> [a] -> [a] - type family ReplaceAllGTypes 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.golden b/tests/compile-and-dump/Singletons/T322.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T322.golden +++ /dev/null @@ -1,49 +0,0 @@ -Singletons/T322.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| infixr 2 ! - - (!) :: Bool -> Bool -> Bool - (!) = (||) |] - ======> - (!) :: Bool -> Bool -> Bool - (!) = (||) - infixr 2 ! - type (!@#@$) :: (~>) Bool ((~>) Bool Bool) - data (!@#@$) a0123456789876543210 - where - (:!@#@$###) :: SameKind (Apply (!@#@$) arg) ((!@#@$$) arg) => - (!@#@$) a0123456789876543210 - type instance Apply (!@#@$) a0123456789876543210 = (!@#@$$) a0123456789876543210 - instance SuppressUnusedWarnings (!@#@$) where - suppressUnusedWarnings = snd (((,) (:!@#@$###)) ()) - infixr 2 !@#@$ - type (!@#@$$) :: Bool -> (~>) Bool Bool - data (!@#@$$) a0123456789876543210 a0123456789876543210 - where - (:!@#@$$###) :: SameKind (Apply ((!@#@$$) a0123456789876543210) arg) ((!@#@$$$) a0123456789876543210 arg) => - (!@#@$$) a0123456789876543210 a0123456789876543210 - type instance Apply ((!@#@$$) a0123456789876543210) a0123456789876543210 = (!@#@$$$) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((!@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (:!@#@$$###)) ()) - infixr 2 !@#@$$ - type (!@#@$$$) (a0123456789876543210 :: Bool) (a0123456789876543210 :: Bool) = - (!) a0123456789876543210 a0123456789876543210 :: Bool - infixr 2 !@#@$$$ - type (!) :: Bool -> Bool -> Bool - type family (!) a a 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.golden b/tests/compile-and-dump/Singletons/T323.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T323.golden +++ /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/T326.golden b/tests/compile-and-dump/Singletons/T326.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T326.golden +++ /dev/null @@ -1,67 +0,0 @@ -Singletons/T326.hs:0:0:: Splicing declarations - genPromotions [''C1] - ======> - type (<%>@#@$) :: forall a. (~>) a ((~>) a a) - data (<%>@#@$) a0123456789876543210 - where - (:<%>@#@$###) :: SameKind (Apply (<%>@#@$) arg) ((<%>@#@$$) arg) => - (<%>@#@$) a0123456789876543210 - type instance Apply (<%>@#@$) a0123456789876543210 = (<%>@#@$$) a0123456789876543210 - instance SuppressUnusedWarnings (<%>@#@$) where - suppressUnusedWarnings = snd (((,) (:<%>@#@$###)) ()) - infixl 9 <%>@#@$ - type (<%>@#@$$) :: forall a. a -> (~>) a a - data (<%>@#@$$) a0123456789876543210 a0123456789876543210 - where - (:<%>@#@$$###) :: SameKind (Apply ((<%>@#@$$) a0123456789876543210) arg) ((<%>@#@$$$) a0123456789876543210 arg) => - (<%>@#@$$) a0123456789876543210 a0123456789876543210 - type instance Apply ((<%>@#@$$) a0123456789876543210) a0123456789876543210 = (<%>@#@$$$) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((<%>@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (:<%>@#@$$###)) ()) - infixl 9 <%>@#@$$ - type (<%>@#@$$$) (a0123456789876543210 :: a) (a0123456789876543210 :: a) = - (<%>) a0123456789876543210 a0123456789876543210 :: a - infixl 9 <%>@#@$$$ - type PC1 :: GHC.Types.Type -> Constraint - class PC1 (a :: GHC.Types.Type) where - type (<%>) (arg :: a) (arg :: a) :: a - infixl 9 <%> -Singletons/T326.hs:0:0:: Splicing declarations - genSingletons [''C2] - ======> - type (<%%>@#@$) :: forall a. (~>) a ((~>) a a) - data (<%%>@#@$) a0123456789876543210 - where - (:<%%>@#@$###) :: SameKind (Apply (<%%>@#@$) arg) ((<%%>@#@$$) arg) => - (<%%>@#@$) a0123456789876543210 - type instance Apply (<%%>@#@$) a0123456789876543210 = (<%%>@#@$$) a0123456789876543210 - instance SuppressUnusedWarnings (<%%>@#@$) where - suppressUnusedWarnings = snd (((,) (:<%%>@#@$###)) ()) - infixl 9 <%%>@#@$ - type (<%%>@#@$$) :: forall a. a -> (~>) a a - data (<%%>@#@$$) a0123456789876543210 a0123456789876543210 - where - (:<%%>@#@$$###) :: SameKind (Apply ((<%%>@#@$$) a0123456789876543210) arg) ((<%%>@#@$$$) a0123456789876543210 arg) => - (<%%>@#@$$) a0123456789876543210 a0123456789876543210 - type instance Apply ((<%%>@#@$$) a0123456789876543210) a0123456789876543210 = (<%%>@#@$$$) a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings ((<%%>@#@$$) a0123456789876543210) where - suppressUnusedWarnings = snd (((,) (:<%%>@#@$$###)) ()) - infixl 9 <%%>@#@$$ - type (<%%>@#@$$$) (a0123456789876543210 :: a) (a0123456789876543210 :: a) = - (<%%>) a0123456789876543210 a0123456789876543210 :: a - infixl 9 <%%>@#@$$$ - type PC2 :: GHC.Types.Type -> Constraint - class PC2 (a :: GHC.Types.Type) where - type (<%%>) (arg :: a) (arg :: a) :: a - infixl 9 <%%> - class SC2 (a :: GHC.Types.Type) where - (%<%%>) :: - forall (t :: a) (t :: a). - Sing t -> Sing t -> Sing (Apply (Apply (<%%>@#@$) t) t :: a) - type SC2 :: GHC.Types.Type -> Constraint - infixl 9 %<%%> - instance SC2 a => SingI ((<%%>@#@$) :: (~>) a ((~>) a a)) where - sing = (singFun2 @(<%%>@#@$)) (%<%%>) - instance (SC2 a, SingI d) => - SingI ((<%%>@#@$$) (d :: a) :: (~>) a a) where - sing = (singFun1 @((<%%>@#@$$) (d :: a))) ((%<%%>) (sing @d)) diff --git a/tests/compile-and-dump/Singletons/T326.hs b/tests/compile-and-dump/Singletons/T326.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T326.hs +++ /dev/null @@ -1,23 +0,0 @@ -module T326 where - -import Data.Singletons.TH -import Data.Type.Equality - -class C1 a where - infixl 9 <%> - (<%>) :: a -> a -> a - -class C2 a where - infixl 9 <%%> - (<%%>) :: a -> a -> a - -$(genPromotions [''C1]) -$(genSingletons [''C2]) - -test1 :: Proxy f -> Proxy g -> Proxy h - -> (f <%> g) <%> h :~: f <%> g <%> h -test1 _ _ _ = Refl - -test2 :: Proxy f -> Proxy g -> Proxy h - -> (f <%%> g) <%%> h :~: f <%%> g <%%> h -test2 _ _ _ = Refl diff --git a/tests/compile-and-dump/Singletons/T33.golden b/tests/compile-and-dump/Singletons/T33.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T33.golden +++ /dev/null @@ -1,37 +0,0 @@ -Singletons/T33.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| foo :: (Bool, Bool) -> () - foo ~(_, _) = () |] - ======> - foo :: (Bool, Bool) -> () - foo ~(_, _) = () - type FooSym0 :: (~>) (Bool, Bool) () - data FooSym0 a0123456789876543210 - where - FooSym0KindInference :: SameKind (Apply FooSym0 arg) (FooSym1 arg) => - FooSym0 a0123456789876543210 - type instance Apply FooSym0 a0123456789876543210 = FooSym1 a0123456789876543210 - instance SuppressUnusedWarnings FooSym0 where - suppressUnusedWarnings = snd (((,) FooSym0KindInference) ()) - type FooSym1 (a0123456789876543210 :: (Bool, Bool)) = - Foo a0123456789876543210 :: () - type Foo :: (Bool, Bool) -> () - type family Foo a 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.golden b/tests/compile-and-dump/Singletons/T332.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T332.golden +++ /dev/null @@ -1,61 +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 MkFooSym0 = MkFoo :: Foo - type FSym0 :: (~>) Foo () - data FSym0 a0123456789876543210 - where - FSym0KindInference :: SameKind (Apply FSym0 arg) (FSym1 arg) => - FSym0 a0123456789876543210 - type instance Apply FSym0 a0123456789876543210 = FSym1 a0123456789876543210 - instance SuppressUnusedWarnings FSym0 where - suppressUnusedWarnings = snd (((,) FSym0KindInference) ()) - type FSym1 (a0123456789876543210 :: Foo) = - F a0123456789876543210 :: () - type F :: Foo -> () - type family F a where - F MkFoo = Tuple0Sym0 -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 :: Bar - type BSym0 :: (~>) Bar () - data BSym0 a0123456789876543210 - where - BSym0KindInference :: SameKind (Apply BSym0 arg) (BSym1 arg) => - BSym0 a0123456789876543210 - type instance Apply BSym0 a0123456789876543210 = BSym1 a0123456789876543210 - instance SuppressUnusedWarnings BSym0 where - suppressUnusedWarnings = snd (((,) BSym0KindInference) ()) - type BSym1 (a0123456789876543210 :: Bar) = - B a0123456789876543210 :: () - type B :: Bar -> () - type family B a 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 :: Bar) - 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.golden b/tests/compile-and-dump/Singletons/T342.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T342.golden +++ /dev/null @@ -1,16 +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 - data MyIdSym0 a0123456789876543210 - where - MyIdSym0KindInference :: SameKind (Apply MyIdSym0 arg) (MyIdSym1 arg) => - MyIdSym0 a0123456789876543210 - type instance Apply MyIdSym0 a0123456789876543210 = MyIdSym1 a0123456789876543210 - instance SuppressUnusedWarnings MyIdSym0 where - suppressUnusedWarnings = snd (((,) MyIdSym0KindInference) ()) - type MyIdSym1 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.golden b/tests/compile-and-dump/Singletons/T353.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T353.golden +++ /dev/null @@ -1,87 +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 - data SymmetrySym0 :: (~>) (Proxy t0123456789876543210) ((~>) (Proxy t0123456789876543210) ((~>) ((:~:) (a0123456789876543210 :: Proxy (t0123456789876543210 :: k0123456789876543210)) (y0123456789876543210 :: Proxy (t0123456789876543210 :: k0123456789876543210))) Type)) - where - SymmetrySym0KindInference :: SameKind (Apply SymmetrySym0 arg) (SymmetrySym1 arg) => - SymmetrySym0 a0123456789876543210 - type instance Apply SymmetrySym0 a0123456789876543210 = SymmetrySym1 a0123456789876543210 - instance SuppressUnusedWarnings SymmetrySym0 where - suppressUnusedWarnings = snd (((,) SymmetrySym0KindInference) ()) - data SymmetrySym1 (a0123456789876543210 :: Proxy t0123456789876543210) :: (~>) (Proxy t0123456789876543210) ((~>) ((:~:) (a0123456789876543210 :: Proxy (t0123456789876543210 :: k0123456789876543210)) (y0123456789876543210 :: Proxy (t0123456789876543210 :: k0123456789876543210))) Type) - where - SymmetrySym1KindInference :: SameKind (Apply (SymmetrySym1 a0123456789876543210) arg) (SymmetrySym2 a0123456789876543210 arg) => - SymmetrySym1 a0123456789876543210 y0123456789876543210 - type instance Apply (SymmetrySym1 a0123456789876543210) y0123456789876543210 = SymmetrySym2 a0123456789876543210 y0123456789876543210 - instance SuppressUnusedWarnings (SymmetrySym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) SymmetrySym1KindInference) ()) - data SymmetrySym2 (a0123456789876543210 :: Proxy t0123456789876543210) (y0123456789876543210 :: Proxy t0123456789876543210) :: (~>) ((:~:) (a0123456789876543210 :: Proxy (t0123456789876543210 :: k0123456789876543210)) (y0123456789876543210 :: Proxy (t0123456789876543210 :: k0123456789876543210))) Type - where - SymmetrySym2KindInference :: SameKind (Apply (SymmetrySym2 a0123456789876543210 y0123456789876543210) arg) (SymmetrySym3 a0123456789876543210 y0123456789876543210 arg) => - SymmetrySym2 a0123456789876543210 y0123456789876543210 e0123456789876543210 - type instance Apply (SymmetrySym2 a0123456789876543210 y0123456789876543210) e0123456789876543210 = SymmetrySym3 a0123456789876543210 y0123456789876543210 e0123456789876543210 - instance SuppressUnusedWarnings (SymmetrySym2 a0123456789876543210 y0123456789876543210) where - suppressUnusedWarnings = snd (((,) SymmetrySym2KindInference) ()) - type SymmetrySym3 (a0123456789876543210 :: Proxy t0123456789876543210) (y0123456789876543210 :: Proxy t0123456789876543210) (e0123456789876543210 :: (:~:) (a0123456789876543210 :: Proxy (t0123456789876543210 :: k0123456789876543210)) (y0123456789876543210 :: Proxy (t0123456789876543210 :: k0123456789876543210))) = - Symmetry a0123456789876543210 y0123456789876543210 e0123456789876543210 :: Type -Singletons/T353.hs:0:0:: Splicing declarations - genDefunSymbols [''Prod] - ======> - type MkProdSym0 :: forall k - (f :: k -> Type) - (g :: k -> Type) - (p :: k). - (~>) (f p) ((~>) (g p) (Prod (f :: k -> Type) (g :: k - -> Type) (p :: k))) - data MkProdSym0 a0123456789876543210 - where - MkProdSym0KindInference :: SameKind (Apply MkProdSym0 arg) (MkProdSym1 arg) => - MkProdSym0 a0123456789876543210 - type instance Apply MkProdSym0 a0123456789876543210 = MkProdSym1 a0123456789876543210 - instance SuppressUnusedWarnings MkProdSym0 where - suppressUnusedWarnings = snd (((,) MkProdSym0KindInference) ()) - type MkProdSym1 :: forall k - (f :: k -> Type) - (g :: k -> Type) - (p :: k). - f p -> (~>) (g p) (Prod (f :: k -> Type) (g :: k -> Type) (p :: k)) - data MkProdSym1 a0123456789876543210 a0123456789876543210 - where - MkProdSym1KindInference :: SameKind (Apply (MkProdSym1 a0123456789876543210) arg) (MkProdSym2 a0123456789876543210 arg) => - MkProdSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (MkProdSym1 a0123456789876543210) a0123456789876543210 = MkProdSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (MkProdSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) MkProdSym1KindInference) ()) - type MkProdSym2 (a0123456789876543210 :: f p) (a0123456789876543210 :: g p) = - 'MkProd a0123456789876543210 a0123456789876543210 :: Prod (f :: k - -> Type) (g :: k - -> Type) (p :: k) -Singletons/T353.hs:0:0:: Splicing declarations - genDefunSymbols [''Foo] - ======> - type MkFooSym0 :: forall k k (a :: k) (b :: k). - (~>) (Proxy a) ((~>) (Proxy b) (Foo (a :: k) (b :: k))) - data MkFooSym0 a0123456789876543210 - where - MkFooSym0KindInference :: SameKind (Apply MkFooSym0 arg) (MkFooSym1 arg) => - MkFooSym0 a0123456789876543210 - type instance Apply MkFooSym0 a0123456789876543210 = MkFooSym1 a0123456789876543210 - instance SuppressUnusedWarnings MkFooSym0 where - suppressUnusedWarnings = snd (((,) MkFooSym0KindInference) ()) - type MkFooSym1 :: forall k k (a :: k) (b :: k). - Proxy a -> (~>) (Proxy b) (Foo (a :: k) (b :: k)) - data MkFooSym1 a0123456789876543210 a0123456789876543210 - where - MkFooSym1KindInference :: SameKind (Apply (MkFooSym1 a0123456789876543210) arg) (MkFooSym2 a0123456789876543210 arg) => - MkFooSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (MkFooSym1 a0123456789876543210) a0123456789876543210 = MkFooSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (MkFooSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) MkFooSym1KindInference) ()) - type MkFooSym2 (a0123456789876543210 :: Proxy a) (a0123456789876543210 :: Proxy b) = - 'MkFoo a0123456789876543210 a0123456789876543210 :: Foo (a :: k) (b :: k) 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.golden b/tests/compile-and-dump/Singletons/T358.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T358.golden +++ /dev/null @@ -1,112 +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 :: f a - class PC1 (f :: k -> Type) where - type Method1 :: f a - type Method2aSym0 :: forall b a. (~>) b a - data Method2aSym0 a0123456789876543210 - where - Method2aSym0KindInference :: SameKind (Apply Method2aSym0 arg) (Method2aSym1 arg) => - Method2aSym0 a0123456789876543210 - type instance Apply Method2aSym0 a0123456789876543210 = Method2aSym1 a0123456789876543210 - instance SuppressUnusedWarnings Method2aSym0 where - suppressUnusedWarnings = snd (((,) Method2aSym0KindInference) ()) - type Method2aSym1 (a0123456789876543210 :: b) = - Method2a a0123456789876543210 :: a - type Method2bSym0 :: forall b a. (~>) b a - data Method2bSym0 a0123456789876543210 - where - Method2bSym0KindInference :: SameKind (Apply Method2bSym0 arg) (Method2bSym1 arg) => - Method2bSym0 a0123456789876543210 - type instance Apply Method2bSym0 a0123456789876543210 = Method2bSym1 a0123456789876543210 - instance SuppressUnusedWarnings Method2bSym0 where - suppressUnusedWarnings = snd (((,) Method2bSym0KindInference) ()) - type Method2bSym1 (a0123456789876543210 :: b) = - Method2b a0123456789876543210 :: a - class PC2 a where - type Method2a (arg :: b) :: a - type Method2b (arg :: b) :: a - type Method1_0123456789876543210 :: [a] - type family Method1_0123456789876543210 where - Method1_0123456789876543210 = NilSym0 - type Method1_0123456789876543210Sym0 = - Method1_0123456789876543210 :: [a] - instance PC1 [] where - type Method1 = Method1_0123456789876543210Sym0 - type Method2a_0123456789876543210 :: b -> [a] - type family Method2a_0123456789876543210 a where - Method2a_0123456789876543210 _ = NilSym0 - type Method2a_0123456789876543210Sym0 :: (~>) b [a] - data Method2a_0123456789876543210Sym0 a0123456789876543210 - where - Method2a_0123456789876543210Sym0KindInference :: SameKind (Apply Method2a_0123456789876543210Sym0 arg) (Method2a_0123456789876543210Sym1 arg) => - Method2a_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Method2a_0123456789876543210Sym0 a0123456789876543210 = Method2a_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Method2a_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Method2a_0123456789876543210Sym0KindInference) ()) - type Method2a_0123456789876543210Sym1 (a0123456789876543210 :: b) = - Method2a_0123456789876543210 a0123456789876543210 :: [a] - type Method2b_0123456789876543210 :: b -> [a] - type family Method2b_0123456789876543210 a where - Method2b_0123456789876543210 _ = NilSym0 - type Method2b_0123456789876543210Sym0 :: (~>) b [a] - data Method2b_0123456789876543210Sym0 a0123456789876543210 - where - Method2b_0123456789876543210Sym0KindInference :: SameKind (Apply Method2b_0123456789876543210Sym0 arg) (Method2b_0123456789876543210Sym1 arg) => - Method2b_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Method2b_0123456789876543210Sym0 a0123456789876543210 = Method2b_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Method2b_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) Method2b_0123456789876543210Sym0KindInference) ()) - type Method2b_0123456789876543210Sym1 (a0123456789876543210 :: b) = - Method2b_0123456789876543210 a0123456789876543210 :: [a] - 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.golden b/tests/compile-and-dump/Singletons/T367.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T367.golden +++ /dev/null @@ -1,36 +0,0 @@ -Singletons/T367.hs:(0,0)-(0,0): Splicing declarations - singletonsOnly - [d| const' :: a -> b -> a - const' x _ = x |] - ======> - type Const'Sym0 :: (~>) a ((~>) b a) - data Const'Sym0 a0123456789876543210 - where - Const'Sym0KindInference :: SameKind (Apply Const'Sym0 arg) (Const'Sym1 arg) => - Const'Sym0 a0123456789876543210 - type instance Apply Const'Sym0 a0123456789876543210 = Const'Sym1 a0123456789876543210 - instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings Const'Sym0 where - Data.Singletons.SuppressUnusedWarnings.suppressUnusedWarnings - = snd (((,) Const'Sym0KindInference) ()) - type Const'Sym1 :: a -> (~>) b a - data Const'Sym1 a0123456789876543210 a0123456789876543210 - where - Const'Sym1KindInference :: SameKind (Apply (Const'Sym1 a0123456789876543210) arg) (Const'Sym2 a0123456789876543210 arg) => - Const'Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Const'Sym1 a0123456789876543210) a0123456789876543210 = Const'Sym2 a0123456789876543210 a0123456789876543210 - instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings (Const'Sym1 a0123456789876543210) where - Data.Singletons.SuppressUnusedWarnings.suppressUnusedWarnings - = snd (((,) Const'Sym1KindInference) ()) - type Const'Sym2 (a0123456789876543210 :: a) (a0123456789876543210 :: b) = - Const' a0123456789876543210 a0123456789876543210 :: a - type Const' :: a -> b -> a - type family Const' a 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.golden b/tests/compile-and-dump/Singletons/T371.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T371.golden +++ /dev/null @@ -1,245 +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 :: X (a :: Type) - type X2Sym0 :: forall (a :: Type). (~>) (Y a) (X (a :: Type)) - data X2Sym0 a0123456789876543210 - where - X2Sym0KindInference :: SameKind (Apply X2Sym0 arg) (X2Sym1 arg) => - X2Sym0 a0123456789876543210 - type instance Apply X2Sym0 a0123456789876543210 = X2Sym1 a0123456789876543210 - instance SuppressUnusedWarnings X2Sym0 where - suppressUnusedWarnings = snd (((,) X2Sym0KindInference) ()) - type X2Sym1 (a0123456789876543210 :: Y a) = - X2 a0123456789876543210 :: X (a :: Type) - type Y1Sym0 = Y1 :: Y (a :: Type) - type Y2Sym0 :: forall (a :: Type). (~>) (X a) (Y (a :: Type)) - data Y2Sym0 a0123456789876543210 - where - Y2Sym0KindInference :: SameKind (Apply Y2Sym0 arg) (Y2Sym1 arg) => - Y2Sym0 a0123456789876543210 - type instance Apply Y2Sym0 a0123456789876543210 = Y2Sym1 a0123456789876543210 - instance SuppressUnusedWarnings Y2Sym0 where - suppressUnusedWarnings = snd (((,) Y2Sym0KindInference) ()) - type Y2Sym1 (a0123456789876543210 :: X a) = - Y2 a0123456789876543210 :: Y (a :: Type) - type ShowsPrec_0123456789876543210 :: GHC.Types.Nat - -> X a -> GHC.Types.Symbol -> GHC.Types.Symbol - type family ShowsPrec_0123456789876543210 a a a 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_0123456789876543210Sym0 :: (~>) GHC.Types.Nat ((~>) (X a) ((~>) GHC.Types.Symbol GHC.Types.Symbol)) - data ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym0KindInference :: SameKind (Apply ShowsPrec_0123456789876543210Sym0 arg) (ShowsPrec_0123456789876543210Sym1 arg) => - ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ShowsPrec_0123456789876543210Sym0 a0123456789876543210 = ShowsPrec_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings ShowsPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym0KindInference) ()) - type ShowsPrec_0123456789876543210Sym1 :: GHC.Types.Nat - -> (~>) (X a) ((~>) GHC.Types.Symbol GHC.Types.Symbol) - data ShowsPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym1KindInference) ()) - type ShowsPrec_0123456789876543210Sym2 :: GHC.Types.Nat - -> X a -> (~>) GHC.Types.Symbol GHC.Types.Symbol - data ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym2KindInference :: 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_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym2KindInference) ()) - type ShowsPrec_0123456789876543210Sym3 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: X a) (a0123456789876543210 :: GHC.Types.Symbol) = - ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 :: GHC.Types.Symbol - instance PShow (X a) where - type ShowsPrec a a a = Apply (Apply (Apply ShowsPrec_0123456789876543210Sym0 a) a) a - type ShowsPrec_0123456789876543210 :: GHC.Types.Nat - -> Y a -> GHC.Types.Symbol -> GHC.Types.Symbol - type family ShowsPrec_0123456789876543210 a a a 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_0123456789876543210Sym0 :: (~>) GHC.Types.Nat ((~>) (Y a) ((~>) GHC.Types.Symbol GHC.Types.Symbol)) - data ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym0KindInference :: SameKind (Apply ShowsPrec_0123456789876543210Sym0 arg) (ShowsPrec_0123456789876543210Sym1 arg) => - ShowsPrec_0123456789876543210Sym0 a0123456789876543210 - type instance Apply ShowsPrec_0123456789876543210Sym0 a0123456789876543210 = ShowsPrec_0123456789876543210Sym1 a0123456789876543210 - instance SuppressUnusedWarnings ShowsPrec_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym0KindInference) ()) - type ShowsPrec_0123456789876543210Sym1 :: GHC.Types.Nat - -> (~>) (Y a) ((~>) GHC.Types.Symbol GHC.Types.Symbol) - data ShowsPrec_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym1KindInference :: 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_0123456789876543210Sym1 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym1KindInference) ()) - type ShowsPrec_0123456789876543210Sym2 :: GHC.Types.Nat - -> Y a -> (~>) GHC.Types.Symbol GHC.Types.Symbol - data ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 a0123456789876543210 - where - ShowsPrec_0123456789876543210Sym2KindInference :: 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_0123456789876543210Sym3 a0123456789876543210 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ShowsPrec_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210) where - suppressUnusedWarnings - = snd (((,) ShowsPrec_0123456789876543210Sym2KindInference) ()) - type ShowsPrec_0123456789876543210Sym3 (a0123456789876543210 :: GHC.Types.Nat) (a0123456789876543210 :: Y a) (a0123456789876543210 :: GHC.Types.Symbol) = - ShowsPrec_0123456789876543210 a0123456789876543210 a0123456789876543210 a0123456789876543210 :: GHC.Types.Symbol - 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) -> Type - where - SX1 :: forall (a :: Type). SX (X1 :: X (a :: Type)) - SX2 :: forall (a :: Type) (n :: Y a). - (Sing n) -> SX (X2 n :: X (a :: Type)) - 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) -> Type - where - SY1 :: forall (a :: Type). SY (Y1 :: Y (a :: Type)) - SY2 :: forall (a :: Type) (n :: X a). - (Sing n) -> SY (Y2 n :: Y (a :: Type)) - 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.golden b/tests/compile-and-dump/Singletons/T376.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T376.golden +++ /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 FSym0 :: (~>) ((~>) () ()) ((~>) () ()) - data FSym0 a0123456789876543210 - where - FSym0KindInference :: SameKind (Apply FSym0 arg) (FSym1 arg) => - FSym0 a0123456789876543210 - type instance Apply FSym0 a0123456789876543210 = FSym1 a0123456789876543210 - instance SuppressUnusedWarnings FSym0 where - suppressUnusedWarnings = snd (((,) FSym0KindInference) ()) - type FSym1 :: (~>) () () -> (~>) () () - data FSym1 a0123456789876543210 a0123456789876543210 - where - FSym1KindInference :: SameKind (Apply (FSym1 a0123456789876543210) arg) (FSym2 a0123456789876543210 arg) => - FSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (FSym1 a0123456789876543210) a0123456789876543210 = FSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (FSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) FSym1KindInference) ()) - type FSym2 (a0123456789876543210 :: (~>) () ()) (a0123456789876543210 :: ()) = - F a0123456789876543210 a0123456789876543210 :: () - type F :: (~>) () () -> () -> () - 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/T378a.golden b/tests/compile-and-dump/Singletons/T378a.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T378a.golden +++ /dev/null @@ -1,78 +0,0 @@ -Singletons/T378a.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| constBA :: forall b a. a -> b -> a - constBA x _ = x - - data Proxy :: forall k. k -> Type - where - Proxy1 :: Proxy a - Proxy2 :: Proxy (a :: k) - Proxy3 :: forall a. Proxy a - Proxy4 :: forall k (a :: k). Proxy a |] - ======> - constBA :: forall b a. a -> b -> a - constBA x _ = x - data Proxy :: forall k. k -> Type - where - Proxy1 :: Proxy a - Proxy2 :: Proxy (a :: k) - Proxy3 :: forall a. Proxy a - Proxy4 :: forall k (a :: k). Proxy a - type Proxy1Sym0 = Proxy1 :: Proxy a - type Proxy2Sym0 = Proxy2 :: Proxy (a :: k) - type Proxy3Sym0 = Proxy3 :: Proxy a - type Proxy4Sym0 = Proxy4 :: Proxy a - type ConstBASym0 :: forall b a. (~>) a ((~>) b a) - data ConstBASym0 a0123456789876543210 - where - ConstBASym0KindInference :: SameKind (Apply ConstBASym0 arg) (ConstBASym1 arg) => - ConstBASym0 a0123456789876543210 - type instance Apply ConstBASym0 a0123456789876543210 = ConstBASym1 a0123456789876543210 - instance SuppressUnusedWarnings ConstBASym0 where - suppressUnusedWarnings = snd (((,) ConstBASym0KindInference) ()) - type ConstBASym1 :: forall b a. a -> (~>) b a - data ConstBASym1 a0123456789876543210 a0123456789876543210 - where - ConstBASym1KindInference :: SameKind (Apply (ConstBASym1 a0123456789876543210) arg) (ConstBASym2 a0123456789876543210 arg) => - ConstBASym1 a0123456789876543210 a0123456789876543210 - type instance Apply (ConstBASym1 a0123456789876543210) a0123456789876543210 = ConstBASym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (ConstBASym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) ConstBASym1KindInference) ()) - type ConstBASym2 (a0123456789876543210 :: a) (a0123456789876543210 :: b) = - ConstBA a0123456789876543210 a0123456789876543210 :: a - type ConstBA :: forall b a. a -> b -> a - type family ConstBA a a where - ConstBA x _ = x - sConstBA :: - forall b a (t :: a) (t :: b). - Sing t -> Sing t -> Sing (Apply (Apply ConstBASym0 t) t :: a) - sConstBA (sX :: Sing x) _ = sX - instance SingI (ConstBASym0 :: (~>) a ((~>) b a)) where - sing = (singFun2 @ConstBASym0) sConstBA - instance SingI d => SingI (ConstBASym1 (d :: a) :: (~>) b a) where - sing = (singFun1 @(ConstBASym1 (d :: a))) (sConstBA (sing @d)) - data SProxy :: forall a. Proxy (a :: k) -> Type - where - SProxy1 :: forall a. SProxy (Proxy1 :: Proxy a) - SProxy2 :: forall k (a :: k). SProxy (Proxy2 :: Proxy (a :: k)) - SProxy3 :: forall a. SProxy (Proxy3 :: Proxy a) - SProxy4 :: forall k (a :: k). SProxy (Proxy4 :: Proxy a) - type instance Sing @(Proxy a) = SProxy - instance SingKind a => SingKind (Proxy a) where - type Demote (Proxy a) = Proxy (Demote a) - fromSing SProxy1 = Proxy1 - fromSing SProxy2 = Proxy2 - fromSing SProxy3 = Proxy3 - fromSing SProxy4 = Proxy4 - toSing Proxy1 = SomeSing SProxy1 - toSing Proxy2 = SomeSing SProxy2 - toSing Proxy3 = SomeSing SProxy3 - toSing Proxy4 = SomeSing SProxy4 - instance SingI Proxy1 where - sing = SProxy1 - instance SingI Proxy2 where - sing = SProxy2 - instance SingI Proxy3 where - sing = SProxy3 - instance SingI Proxy4 where - sing = SProxy4 diff --git a/tests/compile-and-dump/Singletons/T378a.hs b/tests/compile-and-dump/Singletons/T378a.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T378a.hs +++ /dev/null @@ -1,64 +0,0 @@ -module T378a where - -import Data.Kind -import Data.Singletons.Prelude hiding (Proxy(..)) -import Data.Singletons.TH hiding (Proxy(..)) - -$(singletons [d| - constBA :: forall b a. a -> b -> a - constBA x _ = x - - data Proxy :: forall k. k -> Type where - Proxy1 :: Proxy a - Proxy2 :: Proxy (a :: k) - Proxy3 :: forall a. Proxy a - Proxy4 :: forall k (a :: k). Proxy a - |]) - -ex1 :: [Bool] -ex1 = [] @Bool - -type PEx1 :: [Bool] -type PEx1 = '[] @Bool - -sEx1 :: SList ('[] @Bool) -sEx1 = SNil @Bool - -ex2 :: Bool -ex2 = constBA @Ordering @Bool True LT - -type PEx2 :: Bool -type PEx2 = ConstBA @Ordering @Bool True LT - -sEx2 :: Sing (ConstBA True LT) -sEx2 = sConstBA @Ordering @Bool STrue SLT - -proxyEx1, proxyEx2, proxyEx3, proxyEx4 :: Proxy True -proxyEx1 = Proxy1 @True -proxyEx2 = Proxy2 @Bool @True -proxyEx3 = Proxy3 @True -proxyEx4 = Proxy4 @Bool @True - -type ProxyEx1 :: Proxy True -type ProxyEx1 = Proxy1 @True - -type ProxyEx2 :: Proxy True -type ProxyEx2 = Proxy2 @Bool @True - -type ProxyEx3 :: Proxy True -type ProxyEx3 = Proxy3 @True - -type ProxyEx4 :: Proxy True -type ProxyEx4 = Proxy4 @Bool @True - -sProxyEx1 :: SProxy (Proxy1 @True) -sProxyEx1 = SProxy1 @True - -sProxyEx2 :: SProxy (Proxy2 @Bool @True) -sProxyEx2 = SProxy2 @Bool @True - -sProxyEx3 :: SProxy (Proxy3 @True) -sProxyEx3 = SProxy3 @True - -sProxyEx4 :: SProxy (Proxy4 @Bool @True) -sProxyEx4 = SProxy4 @Bool @True diff --git a/tests/compile-and-dump/Singletons/T378b.golden b/tests/compile-and-dump/Singletons/T378b.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T378b.golden +++ /dev/null diff --git a/tests/compile-and-dump/Singletons/T378b.hs b/tests/compile-and-dump/Singletons/T378b.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T378b.hs +++ /dev/null @@ -1,42 +0,0 @@ -module T378b where - -import Data.Kind -import Data.Singletons.TH - -$(singletons [d| - type C :: forall b a. a -> b -> Constraint - class C x y - - type D :: forall b a. a -> b -> Type - data D x y - - f :: forall b a. a -> b -> () - f _ _ = () - - type Nat :: Type - data Nat = Z | S Nat - - -- This will only typecheck if ZSym0 is a type synonym. - -- See Note [No SAKs for fully saturated defunctionalization symbols] - -- in D.S.Promote.Defun for more information. - natMinus :: Nat -> Nat -> Nat - natMinus Z _ = Z - natMinus (S a) (S b) = natMinus a b - natMinus a Z = a - |]) - --- Test some type variable orderings -type CExP :: Bool -> Ordering -> Constraint -type CExP = PC @Ordering @Bool - -type CExS :: Bool -> Ordering -> Constraint -type CExS = SC @Ordering @Bool - -type DExS :: D (x :: Bool) (y :: Ordering) -> Type -type DExS = SD @Ordering @Bool - -type FEx0 :: Bool ~> Ordering ~> () -type FEx0 = FSym0 @Ordering @Bool - -type FEx1 :: Bool -> Ordering ~> () -type FEx1 = FSym1 @Ordering @Bool diff --git a/tests/compile-and-dump/Singletons/T401.golden b/tests/compile-and-dump/Singletons/T401.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T401.golden +++ /dev/null @@ -1,13 +0,0 @@ - -Singletons/T401.hs:0:0: error: - `singletons` does not support higher-rank `forall`s -In the type: (forall a_0 . a_0 -> a_0) -> b_1 -> b_1 - - | -5 | $(singletons [d| - | ^^^^^^^^^^^^^^... - -Singletons/T401.hs:0:0: error: Q monad failure - | -5 | $(singletons [d| - | ^^^^^^^^^^^^^^... diff --git a/tests/compile-and-dump/Singletons/T401.hs b/tests/compile-and-dump/Singletons/T401.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T401.hs +++ /dev/null @@ -1,8 +0,0 @@ -module T401 where - -import Data.Singletons.TH - -$(singletons [d| - f :: (forall a. a -> a) -> b -> b - f _ x = x - |]) diff --git a/tests/compile-and-dump/Singletons/T401b.golden b/tests/compile-and-dump/Singletons/T401b.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T401b.golden +++ /dev/null @@ -1,13 +0,0 @@ - -Singletons/T401b.hs:0:0: error: - `singletons` does not support higher-rank `forall`s -In the type: (forall a_0 . a_0) -> T_1 - - | -5 | $(singletons [d| - | ^^^^^^^^^^^^^^... - -Singletons/T401b.hs:0:0: error: Q monad failure - | -5 | $(singletons [d| - | ^^^^^^^^^^^^^^... diff --git a/tests/compile-and-dump/Singletons/T401b.hs b/tests/compile-and-dump/Singletons/T401b.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T401b.hs +++ /dev/null @@ -1,8 +0,0 @@ -module T401b where - -import Data.Singletons.TH - -$(singletons [d| - newtype T where - MkT :: (forall a. a) -> T - |]) diff --git a/tests/compile-and-dump/Singletons/T402.golden b/tests/compile-and-dump/Singletons/T402.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T402.golden +++ /dev/null @@ -1,13 +0,0 @@ -Singletons/T402.hs:0:0:: Splicing declarations - singletons [d| type AnyOfKind (k :: Type) = Any :: k |] - ======> - type AnyOfKind (k :: Type) = Any :: k - data AnyOfKindSym0 :: (~>) Type k0123456789876543210 - where - AnyOfKindSym0KindInference :: SameKind (Apply AnyOfKindSym0 arg) (AnyOfKindSym1 arg) => - AnyOfKindSym0 k0123456789876543210 - type instance Apply AnyOfKindSym0 k0123456789876543210 = AnyOfKindSym1 k0123456789876543210 - instance SuppressUnusedWarnings AnyOfKindSym0 where - suppressUnusedWarnings = snd (((,) AnyOfKindSym0KindInference) ()) - type AnyOfKindSym1 (k0123456789876543210 :: Type) = - AnyOfKind k0123456789876543210 :: 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/T410.golden b/tests/compile-and-dump/Singletons/T410.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T410.golden +++ /dev/null @@ -1,59 +0,0 @@ -Singletons/T410.hs:(0,0)-(0,0): Splicing declarations - promote - [d| class Eq a where - equals :: a -> a -> Bool - - instance Eq () where - equals () () = True |] - ======> - class Eq a where - equals :: a -> a -> Bool - instance Eq () where - equals () () = True - type EqualsSym0 :: forall a. (~>) a ((~>) a Bool) - data EqualsSym0 a0123456789876543210 - where - EqualsSym0KindInference :: SameKind (Apply EqualsSym0 arg) (EqualsSym1 arg) => - EqualsSym0 a0123456789876543210 - type instance Apply EqualsSym0 a0123456789876543210 = EqualsSym1 a0123456789876543210 - instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings EqualsSym0 where - Data.Singletons.SuppressUnusedWarnings.suppressUnusedWarnings - = snd (((,) EqualsSym0KindInference) ()) - type EqualsSym1 :: forall a. a -> (~>) a Bool - data EqualsSym1 a0123456789876543210 a0123456789876543210 - where - EqualsSym1KindInference :: SameKind (Apply (EqualsSym1 a0123456789876543210) arg) (EqualsSym2 a0123456789876543210 arg) => - EqualsSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (EqualsSym1 a0123456789876543210) a0123456789876543210 = EqualsSym2 a0123456789876543210 a0123456789876543210 - instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings (EqualsSym1 a0123456789876543210) where - Data.Singletons.SuppressUnusedWarnings.suppressUnusedWarnings - = snd (((,) EqualsSym1KindInference) ()) - type EqualsSym2 (a0123456789876543210 :: a) (a0123456789876543210 :: a) = - Equals a0123456789876543210 a0123456789876543210 :: Bool - class PEq a where - type Equals (arg :: a) (arg :: a) :: Bool - type Equals_0123456789876543210 :: () -> () -> Bool - type family Equals_0123456789876543210 a a where - Equals_0123456789876543210 '() '() = TrueSym0 - type Equals_0123456789876543210Sym0 :: (~>) () ((~>) () Bool) - data Equals_0123456789876543210Sym0 a0123456789876543210 - where - Equals_0123456789876543210Sym0KindInference :: SameKind (Apply Equals_0123456789876543210Sym0 arg) (Equals_0123456789876543210Sym1 arg) => - Equals_0123456789876543210Sym0 a0123456789876543210 - type instance Apply Equals_0123456789876543210Sym0 a0123456789876543210 = Equals_0123456789876543210Sym1 a0123456789876543210 - instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings Equals_0123456789876543210Sym0 where - Data.Singletons.SuppressUnusedWarnings.suppressUnusedWarnings - = snd (((,) Equals_0123456789876543210Sym0KindInference) ()) - type Equals_0123456789876543210Sym1 :: () -> (~>) () Bool - data Equals_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - where - Equals_0123456789876543210Sym1KindInference :: SameKind (Apply (Equals_0123456789876543210Sym1 a0123456789876543210) arg) (Equals_0123456789876543210Sym2 a0123456789876543210 arg) => - Equals_0123456789876543210Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (Equals_0123456789876543210Sym1 a0123456789876543210) a0123456789876543210 = Equals_0123456789876543210Sym2 a0123456789876543210 a0123456789876543210 - instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings (Equals_0123456789876543210Sym1 a0123456789876543210) where - Data.Singletons.SuppressUnusedWarnings.suppressUnusedWarnings - = snd (((,) Equals_0123456789876543210Sym1KindInference) ()) - type Equals_0123456789876543210Sym2 (a0123456789876543210 :: ()) (a0123456789876543210 :: ()) = - Equals_0123456789876543210 a0123456789876543210 a0123456789876543210 :: Bool - instance PEq () where - type Equals a a = Apply (Apply Equals_0123456789876543210Sym0 a) a diff --git a/tests/compile-and-dump/Singletons/T410.hs b/tests/compile-and-dump/Singletons/T410.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T410.hs +++ /dev/null @@ -1,12 +0,0 @@ -module T410 where - -import Data.Singletons -import Data.Singletons.Prelude.Bool -import Data.Singletons.TH (promote) - -$(promote [d| - class Eq a where - equals :: a -> a -> Bool - instance Eq () where - equals () () = True - |]) diff --git a/tests/compile-and-dump/Singletons/T412.golden b/tests/compile-and-dump/Singletons/T412.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T412.golden +++ /dev/null @@ -1,374 +0,0 @@ -Singletons/T412.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| infixr 5 `D1`, `MkD1`, `d1A`, `d1B` - infixl 5 `T1a`, `T1b` - infix 6 `m1` - infix 5 `C1` - - class C1 a b where - infix 6 `m1` - m1 :: a -> b -> Bool - type T1a a b = Either a b - type family T1b a b where - T1b a b = Either a b - data D1 a b = MkD1 {d1A :: a, d1B :: b} |] - ======> - infix 5 `C1` - class C1 a b where - m1 :: a -> b -> Bool - infix 6 `m1` - infixl 5 `T1a` - infixl 5 `T1b` - type T1a a b = Either a b - type family T1b a b where - T1b a b = Either a b - infixr 5 `D1` - infixr 5 `MkD1` - infixr 5 `d1A` - infixr 5 `d1B` - data D1 a b = MkD1 {d1A :: a, d1B :: b} - data T1aSym0 a0123456789876543210 - where - T1aSym0KindInference :: SameKind (Apply T1aSym0 arg) (T1aSym1 arg) => - T1aSym0 a0123456789876543210 - type instance Apply T1aSym0 a0123456789876543210 = T1aSym1 a0123456789876543210 - instance SuppressUnusedWarnings T1aSym0 where - suppressUnusedWarnings = snd (((,) T1aSym0KindInference) ()) - infixl 5 `T1aSym0` - data T1aSym1 a0123456789876543210 b0123456789876543210 - where - T1aSym1KindInference :: SameKind (Apply (T1aSym1 a0123456789876543210) arg) (T1aSym2 a0123456789876543210 arg) => - T1aSym1 a0123456789876543210 b0123456789876543210 - type instance Apply (T1aSym1 a0123456789876543210) b0123456789876543210 = T1aSym2 a0123456789876543210 b0123456789876543210 - instance SuppressUnusedWarnings (T1aSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) T1aSym1KindInference) ()) - infixl 5 `T1aSym1` - type T1aSym2 a0123456789876543210 b0123456789876543210 = - T1a a0123456789876543210 b0123456789876543210 - infixl 5 `T1aSym2` - data T1bSym0 a0123456789876543210 - where - T1bSym0KindInference :: SameKind (Apply T1bSym0 arg) (T1bSym1 arg) => - T1bSym0 a0123456789876543210 - type instance Apply T1bSym0 a0123456789876543210 = T1bSym1 a0123456789876543210 - instance SuppressUnusedWarnings T1bSym0 where - suppressUnusedWarnings = snd (((,) T1bSym0KindInference) ()) - infixl 5 `T1bSym0` - data T1bSym1 a0123456789876543210 b0123456789876543210 - where - T1bSym1KindInference :: SameKind (Apply (T1bSym1 a0123456789876543210) arg) (T1bSym2 a0123456789876543210 arg) => - T1bSym1 a0123456789876543210 b0123456789876543210 - type instance Apply (T1bSym1 a0123456789876543210) b0123456789876543210 = T1bSym2 a0123456789876543210 b0123456789876543210 - instance SuppressUnusedWarnings (T1bSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) T1bSym1KindInference) ()) - infixl 5 `T1bSym1` - type T1bSym2 a0123456789876543210 b0123456789876543210 = - T1b a0123456789876543210 b0123456789876543210 - infixl 5 `T1bSym2` - type MkD1Sym0 :: forall a b. (~>) a ((~>) b (D1 a b)) - data MkD1Sym0 a0123456789876543210 - where - MkD1Sym0KindInference :: SameKind (Apply MkD1Sym0 arg) (MkD1Sym1 arg) => - MkD1Sym0 a0123456789876543210 - type instance Apply MkD1Sym0 a0123456789876543210 = MkD1Sym1 a0123456789876543210 - instance SuppressUnusedWarnings MkD1Sym0 where - suppressUnusedWarnings = snd (((,) MkD1Sym0KindInference) ()) - infixr 5 `MkD1Sym0` - type MkD1Sym1 :: forall a b. a -> (~>) b (D1 a b) - data MkD1Sym1 a0123456789876543210 a0123456789876543210 - where - MkD1Sym1KindInference :: SameKind (Apply (MkD1Sym1 a0123456789876543210) arg) (MkD1Sym2 a0123456789876543210 arg) => - MkD1Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (MkD1Sym1 a0123456789876543210) a0123456789876543210 = MkD1Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (MkD1Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) MkD1Sym1KindInference) ()) - infixr 5 `MkD1Sym1` - type MkD1Sym2 (a0123456789876543210 :: a) (a0123456789876543210 :: b) = - MkD1 a0123456789876543210 a0123456789876543210 :: D1 a b - infixr 5 `MkD1Sym2` - type D1BSym0 :: forall a b. (~>) (D1 a b) b - data D1BSym0 a0123456789876543210 - where - D1BSym0KindInference :: SameKind (Apply D1BSym0 arg) (D1BSym1 arg) => - D1BSym0 a0123456789876543210 - type instance Apply D1BSym0 a0123456789876543210 = D1BSym1 a0123456789876543210 - instance SuppressUnusedWarnings D1BSym0 where - suppressUnusedWarnings = snd (((,) D1BSym0KindInference) ()) - infixr 5 `D1BSym0` - type D1BSym1 (a0123456789876543210 :: D1 a b) = - D1B a0123456789876543210 :: b - infixr 5 `D1BSym1` - type D1ASym0 :: forall a b. (~>) (D1 a b) a - data D1ASym0 a0123456789876543210 - where - D1ASym0KindInference :: SameKind (Apply D1ASym0 arg) (D1ASym1 arg) => - D1ASym0 a0123456789876543210 - type instance Apply D1ASym0 a0123456789876543210 = D1ASym1 a0123456789876543210 - instance SuppressUnusedWarnings D1ASym0 where - suppressUnusedWarnings = snd (((,) D1ASym0KindInference) ()) - infixr 5 `D1ASym0` - type D1ASym1 (a0123456789876543210 :: D1 a b) = - D1A a0123456789876543210 :: a - infixr 5 `D1ASym1` - type D1B :: forall a b. D1 a b -> b - type family D1B a where - D1B (MkD1 _ field) = field - type D1A :: forall a b. D1 a b -> a - type family D1A a where - D1A (MkD1 field _) = field - infixr 5 `D1B` - infixr 5 `D1A` - infix 6 `M1` - infix 5 `PC1` - type M1Sym0 :: forall a b. (~>) a ((~>) b Bool) - data M1Sym0 a0123456789876543210 - where - M1Sym0KindInference :: SameKind (Apply M1Sym0 arg) (M1Sym1 arg) => - M1Sym0 a0123456789876543210 - type instance Apply M1Sym0 a0123456789876543210 = M1Sym1 a0123456789876543210 - instance SuppressUnusedWarnings M1Sym0 where - suppressUnusedWarnings = snd (((,) M1Sym0KindInference) ()) - infix 6 `M1Sym0` - type M1Sym1 :: forall a b. a -> (~>) b Bool - data M1Sym1 a0123456789876543210 a0123456789876543210 - where - M1Sym1KindInference :: SameKind (Apply (M1Sym1 a0123456789876543210) arg) (M1Sym2 a0123456789876543210 arg) => - M1Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (M1Sym1 a0123456789876543210) a0123456789876543210 = M1Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (M1Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) M1Sym1KindInference) ()) - infix 6 `M1Sym1` - type M1Sym2 (a0123456789876543210 :: a) (a0123456789876543210 :: b) = - M1 a0123456789876543210 a0123456789876543210 :: Bool - infix 6 `M1Sym2` - class PC1 a b where - type M1 (arg :: a) (arg :: b) :: Bool - infixr 5 `sD1B` - infixr 5 `sD1A` - infixr 5 `SMkD1` - infix 6 `sM1` - infix 5 `SC1` - sD1B :: - forall a b (t :: D1 a b). Sing t -> Sing (Apply D1BSym0 t :: b) - sD1A :: - forall a b (t :: D1 a b). Sing t -> Sing (Apply D1ASym0 t :: a) - sD1B (SMkD1 _ (sField :: Sing field)) = sField - sD1A (SMkD1 (sField :: Sing field) _) = sField - instance SingI (D1BSym0 :: (~>) (D1 a b) b) where - sing = (singFun1 @D1BSym0) sD1B - instance SingI (D1ASym0 :: (~>) (D1 a b) a) where - sing = (singFun1 @D1ASym0) sD1A - data SD1 :: forall a b. D1 a b -> GHC.Types.Type - where - SMkD1 :: forall a b (n :: a) (n :: b). - (Sing n) -> (Sing n) -> SD1 (MkD1 n n :: D1 a b) - type instance Sing @(D1 a b) = SD1 - instance (SingKind a, SingKind b) => SingKind (D1 a b) where - type Demote (D1 a b) = D1 (Demote a) (Demote b) - fromSing (SMkD1 b b) = (MkD1 (fromSing b)) (fromSing b) - toSing (MkD1 (b :: Demote a) (b :: Demote b)) - = case ((,) (toSing b :: SomeSing a)) (toSing b :: SomeSing b) of { - (,) (SomeSing c) (SomeSing c) -> SomeSing ((SMkD1 c) c) } - class SC1 a b where - sM1 :: - forall (t :: a) (t :: b). - Sing t -> Sing t -> Sing (Apply (Apply M1Sym0 t) t :: Bool) - instance (SingI n, SingI n) => SingI (MkD1 (n :: a) (n :: b)) where - sing = (SMkD1 sing) sing - instance SingI (MkD1Sym0 :: (~>) a ((~>) b (D1 a b))) where - sing = (singFun2 @MkD1Sym0) SMkD1 - instance SingI d => - SingI (MkD1Sym1 (d :: a) :: (~>) b (D1 a b)) where - sing = (singFun1 @(MkD1Sym1 (d :: a))) (SMkD1 (sing @d)) - instance SC1 a b => SingI (M1Sym0 :: (~>) a ((~>) b Bool)) where - sing = (singFun2 @M1Sym0) sM1 - instance (SC1 a b, SingI d) => - SingI (M1Sym1 (d :: a) :: (~>) b Bool) where - sing = (singFun1 @(M1Sym1 (d :: a))) (sM1 (sing @d)) -Singletons/T412.hs:0:0:: Splicing declarations - genSingletons [''C2, ''T2a, ''T2b, ''D2] - ======> - type M2Sym0 :: forall a b. (~>) a ((~>) b Bool) - data M2Sym0 a0123456789876543210 - where - M2Sym0KindInference :: SameKind (Apply M2Sym0 arg) (M2Sym1 arg) => - M2Sym0 a0123456789876543210 - type instance Apply M2Sym0 a0123456789876543210 = M2Sym1 a0123456789876543210 - instance SuppressUnusedWarnings M2Sym0 where - suppressUnusedWarnings = snd (((,) M2Sym0KindInference) ()) - infix 6 `M2Sym0` - type M2Sym1 :: forall a b. a -> (~>) b Bool - data M2Sym1 a0123456789876543210 a0123456789876543210 - where - M2Sym1KindInference :: SameKind (Apply (M2Sym1 a0123456789876543210) arg) (M2Sym2 a0123456789876543210 arg) => - M2Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (M2Sym1 a0123456789876543210) a0123456789876543210 = M2Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (M2Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) M2Sym1KindInference) ()) - infix 6 `M2Sym1` - type M2Sym2 (a0123456789876543210 :: a) (a0123456789876543210 :: b) = - M2 a0123456789876543210 a0123456789876543210 :: Bool - infix 6 `M2Sym2` - type PC2 :: GHC.Types.Type -> GHC.Types.Type -> Constraint - class PC2 (a :: GHC.Types.Type) (b :: GHC.Types.Type) where - type M2 (arg :: a) (arg :: b) :: Bool - infix 5 `PC2` - infix 6 `M2` - class SC2 (a :: GHC.Types.Type) (b :: GHC.Types.Type) where - sM2 :: - forall (t :: a) (t :: b). - Sing t -> Sing t -> Sing (Apply (Apply M2Sym0 t) t :: Bool) - type SC2 :: GHC.Types.Type -> GHC.Types.Type -> Constraint - infix 5 `SC2` - infix 6 `sM2` - instance SC2 a b => SingI (M2Sym0 :: (~>) a ((~>) b Bool)) where - sing = (singFun2 @M2Sym0) sM2 - instance (SC2 a b, SingI d) => - SingI (M2Sym1 (d :: a) :: (~>) b Bool) where - sing = (singFun1 @(M2Sym1 (d :: a))) (sM2 (sing @d)) - type T2aSym0 :: (~>) GHC.Types.Type ((~>) GHC.Types.Type GHC.Types.Type) - data T2aSym0 a0123456789876543210 - where - T2aSym0KindInference :: SameKind (Apply T2aSym0 arg) (T2aSym1 arg) => - T2aSym0 a0123456789876543210 - type instance Apply T2aSym0 a0123456789876543210 = T2aSym1 a0123456789876543210 - instance SuppressUnusedWarnings T2aSym0 where - suppressUnusedWarnings = snd (((,) T2aSym0KindInference) ()) - infixl 5 `T2aSym0` - type T2aSym1 :: GHC.Types.Type - -> (~>) GHC.Types.Type GHC.Types.Type - data T2aSym1 a0123456789876543210 a0123456789876543210 - where - T2aSym1KindInference :: SameKind (Apply (T2aSym1 a0123456789876543210) arg) (T2aSym2 a0123456789876543210 arg) => - T2aSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (T2aSym1 a0123456789876543210) a0123456789876543210 = T2aSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (T2aSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) T2aSym1KindInference) ()) - infixl 5 `T2aSym1` - type T2aSym2 (a0123456789876543210 :: GHC.Types.Type) (a0123456789876543210 :: GHC.Types.Type) = - T2a a0123456789876543210 a0123456789876543210 :: GHC.Types.Type - infixl 5 `T2aSym2` - type T2bSym0 :: (~>) GHC.Types.Type ((~>) GHC.Types.Type GHC.Types.Type) - data T2bSym0 a0123456789876543210 - where - T2bSym0KindInference :: SameKind (Apply T2bSym0 arg) (T2bSym1 arg) => - T2bSym0 a0123456789876543210 - type instance Apply T2bSym0 a0123456789876543210 = T2bSym1 a0123456789876543210 - instance SuppressUnusedWarnings T2bSym0 where - suppressUnusedWarnings = snd (((,) T2bSym0KindInference) ()) - infixl 5 `T2bSym0` - type T2bSym1 :: GHC.Types.Type - -> (~>) GHC.Types.Type GHC.Types.Type - data T2bSym1 a0123456789876543210 a0123456789876543210 - where - T2bSym1KindInference :: SameKind (Apply (T2bSym1 a0123456789876543210) arg) (T2bSym2 a0123456789876543210 arg) => - T2bSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (T2bSym1 a0123456789876543210) a0123456789876543210 = T2bSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (T2bSym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) T2bSym1KindInference) ()) - infixl 5 `T2bSym1` - type T2bSym2 (a0123456789876543210 :: GHC.Types.Type) (a0123456789876543210 :: GHC.Types.Type) = - T2b a0123456789876543210 a0123456789876543210 :: GHC.Types.Type - infixl 5 `T2bSym2` - type MkD2Sym0 :: forall (a :: GHC.Types.Type) - (b :: GHC.Types.Type). - (~>) a ((~>) b (D2 (a :: GHC.Types.Type) (b :: GHC.Types.Type))) - data MkD2Sym0 a0123456789876543210 - where - MkD2Sym0KindInference :: SameKind (Apply MkD2Sym0 arg) (MkD2Sym1 arg) => - MkD2Sym0 a0123456789876543210 - type instance Apply MkD2Sym0 a0123456789876543210 = MkD2Sym1 a0123456789876543210 - instance SuppressUnusedWarnings MkD2Sym0 where - suppressUnusedWarnings = snd (((,) MkD2Sym0KindInference) ()) - infixr 5 `MkD2Sym0` - type MkD2Sym1 :: forall (a :: GHC.Types.Type) - (b :: GHC.Types.Type). - a -> (~>) b (D2 (a :: GHC.Types.Type) (b :: GHC.Types.Type)) - data MkD2Sym1 a0123456789876543210 a0123456789876543210 - where - MkD2Sym1KindInference :: SameKind (Apply (MkD2Sym1 a0123456789876543210) arg) (MkD2Sym2 a0123456789876543210 arg) => - MkD2Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (MkD2Sym1 a0123456789876543210) a0123456789876543210 = MkD2Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (MkD2Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) MkD2Sym1KindInference) ()) - infixr 5 `MkD2Sym1` - type MkD2Sym2 (a0123456789876543210 :: a) (a0123456789876543210 :: b) = - 'MkD2 a0123456789876543210 a0123456789876543210 :: D2 (a :: GHC.Types.Type) (b :: GHC.Types.Type) - infixr 5 `MkD2Sym2` - infixr 5 `D2A` - infixr 5 `D2B` - type D2BSym0 :: forall (a :: GHC.Types.Type) (b :: GHC.Types.Type). - (~>) (D2 (a :: GHC.Types.Type) (b :: GHC.Types.Type)) b - data D2BSym0 a0123456789876543210 - where - D2BSym0KindInference :: SameKind (Apply D2BSym0 arg) (D2BSym1 arg) => - D2BSym0 a0123456789876543210 - type instance Apply D2BSym0 a0123456789876543210 = D2BSym1 a0123456789876543210 - instance SuppressUnusedWarnings D2BSym0 where - suppressUnusedWarnings = snd (((,) D2BSym0KindInference) ()) - type D2BSym1 (a0123456789876543210 :: D2 (a :: GHC.Types.Type) (b :: GHC.Types.Type)) = - D2B a0123456789876543210 :: b - type D2ASym0 :: forall (a :: GHC.Types.Type) (b :: GHC.Types.Type). - (~>) (D2 (a :: GHC.Types.Type) (b :: GHC.Types.Type)) a - data D2ASym0 a0123456789876543210 - where - D2ASym0KindInference :: SameKind (Apply D2ASym0 arg) (D2ASym1 arg) => - D2ASym0 a0123456789876543210 - type instance Apply D2ASym0 a0123456789876543210 = D2ASym1 a0123456789876543210 - instance SuppressUnusedWarnings D2ASym0 where - suppressUnusedWarnings = snd (((,) D2ASym0KindInference) ()) - type D2ASym1 (a0123456789876543210 :: D2 (a :: GHC.Types.Type) (b :: GHC.Types.Type)) = - D2A a0123456789876543210 :: a - type D2B :: forall (a :: GHC.Types.Type) (b :: GHC.Types.Type). - D2 (a :: GHC.Types.Type) (b :: GHC.Types.Type) -> b - type family D2B a where - D2B ('MkD2 _ field) = field - type D2A :: forall (a :: GHC.Types.Type) (b :: GHC.Types.Type). - D2 (a :: GHC.Types.Type) (b :: GHC.Types.Type) -> a - type family D2A a where - D2A ('MkD2 field _) = field - sD2B :: - forall (a :: GHC.Types.Type) - (b :: GHC.Types.Type) - (t :: D2 (a :: GHC.Types.Type) (b :: GHC.Types.Type)). - Sing t -> Sing (Apply D2BSym0 t :: b) - sD2A :: - forall (a :: GHC.Types.Type) - (b :: GHC.Types.Type) - (t :: D2 (a :: GHC.Types.Type) (b :: GHC.Types.Type)). - Sing t -> Sing (Apply D2ASym0 t :: a) - sD2B (SMkD2 _ (sField :: Sing field)) = sField - sD2A (SMkD2 (sField :: Sing field) _) = sField - instance SingI (D2BSym0 :: (~>) (D2 (a :: GHC.Types.Type) (b :: GHC.Types.Type)) b) where - sing = (singFun1 @D2BSym0) sD2B - instance SingI (D2ASym0 :: (~>) (D2 (a :: GHC.Types.Type) (b :: GHC.Types.Type)) a) where - sing = (singFun1 @D2ASym0) sD2A - type SD2 :: forall (a :: GHC.Types.Type) (b :: GHC.Types.Type). - D2 (a :: GHC.Types.Type) (b :: GHC.Types.Type) -> GHC.Types.Type - data SD2 z - where - SMkD2 :: forall (a :: GHC.Types.Type) - (b :: GHC.Types.Type) - (n :: a) - (n :: b). - (Sing n) - -> (Sing n) - -> SD2 ('MkD2 n n :: D2 (a :: GHC.Types.Type) (b :: GHC.Types.Type)) - type instance Sing @(D2 a b) = SD2 - instance (SingKind a, SingKind b) => SingKind (D2 a b) where - type Demote (D2 a b) = D2 (Demote a) (Demote b) - fromSing (SMkD2 b b) = (MkD2 (fromSing b)) (fromSing b) - toSing (MkD2 (b :: Demote a) (b :: Demote b)) - = case ((,) (toSing b :: SomeSing a)) (toSing b :: SomeSing b) of { - (,) (SomeSing c) (SomeSing c) -> SomeSing ((SMkD2 c) c) } - infixr 5 `SMkD2` - infixr 5 `sD2A` - infixr 5 `sD2B` - instance (SingI n, SingI n) => - SingI ('MkD2 (n :: a) (n :: b)) where - sing = (SMkD2 sing) sing - instance SingI (MkD2Sym0 :: (~>) a ((~>) b (D2 (a :: GHC.Types.Type) (b :: GHC.Types.Type)))) where - sing = (singFun2 @MkD2Sym0) SMkD2 - instance SingI d => - SingI (MkD2Sym1 (d :: a) :: (~>) b (D2 (a :: GHC.Types.Type) (b :: GHC.Types.Type))) where - sing = (singFun1 @(MkD2Sym1 (d :: a))) (SMkD2 (sing @d)) diff --git a/tests/compile-and-dump/Singletons/T412.hs b/tests/compile-and-dump/Singletons/T412.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T412.hs +++ /dev/null @@ -1,33 +0,0 @@ -module T412 where - -import Data.Singletons.TH - -$(singletons [d| - infix 5 `C1` - class C1 a b where - infix 6 `m1` - m1 :: a -> b -> Bool - - infixl 5 `T1a`, `T1b` - type T1a a b = Either a b - type family T1b a b where - T1b a b = Either a b - - infixr 5 `D1`, `MkD1`, `d1A`, `d1B` - data D1 a b = MkD1 { d1A :: a, d1B :: b } - |]) - -infix 5 `C2` -class C2 a b where - infix 6 `m2` - m2 :: a -> b -> Bool - -infixl 5 `T2a`, `T2b` -type T2a a b = Either a b -type family T2b a b where - T2b a b = Either a b - -infixr 5 `D2`, `MkD2`, `d2A`, `d2B` -data D2 a b = MkD2 { d2A :: a, d2B :: b } - -$(genSingletons [''C2, ''T2a, ''T2b, ''D2]) diff --git a/tests/compile-and-dump/Singletons/T414.golden b/tests/compile-and-dump/Singletons/T414.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T414.golden +++ /dev/null @@ -1,76 +0,0 @@ -Singletons/T414.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| type C3 :: Bool -> Constraint - - class C1 (a :: Bool) where - type T1 a b - class C2 a where - type T2 a b - class C3 a where - type T3 a b |] - ======> - class C1 (a :: Bool) where - type T1 a b - class C2 a where - type T2 a b - type C3 :: Bool -> Constraint - class C3 a where - type T3 a b - data T1Sym0 a0123456789876543210 - where - T1Sym0KindInference :: SameKind (Apply T1Sym0 arg) (T1Sym1 arg) => - T1Sym0 a0123456789876543210 - type instance Apply T1Sym0 a0123456789876543210 = T1Sym1 a0123456789876543210 - instance SuppressUnusedWarnings T1Sym0 where - suppressUnusedWarnings = snd (((,) T1Sym0KindInference) ()) - data T1Sym1 (a0123456789876543210 :: Bool) b0123456789876543210 - where - T1Sym1KindInference :: SameKind (Apply (T1Sym1 a0123456789876543210) arg) (T1Sym2 a0123456789876543210 arg) => - T1Sym1 a0123456789876543210 b0123456789876543210 - type instance Apply (T1Sym1 a0123456789876543210) b0123456789876543210 = T1Sym2 a0123456789876543210 b0123456789876543210 - instance SuppressUnusedWarnings (T1Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) T1Sym1KindInference) ()) - type T1Sym2 (a0123456789876543210 :: Bool) b0123456789876543210 = - T1 a0123456789876543210 b0123456789876543210 - class PC1 (a :: Bool) - data T2Sym0 a0123456789876543210 - where - T2Sym0KindInference :: SameKind (Apply T2Sym0 arg) (T2Sym1 arg) => - T2Sym0 a0123456789876543210 - type instance Apply T2Sym0 a0123456789876543210 = T2Sym1 a0123456789876543210 - instance SuppressUnusedWarnings T2Sym0 where - suppressUnusedWarnings = snd (((,) T2Sym0KindInference) ()) - data T2Sym1 a0123456789876543210 b0123456789876543210 - where - T2Sym1KindInference :: SameKind (Apply (T2Sym1 a0123456789876543210) arg) (T2Sym2 a0123456789876543210 arg) => - T2Sym1 a0123456789876543210 b0123456789876543210 - type instance Apply (T2Sym1 a0123456789876543210) b0123456789876543210 = T2Sym2 a0123456789876543210 b0123456789876543210 - instance SuppressUnusedWarnings (T2Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) T2Sym1KindInference) ()) - type T2Sym2 a0123456789876543210 b0123456789876543210 = - T2 a0123456789876543210 b0123456789876543210 - class PC2 a - type T3Sym0 :: (~>) Bool ((~>) Type Type) - data T3Sym0 a0123456789876543210 - where - T3Sym0KindInference :: SameKind (Apply T3Sym0 arg) (T3Sym1 arg) => - T3Sym0 a0123456789876543210 - type instance Apply T3Sym0 a0123456789876543210 = T3Sym1 a0123456789876543210 - instance SuppressUnusedWarnings T3Sym0 where - suppressUnusedWarnings = snd (((,) T3Sym0KindInference) ()) - type T3Sym1 :: Bool -> (~>) Type Type - data T3Sym1 a0123456789876543210 a0123456789876543210 - where - T3Sym1KindInference :: SameKind (Apply (T3Sym1 a0123456789876543210) arg) (T3Sym2 a0123456789876543210 arg) => - T3Sym1 a0123456789876543210 a0123456789876543210 - type instance Apply (T3Sym1 a0123456789876543210) a0123456789876543210 = T3Sym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (T3Sym1 a0123456789876543210) where - suppressUnusedWarnings = snd (((,) T3Sym1KindInference) ()) - type T3Sym2 (a0123456789876543210 :: Bool) (a0123456789876543210 :: Type) = - T3 a0123456789876543210 a0123456789876543210 :: Type - type PC3 :: Bool -> Constraint - class PC3 a - class SC1 (a :: Bool) - class SC2 a - class SC3 a - type SC3 :: Bool -> Constraint diff --git a/tests/compile-and-dump/Singletons/T414.hs b/tests/compile-and-dump/Singletons/T414.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T414.hs +++ /dev/null @@ -1,16 +0,0 @@ -module T414 where - -import Data.Kind -import Data.Singletons.TH - -$(singletons [d| - class C1 (a :: Bool) where - type T1 a b - - class C2 a where - type T2 a b - - type C3 :: Bool -> Constraint - class C3 a where - type T3 a b - |]) diff --git a/tests/compile-and-dump/Singletons/T54.golden b/tests/compile-and-dump/Singletons/T54.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T54.golden +++ /dev/null @@ -1,56 +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 - data Let0123456789876543210Scrutinee_0123456789876543210Sym0 e0123456789876543210 - where - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference :: SameKind (Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 arg) (Let0123456789876543210Scrutinee_0123456789876543210Sym1 arg) => - Let0123456789876543210Scrutinee_0123456789876543210Sym0 e0123456789876543210 - type instance Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 e0123456789876543210 = Let0123456789876543210Scrutinee_0123456789876543210Sym1 e0123456789876543210 - instance SuppressUnusedWarnings Let0123456789876543210Scrutinee_0123456789876543210Sym0 where - suppressUnusedWarnings - = snd - (((,) - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference) - ()) - type Let0123456789876543210Scrutinee_0123456789876543210Sym1 e0123456789876543210 = - Let0123456789876543210Scrutinee_0123456789876543210 e0123456789876543210 - type family Let0123456789876543210Scrutinee_0123456789876543210 e where - Let0123456789876543210Scrutinee_0123456789876543210 e = Apply (Apply (:@#@$) NotSym0) NilSym0 - type family Case_0123456789876543210 e t where - Case_0123456789876543210 e '[_] = NotSym0 - type GSym0 :: (~>) Bool Bool - data GSym0 a0123456789876543210 - where - GSym0KindInference :: SameKind (Apply GSym0 arg) (GSym1 arg) => - GSym0 a0123456789876543210 - type instance Apply GSym0 a0123456789876543210 = GSym1 a0123456789876543210 - instance SuppressUnusedWarnings GSym0 where - suppressUnusedWarnings = snd (((,) GSym0KindInference) ()) - type GSym1 (a0123456789876543210 :: Bool) = - G a0123456789876543210 :: Bool - type G :: Bool -> Bool - type family G a 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.golden b/tests/compile-and-dump/Singletons/T78.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T78.golden +++ /dev/null @@ -1,33 +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 FooSym0 :: (~>) (Maybe Bool) Bool - data FooSym0 a0123456789876543210 - where - FooSym0KindInference :: SameKind (Apply FooSym0 arg) (FooSym1 arg) => - FooSym0 a0123456789876543210 - type instance Apply FooSym0 a0123456789876543210 = FooSym1 a0123456789876543210 - instance SuppressUnusedWarnings FooSym0 where - suppressUnusedWarnings = snd (((,) FooSym0KindInference) ()) - type FooSym1 (a0123456789876543210 :: Maybe Bool) = - Foo a0123456789876543210 :: Bool - type Foo :: Maybe Bool -> Bool - type family Foo a 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.golden b/tests/compile-and-dump/Singletons/TopLevelPatterns.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/TopLevelPatterns.golden +++ /dev/null @@ -1,363 +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 :: Bool - type TrueSym0 = True :: Bool - type BarSym0 :: (~>) Bool ((~>) Bool Foo) - data BarSym0 a0123456789876543210 - where - BarSym0KindInference :: SameKind (Apply BarSym0 arg) (BarSym1 arg) => - BarSym0 a0123456789876543210 - type instance Apply BarSym0 a0123456789876543210 = BarSym1 a0123456789876543210 - instance SuppressUnusedWarnings BarSym0 where - suppressUnusedWarnings - = Data.Tuple.snd (((,) BarSym0KindInference) ()) - type BarSym1 :: Bool -> (~>) Bool Foo - data BarSym1 a0123456789876543210 a0123456789876543210 - where - BarSym1KindInference :: SameKind (Apply (BarSym1 a0123456789876543210) arg) (BarSym2 a0123456789876543210 arg) => - BarSym1 a0123456789876543210 a0123456789876543210 - type instance Apply (BarSym1 a0123456789876543210) a0123456789876543210 = BarSym2 a0123456789876543210 a0123456789876543210 - instance SuppressUnusedWarnings (BarSym1 a0123456789876543210) where - suppressUnusedWarnings - = Data.Tuple.snd (((,) BarSym1KindInference) ()) - type BarSym2 (a0123456789876543210 :: Bool) (a0123456789876543210 :: Bool) = - Bar a0123456789876543210 a0123456789876543210 :: Foo - data SBool :: Bool -> GHC.Types.Type - where - SFalse :: SBool (False :: Bool) - STrue :: SBool (True :: Bool) - 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) -> (Sing n) -> SFoo (Bar n n :: Foo) - 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 :: Bool - type LSym0 = L :: Bool - type X_0123456789876543210Sym0 = X_0123456789876543210 - type KSym0 = K :: Bool - type JSym0 = J :: Bool - type X_0123456789876543210Sym0 = X_0123456789876543210 - type ISym0 :: (~>) Bool Bool - data ISym0 a0123456789876543210 - where - ISym0KindInference :: SameKind (Apply ISym0 arg) (ISym1 arg) => - ISym0 a0123456789876543210 - type instance Apply ISym0 a0123456789876543210 = ISym1 a0123456789876543210 - instance SuppressUnusedWarnings ISym0 where - suppressUnusedWarnings - = Data.Tuple.snd (((,) ISym0KindInference) ()) - type ISym1 (a0123456789876543210 :: Bool) = - I a0123456789876543210 :: Bool - type HSym0 :: (~>) Bool Bool - data HSym0 a0123456789876543210 - where - HSym0KindInference :: SameKind (Apply HSym0 arg) (HSym1 arg) => - HSym0 a0123456789876543210 - type instance Apply HSym0 a0123456789876543210 = HSym1 a0123456789876543210 - instance SuppressUnusedWarnings HSym0 where - suppressUnusedWarnings - = Data.Tuple.snd (((,) HSym0KindInference) ()) - type HSym1 (a0123456789876543210 :: Bool) = - H a0123456789876543210 :: Bool - type X_0123456789876543210Sym0 = X_0123456789876543210 - type GSym0 :: (~>) Bool Bool - data GSym0 a0123456789876543210 - where - GSym0KindInference :: SameKind (Apply GSym0 arg) (GSym1 arg) => - GSym0 a0123456789876543210 - type instance Apply GSym0 a0123456789876543210 = GSym1 a0123456789876543210 - instance SuppressUnusedWarnings GSym0 where - suppressUnusedWarnings - = Data.Tuple.snd (((,) GSym0KindInference) ()) - type GSym1 (a0123456789876543210 :: Bool) = - G a0123456789876543210 :: Bool - type FSym0 :: (~>) Bool Bool - data FSym0 a0123456789876543210 - where - FSym0KindInference :: SameKind (Apply FSym0 arg) (FSym1 arg) => - FSym0 a0123456789876543210 - type instance Apply FSym0 a0123456789876543210 = FSym1 a0123456789876543210 - instance SuppressUnusedWarnings FSym0 where - suppressUnusedWarnings - = Data.Tuple.snd (((,) FSym0KindInference) ()) - type FSym1 (a0123456789876543210 :: Bool) = - F a0123456789876543210 :: Bool - type X_0123456789876543210Sym0 = X_0123456789876543210 - type False_Sym0 = False_ - type NotSym0 :: (~>) Bool Bool - data NotSym0 a0123456789876543210 - where - NotSym0KindInference :: SameKind (Apply NotSym0 arg) (NotSym1 arg) => - NotSym0 a0123456789876543210 - type instance Apply NotSym0 a0123456789876543210 = NotSym1 a0123456789876543210 - instance SuppressUnusedWarnings NotSym0 where - suppressUnusedWarnings - = Data.Tuple.snd (((,) NotSym0KindInference) ()) - type NotSym1 (a0123456789876543210 :: Bool) = - Not a0123456789876543210 :: Bool - type IdSym0 :: (~>) a a - data IdSym0 a0123456789876543210 - where - IdSym0KindInference :: SameKind (Apply IdSym0 arg) (IdSym1 arg) => - IdSym0 a0123456789876543210 - type instance Apply IdSym0 a0123456789876543210 = IdSym1 a0123456789876543210 - instance SuppressUnusedWarnings IdSym0 where - suppressUnusedWarnings - = Data.Tuple.snd (((,) IdSym0KindInference) ()) - type IdSym1 (a0123456789876543210 :: a) = - Id a0123456789876543210 :: a - type OtherwiseSym0 = Otherwise :: Bool - type M :: Bool - type family M where - M = Case_0123456789876543210 X_0123456789876543210Sym0 - type L :: Bool - type family L where - L = Case_0123456789876543210 X_0123456789876543210Sym0 - type family X_0123456789876543210 where - X_0123456789876543210 = Apply (Apply (:@#@$) (Apply NotSym0 TrueSym0)) (Apply (Apply (:@#@$) (Apply IdSym0 FalseSym0)) NilSym0) - type K :: Bool - type family K where - K = Case_0123456789876543210 X_0123456789876543210Sym0 - type J :: Bool - type family J where - J = Case_0123456789876543210 X_0123456789876543210Sym0 - type family X_0123456789876543210 where - X_0123456789876543210 = Apply (Apply BarSym0 TrueSym0) (Apply HSym0 FalseSym0) - type I :: Bool -> Bool - type family I a where - I a_0123456789876543210 = Apply (Case_0123456789876543210 a_0123456789876543210 X_0123456789876543210Sym0) a_0123456789876543210 - type H :: Bool -> Bool - type family H a 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 G :: Bool -> Bool - type family G a where - G a_0123456789876543210 = Apply (Case_0123456789876543210 a_0123456789876543210 X_0123456789876543210Sym0) a_0123456789876543210 - type F :: Bool -> Bool - type family F a 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) NilSym0) - type family False_ where - False_ = FalseSym0 - type Not :: Bool -> Bool - type family Not a where - Not 'True = FalseSym0 - Not 'False = TrueSym0 - type Id :: a -> a - type family Id a where - Id x = x - type Otherwise :: Bool - type family Otherwise 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.golden b/tests/compile-and-dump/Singletons/TypeRepTYPE.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/TypeRepTYPE.golden +++ /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.golden b/tests/compile-and-dump/Singletons/Undef.golden deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Undef.golden +++ /dev/null @@ -1,49 +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 BarSym0 :: (~>) Bool Bool - data BarSym0 a0123456789876543210 - where - BarSym0KindInference :: SameKind (Apply BarSym0 arg) (BarSym1 arg) => - BarSym0 a0123456789876543210 - type instance Apply BarSym0 a0123456789876543210 = BarSym1 a0123456789876543210 - instance SuppressUnusedWarnings BarSym0 where - suppressUnusedWarnings = snd (((,) BarSym0KindInference) ()) - type BarSym1 (a0123456789876543210 :: Bool) = - Bar a0123456789876543210 :: Bool - type FooSym0 :: (~>) Bool Bool - data FooSym0 a0123456789876543210 - where - FooSym0KindInference :: SameKind (Apply FooSym0 arg) (FooSym1 arg) => - FooSym0 a0123456789876543210 - type instance Apply FooSym0 a0123456789876543210 = FooSym1 a0123456789876543210 - instance SuppressUnusedWarnings FooSym0 where - suppressUnusedWarnings = snd (((,) FooSym0KindInference) ()) - type FooSym1 (a0123456789876543210 :: Bool) = - Foo a0123456789876543210 :: Bool - type Bar :: Bool -> Bool - type family Bar a where - Bar a_0123456789876543210 = Apply (Apply ErrorSym0 "urk") a_0123456789876543210 - type Foo :: Bool -> Bool - type family Foo a 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" - |])