diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,9 +1,595 @@ -Changelog for singletons project -================================ +Changelog for the `singletons` project +====================================== -2.3.1 +3.0.4 [2024.12.11] +------------------ +* Define `Sing` instances such that they explicitly match on their types on the + left-hand sides (e.g., define `type instance Sing @(k1 ~> k2) = SLambda` + instead of `type instance Sing = SLambda`. Doing so will make `singletons` + future-proof once + [GHC#23515](https://gitlab.haskell.org/ghc/ghc/-/issues/23515) is fixed. + +3.0.3 [2024.05.12] +------------------ +* Allow building with GHC 9.10. + +3.0.2 [2022.08.23] +------------------ +* Allow building with GHC 9.4. +* When building with GHC 9.4 or later, use the new + [`withDict`](https://hackage.haskell.org/package/ghc-prim-0.9.0/docs/GHC-Magic-Dict.html#v:withDict) + primitive to implement `withSingI` instead of `unsafeCoerce`. This change + should not have any consequences for user-facing code. + +3.0.1 [2021.10.30] +------------------ +* Add `SingI1` and `SingI2`, higher-order versions of `SingI`, to + `Data.Singletons`, along with various derived functions: + + * `sing{1,2}` + * `singByProxy{1,2}` and `singByProxy{1,2}#` + * `usingSing{1,2}` + * `withSing{1,2}` + * `singThat{1,2}` + +3.0 [2021.03.12] +---------------- +* The `singletons` library has been split into three libraries: + + * The new `singletons` library is now a minimal library that only provides + `Data.Singletons`, `Data.Singletons.Decide`, `Data.Singletons.Sigma`, and + `Data.Singletons.ShowSing` (if compiled with GHC 8.6 or later). + `singletons` now supports building GHCs back to GHC 8.0, as well as GHCJS. + * The `singletons-th` library defines Template Haskell functionality for + promoting and singling term-level definitions, but but nothing else. This + library continues to require the latest stable release of GHC. + * The `singletons-base` library defines promoted and singled versions of + definitions from the `base` library, including the `Prelude`. This library + continues to require the latest stable release of GHC. + + Consult the changelogs for `singletons-th` and `singletons-base` for changes + specific to those libraries. For more information on this split, see the + [relevant GitHub discussion](https://github.com/goldfirere/singletons/issues/420). +* The internals of `ShowSing` have been tweaked to make it possible to derive + `Show` instances for singleton types, e.g., + + ```hs + deriving instance ShowSing a => Show (SList (z :: [a])) + ``` + + For the most part, this is a backwards-compatible change, although there + exists at least one corner case where the new internals of `ShowSing` require + extra work to play nicely with GHC's constraint solver. For more details, + refer to the Haddocks for `ShowSing'` in `Data.Singletons.ShowSing`. + +2.7 +--- +* Require GHC 8.10. +* Record selectors are now singled as top-level functions. For instance, + `$(singletons [d| data T = MkT { unT :: Bool } |])` will now generate this: + + ```hs + data ST :: T -> Type where + SMkT :: Sing b -> Sing (MkT b) + + sUnT :: Sing (t :: T) -> Sing (UnT t :: Bool) + sUnT (SMkT sb) = sb + + ... + ``` + + Instead of this: + + ```hs + data ST :: T -> Type where + SMkT :: { sUnT :: Sing b } -> Sing (MkT b) + ``` + + Note that the new type of `sUnT` is more general than the previous type + (`Sing (MkT b) -> Sing b`). + + There are two primary reasons for this change: + + 1. Singling record selectors as top-level functions is consistent with how + promoting records works (note that `MkT` is also a top-level function). As + 2. Embedding record selectors directly into a singleton data constructor can + result in surprising behavior. This can range from simple code using a + record selector not typechecking to the inability to define multiple + constructors that share the same record name. + + See [this GitHub issue](https://github.com/goldfirere/singletons/issues/364) + for an extended discussion on the motivation behind this change. +* The Template Haskell machinery now supports fine-grained configuration in + the way of an `Options` data type, which lives in the new + `Data.Singletons.TH.Options` module. Besides `Options`, this module also + contains: + * `Options`' record selectors. Currently, these include options to toggle + generating quoted declarations, toggle generating `SingKind` instances, + and configure how `singletons` generates the names of promoted or singled + types. In the future, there may be additional options. + * A `defaultOptions` value. + * An `mtl`-like `OptionsMonad` class for monads that support carrying + `Option`s. This includes `Q`, which uses `defaultOptions` if it is the + top of the monad transformer stack. + * An `OptionM` monad transformer that turns any `DsMonad` into an + `OptionsMonad`. + * A `withOptions` function which allows passing `Options` to TH functions + (e.g., `promote` or `singletons`). See the `README` for a full example + of how to use `withOptions`. + Most TH functions are now polymorphic over `OptionsMonad` instead of + `DsMonad`. +* `singletons` now does a much better job of preserving the order of type + variables in type signatures during promotion and singling. See the + `Support for TypeApplications` section of the `README` for more details. + + When generating type-level declarations in particular (e.g., promoted type + families or defunctionalization symbols), `singletons` will likely also + generate standalone kind signatures to preserve type variable order. As a + result, most `singletons` code that uses Template Haskell will require the + use of the `StandaloneKindSignatures` extension (and, by extension, the + `NoCUSKs` extension) to work. +* `singletons` now does a more much thorough job of rejecting higher-rank types + during promotion or singling, as `singletons` cannot support them. + (Previously, `singletons` would sometimes accept them, often changing rank-2 + types to rank-1 types incorrectly in the process.) +* Add the `Data.Singletons.Prelude.Proxy` module. +* Remove the promoted versions of `genericTake`, `genericDrop`, + `genericSplitAt`, `genericIndex`, and `genericReplicate` from + `Data.Singletons.Prelude.List`. These definitions were subtly wrong since + (1) they claim to work over any `Integral` type `i`, but in practice would + only work on `Nat`s, and (2) wouldn't even typecheck if they were singled. +* Export `ApplyTyConAux1`, `ApplyTyConAux2`, as well as the record pattern + synonyms selector `applySing2`, `applySing3`, etc. from `Data.Singletons`. + These were unintentionally left out in previous releases. +* Export promoted and singled versions of the `getDown` record selector in + `Data.Singletons.Prelude.Ord`. +* Fix a slew of bugs related to fixity declarations: + * Fixity declarations for data types are no longer singled, as fixity + declarations do not serve any purpose for singled data type constructors, + which always have exactly one argument. + * `singletons` now promotes fixity declarations for class names. + `genPromotions`/`genSingletons` now also handle fixity declarations for + classes, class methods, data types, and record selectors correctly. + * `singletons` will no longer erroneously try to single fixity declarations + for type synonym or type family names. + * A bug that caused fixity declarations for certain defunctionalization + symbols not to be generated has been fixed. + * `promoteOnly` and `singletonsOnly` will now produce fixity declarations + for values with infix names. + +2.6 +--- +* Require GHC 8.8. +* `Sing` has switched from a data family to a type family. This + [GitHub issue comment](https://github.com/goldfirere/singletons/issues/318#issuecomment-467067257) + provides a detailed explanation for the motivation behind this change. + + This has a number of consequences: + * Names like `SBool`, `SMaybe`, etc. are no longer type synonyms for + particular instantiations of `Sing` but are instead the names of the + singleton data types themselves. In other words, previous versions of + `singletons` would provide this: + + ```haskell + data instance Sing :: Bool -> Type where + SFalse :: Sing False + STrue :: Sing True + type SBool = (Sing :: Bool -> Type) + ``` + + Whereas with `Sing`-as-a-type-family, `singletons` now provides this: + + ```haskell + data SBool :: Bool -> Type where + SFalse :: SBool False + STrue :: SBool True + type instance Sing @Bool = SBool + ``` + * The `Sing` instance for `TYPE rep` in `Data.Singletons.TypeRepTYPE` is now + directly defined as `type instance Sing @(TYPE rep) = TypeRep`, without the + use of an intermediate newtype as before. + * Due to limitations in the ways that quantified constraints and type + families can interact + (see [this GHC issue](https://gitlab.haskell.org/ghc/ghc/issues/14860)), + the internals of `ShowSing` has to be tweaked in order to continue to + work with `Sing`-as-a-type-family. One notable consequence of this is + that `Show` instances for singleton types can no longer be derived—they + must be written by hand in order to work around + [this GHC bug](https://gitlab.haskell.org/ghc/ghc/issues/16365). + This is unlikely to affect you unless you define 'Show' instances for + singleton types by hand. For more information, refer to the Haddocks for + `ShowSing'` in `Data.Singletons.ShowSing`. + * GHC does not permit type class instances to mention type families, which + means that it is no longer possible to define instances that mention the + `Sing` type constructor. For this reason, a `WrappedSing` data type (which + is a newtype around `Sing`) was introduced so that one can hang instances + off of it. + + This had one noticeable effect in `singletons` + itself: there are no longer `TestEquality Sing` or `TestCoercion Sing` + instances. Instead, `singletons` now generates a separate + `TestEquality`/`TestCoercion` instance for every data type that singles a + derived `Eq` instance. In addition, the `Data.Singletons.Decide` module + now provides top-level `decideEquality`/`decideCoercion` functions which + provide the behavior of `testEquality`/`testCoercion`, but monomorphized + to `Sing`. Finally, `TestEquality`/`TestCoercion` instances are provided + for `WrappedSing`. +* GHC's behavior surrounding kind inference for local definitions has changed + in 8.8, and certain code that `singletons` generates for local definitions + may no longer typecheck as a result. While we have taken measures to mitigate + the issue on `singletons`' end, there still exists code that must be patched + on the users' end in order to continue compiling. For instance, here is an + example of code that stopped compiling with the switch to GHC 8.8: + + ```haskell + replicateM_ :: (Applicative m) => Nat -> m a -> m () + replicateM_ cnt0 f = + loop cnt0 + where + loop cnt + | cnt <= 0 = pure () + | otherwise = f *> loop (cnt - 1) + ``` + + This produces errors to the effect of: + + ``` + • Could not deduce (SNum k1) arising from a use of ‘sFromInteger’ + from the context: SApplicative m + ... + + • Could not deduce (SOrd k1) arising from a use of ‘%<=’ + from the context: SApplicative m + ... + ``` + + The issue is that GHC 8.8 now kind-generalizes `sLoop` (whereas it did not + previously), explaining why the error message mentions a mysterious kind + variable `k1` that only appeared after kind generalization. The solution is + to give `loop` an explicit type signature like so: + + ```diff + -replicateM_ :: (Applicative m) => Nat -> m a -> m () + +replicateM_ :: forall m a. (Applicative m) => Nat -> m a -> m () + replicateM_ cnt0 f = + loop cnt0 + where + + loop :: Nat -> m () + loop cnt + | cnt <= 0 = pure () + | otherwise = f *> loop (cnt - 1) + ``` + + This general approach should be sufficient to fix any type inference + regressions that were introduced between GHC 8.6 and 8.8. If this isn't the + case, please file an issue. +* Due to [GHC Trac #16133](https://ghc.haskell.org/trac/ghc/ticket/16133) being + fixed, `singletons`-generated code now requires explicitly enabling the + `TypeApplications` extension. (The generated code was always using + `TypeApplications` under the hood, but it's only now that GHC is detecting + it.) +* `Data.Singletons` now defines a family of `SingI` instances for `TyCon1` + through `TyCon8`: + + ```haskell + instance (forall a. SingI a => SingI (f a), ...) => SingI (TyCon1 f) + instance (forall a b. (SingI a, SingI b) => SingI (f a b), ...) => SingI (TyCon2 f) + ... + ``` + + As a result, `singletons` no longer generates instances for `SingI` instances + for applications of `TyCon{N}` to particular type constructors, as they have + been superseded by the instances above. +* Changes to `Data.Singletons.Sigma`: + * `SSigma`, the singleton type for `Sigma`, is now defined. + * New functions `fstSigma`, `sndSigma`, `FstSigma`, `SndSigma`, `currySigma`, + and `uncurrySigma` have been added. A `Show` instance for `Sigma` has also + been added. + * `projSigma1` has been redefined to use continuation-passing style to more + closely resemble its cousin `projSigma2`. The new type signature of + `projSigma1` is: + + ```hs + projSigma1 :: (forall (fst :: s). Sing fst -> r) -> Sigma s t -> r + ``` + + The old type signature of `projSigma1` can be found in the `fstSigma` + function. + * `Σ` has been redefined such that it is now a partial application of + `Sigma`, like so: + + ```haskell + type Σ = Sigma + ``` + + One benefit of this change is that one no longer needs defunctionalization + symbols in order to partially apply `Σ`. As a result, `ΣSym0`, `ΣSym1`, + and `ΣSym2` have been removed. +* In line with corresponding changes in `base-4.13`, the `Fail`/`sFail` methods + of `{P,S}Monad` have been removed in favor of new `{P,S}MonadFail` classes + introduced in the `Data.Singletons.Prelude.Monad.Fail` module. These classes + are also re-exported from `Data.Singletons.Prelude`. +* Fix a bug where expressions with explicit signatures involving function types + would fail to single. +* The infix names `(.)` and `(!)` are no longer mapped to `(:.)` and `(:!)`, + as GHC 8.8 learned to parse them at the type level. +* The `Enum` instance for `SomeSing` now uses more efficient implementations of + `enumFromTo` and `enumFromThenTo` that no longer require a `SingKind` + constraint. + +2.5.1 ----- -* Fix the Haddock build, thanks to @christiaanb. +* `ShowSing` is now a type class (with a single instance) instead of a type + synonym. This was changed because defining `ShowSing` as a type synonym + prevents it from working well with recursive types due to an unfortunate GHC + bug. For more information, see + [issue #371](https://github.com/goldfirere/singletons/issues/371). +* Add an `IsString` instance for `SomeSing`. + +2.5 +--- +* The `Data.Promotion.Prelude.*` namespace has been removed. Use the + corresponding modules in the `Data.Singletons.Prelude.*` namespace instead. + +* Fix a regression in which certain infix type families, such as `(++)`, `($)`, + `(+)`, and others, did not have the correct fixities. + +* The default implementation of the `(==)` type in `PEq` was changed from + `(Data.Type.Equality.==)` to a custom type family, `DefaultEq`. The reason + for this change is that `(Data.Type.Equality.==)` is unable to conclude that + `a == a` reduces to `True` for any `a`. (As a result, the previous version of + `singletons` regressed in terms of type inference for the `PEq` instances + for `Nat` and `Symbol`, which used that default.) On the other hand, + `DefaultEq a a` _does_ reduce to `True` for all `a`. + +* Add `Enum Nat`, `Show Nat`, and `Show Symbol` instances to + `Data.Singletons.TypeLits`. + +* Template Haskell-generated code may require `DataKinds` and `PolyKinds` in + scenarios which did not previously require it: + * `singletons` now explicitly quantifies all kind variables used in explicit + `forall`s. + * `singletons` now generates `a ~> b` instead of `TyFun a b -> Type` whenever + possible. + +* Since `th-desugar` now desugars all data types to GADT syntax, Template + Haskell-generated code may require `GADTs` in situations that didn't require + it before. + +* Overhaul the way derived `Show` instances for singleton types works. Before, + there was an awkward `ShowSing` class (which was essentially a cargo-culted + version of `Show` specialized for `Sing`) that one had to create instances + for separately. Now that GHC has `QuantifiedConstraints`, we can scrap this + whole class and turn `ShowSing` into a simple type synonym: + + ```haskell + type ShowSing k = forall z. Show (Sing (z :: k)) + ``` + + Now, instead of generating a hand-written `ShowSing` and `Show` instance for + each singleton type, we only generate a single (derived!) `Show` instance. + As a result of this change, you will likely need to enable + `QuantifiedConstraints` and `StandaloneDeriving` if you single any derived + `Show` instances in your code. + +* The kind of the type parameter to `SingI` is no longer specified. This only + affects you if you were using the `sing` method with `TypeApplications`. For + instance, if you were using `sing @Bool @True` before, then you will now need + to now use `sing @Bool` instead. + +* `singletons` now generates `SingI` instances for defunctionalization symbols + through Template Haskell. As a result, you may need to enable + `FlexibleInstances` in more places. + +* `genDefunSymbols` is now more robust with respect to types that use + dependent quantification, such as: + + ```haskell + type family MyProxy k (a :: k) :: Type where + MyProxy k (a :: k) = Proxy a + ``` + + See the documentation for `genDefunSymbols` for limitations to this. + +* Rename `Data.Singletons.TypeRepStar` to `Data.Singletons.TypeRepTYPE`, and + generalize the `Sing :: Type -> Type` instance to `Sing :: TYPE rep -> Type`, + allowing it to work over more open kinds. Also rename `SomeTypeRepStar` to + `SomeTypeRepTYPE`, and change its definition accordingly. + +* Promoting or singling a type synonym or type family declaration now produces + defunctionalization symbols for it. (Previously, promoting or singling a type + synonym did nothing whatsoever, and promoting or singling a type family + produced an error.) + +* `singletons` now produces fixity declarations for defunctionalization + symbols when appropriate. + +* Add `(%<=?)`, a singled version of `(<=?)` from `GHC.TypeNats`, as well as + defunctionalization symbols for `(<=?)`, to `Data.Singletons.TypeLits`. + +* Add `Data.Singletons.Prelude.{Semigroup,Monoid}`, which define + promoted and singled versions of the `Semigroup` and `Monoid` type classes, + as well as various newtype modifiers. + + `Symbol` is now has promoted `Semigroup` and `Monoid` instances as well. + As a consequence, `Data.Singletons.TypeLits` no longer exports `(<>)` or + `(%<>)`, as they are superseded by the corresponding methods from + `PSemigroup` and `SSemigroup`. + +* Add promoted and singled versions of the `Functor`, `Foldable`, + `Traversable`, `Applicative`, `Alternative`, `Monad`, `MonadPlus`, and + `MonadZip` classes. Among other things, this grants the ability to promote + or single `do`-notation and list comprehensions. + * `Data.Singletons.Prelude.List` now reexports more general + `Foldable`/`Traversable` functions wherever possible, just as `Data.List` + does. + +* Add `Data.Singletons.Prelude.{Const,Identity}`, which define + promoted and singled version of the `Const` and `Identity` data types, + respectively. + +* Promote and single the `Down` newtype in `Data.Singletons.Prelude.Ord`. + +* To match the `base` library, the promoted/singled versions of `comparing` + and `thenCmp` are no longer exported from `Data.Singletons.Prelude`. (They + continue to live in `Data.Singletons.Prelude.Ord`.) + +* Permit singling of expression and pattern signatures. + +* Permit promotion and singling of `InstanceSigs`. + +* `sError` and `sUndefined` now have `HasCallStack` constraints, like their + counterparts `error` and `undefined`. The promoted and singled counterparts + to `errorWithoutStackTrace` have also been added in case you do not want + this behavior. + +* Add `Data.Singletons.TypeError`, which provides a drop-in replacement for + `GHC.TypeLits.TypeError` which can be used at both the value- and type-level. + +2.4.1 +----- +* Restore the `TyCon1`, `TyCon2`, etc. types. It turns out that the new +`TyCon` doesn't work with kind-polymorphic tycons. + +2.4 +--- +* Require GHC 8.4. + +* `Demote Nat` is now `Natural` (from `Numeric.Natural`) instead of `Integer`. + In accordance with this change, `Data.Singletons.TypeLits` now exposes + `GHC.TypeNats.natVal` (which returns a `Natural`) instead of + `GHC.TypeLits.natVal` (which returns an `Integer`). + +* The naming conventions for infix identifiers (e.g., `(&*)`) have been overhauled. + * Infix functions (that are not constructors) are no longer prepended with a + colon when promoted to type families. For instance, the promoted version of + `(&*)` is now called `(&*)` as well, instead of `(:&*)` as before. + + There is one exception to this rule: the `(.)` function, which is promoted + as `(:.)`. The reason is that one cannot write `(.)` at the type level. + * Singletons for infix functions are now always prepended with `%` instead of `%:`. + * Singletons for infix classes are now always prepended with `%` instead of `:%`. + * Singletons for infix datatypes are now always prepended with a `%`. + + (Before, there was an unspoken requirement that singling an infix datatype + required that name to begin with a colon, and the singleton type would begin + with `:%`. But now that infix datatype names can be things like `(+)`, this + requirement became obsolete.) + + The upshot is that most infix names can now be promoted using the same name, and + singled by simply prepending the name with `%`. + +* The suffix for defunctionalized names of symbolic functions (e.g., `(+)`) has + changed. Before, the promoted type name would be suffixed with some number of + dollar signs (e.g., `(+$)` and `(+$$)`) to indicate defunctionalization + symbols. Now, the promoted type name is first suffixed with `@#@` and + _then_ followed by dollar signs (e.g., `(+@#@$)` and `(+@#@$$)`). + Adopting this conventional eliminates naming conflicts that could arise for + functions that consisted of solely `$` symbols. + +* The treatment of `undefined` is less magical. Before, all uses of `undefined` + would be promoted to `GHC.Exts.Any` and singled to `undefined`. Now, there is + a proper `Undefined` type family and `sUndefined` singleton function. + +* As a consequence of not promoting `undefined` to `Any`, there is no need to + have a special `any_` function to distinguish the function on lists. The + corresponding promoted type, singleton function, and defunctionalization + symbols are now named `Any`, `sAny`, and `AnySym{0,1,2}`. + +* Rework the treatment of empty data types: + * Generated `SingKind` instances for empty data types now use `EmptyCase` + instead of simply `error`ing. + * Derived `PEq` instances for empty data types now return `True` instead of + `False`. Derived `SEq` instances now return `True` instead of `error`ing. + * Derived `SDecide` instances for empty data types now return `Proved bottom`, + where `bottom` is a divergent computation, instead of `error`ing. + +* Add `Data.Singletons.Prelude.IsString` and `Data.Promotion.Prelude.IsString` + modules. `IsString.fromString` is now used when promoting or singling + string literals when the `-XOverloadedStrings` extension is enabled + (similarly to how `Num.fromInteger` is currently used when promoting or + singling numeric literals). + +* Add `Data.Singletons.Prelude.Void`. + +* Add promoted and singled versions of `div`, `mod`, `divMod`, `quot`, `rem`, + and `quotRem` to `Data.Singletons.TypeLits` that utilize the efficient `Div` + and `Mod` type families from `GHC.TypeNats`. Also add `sLog2` and + defunctionalization symbols for `Log2` from `GHC.TypeNats`. + +* Add `(<>)` and `(%<>)`, the promoted and singled versions of `AppendSymbol` + from `GHC.TypeLits`. + +* Add `(%^)`, the singleton version of `GHC.TypeLits.^`. + +* Add `unlines` and `unwords` to `Data.Singletons.Prelude.List`. + +* Add promoted and singled versions of `Show`, including `deriving` support. + +* Add a `ShowSing` class, which facilitates the ability to write `Show` instances + for `Sing` instances. + +* Permit derived `Ord` instances for empty datatypes. + +* Permit standalone `deriving` declarations. + +* Permit `DeriveAnyClass` (through the `anyclass` keyword of `DerivingStrategies`) + +* Add a value-level `(@@)`, which is a synonym for `applySing`. + +* Add `Eq`, `Ord`, `Num`, `Enum`, and `Bounded` instances for `SomeSing`, which + leverage the `SEq`, `SOrd`, `SNum`, `SEnum`, and `SBounded` instances, + respectively, for the underlying `Sing`. + +* Rework the `Sing (a :: *)` instance in `Data.Singletons.TypeRepStar` such + that it now uses type-indexed `Typeable`. The new `Sing` instance is now: + + ```haskell + newtype instance Sing :: Type -> Type where + STypeRep :: TypeRep a -> Sing a + ``` + + Accordingly, the `SingKind` instance has also been changed: + + ```haskell + instance SingKind Type where + type Demote Type = SomeTypeRepStar + ... + + data SomeTypeRepStar where + SomeTypeRepStar :: forall (a :: *). !(TypeRep a) -> SomeTypeRepStar + ``` + + Aside from cleaning up some implementation details, this change assures + that `toSing` can only be called on `TypeRep`s whose kind is of kind `*`. + The previous implementation did not enforce this, which could lead to + segfaults if used carelessly. + +* Instead of `error`ing, the `toSing` implementation in the `SingKind (k1 ~> k2)` + instance now works as one would expect (provided the user adheres to some + common-sense `SingKind` laws, which are now documented). + +* Add a `demote` function, which is a convenient shorthand for `fromSing sing`. + +* Add a `Data.Singletons.Sigma` module with a `Sigma` (dependent pair) data type. + +* Export defunctionalization symbols for `Demote`, `SameKind, `KindOf`, `(~>)`, + `Apply`, and `(@@)` from `Data.Singletons`. + +* Add an explicitly bidirectional pattern synonym `Sing`. Pattern + matching on `Sing` brings a `SingI ty` constraint into scope from a + singleton `Sing ty`. + +* Add an explicitly bidirectional pattern synonym `FromSing`. Pattern + matching on any demoted (base) type gives us the corresponding + singleton. + +* Add explicitly bidirectional pattern synonyms + `SLambda{2..8}`. Pattern matching on any defunctionalized singleton + yields a term-level Haskell function on singletons. + +* Remove the family of `TyCon1`, `TyCon2`, ..., in favor of just `TyCon`. + GHC 8.4's type system is powerful enough to allow this nice simplification. 2.3 --- 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,591 +1,24 @@ -singletons 2.3.1 -================ - -[![Build Status](https://travis-ci.org/goldfirere/singletons.svg?branch=master)](https://travis-ci.org/goldfirere/singletons) - -This is the README file for the singletons library. This file contains all the -documentation for the definitions and functions in the library. - -The singletons library was written by Richard Eisenberg, , and -with significant contributions by Jan Stolarek, . There -are two papers that describe the library. Original one, _Dependently typed -programming with singletons_, is available -[here](http://www.cis.upenn.edu/~eir/papers/2012/singletons/paper.pdf) and will -be referenced in this documentation as the "singletons paper". A follow-up -paper, _Promoting Functions to Type Families in Haskell_, is available -[here](http://www.cis.upenn.edu/~eir/papers/2014/promotion/promotion.pdf) -and will be referenced in this documentation as the -"promotion paper". - -Ryan Scott, , is an active maintainer. - -Purpose of the singletons library ---------------------------------- - -The library contains a definition of _singleton types_, which allow programmers -to use dependently typed techniques to enforce rich constraints among the types -in their programs. See the singletons paper for a more thorough introduction. - -The package also allows _promotion_ of term-level functions to type-level -equivalents. Accordingly, it exports a Prelude of promoted and singletonized -functions, mirroring functions and datatypes found in Prelude, `Data.Bool`, -`Data.Maybe`, `Data.Either`, `Data.Tuple` and `Data.List`. See the promotion -paper for a more thorough introduction. - -Compatibility -------------- - -The singletons library requires GHC 8.2.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: - -* `ScopedTypeVariables` -* `TemplateHaskell` -* `TypeFamilies` -* `GADTs` -* `KindSignatures` -* `TypeOperators` -* `FlexibleContexts` -* `RankNTypes` -* `UndecidableInstances` -* `FlexibleInstances` -* `InstanceSigs` -* `DefaultSignatures` -* `TypeInType` - -You may also want - -* `-Wno-redundant-constraints` - -as the code that `singletons` generates uses redundant constraints, and there -seems to be no way, without a large library redesign, to avoid this. - -Modules for singleton types ---------------------------- - -`Data.Singletons` exports all the basic singletons definitions. Import this -module if you are not using Template Haskell and wish only to define your -own singletons. - -`Data.Singletons.TH` exports all the definitions needed to use the Template -Haskell code to generate new singletons. - -`Data.Singletons.Prelude` re-exports `Data.Singletons` along with singleton -definitions for various Prelude types. This module provides a singletonized -equivalent of the real `Prelude`. Note that not all functions from original -`Prelude` could be turned into singletons. - -`Data.Singletons.Prelude.*` modules provide singletonized equivalents of -definitions found in the following `base` library modules: `Data.Bool`, -`Data.Maybe`, `Data.Either`, `Data.List`, `Data.Tuple` and `GHC.Base`. We also -provide singletonized `Eq` and `Ord` typeclasses - -`Data.Singletons.Decide` exports type classes for propositional equality. - -`Data.Singletons.TypeLits` exports definitions for working with `GHC.TypeLits`. - -`Data.Singletons.Void` exports a `Void` type, shamelessly copied from -Edward Kmett's `void` package, but without the great many package dependencies -in `void`. - -Modules for function promotion ------------------------------- - -Modules in `Data.Promotion` namespace provide functionality required for -function promotion. They mostly re-export a subset of definitions from -respective `Data.Singletons` modules. - -`Data.Promotion.TH` exports all the definitions needed to use the Template -Haskell code to generate promoted definitions. - -`Data.Promotion.Prelude` and `Data.Promotion.Prelude.*` modules re-export all -promoted definitions from respective `Data.Singletons.Prelude` -modules. `Data.Promotion.Prelude.List` adds a significant amount of functions -that couldn't be singletonized but can be promoted. Some functions still don't -promote - these are documented in the source code of the module. There is also -`Data.Promotion.Prelude.Bounded` module that provides promoted `PBounded` -typeclass. - -Functions to generate singletons --------------------------------- - -The top-level functions used to generate singletons are documented in the -`Data.Singletons.TH` module. The most common case is just calling `singletons`, -which I'll describe here: - - singletons :: Q [Dec] -> Q [Dec] - -Generates singletons from the definitions given. Because singleton generation -requires promotion, this also promotes all of the definitions given to the -type level. - -Usage example: - -```haskell -$(singletons [d| - data Nat = Zero | Succ Nat - pred :: Nat -> Nat - pred Zero = Zero - pred (Succ n) = n - |]) -``` - -Definitions used to support singletons --------------------------------------- - -Please refer to the singletons paper for a more in-depth explanation of these -definitions. Many of the definitions were developed in tandem with Iavor Diatchki. - - data family Sing (a :: k) - -The data family of singleton types. A new instance of this data family is -generated for every new singleton type. - - class SingI (a :: k) where - sing :: Sing a - -A class used to pass singleton values implicitly. The `sing` method produces -an explicit singleton value. - - data SomeSing 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`. - - 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`. - - data SingInstance (a :: k) where - SingInstance :: SingI a => SingInstance a - singInstance :: Sing a -> SingInstance a - -Sometimes you have an explicit singleton (a `Sing`) where you need an implicit -one (a dictionary for `SingI`). The `SingInstance` type simply wraps a `SingI` -dictionary, and the `singInstance` function produces this dictionary from an -explicit singleton. The `singInstance` function runs in constant time, using -a little magic. - - -Equality classes ----------------- - -There are two different notions of equality applicable to singletons: Boolean -equality and propositional equality. - -* Boolean equality is implemented in the type family `(:==)` (which is actually -a synonym for the type family `(==)` from `Data.Type.Equality`) and the class -`SEq`. See the `Data.Singletons.Prelude.Eq` module for more information. - -* Propositional equality is implemented through the constraint `(~)`, the type -`(:~:)`, and the class `SDecide`. See modules `Data.Type.Equality` and -`Data.Singletons.Decide` for more information. - -Which one do you need? That depends on your application. Boolean equality has -the advantage that your program can take action when two types do _not_ equal, -while propositional equality has the advantage that GHC can use the equality -of types during type inference. - -Instances of both `SEq` and `SDecide` are generated when `singletons` is called -on a datatype that has `deriving Eq`. You can also generate these instances -directly through functions exported from `Data.Singletons.TH`. - - -Pre-defined singletons ----------------------- - -The singletons library defines a number of singleton types and functions -by default: - -* `Bool` -* `Maybe` -* `Either` -* `Ordering` -* `()` -* tuples up to length 7 -* lists - -These are all available through `Data.Singletons.Prelude`. Functions that -operate on these singletons are available from modules such as `Data.Singletons.Bool` -and `Data.Singletons.Maybe`. - -Promoting functions -------------------- - -Function promotion allows to generate type-level equivalents of term-level -definitions. Almost all Haskell source constructs are supported -- see last -section of this README for a full list. - -Promoted definitions are usually generated by calling `promote` function: - -```haskell -$(promote [d| - data Nat = Zero | Succ Nat - pred :: Nat -> Nat - pred Zero = Zero - pred (Succ n) = n - |]) -``` - -Every promoted function and data constructor definition comes with a set of -so-called "symbols". These are required to represent partial application at the -type level. Each function gets N+1 symbols, where N is the arity. Symbols -represent application of between 0 to N arguments. When calling any of the -promoted definitions it is important refer to it using their symbol -name. Moreover, there is new function application at the type level represented -by `Apply` type family. Symbol representing arity X can have X arguments passed -in using normal function application. All other parameters must be passed by -calling `Apply`. - -Users also have access to `Data.Promotion.Prelude` and its submodules (`Base`, -`Bool`, `Either`, `List`, `Maybe` and `Tuple`). These provide promoted versions -of function found in GHC's base library. - -Note that GHC resolves variable names in Template Haskell quotes. You cannot -then use an undefined identifier in a quote, making idioms like this not -work: -```haskell -type family Foo a where ... -$(promote [d| ... foo x ... |]) -``` -In this example, `foo` would be out of scope. - -Refer to the promotion paper for more details on function promotion. - -Classes and instances ---------------------- - -This is best understood by example. Let's look at a stripped down `Ord`: - -```haskell -class Eq a => Ord a where - compare :: a -> a -> Ordering - (<) :: a -> a -> Bool - x < y = case x `compare` y of - LT -> True - EQ -> False - GT -> False -``` - -This class gets promoted to a "kind class" thus: - -```haskell -class PEq a => POrd a where - type Compare (x :: a) (y :: a) :: Ordering - type (:<) (x :: a) (y :: a) :: Bool - type x :< y = ... -- promoting `case` is yucky. -``` - -Note that default method definitions become default associated type family -instances. This works out quite nicely. - -We also get this singleton class: - -```haskell -class SEq a => SOrd a where - sCompare :: forall (x :: a) (y :: a). Sing x -> Sing y -> Sing (Compare x y) - (%:<) :: forall (x :: a) (y :: a). Sing x -> Sing y -> Sing (x :< y) - - default (%:<) :: forall (x :: a) (y :: a). - ((x :< y) ~ {- RHS from (:<) above -}) - => Sing x -> Sing y -> Sing (x :< y) - x %:< y = ... -- this is a bit yucky too -``` - -Note that a singletonized class needs to use `default` signatures, because -type-checking the default body requires that the default associated type -family instance was used in the promoted class. The extra equality constraint -on the default signature asserts this fact to the type checker. - -Instances work roughly similarly. - -```haskell -instance Ord Bool where - compare False False = EQ - compare False True = LT - compare True False = GT - compare True True = EQ - -instance POrd Bool where - type Compare 'False 'False = 'EQ - type Compare 'False 'True = 'LT - type Compare 'True 'False = 'GT - type Compare 'True 'True = 'EQ - -instance SOrd Bool where - sCompare :: forall (x :: a) (y :: a). Sing x -> Sing y -> Sing (Compare x y) - sCompare SFalse SFalse = SEQ - sCompare SFalse STrue = SLT - sCompare STrue SFalse = SGT - sCompare STrue STrue = SEQ -``` - -The only interesting bit here is the instance signature. It's not necessary -in such a simple scenario, but more complicated functions need to refer to -scoped type variables, which the instance signature can bring into scope. -The defaults all just work. - -On names --------- - -The singletons library has to produce new names for the new constructs it -generates. Here are some examples showing how this is done: - -1. original datatype: `Nat` - - promoted kind: `Nat` - - singleton type: `SNat` (which is really a synonym for `Sing`) - - -2. original datatype: `:/\:` - - promoted kind: `:/\:` - - singleton type: `:%/\:` - - - -3. original constructor: `Succ` - - promoted type: `'Succ` (you can use `Succ` when unambiguous) - - singleton constructor: `SSucc` - - symbols: `SuccSym0`, `SuccSym1` - - -4. original constructor: `:+:` - - promoted type: `':+:` - - singleton constructor: `:%+:` - - symbols: `:+:$`, `:+:$$`, `:+:$$$` - - -5. original value: `pred` - - promoted type: `Pred` - - singleton value: `sPred` - - symbols: `PredSym0`, `PredSym1` - - -6. original value: `+` - - promoted type: `:+` - - singleton value: `%:+` - - symbols: `:+$`, `:+$$`, `:+$$$` - - -7. original class: `Num` - - promoted class: `PNum` - - singleton class: `SNum` - - -8. original class: `~>` - - promoted class: `#~>` - - singleton class: `:%~>` - - -Special names -------------- - -There are some special cases: - -1. original datatype: `[]` - - singleton type: `SList` - - -2. original constructor: `[]` - - promoted type: `'[]` - - singleton constructor: `SNil` - - symbols: `NilSym0` - - -3. original constructor: `:` - - promoted type: `':` - - singleton constructr: `SCons` - - symbols: `ConsSym0`, `ConsSym1` - - -4. original datatype: `(,)` - - singleton type: `STuple2` - - -5. original constructor: `(,)` - - promoted type: `'(,)` - - singleton constructor: `STuple2` - - symbols: `Tuple2Sym0`, `Tuple2Sym1`, `Tuple2Sym2` - - All tuples (including the 0-tuple, unit) are treated similarly. - -6. original value: `undefined` - - promoted type: `Any` - - singleton value: `undefined` - - -Supported Haskell constructs ----------------------------- - -The following constructs are fully supported: - -* variables -* tuples -* constructors -* if statements -* infix expressions -* `_` patterns -* aliased patterns -* lists -* sections -* undefined -* error -* deriving `Eq`, `Ord`, `Bounded`, and `Enum` -* class constraints (though these sometimes fail with `let`, `lambda`, and `case`) -* literals (for `Nat` and `Symbol`), including overloaded number literals -* unboxed tuples (which are treated as normal tuples) -* records -* pattern guards -* case -* let -* lambda expressions -* `!` and `~` patterns (silently but successfully ignored during promotion) -* class and instance declarations -* higher-kinded type variables (see below) -* functional dependencies (with limitations -- see below) - -Higher-kinded type variables in `class`/`data` declarations must be annotated -explicitly. This is due to GHC's handling of *complete -user-specified kind signatures*, or [CUSKs](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#complete-user-supplied-kind-signatures-and-polymorphic-recursion). -Briefly, `singletons` has a hard -time conforming to the precise rules that GHC imposes around CUSKs and so -needs a little help around kind inference here. See -[this pull request](https://github.com/goldfirere/singletons/pull/171) for more -background. - -The following constructs are supported for promotion but not singleton generation: - -* scoped type variables -* overlapping patterns. Note that overlapping patterns are - sometimes not obvious. For example, the `filter` function does not - singletonize due - to overlapping patterns: -```haskell -filter :: (a -> Bool) -> [a] -> [a] -filter _pred [] = [] -filter pred (x:xs) - | pred x = x : filter pred xs - | otherwise = filter pred xs -``` -Overlap is caused by `otherwise` catch-all guard, which is always true and thus -overlaps with `pred x` guard. - -The following constructs are not supported: - -* list comprehensions -* do -* arithmetic sequences -* datatypes that store arrows, `Nat`, or `Symbol` -* literals (limited support) -* symbolic (as opposed to alphanumeric) types - -Why are these out of reach? The first two depend on monads, which mention a -higher-kinded type variable. GHC did not support higher-sorted kind variables, -which are be necessary to promote/singletonize monads, and `singletons` has -not be rewritten to accommodate this new ability. [This bug -report](https://github.com/goldfirere/singletons/issues/37) is a feature request -looking for support for these constructs. - -Arithmetic sequences are defined using `Enum` typeclass, which uses infinite -lists. - -As described in the promotion paper, promotion of datatypes that store arrows is -currently impossible. So if you have a declaration such as - - data Foo = Bar (Bool -> Maybe Bool) - -you will quickly run into errors. - -Literals are problematic because we rely on GHC's built-in support, which -currently is limited. Functions that operate on strings will not work because -type level strings are no longer considered lists of characters. Function -working on integer literals can be promoted by rewriting them to use -`Nat`. Since `Nat` does not exist at the term level it will only be possible to -use the promoted definition, but not the original, term-level one. - -This is the same line of reasoning that forbids the use of `Nat` or `Symbol` -in datatype definitions. But, see [this bug -report](https://github.com/goldfirere/singletons/issues/76) for a workaround. - -Symbolic types used in kinds were not supported in GHC, but now are. However, -`singletons` still does not support them, mostly because of challenges around -telling datacon names apart from tycon names. [This -issue](https://github.com/goldfirere/singletons/issues/163) tracks adding -this feature. - -Support for `*` ---------------- - -The built-in Haskell promotion mechanism does not yet have a full story around -the kind `*` (the kind of types that have values). Ideally, promoting some form -of `TypeRep` would yield `*`, but the implementation of TypeRep would have to be -updated for this to really work out. In the meantime, users who wish to -experiment with this feature have two options: - -1) The module `Data.Singletons.TypeRepStar` has all the definitions possible for -making `*` the promoted version of `TypeRep`, as `TypeRep` is currently implemented. -The singleton associated with `TypeRep` has one constructor: +`singletons` +============ - data instance Sing (a :: *) where - STypeRep :: Typeable a => Sing a +[![Hackage](https://img.shields.io/hackage/v/singletons.svg)](http://hackage.haskell.org/package/singletons) -Thus, an implicit `TypeRep` is stored in the singleton constructor. However, -any datatypes that store `TypeRep`s will not generally work as expected; the -built-in promotion mechanism will not promote `TypeRep` to `*`. +`singletons` contains the basic types and definitions needed to support +dependently typed programming techniques in Haskell. This library was +originally presented in +[_Dependently Typed Programming with Singletons_](https://richarde.dev/papers/2012/singletons/paper.pdf), +published at the Haskell Symposium, 2012. -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. +`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). -Known bugs ----------- +You may also be interested in the following related libraries: -* Record updates don't singletonize -* Inference dependent on functional dependencies is unpredictably bad. The - problem is that a use of an associated type family tied to a class with - fundeps doesn't provoke the fundep to kick in. This is GHC's problem, in - the end. +* 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/singletons.cabal b/singletons.cabal --- a/singletons.cabal +++ b/singletons.cabal @@ -1,132 +1,82 @@ name: singletons -version: 2.3.1 - -- Remember to bump version in the Makefile as well -cabal-version: >= 1.10 -synopsis: A framework for generating singleton types +version: 3.0.4 +cabal-version: 1.24 +synopsis: Basic singleton types and definitions homepage: http://www.github.com/goldfirere/singletons category: Dependent Types author: Richard Eisenberg , Jan Stolarek -maintainer: Richard Eisenberg , Jan Stolarek +maintainer: Ryan Scott bug-reports: https://github.com/goldfirere/singletons/issues stability: experimental -tested-with: GHC == 8.2.1 -extra-source-files: README.md, CHANGES.md, - tests/compile-and-dump/buildGoldenFiles.awk, - tests/compile-and-dump/GradingClient/*.hs, - tests/compile-and-dump/InsertionSort/*.hs, - tests/compile-and-dump/Promote/*.hs, - tests/compile-and-dump/Singletons/*.hs - tests/compile-and-dump/GradingClient/*.ghc82.template, - tests/compile-and-dump/InsertionSort/*.ghc82.template, - tests/compile-and-dump/Promote/*.ghc82.template, - tests/compile-and-dump/Singletons/*.ghc82.template +tested-with: GHC == 8.0.2 + , GHC == 8.2.2 + , GHC == 8.4.4 + , GHC == 8.6.5 + , GHC == 8.8.4 + , GHC == 8.10.7 + , GHC == 9.0.2 + , GHC == 9.2.7 + , GHC == 9.4.8 + , GHC == 9.6.6 + , GHC == 9.8.2 + , GHC == 9.10.1 + , GHC == 9.12.1 +extra-source-files: README.md, CHANGES.md license: BSD3 license-file: LICENSE build-type: Simple description: - This library generates singleton types, promoted functions, and singleton - functions using Template Haskell. It is useful for programmers who wish - to use dependently typed programming techniques. The library was originally - presented in /Dependently Typed Programming with Singletons/, published - at the Haskell Symposium, 2012. - () - - Version 1.0 and onwards works a lot harder to promote functions. See the - paper published at Haskell Symposium, 2014: - . + @singletons@ contains the basic types and definitions needed to support + dependently typed programming techniques in Haskell. This library was + originally presented in /Dependently Typed Programming with Singletons/, + published at the Haskell Symposium, 2012. + () + . + @singletons@ is intended to be a small, foundational library on which other + projects can build. As such, @singletons@ has a minimal dependency + footprint and supports GHCs dating back to GHC 8.0. For more information, + consult the @singletons@ + @@. + . + You may also be interested in the following related libraries: + . + * The @singletons-th@ library defines Template Haskell functionality that + allows /promotion/ of term-level functions to type-level equivalents and + /singling/ functions to dependently typed equivalents. + . + * The @singletons-base@ library uses @singletons-th@ to define promoted and + singled functions from the @base@ library, including the "Prelude". source-repository this type: git location: https://github.com/goldfirere/singletons.git - tag: v2.3.1 + subdir: singletons + tag: v3.0.2 +source-repository head + type: git + location: https://github.com/goldfirere/singletons.git + subdir: singletons + branch: master + library hs-source-dirs: src - build-depends: base >= 4.10 && < 5, - mtl >= 2.1.2, - template-haskell, - containers >= 0.5, - th-desugar >= 1.7 && < 1.8, - syb >= 0.4, - text >= 1.2 + build-depends: base >= 4.9 && < 4.22 default-language: Haskell2010 - other-extensions: TemplateHaskell - -- TemplateHaskell must be listed in cabal file to work with - -- ghc7.8+ - - exposed-modules: Data.Singletons, - Data.Singletons.CustomStar, - Data.Singletons.TypeRepStar, - Data.Singletons.TH, - Data.Singletons.Prelude, - Data.Singletons.Prelude.Base, - Data.Singletons.Prelude.Bool, - Data.Singletons.Prelude.Either, - Data.Singletons.Prelude.Enum, - Data.Singletons.Prelude.Eq, - Data.Singletons.Prelude.Function, - Data.Singletons.Prelude.Ord, - Data.Singletons.Prelude.List, - Data.Singletons.Prelude.List.NonEmpty, - Data.Singletons.Prelude.Maybe, - Data.Singletons.Prelude.Num - Data.Singletons.Prelude.Tuple, - Data.Promotion.Prelude, - Data.Promotion.TH, - Data.Promotion.Prelude.Base, - Data.Promotion.Prelude.Bool, - Data.Promotion.Prelude.Either, - Data.Promotion.Prelude.Eq, - Data.Promotion.Prelude.Function, - Data.Promotion.Prelude.Ord, - Data.Promotion.Prelude.Enum, - Data.Promotion.Prelude.List, - Data.Promotion.Prelude.List.NonEmpty, - Data.Promotion.Prelude.Maybe, - Data.Promotion.Prelude.Num, - Data.Promotion.Prelude.Tuple, - Data.Singletons.TypeLits, - Data.Singletons.Decide, - Data.Singletons.SuppressUnusedWarnings - - other-modules: Data.Singletons.Deriving.Infer, - Data.Singletons.Deriving.Bounded, - Data.Singletons.Deriving.Enum, - Data.Singletons.Deriving.Ord, - Data.Singletons.Prelude.List.NonEmpty.Internal, - Data.Singletons.Promote, - Data.Singletons.Promote.Monad, - Data.Singletons.Promote.Eq, - Data.Singletons.Promote.Type, - Data.Singletons.Promote.Defun, - Data.Singletons.Util, - Data.Singletons.Partition, - Data.Singletons.Prelude.Instances, - Data.Singletons.Names, - Data.Singletons.Single.Monad, - Data.Singletons.Single.Type, - Data.Singletons.Single.Eq, - Data.Singletons.Single.Data, - Data.Singletons.Single.Fixity, - Data.Singletons.Single, - Data.Singletons.TypeLits.Internal, - Data.Singletons.Syntax - - ghc-options: -Wall -Wno-redundant-constraints + exposed-modules: Data.Singletons + Data.Singletons.Decide + Data.Singletons.ShowSing + Data.Singletons.Sigma + ghc-options: -Wall test-suite singletons-test-suite type: exitcode-stdio-1.0 - hs-source-dirs: src, tests - ghc-options: -Wall + hs-source-dirs: tests + ghc-options: -Wall -threaded default-language: Haskell2010 main-is: SingletonsTestSuite.hs - other-modules: SingletonsTestSuiteUtils + other-modules: ByHand + ByHand2 - build-depends: base >= 4.10 && < 5, - filepath >= 1.3, - process >= 1.1, - singletons, - tasty >= 0.6, - tasty-golden >= 2.2, - Cabal >= 2.0, - directory >= 1 + build-depends: base >= 4.9 && < 4.22, + singletons diff --git a/src/Data/Promotion/Prelude.hs b/src/Data/Promotion/Prelude.hs deleted file mode 100644 --- a/src/Data/Promotion/Prelude.hs +++ /dev/null @@ -1,164 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Promotion.Prelude --- Copyright : (C) 2014 Jan Stolarek --- License : BSD-style (see LICENSE) --- Maintainer : Jan Stolarek (jan.stolarek@p.lodz.pl) --- Stability : experimental --- Portability : non-portable --- --- Mimics the Haskell Prelude, but with promoted types. --- ----------------------------------------------------------------------------- - -{-# LANGUAGE ExplicitNamespaces #-} -module Data.Promotion.Prelude ( - -- * Standard types, classes and related functions - -- ** Basic data types - If, Not, (:&&), (:||), Otherwise, - - maybe_, Maybe_, either_, Either_, - - Symbol, - - Fst, Snd, Curry, Uncurry, - - -- * Error reporting - Error, ErrorSym0, - - -- * Promoted equality - module Data.Promotion.Prelude.Eq, - - -- * Promoted comparisons - module Data.Promotion.Prelude.Ord, - - -- * Promoted enumerations - -- | As a matter of convenience, the promoted Prelude does /not/ export - -- promoted @succ@ and @pred@, due to likely conflicts with - -- unary numbers. Please import 'Data.Promotion.Prelude.Enum' directly if - -- you want these. - module Data.Promotion.Prelude.Enum, - - -- * Promoted numbers - module Data.Promotion.Prelude.Num, - - -- ** Miscellaneous functions - Id, Const, (:.), type ($), type ($!), Flip, AsTypeOf, Until, Seq, - - -- * List operations - Map, (:++), Filter, - Head, Last, Tail, Init, Null, Length, (:!!), - Reverse, - -- ** Reducing lists (folds) - Foldl, Foldl1, Foldr, Foldr1, - -- *** Special folds - And, Or, any_, Any_, All, - Sum, Product, - Concat, ConcatMap, - Maximum, Minimum, - -- ** Building lists - -- *** Scans - Scanl, Scanl1, Scanr, Scanr1, - -- *** Infinite lists - Replicate, - -- ** Sublists - Take, Drop, SplitAt, - TakeWhile, DropWhile, Span, Break, - - -- ** Searching lists - Elem, NotElem, Lookup, - -- ** Zipping and unzipping lists - Zip, Zip3, ZipWith, ZipWith3, Unzip, Unzip3, - - -- * Defunctionalization symbols - FalseSym0, TrueSym0, - NotSym0, NotSym1, (:&&$), (:&&$$), (:&&$$$), (:||$), (:||$$), (:||$$$), - OtherwiseSym0, - - NothingSym0, JustSym0, JustSym1, - Maybe_Sym0, Maybe_Sym1, Maybe_Sym2, Maybe_Sym3, - - LeftSym0, LeftSym1, RightSym0, RightSym1, - Either_Sym0, Either_Sym1, Either_Sym2, Either_Sym3, - - Tuple0Sym0, - Tuple2Sym0, Tuple2Sym1, Tuple2Sym2, - Tuple3Sym0, Tuple3Sym1, Tuple3Sym2, Tuple3Sym3, - Tuple4Sym0, Tuple4Sym1, Tuple4Sym2, Tuple4Sym3, Tuple4Sym4, - Tuple5Sym0, Tuple5Sym1, Tuple5Sym2, Tuple5Sym3, Tuple5Sym4, Tuple5Sym5, - Tuple6Sym0, Tuple6Sym1, Tuple6Sym2, Tuple6Sym3, Tuple6Sym4, Tuple6Sym5, Tuple6Sym6, - Tuple7Sym0, Tuple7Sym1, Tuple7Sym2, Tuple7Sym3, Tuple7Sym4, Tuple7Sym5, Tuple7Sym6, Tuple7Sym7, - FstSym0, FstSym1, SndSym0, SndSym1, - CurrySym0, CurrySym1, CurrySym2, CurrySym3, - UncurrySym0, UncurrySym1, UncurrySym2, - - (:^$), (:^$$), - - IdSym0, IdSym1, ConstSym0, ConstSym1, ConstSym2, - (:.$), (:.$$), (:.$$$), - type ($$), type ($$$), type ($$$$), - type ($!$), type ($!$$), type ($!$$$), - FlipSym0, FlipSym1, FlipSym2, - AsTypeOfSym0, AsTypeOfSym1, AsTypeOfSym2, SeqSym0, SeqSym1, SeqSym2, - - (:$), (:$$), (:$$$), NilSym0, - MapSym0, MapSym1, MapSym2, ReverseSym0, ReverseSym1, - (:++$$), (:++$), HeadSym0, HeadSym1, LastSym0, LastSym1, - TailSym0, TailSym1, InitSym0, InitSym1, NullSym0, NullSym1, - - FoldlSym0, FoldlSym1, FoldlSym2, FoldlSym3, - Foldl1Sym0, Foldl1Sym1, Foldl1Sym2, - FoldrSym0, FoldrSym1, FoldrSym2, FoldrSym3, - Foldr1Sym0, Foldr1Sym1, Foldr1Sym2, - - ConcatSym0, ConcatSym1, - ConcatMapSym0, ConcatMapSym1, ConcatMapSym2, - MaximumBySym0, MaximumBySym1, MaximumBySym2, - MinimumBySym0, MinimumBySym1, MinimumBySym2, - AndSym0, AndSym1, OrSym0, OrSym1, - Any_Sym0, Any_Sym1, Any_Sym2, - AllSym0, AllSym1, AllSym2, - - ScanlSym0, ScanlSym1, ScanlSym2, ScanlSym3, - Scanl1Sym0, Scanl1Sym1, Scanl1Sym2, - ScanrSym0, ScanrSym1, ScanrSym2, ScanrSym3, - Scanr1Sym0, Scanr1Sym1, Scanr1Sym2, - - ElemSym0, ElemSym1, ElemSym2, - NotElemSym0, NotElemSym1, NotElemSym2, - - ZipSym0, ZipSym1, ZipSym2, - Zip3Sym0, Zip3Sym1, Zip3Sym2, Zip3Sym3, - ZipWithSym0, ZipWithSym1, ZipWithSym2, ZipWithSym3, - ZipWith3Sym0, ZipWith3Sym1, ZipWith3Sym2, ZipWith3Sym3, - UnzipSym0, UnzipSym1, - - UntilSym0, UntilSym1, UntilSym2, UntilSym3, - LengthSym0, LengthSym1, - SumSym0, SumSym1, - ProductSym0, ProductSym1, - ReplicateSym0, ReplicateSym1, ReplicateSym2, - TakeSym0, TakeSym1, TakeSym2, - DropSym0, DropSym1, DropSym2, - SplitAtSym0, SplitAtSym1, SplitAtSym2, - TakeWhileSym0, TakeWhileSym1, TakeWhileSym2, - DropWhileSym0, DropWhileSym1, DropWhileSym2, - SpanSym0, SpanSym1, SpanSym2, - BreakSym0, BreakSym1, BreakSym2, - LookupSym0, LookupSym1, LookupSym2, - FilterSym0, FilterSym1, FilterSym2, - (:!!$), (:!!$$), (:!!$$$), - ) where - -import Data.Promotion.Prelude.Base -import Data.Promotion.Prelude.Bool -import Data.Promotion.Prelude.Either -import Data.Promotion.Prelude.List -import Data.Promotion.Prelude.Maybe -import Data.Promotion.Prelude.Tuple -import Data.Promotion.Prelude.Eq -import Data.Promotion.Prelude.Ord -import Data.Promotion.Prelude.Enum - hiding (Succ, Pred, SuccSym0, SuccSym1, PredSym0, PredSym1) -import Data.Promotion.Prelude.Num -import Data.Singletons.TypeLits diff --git a/src/Data/Promotion/Prelude/Base.hs b/src/Data/Promotion/Prelude/Base.hs deleted file mode 100644 --- a/src/Data/Promotion/Prelude/Base.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE TemplateHaskell, KindSignatures, PolyKinds, TypeOperators, - DataKinds, ScopedTypeVariables, TypeFamilies, GADTs, - UndecidableInstances #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Promotion.Prelude.Base --- Copyright : (C) 2014 Jan Stolarek --- License : BSD-style (see LICENSE) --- Maintainer : Jan Stolarek (jan.stolarek@p.lodz.pl) --- Stability : experimental --- Portability : non-portable --- --- Implements promoted functions from GHC.Base module. --- --- Because many of these definitions are produced by Template Haskell, --- it is not possible to create proper Haddock documentation. Please look --- up the corresponding operation in @Prelude@. Also, please excuse --- the apparent repeated variable names. This is due to an interaction --- between Template Haskell and Haddock. --- ----------------------------------------------------------------------------- - -module Data.Promotion.Prelude.Base ( - -- * Promoted functions from @GHC.Base@ - Foldr, Map, (:++), Otherwise, Id, Const, (:.), type ($), type ($!), - Flip, Until, AsTypeOf, Seq, - - -- * Defunctionalization symbols - FoldrSym0, FoldrSym1, FoldrSym2, FoldrSym3, - MapSym0, MapSym1, MapSym2, - (:++$), (:++$$), (:++$$$), - OtherwiseSym0, - IdSym0, IdSym1, - ConstSym0, ConstSym1, ConstSym2, - (:.$), (:.$$), (:.$$$), (:.$$$$), - type ($$), type ($$$), type ($$$$), - type ($!$), type ($!$$), type ($!$$$), - FlipSym0, FlipSym1, FlipSym2, FlipSym3, - UntilSym0, UntilSym1, UntilSym2, UntilSym3, - AsTypeOfSym0, AsTypeOfSym1, AsTypeOfSym2, - SeqSym0, SeqSym1, SeqSym2 - ) where - -import Data.Singletons.TH -import Data.Singletons.Prelude.Base - -$(promoteOnly [d| - -- Does not singletoznize. See #30 - until :: (a -> Bool) -> (a -> a) -> a -> a - until p f = go - where - go x | p x = x - | otherwise = go (f x) - |]) diff --git a/src/Data/Promotion/Prelude/Bool.hs b/src/Data/Promotion/Prelude/Bool.hs deleted file mode 100644 --- a/src/Data/Promotion/Prelude/Bool.hs +++ /dev/null @@ -1,42 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Promotion.Prelude.Bool --- Copyright : (C) 2014 Jan Stolarek --- License : BSD-style (see LICENSE) --- Maintainer : Jan Stolarek (jan.stolarek@p.lodz.pl) --- Stability : experimental --- Portability : non-portable --- --- Defines promoted functions and datatypes relating to 'Bool', --- including a promoted version of all the definitions in @Data.Bool@. --- --- Because many of these definitions are produced by Template Haskell, --- it is not possible to create proper Haddock documentation. Please look --- up the corresponding operation in @Data.Bool@. Also, please excuse --- the apparent repeated variable names. This is due to an interaction --- between Template Haskell and Haddock. --- ----------------------------------------------------------------------------- - -module Data.Promotion.Prelude.Bool ( - If, - - -- * Promoted functions from @Data.Bool@ - Bool_, bool_, - -- | The preceding two definitions are derived from the function 'bool' in - -- @Data.Bool@. The extra underscore is to avoid name clashes with the type - -- 'Bool'. - - Not, (:&&), (:||), Otherwise, - - -- * Defunctionalization symbols - TrueSym0, FalseSym0, - - NotSym0, NotSym1, - (:&&$), (:&&$$), (:&&$$$), - (:||$), (:||$$), (:||$$$), - Bool_Sym0, Bool_Sym1, Bool_Sym2, Bool_Sym3, - OtherwiseSym0 - ) where - -import Data.Singletons.Prelude.Bool diff --git a/src/Data/Promotion/Prelude/Either.hs b/src/Data/Promotion/Prelude/Either.hs deleted file mode 100644 --- a/src/Data/Promotion/Prelude/Either.hs +++ /dev/null @@ -1,38 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Promotion.Prelude.Either --- Copyright : (C) 2014 Jan Stolarek --- License : BSD-style (see LICENSE) --- Maintainer : jan.stolarek@p.lodz.pl --- Stability : experimental --- Portability : non-portable --- --- Defines promoted functions and datatypes relating to 'Either', --- including a promoted version of all the definitions in @Data.Either@. --- --- Because many of these definitions are produced by Template Haskell, --- it is not possible to create proper Haddock documentation. Please look --- up the corresponding operation in @Data.Either@. Also, please excuse --- the apparent repeated variable names. This is due to an interaction --- between Template Haskell and Haddock. --- ----------------------------------------------------------------------------- - -module Data.Promotion.Prelude.Either ( - -- * Promoted functions from @Data.Either@ - either_, Either_, - -- | The preceding two definitions are derived from the function 'either' in - -- @Data.Either@. The extra underscore is to avoid name clashes with the type - -- 'Either'. - - Lefts, Rights, PartitionEithers, IsLeft, IsRight, - - -- * Defunctionalization symbols - LeftSym0, LeftSym1, RightSym0, RightSym1, - - Either_Sym0, Either_Sym1, Either_Sym2, Either_Sym3, - LeftsSym0, LeftsSym1, RightsSym0, RightsSym1, - IsLeftSym0, IsLeftSym1, IsRightSym0, IsRightSym1 - ) where - -import Data.Singletons.Prelude.Either diff --git a/src/Data/Promotion/Prelude/Enum.hs b/src/Data/Promotion/Prelude/Enum.hs deleted file mode 100644 --- a/src/Data/Promotion/Prelude/Enum.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE TemplateHaskell, PolyKinds, DataKinds, TypeFamilies, - UndecidableInstances, GADTs #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Promotion.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 --- --- Exports promoted versions of 'Enum' and 'Bounded' --- ------------------------------------------------------------------------------ - -module Data.Promotion.Prelude.Enum ( - PBounded(..), PEnum(..), - - -- ** Defunctionalization symbols - MinBoundSym0, - MaxBoundSym0, - SuccSym0, SuccSym1, - PredSym0, PredSym1, - ToEnumSym0, ToEnumSym1, - FromEnumSym0, FromEnumSym1, - EnumFromToSym0, EnumFromToSym1, EnumFromToSym2, - EnumFromThenToSym0, EnumFromThenToSym1, EnumFromThenToSym2, - EnumFromThenToSym3 - ) where - -import Data.Singletons.Prelude.Enum diff --git a/src/Data/Promotion/Prelude/Eq.hs b/src/Data/Promotion/Prelude/Eq.hs deleted file mode 100644 --- a/src/Data/Promotion/Prelude/Eq.hs +++ /dev/null @@ -1,19 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Promotion.Prelude.Eq --- Copyright : (C) 2014 Jan Stolarek --- License : BSD-style (see LICENSE) --- Maintainer : Jan Stolarek (jan.stolarek@p.lodz.pl) --- Stability : experimental --- Portability : non-portable --- --- Provided promoted definitions related to type-level equality. --- ------------------------------------------------------------------------------ - -{-# LANGUAGE ExplicitNamespaces #-} -module Data.Promotion.Prelude.Eq ( - PEq(..), (:==$), (:==$$), (:==$$$), (:/=$), (:/=$$), (:/=$$$) - ) where - -import Data.Singletons.Prelude.Eq diff --git a/src/Data/Promotion/Prelude/Function.hs b/src/Data/Promotion/Prelude/Function.hs deleted file mode 100644 --- a/src/Data/Promotion/Prelude/Function.hs +++ /dev/null @@ -1,38 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Promotion.Prelude.Function --- Copyright : (C) 2016 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines promoted functions from @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 ExplicitNamespaces #-} - -module Data.Promotion.Prelude.Function ( - -- * "Prelude" re-exports - Id, Const, (:.), Flip, type ($) - -- * Other combinators - , (:&), On - - -- * Defunctionalization symbols - , IdSym0, IdSym1 - , ConstSym0, ConstSym1, ConstSym2 - , (:.$), (:.$$), (:.$$$), (:.$$$$) - , FlipSym0, FlipSym1, FlipSym2, FlipSym3 - , type ($$), type ($$$), type ($$$$) - , (:&$), (:&$$), (:&$$$) - , OnSym0, OnSym1, OnSym2, OnSym3, OnSym4 - ) where - -import Data.Singletons.Prelude.Function diff --git a/src/Data/Promotion/Prelude/List.hs b/src/Data/Promotion/Prelude/List.hs deleted file mode 100644 --- a/src/Data/Promotion/Prelude/List.hs +++ /dev/null @@ -1,303 +0,0 @@ -{-# LANGUAGE TypeOperators, DataKinds, PolyKinds, TypeFamilies, - TemplateHaskell, GADTs, UndecidableInstances, RankNTypes, - ScopedTypeVariables, MultiWayIf #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Promotion.Prelude.List --- Copyright : (C) 2014 Jan Stolarek --- License : BSD-style (see LICENSE) --- Maintainer : Jan Stolarek (jan.stolarek@p.lodz.pl) --- Stability : experimental --- Portability : non-portable --- --- Defines promoted functions and datatypes relating to 'List', --- including a promoted version of all the definitions in @Data.List@. --- --- Because many of these definitions are produced by Template Haskell, --- it is not possible to create proper Haddock documentation. Please look --- up the corresponding operation in @Data.List@. Also, please excuse --- the apparent repeated variable names. This is due to an interaction --- between Template Haskell and Haddock. --- ----------------------------------------------------------------------------- - -module Data.Promotion.Prelude.List ( - -- * Basic functions - (:++), Head, Last, Tail, Init, Null, Length, - - -- * List transformations - Map, Reverse, Intersperse, Intercalate, Transpose, Subsequences, Permutations, - - -- * Reducing lists (folds) - Foldl, Foldl', Foldl1, Foldl1', Foldr, Foldr1, - - -- ** Special folds - Concat, ConcatMap, And, Or, Any_, All, Sum, Product, Maximum, Minimum, - any_, -- equivalent of Data.List `any`. Avoids name clash with Any type - - -- * Building lists - - -- ** Scans - Scanl, Scanl1, Scanr, Scanr1, - - -- ** Accumulating maps - MapAccumL, MapAccumR, - - -- ** Infinite lists - Replicate, - - -- ** Unfolding - Unfoldr, - - -- * Sublists - - -- ** Extracting sublists - Take, Drop, SplitAt, - TakeWhile, DropWhile, DropWhileEnd, Span, Break, - StripPrefix, - Group, - Inits, Tails, - - -- ** Predicates - IsPrefixOf, IsSuffixOf, IsInfixOf, - - -- * Searching lists - - -- ** Searching by equality - Elem, NotElem, Lookup, - - -- ** Searching with a predicate - Find, Filter, Partition, - - -- * Indexing lists - (:!!), ElemIndex, ElemIndices, FindIndex, FindIndices, - - -- * Zipping and unzipping lists - Zip, Zip3, Zip4, Zip5, Zip6, Zip7, - ZipWith, ZipWith3, ZipWith4, ZipWith5, ZipWith6, ZipWith7, - Unzip, Unzip3, Unzip4, Unzip5, Unzip6, Unzip7, - - -- * Special lists - - -- ** \"Set\" operations - Nub, Delete, (:\\), Union, Intersect, - - -- ** Ordered lists - Sort, Insert, - - -- * Generalized functions - - -- ** The \"@By@\" operations - -- *** User-supplied equality (replacing an @Eq@ context) - NubBy, DeleteBy, DeleteFirstsBy, UnionBy, GroupBy, IntersectBy, - - -- *** User-supplied comparison (replacing an @Ord@ context) - SortBy, InsertBy, - MaximumBy, MinimumBy, - - -- ** The \"@generic@\" operations - GenericLength, GenericTake, GenericDrop, - GenericSplitAt, GenericIndex, GenericReplicate, - - -- * Defunctionalization symbols - NilSym0, - (:$), (:$$), (:$$$), - - (:++$$$), (:++$$), (:++$), HeadSym0, HeadSym1, LastSym0, LastSym1, - TailSym0, TailSym1, InitSym0, InitSym1, NullSym0, NullSym1, - - MapSym0, MapSym1, MapSym2, ReverseSym0, ReverseSym1, - IntersperseSym0, IntersperseSym1, IntersperseSym2, - IntercalateSym0, IntercalateSym1, IntercalateSym2, - SubsequencesSym0, SubsequencesSym1, - PermutationsSym0, PermutationsSym1, - - FoldlSym0, FoldlSym1, FoldlSym2, FoldlSym3, - Foldl'Sym0, Foldl'Sym1, Foldl'Sym2, Foldl'Sym3, - Foldl1Sym0, Foldl1Sym1, Foldl1Sym2, - Foldl1'Sym0, Foldl1'Sym1, Foldl1'Sym2, - FoldrSym0, FoldrSym1, FoldrSym2, FoldrSym3, - Foldr1Sym0, Foldr1Sym1, Foldr1Sym2, - - ConcatSym0, ConcatSym1, - ConcatMapSym0, ConcatMapSym1, ConcatMapSym2, - AndSym0, AndSym1, OrSym0, OrSym1, - Any_Sym0, Any_Sym1, Any_Sym2, - AllSym0, AllSym1, AllSym2, - - ScanlSym0, ScanlSym1, ScanlSym2, ScanlSym3, - Scanl1Sym0, Scanl1Sym1, Scanl1Sym2, - ScanrSym0, ScanrSym1, ScanrSym2, ScanrSym3, - Scanr1Sym0, Scanr1Sym1, Scanr1Sym2, - - MapAccumLSym0, MapAccumLSym1, MapAccumLSym2, MapAccumLSym3, - MapAccumRSym0, MapAccumRSym1, MapAccumRSym2, MapAccumRSym3, - - UnfoldrSym0, UnfoldrSym1, UnfoldrSym2, - - InitsSym0, InitsSym1, TailsSym0, TailsSym1, - - IsPrefixOfSym0, IsPrefixOfSym1, IsPrefixOfSym2, - IsSuffixOfSym0, IsSuffixOfSym1, IsSuffixOfSym2, - IsInfixOfSym0, IsInfixOfSym1, IsInfixOfSym2, - - ElemSym0, ElemSym1, ElemSym2, - NotElemSym0, NotElemSym1, NotElemSym2, - - ZipSym0, ZipSym1, ZipSym2, - Zip3Sym0, Zip3Sym1, Zip3Sym2, Zip3Sym3, - ZipWithSym0, ZipWithSym1, ZipWithSym2, ZipWithSym3, - ZipWith3Sym0, ZipWith3Sym1, ZipWith3Sym2, ZipWith3Sym3, ZipWith3Sym4, - UnzipSym0, UnzipSym1, - Unzip3Sym0, Unzip3Sym1, - Unzip4Sym0, Unzip4Sym1, - Unzip5Sym0, Unzip5Sym1, - Unzip6Sym0, Unzip6Sym1, - Unzip7Sym0, Unzip7Sym1, - - DeleteSym0, DeleteSym1, DeleteSym2, - (:\\$), (:\\$$), (:\\$$$), - IntersectSym0, IntersectSym1, IntersectSym2, - - InsertSym0, InsertSym1, InsertSym2, - SortSym0, SortSym1, - - DeleteBySym0, DeleteBySym1, DeleteBySym2, DeleteBySym3, - DeleteFirstsBySym0, DeleteFirstsBySym1, DeleteFirstsBySym2, DeleteFirstsBySym3, - IntersectBySym0, IntersectBySym1, IntersectBySym2, - - SortBySym0, SortBySym1, SortBySym2, - InsertBySym0, InsertBySym1, InsertBySym2, InsertBySym3, - MaximumBySym0, MaximumBySym1, MaximumBySym2, - MinimumBySym0, MinimumBySym1, MinimumBySym2, - LengthSym0, LengthSym1, - SumSym0, SumSym1, ProductSym0, ProductSym1, - ReplicateSym0, ReplicateSym1, ReplicateSym2, - TransposeSym0, TransposeSym1, - TakeSym0, TakeSym1, TakeSym2, - DropSym0, DropSym1, DropSym2, - SplitAtSym0, SplitAtSym1, SplitAtSym2, - TakeWhileSym0, TakeWhileSym1, TakeWhileSym2, - DropWhileSym0, DropWhileSym1, DropWhileSym2, - DropWhileEndSym0, DropWhileEndSym1, DropWhileEndSym2, - SpanSym0, SpanSym1, SpanSym2, - BreakSym0, BreakSym1, BreakSym2, - StripPrefixSym0, StripPrefixSym1, StripPrefixSym2, - MaximumSym0, MaximumSym1, - MinimumSym0, MinimumSym1, - GroupSym0, GroupSym1, - GroupBySym0, GroupBySym1, GroupBySym2, - LookupSym0, LookupSym1, LookupSym2, - FindSym0, FindSym1, FindSym2, - FilterSym0, FilterSym1, FilterSym2, - PartitionSym0, PartitionSym1, PartitionSym2, - - (:!!$), (:!!$$), (:!!$$$), - - ElemIndexSym0, ElemIndexSym1, ElemIndexSym2, - ElemIndicesSym0, ElemIndicesSym1, ElemIndicesSym2, - FindIndexSym0, FindIndexSym1, FindIndexSym2, - FindIndicesSym0, FindIndicesSym1, FindIndicesSym2, - - Zip4Sym0, Zip4Sym1, Zip4Sym2, Zip4Sym3, Zip4Sym4, - Zip5Sym0, Zip5Sym1, Zip5Sym2, Zip5Sym3, Zip5Sym4, Zip5Sym5, - Zip6Sym0, Zip6Sym1, Zip6Sym2, Zip6Sym3, Zip6Sym4, Zip6Sym5, Zip6Sym6, - Zip7Sym0, Zip7Sym1, Zip7Sym2, Zip7Sym3, Zip7Sym4, Zip7Sym5, Zip7Sym6, Zip7Sym7, - - ZipWith4Sym0, ZipWith4Sym1, ZipWith4Sym2, ZipWith4Sym3, ZipWith4Sym4, 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, - - NubSym0, NubSym1, - NubBySym0, NubBySym1, NubBySym2, - UnionSym0, UnionSym1, UnionSym2, - UnionBySym0, UnionBySym1, UnionBySym2, UnionBySym3, - - GenericLengthSym0, GenericLengthSym1, - GenericTakeSym0, GenericTakeSym1, GenericTakeSym2, - GenericDropSym0, GenericDropSym1, GenericDropSym2, - GenericSplitAtSym0, GenericSplitAtSym1, GenericSplitAtSym2, - GenericIndexSym0, GenericIndexSym1, GenericIndexSym2, - GenericReplicateSym0, GenericReplicateSym1, GenericReplicateSym2, - - ) where - -import Data.Singletons.Prelude.Base -import Data.Singletons.Prelude.Eq -import Data.Singletons.Prelude.List -import Data.Singletons.Prelude.Maybe -import Data.Singletons.TH - -$(promoteOnly [d| - - -- Overlapping patterns don't singletonize - stripPrefix :: Eq a => [a] -> [a] -> Maybe [a] - stripPrefix [] ys = Just ys - stripPrefix (x:xs) (y:ys) - | x == y = stripPrefix xs ys - stripPrefix _ _ = Nothing - - -- To singletonize these we would need to rewrite all patterns - -- as non-overlapping. This means 2^7 equations for zipWith7. - - zip4 :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)] - zip4 = zipWith4 (,,,) - - zip5 :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)] - zip5 = zipWith5 (,,,,) - - zip6 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> - [(a,b,c,d,e,f)] - zip6 = zipWith6 (,,,,,) - - zip7 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> - [g] -> [(a,b,c,d,e,f,g)] - zip7 = zipWith7 (,,,,,,) - - zipWith4 :: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] - zipWith4 z (a:as) (b:bs) (c:cs) (d:ds) - = z a b c d : zipWith4 z as bs cs ds - zipWith4 _ _ _ _ _ = [] - - zipWith5 :: (a->b->c->d->e->f) -> - [a]->[b]->[c]->[d]->[e]->[f] - zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) - = z a b c d e : zipWith5 z as bs cs ds es - zipWith5 _ _ _ _ _ _ = [] - - zipWith6 :: (a->b->c->d->e->f->g) -> - [a]->[b]->[c]->[d]->[e]->[f]->[g] - zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) - = z a b c d e f : zipWith6 z as bs cs ds es fs - zipWith6 _ _ _ _ _ _ _ = [] - - zipWith7 :: (a->b->c->d->e->f->g->h) -> - [a]->[b]->[c]->[d]->[e]->[f]->[g]->[h] - zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs) - = z a b c d e f g : zipWith7 z as bs cs ds es fs gs - zipWith7 _ _ _ _ _ _ _ _ = [] - --- These functions use Integral or Num typeclass instead of Int. --- --- genericLength, genericTake, genericDrop, genericSplitAt, genericIndex --- genericReplicate --- --- We provide aliases below to improve compatibility - - genericTake :: (Integral i) => i -> [a] -> [a] - genericTake = take - - genericDrop :: (Integral i) => i -> [a] -> [a] - genericDrop = drop - - genericSplitAt :: (Integral i) => i -> [a] -> ([a], [a]) - genericSplitAt = splitAt - - genericIndex :: (Integral i) => [a] -> i -> a - genericIndex = (!!) - - genericReplicate :: (Integral i) => i -> a -> [a] - genericReplicate = replicate - |]) diff --git a/src/Data/Promotion/Prelude/List/NonEmpty.hs b/src/Data/Promotion/Prelude/List/NonEmpty.hs deleted file mode 100644 --- a/src/Data/Promotion/Prelude/List/NonEmpty.hs +++ /dev/null @@ -1,127 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Promotion.Prelude.List.NonEmpty --- Copyright : (C) 2016 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines functions and datatypes relating to promoting 'NonEmpty', --- including promoted versions of many of the definitions in @Data.List.NonEmpty@. --- ----------------------------------------------------------------------------- - -module Data.Promotion.Prelude.List.NonEmpty ( - - -- * Non-empty stream transformations - Map, - Intersperse, - Scanl, - Scanr, - Scanl1, - Scanr1, - Transpose, - SortBy, - SortWith, - Length, - Head, - Tail, - Last, - Init, - (:<|), - Cons, - Uncons, - Unfoldr, - Sort, - Reverse, - Inits, - Tails, - Unfold, - Insert, - Take, - Drop, - SplitAt, - TakeWhile, - DropWhile, - Span, - Break, - Filter, - Partition, - Group, - GroupBy, - GroupWith, - GroupAllWith, - Group1, - GroupBy1, - GroupWith1, - GroupAllWith1, - IsPrefixOf, - Nub, - NubBy, - (:!!), - Zip, - ZipWith, - Unzip, - FromList, - ToList, - NonEmpty_, - Xor, - - -- * 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, - (:<|$), (:<|$$), (:<|$$$), - 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, - (:!!$), (:!!$$), (:!!$$$), - ZipSym0, ZipSym1, ZipSym2, - ZipWithSym0, ZipWithSym1, ZipWithSym2, ZipWithSym3, - UnzipSym0, UnzipSym1, - FromListSym0, FromListSym1, - ToListSym0, ToListSym1, - NonEmpty_Sym0, NonEmpty_Sym1, - XorSym0, XorSym1 - ) where - -import Data.Singletons.Prelude.List.NonEmpty diff --git a/src/Data/Promotion/Prelude/Maybe.hs b/src/Data/Promotion/Prelude/Maybe.hs deleted file mode 100644 --- a/src/Data/Promotion/Prelude/Maybe.hs +++ /dev/null @@ -1,42 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Promotion.Prelude.Maybe --- Copyright : (C) 2014 Jan Stolarek --- License : BSD-style (see LICENSE) --- Maintainer : Jan Stolarek (jan.stolarek@p.lodz.pl) --- Stability : experimental --- Portability : non-portable --- --- Defines promoted functions and datatypes relating to 'Maybe', --- including a promoted version of all the definitions in @Data.Maybe@. --- --- Because many of these definitions are produced by Template Haskell, --- it is not possible to create proper Haddock documentation. Please look --- up the corresponding operation in @Data.Maybe@. Also, please excuse --- the apparent repeated variable names. This is due to an interaction --- between Template Haskell and Haddock. --- ----------------------------------------------------------------------------- - - -module Data.Promotion.Prelude.Maybe ( - -- * Promoted functions from @Data.Maybe@ - maybe_, Maybe_, - -- | The preceding two definitions is derived from the function 'maybe' in - -- @Data.Maybe@. The extra underscore is to avoid name clashes with the type - -- 'Maybe'. - - IsJust, IsNothing, FromJust, FromMaybe, MaybeToList, - ListToMaybe, CatMaybes, MapMaybe, - - -- * Defunctionalization symbols - NothingSym0, JustSym0, JustSym1, - - Maybe_Sym0, Maybe_Sym1, Maybe_Sym2, Maybe_Sym3, - IsJustSym0, IsJustSym1, IsNothingSym0, IsNothingSym1, - FromJustSym0, FromJustSym1, FromMaybeSym0, FromMaybeSym1, FromMaybeSym2, - MaybeToListSym0, MaybeToListSym1, ListToMaybeSym0, ListToMaybeSym1, - CatMaybesSym0, CatMaybesSym1, MapMaybeSym0, MapMaybeSym1, MapMaybeSym2 - ) where - -import Data.Singletons.Prelude.Maybe diff --git a/src/Data/Promotion/Prelude/Num.hs b/src/Data/Promotion/Prelude/Num.hs deleted file mode 100644 --- a/src/Data/Promotion/Prelude/Num.hs +++ /dev/null @@ -1,30 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Promotion.Prelude.Num --- Copyright : (C) 2014 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines and exports promoted and singleton versions of definitions from --- GHC.Num. --- ----------------------------------------------------------------------------- - -module Data.Promotion.Prelude.Num ( - PNum(..), Subtract, - - -- ** Defunctionalization symbols - (:+$), (:+$$), (:+$$$), - (:-$), (:-$$), (:-$$$), - (:*$), (:*$$), (:*$$$), - NegateSym0, NegateSym1, - AbsSym0, AbsSym1, - SignumSym0, SignumSym1, - FromIntegerSym0, FromIntegerSym1, - SubtractSym0, SubtractSym1, SubtractSym2 - ) where - -import Data.Singletons.Prelude.Num -import Data.Singletons.TypeLits () -- for the Num instance! diff --git a/src/Data/Promotion/Prelude/Ord.hs b/src/Data/Promotion/Prelude/Ord.hs deleted file mode 100644 --- a/src/Data/Promotion/Prelude/Ord.hs +++ /dev/null @@ -1,26 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Promotion.Prelude.Ord --- Copyright : (C) 2014 Jan Stolarek --- License : BSD-style (see LICENSE) --- Maintainer : Jan Stolarek (jan.stolarek@p.lodz.pl) --- Stability : experimental --- Portability : non-portable --- --- Provides promoted definitions related to type-level comparisons. --- ------------------------------------------------------------------------------ - -module Data.Promotion.Prelude.Ord ( - POrd(..), - LTSym0, EQSym0, GTSym0, - CompareSym0, CompareSym1, CompareSym2, - (:<$), (:<$$), (:<$$$), - (:<=$), (:<=$$), (:<=$$$), - (:>$), (:>$$), (:>$$$), - (:>=$), (:>=$$), (:>=$$$), - MaxSym0, MaxSym1, MaxSym2, - MinSym0, MinSym1, MinSym2 - ) where - -import Data.Singletons.Prelude.Ord diff --git a/src/Data/Promotion/Prelude/Tuple.hs b/src/Data/Promotion/Prelude/Tuple.hs deleted file mode 100644 --- a/src/Data/Promotion/Prelude/Tuple.hs +++ /dev/null @@ -1,39 +0,0 @@ --- | --- Module : Data.Promotion.Prelude.Tuple --- Copyright : (C) 2014 Jan Stolarek --- License : BSD-style (see LICENSE) --- Maintainer : Jan Stolarek (jan.stolarek@p.lodz.pl) --- Stability : experimental --- Portability : non-portable --- --- Defines promoted functions and datatypes relating to tuples, --- including a promoted version of all the definitions in @Data.Tuple@. --- --- Because many of these definitions are produced by Template Haskell, --- it is not possible to create proper Haddock documentation. Please look --- up the corresponding operation in @Data.Tuple@. Also, please excuse --- the apparent repeated variable names. This is due to an interaction --- between Template Haskell and Haddock. --- ----------------------------------------------------------------------------- - -module Data.Promotion.Prelude.Tuple ( - -- * Promoted functions from @Data.Tuple@ - Fst, Snd, Curry, Uncurry, Swap, - - -- * Defunctionalization symbols - Tuple0Sym0, - Tuple2Sym0, Tuple2Sym1, Tuple2Sym2, - Tuple3Sym0, Tuple3Sym1, Tuple3Sym2, Tuple3Sym3, - Tuple4Sym0, Tuple4Sym1, Tuple4Sym2, Tuple4Sym3, Tuple4Sym4, - Tuple5Sym0, Tuple5Sym1, Tuple5Sym2, Tuple5Sym3, Tuple5Sym4, Tuple5Sym5, - Tuple6Sym0, Tuple6Sym1, Tuple6Sym2, Tuple6Sym3, Tuple6Sym4, Tuple6Sym5, Tuple6Sym6, - Tuple7Sym0, Tuple7Sym1, Tuple7Sym2, Tuple7Sym3, Tuple7Sym4, Tuple7Sym5, Tuple7Sym6, Tuple7Sym7, - - FstSym0, FstSym1, SndSym0, SndSym1, - CurrySym0, CurrySym1, CurrySym2, CurrySym3, - UncurrySym0, UncurrySym1, UncurrySym2, - SwapSym0, SwapSym1 - ) where - -import Data.Singletons.Prelude.Tuple diff --git a/src/Data/Promotion/TH.hs b/src/Data/Promotion/TH.hs deleted file mode 100644 --- a/src/Data/Promotion/TH.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE ExplicitNamespaces #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Promotion.TH --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) --- Stability : experimental --- Portability : non-portable --- --- This module contains everything you need to promote your own functions via --- Template Haskell. --- ----------------------------------------------------------------------------- - -module Data.Promotion.TH ( - -- * Primary Template Haskell generation functions - promote, promoteOnly, genDefunSymbols, genPromotions, - - -- ** Functions to generate @Eq@ instances - promoteEqInstances, promoteEqInstance, - - -- ** Functions to generate @Ord@ instances - promoteOrdInstances, promoteOrdInstance, - - -- ** Functions to generate @Bounded@ instances - promoteBoundedInstances, promoteBoundedInstance, - - -- ** Functions to generate @Enum@ instances - promoteEnumInstances, promoteEnumInstance, - - -- ** defunctionalization - TyFun, Apply, type (@@), - - -- * Auxiliary definitions - -- | These definitions might be mentioned in code generated by Template Haskell, - -- so they must be in scope. - - PEq(..), If, (:&&), - POrd(..), - Any, - Proxy(..), ThenCmp, Foldl, - - Error, ErrorSym0, - TrueSym0, FalseSym0, - LTSym0, EQSym0, GTSym0, - Tuple0Sym0, - Tuple2Sym0, Tuple2Sym1, Tuple2Sym2, - Tuple3Sym0, Tuple3Sym1, Tuple3Sym2, Tuple3Sym3, - Tuple4Sym0, Tuple4Sym1, Tuple4Sym2, Tuple4Sym3, Tuple4Sym4, - Tuple5Sym0, Tuple5Sym1, Tuple5Sym2, Tuple5Sym3, Tuple5Sym4, Tuple5Sym5, - Tuple6Sym0, Tuple6Sym1, Tuple6Sym2, Tuple6Sym3, Tuple6Sym4, Tuple6Sym5, Tuple6Sym6, - Tuple7Sym0, Tuple7Sym1, Tuple7Sym2, Tuple7Sym3, Tuple7Sym4, Tuple7Sym5, Tuple7Sym6, Tuple7Sym7, - ThenCmpSym0, FoldlSym0, - - SuppressUnusedWarnings(..) - - ) where - -import Data.Singletons -import Data.Singletons.Promote -import Data.Singletons.Prelude.Instances -import Data.Singletons.Prelude.Bool -import Data.Singletons.Prelude.Eq -import Data.Singletons.Prelude.Ord -import Data.Singletons.TypeLits -import Data.Singletons.SuppressUnusedWarnings -import GHC.Exts diff --git a/src/Data/Singletons.hs b/src/Data/Singletons.hs --- a/src/Data/Singletons.hs +++ b/src/Data/Singletons.hs @@ -1,319 +1,1363 @@ -{-# LANGUAGE MagicHash, RankNTypes, PolyKinds, GADTs, DataKinds, - FlexibleContexts, FlexibleInstances, - TypeFamilies, TypeOperators, TypeFamilyDependencies, - UndecidableInstances, TypeInType, ConstraintKinds #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) --- Stability : experimental --- Portability : non-portable --- --- This module exports the basic definitions to use singletons. For routine --- use, consider importing 'Data.Singletons.Prelude', which exports constructors --- for singletons based on types in the @Prelude@. --- --- You may also want to read --- the original papers presenting this library, available at --- --- and . --- ----------------------------------------------------------------------------- - -module Data.Singletons ( - -- * Main singleton definitions - - Sing(SLambda, applySing), - -- | See also 'Data.Singletons.Prelude.Sing' for exported constructors - - SingI(..), SingKind(..), - - -- * Working with singletons - KindOf, SameKind, - SingInstance(..), SomeSing(..), - singInstance, withSingI, withSomeSing, singByProxy, - - singByProxy#, - withSing, singThat, - - -- ** Defunctionalization - TyFun, type (~>), - TyCon1, TyCon2, TyCon3, TyCon4, TyCon5, TyCon6, TyCon7, TyCon8, - Apply, type (@@), - - -- ** Defunctionalized singletons - -- | When calling a higher-order singleton function, you need to use a - -- @singFun...@ function to wrap it. See 'singFun1'. - singFun1, singFun2, singFun3, singFun4, singFun5, singFun6, singFun7, - singFun8, - unSingFun1, unSingFun2, unSingFun3, unSingFun4, unSingFun5, - unSingFun6, unSingFun7, unSingFun8, - - -- | These type synonyms are exported only to improve error messages; users - -- should not have to mention them. - SingFunction1, SingFunction2, SingFunction3, SingFunction4, SingFunction5, - SingFunction6, SingFunction7, SingFunction8, - - -- * Auxiliary functions - Proxy(..) - ) where - -import Data.Kind -import Unsafe.Coerce -import Data.Proxy ( Proxy(..) ) -import GHC.Exts ( Proxy#, Constraint ) - --- | Convenient synonym to refer to the kind of a type variable: --- @type KindOf (a :: k) = k@ -type KindOf (a :: k) = k - --- | Force GHC to unify the kinds of @a@ and @b@. Note that @SameKind a b@ is --- different from @KindOf a ~ KindOf b@ in that the former makes the kinds --- unify immediately, whereas the latter is a proposition that GHC considers --- as possibly false. -type SameKind (a :: k) (b :: k) = (() :: Constraint) - ----------------------------------------------------------------------- ----- Sing & friends -------------------------------------------------- ----------------------------------------------------------------------- - --- | The singleton kind-indexed data family. -data family Sing (a :: k) - --- | A 'SingI' constraint is essentially an implicitly-passed singleton. --- If you need to satisfy this constraint with an explicit singleton, please --- see 'withSingI'. -class SingI (a :: k) where - -- | Produce the singleton explicitly. You will likely need the @ScopedTypeVariables@ - -- extension to use this method the way you want. - sing :: Sing a - --- | The 'SingKind' class is a /kind/ class. It classifies all kinds --- for which singletons are defined. The class supports converting between a singleton --- type and the base (unrefined) type which it is built from. -class 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 @Integer@. - type Demote k = (r :: *) | r -> k - - -- | Convert a singleton to its unrefined version. - fromSing :: Sing (a :: k) -> Demote k - - -- | Convert an unrefined type to an existentially-quantified singleton type. - toSing :: Demote k -> SomeSing k - --- | An /existentially-quantified/ singleton. This type is useful when you want a --- singleton type, but there is no way of knowing, at compile-time, what the type --- index will be. To make use of this type, you will generally have to use a --- pattern-match: --- --- > foo :: Bool -> ... --- > foo b = case toSing b of --- > SomeSing sb -> {- fancy dependently-typed code with sb -} --- --- An example like the one above may be easier to write using 'withSomeSing'. -data SomeSing k where - SomeSing :: Sing (a :: k) -> SomeSing k - ----------------------------------------------------------------------- ----- SingInstance ---------------------------------------------------- ----------------------------------------------------------------------- - --- | A 'SingInstance' wraps up a 'SingI' instance for explicit handling. -data SingInstance (a :: k) where - SingInstance :: SingI a => SingInstance a - --- dirty implementation of explicit-to-implicit conversion -newtype DI a = Don'tInstantiate (SingI a => SingInstance a) - --- | Get an implicit singleton (a 'SingI' instance) from an explicit one. -singInstance :: forall (a :: k). Sing a -> SingInstance a -singInstance s = with_sing_i SingInstance - where - with_sing_i :: (SingI a => SingInstance a) -> SingInstance a - with_sing_i si = unsafeCoerce (Don'tInstantiate si) s - ----------------------------------------------------------------------- ----- Defunctionalization --------------------------------------------- ----------------------------------------------------------------------- - --- | Representation of the kind of a type-level function. The difference --- between term-level arrows and this type-level arrow is that at the term --- level applications can be unsaturated, whereas at the type level all --- applications have to be fully saturated. -data TyFun :: * -> * -> * - --- | Something of kind `a ~> b` is a defunctionalized type function that is --- not necessarily generative or injective. -type a ~> b = TyFun a b -> * -infixr 0 ~> - --- | 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 level function application -type family Apply (f :: k1 ~> k2) (x :: k1) :: k2 -type instance Apply (TyCon1 f) x = f x -type instance Apply (TyCon2 f) x = TyCon1 (f x) -type instance Apply (TyCon3 f) x = TyCon2 (f x) -type instance Apply (TyCon4 f) x = TyCon3 (f x) -type instance Apply (TyCon5 f) x = TyCon4 (f x) -type instance Apply (TyCon6 f) x = TyCon5 (f x) -type instance Apply (TyCon7 f) x = TyCon6 (f x) -type instance Apply (TyCon8 f) x = TyCon7 (f x) - --- | An infix synonym for `Apply` -type a @@ b = Apply a b -infixl 9 @@ - ----------------------------------------------------------------------- ----- Defunctionalized Sing instance and utilities -------------------- ----------------------------------------------------------------------- - -newtype instance Sing (f :: k1 ~> k2) = - SLambda { applySing :: forall t. Sing t -> Sing (f @@ t) } - -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 _ = error "Cannot create existentially-quantified singleton functions." - -type SingFunction1 f = forall t. Sing t -> Sing (f @@ t) - --- | Use this function when passing a function on singletons as --- a higher-order function. You will need visible type application --- to get this to work. For example: --- --- > falses = sMap (singFun1 @NotSym0 sNot) --- > (STrue `SCons` STrue `SCons` SNil) --- --- There are a family of @singFun...@ functions, keyed by the number --- of parameters of the function. -singFun1 :: forall f. SingFunction1 f -> Sing f -singFun1 f = SLambda f - -type SingFunction2 f = forall t. Sing t -> SingFunction1 (f @@ t) -singFun2 :: forall f. SingFunction2 f -> Sing f -singFun2 f = SLambda (\x -> singFun1 (f x)) - -type SingFunction3 f = forall t. Sing t -> SingFunction2 (f @@ t) -singFun3 :: forall f. SingFunction3 f -> Sing f -singFun3 f = SLambda (\x -> singFun2 (f x)) - -type SingFunction4 f = forall t. Sing t -> SingFunction3 (f @@ t) -singFun4 :: forall f. SingFunction4 f -> Sing f -singFun4 f = SLambda (\x -> singFun3 (f x)) - -type SingFunction5 f = forall t. Sing t -> SingFunction4 (f @@ t) -singFun5 :: forall f. SingFunction5 f -> Sing f -singFun5 f = SLambda (\x -> singFun4 (f x)) - -type SingFunction6 f = forall t. Sing t -> SingFunction5 (f @@ t) -singFun6 :: forall f. SingFunction6 f -> Sing f -singFun6 f = SLambda (\x -> singFun5 (f x)) - -type SingFunction7 f = forall t. Sing t -> SingFunction6 (f @@ t) -singFun7 :: forall f. SingFunction7 f -> Sing f -singFun7 f = SLambda (\x -> singFun6 (f x)) - -type SingFunction8 f = forall t. Sing t -> SingFunction7 (f @@ t) -singFun8 :: forall f. SingFunction8 f -> Sing f -singFun8 f = SLambda (\x -> singFun7 (f x)) - --- | This is the inverse of 'singFun1', and likewise for the other --- @unSingFun...@ functions. -unSingFun1 :: forall f. Sing f -> SingFunction1 f -unSingFun1 sf = applySing sf - -unSingFun2 :: forall f. Sing f -> SingFunction2 f -unSingFun2 sf x = unSingFun1 (sf `applySing` x) - -unSingFun3 :: forall f. Sing f -> SingFunction3 f -unSingFun3 sf x = unSingFun2 (sf `applySing` x) - -unSingFun4 :: forall f. Sing f -> SingFunction4 f -unSingFun4 sf x = unSingFun3 (sf `applySing` x) - -unSingFun5 :: forall f. Sing f -> SingFunction5 f -unSingFun5 sf x = unSingFun4 (sf `applySing` x) - -unSingFun6 :: forall f. Sing f -> SingFunction6 f -unSingFun6 sf x = unSingFun5 (sf `applySing` x) - -unSingFun7 :: forall f. Sing f -> SingFunction7 f -unSingFun7 sf x = unSingFun6 (sf `applySing` x) - -unSingFun8 :: forall f. Sing f -> SingFunction8 f -unSingFun8 sf x = unSingFun7 (sf `applySing` x) - ----------------------------------------------------------------------- ----- 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 (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 +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE QuantifiedConstraints #-} +#else +{-# LANGUAGE TypeInType #-} +#endif + +#if __GLASGOW_HASKELL__ >= 810 +{-# LANGUAGE StandaloneKindSignatures #-} +#endif + +#if __GLASGOW_HASKELL__ >= 910 +{-# LANGUAGE TypeAbstractions #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Singletons +-- Copyright : (C) 2013 Richard Eisenberg +-- License : BSD-style (see LICENSE) +-- Maintainer : Ryan Scott +-- Stability : experimental +-- Portability : non-portable +-- +-- This module exports the basic definitions to use singletons. See also +-- @Prelude.Singletons@ from the @singletons-base@ +-- library, which re-exports this module alongside many singled definitions +-- based on the "Prelude". +-- +-- You may also want to read +-- the original papers presenting this library, available at +-- +-- and . +-- +---------------------------------------------------------------------------- + +module Data.Singletons ( + -- * Main singleton definitions + + Sing, SLambda(..), (@@), + + SingI(..), + SingI1(..), sing1, + SingI2(..), sing2, + SingKind(..), + + -- * Working with singletons + KindOf, SameKind, + SingInstance(..), SomeSing(..), + singInstance, pattern Sing, withSingI, + withSomeSing, pattern FromSing, + usingSingI1, usingSingI2, + singByProxy, singByProxy1, singByProxy2, + demote, demote1, demote2, + + singByProxy#, singByProxy1#, singByProxy2#, + withSing, withSing1, withSing2, + singThat, singThat1, singThat2, + + -- ** @WrappedSing@ + WrappedSing(..), SWrappedSing(..), UnwrapSing, + -- $SingletonsOfSingletons + + -- ** Defunctionalization + TyFun, type (~>), + TyCon1, TyCon2, TyCon3, TyCon4, TyCon5, TyCon6, TyCon7, TyCon8, + Apply, type (@@), +#if __GLASGOW_HASKELL__ >= 806 + TyCon, ApplyTyCon, ApplyTyConAux1, ApplyTyConAux2, +#endif + + -- ** Defunctionalized singletons + -- | When calling a higher-order singleton function, you need to use a + -- @singFun...@ function to wrap it. See 'singFun1'. + singFun1, singFun2, singFun3, singFun4, singFun5, singFun6, singFun7, + singFun8, + unSingFun1, unSingFun2, unSingFun3, unSingFun4, unSingFun5, + unSingFun6, unSingFun7, unSingFun8, + -- $SLambdaPatternSynonyms + pattern SLambda2, applySing2, + pattern SLambda3, applySing3, + pattern SLambda4, applySing4, + pattern SLambda5, applySing5, + pattern SLambda6, applySing6, + pattern SLambda7, applySing7, + pattern SLambda8, applySing8, + + -- | These type synonyms are exported only to improve error messages; users + -- should not have to mention them. + SingFunction1, SingFunction2, SingFunction3, SingFunction4, SingFunction5, + SingFunction6, SingFunction7, SingFunction8, + + -- * Auxiliary functions + Proxy(..), + + -- * Defunctionalization symbols + DemoteSym0, DemoteSym1, + SameKindSym0, SameKindSym1, SameKindSym2, + KindOfSym0, KindOfSym1, + type (~>@#@$), type (~>@#@$$), type (~>@#@$$$), + ApplySym0, ApplySym1, ApplySym2, + type (@@@#@$), type (@@@#@$$), type (@@@#@$$$) + ) where + +import Data.Kind (Constraint, Type) +import Data.Proxy (Proxy(..)) +import GHC.Exts (Proxy#) +import Unsafe.Coerce (unsafeCoerce) + +#if MIN_VERSION_base(4,17,0) +import GHC.Exts (withDict) +#endif + +-- | Convenient synonym to refer to the kind of a type variable: +-- @type KindOf (a :: k) = k@ +#if __GLASGOW_HASKELL__ >= 810 +type KindOf :: k -> Type +#endif +type KindOf (a :: k) = k + +-- | Force GHC to unify the kinds of @a@ and @b@. Note that @SameKind a b@ is +-- different from @KindOf a ~ KindOf b@ in that the former makes the kinds +-- unify immediately, whereas the latter is a proposition that GHC considers +-- as possibly false. +#if __GLASGOW_HASKELL__ >= 810 +type SameKind :: k -> k -> Constraint +#endif +type SameKind (a :: k) (b :: k) = (() :: Constraint) + +---------------------------------------------------------------------- +---- Sing & friends -------------------------------------------------- +---------------------------------------------------------------------- + +-- | The singleton kind-indexed type family. +#if __GLASGOW_HASKELL__ >= 810 +type Sing :: k -> Type +#endif +#if __GLASGOW_HASKELL__ >= 910 +type family Sing @k :: k -> Type +#else +type family Sing :: k -> Type +#endif + +{- +Note [The kind of Sing] +~~~~~~~~~~~~~~~~~~~~~~~ +It is important to define Sing like this: + + type Sing :: k -> Type + type family Sing + +Or, equivalently, + + type family Sing :: k -> Type + +There are other conceivable ways to define Sing, but they all suffer from +various drawbacks: + +* type family Sing :: forall k. k -> Type + + Surprisingly, this is /not/ equivalent to `type family Sing :: k -> Type`. + The difference lies in their arity, i.e., the number of arguments that must + be supplied in order to apply Sing. The former declaration has arity 0, while + the latter has arity 1 (this is more obvious if you write the declaration as + GHCi would display it with -fprint-explicit-kinds enabled: + `type family Sing @k :: k -> Type`). + + The former declaration having arity 0 is actually what makes it useless. If + we were to adopt an arity-0 definition of `Sing`, then in order to write + `type instance Sing = SFoo`, GHC would require that `SFoo` must have the kind + `forall k. k -> Type`, and moreover, the kind /must/ be polymorphic in `k`. + This is undesirable, because in practice, every single `Sing` instance in the + wild must monomorphize `k` (e.g., `SBool` monomorphizes it to `Bool`), so an + arity-0 `Sing` simply won't work. In contrast, the current arity-1 definition + of `Sing` /does/ let you monomorphize `k` in type family instances. + +* type family Sing (a :: k) = (r :: Type) | r -> a + + Again, this is not equivalent to `type family Sing :: k -> Type`. This + version of `Sing` has arity 2, since one must supply both `k` and `a` in + order to apply it. While an arity-2 `Sing` is not suffer from the same + polymorphism issues as the arity-0 `Sing` in the previous bullet point, it + does suffer from another issue in that it cannot be partially applied. This + is because its `a` argument /must/ be supplied, whereas with the arity-1 + `Sing`, it is perfectly admissible to write `Sing` without an explicit `a` + argument. (Its invisible `k` argument is filled in automatically behind the + scenes.) + +* type family Sing = (r :: k -> Type) | r -> k + + This is the same as `type family Sing :: k -> Type`, but with an injectivity + annotation. Technically, this definition isn't /wrong/, but the injectivity + annotation is actually unnecessary. Because the return kind of `Sing` is + declared to be `k -> Type`, the `Sing` type constructor is automatically + injective, so `Sing a1 ~ Sing a2` implies `a1 ~~ a2`. + + Another way of phrasing this, using the terminology of Dependent Haskell, is + that the arrow in `Sing`'s return kind is /matchable/, which implies that + `Sing` is an injective type constructor as a consequence. +-} + +-- | A 'SingI' constraint is essentially an implicitly-passed singleton. +-- +-- In contrast to the 'SingKind' class, which is parameterized over data types +-- promoted to the kind level, the 'SingI' class is parameterized over values +-- promoted to the type level. To explain this distinction another way, consider +-- this code: +-- +-- @ +-- f = fromSing (sing @(T :: K)) +-- @ +-- +-- Here, @f@ uses methods from both 'SingI' and 'SingKind'. However, the shape +-- of each constraint is rather different: using 'sing' requires a @SingI T@ +-- constraint, whereas using 'fromSing' requires a @SingKind K@ constraint. +-- +-- If you need to satisfy this constraint with an explicit singleton, please +-- see 'withSingI' or the v'Sing' pattern synonym. +#if __GLASGOW_HASKELL__ >= 900 +type SingI :: forall {k}. k -> Constraint +#endif +class SingI a where + -- | Produce the singleton explicitly. You will likely need the @ScopedTypeVariables@ + -- extension to use this method the way you want. + sing :: Sing a + +-- | A version of the 'SingI' class lifted to unary type constructors. +#if __GLASGOW_HASKELL__ >= 900 +type SingI1 :: forall {k1} {k2}. (k1 -> k2) -> Constraint +#endif +class +#if __GLASGOW_HASKELL__ >= 806 + (forall x. SingI x => SingI (f x)) => +#endif + SingI1 f where + -- | Lift an explicit singleton through a unary type constructor. + -- You will likely need the @ScopedTypeVariables@ extension to use this + -- method the way you want. + liftSing :: Sing x -> Sing (f x) + +-- | Produce a singleton explicitly using implicit 'SingI1' and 'SingI' +-- constraints. You will likely need the @ScopedTypeVariables@ extension to use +-- this method the way you want. +sing1 :: (SingI1 f, SingI x) => Sing (f x) +sing1 = liftSing sing + +-- | A version of the 'SingI' class lifted to binary type constructors. +#if __GLASGOW_HASKELL__ >= 900 +type SingI2 :: forall {k1} {k2} {k3}. (k1 -> k2 -> k3) -> Constraint +#endif +class +#if __GLASGOW_HASKELL__ >= 806 + (forall x y. (SingI x, SingI y) => SingI (f x y)) => +#endif + SingI2 f where + -- | Lift explicit singletons through a binary type constructor. + -- You will likely need the @ScopedTypeVariables@ extension to use this + -- method the way you want. + liftSing2 :: Sing x -> Sing y -> Sing (f x y) + +-- | Produce a singleton explicitly using implicit 'SingI2' and 'SingI' +-- constraints. You will likely need the @ScopedTypeVariables@ extension to use +-- this method the way you want. +sing2 :: (SingI2 f, SingI x, SingI y) => Sing (f x y) +sing2 = liftSing2 sing sing + +-- | An explicitly bidirectional pattern synonym for implicit singletons. +-- +-- As an __expression__: Constructs a singleton @Sing a@ given a +-- implicit singleton constraint @SingI a@. +-- +-- As a __pattern__: Matches on an explicit @Sing a@ witness bringing +-- an implicit @SingI a@ constraint into scope. +#if __GLASGOW_HASKELL__ >= 802 +{-# COMPLETE Sing #-} +#endif +pattern Sing :: forall k (a :: k). () => SingI a => Sing a +pattern Sing <- (singInstance -> SingInstance) + where Sing = sing + +-- | The 'SingKind' class is a /kind/ class. It classifies all kinds +-- for which singletons are defined. The class supports converting between a singleton +-- type and the base (unrefined) type which it is built from. +-- +-- For a 'SingKind' instance to be well behaved, it should obey the following laws: +-- +-- @ +-- 'toSing' . 'fromSing' ≡ 'SomeSing' +-- (\\x -> 'withSomeSing' x 'fromSing') ≡ 'id' +-- @ +-- +-- The final law can also be expressed in terms of the 'FromSing' pattern +-- synonym: +-- +-- @ +-- (\\('FromSing' sing) -> 'FromSing' sing) ≡ 'id' +-- @ +#if __GLASGOW_HASKELL__ >= 810 +type SingKind :: Type -> Constraint +#endif +class SingKind k where + -- | Get a base type from the promoted kind. For example, + -- @Demote Bool@ will be the type @Bool@. Rarely, the type and kind do not + -- match. For example, @Demote Nat@ is @Natural@. + type Demote k = (r :: Type) | r -> k + + -- | Convert a singleton to its unrefined version. + fromSing :: Sing (a :: k) -> Demote k + + -- | Convert an unrefined type to an existentially-quantified singleton type. + toSing :: Demote k -> SomeSing k + +-- | An /existentially-quantified/ singleton. This type is useful when you want a +-- singleton type, but there is no way of knowing, at compile-time, what the type +-- index will be. To make use of this type, you will generally have to use a +-- pattern-match: +-- +-- > foo :: Bool -> ... +-- > foo b = case toSing b of +-- > SomeSing sb -> {- fancy dependently-typed code with sb -} +-- +-- An example like the one above may be easier to write using 'withSomeSing'. +#if __GLASGOW_HASKELL__ >= 810 +type SomeSing :: Type -> Type +#endif +data SomeSing k where + SomeSing :: Sing (a :: k) -> SomeSing k + +-- | An explicitly bidirectional pattern synonym for going between a +-- singleton and the corresponding demoted term. +-- +-- As an __expression__: this takes a singleton to its demoted (base) +-- type. +-- +-- >>> :t FromSing \@Bool +-- FromSing \@Bool :: Sing a -> Bool +-- >>> FromSing SFalse +-- False +-- +-- As a __pattern__: It extracts a singleton from its demoted (base) +-- type. +-- +-- @ +-- singAnd :: 'Bool' -> 'Bool' -> 'SomeSing' 'Bool' +-- singAnd ('FromSing' singBool1) ('FromSing' singBool2) = +-- 'SomeSing' (singBool1 %&& singBool2) +-- @ +-- +-- instead of writing it with 'withSomeSing': +-- +-- @ +-- singAnd bool1 bool2 = +-- 'withSomeSing' bool1 $ \singBool1 -> +-- 'withSomeSing' bool2 $ \singBool2 -> +-- 'SomeSing' (singBool1 %&& singBool2) +-- @ +#if __GLASGOW_HASKELL__ >= 802 +{-# COMPLETE FromSing #-} +#endif +pattern FromSing :: SingKind k => forall (a :: k). Sing a -> Demote k +pattern FromSing sng <- ((\demotedVal -> withSomeSing demotedVal SomeSing) -> SomeSing sng) + where FromSing sng = fromSing sng + +---------------------------------------------------------------------- +---- WrappedSing ----------------------------------------------------- +---------------------------------------------------------------------- + +-- | A newtype around 'Sing'. +-- +-- Since 'Sing' is a type family, it cannot be used directly in type class +-- instances. As one example, one cannot write a catch-all +-- @instance 'SDecide' k => 'TestEquality' ('Sing' k)@. On the other hand, +-- 'WrappedSing' is a perfectly ordinary data type, which means that it is +-- quite possible to define an +-- @instance 'SDecide' k => 'TestEquality' ('WrappedSing' k)@. +#if __GLASGOW_HASKELL__ >= 810 +type WrappedSing :: k -> Type +#endif +newtype WrappedSing :: forall k. k -> Type where + WrapSing :: forall k (a :: k). { unwrapSing :: Sing a } -> WrappedSing a + +-- | The singleton for 'WrappedSing's. Informally, this is the singleton type +-- for other singletons. +#if __GLASGOW_HASKELL__ >= 810 +type SWrappedSing :: forall k (a :: k). WrappedSing a -> Type +#endif +newtype SWrappedSing :: forall k (a :: k). WrappedSing a -> Type where + SWrapSing :: forall k (a :: k) (ws :: WrappedSing a). + { sUnwrapSing :: Sing a } -> SWrappedSing ws +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @(WrappedSing a) = +#else +type instance Sing = +#endif + SWrappedSing + +#if __GLASGOW_HASKELL__ >= 810 +type UnwrapSing :: forall k (a :: k). WrappedSing a -> Sing a +#endif +type family UnwrapSing (ws :: WrappedSing (a :: k)) :: Sing a where + UnwrapSing ('WrapSing s) = s + +instance SingKind (WrappedSing a) where + type Demote (WrappedSing a) = WrappedSing a + fromSing (SWrapSing s) = WrapSing s + toSing (WrapSing s) = SomeSing $ SWrapSing s + +instance forall a (s :: Sing a). SingI a => SingI ('WrapSing s) where + sing = SWrapSing sing + +---------------------------------------------------------------------- +---- SingInstance ---------------------------------------------------- +---------------------------------------------------------------------- + +-- | A 'SingInstance' wraps up a 'SingI' instance for explicit handling. +#if __GLASGOW_HASKELL__ >= 810 +type SingInstance :: k -> Type +#endif +data SingInstance (a :: k) where + SingInstance :: SingI a => SingInstance a + +-- | Get an implicit singleton (a 'SingI' instance) from an explicit one. +singInstance :: forall k (a :: k). Sing a -> SingInstance a +singInstance s = with_sing_i SingInstance + where + with_sing_i :: (SingI a => SingInstance a) -> SingInstance a +#if MIN_VERSION_base(4,17,0) + with_sing_i = withDict @(SingI a) @(Sing a) s +#else + with_sing_i si = unsafeCoerce (Don'tInstantiate si) s + +-- dirty implementation of explicit-to-implicit conversion +#if __GLASGOW_HASKELL__ >= 810 +type DI :: k -> Type +#endif +newtype DI a = Don'tInstantiate (SingI a => SingInstance a) +#endif + +---------------------------------------------------------------------- +---- Defunctionalization --------------------------------------------- +---------------------------------------------------------------------- + +-- | Representation of the kind of a type-level function. The difference +-- between term-level arrows and this type-level arrow is that at the term +-- level applications can be unsaturated, whereas at the type level all +-- applications have to be fully saturated. +#if __GLASGOW_HASKELL__ >= 810 +type TyFun :: Type -> Type -> Type +#endif +data TyFun :: Type -> Type -> Type + +-- | Something of kind @a '~>' b@ is a defunctionalized type function that is +-- not necessarily generative or injective. Defunctionalized type functions +-- (also called \"defunctionalization symbols\") can be partially applied, even +-- if the original type function cannot be. For more information on how this +-- works, see the "Promotion and partial application" section of the +-- @@. +-- +-- The singleton for things of kind @a '~>' b@ is 'SLambda'. 'SLambda' values +-- can be constructed in one of two ways: +-- +-- 1. With the @singFun*@ family of combinators (e.g., 'singFun1'). For +-- example, if you have: +-- +-- @ +-- type Id :: a -> a +-- sId :: Sing a -> Sing (Id a) +-- @ +-- +-- Then you can construct a value of type @'Sing' \@(a '~>' a)@ (that is, +-- @'SLambda' \@a \@a@ like so: +-- +-- @ +-- sIdFun :: 'Sing' \@(a '~>' a) IdSym0 +-- sIdFun = singFun1 @IdSym0 sId +-- @ +-- +-- Where @IdSym0 :: a '~>' a@ is the defunctionlized version of @Id@. +-- +-- 2. Using the 'SingI' class. For example, @'sing' \@IdSym0@ is another way of +-- defining @sIdFun@ above. The @singletons-th@ library automatically +-- generates 'SingI' instances for defunctionalization symbols such as +-- @IdSym0@. +-- +-- Normal type-level arrows @(->)@ can be converted into defunctionalization +-- arrows @('~>')@ by the use of the 'TyCon' family of types. (Refer to the +-- Haddocks for 'TyCon1' to see an example of this in practice.) For this +-- reason, we do not make an effort to define defunctionalization symbols for +-- most type constructors of kind @a -> b@, as they can be used in +-- defunctionalized settings by simply applying @TyCon{N}@ with an appropriate +-- @N@. +-- +-- This includes the @(->)@ type constructor itself, which is of kind +-- @'Type' -> 'Type' -> 'Type'@. One can turn it into something of kind +-- @'Type' '~>' 'Type' '~>' 'Type'@ by writing @'TyCon2' (->)@, or something of +-- kind @'Type' -> 'Type' '~>' 'Type'@ by writing @'TyCon1' ((->) t)@ +-- (where @t :: 'Type'@). +#if __GLASGOW_HASKELL__ >= 810 +type (~>) :: Type -> Type -> Type +#endif +type a ~> b = TyFun a b -> Type +infixr 0 ~> + +-- | Type level function application +#if __GLASGOW_HASKELL__ >= 810 +type Apply :: (k1 ~> k2) -> k1 -> k2 +#endif +type family Apply (f :: k1 ~> k2) (x :: k1) :: k2 + +-- | An infix synonym for `Apply` +#if __GLASGOW_HASKELL__ >= 810 +type (@@) :: (k1 ~> k2) -> k1 -> k2 +#endif +type a @@ b = Apply a b +infixl 9 @@ + +#if __GLASGOW_HASKELL__ >= 806 +-- | Workhorse for the 'TyCon1', etc., types. This can be used directly +-- in place of any of the @TyConN@ types, but it will work only with +-- /monomorphic/ types. When GHC#14645 is fixed, this should fully supersede +-- the @TyConN@ types. +-- +-- Note that this is only defined on GHC 8.6 or later. Prior to GHC 8.6, +-- 'TyCon1' /et al./ were defined as separate data types. +#if __GLASGOW_HASKELL__ >= 810 +type TyCon :: (k1 -> k2) -> unmatchable_fun +#endif +data family TyCon :: (k1 -> k2) -> unmatchable_fun +-- That unmatchable_fun should really be a function of k1 and k2, +-- but GHC 8.4 doesn't support type family calls in the result kind +-- of a data family. It should. See GHC#14645. + +-- The result kind of this is also a bit wrong; it should line +-- up with unmatchable_fun above. However, we can't do that +-- because GHC is too stupid to remember that f's kind can't +-- have more than one argument when kind-checking the RHS of +-- the second equation. Note that this infelicity is independent +-- of the problem in the kind of TyCon. There is no GHC ticket +-- here because dealing with inequality like this is hard, and +-- I (Richard) wasn't sure what concrete value the ticket would +-- have, given that we don't know how to begin fixing it. + +-- | An \"internal\" definition used primary in the 'Apply' instance for +-- 'TyCon'. +-- +-- Note that this only defined on GHC 8.6 or later. +#if __GLASGOW_HASKELL__ >= 810 +type ApplyTyCon :: (k1 -> k2) -> (k1 ~> unmatchable_fun) +#endif +#if __GLASGOW_HASKELL__ >= 910 +type family ApplyTyCon @k1 @k2 @unmatchable_fun :: (k1 -> k2) -> (k1 ~> unmatchable_fun) where +#else +type family ApplyTyCon :: (k1 -> k2) -> (k1 ~> unmatchable_fun) where +#endif +#if __GLASGOW_HASKELL__ >= 808 + ApplyTyCon @k1 @(k2 -> k3) @unmatchable_fun = ApplyTyConAux2 + ApplyTyCon @k1 @k2 @k2 = ApplyTyConAux1 +#else + ApplyTyCon = (ApplyTyConAux2 :: (k1 -> k2 -> k3) -> (k1 ~> unmatchable_fun)) + ApplyTyCon = (ApplyTyConAux1 :: (k1 -> k2) -> (k1 ~> k2)) +#endif +-- Upon first glance, the definition of ApplyTyCon (as well as the +-- corresponding Apply instance for TyCon) seems a little indirect. One might +-- wonder why these aren't defined like so: +-- +-- type family ApplyTyCon (f :: k1 -> k2) (x :: k1) :: k3 where +-- ApplyTyCon (f :: k1 -> k2 -> k3) x = TyCon (f x) +-- ApplyTyCon f x = f x +-- +-- type instance Apply (TyCon f) x = ApplyTyCon f x +-- +-- This also works, but it requires that ApplyTyCon always be applied to a +-- minimum of two arguments. In particular, this rules out a trick that we use +-- elsewhere in the library to write SingI instances for different TyCons, +-- which relies on partial applications of ApplyTyCon: +-- +-- instance forall k1 k2 (f :: k1 -> k2). +-- ( forall a. SingI a => SingI (f a) +-- , (ApplyTyCon :: (k1 -> k2) -> (k1 ~> k2)) ~ ApplyTyConAux1 +-- ) => SingI (TyCon1 f) where +#if __GLASGOW_HASKELL__ >= 808 +type instance Apply @k1 @k3 (TyCon @k1 @k2 @(k1 ~> k3) f) x = +#else +type instance Apply (TyCon f) x = +#endif + ApplyTyCon f @@ x + +-- | An \"internal\" defunctionalization symbol used primarily in the +-- definition of 'ApplyTyCon', as well as the 'SingI' instances for 'TyCon1', +-- 'TyCon2', etc. +-- +-- Note that this is only defined on GHC 8.6 or later. +#if __GLASGOW_HASKELL__ >= 810 +type ApplyTyConAux1 :: (k1 -> k2) -> (k1 ~> k2) +#endif +data ApplyTyConAux1 :: (k1 -> k2) -> (k1 ~> k2) + +-- | An \"internal\" defunctionalization symbol used primarily in the +-- definition of 'ApplyTyCon'. +-- +-- Note that this is only defined on GHC 8.6 or later. +#if __GLASGOW_HASKELL__ >= 810 +type ApplyTyConAux2 :: (k1 -> k2 -> k3) -> (k1 ~> unmatchable_fun) +#endif +data ApplyTyConAux2 :: (k1 -> k2 -> k3) -> (k1 ~> unmatchable_fun) + +type instance Apply (ApplyTyConAux1 f) x = f x +type instance Apply (ApplyTyConAux2 f) x = TyCon (f x) + +#if __GLASGOW_HASKELL__ >= 810 +type TyCon1 :: (k1 -> k2) -> (k1 ~> k2) +type TyCon2 :: (k1 -> k2 -> k3) -> (k1 ~> k2 ~> k3) +type TyCon3 :: (k1 -> k2 -> k3 -> k4) -> (k1 ~> k2 ~> k3 ~> k4) +type TyCon4 :: (k1 -> k2 -> k3 -> k4 -> k5) -> (k1 ~> k2 ~> k3 ~> k4 ~> k5) +type TyCon5 :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6) + -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6) +type TyCon6 :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7) + -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7) +type TyCon7 :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7 -> k8) + -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7 ~> k8) +type TyCon8 :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7 -> k8 -> k9) + -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7 ~> k8 ~> k9) +#endif + +-- | Wrapper for converting the normal type-level arrow into a '~>'. +-- For example, given: +-- +-- > data Nat = Zero | Succ Nat +-- > type family Map (a :: a ~> b) (a :: [a]) :: [b] +-- > Map f '[] = '[] +-- > Map f (x ': xs) = Apply f x ': Map f xs +-- +-- We can write: +-- +-- > Map (TyCon1 Succ) [Zero, Succ Zero] +#if __GLASGOW_HASKELL__ >= 910 +type TyCon1 @k1 @k2 = (TyCon :: (k1 -> k2) -> (k1 ~> k2)) + +-- | Similar to 'TyCon1', but for two-parameter type constructors. +type TyCon2 @k1 @k2 @k3 = + (TyCon :: (k1 -> k2 -> k3) -> (k1 ~> k2 ~> k3)) +type TyCon3 @k1 @k2 @k3 @k4 = + (TyCon :: (k1 -> k2 -> k3 -> k4) -> (k1 ~> k2 ~> k3 ~> k4)) +type TyCon4 @k1 @k2 @k3 @k4 @k5 = + (TyCon :: (k1 -> k2 -> k3 -> k4 -> k5) -> (k1 ~> k2 ~> k3 ~> k4 ~> k5)) +type TyCon5 @k1 @k2 @k3 @k4 @k5 @k6 = + (TyCon :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6) + -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6)) +type TyCon6 @k1 @k2 @k3 @k4 @k5 @k6 @k7 = + (TyCon :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7) + -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7)) +type TyCon7 @k1 @k2 @k3 @k4 @k5 @k6 @k7 @k8 = + (TyCon :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7 -> k8) + -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7 ~> k8)) +type TyCon8 @k1 @k2 @k3 @k4 @k5 @k6 @k7 @k8 @k9 = + (TyCon :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7 -> k8 -> k9) + -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7 ~> k8 ~> k9)) +#else +type TyCon1 = (TyCon :: (k1 -> k2) -> (k1 ~> k2)) + +-- | Similar to 'TyCon1', but for two-parameter type constructors. +type TyCon2 = (TyCon :: (k1 -> k2 -> k3) -> (k1 ~> k2 ~> k3)) +type TyCon3 = (TyCon :: (k1 -> k2 -> k3 -> k4) -> (k1 ~> k2 ~> k3 ~> k4)) +type TyCon4 = (TyCon :: (k1 -> k2 -> k3 -> k4 -> k5) -> (k1 ~> k2 ~> k3 ~> k4 ~> k5)) +type TyCon5 = (TyCon :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6) + -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6)) +type TyCon6 = (TyCon :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7) + -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7)) +type TyCon7 = (TyCon :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7 -> k8) + -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7 ~> k8)) +type TyCon8 = (TyCon :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7 -> k8 -> k9) + -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7 ~> k8 ~> k9)) +#endif +#else +-- | Wrapper for converting the normal type-level arrow into a '~>'. +-- For example, given: +-- +-- > data Nat = Zero | Succ Nat +-- > type family Map (a :: a ~> b) (a :: [a]) :: [b] +-- > Map f '[] = '[] +-- > Map f (x ': xs) = Apply f x ': Map f xs +-- +-- We can write: +-- +-- > Map (TyCon1 Succ) [Zero, Succ Zero] +data TyCon1 :: (k1 -> k2) -> (k1 ~> k2) + +-- | Similar to 'TyCon1', but for two-parameter type constructors. +data TyCon2 :: (k1 -> k2 -> k3) -> (k1 ~> k2 ~> k3) +data TyCon3 :: (k1 -> k2 -> k3 -> k4) -> (k1 ~> k2 ~> k3 ~> k4) +data TyCon4 :: (k1 -> k2 -> k3 -> k4 -> k5) -> (k1 ~> k2 ~> k3 ~> k4 ~> k5) +data TyCon5 :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6) + -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6) +data TyCon6 :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7) + -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7) +data TyCon7 :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7 -> k8) + -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7 ~> k8) +data TyCon8 :: (k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7 -> k8 -> k9) + -> (k1 ~> k2 ~> k3 ~> k4 ~> k5 ~> k6 ~> k7 ~> k8 ~> k9) + +type instance Apply (TyCon1 f) x = f x +type instance Apply (TyCon2 f) x = TyCon1 (f x) +type instance Apply (TyCon3 f) x = TyCon2 (f x) +type instance Apply (TyCon4 f) x = TyCon3 (f x) +type instance Apply (TyCon5 f) x = TyCon4 (f x) +type instance Apply (TyCon6 f) x = TyCon5 (f x) +type instance Apply (TyCon7 f) x = TyCon6 (f x) +type instance Apply (TyCon8 f) x = TyCon7 (f x) +#endif + +---------------------------------------------------------------------- +---- Defunctionalized Sing instance and utilities -------------------- +---------------------------------------------------------------------- + +-- | The singleton type for functions. Functions have somewhat special +-- treatment in @singletons@ (see the Haddocks for @('~>')@ for more information +-- about this), and as a result, the 'Sing' instance for 'SLambda' is one of the +-- only such instances defined in the @singletons@ library rather than, say, +-- @singletons-base@. +#if __GLASGOW_HASKELL__ >= 810 +type SLambda :: (k1 ~> k2) -> Type +#endif +newtype SLambda (f :: k1 ~> k2) = + SLambda { applySing :: forall t. Sing t -> Sing (f @@ t) } +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @(k1 ~> k2) = +#else +type instance Sing = +#endif + SLambda + +-- | An infix synonym for `applySing` +(@@) :: forall k1 k2 (f :: k1 ~> k2) (t :: k1). Sing f -> Sing t -> Sing (f @@ t) +(@@) f = applySing f + +-- | Note that this instance's 'toSing' implementation crucially relies on the fact +-- that the 'SingKind' instances for 'k1' and 'k2' both satisfy the 'SingKind' laws. +-- If they don't, 'toSing' might produce strange results! +instance (SingKind k1, SingKind k2) => SingKind (k1 ~> k2) where + type Demote (k1 ~> k2) = Demote k1 -> Demote k2 + fromSing sFun x = withSomeSing x (fromSing . applySing sFun) + toSing f = SomeSing slam + where + -- Here, we are essentially "manufacturing" a type-level version of the + -- function f. As long as k1 and k2 obey the SingKind laws, this is a + -- perfectly fine thing to do, since the computational content of Sing f + -- will be isomorphic to that of the function f. + slam :: forall (f :: k1 ~> k2). Sing f + slam = singFun1 @f lam + where + -- Here's the tricky part. We need to demote the argument Sing, apply the + -- term-level function f to it, and promote it back to a Sing. However, + -- we don't have a way to convince the typechecker that for all argument + -- types t, f @@ t should be the same thing as res, which motivates the + -- use of unsafeCoerce. + lam :: forall (t :: k1). Sing t -> Sing (f @@ t) + lam x = withSomeSing (f (fromSing x)) (\(r :: Sing res) -> unsafeCoerce r) + +#if __GLASGOW_HASKELL__ >= 810 +type SingFunction1 :: (a1 ~> b) -> Type +type SingFunction2 :: (a1 ~> a2 ~> b) -> Type +type SingFunction3 :: (a1 ~> a2 ~> a3 ~> b) -> Type +type SingFunction4 :: (a1 ~> a2 ~> a3 ~> a4 ~> b) -> Type +type SingFunction5 :: (a1 ~> a2 ~> a3 ~> a4 ~> a5 ~> b) -> Type +type SingFunction6 :: (a1 ~> a2 ~> a3 ~> a4 ~> a5 ~> a6 ~> b) -> Type +type SingFunction7 :: (a1 ~> a2 ~> a3 ~> a4 ~> a5 ~> a6 ~> a7 ~> b) -> Type +type SingFunction8 :: (a1 ~> a2 ~> a3 ~> a4 ~> a5 ~> a6 ~> a7 ~> a8 ~> b) -> Type +#endif + +type SingFunction1 (f :: a1 ~> b) = + forall t. Sing t -> Sing (f @@ t) + +-- | Use this function when passing a function on singletons as +-- a higher-order function. You will need visible type application +-- to get this to work. For example: +-- +-- > falses = sMap (singFun1 @NotSym0 sNot) +-- > (STrue `SCons` STrue `SCons` SNil) +-- +-- There are a family of @singFun...@ functions, keyed by the number +-- of parameters of the function. +singFun1 :: forall f. SingFunction1 f -> Sing f +singFun1 f = SLambda f + +type SingFunction2 (f :: a1 ~> a2 ~> b) = + forall t1 t2. Sing t1 -> Sing t2 -> Sing (f @@ t1 @@ t2) +singFun2 :: forall f. SingFunction2 f -> Sing f +singFun2 f = SLambda (\x -> singFun1 (f x)) + +type SingFunction3 (f :: a1 ~> a2 ~> a3 ~> b) = + forall t1 t2 t3. + Sing t1 -> Sing t2 -> Sing t3 + -> Sing (f @@ t1 @@ t2 @@ t3) +singFun3 :: forall f. SingFunction3 f -> Sing f +singFun3 f = SLambda (\x -> singFun2 (f x)) + +type SingFunction4 (f :: a1 ~> a2 ~> a3 ~> a4 ~> b) = + forall t1 t2 t3 t4. + Sing t1 -> Sing t2 -> Sing t3 -> Sing t4 + -> Sing (f @@ t1 @@ t2 @@ t3 @@ t4) +singFun4 :: forall f. SingFunction4 f -> Sing f +singFun4 f = SLambda (\x -> singFun3 (f x)) + +type SingFunction5 (f :: a1 ~> a2 ~> a3 ~> a4 ~> a5 ~> b) = + forall t1 t2 t3 t4 t5. + Sing t1 -> Sing t2 -> Sing t3 -> Sing t4 -> Sing t5 + -> Sing (f @@ t1 @@ t2 @@ t3 @@ t4 @@ t5) +singFun5 :: forall f. SingFunction5 f -> Sing f +singFun5 f = SLambda (\x -> singFun4 (f x)) + +type SingFunction6 (f :: a1 ~> a2 ~> a3 ~> a4 ~> a5 ~> a6 ~> b) = + forall t1 t2 t3 t4 t5 t6. + Sing t1 -> Sing t2 -> Sing t3 -> Sing t4 -> Sing t5 -> Sing t6 + -> Sing (f @@ t1 @@ t2 @@ t3 @@ t4 @@ t5 @@ t6) +singFun6 :: forall f. SingFunction6 f -> Sing f +singFun6 f = SLambda (\x -> singFun5 (f x)) + +type SingFunction7 (f :: a1 ~> a2 ~> a3 ~> a4 ~> a5 ~> a6 ~> a7 ~> b) = + forall t1 t2 t3 t4 t5 t6 t7. + Sing t1 -> Sing t2 -> Sing t3 -> Sing t4 -> Sing t5 -> Sing t6 -> Sing t7 + -> Sing (f @@ t1 @@ t2 @@ t3 @@ t4 @@ t5 @@ t6 @@ t7) +singFun7 :: forall f. SingFunction7 f -> Sing f +singFun7 f = SLambda (\x -> singFun6 (f x)) + +type SingFunction8 (f :: a1 ~> a2 ~> a3 ~> a4 ~> a5 ~> a6 ~> a7 ~> a8 ~> b) = + forall t1 t2 t3 t4 t5 t6 t7 t8. + Sing t1 -> Sing t2 -> Sing t3 -> Sing t4 -> Sing t5 -> Sing t6 -> Sing t7 -> Sing t8 + -> Sing (f @@ t1 @@ t2 @@ t3 @@ t4 @@ t5 @@ t6 @@ t7 @@ t8) +singFun8 :: forall f. SingFunction8 f -> Sing f +singFun8 f = SLambda (\x -> singFun7 (f x)) + +-- | This is the inverse of 'singFun1', and likewise for the other +-- @unSingFun...@ functions. +unSingFun1 :: forall f. Sing f -> SingFunction1 f +unSingFun1 sf = applySing sf + +unSingFun2 :: forall f. Sing f -> SingFunction2 f +unSingFun2 sf x = unSingFun1 (sf @@ x) + +unSingFun3 :: forall f. Sing f -> SingFunction3 f +unSingFun3 sf x = unSingFun2 (sf @@ x) + +unSingFun4 :: forall f. Sing f -> SingFunction4 f +unSingFun4 sf x = unSingFun3 (sf @@ x) + +unSingFun5 :: forall f. Sing f -> SingFunction5 f +unSingFun5 sf x = unSingFun4 (sf @@ x) + +unSingFun6 :: forall f. Sing f -> SingFunction6 f +unSingFun6 sf x = unSingFun5 (sf @@ x) + +unSingFun7 :: forall f. Sing f -> SingFunction7 f +unSingFun7 sf x = unSingFun6 (sf @@ x) + +unSingFun8 :: forall f. Sing f -> SingFunction8 f +unSingFun8 sf x = unSingFun7 (sf @@ x) + +#if __GLASGOW_HASKELL__ >= 802 +{-# COMPLETE SLambda2 #-} +{-# COMPLETE SLambda3 #-} +{-# COMPLETE SLambda4 #-} +{-# COMPLETE SLambda5 #-} +{-# COMPLETE SLambda6 #-} +{-# COMPLETE SLambda7 #-} +{-# COMPLETE SLambda8 #-} +#endif + +pattern SLambda2 :: forall f. SingFunction2 f -> Sing f +pattern SLambda2 {applySing2} <- (unSingFun2 -> applySing2) + where SLambda2 lam2 = singFun2 lam2 + +pattern SLambda3 :: forall f. SingFunction3 f -> Sing f +pattern SLambda3 {applySing3} <- (unSingFun3 -> applySing3) + where SLambda3 lam3 = singFun3 lam3 + +pattern SLambda4 :: forall f. SingFunction4 f -> Sing f +pattern SLambda4 {applySing4} <- (unSingFun4 -> applySing4) + where SLambda4 lam4 = singFun4 lam4 + +pattern SLambda5 :: forall f. SingFunction5 f -> Sing f +pattern SLambda5 {applySing5} <- (unSingFun5 -> applySing5) + where SLambda5 lam5 = singFun5 lam5 + +pattern SLambda6 :: forall f. SingFunction6 f -> Sing f +pattern SLambda6 {applySing6} <- (unSingFun6 -> applySing6) + where SLambda6 lam6 = singFun6 lam6 + +pattern SLambda7 :: forall f. SingFunction7 f -> Sing f +pattern SLambda7 {applySing7} <- (unSingFun7 -> applySing7) + where SLambda7 lam7 = singFun7 lam7 + +pattern SLambda8 :: forall f. SingFunction8 f -> Sing f +pattern SLambda8 {applySing8} <- (unSingFun8 -> applySing8) + where SLambda8 lam8 = singFun8 lam8 + +---------------------------------------------------------------------- +---- Convenience ----------------------------------------------------- +---------------------------------------------------------------------- + +-- | Convenience function for creating a context with an implicit singleton +-- available. +withSingI :: Sing n -> (SingI n => r) -> r +withSingI sn r = + case singInstance sn of + SingInstance -> r + +-- | Convert a normal datatype (like 'Bool') to a singleton for that datatype, +-- passing it into a continuation. +withSomeSing :: forall k r + . SingKind k + => Demote k -- ^ The original datatype + -> (forall (a :: k). Sing a -> r) -- ^ Function expecting a singleton + -> r +withSomeSing x f = + case toSing x of + SomeSing x' -> f x' + +-- | Convert a group of 'SingI1' and 'SingI' constraints (representing a +-- function to apply and its argument, respectively) into a single 'SingI' +-- constraint representing the application. You will likely need the +-- @ScopedTypeVariables@ extension to use this method the way you want. +usingSingI1 :: forall f x r. (SingI1 f, SingI x) => (SingI (f x) => r) -> r +usingSingI1 k = withSingI (sing1 @f @x) k + +-- | Convert a group of 'SingI2' and 'SingI' constraints (representing a +-- function to apply and its arguments, respectively) into a single 'SingI' +-- constraint representing the application. You will likely need the +-- @ScopedTypeVariables@ extension to use this method the way you want. +usingSingI2 :: forall f x y r. (SingI2 f, SingI x, SingI y) => (SingI (f x y) => r) -> r +usingSingI2 k = withSingI (sing2 @f @x @y) k + +-- | A convenience function useful when we need to name a singleton value +-- multiple times. Without this function, each use of 'sing' could potentially +-- refer to a different singleton, and one has to use type signatures (often +-- with @ScopedTypeVariables@) to ensure that they are the same. +withSing :: SingI a => (Sing a -> b) -> b +withSing f = f sing + +-- | A convenience function useful when we need to name a singleton value for a +-- unary type constructor multiple times. Without this function, each use of +-- 'sing1' could potentially refer to a different singleton, and one has to use +-- type signatures (often with @ScopedTypeVariables@) to ensure that they are +-- the same. +withSing1 :: (SingI1 f, SingI x) => (Sing (f x) -> b) -> b +withSing1 f = f sing1 + +-- | A convenience function useful when we need to name a singleton value for a +-- binary type constructor multiple times. Without this function, each use of +-- 'sing1' could potentially refer to a different singleton, and one has to use +-- type signatures (often with @ScopedTypeVariables@) to ensure that they are +-- the same. +withSing2 :: (SingI2 f, SingI x, SingI y) => (Sing (f x y) -> b) -> b +withSing2 f = f sing2 + +-- | A convenience function that names a singleton satisfying a certain +-- property. If the singleton does not satisfy the property, then the function +-- returns 'Nothing'. The property is expressed in terms of the underlying +-- representation of the singleton. +singThat :: forall k (a :: k). (SingKind k, SingI a) + => (Demote k -> Bool) -> Maybe (Sing a) +singThat p = withSing $ \x -> if p (fromSing x) then Just x else Nothing + +-- | A convenience function that names a singleton for a unary type constructor +-- satisfying a certain property. If the singleton does not satisfy the +-- property, then the function returns 'Nothing'. The property is expressed in +-- terms of the underlying representation of the singleton. +singThat1 :: forall k1 k2 (f :: k1 -> k2) (x :: k1). + (SingKind k2, SingI1 f, SingI x) + => (Demote k2 -> Bool) -> Maybe (Sing (f x)) +singThat1 p = withSing1 $ \x -> if p (fromSing x) then Just x else Nothing + +-- | A convenience function that names a singleton for a binary type constructor +-- satisfying a certain property. If the singleton does not satisfy the +-- property, then the function returns 'Nothing'. The property is expressed in +-- terms of the underlying representation of the singleton. +singThat2 :: forall k1 k2 k3 (f :: k1 -> k2 -> k3) (x :: k1) (y :: k2). + (SingKind k3, SingI2 f, SingI x, SingI y) + => (Demote k3 -> Bool) -> Maybe (Sing (f x y)) +singThat2 p = withSing2 $ \x -> if p (fromSing x) then Just x else Nothing + +-- | Allows creation of a singleton when a proxy is at hand. +singByProxy :: SingI a => proxy a -> Sing a +singByProxy _ = sing + +-- | Allows creation of a singleton for a unary type constructor when a proxy +-- is at hand. +singByProxy1 :: (SingI1 f, SingI x) => proxy (f x) -> Sing (f x) +singByProxy1 _ = sing1 + +-- | Allows creation of a singleton for a binary type constructor when a proxy +-- is at hand. +singByProxy2 :: (SingI2 f, SingI x, SingI y) => proxy (f x y) -> Sing (f x y) +singByProxy2 _ = sing2 + +-- | Allows creation of a singleton when a @proxy#@ is at hand. +singByProxy# :: SingI a => Proxy# a -> Sing a +singByProxy# _ = sing + +-- | Allows creation of a singleton for a unary type constructor when a +-- @proxy#@ is at hand. +singByProxy1# :: (SingI1 f, SingI x) => Proxy# (f x) -> Sing (f x) +singByProxy1# _ = sing1 + +-- | Allows creation of a singleton for a binary type constructor when a +-- @proxy#@ is at hand. +singByProxy2# :: (SingI2 f, SingI x, SingI y) => Proxy# (f x y) -> Sing (f x y) +singByProxy2# _ = sing2 + +-- | A convenience function that takes a type as input and demotes it to its +-- value-level counterpart as output. This uses 'SingKind' and 'SingI' behind +-- the scenes, so @'demote' = 'fromSing' 'sing'@. +-- +-- This function is intended to be used with @TypeApplications@. For example: +-- +-- >>> demote @True +-- True +-- +-- >>> demote @(Nothing :: Maybe Ordering) +-- Nothing +-- +-- >>> demote @(Just EQ) +-- Just EQ +-- +-- >>> demote @'(True,EQ) +-- (True,EQ) +demote :: +#if __GLASGOW_HASKELL__ >= 900 + forall {k} (a :: k). (SingKind k, SingI a) => Demote k +#else + forall a. (SingKind (KindOf a), SingI a) => Demote (KindOf a) +#endif +demote = fromSing (sing @a) + +-- | A convenience function that takes a unary type constructor and its +-- argument as input, applies them, and demotes the result to its +-- value-level counterpart as output. This uses 'SingKind', 'SingI1', and +-- 'SingI' behind the scenes, so @'demote1' = 'fromSing' 'sing1'@. +-- +-- This function is intended to be used with @TypeApplications@. For example: +-- +-- >>> demote1 @Just @EQ +-- Just EQ +-- +-- >>> demote1 @('(,) True) @EQ +-- (True,EQ) +demote1 :: +#if __GLASGOW_HASKELL__ >= 900 + forall {k1} {k2} (f :: k1 -> k2) (x :: k1). + (SingKind k2, SingI1 f, SingI x) => + Demote k2 +#else + forall f x. + (SingKind (KindOf (f x)), SingI1 f, SingI x) => + Demote (KindOf (f x)) +#endif +demote1 = fromSing (sing1 @f @x) + +-- | A convenience function that takes a binary type constructor and its +-- arguments as input, applies them, and demotes the result to its +-- value-level counterpart as output. This uses 'SingKind', 'SingI2', and +-- 'SingI' behind the scenes, so @'demote2' = 'fromSing' 'sing2'@. +-- +-- This function is intended to be used with @TypeApplications@. For example: +-- +-- >>> demote2 @'(,) @True @EQ +-- (True,EQ) +demote2 :: +#if __GLASGOW_HASKELL__ >= 900 + forall {k1} {k2} {k3} (f :: k1 -> k2 -> k3) (x :: k1) (y :: k2). + (SingKind k3, SingI2 f, SingI x, SingI y) => + Demote k3 +#else + forall f x y. + (SingKind (KindOf (f x y)), SingI2 f, SingI x, SingI y) => + Demote (KindOf (f x y)) +#endif +demote2 = fromSing (sing2 @f @x @y) + +---------------------------------------------------------------------- +---- SingI TyCon{N} instances ---------------------------------------- +---------------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ >= 806 +instance forall k1 kr (f :: k1 -> kr). + ( forall a. SingI a => SingI (f a) + , (ApplyTyCon :: (k1 -> kr) -> (k1 ~> kr)) + ~ ApplyTyConAux1 + ) => SingI (TyCon1 f) where + sing = singFun1 (`withSingI` sing) +instance forall k1 k2 kr (f :: k1 -> k2 -> kr). + ( forall a b. (SingI a, SingI b) => SingI (f a b) + , (ApplyTyCon :: (k2 -> kr) -> (k2 ~> kr)) + ~ ApplyTyConAux1 + ) => SingI (TyCon2 f) where + sing = singFun1 (`withSingI` sing) +instance forall k1 k2 k3 kr (f :: k1 -> k2 -> k3 -> kr). + ( forall a b c. (SingI a, SingI b, SingI c) => SingI (f a b c) + , (ApplyTyCon :: (k3 -> kr) -> (k3 ~> kr)) + ~ ApplyTyConAux1 + ) => SingI (TyCon3 f) where + sing = singFun1 (`withSingI` sing) +instance forall k1 k2 k3 k4 kr (f :: k1 -> k2 -> k3 -> k4 -> kr). + ( forall a b c d. (SingI a, SingI b, SingI c, SingI d) => SingI (f a b c d) + , (ApplyTyCon :: (k4 -> kr) -> (k4 ~> kr)) + ~ ApplyTyConAux1 + ) => SingI (TyCon4 f) where + sing = singFun1 (`withSingI` sing) +instance forall k1 k2 k3 k4 k5 kr + (f :: k1 -> k2 -> k3 -> k4 -> k5 -> kr). + ( forall a b c d e. + (SingI a, SingI b, SingI c, SingI d, SingI e) + => SingI (f a b c d e) + , (ApplyTyCon :: (k5 -> kr) -> (k5 ~> kr)) + ~ ApplyTyConAux1 + ) => SingI (TyCon5 f) where + sing = singFun1 (`withSingI` sing) +instance forall k1 k2 k3 k4 k5 k6 kr + (f :: k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> kr). + ( forall a b c d e f'. + (SingI a, SingI b, SingI c, SingI d, SingI e, SingI f') + => SingI (f a b c d e f') + , (ApplyTyCon :: (k6 -> kr) -> (k6 ~> kr)) + ~ ApplyTyConAux1 + ) => SingI (TyCon6 f) where + sing = singFun1 (`withSingI` sing) +instance forall k1 k2 k3 k4 k5 k6 k7 kr + (f :: k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7 -> kr). + ( forall a b c d e f' g. + (SingI a, SingI b, SingI c, SingI d, SingI e, SingI f', SingI g) + => SingI (f a b c d e f' g) + , (ApplyTyCon :: (k7 -> kr) -> (k7 ~> kr)) + ~ ApplyTyConAux1 + ) => SingI (TyCon7 f) where + sing = singFun1 (`withSingI` sing) +instance forall k1 k2 k3 k4 k5 k6 k7 k8 kr + (f :: k1 -> k2 -> k3 -> k4 -> k5 -> k6 -> k7 -> k8 -> kr). + ( forall a b c d e f' g h. + (SingI a, SingI b, SingI c, SingI d, SingI e, SingI f', SingI g, SingI h) + => SingI (f a b c d e f' g h) + , (ApplyTyCon :: (k8 -> kr) -> (k8 ~> kr)) + ~ ApplyTyConAux1 + ) => SingI (TyCon8 f) where + sing = singFun1 (`withSingI` sing) +#endif + +---------------------------------------------------------------------- +---- Defunctionalization symbols ------------------------------------- +---------------------------------------------------------------------- + +-- $(genDefunSymbols [''Demote, ''SameKind, ''KindOf, ''(~>), ''Apply, ''(@@)]) +-- WrapSing, UnwrapSing, and SingFunction1 et al. are not defunctionalizable +-- at the moment due to GHC#9269 + +#if __GLASGOW_HASKELL__ >= 810 +type DemoteSym0 :: Type ~> Type +type DemoteSym1 :: Type -> Type +#endif + +data DemoteSym0 :: Type ~> Type +type DemoteSym1 x = Demote x + +type instance Apply DemoteSym0 x = Demote x + +----- + +#if __GLASGOW_HASKELL__ >= 810 +type SameKindSym0 :: forall k. k ~> k ~> Constraint +type SameKindSym1 :: forall k. k -> k ~> Constraint +type SameKindSym2 :: forall k. k -> k -> Constraint +#endif + +data SameKindSym0 :: forall k. k ~> k ~> Constraint +data SameKindSym1 :: forall k. k -> k ~> Constraint +type SameKindSym2 (x :: k) (y :: k) = SameKind x y + +type instance Apply SameKindSym0 x = SameKindSym1 x +type instance Apply (SameKindSym1 x) y = SameKind x y + +----- + +#if __GLASGOW_HASKELL__ >= 810 +type KindOfSym0 :: forall k. k ~> Type +type KindOfSym1 :: forall k. k -> Type +#endif + +data KindOfSym0 :: forall k. k ~> Type +type KindOfSym1 (x :: k) = KindOf x + +type instance Apply KindOfSym0 x = KindOf x + +----- + +infixr 0 ~>@#@$, ~>@#@$$, ~>@#@$$$ + +#if __GLASGOW_HASKELL__ >= 810 +type (~>@#@$) :: Type ~> Type ~> Type +type (~>@#@$$) :: Type -> Type ~> Type +type (~>@#@$$$) :: Type -> Type -> Type +#endif + +data (~>@#@$) :: Type ~> Type ~> Type +data (~>@#@$$) :: Type -> Type ~> Type +type x ~>@#@$$$ y = x ~> y + +type instance Apply (~>@#@$) x = (~>@#@$$) x +type instance Apply ((~>@#@$$) x) y = x ~> y + +----- + +#if __GLASGOW_HASKELL__ >= 810 +type ApplySym0 :: forall a b. (a ~> b) ~> a ~> b +type ApplySym1 :: forall a b. (a ~> b) -> a ~> b +type ApplySym2 :: forall a b. (a ~> b) -> a -> b +#endif + +data ApplySym0 :: forall a b. (a ~> b) ~> a ~> b +data ApplySym1 :: forall a b. (a ~> b) -> a ~> b +type ApplySym2 (f :: a ~> b) (x :: a) = Apply f x + +type instance Apply ApplySym0 f = ApplySym1 f +type instance Apply (ApplySym1 f) x = Apply f x + +----- + +infixl 9 @@@#@$, @@@#@$$, @@@#@$$$ + +#if __GLASGOW_HASKELL__ >= 810 +type (@@@#@$) :: forall a b. (a ~> b) ~> a ~> b +type (@@@#@$$) :: forall a b. (a ~> b) -> a ~> b +type (@@@#@$$$) :: forall a b. (a ~> b) -> a -> b +#endif + +data (@@@#@$) :: forall a b. (a ~> b) ~> a ~> b +data (@@@#@$$) :: forall a b. (a ~> b) -> a ~> b +type (f :: a ~> b) @@@#@$$$ (x :: a) = f @@ x + +type instance Apply (@@@#@$) f = (@@@#@$$) f +type instance Apply ((@@@#@$$) f) x = f @@ x + +{- $SingletonsOfSingletons + +Aside from being a data type to hang instances off of, 'WrappedSing' has +another purpose as a general-purpose mechanism for allowing one to write +code that uses singletons of other singletons. For instance, suppose you +had the following data type: + +@ +data T :: Type -> Type where + MkT :: forall a (x :: a). 'Sing' x -> F a -> T a +@ + +A naïve attempt at defining a singleton for @T@ would look something like +this: + +@ +data ST :: forall a. T a -> Type where + SMkT :: forall a (x :: a) (sx :: 'Sing' x) (f :: F a). + 'Sing' sx -> 'Sing' f -> ST (MkT sx f) +@ + +But there is a problem here: what exactly /is/ @'Sing' sx@? If @x@ were 'True', +for instance, then @sx@ would be 'STrue', but it's not clear what +@'Sing' 'STrue'@ should be. One could define @SSBool@ to be the singleton of +'SBool's, but in order to be thorough, one would have to generate a singleton +for /every/ singleton type out there. Plus, it's not clear when to stop. Should +we also generate @SSSBool@, @SSSSBool@, etc.? + +Instead, 'WrappedSing' and its singleton 'SWrappedSing' provide a way to talk +about singletons of other arbitrary singletons without the need to generate a +bazillion instances. For reference, here is the definition of 'SWrappedSing': + +@ +newtype 'SWrappedSing' :: forall k (a :: k). 'WrappedSing' a -> Type where + 'SWrapSing' :: forall k (a :: k) (ws :: 'WrappedSing' a). + { 'sUnwrapSing' :: 'Sing' a } -> 'SWrappedSing' ws +type instance 'Sing' \@('WrappedSing' a) = 'SWrappedSing' +@ + +'SWrappedSing' is a bit of an unusual singleton in that its field is a +singleton for @'Sing' \@k@, not @'WrappedSing' \@k@. But that's exactly the +point—a singleton of a singleton contains as much type information as the +underlying singleton itself, so we can get away with just @'Sing' \@k@. + +As an example of this in action, here is how you would define the singleton +for the earlier @T@ type: + +@ +data ST :: forall a. T a -> Type where + SMkT :: forall a (x :: a) (sx :: 'Sing' x) (f :: F a). + 'Sing' ('WrapSing' sx) -> 'Sing' f -> ST (MkT sx f) +@ + +With this technique, we won't need anything like @SSBool@ in order to +instantiate @x@ with 'True'. Instead, the field of type +@'Sing' ('WrapSing' sx)@ will simply be a newtype around 'SBool'. In general, +you'll need /n/ layers of 'WrapSing' if you wish to single a singleton /n/ +times. + +Note that this is not the only possible way to define a singleton for @T@. +An alternative approach that does not make use of singletons-of-singletons is +discussed at some length +. +Due to the technical limitations of this approach, however, we do not use it +in @singletons@ at the moment, instead favoring the +slightly-clunkier-but-more-reliable 'WrappedSing' approach. +-} + +{- $SLambdaPatternSynonyms + +@SLambda{2...8}@ are explicitly bidirectional pattern synonyms for +defunctionalized singletons (@'Sing' (f :: k '~>' k' '~>' k'')@). + +As __constructors__: Same as @singFun{2..8}@. For example, one can turn a +binary function on singletons @sTake :: 'SingFunction2' TakeSym0@ into a +defunctionalized singleton @'Sing' (TakeSym :: Nat '~>' [a] '~>' [a])@: + +@ +>>> import Data.List.Singletons +>>> :set -XTypeApplications +>>> +>>> :t 'SLambda2' +'SLambda2' :: 'SingFunction2' f -> 'Sing' f +>>> :t 'SLambda2' \@TakeSym0 +'SLambda2' :: 'SingFunction2' TakeSym0 -> 'Sing' TakeSym0 +>>> :t 'SLambda2' \@TakeSym0 sTake +'SLambda2' :: 'Sing' TakeSym0 +@ + +This is useful for functions on singletons that expect a defunctionalized +singleton as an argument, such as @sZipWith :: 'SingFunction3' ZipWithSym0@: + +@ +sZipWith :: Sing (f :: a '~>' b '~>' c) -> Sing (xs :: [a]) -> Sing (ys :: [b]) -> Sing (ZipWith f xs ys :: [c]) +sZipWith ('SLambda2' \@TakeSym0 sTake) :: Sing (xs :: [Nat]) -> Sing (ys :: [[a]]) -> Sing (ZipWith TakeSym0 xs ys :: [[a]]) +@ + +As __patterns__: Same as @unSingFun{2..8}@. Gets a binary term-level +Haskell function on singletons +@'Sing' (x :: k) -> 'Sing' (y :: k') -> 'Sing' (f \@\@ x \@\@ y)@ +from a defunctionalised @'Sing' f@. Alternatively, as a record field accessor: + +@ +applySing2 :: 'Sing' (f :: k '~>' k' '~>' k'') -> 'SingFunction2' f +@ +-} 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,133 +0,0 @@ -{-# LANGUAGE DataKinds, TypeFamilies, KindSignatures, TemplateHaskell, CPP #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.CustomStar --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) --- Stability : experimental --- Portability : non-portable --- --- This file implements 'singletonStar', which generates a datatype @Rep@ and associated --- singleton from a list of types. The promoted version of @Rep@ is kind @*@ and the --- Haskell types themselves. This is still very experimental, so expect unusual --- results! --- ----------------------------------------------------------------------------- - -module Data.Singletons.CustomStar ( - singletonStar, - - module Data.Singletons.Prelude.Eq, - module Data.Singletons.Prelude.Bool - ) where - -import Language.Haskell.TH -import Data.Singletons.Util -import Data.Singletons.Deriving.Ord -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 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, Show, Read) --- --- and its singleton. However, because @Rep@ is promoted to @*@, the singleton --- is perhaps slightly unexpected: --- --- > data instance Sing (a :: *) where --- > SNat :: Sing Nat --- > SBool :: Sing Bool --- > SMaybe :: SingRep a => Sing a -> Sing (Maybe a) --- --- The unexpected part is that @Nat@, @Bool@, and @Maybe@ above are the real @Nat@, --- @Bool@, and @Maybe@, not just promoted data constructors. --- --- Please note that this function is /very/ experimental. Use at your own risk. -singletonStar :: DsMonad q - => [Name] -- ^ A list of Template Haskell @Name@s for types - -> q [Dec] -singletonStar names = do - kinds <- mapM getKind names - ctors <- zipWithM (mkCtor True) names kinds - let repDecl = DDataD Data [] repName [] ctors - [DDerivClause Nothing [DConPr ''Eq, DConPr ''Show, DConPr ''Read]] - fakeCtors <- zipWithM (mkCtor False) names kinds - let dataDecl = DataDecl Data repName [] fakeCtors - [DConPr ''Show, DConPr ''Read , DConPr ''Eq] - ordInst <- mkOrdInstance (DConT repName) fakeCtors - (pOrdInst, promDecls) <- promoteM [] $ do promoteDataDec dataDecl - promoteInstanceDec mempty ordInst - singletonDecls <- singDecsM [] $ do decs1 <- singDataD dataDecl - dec2 <- singInstD pOrdInst - return (dec2 : decs1) - 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 <- reifyWithWarning name - dinfo <- dsInfo info - case dinfo of - DTyConI (DDataD _ (_:_) _ _ _ _) _ -> - fail "Cannot make a representation of a constrainted data type" - DTyConI (DDataD _ [] _ tvbs _ _) _ -> - return $ map (fromMaybe DStarT . extractTvbKind) tvbs - DTyConI (DTySynD _ tvbs _) _ -> - return $ map (fromMaybe DStarT . extractTvbKind) tvbs - DPrimTyConI _ n _ -> - return $ replicate n DStarT - _ -> 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 (map (\ty -> (noBang, ty)) types)) - Nothing - where - noBang = Bang NoSourceUnpackedness NoSourceStrictness - - -- demote a kind back to a type, accumulating any unbound parameters - kindToType :: DsMonad q => [DType] -> DKind -> QWithAux [Name] q DType - kindToType _ (DForallT _ _ _) = fail "Explicit forall encountered in kind" - kindToType args (DAppT f a) = do - a' <- kindToType [] a - kindToType (a' : args) f - kindToType args (DSigT t k) = do - t' <- kindToType [] t - k' <- kindToType [] k - return $ DSigT t' k' `foldType` args - kindToType args (DVarT n) = do - addElement n - return $ DVarT n `foldType` args - kindToType args (DConT n) = return $ DConT n `foldType` args - kindToType args DArrowT = return $ DArrowT `foldType` args - kindToType args k@(DLitT {}) = return $ k `foldType` args - kindToType args DWildCardT = return $ DWildCardT `foldType` args - kindToType args DStarT = return $ DConT repName `foldType` 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,13 +1,22 @@ -{-# LANGUAGE RankNTypes, PolyKinds, DataKinds, TypeOperators, TypeInType, - TypeFamilies, FlexibleContexts, UndecidableInstances, GADTs #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP, RankNTypes, PolyKinds, DataKinds, TypeOperators, + TypeFamilies, FlexibleContexts, UndecidableInstances, + GADTs, TypeApplications #-} +{-# OPTIONS_GHC -Wno-orphans #-} +#if __GLASGOW_HASKELL__ < 806 +{-# LANGUAGE TypeInType #-} +#endif + +#if __GLASGOW_HASKELL__ >= 810 +{-# LANGUAGE StandaloneKindSignatures #-} +#endif + ----------------------------------------------------------------------------- -- | -- Module : Data.Singletons.Decide -- Copyright : (C) 2013 Richard Eisenberg -- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) +-- Maintainer : Ryan Scott -- Stability : experimental -- Portability : non-portable -- @@ -20,11 +29,13 @@ SDecide(..), -- * Supporting definitions - (:~:)(..), Void, Refuted, Decision(..) + (:~:)(..), Void, Refuted, Decision(..), + decideEquality, decideCoercion ) where import Data.Kind import Data.Singletons +import Data.Type.Coercion import Data.Type.Equality import Data.Void @@ -35,22 +46,50 @@ -- | Because we can never create a value of type 'Void', a function that type-checks -- at @a -> Void@ shows that objects of type @a@ can never exist. Thus, we say that -- @a@ is 'Refuted' +#if __GLASGOW_HASKELL__ >= 810 +type Refuted :: Type -> Type +#endif type Refuted a = (a -> Void) -- | A 'Decision' about a type @a@ is either a proof of existence or a proof that @a@ -- cannot exist. +#if __GLASGOW_HASKELL__ >= 810 +type Decision :: Type -> Type +#endif data Decision a = Proved a -- ^ Witness for @a@ | Disproved (Refuted a) -- ^ Proof that no @a@ exists -- | Members of the 'SDecide' "kind" class support decidable equality. Instances -- of this class are generated alongside singleton definitions for datatypes that -- derive an 'Eq' instance. +#if __GLASGOW_HASKELL__ >= 810 +type SDecide :: Type -> Constraint +#endif class SDecide k where -- | Compute a proof or disproof of equality, given two singletons. (%~) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Decision (a :~: b) + infix 4 %~ -instance SDecide k => TestEquality (Sing :: k -> Type) where - testEquality a b = - case a %~ b of - Proved Refl -> Just Refl - Disproved _ -> Nothing +-- | A suitable default implementation for 'testEquality' that leverages +-- 'SDecide'. +decideEquality :: forall k (a :: k) (b :: k). SDecide k + => Sing a -> Sing b -> Maybe (a :~: b) +decideEquality a b = + case a %~ b of + Proved Refl -> Just Refl + Disproved _ -> Nothing + +instance SDecide k => TestEquality (WrappedSing :: k -> Type) where + testEquality (WrapSing s1) (WrapSing s2) = decideEquality s1 s2 + +-- | A suitable default implementation for 'testCoercion' that leverages +-- 'SDecide'. +decideCoercion :: forall k (a :: k) (b :: k). SDecide k + => Sing a -> Sing b -> Maybe (Coercion a b) +decideCoercion a b = + case a %~ b of + Proved Refl -> Just Coercion + Disproved _ -> Nothing + +instance SDecide k => TestCoercion (WrappedSing :: k -> Type) where + testCoercion (WrapSing s1) (WrapSing s2) = decideCoercion s1 s2 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,57 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Deriving.Bounded --- Copyright : (C) 2015 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu --- Stability : experimental --- Portability : non-portable --- --- Implements deriving of Bounded instances --- ----------------------------------------------------------------------------- - -module Data.Singletons.Deriving.Bounded where - -import Language.Haskell.TH.Syntax -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 Control.Monad - --- monadic only for failure and parallelism with other functions --- that make instances -mkBoundedInstance :: Quasi q => DType -> [DCon] -> q UInstDecl -mkBoundedInstance ty 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] - return $ InstDecl { id_cxt = inferConstraints (DConPr boundedName) cons - , id_name = boundedName - , id_arg_tys = [ty] - , 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,53 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Deriving.Enum --- Copyright : (C) 2015 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) --- 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.Syntax -import Data.Singletons.Util -import Data.Singletons.Names -import Control.Monad -import Data.Maybe - --- monadic for failure only -mkEnumInstance :: Quasi q => DType -> [DCon] -> q UInstDecl -mkEnumInstance ty cons = do - when (null cons || - any (\(DCon tvbs cxt _ f rty) -> or [ not $ null $ tysOfConFields f - , not $ null tvbs - , not $ null cxt - , isJust rty ]) cons) $ - fail ("Can't derive Enum instance for " ++ pprint (typeToTH ty) ++ ".") - n <- qNewName "n" - let to_enum = UFunction [DClause [DVarPa 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 (DConPa trueName []) (DConE name) - , DMatch (DConPa 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 [DConPa (extractName con) []] - (DLitE (IntegerL i))) - [0..] cons) - return (InstDecl { id_cxt = [] - , 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_meths = [ (singletonsToEnumName, to_enum) - , (singletonsFromEnumName, from_enum) ] }) 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,24 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Deriving.Infer --- Copyright : (C) 2015 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu --- Stability : experimental --- Portability : non-portable --- --- Infers constraints for a `deriving` class --- ----------------------------------------------------------------------------- - -module Data.Singletons.Deriving.Infer ( inferConstraints ) where - -import Language.Haskell.TH.Desugar -import Data.Singletons.Util -import Data.List -import Data.Generics.Twins - -inferConstraints :: DPred -> [DCon] -> DCxt -inferConstraints pr = nubBy geq . concatMap infer_ct - where - infer_ct (DCon _ _ _ fields _) = map (pr `DAppPr`) (tysOfConFields fields) 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,65 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Deriving.Ord --- Copyright : (C) 2015 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu --- 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.Syntax - --- | Make a *non-singleton* Ord instance -mkOrdInstance :: Quasi q => DType -> [DCon] -> q UInstDecl -mkOrdInstance ty cons = do - let constraints = inferConstraints (DConPr ordName) 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) ] - return (InstDecl { id_cxt = constraints - , id_name = ordName - , id_arg_tys = [ty] - , id_meths = [( compareName - , UFunction (compare_eq_clauses ++ - compare_noneq_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 = DConPa name (map DVarPa a_names) - pat2 = DConPa name (map DVarPa 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 = DConPa name1 (map (const DWildPa) (tysOfConFields fields1)) - pat2 = DConPa name2 (map (const DWildPa) (tysOfConFields fields2)) 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,239 +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 -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 ( Any, Constraint ) -import Data.Typeable ( TypeRep ) -import Data.Singletons.Util -import Control.Monad - -anyTypeName, boolName, andName, tyEqName, compareName, minBoundName, - maxBoundName, repName, - nilName, consName, listName, tyFunName, - applyName, natName, symbolName, undefinedName, typeRepName, stringName, - eqName, ordName, boundedName, orderingName, - singFamilyName, singIName, singMethName, demoteName, - singKindClassName, sEqClassName, sEqMethName, sconsName, snilName, - sIfName, - someSingTypeName, someSingDataName, - sListName, sDecideClassName, sDecideMethName, - 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 :: Name -anyTypeName = ''Any -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 = ''[] -tyFunName = ''TyFun -applyName = ''Apply -symbolName = ''Symbol -natName = ''Nat -undefinedName = 'undefined -typeRepName = ''TypeRep -stringName = ''String -eqName = ''Eq -ordName = ''Ord -boundedName = ''Bounded -orderingName = ''Ordering -singFamilyName = ''Sing -singIName = ''SingI -singMethName = 'sing -toSingName = 'toSing -fromSingName = 'fromSing -demoteName = ''Demote -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" -someSingTypeName = ''SomeSing -someSingDataName = 'SomeSing -sListName = mk_name_tc "Data.Singletons.Prelude.Instances" "SList" -sDecideClassName = ''SDecide -sDecideMethName = '(%~) -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 - -singPkg :: String -singPkg = $( (LitE . StringL . loc_package) `liftM` location ) - -mk_name_tc :: String -> String -> Name -mk_name_tc = mkNameG_tc singPkg - -mk_name_d :: String -> String -> Name -mk_name_d = mkNameG_d singPkg - -mk_name_v :: String -> String -> Name -mk_name_v = mkNameG_v singPkg - -mkTupleTypeName :: Int -> Name -mkTupleTypeName n = mk_name_tc "Data.Singletons.Prelude.Instances" $ - "STuple" ++ (show n) - -mkTupleDataName :: Int -> Name -mkTupleDataName n = mk_name_d "Data.Singletons.Prelude.Instances" $ - "STuple" ++ (show n) - --- used when a value name appears in a pattern context --- works only for proper variables (lower-case names) -promoteValNameLhs :: Name -> Name -promoteValNameLhs = upcase - --- like promoteValNameLhs, but adds a prefix to the promoted name -promoteValNameLhsPrefix :: (String, String) -> Name -> Name -promoteValNameLhsPrefix pres n = mkName $ toUpcaseStr pres n - --- used when a value name appears in an expression context --- works for both variables and datacons -promoteValRhs :: Name -> DType -promoteValRhs name - | name == nilName - = DConT nilName -- workaround for #21 - - | otherwise - = DConT $ promoteTySym name 0 - --- generates type-level symbol for a given name. Int parameter represents --- saturation: 0 - no parameters passed to the symbol, 1 - one parameter --- passed to the symbol, and so on. Works on both promoted and unpromoted --- names. -promoteTySym :: Name -> Int -> Name -promoteTySym name sat - | name == undefinedName - = anyTypeName - - | name == nilName - = mkName $ "NilSym" ++ (show sat) - - -- treat unboxed tuples like tuples - | Just degree <- tupleNameDegree_maybe name `mplus` - unboxedTupleNameDegree_maybe name - = mk_name_tc "Data.Singletons.Prelude.Instances" $ - "Tuple" ++ show degree ++ "Sym" ++ (show sat) - - | otherwise - = let capped = toUpcaseStr noPrefix name in - if isHsLetter (head capped) - then mkName (capped ++ "Sym" ++ (show sat)) - else mkName (capped ++ (replicate (sat + 1) '$')) - -promoteClassName :: Name -> Name -promoteClassName = prefixUCName "P" "#" - -mkTyName :: Quasi q => Name -> q Name -mkTyName tmName = do - let nameStr = nameBase tmName - symbolic = not (isHsLetter (head nameStr)) - qNewName (if symbolic then "ty" else nameStr) - -falseTySym :: DType -falseTySym = promoteValRhs falseName - -trueTySym :: DType -trueTySym = promoteValRhs trueName - -boolKi :: DKind -boolKi = DConT boolName - -andTySym :: DType -andTySym = promoteValRhs andName - --- Singletons - -singDataConName :: Name -> Name -singDataConName nm - | nm == nilName = snilName - | nm == consName = sconsName - | Just degree <- tupleNameDegree_maybe nm = mkTupleDataName degree - | Just degree <- unboxedTupleNameDegree_maybe nm = mkTupleDataName degree - | otherwise = prefixUCName "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 = prefixUCName "S" ":%" name - -singClassName :: Name -> Name -singClassName = singTyConName - -singValName :: Name -> Name -singValName n - | n == undefinedName = undefinedName - -- avoid unused variable warnings - | head (nameBase n) == '_' = (prefixLCName "_s" "%") $ n - | otherwise = (prefixLCName "s" "%") $ upcase n - -singFamily :: DType -singFamily = DConT singFamilyName - -singKindConstraint :: DKind -> DPred -singKindConstraint = DAppPr (DConPr 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 and equality predicate -mkEqPred :: DType -> DType -> DPred -mkEqPred ty1 ty2 = foldl DAppPr (DConPr equalityName) [ty1, ty2] 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,127 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Partition --- Copyright : (C) 2015 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu --- Stability : experimental --- Portability : non-portable --- --- Partitions a list of declarations into its bits --- ----------------------------------------------------------------------------- - -{-# 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.Names -import Language.Haskell.TH.Syntax -import Language.Haskell.TH.Ppr -import Language.Haskell.TH.Desugar -import Data.Singletons.Util - -import Data.Monoid -import Control.Monad -import Data.Maybe - -data PartitionedDecs = - PDecs { pd_let_decs :: [DLetDec] - , pd_class_decs :: [UClassDecl] - , pd_instance_decs :: [UInstDecl] - , pd_data_decs :: [DataDecl] - } - -instance Monoid PartitionedDecs where - mempty = PDecs [] [] [] [] - mappend (PDecs a1 b1 c1 d1) (PDecs a2 b2 c2 d2) = - PDecs (a1 <> a2) (b1 <> b2) (c1 <> c2) (d1 <> d2) - --- | Split up a @[DDec]@ into its pieces, extracting 'Ord' instances --- from deriving clauses -partitionDecs :: Quasi m => [DDec] -> m PartitionedDecs -partitionDecs = concatMapM partitionDec - -partitionDec :: Quasi m => DDec -> m PartitionedDecs -partitionDec (DLetDec (DPragmaD {})) = return mempty -partitionDec (DLetDec letdec) = return $ mempty { pd_let_decs = [letdec] } - -partitionDec (DDataD nd _cxt name tvbs cons derivings) = do - (derivings', derived_instances) <- partitionWithM part_derivings - $ concatMap flatten_clause derivings - return $ mempty { pd_data_decs = [DataDecl nd name tvbs cons derivings'] - , pd_instance_decs = derived_instances } - where - ty = foldType (DConT name) (map tvbToType tvbs) - - flatten_clause :: DDerivClause -> [(Maybe DerivStrategy, DPred)] - flatten_clause (DDerivClause strat preds) = map (strat,) preds - - part_derivings :: Quasi m => (Maybe DerivStrategy, DPred) - -> m (Either DPred UInstDecl) - part_derivings (strat, deriv) = case deriv of - DConPr deriv_name - | stock, deriv_name == ordName - -> Right <$> mkOrdInstance ty cons - | stock, deriv_name == boundedName - -> Right <$> mkBoundedInstance ty cons - | stock, deriv_name == enumName - -> Right <$> mkEnumInstance ty cons - where - stock = case strat of - Nothing -> True - Just StockStrategy -> True - Just _ -> False - _ -> return (Left deriv) - -partitionDec (DClassD cxt name tvbs fds decs) = do - env <- concatMapM partitionClassDec decs - return $ mempty { pd_class_decs = [ClassDecl { cd_cxt = cxt - , cd_name = name - , cd_tvbs = tvbs - , cd_fds = fds - , cd_lde = env }] } -partitionDec (DInstanceD _ cxt ty decs) = do - defns <- liftM catMaybes $ mapM partitionInstanceDec decs - (name, tys) <- split_app_tys [] ty - return $ mempty { pd_instance_decs = [InstDecl { id_cxt = cxt - , id_name = name - , id_arg_tys = tys - , 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 {}) = return mempty -- ignore type synonyms; - -- promotion is a no-op, and - -- singling expands all syns -partitionDec dec = - fail $ "Declaration cannot be promoted: " ++ pprint (decToTH dec) - -partitionClassDec :: Monad m => DDec -> m ULetDecEnv -partitionClassDec (DLetDec (DSigD name ty)) = return $ typeBinding name ty -partitionClassDec (DLetDec (DValD (DVarPa name) exp)) = - return $ valueBinding name (UValue exp) -partitionClassDec (DLetDec (DFunD name clauses)) = - return $ valueBinding name (UFunction clauses) -partitionClassDec (DLetDec (DInfixD fixity name)) = - return $ infixDecl fixity name -partitionClassDec (DLetDec (DPragmaD {})) = return mempty -partitionClassDec _ = - fail "Only method declarations can be promoted within a class." - -partitionInstanceDec :: Monad m => DDec -> m (Maybe (Name, ULetDecRHS)) -partitionInstanceDec (DLetDec (DValD (DVarPa name) exp)) = - return $ Just (name, UValue exp) -partitionInstanceDec (DLetDec (DFunD name clauses)) = - return $ Just (name, UFunction clauses) -partitionInstanceDec (DLetDec (DPragmaD {})) = return Nothing -partitionInstanceDec _ = - fail "Only method bodies can be promoted within an instance." 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,163 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) --- Stability : experimental --- Portability : non-portable --- --- Mimics the Haskell Prelude, but with singleton types. Includes the basic --- singleton definitions. Note: This is currently very incomplete! --- --- Because many of these definitions are produced by Template Haskell, it is --- not possible to create proper Haddock documentation. Also, please excuse --- the apparent repeated variable names. This is due to an interaction between --- Template Haskell and Haddock. --- ----------------------------------------------------------------------------- - -{-# LANGUAGE ExplicitNamespaces #-} -module Data.Singletons.Prelude ( - -- * Basic singleton definitions - module Data.Singletons, - - Sing(SFalse, STrue, SNil, SCons, SJust, SNothing, SLeft, SRight, SLT, SEQ, SGT, - STuple0, STuple2, STuple3, STuple4, STuple5, STuple6, STuple7), - - -- * Singleton type synonyms - - -- | These synonyms are all kind-restricted synonyms of 'Sing'. - -- For example 'SBool' requires an argument of kind 'Bool'. - SBool, SList, SMaybe, SEither, SOrdering, - STuple0, STuple2, STuple3, STuple4, STuple5, STuple6, STuple7, - - -- * Functions working with 'Bool' - If, sIf, Not, sNot, (:&&), (:||), (%:&&), (%:||), Otherwise, sOtherwise, - - -- * Error reporting - Error, ErrorSym0, sError, - - -- * Singleton equality - module Data.Singletons.Prelude.Eq, - - -- * Singleton comparisons - module Data.Singletons.Prelude.Ord, - - -- * 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, - - -- ** Miscellaneous functions - Id, sId, Const, sConst, (:.), (%:.), type ($), (%$), type ($!), (%$!), - Flip, sFlip, AsTypeOf, sAsTypeOf, - Seq, sSeq, - - -- * List operations - Map, sMap, (:++), (%:++), Head, sHead, Last, sLast, Tail, sTail, - Init, sInit, Null, sNull, Reverse, sReverse, - -- ** Reducing lists (folds) - Foldl, sFoldl, Foldl1, sFoldl1, Foldr, sFoldr, Foldr1, sFoldr1, - -- *** Special folds - And, sAnd, Or, sOr, Any_, sAny_, All, sAll, - Concat, sConcat, ConcatMap, sConcatMap, - -- *** Scans - Scanl, sScanl, Scanl1, sScanl1, Scanr, sScanr, Scanr1, sScanr1, - -- ** Searching lists - Elem, sElem, NotElem, sNotElem, Lookup, sLookup, - -- ** Zipping and unzipping lists - Zip, sZip, Zip3, sZip3, ZipWith, sZipWith, ZipWith3, sZipWith3, - Unzip, sUnzip, Unzip3, sUnzip3, - - -- * Other datatypes - Maybe_, sMaybe_, - Either_, sEither_, - Fst, sFst, Snd, sSnd, Curry, sCurry, Uncurry, sUncurry, - Symbol, - - -- * Other functions - either_, -- reimplementation of either to be used with singletons library - maybe_, - bool_, - any_, - - -- * Defunctionalization symbols - FalseSym0, TrueSym0, - NotSym0, NotSym1, (:&&$), (:&&$$), (:&&$$$), (:||$), (:||$$), (:||$$$), - OtherwiseSym0, - - NothingSym0, JustSym0, JustSym1, - Maybe_Sym0, Maybe_Sym1, Maybe_Sym2, Maybe_Sym3, - - LeftSym0, LeftSym1, RightSym0, RightSym1, - Either_Sym0, Either_Sym1, Either_Sym2, Either_Sym3, - - Tuple0Sym0, - Tuple2Sym0, Tuple2Sym1, Tuple2Sym2, - Tuple3Sym0, Tuple3Sym1, Tuple3Sym2, Tuple3Sym3, - Tuple4Sym0, Tuple4Sym1, Tuple4Sym2, Tuple4Sym3, Tuple4Sym4, - Tuple5Sym0, Tuple5Sym1, Tuple5Sym2, Tuple5Sym3, Tuple5Sym4, Tuple5Sym5, - Tuple6Sym0, Tuple6Sym1, Tuple6Sym2, Tuple6Sym3, Tuple6Sym4, Tuple6Sym5, Tuple6Sym6, - Tuple7Sym0, Tuple7Sym1, Tuple7Sym2, Tuple7Sym3, Tuple7Sym4, Tuple7Sym5, Tuple7Sym6, Tuple7Sym7, - FstSym0, FstSym1, SndSym0, SndSym1, - CurrySym0, CurrySym1, CurrySym2, CurrySym3, - UncurrySym0, UncurrySym1, UncurrySym2, - - IdSym0, IdSym1, ConstSym0, ConstSym1, ConstSym2, - (:.$), (:.$$), (:.$$$), - type ($$), type ($$$), type ($$$$), - type ($!$), type ($!$$), type ($!$$$), - FlipSym0, FlipSym1, FlipSym2, - AsTypeOfSym0, AsTypeOfSym1, AsTypeOfSym2, SeqSym0, SeqSym1, SeqSym2, - - (:$), (:$$), (:$$$), NilSym0, - MapSym0, MapSym1, MapSym2, ReverseSym0, ReverseSym1, - (:++$$), (:++$), HeadSym0, HeadSym1, LastSym0, LastSym1, - TailSym0, TailSym1, InitSym0, InitSym1, NullSym0, NullSym1, - - FoldlSym0, FoldlSym1, FoldlSym2, FoldlSym3, - Foldl1Sym0, Foldl1Sym1, Foldl1Sym2, - FoldrSym0, FoldrSym1, FoldrSym2, FoldrSym3, - Foldr1Sym0, Foldr1Sym1, Foldr1Sym2, - - ConcatSym0, ConcatSym1, - ConcatMapSym0, ConcatMapSym1, ConcatMapSym2, - AndSym0, AndSym1, OrSym0, OrSym1, - Any_Sym0, Any_Sym1, Any_Sym2, - AllSym0, AllSym1, AllSym2, - - ScanlSym0, ScanlSym1, ScanlSym2, ScanlSym3, - Scanl1Sym0, Scanl1Sym1, Scanl1Sym2, - ScanrSym0, ScanrSym1, ScanrSym2, ScanrSym3, - Scanr1Sym0, Scanr1Sym1, Scanr1Sym2, - - ElemSym0, ElemSym1, ElemSym2, - NotElemSym0, NotElemSym1, NotElemSym2, - - ZipSym0, ZipSym1, ZipSym2, - Zip3Sym0, Zip3Sym1, Zip3Sym2, Zip3Sym3, - ZipWithSym0, ZipWithSym1, ZipWithSym2, ZipWithSym3, - ZipWith3Sym0, ZipWith3Sym1, ZipWith3Sym2, ZipWith3Sym3, - UnzipSym0, UnzipSym1 - ) where - -import Data.Singletons -import Data.Singletons.Prelude.Base -import Data.Singletons.Prelude.Bool -import Data.Singletons.Prelude.Either -import Data.Singletons.Prelude.List -import Data.Singletons.Prelude.Maybe -import Data.Singletons.Prelude.Tuple -import Data.Singletons.Prelude.Eq -import Data.Singletons.Prelude.Ord -import Data.Singletons.Prelude.Instances -import Data.Singletons.Prelude.Enum - hiding (Succ, Pred, SuccSym0, SuccSym1, PredSym0, PredSym1, sSucc, sPred) -import Data.Singletons.Prelude.Num -import Data.Singletons.TypeLits 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,128 +0,0 @@ -{-# LANGUAGE TemplateHaskell, KindSignatures, PolyKinds, TypeOperators, - DataKinds, ScopedTypeVariables, TypeFamilies, GADTs, - UndecidableInstances, BangPatterns #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Base --- Copyright : (C) 2014 Jan Stolarek --- License : BSD-style (see LICENSE) --- Maintainer : Jan Stolarek (jan.stolarek@p.lodz.pl) --- Stability : experimental --- Portability : non-portable --- --- Implements singletonized versions of functions from @GHC.Base@ module. --- --- Because many of these definitions are produced by Template Haskell, --- it is not possible to create proper Haddock documentation. Please look --- up the corresponding operation in @Data.Tuple@. Also, please excuse --- the apparent repeated variable names. This is due to an interaction --- between Template Haskell and Haddock. --- ----------------------------------------------------------------------------- - -module Data.Singletons.Prelude.Base ( - -- * Basic functions - Foldr, sFoldr, Map, sMap, (:++), (%:++), Otherwise, sOtherwise, - Id, sId, Const, sConst, (:.), (%:.), type ($), type ($!), (%$), (%$!), - Flip, sFlip, AsTypeOf, sAsTypeOf, - Seq, sSeq, - - -- * Defunctionalization symbols - FoldrSym0, FoldrSym1, FoldrSym2, FoldrSym3, - MapSym0, MapSym1, MapSym2, - (:++$), (:++$$), (:++$$$), - OtherwiseSym0, - IdSym0, IdSym1, - ConstSym0, ConstSym1, ConstSym2, - (:.$), (:.$$), (:.$$$), (:.$$$$), - type ($$), type ($$$), type ($$$$), - type ($!$), type ($!$$), type ($!$$$), - FlipSym0, FlipSym1, FlipSym2, FlipSym3, - AsTypeOfSym0, AsTypeOfSym1, AsTypeOfSym2, - SeqSym0, SeqSym1, SeqSym2 - ) where - -import Data.Singletons.Prelude.Instances -import Data.Singletons.Single -import Data.Singletons -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 - - -- 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` - |]) - --- ($) is a special case, because its kind-inference data constructors --- clash with (:). See #29. -type family (f :: TyFun a b -> *) $ (x :: a) :: b -type instance f $ x = f @@ x -infixr 0 $ - -data ($$) :: TyFun (TyFun a b -> *) (TyFun a b -> *) -> * -type instance Apply ($$) arg = ($$$) arg - -data ($$$) :: (TyFun a b -> *) -> TyFun a b -> * -type instance Apply (($$$) f) arg = ($$$$) f arg - -type ($$$$) a b = ($) a b - -(%$) :: forall (f :: TyFun a b -> *) (x :: a). - Sing f -> Sing x -> Sing (($$) @@ f @@ x) -f %$ x = applySing f x -infixr 0 %$ - -type family (f :: TyFun a b -> *) $! (x :: a) :: b -type instance f $! x = f @@ x -infixr 0 $! - -data ($!$) :: TyFun (TyFun a b -> *) (TyFun a b -> *) -> * -type instance Apply ($!$) arg = ($!$$) arg - -data ($!$$) :: (TyFun a b -> *) -> TyFun a b -> * -type instance Apply (($!$$) f) arg = ($!$$$) f arg - -type ($!$$$) a b = ($!) a b - -(%$!) :: forall (f :: TyFun a b -> *) (x :: a). - Sing f -> Sing x -> Sing (($!$) @@ f @@ x) -f %$! x = applySing f x -infixr 0 %$! diff --git a/src/Data/Singletons/Prelude/Bool.hs b/src/Data/Singletons/Prelude/Bool.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/Bool.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE TemplateHaskell, DataKinds, PolyKinds, TypeFamilies, TypeOperators, - GADTs, ScopedTypeVariables, DeriveDataTypeable, UndecidableInstances #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Bool --- Copyright : (C) 2013-2014 Richard Eisenberg, Jan Stolarek --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines functions and datatypes relating to the singleton for 'Bool', --- including a singletons version of all the definitions in @Data.Bool@. --- --- Because many of these definitions are produced by Template Haskell, --- it is not possible to create proper Haddock documentation. Please look --- up the corresponding operation in @Data.Bool@. Also, please excuse --- the apparent repeated variable names. This is due to an interaction --- between Template Haskell and Haddock. --- ----------------------------------------------------------------------------- - -module Data.Singletons.Prelude.Bool ( - -- * The 'Bool' singleton - - Sing(SFalse, STrue), - -- | Though Haddock doesn't show it, the 'Sing' instance above declares - -- constructors - -- - -- > SFalse :: Sing False - -- > STrue :: Sing True - - SBool, - -- | 'SBool' is a kind-restricted synonym for 'Sing': @type SBool (a :: Bool) = Sing a@ - - -- * Conditionals - If, sIf, - - -- * Singletons from @Data.Bool@ - Not, sNot, (:&&), (:||), (%:&&), (%:||), - - -- | The following are derived from the function 'bool' in @Data.Bool@. The extra - -- underscore is to avoid name clashes with the type 'Bool'. - bool_, Bool_, sBool_, Otherwise, sOtherwise, - - -- * Defunctionalization symbols - TrueSym0, FalseSym0, - - NotSym0, NotSym1, - (:&&$), (:&&$$), (:&&$$$), - (:||$), (:||$$), (:||$$$), - Bool_Sym0, Bool_Sym1, Bool_Sym2, Bool_Sym3, - OtherwiseSym0 - ) where - -import Data.Singletons -import Data.Singletons.Prelude.Instances -import Data.Singletons.Single -import Data.Type.Bool ( If ) - -$(singletons [d| - bool_ :: a -> a -> Bool -> a - bool_ fls _tru False = fls - bool_ _fls tru True = tru - |]) - -$(singletonsOnly [d| - (&&) :: Bool -> Bool -> Bool - False && _ = False - True && x = x - infixr 3 && - - (||) :: Bool -> Bool -> Bool - False || x = x - True || _ = True - infixr 2 || - - not :: Bool -> Bool - not False = True - not True = False - - otherwise :: Bool - otherwise = True - |]) - --- | Conditional over singletons -sIf :: Sing a -> Sing b -> Sing c -> Sing (If a b c) -sIf STrue b _ = b -sIf SFalse _ c = c diff --git a/src/Data/Singletons/Prelude/Either.hs b/src/Data/Singletons/Prelude/Either.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/Either.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TypeFamilies, GADTs, - DataKinds, PolyKinds, RankNTypes, UndecidableInstances #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Either --- Copyright : (C) 2013-2014 Richard Eisenberg, Jan Stolarek --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines functions and datatypes relating to the singleton for 'Either', --- including a singletons version of all the definitions in @Data.Either@. --- --- Because many of these definitions are produced by Template Haskell, --- it is not possible to create proper Haddock documentation. Please look --- up the corresponding operation in @Data.Either@. Also, please excuse --- the apparent repeated variable names. This is due to an interaction --- between Template Haskell and Haddock. --- ----------------------------------------------------------------------------- - -module Data.Singletons.Prelude.Either ( - -- * The 'Either' singleton - Sing(SLeft, SRight), - -- | Though Haddock doesn't show it, the 'Sing' instance above declares - -- constructors - -- - -- > SLeft :: Sing a -> Sing (Left a) - -- > SRight :: Sing b -> Sing (Right b) - - SEither, - -- | 'SEither' is a kind-restricted synonym for 'Sing': - -- @type SEither (a :: Either x y) = Sing a@ - - -- * Singletons from @Data.Either@ - either_, Either_, sEither_, - -- | The preceding two definitions are derived from the function 'either' in - -- @Data.Either@. The extra underscore is to avoid name clashes with the type - -- 'Either'. - - Lefts, sLefts, Rights, sRights, - PartitionEithers, sPartitionEithers, IsLeft, sIsLeft, IsRight, sIsRight, - - -- * Defunctionalization symbols - LeftSym0, LeftSym1, RightSym0, RightSym1, - - Either_Sym0, Either_Sym1, Either_Sym2, Either_Sym3, - LeftsSym0, LeftsSym1, RightsSym0, RightsSym1, - IsLeftSym0, IsLeftSym1, IsRightSym0, IsRightSym1 - ) where - -import Data.Singletons.Prelude.Instances -import Data.Singletons.TH -import Data.Singletons.Prelude.Base - --- 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, TypeInType, - InstanceSigs #-} - ------------------------------------------------------------------------------ --- | --- 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,62 +0,0 @@ -{-# LANGUAGE TypeOperators, DataKinds, PolyKinds, TypeFamilies, TypeInType, - RankNTypes, FlexibleContexts, TemplateHaskell, - UndecidableInstances, GADTs, DefaultSignatures #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Eq --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines the SEq singleton version of the Eq type class. --- ------------------------------------------------------------------------------ - -module Data.Singletons.Prelude.Eq ( - PEq(..), SEq(..), - (:==$), (:==$$), (:==$$$), (:/=$), (:/=$$), (:/=$$$) - ) where - -import Data.Singletons.Prelude.Bool -import Data.Singletons.Single -import Data.Singletons.Prelude.Instances -import Data.Singletons.Util -import Data.Singletons.Promote -import Data.Type.Equality - --- NB: These must be defined by hand because of the custom handling of the --- default for (:==) to use Data.Type.Equality.== - --- | The promoted analogue of 'Eq'. If you supply no definition for '(:==)', --- then it defaults to a use of '(==)', from @Data.Type.Equality@. -class PEq a where - type (:==) (x :: a) (y :: a) :: Bool - type (:/=) (x :: a) (y :: a) :: Bool - - type (x :: a) :== (y :: a) = x == y - type (x :: a) :/= (y :: a) = Not (x :== y) - -infix 4 :== -infix 4 :/= - -$(genDefunSymbols [''(:==), ''(:/=)]) - --- | The singleton analogue of 'Eq'. Unlike the definition for 'Eq', it is required --- that instances define a body for '(%:==)'. You may also supply a body for '(%:/=)'. -class 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) 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,115 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Function --- Copyright : (C) 2016 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) --- 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, TypeInType, TypeFamilies, - TypeOperators, UndecidableInstances, GADTs #-} - -module Data.Singletons.Prelude.Function ( - -- * "Prelude" re-exports - Id, sId, Const, sConst, (:.), (%:.), Flip, sFlip, type ($), (%$) - -- * Other combinators - , (:&), (%:&), On, sOn - - -- * Defunctionalization symbols - , IdSym0, IdSym1 - , ConstSym0, ConstSym1, ConstSym2 - , (:.$), (:.$$), (:.$$$), (:.$$$$) - , FlipSym0, FlipSym1, FlipSym2, FlipSym3 - , 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 - - - -- -| '&' 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 - - |]) 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,34 +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 RankNTypes, TypeInType, GADTs, TypeFamilies, - FlexibleContexts, TemplateHaskell, ScopedTypeVariables, - UndecidableInstances, TypeOperators, FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Data.Singletons.Prelude.Instances where - -import Data.Singletons.Single -import Data.Singletons.Util - --- some useful singletons -$(genSingletons basicTypes) -$(singDecideInstances basicTypes) - --- 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/List.hs b/src/Data/Singletons/Prelude/List.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/List.hs +++ /dev/null @@ -1,806 +0,0 @@ -{-# LANGUAGE TypeOperators, DataKinds, PolyKinds, TypeFamilies, TypeInType, - TemplateHaskell, GADTs, UndecidableInstances, RankNTypes, - ScopedTypeVariables, FlexibleContexts, AllowAmbiguousTypes #-} -{-# OPTIONS_GHC -O0 #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.List --- Copyright : (C) 2013-2014 Richard Eisenberg, Jan Stolarek --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines functions and datatypes relating to the singleton for '[]', --- including a singletons version of a few of the definitions in @Data.List@. --- --- Because many of these definitions are produced by Template Haskell, --- it is not possible to create proper Haddock documentation. Please look --- up the corresponding operation in @Data.List@. Also, please excuse --- the apparent repeated variable names. This is due to an interaction --- between Template Haskell and Haddock. --- ----------------------------------------------------------------------------- - -module Data.Singletons.Prelude.List ( - -- * The singleton for lists - Sing(SNil, SCons), - -- | Though Haddock doesn't show it, the 'Sing' instance above declares - -- constructors - -- - -- > SNil :: Sing '[] - -- > SCons :: Sing (h :: k) -> Sing (t :: [k]) -> Sing (h ': t) - - SList, - -- | 'SList' is a kind-restricted synonym for 'Sing': @type SList (a :: [k]) = Sing a@ - - -- * Basic functions - (:++), (%:++), Head, sHead, Last, sLast, Tail, sTail, Init, sInit, - Null, sNull, 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, - any_, -- equivalent of Data.List `any`. Avoids name clash with Any type - - -- * Building lists - - -- ** Scans - Scanl, sScanl, Scanl1, sScanl1, Scanr, sScanr, Scanr1, sScanr1, - - -- ** Accumulating maps - MapAccumL, sMapAccumL, MapAccumR, sMapAccumR, - - -- ** 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, 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 - (:!!), (%:!!), - ElemIndex, sElemIndex, ElemIndices, sElemIndices, - FindIndex, sFindIndex, FindIndices, sFindIndices, - - -- * Zipping and unzipping lists - Zip, sZip, Zip3, sZip3, ZipWith, sZipWith, ZipWith3, sZipWith3, - Unzip, sUnzip, Unzip3, sUnzip3, Unzip4, sUnzip4, - Unzip5, sUnzip5, Unzip6, sUnzip6, Unzip7, sUnzip7, - - -- * Special lists - - -- ** \"Set\" operations - Nub, sNub, Delete, sDelete, (:\\), (%:\\), - 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, - (:$), (:$$), (:$$$), - - (:++$$$), (:++$$), (:++$), 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, - Any_Sym0, Any_Sym1, Any_Sym2, - 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, - 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, - - (:!!$), (:!!$$), (:!!$$$), - ElemIndexSym0, ElemIndexSym1, ElemIndexSym2, - ElemIndicesSym0, ElemIndicesSym1, ElemIndicesSym2, - FindIndexSym0, FindIndexSym1, FindIndexSym2, - FindIndicesSym0, FindIndicesSym1, FindIndicesSym2, - - ZipSym0, ZipSym1, ZipSym2, - Zip3Sym0, Zip3Sym1, Zip3Sym2, Zip3Sym3, - ZipWithSym0, ZipWithSym1, ZipWithSym2, ZipWithSym3, - ZipWith3Sym0, ZipWith3Sym1, ZipWith3Sym2, ZipWith3Sym3, ZipWith3Sym4, - UnzipSym0, UnzipSym1, - Unzip3Sym0, Unzip3Sym1, - Unzip4Sym0, Unzip4Sym1, - Unzip5Sym0, Unzip5Sym1, - Unzip6Sym0, Unzip6Sym1, - Unzip7Sym0, Unzip7Sym1, - - NubSym0, NubSym1, - DeleteSym0, DeleteSym1, DeleteSym2, - (:\\$), (:\\$$), (:\\$$$), - 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 -import Data.Singletons.Prelude.Instances -import Data.Singletons.Single -import Data.Singletons.TypeLits -import Data.Singletons.Prelude.Base -import Data.Singletons.Prelude.Bool -import Data.Singletons.Prelude.Eq -import Data.Singletons.Prelude.Maybe -import Data.Singletons.Prelude.Tuple -import Data.Singletons.Prelude.Num -import Data.Singletons.Prelude.Ord -import Data.Maybe - -$(singletons [d| - any_ :: (a -> Bool) -> [a] -> Bool - any_ _ [] = False - any_ p (x:xs) = p x || any_ p xs - |]) - -$(singletonsOnly [d| - head :: [a] -> a - head (a : _) = a - head [] = error "Data.Singletons.List.head: empty list" - - last :: [a] -> a - last [] = error "Data.Singletons.List.last: empty list" - last [x] = 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 - - -- This type signature isn't present in the reference - -- implementation of permutations in base. However, it is needed - -- here, since (at least in GHC 8.2.1) the singletonized version - -- will fail to typecheck without it. See #13549 for the full story. - interleave' :: ([a] -> b) -> [a] -> [b] -> ([a], [b]) - 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 - - scanl :: (b -> a -> b) -> b -> [a] -> [b] - scanl f q ls = q : (case ls of - [] -> [] - x:xs -> scanl f (f q x) xs) - scanl1 :: (a -> a -> a) -> [a] -> [a] - scanl1 f (x:xs) = scanl f x xs - scanl1 _ [] = [] - - scanr :: (a -> b -> b) -> b -> [a] -> [b] - scanr _ q0 [] = [q0] - scanr f q0 (x:xs) = case scanr f q0 xs of - [] -> error "Data.Singletons.List.scanr: empty list" - (q:qs) -> f x q : (q:qs) - - scanr1 :: (a -> a -> a) -> [a] -> [a] - scanr1 _ [] = [] - scanr1 _ [x] = [x] - scanr1 f (x:xs@(_:_)) = case scanr1 f xs of - [] -> error "Data.Singletons.List.scanr1: empty list" - (q:qs) -> f x q : (q:qs) - - mapAccumL :: (acc -> x -> (acc, y)) - -> acc - -> [x] - -> (acc, [y]) - mapAccumL _ s [] = (s, []) - mapAccumL f s (x:xs) = (s'',y:ys) - where (s', y ) = f s x - (s'',ys) = mapAccumL f s' xs - - mapAccumR :: (acc -> x -> (acc, y)) - -> acc - -> [x] - -> (acc, [y]) - mapAccumR _ s [] = (s, []) - mapAccumR f s (x:xs) = (s'', y:ys) - where (s'',y ) = f s' x - (s', ys) = mapAccumR f s xs - - unfoldr :: (b -> Maybe (a, b)) -> b -> [a] - unfoldr f b = - case f b of - Just (a,new_b) -> a : unfoldr f new_b - Nothing -> [] - - inits :: [a] -> [[a]] - inits xs = [] : case xs of - [] -> [] - x : xs' -> map (x :) (inits xs') - - tails :: [a] -> [[a]] - tails xs = xs : case xs of - [] -> [] - _ : xs' -> tails xs' - - isPrefixOf :: (Eq a) => [a] -> [a] -> Bool - isPrefixOf [] [] = True - isPrefixOf [] (_:_) = True - isPrefixOf (_:_) [] = False - isPrefixOf (x:xs) (y:ys)= x == y && isPrefixOf xs ys - - isSuffixOf :: (Eq a) => [a] -> [a] -> Bool - isSuffixOf x y = reverse x `isPrefixOf` reverse y - - isInfixOf :: (Eq a) => [a] -> [a] -> Bool - isInfixOf needle haystack = any_ (isPrefixOf needle) (tails haystack) - - elem :: (Eq a) => a -> [a] -> Bool - elem _ [] = False - elem x (y:ys) = x==y || elem x ys - - notElem :: (Eq a) => a -> [a] -> Bool - notElem _ [] = True - notElem x (y:ys) = x /= y && notElem x ys - - zip :: [a] -> [b] -> [(a,b)] - zip (x:xs) (y:ys) = (x,y) : zip xs ys - zip [] [] = [] - zip (_:_) [] = [] - zip [] (_:_) = [] - - zip3 :: [a] -> [b] -> [c] -> [(a,b,c)] - zip3 (a:as) (b:bs) (c:cs) = (a,b,c) : zip3 as bs cs - zip3 [] [] [] = [] - zip3 [] [] (_:_) = [] - zip3 [] (_:_) [] = [] - zip3 [] (_:_) (_:_) = [] - zip3 (_:_) [] [] = [] - zip3 (_:_) [] (_:_) = [] - zip3 (_:_) (_:_) [] = [] - - zipWith :: (a -> b -> c) -> [a] -> [b] -> [c] - zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys - zipWith _ [] [] = [] - zipWith _ (_:_) [] = [] - zipWith _ [] (_:_) = [] - - zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d] - zipWith3 z (a:as) (b:bs) (c:cs) = z a b c : zipWith3 z as bs cs - zipWith3 _ [] [] [] = [] - zipWith3 _ [] [] (_:_) = [] - zipWith3 _ [] (_:_) [] = [] - zipWith3 _ [] (_:_) (_:_) = [] - zipWith3 _ (_:_) [] [] = [] - zipWith3 _ (_:_) [] (_:_) = [] - zipWith3 _ (_:_) (_:_) [] = [] - - unzip :: [(a,b)] -> ([a],[b]) - unzip xs = foldr (\(a,b) (as,bs) -> (a:as,b:bs)) ([],[]) xs - - -- Lazy patterns removed from unzip - unzip3 :: [(a,b,c)] -> ([a],[b],[c]) - unzip3 xs = foldr (\(a,b,c) (as,bs,cs) -> (a:as,b:bs,c:cs)) - ([],[],[]) xs - - unzip4 :: [(a,b,c,d)] -> ([a],[b],[c],[d]) - unzip4 xs = foldr (\(a,b,c,d) (as,bs,cs,ds) -> - (a:as,b:bs,c:cs,d:ds)) - ([],[],[],[]) xs - - unzip5 :: [(a,b,c,d,e)] -> ([a],[b],[c],[d],[e]) - unzip5 xs = foldr (\(a,b,c,d,e) (as,bs,cs,ds,es) -> - (a:as,b:bs,c:cs,d:ds,e:es)) - ([],[],[],[],[]) xs - - unzip6 :: [(a,b,c,d,e,f)] -> ([a],[b],[c],[d],[e],[f]) - unzip6 xs = foldr (\(a,b,c,d,e,f) (as,bs,cs,ds,es,fs) -> - (a:as,b:bs,c:cs,d:ds,e:es,f:fs)) - ([],[],[],[],[],[]) xs - - unzip7 :: [(a,b,c,d,e,f,g)] -> ([a],[b],[c],[d],[e],[f],[g]) - unzip7 xs = foldr (\(a,b,c,d,e,f,g) (as,bs,cs,ds,es,fs,gs) -> - (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs)) - ([],[],[],[],[],[],[]) xs - --- We can't promote any of these functions because at the type level --- String literals are no longer considered to be lists of Chars, so --- there is mismatch between term-level and type-level semantics --- lines :: String -> [String] --- lines "" = [] --- lines s = cons (case break (== '\n') s of --- (l, s') -> (l, case s' of --- [] -> [] --- _:s'' -> lines s'')) --- where --- cons ~(h, t) = h : t --- --- unlines :: [String] -> String --- unlines = concatMap (++ "\n") --- --- words :: String -> [String] --- words s = case dropWhile isSpace s of --- "" -> [] --- s' -> w : words s'' --- where (w, s'') = --- break isSpace s' --- --- unwords :: [String] -> String --- unwords [] = "" --- unwords ws = foldr1 (\w s -> w ++ ' ':s) ws - - delete :: (Eq a) => a -> [a] -> [a] - delete = deleteBy (==) - - (\\) :: (Eq a) => [a] -> [a] -> [a] - (\\) = foldl (flip delete) - 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 list comprehensions, infinite lists and and Ints --- findIndices :: (a -> Bool) -> [a] -> [Int] --- findIndices p xs = [ i | (x,i) <- zip xs [0..], p x] - - findIndices :: (a -> Bool) -> [a] -> [Nat] - findIndices p xs = map snd (filter (\(x,_) -> p x) - (zip xs (buildList 0 xs))) - where buildList :: Nat -> [b] -> [Nat] - buildList _ [] = [] - buildList a (_:rest) = a : buildList (a+1) rest - - -- Relies on intersectBy, which does not singletonize - intersect :: (Eq a) => [a] -> [a] -> [a] - intersect = intersectBy (==) - --- Uses list comprehensions. --- intersectBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] --- intersectBy _ [] [] = [] --- intersectBy _ [] (_:_) = [] --- intersectBy _ (_:_) [] = [] --- intersectBy eq xs ys = [x | x <- xs, any_ (eq x) ys] - - intersectBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] - intersectBy _ [] [] = [] - intersectBy _ [] (_:_) = [] - intersectBy _ (_:_) [] = [] - intersectBy eq xs@(_:_) ys@(_:_) = filter (\x -> any_ (eq x) ys) xs - - 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 list comprehensions --- transpose :: [[a]] -> [[a]] --- transpose [] = [] --- transpose ([] : xss) = transpose xss --- transpose ((x:xs) : xss) = (x : [h | (h:_) <- xss]) : transpose (xs : [ t | (_:t) <- xss]) - - transpose :: [[a]] -> [[a]] - transpose [] = [] - transpose ([] : xss) = transpose xss - transpose ((x:xs) : xss) = (x : (map head xss)) : transpose (xs : (map tail xss)) - --- Can't be promoted because of limitations of Int promotion. --- Below is a re-implementation using Nat --- (!!) :: [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) - - 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 - - |]) 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,555 +0,0 @@ -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TypeInType, TypeOperators, - TypeFamilies, GADTs, UndecidableInstances #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.List.NonEmpty --- Copyright : (C) 2016 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) --- 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((:%|)), - - -- | Though Haddock doesn't show it, the 'Sing' instance above declares - -- constructor - -- - -- > (:%|) :: Sing h -> Sing t -> Sing (h :| t) - - SNonEmpty, - -- | 'SNonEmpty' is a kind-restricted synonym for 'Sing': - -- @type SNonEmpty (a :: NonEmpty) = Sing a@ - - -- * 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, - (:<|), (%:<|), - 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, - (:!!), (%:!!), - 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, - (:<|$), (:<|$$), (:<|$$$), - 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, - (:!!$), (:!!$$), (:!!$$$), - ZipSym0, ZipSym1, ZipSym2, - ZipWithSym0, ZipWithSym1, ZipWithSym2, ZipWithSym3, - UnzipSym0, UnzipSym1, - FromListSym0, FromListSym1, - ToListSym0, ToListSym1, - NonEmpty_Sym0, NonEmpty_Sym1, - XorSym0, XorSym1 - ) where - -import Data.List.NonEmpty -import Data.Singletons.Prelude.List.NonEmpty.Internal -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.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) - - -- | @since 4.9.0.0 - 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/List/NonEmpty/Internal.hs b/src/Data/Singletons/Prelude/List/NonEmpty/Internal.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/List/NonEmpty/Internal.hs +++ /dev/null @@ -1,133 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.List.NonEmpty.Internal --- Copyright : (C) 2016 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) --- Stability : experimental --- Portability : non-portable --- --- Renames a bunch of List functions because singletons can't support qualified --- names. :( --- ----------------------------------------------------------------------------- - -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TypeInType, TypeFamilies, - UndecidableInstances, GADTs #-} -{-# OPTIONS_GHC -Wno-missing-signatures #-} - -module Data.Singletons.Prelude.List.NonEmpty.Internal where - -import Data.Singletons.Single -import Data.Singletons.Prelude.List -import Data.Singletons.Prelude.Ord -import Data.Singletons.Prelude.Eq -import Data.List -import GHC.TypeLits - --- singletons doesn't support qualified names :( -$(singletons [d| - listlast :: [a] -> a - listlast = last - - listinit :: [a] -> [a] - listinit = init - - listsort :: Ord a => [a] -> [a] - listsort = sort - - listinits :: [a] -> [[a]] - listinits = inits - - listtails :: [a] -> [[a]] - listtails = tails - - listinsert :: Ord a => a -> [a] -> [a] - listinsert = insert - - listscanl :: (b -> a -> b) -> b -> [a] -> [b] - listscanl = scanl - - listscanr :: (a -> b -> b) -> b -> [a] -> [b] - listscanr = scanr - - listscanr1 :: (a -> a -> a) -> [a] -> [a] - listscanr1 = scanr1 - - listintersperse :: a -> [a] -> [a] - listintersperse = intersperse - - listreverse :: [a] -> [a] - listreverse = reverse - - listtakeWhile :: (a -> Bool) -> [a] -> [a] - listtakeWhile = takeWhile - - listdropWhile :: (a -> Bool) -> [a] -> [a] - listdropWhile = dropWhile - - listspan :: (a -> Bool) -> [a] -> ([a], [a]) - listspan = span - - listfilter :: (a -> Bool) -> [a] -> [a] - listfilter = filter - - listpartition :: (a -> Bool) -> [a] -> ([a], [a]) - listpartition = partition - - listsortBy :: (a -> a -> Ordering) -> [a] -> [a] - listsortBy = sortBy - - listisPrefixOf :: Eq a => [a] -> [a] -> Bool - listisPrefixOf = isPrefixOf - - listzip :: [a] -> [b] -> [(a, b)] - listzip = zip - - listzipWith :: (a -> b -> c) -> [a] -> [b] -> [c] - listzipWith = zipWith - - listnubBy :: (a -> a -> Bool) -> [a] -> [a] - listnubBy = nubBy - - listtranspose :: [[a]] -> [[a]] - listtranspose = transpose - - listunzip :: [(a,b)] -> ([a],[b]) - listunzip = unzip - - listmap :: (a -> b) -> [a] -> [b] - listmap = map - |]) - -$(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/Maybe.hs b/src/Data/Singletons/Prelude/Maybe.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/Maybe.hs +++ /dev/null @@ -1,129 +0,0 @@ -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TypeFamilies, TypeInType, - DataKinds, PolyKinds, UndecidableInstances, GADTs, RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Maybe --- Copyright : (C) 2013-2014 Richard Eisenberg, Jan Stolarek --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines functions and datatypes relating to the singleton for 'Maybe', --- including a singletons version of all the definitions in @Data.Maybe@. --- --- Because many of these definitions are produced by Template Haskell, --- it is not possible to create proper Haddock documentation. Please look --- up the corresponding operation in @Data.Maybe@. Also, please excuse --- the apparent repeated variable names. This is due to an interaction --- between Template Haskell and Haddock. --- ----------------------------------------------------------------------------- - - -module Data.Singletons.Prelude.Maybe ( - -- The 'Maybe' singleton - - Sing(SNothing, SJust), - -- | Though Haddock doesn't show it, the 'Sing' instance above declares - -- constructors - -- - -- > SNothing :: Sing Nothing - -- > SJust :: Sing a -> Sing (Just a) - - SMaybe, - -- | 'SBool' is a kind-restricted synonym for 'Sing': @type SMaybe (a :: Maybe k) = Sing a@ - - -- * Singletons from @Data.Maybe@ - maybe_, Maybe_, sMaybe_, - -- | The preceding two definitions are derived from the function 'maybe' in - -- @Data.Maybe@. The extra underscore is to avoid name clashes with the type - -- 'Maybe'. - - IsJust, sIsJust, IsNothing, sIsNothing, - FromJust, sFromJust, FromMaybe, sFromMaybe, ListToMaybe, sListToMaybe, - MaybeToList, sMaybeToList, CatMaybes, sCatMaybes, MapMaybe, sMapMaybe, - - -- * Defunctionalization symbols - NothingSym0, JustSym0, JustSym1, - - Maybe_Sym0, Maybe_Sym1, Maybe_Sym2, Maybe_Sym3, - IsJustSym0, IsJustSym1, IsNothingSym0, IsNothingSym1, - FromJustSym0, FromJustSym1, FromMaybeSym0, FromMaybeSym1, FromMaybeSym2, - ListToMaybeSym0, ListToMaybeSym1, MaybeToListSym0, MaybeToListSym1, - CatMaybesSym0, CatMaybesSym1, MapMaybeSym0, MapMaybeSym1, MapMaybeSym2 - ) where - -import Data.Singletons.Prelude.Instances -import Data.Singletons.TH -import Data.Singletons.TypeLits - -$(singletons [d| - -- Renamed to avoid name clash - -- -| The 'maybe' function takes a default value, a function, and a 'Maybe' - -- value. If the 'Maybe' value is 'Nothing', the function returns the - -- default value. Otherwise, it applies the function to the value inside - -- the 'Just' and returns the result. - maybe_ :: b -> (a -> b) -> Maybe a -> b - maybe_ n _ Nothing = n - maybe_ _ f (Just x) = f x - |]) - -$(singletonsOnly [d| - -- -| The 'isJust' function returns 'True' iff its argument is of the - -- form @Just _@. - isJust :: Maybe a -> Bool - isJust Nothing = False - isJust (Just _) = True - - -- -| The 'isNothing' function returns 'True' iff its argument is 'Nothing'. - isNothing :: Maybe a -> Bool - isNothing Nothing = True - isNothing (Just _) = False - - -- -| The 'fromJust' function extracts the element out of a 'Just' and - -- throws an error if its argument is 'Nothing'. - fromJust :: Maybe a -> a - fromJust Nothing = error "Maybe.fromJust: Nothing" -- yuck - fromJust (Just x) = x - - -- -| The 'fromMaybe' function takes a default value and and 'Maybe' - -- value. If the 'Maybe' is 'Nothing', it returns the default values; - -- otherwise, it returns the value contained in the 'Maybe'. - fromMaybe :: a -> Maybe a -> a - fromMaybe d x = case x of {Nothing -> d;Just v -> v} - - -- -| The 'maybeToList' function returns an empty list when given - -- 'Nothing' or a singleton list when not given 'Nothing'. - maybeToList :: Maybe a -> [a] - maybeToList Nothing = [] - maybeToList (Just x) = [x] - - -- -| The 'listToMaybe' function returns 'Nothing' on an empty list - -- or @'Just' a@ where @a@ is the first element of the list. - listToMaybe :: [a] -> Maybe a - listToMaybe [] = Nothing - listToMaybe (a:_) = Just a - - -- Modified to avoid list comprehensions - -- -| The 'catMaybes' function takes a list of 'Maybe's and returns - -- a list of all the 'Just' values. - catMaybes :: [Maybe a] -> [a] - catMaybes [] = [] - catMaybes (Just x : xs) = x : catMaybes xs - catMaybes (Nothing : xs) = catMaybes xs - - -- -| The 'mapMaybe' function is a version of 'map' which can throw - -- out elements. In particular, the functional argument returns - -- something of type @'Maybe' b@. If this is 'Nothing', no element - -- is added on to the result list. If it just @'Just' b@, then @b@ is - -- included in the result list. - mapMaybe :: (a -> Maybe b) -> [a] -> [b] - mapMaybe _ [] = [] - mapMaybe f (x:xs) = - let rs = mapMaybe f xs in - case f x of - Nothing -> rs - Just r -> r:rs - |]) diff --git a/src/Data/Singletons/Prelude/Num.hs b/src/Data/Singletons/Prelude/Num.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/Num.hs +++ /dev/null @@ -1,129 +0,0 @@ -{-# LANGUAGE TemplateHaskell, PolyKinds, DataKinds, TypeFamilies, TypeInType, - TypeOperators, GADTs, ScopedTypeVariables, UndecidableInstances, - DefaultSignatures, FlexibleContexts - #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Num --- Copyright : (C) 2014 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines and exports promoted and singleton versions of definitions from --- GHC.Num. --- ----------------------------------------------------------------------------- - -module Data.Singletons.Prelude.Num ( - PNum(..), SNum(..), Subtract, sSubtract, - - -- ** Defunctionalization symbols - (:+$), (:+$$), (:+$$$), - (:-$), (:-$$), (:-$$$), - (:*$), (:*$$), (:*$$$), - NegateSym0, NegateSym1, - AbsSym0, AbsSym1, - SignumSym0, SignumSym1, - FromIntegerSym0, FromIntegerSym1, - SubtractSym0, SubtractSym1, SubtractSym2 - ) where - -import Data.Singletons.Single -import Data.Singletons -import Data.Singletons.TypeLits.Internal -import Data.Singletons.Decide -import GHC.TypeLits -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 - |]) - --- PNum instance -type family SignumNat (a :: Nat) :: Nat where - SignumNat 0 = 0 - SignumNat x = 1 - -instance PNum Nat where - type a :+ b = a + b - type a :- b = a - b - type a :* b = a * 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 - Just (SomeNat (_ :: Proxy ab)) -> unsafeCoerce (SNat :: Sing ab) - Nothing -> error "Two naturals added to a negative?" - - sa %:- sb = - let a = fromSing sa - b = fromSing sb - ex = someNatVal (a - b) - in - case ex of - Just (SomeNat (_ :: Proxy ab)) -> unsafeCoerce (SNat :: Sing ab) - Nothing -> - error "Negative natural-number singletons are naturally not allowed." - - sa %:* sb = - let a = fromSing sa - b = fromSing sb - ex = someNatVal (a * b) - in - case ex of - Just (SomeNat (_ :: Proxy ab)) -> unsafeCoerce (SNat :: Sing ab) - Nothing -> - error "Two naturals multiplied to a negative?" - - sNegate _ = error "Cannot call sNegate on a natural number singleton." - - sAbs x = x - - sSignum sx = - case sx %~ (sing :: Sing 0) of - Proved Refl -> sing :: Sing 0 - Disproved _ -> unsafeCoerce (sing :: Sing 1) - - sFromInteger x = x - -$(singletonsOnly [d| - subtract :: Num a => a -> a -> a - subtract x y = y - x - |]) diff --git a/src/Data/Singletons/Prelude/Ord.hs b/src/Data/Singletons/Prelude/Ord.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/Ord.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# LANGUAGE TemplateHaskell, DataKinds, PolyKinds, ScopedTypeVariables, - TypeFamilies, TypeOperators, GADTs, UndecidableInstances, - FlexibleContexts, DefaultSignatures, InstanceSigs, TypeInType #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Ord --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines the promoted version of Ord, 'POrd', and the singleton version, --- 'SOrd'. --- ------------------------------------------------------------------------------ - -module Data.Singletons.Prelude.Ord ( - POrd(..), SOrd(..), - - Comparing, sComparing, - - -- | 'thenCmp' returns its second argument if its first is 'EQ'; otherwise, - -- it returns its first argument. - thenCmp, ThenCmp, sThenCmp, - - Sing(SLT, SEQ, SGT), - - -- ** Defunctionalization symbols - ThenCmpSym0, ThenCmpSym1, ThenCmpSym2, - LTSym0, EQSym0, GTSym0, - CompareSym0, CompareSym1, CompareSym2, - (:<$), (:<$$), (:<$$$), - (:<=$), (:<=$$), (:<=$$$), - (:>$), (:>$$), (:>$$$), - (:>=$), (:>=$$), (:>=$$$), - MaxSym0, MaxSym1, MaxSym2, - MinSym0, MinSym1, MinSym2, - ComparingSym0, ComparingSym1, ComparingSym2, ComparingSym3 - ) where - -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) - |]) - -$(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/Tuple.hs b/src/Data/Singletons/Prelude/Tuple.hs deleted file mode 100644 --- a/src/Data/Singletons/Prelude/Tuple.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, DataKinds, PolyKinds, - RankNTypes, TypeFamilies, GADTs, UndecidableInstances, TypeInType #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Tuple --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines functions and datatypes relating to the singleton for tuples, --- including a singletons version of all the definitions in @Data.Tuple@. --- --- Because many of these definitions are produced by Template Haskell, --- it is not possible to create proper Haddock documentation. Please look --- up the corresponding operation in @Data.Tuple@. Also, please excuse --- the apparent repeated variable names. This is due to an interaction --- between Template Haskell and Haddock. --- ----------------------------------------------------------------------------- - -module Data.Singletons.Prelude.Tuple ( - -- * Singleton definitions - -- | See 'Data.Singletons.Prelude.Sing' for more info. - - Sing(STuple0, STuple2, STuple3, STuple4, STuple5, STuple6, STuple7), - STuple0, STuple2, STuple3, STuple4, STuple5, STuple6, STuple7, - - -- * Singletons from @Data.Tuple@ - Fst, sFst, Snd, sSnd, Curry, sCurry, Uncurry, sUncurry, Swap, sSwap, - - -- * Defunctionalization symbols - Tuple0Sym0, - Tuple2Sym0, Tuple2Sym1, Tuple2Sym2, - Tuple3Sym0, Tuple3Sym1, Tuple3Sym2, Tuple3Sym3, - Tuple4Sym0, Tuple4Sym1, Tuple4Sym2, Tuple4Sym3, Tuple4Sym4, - Tuple5Sym0, Tuple5Sym1, Tuple5Sym2, Tuple5Sym3, Tuple5Sym4, Tuple5Sym5, - Tuple6Sym0, Tuple6Sym1, Tuple6Sym2, Tuple6Sym3, Tuple6Sym4, Tuple6Sym5, Tuple6Sym6, - Tuple7Sym0, Tuple7Sym1, Tuple7Sym2, Tuple7Sym3, Tuple7Sym4, Tuple7Sym5, Tuple7Sym6, Tuple7Sym7, - - FstSym0, FstSym1, SndSym0, SndSym1, - CurrySym0, CurrySym1, CurrySym2, CurrySym3, - UncurrySym0, UncurrySym1, UncurrySym2, - SwapSym0, SwapSym1 - ) where - -import Data.Singletons.Prelude.Instances -import Data.Singletons.TH - -$(singletonsOnly [d| - -- -| Extract the first component of a pair. - fst :: (a,b) -> a - fst (x,_) = x - - -- -| Extract the second component of a pair. - snd :: (a,b) -> b - snd (_,y) = y - - -- -| 'curry' converts an uncurried function to a curried function. - curry :: ((a, b) -> c) -> a -> b -> c - curry f x y = f (x, y) - - -- -| 'uncurry' converts a curried function to a function on pairs. - uncurry :: (a -> b -> c) -> ((a, b) -> c) - uncurry f p = f (fst p) (snd p) - - -- -| Swap the components of a pair. - swap :: (a,b) -> (b,a) - swap (a,b) = (b,a) - |]) diff --git a/src/Data/Singletons/Promote.hs b/src/Data/Singletons/Promote.hs deleted file mode 100644 --- a/src/Data/Singletons/Promote.hs +++ /dev/null @@ -1,638 +0,0 @@ -{- Data/Singletons/Promote.hs - -(c) Richard Eisenberg 2013 -rae@cs.brynmawr.edu - -This file contains functions to promote term-level constructs to the -type level. It is an internal module to the singletons package. --} - -{-# LANGUAGE TemplateHaskell, MultiWayIf, LambdaCase, TupleSections #-} - -module Data.Singletons.Promote where - -import Language.Haskell.TH hiding ( Q, cxt ) -import Language.Haskell.TH.Syntax ( Quasi(..) ) -import Language.Haskell.TH.Desugar -import 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.Partition -import Data.Singletons.Util -import Data.Singletons.Syntax -import Prelude hiding (exp) -import Control.Monad -import qualified Data.Map.Strict as Map -import Data.Map.Strict ( Map ) -import Data.Maybe - --- | Generate promoted definitions from a type that is already defined. --- This is generally only useful with classes. -genPromotions :: DsMonad q => [Name] -> q [Dec] -genPromotions names = do - checkForRep names - infos <- mapM reifyWithWarning names - dinfos <- mapM dsInfo infos - ddecs <- promoteM_ [] $ mapM_ promoteInfo dinfos - return $ decsToTH ddecs - --- | Promote every declaration given to the type level, retaining the originals. -promote :: DsMonad q => q [Dec] -> q [Dec] -promote qdec = do - decls <- qdec - ddecls <- withLocalDeclarations decls $ dsDecs decls - promDecls <- promoteM_ decls $ promoteDecs ddecls - return $ decls ++ decsToTH promDecls - --- | Promote each declaration, discarding the originals. Note that a promoted --- datatype uses the same definition as an original datatype, so this will --- not work with datatypes. Classes, instances, and functions are all fine. -promoteOnly :: DsMonad q => q [Dec] -> q [Dec] -promoteOnly qdec = do - decls <- qdec - ddecls <- dsDecs decls - promDecls <- promoteM_ decls $ promoteDecs ddecls - return $ decsToTH promDecls - --- | Generate defunctionalization symbols for existing type family -genDefunSymbols :: DsMonad q => [Name] -> q [Dec] -genDefunSymbols names = do - checkForRep names - infos <- mapM (dsInfo <=< reifyWithWarning) names - decs <- promoteMDecs [] $ concatMapM defunInfo infos - return $ decsToTH decs - --- | Produce instances for '(:==)' (type-level equality) from the given types -promoteEqInstances :: DsMonad q => [Name] -> q [Dec] -promoteEqInstances = concatMapM promoteEqInstance - --- | Produce instances for 'POrd' from the given types -promoteOrdInstances :: DsMonad q => [Name] -> q [Dec] -promoteOrdInstances = concatMapM promoteOrdInstance - --- | Produce an instance for 'POrd' from the given type -promoteOrdInstance :: DsMonad q => Name -> q [Dec] -promoteOrdInstance = promoteInstance mkOrdInstance "Ord" - --- | Produce instances for 'PBounded' from the given types -promoteBoundedInstances :: DsMonad q => [Name] -> q [Dec] -promoteBoundedInstances = concatMapM promoteBoundedInstance - --- | Produce an instance for 'PBounded' from the given type -promoteBoundedInstance :: DsMonad q => Name -> q [Dec] -promoteBoundedInstance = promoteInstance mkBoundedInstance "Bounded" - --- | Produce instances for 'PEnum' from the given types -promoteEnumInstances :: DsMonad q => [Name] -> q [Dec] -promoteEnumInstances = concatMapM promoteEnumInstance - --- | Produce an instance for 'PEnum' from the given type -promoteEnumInstance :: DsMonad q => Name -> q [Dec] -promoteEnumInstance = promoteInstance mkEnumInstance "Enum" - --- | Produce an instance for '(:==)' (type-level equality) from the given type -promoteEqInstance :: DsMonad q => Name -> q [Dec] -promoteEqInstance name = do - (_tvbs, cons) <- getDataD "I cannot make an instance of (:==) for it." name - cons' <- concatMapM dsCon cons - vars <- replicateM (length _tvbs) (qNewName "k") - kind <- promoteType (foldType (DConT name) (map DVarT vars)) - inst_decs <- mkEqTypeInstance kind cons' - return $ decsToTH inst_decs - -promoteInstance :: DsMonad q => (DType -> [DCon] -> q UInstDecl) - -> 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 - cons' <- concatMapM dsCon cons - tvbs' <- mapM dsTvb tvbs - raw_inst <- mk_inst (foldType (DConT name) (map tvbToType tvbs')) cons' - decs <- promoteM_ [] $ void $ promoteInstanceDec 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) :: TyFun Bool Bool -> * where --- Foo Zero = Id --- Foo a = Not --- --- To generate type signature for Foo type family we must first learn --- what is the actual number of patterns used in defining cequations --- of foo. In this case there is only one so we declare Foo to take --- one argument and have return type of Bool -> Bool. - --- Promote a list of top-level declarations. -promoteDecs :: [DDec] -> PrM () -promoteDecs 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 } <- partitionDecs decls - - -- promoteLetDecs returns LetBinds, which we don't need at top level - _ <- promoteLetDecs noPrefix let_decs - mapM_ promoteClassDec classes - let all_meth_sigs = foldMap (lde_types . cd_lde) classes - mapM_ (promoteInstanceDec all_meth_sigs) insts - promoteDataDecs datas - -promoteDataDecs :: [DataDecl] -> PrM () -promoteDataDecs data_decs = do - rec_selectors <- concatMapM extract_rec_selectors data_decs - _ <- promoteLetDecs noPrefix rec_selectors - mapM_ promoteDataDec data_decs - where - extract_rec_selectors :: DataDecl -> PrM [DLetDec] - extract_rec_selectors (DataDecl _nd data_name tvbs cons _derivings) = - let arg_ty = foldType (DConT data_name) - (map tvbToType tvbs) - in - getRecordSelectors arg_ty cons - --- curious about ALetDecEnv? See the LetDecEnv module for an explanation. -promoteLetDecs :: (String, String) -- (alpha, symb) prefixes to use - -> [DLetDec] -> PrM ([LetBind], ALetDecEnv) - -- See Note [Promoting declarations in two stages] -promoteLetDecs prefixes decls = do - let_dec_env <- buildLetDecEnv decls - all_locals <- allLocals - let binds = [ (name, foldType (DConT sym) (map DVarT all_locals)) - | name <- Map.keys $ lde_defns let_dec_env - , let proName = promoteValNameLhsPrefix prefixes name - sym = promoteTySym proName (length all_locals) ] - (decs, let_dec_env') <- letBind binds $ promoteLetDecEnv prefixes let_dec_env - emitDecs decs - return (binds, let_dec_env' { lde_proms = Map.fromList binds }) - --- Promotion of data types to kinds is automatic (see "Ginving Haskell a --- Promotion" paper for more details). Here we "plug into" the promotion --- mechanism to add some extra stuff to the promotion: --- --- * if data type derives Eq we generate a type family that implements the --- equality test for the data type. --- --- * for each data constructor with arity greater than 0 we generate type level --- symbols for use with Apply type family. In this way promoted data --- constructors and promoted functions can be used in a uniform way at the --- type level in the same way they can be used uniformly at the type level. --- --- * for each nullary data constructor we generate a type synonym -promoteDataDec :: DataDecl -> PrM () -promoteDataDec (DataDecl _nd name tvbs ctors derivings) = do - -- deriving Eq instance - kvs <- replicateM (length tvbs) (qNewName "k") - kind <- promoteType (foldType (DConT name) (map DVarT kvs)) - when (any (\case DConPr n -> n == eqName - _ -> False) derivings) $ do - eq_decs <- mkEqTypeInstance kind ctors - emitDecs eq_decs - - ctorSyms <- buildDefunSymsDataD name tvbs ctors - emitDecs ctorSyms - --- Note [CUSKification] --- ~~~~~~~~~~~~~~~~~~~~ --- GHC #12928 means that sometimes, this TH code will produce a declaration --- that has a kind signature even when we want kind inference to work. There --- seems to be no way to avoid this, so we embrace it: --- --- * If a class type variable has no explicit kind, we make no effort to --- guess it and default to *. This is OK because before TypeInType we were --- limited by KProxy anyway. --- --- * If a class type variable has an explicit kind, it is preserved. --- --- This way, we always get proper CUSKs where we need them. - -promoteClassDec :: UClassDecl - -> PrM AClassDecl -promoteClassDec decl@(ClassDecl { cd_cxt = cxt - , cd_name = cls_name - , cd_tvbs = tvbs' - , cd_fds = fundeps - , cd_lde = lde@LetDecEnv - { lde_defns = defaults - , lde_types = meth_sigs - , lde_infix = infix_decls } }) = do - let - -- a workaround for GHC Trac #12928; see Note [CUSKification] - cuskify :: DTyVarBndr -> DTyVarBndr - cuskify (DPlainTV tvname) = DKindedTV tvname DStarT - cuskify tv = tv - tvbs = map cuskify tvbs' - let pClsName = promoteClassName cls_name - pCxt <- mapM promote_superclass_pred cxt - sig_decs <- mapM (uncurry promote_sig) (Map.toList meth_sigs) - let defaults_list = Map.toList defaults - defaults_names = map fst defaults_list - (default_decs, ann_rhss, prom_rhss) - <- mapAndUnzip3M (promoteMethod Nothing meth_sigs) defaults_list - - let infix_decls' = catMaybes $ map (uncurry promoteInfixDecl) infix_decls - - -- no need to do anything to the fundeps. They work as is! - emitDecs [DClassD pCxt pClsName tvbs fundeps - (sig_decs ++ default_decs ++ infix_decls')] - let defaults_list' = zip defaults_names ann_rhss - proms = zip defaults_names prom_rhss - return (decl { cd_lde = lde { lde_defns = Map.fromList defaults_list' - , lde_proms = Map.fromList proms } }) - where - promote_sig :: Name -> DType -> PrM DDec - promote_sig name ty = do - let proName = promoteValNameLhs name - (argKs, resK) <- promoteUnraveled ty - args <- mapM (const $ qNewName "arg") argKs - emitDecsM $ defunctionalize proName (map Just argKs) (Just resK) - - return $ DOpenTypeFamilyD (DTypeFamilyHead proName - (zipWith DKindedTV args argKs) - (DKindSig resK) - Nothing) - - promote_superclass_pred :: DPred -> PrM DPred - promote_superclass_pred = go - where - go (DAppPr pr ty) = DAppPr <$> go pr <*> promoteType ty - go (DSigPr pr _k) = go pr -- just ignore the kind; it can't matter - go (DVarPr name) = fail $ "Cannot promote ConstraintKinds variables like " - ++ show name - go (DConPr name) = return $ DConPr (promoteClassName name) - go DWildCardPr = return DWildCardPr - --- returns (unpromoted method name, ALetDecRHS) pairs -promoteInstanceDec :: Map Name DType -> UInstDecl -> PrM AInstDecl -promoteInstanceDec meth_sigs - decl@(InstDecl { id_name = cls_name - , id_arg_tys = inst_tys - , id_meths = meths }) = do - cls_tvb_names <- lookup_cls_tvb_names - inst_kis <- mapM promoteType inst_tys - let subst = Map.fromList $ zip cls_tvb_names inst_kis - (meths', ann_rhss, _) <- mapAndUnzip3M (promoteMethod (Just subst) meth_sigs) meths - emitDecs [DInstanceD Nothing [] (foldType (DConT pClsName) - inst_kis) meths'] - return (decl { id_meths = zip (map fst meths) ann_rhss }) - where - pClsName = promoteClassName cls_name - - lookup_cls_tvb_names :: PrM [Name] - lookup_cls_tvb_names = do - mb_info <- dsReify pClsName - case mb_info of - Just (DTyConI (DClassD _ _ tvbs _ _) _) -> return (map extractTvbName tvbs) - _ -> do - mb_info' <- dsReify cls_name - case mb_info' of - Just (DTyConI (DClassD _ _ tvbs _ _) _) -> return (map extractTvbName tvbs) - _ -> fail $ "Cannot find class declaration annotation for " ++ show cls_name - --- promoteMethod needs to substitute in a method's kind because GHC does not do --- enough kind checking of associated types. See GHC#9063. When that bug is fixed, --- the substitution code can be removed. --- Bug is fixed, but only in HEAD, naturally. When we stop supporting 7.8, --- this can be rewritten more cleanly, I imagine. --- UPDATE: GHC 7.10.2 didn't fully solve GHC#9063. Urgh. - -promoteMethod :: Maybe (Map Name DKind) - -- ^ instantiations for class tyvars (Nothing for default decls) - -> Map Name DType -- method types - -> (Name, ULetDecRHS) - -> PrM (DDec, ALetDecRHS, DType) - -- returns (type instance, ALetDecRHS, promoted RHS) -promoteMethod m_subst sigs_map (meth_name, meth_rhs) = do - (arg_kis, res_ki) <- lookup_meth_ty - ((_, _, _, eqns), _defuns, ann_rhs) - <- promoteLetDecRHS (Just (arg_kis, res_ki)) sigs_map noPrefix meth_name meth_rhs - meth_arg_tvs <- mapM (const $ qNewName "a") arg_kis - let do_subst = maybe id substKind m_subst - meth_arg_kis' = map do_subst arg_kis - meth_res_ki' = do_subst res_ki - helperNameBase = case nameBase proName of - first:_ | not (isHsLetter first) -> "TFHelper" - alpha -> alpha - family_args - -- GHC 8 requires bare tyvars to the left of a type family default - | Nothing <- m_subst - = map DVarT meth_arg_tvs - | otherwise - = zipWith (DSigT . DVarT) meth_arg_tvs meth_arg_kis' - helperName <- newUniqueName helperNameBase - emitDecs [DClosedTypeFamilyD (DTypeFamilyHead - helperName - (zipWith DKindedTV meth_arg_tvs meth_arg_kis') - (DKindSig meth_res_ki') - Nothing) - eqns] - emitDecsM (defunctionalize helperName (map Just meth_arg_kis') (Just meth_res_ki')) - return ( DTySynInstD - proName - (DTySynEqn family_args - (foldApply (promoteValRhs helperName) (map DVarT meth_arg_tvs))) - , ann_rhs - , DConT (promoteTySym helperName 0) ) - where - proName = promoteValNameLhs meth_name - - lookup_meth_ty :: PrM ([DKind], DKind) - lookup_meth_ty = case Map.lookup meth_name sigs_map of - Nothing -> do - mb_info <- dsReify proName - case mb_info of - Just (DTyConI (DOpenTypeFamilyD (DTypeFamilyHead _ tvbs mb_res_ki _)) _) - -> let arg_kis = map (default_to_star . extractTvbKind) tvbs - res_ki = default_to_star (resultSigToMaybeKind mb_res_ki) - in return (arg_kis, res_ki) - _ -> fail $ "Cannot find type annotation for " ++ show proName - Just ty -> promoteUnraveled ty - - default_to_star Nothing = DStarT - default_to_star (Just k) = k - -promoteLetDecEnv :: (String, String) -> ULetDecEnv -> PrM ([DDec], ALetDecEnv) -promoteLetDecEnv prefixes (LetDecEnv { lde_defns = value_env - , lde_types = type_env - , lde_infix = infix_decls }) = do - let infix_decls' = catMaybes $ map (uncurry promoteInfixDecl) infix_decls - - -- promote all the declarations, producing annotated declarations - let (names, rhss) = unzip $ Map.toList value_env - (payloads, defun_decss, ann_rhss) - <- fmap unzip3 $ zipWithM (promoteLetDecRHS Nothing type_env prefixes) names rhss - - emitDecs $ concat defun_decss - let decs = map payload_to_dec payloads ++ infix_decls' - - -- build the ALetDecEnv - let let_dec_env' = LetDecEnv { lde_defns = Map.fromList $ zip names ann_rhss - , lde_types = type_env - , lde_infix = infix_decls - , lde_proms = Map.empty } -- filled in promoteLetDecs - - return (decs, let_dec_env') - where - payload_to_dec (name, tvbs, m_ki, eqns) = DClosedTypeFamilyD - (DTypeFamilyHead name tvbs sig Nothing) - eqns - where - sig = maybe DNoSig DKindSig m_ki - -promoteInfixDecl :: Fixity -> Name -> Maybe DDec -promoteInfixDecl fixity name - | isUpcase name = Nothing -- no need to promote the decl - | otherwise = Just $ DLetDec $ DInfixD fixity (promoteValNameLhs name) - --- This function is used both to promote class method defaults and normal --- let bindings. Thus, it can't quite do all the work locally and returns --- an intermediate structure. Perhaps a better design is available. -promoteLetDecRHS :: Maybe ([DKind], DKind) -- the promoted type of the RHS (if known) - -- needed to fix #136 - -> Map Name DType -- local type env't - -> (String, String) -- let-binding prefixes - -> Name -- name of the thing being promoted - -> ULetDecRHS -- body of the thing - -> PrM ( (Name, [DTyVarBndr], Maybe DKind, [DTySynEqn]) -- "type family" - , [DDec] -- defunctionalization - , ALetDecRHS ) -- annotated RHS -promoteLetDecRHS m_rhs_ki type_env prefixes name (UValue exp) = do - (res_kind, num_arrows) - <- case m_rhs_ki of - Just (arg_kis, res_ki) -> return ( Just (ravelTyFun (arg_kis ++ [res_ki])) - , length arg_kis ) - _ | Just ty <- Map.lookup name type_env - -> do ki <- promoteType ty - return (Just ki, countArgs ty) - | otherwise - -> return (Nothing, 0) - case num_arrows of - 0 -> do - all_locals <- allLocals - (exp', ann_exp) <- promoteExp exp - let proName = promoteValNameLhsPrefix prefixes name - defuns <- defunctionalize proName (map (const Nothing) all_locals) res_kind - return ( ( proName, map DPlainTV all_locals, res_kind - , [DTySynEqn (map DVarT all_locals) exp'] ) - , defuns - , AValue (foldType (DConT proName) (map DVarT all_locals)) - num_arrows ann_exp ) - _ -> do - names <- replicateM num_arrows (newUniqueName "a") - let pats = map DVarPa names - newArgs = map DVarE names - promoteLetDecRHS m_rhs_ki type_env prefixes name - (UFunction [DClause pats (foldExp exp newArgs)]) - -promoteLetDecRHS m_rhs_ki type_env prefixes name (UFunction clauses) = do - numArgs <- count_args clauses - (m_argKs, m_resK, ty_num_args) <- case m_rhs_ki of - Just (arg_kis, res_ki) -> return (map Just arg_kis, Just res_ki, length arg_kis) - _ | Just ty <- Map.lookup name type_env - -> do - -- promoteType turns arrows into TyFun. So, we unravel first to - -- avoid this behavior. Note the use of ravelTyFun in resultK - -- to make the return kind work out - (argKs, resultK) <- promoteUnraveled ty - -- invariant: countArgs ty == length argKs - return (map Just argKs, Just resultK, length argKs) - - | otherwise - -> return (replicate numArgs Nothing, Nothing, numArgs) - let proName = promoteValNameLhsPrefix prefixes name - all_locals <- allLocals - defun_decs <- defunctionalize proName - (map (const Nothing) all_locals ++ m_argKs) m_resK - let local_tvbs = map DPlainTV all_locals - tyvarNames <- mapM (const $ qNewName "a") m_argKs - expClauses <- mapM (etaExpand (ty_num_args - numArgs)) clauses - (eqns, ann_clauses) <- mapAndUnzipM promoteClause expClauses - prom_fun <- lookupVarE name - let args = zipWith inferMaybeKindTV tyvarNames m_argKs - all_args = local_tvbs ++ args - return ( (proName, all_args, m_resK, eqns) - , defun_decs - , AFunction prom_fun ty_num_args ann_clauses ) - - where - etaExpand :: Int -> DClause -> PrM DClause - etaExpand n (DClause pats exp) = do - names <- replicateM n (newUniqueName "a") - let newPats = map DVarPa names - newArgs = map DVarE names - return $ DClause (pats ++ newPats) (foldExp exp newArgs) - - count_args (DClause pats _ : _) = return $ length pats - count_args _ = fail $ "Impossible! A function without clauses." - -promoteClause :: DClause -> PrM (DTySynEqn, ADClause) -promoteClause (DClause pats exp) = do - -- promoting the patterns creates variable bindings. These are passed - -- to the function promoted the RHS - (types, new_vars) <- evalForPair $ mapM promotePat pats - (ty, ann_exp) <- lambdaBind new_vars $ promoteExp exp - all_locals <- allLocals -- these are bound *outside* of this clause - return ( DTySynEqn (map DVarT all_locals ++ types) ty - , ADClause new_vars pats ann_exp ) - -promoteMatch :: DMatch -> PrM (DTySynEqn, ADMatch) -promoteMatch (DMatch pat exp) = do - -- promoting the patterns creates variable bindings. These are passed - -- to the function promoted the RHS - (ty, new_vars) <- evalForPair $ promotePat pat - (rhs, ann_exp) <- lambdaBind new_vars $ promoteExp exp - all_locals <- allLocals - return $ ( DTySynEqn (map DVarT all_locals ++ [ty]) rhs - , ADMatch new_vars pat ann_exp) - --- promotes a term pattern into a type pattern, accumulating bound variable names -promotePat :: DPat -> QWithAux VarPromotions PrM DType -promotePat (DLitPa lit) = do - lit' <- promoteLitPat lit - return lit' -promotePat (DVarPa name) = do - -- term vars can be symbols... type vars can't! - tyName <- mkTyName name - addElement (name, tyName) - return $ DVarT tyName -promotePat (DConPa name pats) = do - types <- mapM promotePat pats - let name' = unboxed_tuple_to_tuple name - return $ foldType (DConT name') types - where - unboxed_tuple_to_tuple n - | Just deg <- unboxedTupleNameDegree_maybe n = tupleDataName deg - | otherwise = n -promotePat (DTildePa pat) = do - qReportWarning "Lazy pattern converted into regular pattern in promotion" - promotePat pat -promotePat (DBangPa pat) = do - qReportWarning "Strict pattern converted into regular pattern in promotion" - promotePat pat -promotePat (DSigPa pat ty) = do - promoted <- promotePat pat - ki <- promoteType ty - return $ DSigT promoted ki -promotePat DWildPa = do - name <- newUniqueName "_z" - tyName <- mkTyName name - return $ DVarT tyName - -promoteExp :: DExp -> PrM (DType, ADExp) -promoteExp (DVarE name) = fmap (, ADVarE name) $ lookupVarE name -promoteExp (DConE name) = return $ (promoteValRhs name, ADConE name) -promoteExp (DLitE lit) = fmap (, ADLitE lit) $ promoteLitExp lit -promoteExp (DAppE exp1 exp2) = do - (exp1', ann_exp1) <- promoteExp exp1 - (exp2', ann_exp2) <- promoteExp exp2 - return (apply exp1' exp2', ADAppE ann_exp1 ann_exp2) --- Until we get visible kind applications, this is the best we can do. -promoteExp (DAppTypeE exp _) = do - qReportWarning "Visible type applications are ignored by `singletons`." - promoteExp exp -promoteExp (DLamE names exp) = do - lambdaName <- newUniqueName "Lambda" - tyNames <- mapM mkTyName names - let var_proms = zip names tyNames - (rhs, ann_exp) <- lambdaBind var_proms $ promoteExp exp - tyFamLamTypes <- mapM (const $ qNewName "t") names - all_locals <- allLocals - let all_args = all_locals ++ tyFamLamTypes - tvbs = map DPlainTV all_args - emitDecs [DClosedTypeFamilyD (DTypeFamilyHead - lambdaName - tvbs - DNoSig - Nothing) - [DTySynEqn (map DVarT (all_locals ++ tyNames)) - rhs]] - emitDecsM $ defunctionalize lambdaName (map (const Nothing) all_args) Nothing - let promLambda = foldl apply (DConT (promoteTySym lambdaName 0)) - (map DVarT all_locals) - return (promLambda, ADLamE 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 matches - tyvarName <- qNewName "t" - let all_args = all_locals ++ [tyvarName] - tvbs = map DPlainTV all_args - emitDecs [DClosedTypeFamilyD (DTypeFamilyHead caseTFName tvbs DNoSig Nothing) eqns] - -- See Note [Annotate case return type] in Single - let applied_case = prom_case `DAppT` exp' - return ( applied_case - , ADCaseE ann_exp ann_matches applied_case ) -promoteExp (DLetE decs exp) = do - unique <- qNewUnique - let letPrefixes = uniquePrefixes "Let" ":<<<" unique - (binds, ann_env) <- promoteLetDecs letPrefixes decs - (exp', ann_exp) <- letBind binds $ promoteExp exp - return (exp', ADLetE ann_env ann_exp) -promoteExp (DSigE exp ty) = do - (exp', ann_exp) <- promoteExp exp - ty' <- promoteType ty - return (DSigT exp' ty', ADSigE ann_exp ty) -promoteExp e@(DStaticE _) = fail ("Static expressions cannot be promoted: " ++ show e) - -promoteLitExp :: Monad m => Lit -> m 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) = return $ DLitT (StrTyLit str) -promoteLitExp lit = - fail ("Only string and natural number literals can be promoted: " ++ show lit) - -promoteLitPat :: Monad 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) 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,194 +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.Util -import Control.Monad - -defunInfo :: DInfo -> PrM [DDec] -defunInfo (DTyConI dec _instances) = buildDefunSyms dec -defunInfo (DPrimTyConI _name _numArgs _unlifted) = - fail $ "Building defunctionalization symbols of primitive " ++ - "type constructors not supported" -defunInfo (DVarI _name _ty _mdec) = - 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" - -buildDefunSyms :: DDec -> PrM [DDec] -buildDefunSyms (DDataD _new_or_data _cxt tyName tvbs ctors _derivings) = - buildDefunSymsDataD tyName tvbs ctors -buildDefunSyms (DClosedTypeFamilyD (DTypeFamilyHead name tvbs result_sig _) _) = do - let arg_m_kinds = map extractTvbKind tvbs - defunctionalize name arg_m_kinds (resultSigToMaybeKind result_sig) -buildDefunSyms (DOpenTypeFamilyD (DTypeFamilyHead name tvbs result_sig _)) = do - let arg_kinds = map (default_to_star . extractTvbKind) tvbs - res_kind = default_to_star (resultSigToMaybeKind result_sig) - default_to_star Nothing = Just DStarT - default_to_star (Just k) = Just k - defunctionalize name arg_kinds res_kind -buildDefunSyms (DTySynD name tvbs _type) = do - let arg_m_kinds = map extractTvbKind tvbs - defunctionalize name arg_m_kinds Nothing -buildDefunSyms (DClassD _cxt name tvbs _fundeps _members) = do - let arg_m_kinds = map extractTvbKind tvbs - defunctionalize name arg_m_kinds (Just (DConT constraintName)) -buildDefunSyms _ = fail $ "Defunctionalization symbols can only be built for " ++ - "type families and data declarations" - -buildDefunSymsDataD :: Name -> [DTyVarBndr] -> [DCon] -> PrM [DDec] -buildDefunSymsDataD tyName tvbs ctors = do - let res_ty = foldType (DConT tyName) (map tvbToType tvbs) - res_ki <- promoteType res_ty - concatMapM (promoteCtor res_ki) ctors - where - promoteCtor :: DKind -> DCon -> PrM [DDec] - promoteCtor promotedKind ctor = do - let (name, arg_tys) = extractNameTypes ctor - arg_kis <- mapM promoteType arg_tys - defunctionalize name (map Just arg_kis) (Just promotedKind) - --- Generate data declarations and apply instances --- required for defunctionalization. --- For a type family: --- --- type family Foo (m :: Nat) (n :: Nat) (l :: Nat) :: Nat --- --- we generate data declarations that allow us to talk about partial --- application at the type level: --- --- type FooSym3 a b c = Foo a b c --- data FooSym2 a b f where --- FooSym2KindInference :: SameKind (Apply (FooSym2 a b) arg) (FooSym3 a b arg) --- => FooSym2 a b f --- type instance Apply (FooSym2 a b) c = FooSym3 a b c --- data FooSym1 a f where --- FooSym1KindInference :: SameKind (Apply (FooSym1 a) arg) (FooSym2 a arg) --- => FooSym1 a f --- type instance Apply (FooSym1 a) b = FooSym2 a b --- data FooSym0 f where --- FooSym0KindInference :: SameKind (Apply FooSym0 arg) (FooSym1 arg) --- => FooSym0 f --- type instance Apply FooSym0 a = FooSym1 a --- --- What's up with all the "KindInference" stuff? In some scenarios, we don't --- know the kinds that we should be using in these symbols. But, GHC can figure --- it out using the types of the "KindInference" dummy data constructors. A --- bit of a hack, but it works quite nicely. The only problem is that GHC will --- warn about an unused data constructor. So, we use the data constructor in --- an instance of a dummy class. (See Data.Singletons.Hidden for the class, which --- should never be seen by anyone, ever.) --- --- The defunctionalize function takes Maybe DKinds so that the caller can --- indicate which kinds are known and which need to be inferred. -defunctionalize :: Name -> [Maybe DKind] -> Maybe DKind -> PrM [DDec] -defunctionalize name m_arg_kinds' m_res_kind' = do - let (m_arg_kinds, m_res_kind) = eta_expand (noExactTyVars m_arg_kinds') - (noExactTyVars m_res_kind') - num_args = length m_arg_kinds - sat_name = promoteTySym name num_args - tvbNames <- replicateM num_args $ qNewName "t" - let mk_rhs ns = foldType (DConT name) (map DVarT ns) - sat_dec = DTySynD sat_name (zipWith mk_tvb tvbNames m_arg_kinds) (mk_rhs tvbNames) - other_decs <- go (num_args - 1) (reverse m_arg_kinds) m_res_kind mk_rhs - return $ sat_dec : other_decs - where - mk_tvb :: Name -> Maybe DKind -> DTyVarBndr - mk_tvb tvb_name Nothing = DPlainTV tvb_name - mk_tvb tvb_name (Just k) = DKindedTV tvb_name k - - eta_expand :: [Maybe DKind] -> Maybe DKind -> ([Maybe DKind], Maybe DKind) - eta_expand m_arg_kinds Nothing = (m_arg_kinds, Nothing) - eta_expand m_arg_kinds (Just res_kind) = - let (_, _, argKs, resultK) = unravel res_kind - in (m_arg_kinds ++ (map Just argKs), Just resultK) - - go :: Int -> [Maybe DKind] -> Maybe DKind - -> ([Name] -> DType) -- given the argument names, the RHS of the Apply instance - -> PrM [DDec] - go _ [] _ _ = return [] - go n (m_arg : m_args) m_result mk_rhs = do - fst_name : rest_names <- replicateM (n + 1) (qNewName "l") - extra_name <- qNewName "arg" - let data_name = promoteTySym name n - next_name = promoteTySym name (n+1) - con_name = suffixName "KindInference" "###" (toDataConName data_name) - m_tyfun = buildTyFun_maybe m_arg m_result - arg_params = zipWith mk_tvb rest_names (reverse m_args) - tyfun_param = mk_tvb fst_name m_tyfun - arg_names = map extractTvbName arg_params - params = arg_params ++ [tyfun_param] - con_eq_ct = DConPr sameKindName `DAppPr` lhs `DAppPr` 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 [DPlainTV extra_name] - [con_eq_ct] - con_name - (DNormalC []) - Nothing - data_decl = DDataD Data [] data_name params [con_decl] [] - app_eqn = DTySynEqn [ foldType (DConT data_name) - (map DVarT rest_names) - , DVarT fst_name ] - (mk_rhs (rest_names ++ [fst_name])) - app_decl = DTySynInstD applyName app_eqn - suppress = DInstanceD Nothing [] - (DConT suppressClassName `DAppT` DConT data_name) - [DLetDec $ DFunD suppressMethodName - [DClause [DWildPa] - ((DVarE 'snd) `DAppE` - mkTupleDExp [DConE con_name, - mkTupleDExp []])]] - - mk_rhs' ns = foldType (DConT data_name) (map DVarT ns) - - decls <- go (n - 1) m_args (addStar_maybe (buildTyFun_maybe m_arg m_result)) mk_rhs' - return $ suppress : data_decl : app_decl : decls - -buildTyFun :: DKind -> DKind -> DKind -buildTyFun k1 k2 = DConT tyFunName `DAppT` k1 `DAppT` k2 - -buildTyFun_maybe :: Maybe DKind -> Maybe DKind -> Maybe DKind -buildTyFun_maybe m_k1 m_k2 = do - k1 <- m_k1 - k2 <- m_k2 - return $ DConT tyFunName `DAppT` k1 `DAppT` k2 - --- Counts the arity of type level function represented with TyFun constructors -tyFunArity :: DKind -> Int -tyFunArity (DArrowT `DAppT` (DConT tyFunNm `DAppT` _ `DAppT` b) `DAppT` DStarT) - | tyFunName == tyFunNm - = 1 + tyFunArity b -tyFunArity _ = 0 - --- Checks if type is (TyFun a b -> *) -isTyFun :: DKind -> Bool -isTyFun (DArrowT `DAppT` (DConT tyFunNm `DAppT` _ `DAppT` _) `DAppT` DStarT) - | tyFunName == tyFunNm - = True -isTyFun _ = False - --- Build TyFun kind from the list of kinds -ravelTyFun :: [DKind] -> DKind -ravelTyFun [] = error "Internal error: TyFun raveling nil" -ravelTyFun [k] = k -ravelTyFun kinds = go tailK (buildTyFun k2 k1) - where (k1 : k2 : tailK) = reverse kinds - go [] acc = addStar acc - go (k:ks) acc = go ks (buildTyFun k (addStar acc)) diff --git a/src/Data/Singletons/Promote/Eq.hs b/src/Data/Singletons/Promote/Eq.hs deleted file mode 100644 --- a/src/Data/Singletons/Promote/Eq.hs +++ /dev/null @@ -1,66 +0,0 @@ -{- Data/Singletons/Promote/Eq.hs - -(c) Richard Eisenberg 2014 -rae@cs.brynmawr.edu - -This module defines the functions that generate type-level equality type -family instances. --} - -module Data.Singletons.Promote.Eq where - -import Language.Haskell.TH.Syntax -import Language.Haskell.TH.Desugar -import Data.Singletons.Names -import Data.Singletons.Util -import Control.Monad - --- produce a closed type family helper and the instance --- for (:==) over the given list of ctors -mkEqTypeInstance :: Quasi q => DKind -> [DCon] -> q [DDec] -mkEqTypeInstance kind cons = do - helperName <- newUniqueName "Equals" - aName <- qNewName "a" - bName <- qNewName "b" - true_branches <- mapM mk_branch cons - false_branch <- false_case - let closedFam = DClosedTypeFamilyD (DTypeFamilyHead helperName - [ DKindedTV aName kind - , DKindedTV bName kind ] - (DKindSig boolKi) - Nothing) - (true_branches ++ [false_branch]) - eqInst = DTySynInstD tyEqName (DTySynEqn [ DSigT (DVarT aName) kind - , DSigT (DVarT bName) kind ] - (foldType (DConT helperName) - [DVarT aName, DVarT bName])) - inst = DInstanceD Nothing [] ((DConT $ promoteClassName eqName) `DAppT` - kind) [eqInst] - - return [closedFam, inst] - - where mk_branch :: Quasi q => DCon -> q DTySynEqn - mk_branch con = do - let (name, numArgs) = extractNameArgs con - lnames <- replicateM numArgs (qNewName "a") - rnames <- replicateM numArgs (qNewName "b") - let lvars = map DVarT lnames - rvars = map DVarT rnames - ltype = foldType (DConT name) lvars - rtype = foldType (DConT name) rvars - results = zipWith (\l r -> foldType (DConT tyEqName) [l, r]) lvars rvars - result = tyAll results - return $ DTySynEqn [ltype, rtype] result - - false_case :: Quasi q => q DTySynEqn - false_case = do - lvar <- qNewName "a" - rvar <- qNewName "b" - return $ DTySynEqn [DSigT (DVarT lvar) kind, DSigT (DVarT rvar) kind] - (promoteValRhs falseName) - - tyAll :: [DType] -> DType -- "all" at the type level - tyAll [] = (promoteValRhs trueName) - tyAll [one] = one - tyAll (h:t) = foldType (DConT $ promoteValNameLhs andName) [h, (tyAll t)] - -- I could use the Apply nonsense here, but there's no reason to 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,113 +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, StandaloneDeriving, - FlexibleContexts, TypeFamilies, KindSignatures #-} - -module Data.Singletons.Promote.Monad ( - PrM, promoteM, promoteM_, promoteMDecs, VarPromotions, - allLocals, emitDecs, emitDecsM, - lambdaBind, LetBind, letBind, lookupVarE - ) where - -import Control.Monad.Reader -import Control.Monad.Writer -import qualified Data.Map.Strict as Map -import Data.Map.Strict ( Map ) -import Language.Haskell.TH.Syntax hiding ( lift ) -import Language.Haskell.TH.Desugar -import Data.Singletons.Names -import Data.Singletons.Syntax -import Control.Monad.Fail ( MonadFail ) - -type LetExpansions = Map Name DType -- from **term-level** name - --- environment during promotion -data PrEnv = - PrEnv { pr_lambda_bound :: Map Name Name - , pr_let_bound :: LetExpansions - , pr_local_decls :: [Dec] - } - -emptyPrEnv :: PrEnv -emptyPrEnv = PrEnv { pr_lambda_bound = Map.empty - , pr_let_bound = Map.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 ) - -instance DsMonad PrM where - localDeclarations = asks pr_local_decls - --- return *type-level* names -allLocals :: MonadReader PrEnv m => m [Name] -allLocals = do - lambdas <- asks (Map.toList . pr_lambda_bound) - lets <- asks pr_let_bound - -- filter out shadowed variables! - return [ typeName - | (termName, typeName) <- lambdas - , case Map.lookup termName lets of - Just (DVarT typeName') | typeName' == typeName -> True - _ -> False ] - -emitDecs :: MonadWriter [DDec] m => [DDec] -> m () -emitDecs = tell - -emitDecsM :: MonadWriter [DDec] m => m [DDec] -> m () -emitDecsM action = do - decs <- action - emitDecs decs - --- when lambda-binding variables, we still need to add the variables --- to the let-expansion, because of shadowing. ugh. -lambdaBind :: VarPromotions -> PrM a -> PrM a -lambdaBind binds = local add_binds - where add_binds env@(PrEnv { pr_lambda_bound = lambdas - , pr_let_bound = lets }) = - let new_lets = Map.fromList [ (tmN, DVarT tyN) | (tmN, tyN) <- binds ] in - env { pr_lambda_bound = Map.union (Map.fromList binds) lambdas - , pr_let_bound = Map.union new_lets lets } - -type LetBind = (Name, DType) -letBind :: [LetBind] -> PrM a -> PrM a -letBind binds = local add_binds - where add_binds env@(PrEnv { pr_let_bound = lets }) = - env { pr_let_bound = Map.union (Map.fromList binds) lets } - -lookupVarE :: Name -> PrM DType -lookupVarE n = do - lets <- asks pr_let_bound - case Map.lookup n lets of - Just ty -> return ty - Nothing -> return $ promoteValRhs n - -promoteM :: DsMonad q => [Dec] -> PrM a -> q (a, [DDec]) -promoteM locals (PrM rdr) = do - other_locals <- localDeclarations - let wr = runReaderT rdr (emptyPrEnv { pr_local_decls = other_locals ++ locals }) - q = runWriterT wr - runQ q - -promoteM_ :: DsMonad q => [Dec] -> PrM () -> q [DDec] -promoteM_ locals thing = do - ((), decs) <- promoteM locals thing - return decs - --- promoteM specialized to [DDec] -promoteMDecs :: DsMonad q => [Dec] -> PrM [DDec] -> q [DDec] -promoteMDecs locals thing = do - (decs1, decs2) <- promoteM locals thing - return $ decs1 ++ decs2 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,65 +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, promoteUnraveled ) where - -import Language.Haskell.TH.Desugar -import Data.Singletons.Names -import Data.Singletons.Util -import Language.Haskell.TH - --- the only monadic thing we do here is fail. This allows the function --- to be used from the Singletons module -promoteType :: Monad m => DType -> m DKind -promoteType = go [] - where - go :: Monad m => [DKind] -> DType -> m DKind - -- We don't need to worry about constraints: they are used to express - -- static guarantees at runtime. But, because we don't need to do - -- anything special to keep static guarantees at compile time, we don't - -- need to promote them. - go [] (DForallT _tvbs _cxt ty) = go [] ty - go [] (DAppT (DAppT DArrowT (DForallT (_:_) _ _)) _) = - fail "Cannot promote types of rank above 1." - go args (DAppT t1 t2) = do - k2 <- go [] t2 - go (k2 : args) t1 - -- 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 (DSigT ty ki) = do - ty' <- go [] ty - -- No need to promote 'ki' - it is already a kind. - return $ foldType (DSigT ty' ki) args - go args (DVarT name) = return $ foldType (DVarT name) args - go [] (DConT name) - | name == typeRepName = return DStarT - | name == stringName = return $ DConT symbolName - | nameBase name == nameBase repName = return DStarT - go args (DConT name) - | Just n <- unboxedTupleNameDegree_maybe name - = return $ foldType (DConT (tupleTypeName n)) args - | otherwise - = return $ foldType (DConT name) args - go [k1, k2] DArrowT = return $ addStar (DConT tyFunName `DAppT` k1 `DAppT` k2) - go _ (DLitT _) = fail "Cannot promote a type-level literal" - - go args hd = fail $ "Illegal Haskell construct encountered:\n" ++ - "headed by: " ++ show hd ++ "\n" ++ - "applied to: " ++ show args - -promoteUnraveled :: Monad m => DType -> m ([DKind], DKind) -promoteUnraveled ty = do - arg_kis <- mapM promoteType arg_tys - res_ki <- promoteType res_ty - return (arg_kis, res_ki) - where - (_, _, arg_tys, res_ty) = unravel ty diff --git a/src/Data/Singletons/ShowSing.hs b/src/Data/Singletons/ShowSing.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/ShowSing.hs @@ -0,0 +1,319 @@ +{-# LANGUAGE CPP #-} + +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +#if __GLASGOW_HASKELL__ >= 810 +{-# LANGUAGE StandaloneKindSignatures #-} +#endif +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Singletons.ShowSing +-- Copyright : (C) 2017 Ryan Scott +-- License : BSD-style (see LICENSE) +-- Maintainer : Ryan Scott +-- Stability : experimental +-- Portability : non-portable +-- +-- Defines the class 'ShowSing' which is useful for defining 'Show' instances +-- for singleton types. Because 'ShowSing' crucially relies on +-- @QuantifiedConstraints@, it is only defined if this library is built with +-- GHC 8.6 or later. +-- +---------------------------------------------------------------------------- + +module Data.Singletons.ShowSing ( +#if __GLASGOW_HASKELL__ >= 806 + -- * The 'ShowSing' type + ShowSing, + + -- * Internal utilities + ShowSing' +#endif + ) where + +#if __GLASGOW_HASKELL__ >= 806 +import Data.Kind +import Data.Singletons +import Text.Show + +-- | In addition to the promoted and singled versions of the 'Show' class that +-- @singletons-base@ provides, it is also useful to be able to directly define +-- 'Show' instances for singleton types themselves. Doing so is almost entirely +-- straightforward, as a derived 'Show' instance does 90 percent of the work. +-- The last 10 percent—getting the right instance context—is a bit tricky, and +-- that's where 'ShowSing' comes into play. +-- +-- As an example, let's consider the singleton type for lists. We want to write +-- an instance with the following shape: +-- +-- @ +-- instance ??? => 'Show' ('SList' (z :: [k])) where +-- showsPrec p 'SNil' = showString \"SNil\" +-- showsPrec p ('SCons' sx sxs) = +-- showParen (p > 10) $ showString \"SCons \" . showsPrec 11 sx +-- . showSpace . showsPrec 11 sxs +-- @ +-- +-- To figure out what should go in place of @???@, observe that we require the +-- type of each field to also be 'Show' instances. In other words, we need +-- something like @('Show' ('Sing' (a :: k)))@. But this isn't quite right, as the +-- type variable @a@ doesn't appear in the instance head. In fact, this @a@ +-- type is really referring to an existentially quantified type variable in the +-- 'SCons' constructor, so it doesn't make sense to try and use it like this. +-- +-- Luckily, the @QuantifiedConstraints@ language extension provides a solution +-- to this problem. This lets you write a context of the form +-- @(forall a. 'Show' ('Sing' (a :: k)))@, which demands that there be an instance +-- for @'Show' ('Sing' (a :: k))@ that is parametric in the use of @a@. +-- This lets us write something closer to this: +-- +-- @ +-- instance (forall a. 'Show' ('Sing' (a :: k))) => 'SList' ('Sing' (z :: [k])) where ... +-- @ +-- +-- The 'ShowSing' class is a thin wrapper around +-- @(forall a. 'Show' ('Sing' (a :: k)))@. With 'ShowSing', our final instance +-- declaration becomes this: +-- +-- @ +-- instance 'ShowSing' k => 'Show' ('SList' (z :: [k])) where ... +-- @ +-- +-- In fact, this instance can be derived: +-- +-- @ +-- deriving instance 'ShowSing' k => 'Show' ('SList' (z :: [k])) +-- @ +-- +-- (Note that the actual definition of 'ShowSing' is slightly more complicated +-- than what this documentation might suggest. For the full story, +-- refer to the documentation for `ShowSing'`.) +-- +-- When singling a derived 'Show' instance, @singletons-th@ will also generate +-- a 'Show' instance for the corresponding singleton type using 'ShowSing'. +-- In other words, if you give @singletons-th@ a derived 'Show' instance, then +-- you'll receive the following in return: +-- +-- * A promoted (@PShow@) instance +-- * A singled (@SShow@) instance +-- * A 'Show' instance for the singleton type +-- +-- What a bargain! + +-- One might wonder we we simply don't define ShowSing as +-- @type ShowSing k = (forall (z :: k). ShowSing' z)@ instead of going the +-- extra mile to define it as a class. +-- See Note [Define ShowSing as a class, not a type synonym] for an explanation. +#if __GLASGOW_HASKELL__ >= 810 +type ShowSing :: Type -> Constraint +#endif +class (forall (z :: k). ShowSing' z) => ShowSing (k :: Type) +instance (forall (z :: k). ShowSing' z) => ShowSing (k :: Type) + +-- | The workhorse that powers 'ShowSing'. The only reason that `ShowSing'` +-- exists is to work around GHC's inability to put type families in the head +-- of a quantified constraint (see +-- for more +-- details on this point). In other words, GHC will not let you define +-- 'ShowSing' like so: +-- +-- @ +-- class (forall (z :: k). 'Show' ('Sing' z)) => 'ShowSing' k +-- @ +-- +-- By replacing @'Show' ('Sing' z)@ with @ShowSing' z@, we are able to avoid +-- this restriction for the most part. +-- +-- The superclass of `ShowSing'` is a bit peculiar: +-- +-- @ +-- class (forall (sing :: k -> Type). sing ~ 'Sing' => 'Show' (sing z)) => `ShowSing'` (z :: k) +-- @ +-- +-- One might wonder why this superclass is used instead of this seemingly more +-- direct equivalent: +-- +-- @ +-- class 'Show' ('Sing' z) => `ShowSing'` (z :: k) +-- @ +-- +-- Actually, these aren't equivalent! The latter's superclass mentions a type +-- family in its head, and this gives GHC's constraint solver trouble when +-- trying to match this superclass against other constraints. (See the +-- discussion beginning at +-- https://gitlab.haskell.org/ghc/ghc/-/issues/16365#note_189057 for more on +-- this point). The former's superclass, on the other hand, does /not/ mention +-- a type family in its head, which allows it to match other constraints more +-- easily. It may sound like a small difference, but it's the only reason that +-- 'ShowSing' is able to work at all without a significant amount of additional +-- workarounds. +-- +-- The quantified superclass has one major downside. Although the head of the +-- quantified superclass is more eager to match, which is usually a good thing, +-- it can bite under certain circumstances. Because @'Show' (sing z)@ will +-- match a 'Show' instance for /any/ types @sing :: k -> Type@ and @z :: k@, +-- (where @k@ is a kind variable), it is possible for GHC's constraint solver +-- to get into a situation where multiple instances match @'Show' (sing z)@, +-- and GHC will get confused as a result. Consider this example: +-- +-- @ +-- -- As in "Data.Singletons" +-- newtype 'WrappedSing' :: forall k. k -> Type where +-- 'WrapSing' :: forall k (a :: k). { 'unwrapSing' :: 'Sing' a } -> 'WrappedSing' a +-- +-- instance 'ShowSing' k => 'Show' ('WrappedSing' (a :: k)) where +-- 'showsPrec' _ s = 'showString' "WrapSing {unwrapSing = " . showsPrec 0 s . showChar '}' +-- @ +-- +-- When typechecking the 'Show' instance for 'WrappedSing', GHC must fill in a +-- default definition @'show' = defaultShow@, where +-- @defaultShow :: 'Show' ('WrappedSing' a) => 'WrappedSing' a -> 'String'@. +-- GHC's constraint solver has two possible ways to satisfy the +-- @'Show' ('WrappedSing' a)@ constraint for @defaultShow@: +-- +-- 1. The top-level instance declaration for @'Show' ('WrappedSing' (a :: k))@ +-- itself, and +-- +-- 2. @'Show' (sing (z :: k))@ from the head of the quantified constraint arising +-- from @'ShowSing' k@. +-- +-- In practice, GHC will choose (2), as local quantified constraints shadow +-- global constraints. This confuses GHC greatly, causing it to error out with +-- an error akin to @Couldn't match type Sing with WrappedSing@. See +-- https://gitlab.haskell.org/ghc/ghc/-/issues/17934 for a full diagnosis of +-- the issue. +-- +-- The bad news is that because of GHC#17934, we have to manually define 'show' +-- (and 'showList') in the 'Show' instance for 'WrappedSing' in order to avoid +-- confusing GHC's constraint solver. In other words, @deriving 'Show'@ is a +-- no-go for 'WrappedSing'. The good news is that situations like 'WrappedSing' +-- are quite rare in the world of @singletons@—most of the time, 'Show' +-- instances for singleton types do /not/ have the shape +-- @'Show' (sing (z :: k))@, where @k@ is a polymorphic kind variable. Rather, +-- most such instances instantiate @k@ to a specific kind (e.g., @Bool@, or +-- @[a]@), which means that they will not overlap the head of the quantified +-- superclass in `ShowSing'` as observed above. +-- +-- Note that we define the single instance for `ShowSing'` without the use of a +-- quantified constraint in the instance context: +-- +-- @ +-- instance 'Show' ('Sing' z) => `ShowSing'` (z :: k) +-- @ +-- +-- We /could/ define this instance with a quantified constraint in the instance +-- context, and it would be equally as expressive. But it doesn't provide any +-- additional functionality that the non-quantified version gives, so we opt +-- for the non-quantified version, which is easier to read. +#if __GLASGOW_HASKELL__ >= 810 +type ShowSing' :: k -> Constraint +#endif +class (forall (sing :: k -> Type). sing ~ Sing => Show (sing z)) + => ShowSing' (z :: k) +instance Show (Sing z) => ShowSing' (z :: k) + +{- +Note [Define ShowSing as a class, not a type synonym] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In an ideal world, we would simply define ShowSing like this: + + type ShowSing k = (forall (z :: k). ShowSing' z) :: Constraint) + +In fact, I used to define ShowSing in a manner similar to this in version 2.5 +of singletons. However, I realized some time after 2.5's release that the +this encoding is unfeasible at the time being due to GHC Trac #15888. + +To be more precise, the exact issue involves an infelicity in the way +QuantifiedConstraints interacts with recursive type class instances. +Consider the following example (from #371): + + $(singletons [d| + data X a = X1 | X2 (Y a) deriving Show + data Y a = Y1 | Y2 (X a) deriving Show + |]) + +This will generate the following instances: + + deriving instance ShowSing (Y a) => Show (Sing (z :: X a)) + deriving instance ShowSing (X a) => Show (Sing (z :: Y a)) + +So far, so good. Now, suppose you try to actually `show` a singleton for X. +For example: + + show (sing @(X1 :: X Bool)) + +Somewhat surprisingly, this will be rejected by the typechecker with the +following error: + + • Reduction stack overflow; size = 201 + When simplifying the following type: Show (Sing z) + +To see why this happens, observe what goes on if we expand the occurrences of +the ShowSing type synonym in the generated instances: + + deriving instance (forall z. ShowSing' (z :: Y a)) => Show (Sing (z :: X a)) + deriving instance (forall z. ShowSing' (z :: X a)) => Show (Sing (z :: Y a)) + +Due to the way QuantifiedConstraints currently works (as surmised in Trac +#15888), when GHC has a Wanted `ShowSing' (X1 :: X Bool)` constraint, it +chooses the appropriate instance and emits a Wanted +`forall z. ShowSing' (z :: Y Bool)` constraint (from the instance context). +GHC skolemizes the `z` to `z1` and tries to solve a Wanted +`ShowSing' (z1 :: Y Bool)` constraint. GHC chooses the appropriate instance +and emits a Wanted `forall z. ShowSing' (z :: X Bool)` constraint. GHC +skolemizes the `z` to `z2` and tries to solve a Wanted +`ShowSing' (z2 :: X Bool)` constraint... we repeat the process and find +ourselves in an infinite loop that eventually overflows the reduction stack. +Eep. + +Until Trac #15888 is fixed, there are two possible ways to work around this +problem: + +1. Make derived instances' type inference more clever. If you look closely, + you'll notice that the `ShowSing (X a)`/`ShowSing (Y a)` constraints in + the generated instances are entirely redundant and could safely be left + off. But determining this would require significantly improving singletons-th' + Template Haskell capabilities for type inference, which is a path that we + usually spurn in favor of keeping the generated code dumb but predictable. +2. Define `ShowSing` as a class (with a single instance) instead of a type + synonym. `ShowSing`-as-a-class ties the recursive knot during instance + resolution and thus avoids the problems that the type synonym version + currently suffers from. + +Given the two options, (2) is by far the easier option, so that is what we +ultimately went with. +-} + +------------------------------------------------------------ +-- (S)WrappedSing instances +------------------------------------------------------------ + +-- Note that we cannot derive this Show instance due to +-- https://gitlab.haskell.org/ghc/ghc/-/issues/17934. The Haddocks for +-- ShowSing' contain a lengthier explanation of how GHC#17934 relates to +-- ShowSing. +instance ShowSing k => Show (WrappedSing (a :: k)) where + showsPrec = showsWrappedSingPrec + show x = showsWrappedSingPrec 0 x "" + showList = showListWith (showsWrappedSingPrec 0) + +showsWrappedSingPrec :: ShowSing k => Int -> WrappedSing (a :: k) -> ShowS +showsWrappedSingPrec p (WrapSing s) = showParen (p >= 11) $ + showString "WrapSing {unwrapSing = " . showsPrec 0 s . showChar '}' + +deriving instance ShowSing k => Show (SWrappedSing (ws :: WrappedSing (a :: k))) +#endif diff --git a/src/Data/Singletons/Sigma.hs b/src/Data/Singletons/Sigma.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Sigma.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE QuantifiedConstraints #-} +#else +{-# LANGUAGE TypeInType #-} +#endif + +#if __GLASGOW_HASKELL__ >= 810 +{-# LANGUAGE StandaloneKindSignatures #-} +#else +{-# LANGUAGE ImpredicativeTypes #-} -- See Note [Impredicative Σ?] +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Singletons.Sigma +-- Copyright : (C) 2017 Ryan Scott +-- License : BSD-style (see LICENSE) +-- Maintainer : Ryan Scott +-- Stability : experimental +-- Portability : non-portable +-- +-- Defines 'Sigma', a dependent pair data type, and related functions. +-- +---------------------------------------------------------------------------- + +module Data.Singletons.Sigma + ( -- * The 'Sigma' type + Sigma(..), Σ + , Sing, SSigma(..), SΣ + + -- * Operations over 'Sigma' + , fstSigma, FstSigma, sndSigma, SndSigma + , projSigma1, projSigma2 + , mapSigma, zipSigma + , currySigma, uncurrySigma + +#if __GLASGOW_HASKELL__ >= 806 + -- * Internal utilities + -- $internalutilities + , ShowApply, ShowSingApply + , ShowApply', ShowSingApply' +#endif + ) where + +import Data.Kind +import Data.Singletons +#if __GLASGOW_HASKELL__ >= 806 +import Data.Singletons.ShowSing +#endif + +-- | A dependent pair. +#if __GLASGOW_HASKELL__ >= 810 +type Sigma :: forall s -> (s ~> Type) -> Type +#endif +data Sigma (s :: Type) :: (s ~> Type) -> Type where + (:&:) :: forall s t fst. Sing (fst :: s) -> t @@ fst -> Sigma s t +infixr 4 :&: + +-- | Unicode shorthand for 'Sigma'. +#if __GLASGOW_HASKELL__ >= 810 +type Σ :: forall s -> (s ~> Type) -> Type +#endif +type Σ = Sigma + +{- +Note [Impredicative Σ?] +~~~~~~~~~~~~~~~~~~~~~~~ +The following definition alone: + + type Σ = Sigma + +will not typecheck without the use of ImpredicativeTypes. There isn't a +fundamental reason that this should be the case, and the only reason that GHC +currently requires this is due to GHC#13408. Thankfully, giving Σ a standalone +kind signature works around GHC#13408, so we only have to enable +ImpredicativeTypes on pre-8.10 versions of GHC. +-} + +-- | The singleton type for 'Sigma'. +#if __GLASGOW_HASKELL__ >= 810 +type SSigma :: Sigma s t -> Type +#endif +data SSigma :: forall s t. Sigma s t -> Type where + (:%&:) :: forall s t (fst :: s) (sfst :: Sing fst) (snd :: t @@ fst). + Sing ('WrapSing sfst) -> Sing snd -> SSigma (sfst ':&: snd :: Sigma s t) +infixr 4 :%&: +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @(Sigma s t) = +#else +type instance Sing = +#endif + SSigma + +instance forall s t (fst :: s) (a :: Sing fst) (b :: t @@ fst). + (SingI fst, SingI b) + => SingI (a ':&: b :: Sigma s t) where + sing = sing :%&: sing + +-- | Unicode shorthand for 'SSigma'. +#if __GLASGOW_HASKELL__ >= 810 +type SΣ :: Sigma s t -> Type +#endif +type SΣ = SSigma + +-- | Project the first element out of a dependent pair. +fstSigma :: forall s t. SingKind s => Sigma s t -> Demote s +fstSigma (a :&: _) = fromSing a + +-- | Project the first element out of a dependent pair. +#if __GLASGOW_HASKELL__ >= 810 +type FstSigma :: Sigma s t -> s +#endif +type family FstSigma (sig :: Sigma s t) :: s where + FstSigma ((_ :: Sing fst) ':&: _) = fst + +-- | Project the second element out of a dependent pair. +sndSigma :: forall s t (sig :: Sigma s t). + SingKind (t @@ FstSigma sig) + => SSigma sig -> Demote (t @@ FstSigma sig) +sndSigma (_ :%&: b) = fromSing b + +-- | Project the second element out of a dependent pair. +#if __GLASGOW_HASKELL__ >= 810 +type SndSigma :: forall s t. forall (sig :: Sigma s t) -> t @@ FstSigma sig +#endif +type family SndSigma (sig :: Sigma s t) :: t @@ FstSigma sig where + SndSigma (_ ':&: b) = b + +-- | Project the first element out of a dependent pair using +-- continuation-passing style. +projSigma1 :: (forall (fst :: s). Sing fst -> r) -> Sigma s t -> r +projSigma1 f (a :&: _) = f a + +-- | Project the second element out of a dependent pair using +-- continuation-passing style. +projSigma2 :: forall s t r. (forall (fst :: s). t @@ fst -> r) -> Sigma s t -> r +projSigma2 f ((_ :: Sing (fst :: s)) :&: b) = f @fst b + +-- | Map across a 'Sigma' value in a dependent fashion. +mapSigma :: Sing (f :: a ~> b) -> (forall (x :: a). p @@ x -> q @@ (f @@ x)) + -> Sigma a p -> Sigma b q +mapSigma f g ((x :: Sing (fst :: a)) :&: y) = (f @@ x) :&: (g @fst y) + +-- | Zip two 'Sigma' values together in a dependent fashion. +zipSigma :: Sing (f :: a ~> b ~> c) + -> (forall (x :: a) (y :: b). p @@ x -> q @@ y -> r @@ (f @@ x @@ y)) + -> Sigma a p -> Sigma b q -> Sigma c r +zipSigma f g ((a :: Sing (fstA :: a)) :&: p) ((b :: Sing (fstB :: b)) :&: q) = + (f @@ a @@ b) :&: (g @fstA @fstB p q) + +-- | Convert an uncurried function on 'Sigma' to a curried one. +-- +-- Together, 'currySigma' and 'uncurrySigma' witness an isomorphism such that +-- the following identities hold: +-- +-- @ +-- id1 :: forall a (b :: a ~> Type) (c :: 'Sigma' a b ~> Type). +-- (forall (p :: Sigma a b). 'SSigma' p -> c @@ p) +-- -> (forall (p :: Sigma a b). 'SSigma' p -> c @@ p) +-- id1 f = 'uncurrySigma' @a @b @c ('currySigma' @a @b @c f) +-- +-- id2 :: forall a (b :: a ~> Type) (c :: 'Sigma' a b ~> Type). +-- (forall (x :: a) (sx :: Sing x) (y :: b @@ x). Sing ('WrapSing' sx) -> Sing y -> c @@ (sx :&: y)) +-- -> (forall (x :: a) (sx :: Sing x) (y :: b @@ x). Sing ('WrapSing' sx) -> Sing y -> c @@ (sx :&: y)) +-- id2 f = 'currySigma' @a @b @c ('uncurrySigma' @a @b @c f) +-- @ +currySigma :: forall a (b :: a ~> Type) (c :: Sigma a b ~> Type). + (forall (p :: Sigma a b). SSigma p -> c @@ p) + -> (forall (x :: a) (sx :: Sing x) (y :: b @@ x). + Sing ('WrapSing sx) -> Sing y -> c @@ (sx ':&: y)) +currySigma f x y = f (x :%&: y) + +-- | Convert a curried function on 'Sigma' to an uncurried one. +-- +-- Together, 'currySigma' and 'uncurrySigma' witness an isomorphism. +-- (Refer to the documentation for 'currySigma' for more details.) +uncurrySigma :: forall a (b :: a ~> Type) (c :: Sigma a b ~> Type). + (forall (x :: a) (sx :: Sing x) (y :: b @@ x). + Sing ('WrapSing sx) -> Sing y -> c @@ (sx ':&: y)) + -> (forall (p :: Sigma a b). SSigma p -> c @@ p) +uncurrySigma f (x :%&: y) = f x y + +#if __GLASGOW_HASKELL__ >= 806 +instance (ShowSing s, ShowApply t) => Show (Sigma s t) where + showsPrec p ((a :: Sing (fst :: s)) :&: b) = showParen (p >= 5) $ + showsPrec 5 a . showString " :&: " . showsPrec 5 b + :: ShowApply' t fst => ShowS + +instance forall s (t :: s ~> Type) (sig :: Sigma s t). + (ShowSing s, ShowSingApply t) + => Show (SSigma sig) where + showsPrec p ((sa :: Sing ('WrapSing (sfst :: Sing fst))) :%&: (sb :: Sing snd)) = + showParen (p >= 5) $ + showsPrec 5 sa . showString " :&: " . showsPrec 5 sb + :: ShowSingApply' t fst snd => ShowS + +------------------------------------------------------------ +-- Internal utilities +------------------------------------------------------------ + +{- $internal-utilities + +See the documentation in "Data.Singletons.ShowSing"—in particular, the +Haddocks for 'ShowSing' and `ShowSing'`—for an explanation for why these +classes exist. + +Note that these classes are only defined on GHC 8.6 or later. +-} + +#if __GLASGOW_HASKELL__ >= 810 +type ShowApply :: (a ~> Type) -> Constraint +#endif +class (forall (x :: a). ShowApply' f x) => ShowApply (f :: a ~> Type) +instance (forall (x :: a). ShowApply' f x) => ShowApply (f :: a ~> Type) + +#if __GLASGOW_HASKELL__ >= 810 +type ShowApply' :: (a ~> Type) -> a -> Constraint +#endif +class Show (Apply f x) => ShowApply' (f :: a ~> Type) (x :: a) +instance Show (Apply f x) => ShowApply' (f :: a ~> Type) (x :: a) + +#if __GLASGOW_HASKELL__ >= 810 +type ShowSingApply :: (a ~> Type) -> Constraint +#endif +class (forall (x :: a) (z :: Apply f x). ShowSingApply' f x z) => ShowSingApply (f :: a ~> Type) +instance (forall (x :: a) (z :: Apply f x). ShowSingApply' f x z) => ShowSingApply (f :: a ~> Type) + +#if __GLASGOW_HASKELL__ >= 810 +type ShowSingApply' :: forall a. forall (f :: a ~> Type) (x :: a) -> Apply f x -> Constraint +#endif +class Show (Sing z) => ShowSingApply' (f :: a ~> Type) (x :: a) (z :: Apply f x) +instance Show (Sing z) => ShowSingApply' (f :: a ~> Type) (x :: a) (z :: Apply f x) +#endif 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,583 +0,0 @@ -{- Data/Singletons/Single.hs - -(c) Richard Eisenberg 2013 -rae@cs.brynmawr.edu - -This file contains functions to refine constructs to work with singleton -types. It is an internal module to the singletons package. --} -{-# LANGUAGE TemplateHaskell, TupleSections, ParallelListComp, CPP #-} - -module Data.Singletons.Single where - -import Prelude hiding ( exp ) -import Language.Haskell.TH hiding ( cxt ) -import Language.Haskell.TH.Syntax (Quasi(..)) -import Data.Singletons.Deriving.Ord -import Data.Singletons.Deriving.Bounded -import Data.Singletons.Deriving.Enum -import Data.Singletons.Util -import Data.Singletons.Promote -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.Fixity -import Data.Singletons.Single.Eq -import Data.Singletons.Syntax -import Data.Singletons.Partition -import Language.Haskell.TH.Desugar -import qualified Data.Map.Strict as Map -import Data.Map.Strict ( Map ) -import Data.Maybe -import Control.Monad -import Data.List - -{- -How singletons works -~~~~~~~~~~~~~~~~~~~~ - -Singling, on the surface, doesn't seem all that complicated. Promote the type, -and singletonize all the terms. That's essentially what was done singletons < 1.0. -But, now we want to deal with higher-order singletons. So, things are a little -more complicated. - -The way to understand all of this is that *every* variable maps to something -of type (Sing t), for an appropriately-kinded t. This includes functions, which -use the "SLambda" instance of Sing. To apply singleton functions, we use the -applySing function. - -That, in and of itself, wouldn't be too hard, but it's really annoying from -the user standpoint. After dutifully singling `map`, a user doesn't want to -have to use two `applySing`s to actually use it. So, any let-bound identifier -is eta-expanded so that the singled type has the same number of arrows as -the original type. (If there is no original type signature, then it has as -many arrows as the original had patterns.) Then, we store a use of one of the -singFunX functions in the SgM environment so that every use of a let-bound -identifier has a proper type (Sing t). - -It would be consistent to avoid this eta-expansion for local lets (as opposed -to top-level lets), but that seemed like more bother than it was worth. It -may also be possible to be cleverer about nested eta-expansions and contractions, -but that also seemed not to be worth it. Though I haven't tested it, my hope -is that the eta-expansions and contractions have no runtime effect, especially -because SLambda is a *newtype* instance, not a *data* instance. - -Note that to maintain the desired invariant, we must also be careful to eta- -contract constructors. This is the point of buildDataLets. --} - --- | Generate singleton definitions from a type that is already defined. --- For example, the singletons package itself uses --- --- > $(genSingletons [''Bool, ''Maybe, ''Either, ''[]]) --- --- to generate singletons for Prelude types. -genSingletons :: DsMonad q => [Name] -> q [Dec] -genSingletons names = do - checkForRep names - ddecs <- concatMapM (singInfo <=< dsInfo <=< reifyWithWarning) names - return $ decsToTH ddecs - --- | Make promoted and singleton versions of all declarations given, retaining --- the original declarations. --- See for --- further explanation. -singletons :: DsMonad q => q [Dec] -> q [Dec] -singletons qdecs = do - decs <- qdecs - singDecs <- wrapDesugar singTopLevelDecs decs - return (decs ++ singDecs) - --- | Make promoted and singleton versions of all declarations given, discarding --- the original declarations. Note that a singleton based on a datatype needs --- the original datatype, so this will fail if it sees any datatype declarations. --- Classes, instances, and functions are all fine. -singletonsOnly :: DsMonad q => q [Dec] -> q [Dec] -singletonsOnly = (>>= wrapDesugar singTopLevelDecs) - --- | Create instances of 'SEq' and type-level '(:==)' for each type in the list -singEqInstances :: DsMonad q => [Name] -> q [Dec] -singEqInstances = concatMapM singEqInstance - --- | Create instance of 'SEq' and type-level '(:==)' for the given type -singEqInstance :: DsMonad q => Name -> q [Dec] -singEqInstance name = do - promotion <- promoteEqInstance name - dec <- singEqualityInstance sEqClassDesc name - return $ dec ++ promotion - --- | Create instances of 'SEq' (only -- no instance for '(:==)', which 'SEq' generally --- relies on) for each type in the list -singEqInstancesOnly :: DsMonad q => [Name] -> q [Dec] -singEqInstancesOnly = concatMapM singEqInstanceOnly - --- | Create instances of 'SEq' (only -- no instance for '(:==)', which 'SEq' generally --- relies on) for the given type -singEqInstanceOnly :: DsMonad q => Name -> q [Dec] -singEqInstanceOnly name = singEqualityInstance sEqClassDesc name - --- | Create instances of 'SDecide' for each type in the list. -singDecideInstances :: DsMonad q => [Name] -> q [Dec] -singDecideInstances = concatMapM singDecideInstance - --- | Create instance of 'SDecide' for the given type. -singDecideInstance :: DsMonad q => Name -> q [Dec] -singDecideInstance name = singEqualityInstance sDecideClassDesc name - --- generalized function for creating equality instances -singEqualityInstance :: DsMonad q => EqualityClassDesc q -> Name -> q [Dec] -singEqualityInstance desc@(_, className, _) name = do - (tvbs, cons) <- getDataD ("I cannot make an instance of " ++ - show className ++ " for it.") name - dtvbs <- mapM dsTvb tvbs - dcons <- concatMapM dsCon cons - let tyvars = map (DVarT . extractTvbName) dtvbs - kind = foldType (DConT name) tyvars - aName <- qNewName "a" - let aVar = DVarT aName - (scons, _) <- singM [] $ mapM (singCtor aVar) dcons - eqInstance <- mkEqualityInstance kind scons desc - return $ decToTH eqInstance - --- | Create instances of 'SOrd' for the given types -singOrdInstances :: DsMonad q => [Name] -> q [Dec] -singOrdInstances = concatMapM singOrdInstance - --- | Create instance of 'SOrd' for the given type -singOrdInstance :: DsMonad q => Name -> q [Dec] -singOrdInstance = singInstance mkOrdInstance "Ord" - --- | Create instances of 'SBounded' for the given types -singBoundedInstances :: DsMonad q => [Name] -> q [Dec] -singBoundedInstances = concatMapM singBoundedInstance - --- | Create instance of 'SBounded' for the given type -singBoundedInstance :: DsMonad q => Name -> q [Dec] -singBoundedInstance = singInstance mkBoundedInstance "Bounded" - --- | Create instances of 'SEnum' for the given types -singEnumInstances :: DsMonad q => [Name] -> q [Dec] -singEnumInstances = concatMapM singEnumInstance - --- | Create instance of 'SEnum' for the given type -singEnumInstance :: DsMonad q => Name -> q [Dec] -singEnumInstance = singInstance mkEnumInstance "Enum" - -singInstance :: DsMonad q - => (DType -> [DCon] -> q UInstDecl) - -> 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 - dcons <- concatMapM dsCon cons - raw_inst <- mk_inst (foldType (DConT name) (map tvbToType dtvbs)) dcons - (a_inst, decs) <- promoteM [] $ - promoteInstanceDec Map.empty raw_inst - decs' <- singDecsM [] $ (:[]) <$> singInstD a_inst - return $ decsToTH (decs ++ decs') - -singInfo :: DsMonad q => DInfo -> q [DDec] -singInfo (DTyConI dec _) = - singTopLevelDecs [] [dec] -singInfo (DPrimTyConI _name _numArgs _unlifted) = - fail "Singling of primitive type constructors not supported" -singInfo (DVarI _name _ty _mdec) = - fail "Singling of value info not supported" -singInfo (DTyVarI _name _ty) = - fail "Singling of type variable info not supported" -singInfo (DPatSynI {}) = - fail "Singling of pattern synonym info not supported" - -singTopLevelDecs :: DsMonad q => [Dec] -> [DDec] -> q [DDec] -singTopLevelDecs locals raw_decls = do - decls <- withLocalDeclarations locals $ expand raw_decls -- expand type synonyms - PDecs { pd_let_decs = letDecls - , pd_class_decs = classes - , pd_instance_decs = insts - , pd_data_decs = datas } <- partitionDecs decls - - ((letDecEnv, classes', insts'), promDecls) <- promoteM locals $ do - promoteDataDecs datas - (_, letDecEnv) <- promoteLetDecs noPrefix letDecls - classes' <- mapM promoteClassDec classes - let meth_sigs = foldMap (lde_types . cd_lde) classes - insts' <- mapM (promoteInstanceDec meth_sigs) insts - return (letDecEnv, classes', insts') - - singDecsM locals $ do - let letBinds = concatMap buildDataLets datas - ++ concatMap buildMethLets classes - (newLetDecls, newDecls) <- bindLets letBinds $ - singLetDecEnv letDecEnv $ do - newDataDecls <- concatMapM singDataD datas - newClassDecls <- mapM singClassD classes' - newInstDecls <- mapM singInstD insts' - return (newDataDecls ++ newClassDecls ++ newInstDecls) - return $ promDecls ++ (map DLetDec newLetDecls) ++ newDecls - --- see comment at top of file -buildDataLets :: DataDecl -> [(Name, DExp)] -buildDataLets (DataDecl _nd _name _tvbs cons _derivings) = - concatMap con_num_args cons - where - con_num_args :: DCon -> [(Name, DExp)] - con_num_args (DCon _tvbs _cxt name fields _rty) = - (name, wrapSingFun (length (tysOfConFields fields)) - (promoteValRhs name) (DConE $ singDataConName name)) - : rec_selectors fields - - rec_selectors :: DConFields -> [(Name, DExp)] - rec_selectors (DNormalC {}) = [] - rec_selectors (DRecC fields) = - let names = map fstOf3 fields in - [ (name, wrapSingFun 1 (promoteValRhs name) (DVarE $ singValName name)) - | name <- names ] - --- see comment at top of file -buildMethLets :: UClassDecl -> [(Name, DExp)] -buildMethLets (ClassDecl { cd_lde = LetDecEnv { lde_types = meth_sigs } }) = - map mk_bind (Map.toList meth_sigs) - where - mk_bind (meth_name, meth_ty) = - ( meth_name - , wrapSingFun (countArgs meth_ty) (promoteValRhs meth_name) - (DVarE $ singValName meth_name) ) - -singClassD :: AClassDecl -> SgM DDec -singClassD (ClassDecl { cd_cxt = cls_cxt - , cd_name = cls_name - , cd_tvbs = cls_tvbs - , cd_fds = cls_fundeps - , cd_lde = LetDecEnv { lde_defns = default_defns - , lde_types = meth_sigs - , lde_infix = fixities - , lde_proms = promoted_defaults } }) = do - (sing_sigs, _, tyvar_names, res_kis) - <- unzip4 <$> zipWithM (singTySig no_meth_defns meth_sigs) - meth_names (map promoteValRhs meth_names) - let default_sigs = catMaybes $ zipWith3 mk_default_sig meth_names sing_sigs 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) - res_ki_map)) - (Map.toList default_defns) - let fixities' = map (uncurry singInfixDecl) fixities - cls_cxt' <- mapM singPred cls_cxt - return $ DClassD cls_cxt' - (singClassName cls_name) - cls_tvbs - cls_fundeps -- they are fine without modification - (map DLetDec (sing_sigs ++ sing_meths ++ fixities') ++ default_sigs) - where - no_meth_defns = error "Internal error: can't find declared method type" - always_sig = error "Internal error: no signature for default method" - meth_names = Map.keys meth_sigs - - mk_default_sig meth_name (DSigD s_name sty) (Just res_ki) = - DDefaultSigD s_name <$> add_constraints meth_name sty res_ki - mk_default_sig _ _ _ = error "Internal error: a singled signature isn't a signature." - - add_constraints meth_name sty res_ki = do -- Maybe monad - prom_dflt <- Map.lookup meth_name promoted_defaults - let default_pred = foldl DAppPr (DConPr equalityName) - -- NB: Need the res_ki here to prevent ambiguous - -- kinds in result-inferred default methods. - -- See #175 - [ foldApply (promoteValRhs meth_name) tvs `DSigT` res_ki - , foldApply prom_dflt tvs ] - return $ DForallT tvbs (default_pred : cxt) (ravel args res) - where - (tvbs, cxt, args, res) = unravel sty - tvs = map tvbToType tvbs - - -singInstD :: AInstDecl -> SgM DDec -singInstD (InstDecl { id_cxt = cxt, id_name = inst_name - , id_arg_tys = inst_tys, id_meths = ann_meths }) = do - cxt' <- mapM singPred cxt - inst_kis <- mapM promoteType inst_tys - meths <- concatMapM (uncurry sing_meth) ann_meths - return (DInstanceD Nothing - cxt' - (foldl DAppT (DConT s_inst_name) inst_kis) - meths) - - where - s_inst_name = singClassName inst_name - - sing_meth :: Name -> ALetDecRHS -> SgM [DDec] - sing_meth name rhs = do - mb_s_info <- dsReify (singValName name) - (s_ty, tyvar_names, m_res_ki) <- case mb_s_info of - Just (DVarI _ (DForallT cls_tvbs _cls_pred s_ty) _) -> do - let (sing_tvbs, _pred, _args, res_ty) = unravel s_ty - inst_kis <- mapM promoteType inst_tys - let subst = Map.fromList (zip (map extractTvbName cls_tvbs) - inst_kis) - m_res_ki = case res_ty of - _sing `DAppT` (_prom_func `DSigT` res_ki) -> Just (substKind subst res_ki) - _ -> Nothing - - return (substType subst s_ty, map extractTvbName sing_tvbs, m_res_ki) - _ -> do - mb_info <- dsReify name - case mb_info of - Just (DVarI _ (DForallT cls_tvbs _cls_pred inner_ty) _) -> do - let subst = Map.fromList (zip (map extractTvbName cls_tvbs) - inst_tys) - -- 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, res_ki) <- singType (promoteValRhs name) - (substType subst raw_ty) - return (s_ty, tyvar_names, Just 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) - kind_map name rhs - return $ map DLetDec [DSigD (singValName name) s_ty, meth'] - -singLetDecEnv :: ALetDecEnv -> SgM a -> SgM ([DLetDec], a) -singLetDecEnv (LetDecEnv { lde_defns = defns - , lde_types = types - , lde_infix = infix_decls - , lde_proms = proms }) - thing_inside = do - let prom_list = Map.toList proms - (typeSigs, letBinds, tyvarNames, res_kis) - <- unzip4 <$> mapM (uncurry (singTySig defns types)) prom_list - let infix_decls' = map (uncurry singInfixDecl) infix_decls - 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) res_ki_map)) - (Map.toList defns) - thing <- thing_inside - return (infix_decls' ++ typeSigs ++ let_decs, thing) - -singTySig :: Map Name ALetDecRHS -- definitions - -> Map Name DType -- type signatures - -> 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 - , Maybe DKind -- the result kind in the tysig - ) -singTySig defns types name prom_ty = - let sName = singValName name in - case Map.lookup name types of - Nothing -> do - num_args <- guess_num_args - (sty, tyvar_names) <- mk_sing_ty num_args - return ( DSigD sName sty - , (name, wrapSingFun num_args prom_ty (DVarE sName)) - , (name, tyvar_names) - , Nothing ) - Just ty -> do - (sty, num_args, tyvar_names, res_ki) <- singType prom_ty ty - return ( DSigD sName sty - , (name, wrapSingFun num_args prom_ty (DVarE sName)) - , (name, tyvar_names) - , Just res_ki ) - where - guess_num_args :: SgM Int - guess_num_args = - case Map.lookup name defns of - Nothing -> fail "Internal error: promotion known for something not let-bound." - Just (AValue _ n _) -> return n - Just (AFunction _ n _) -> return n - - -- create a Sing t1 -> Sing t2 -> ... type of a given arity and result type - mk_sing_ty :: Int -> SgM (DType, [Name]) - mk_sing_ty n = do - arg_names <- replicateM n (qNewName "arg") - return ( DForallT (map DPlainTV arg_names) [] - (ravel (map (\nm -> singFamily `DAppT` DVarT nm) arg_names) - (singFamily `DAppT` - (foldl apply prom_ty (map DVarT arg_names)))) - , arg_names ) - -singLetDecRHS :: Map Name [Name] - -> Map Name DKind -- result kind (might not be known) - -> Name -> ALetDecRHS -> SgM DLetDec -singLetDecRHS _bound_names res_kis name (AValue prom num_arrows exp) = - DValD (DVarPa (singValName name)) <$> - (wrapUnSingFun num_arrows prom <$> singExp exp (Map.lookup name res_kis)) -singLetDecRHS bound_names res_kis name (AFunction prom_fun num_arrows clauses) = - let tyvar_names = case Map.lookup name bound_names of - Nothing -> [] - Just ns -> ns - res_ki = Map.lookup name res_kis - in - DFunD (singValName name) <$> - mapM (singClause prom_fun num_arrows tyvar_names res_ki) clauses - -singClause :: DType -- the promoted function - -> Int -- the number of arrows in the type. If this is more - -- than the number of patterns, we need to eta-expand - -- with unSingFun. - -> [Name] -- the names of the forall'd vars in the type sig of this - -- function. This list should have at least the length as the - -- number of patterns in the clause - -> Maybe DKind -- result kind, if known - -> ADClause -> SgM DClause -singClause prom_fun num_arrows bound_names res_ki - (ADClause var_proms pats exp) = do - - -- Fix #166: - when (num_arrows - length pats < 0) $ - fail $ "Function being promoted to " ++ (pprint (typeToTH prom_fun)) ++ - " has too many arguments." - - sPats <- mapM (singPat (Map.fromList var_proms) Parameter) 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 sBody' - --- we need to know where a pattern is to anticipate when --- GHC's brain might explode -data PatternContext = LetBinding - | CaseStatement - | Parameter - deriving Eq - -checkIfBrainWillExplode :: Monad m => PatternContext -> m () -checkIfBrainWillExplode CaseStatement = return () -checkIfBrainWillExplode Parameter = return () -checkIfBrainWillExplode _ = - fail $ "Can't use a singleton pattern outside of a case-statement or\n" ++ - "do expression: GHC's brain will explode if you try. (Do try it!)" - -singPat :: Map Name Name -- from term-level names to type-level names - -> PatternContext - -> DPat - -> SgM DPat -singPat _var_proms _patCxt (DLitPa _lit) = - fail "Singling of literal patterns not yet supported" -singPat var_proms _patCxt (DVarPa name) = do - tyname <- case Map.lookup name var_proms of - Nothing -> - fail "Internal error: unknown variable when singling pattern" - Just tyname -> return tyname - return $ DVarPa (singValName name) `DSigPa` (singFamily `DAppT` DVarT tyname) -singPat var_proms patCxt (DConPa name pats) = do - checkIfBrainWillExplode patCxt - pats' <- mapM (singPat var_proms patCxt) pats - return $ DConPa (singDataConName name) pats' -singPat var_proms patCxt (DTildePa pat) = do - qReportWarning - "Lazy pattern converted into regular pattern during singleton generation." - singPat var_proms patCxt pat -singPat var_proms patCxt (DBangPa pat) = do - pat' <- singPat var_proms patCxt pat - return $ DBangPa pat' -singPat _var_proms _patCxt (DSigPa _pat _ty) = error "TODO: Handle SigPa. See Issue #183." -singPat _var_proms _patCxt DWildPa = return DWildPa - - --- 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. - --- 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. - -singExp :: ADExp -> Maybe DKind -- the kind of the expression, if known - -> SgM DExp - -- See Note [Why error is so special] -singExp (ADVarE err `ADAppE` arg) _res_ki - | err == errorName = DAppE (DVarE (singValName err)) <$> - singExp arg (Just (DConT symbolName)) -singExp (ADVarE name) _res_ki = lookupVarE name -singExp (ADConE name) _res_ki = lookupConE name -singExp (ADLitE lit) _res_ki = singLit lit -singExp (ADAppE e1 e2) _res_ki = do - e1' <- singExp e1 Nothing - e2' <- singExp e2 Nothing - -- `applySing undefined x` kills type inference, because GHC can't figure - -- out the type of `undefined`. So we don't emit that code. - if isException e1' - then return e1' - else return $ (DVarE applySingName) `DAppE` e1' `DAppE` e2' -singExp (ADLamE ty_names prom_lam names exp) _res_ki = do - let sNames = map singValName names - exp' <- singExp exp Nothing - -- we need to bind the type variables... but DLamE doesn't allow SigT patterns. - -- So: build a case - let caseExp = DCaseE (mkTupleDExp (map DVarE sNames)) - [DMatch (mkTupleDPat - (map ((DWildPa `DSigPa`) . - (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] - DSigE <$> (DCaseE <$> singExp exp Nothing <*> mapM (singMatch res_ki) matches) - <*> pure (singFamily `DAppT` (ret_ty `maybeSigT` res_ki)) -singExp (ADLetE env exp) res_ki = - uncurry DLetE <$> singLetDecEnv env (singExp exp res_ki) -singExp (ADSigE {}) _ = - fail "Singling of explicit type annotations not yet supported." - -isException :: DExp -> Bool -isException (DVarE n) = n == undefinedName -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 <- singPat (Map.fromList var_proms) CaseStatement pat - sExp <- singExp exp res_ki - return $ DMatch sPat 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 lit = do - prom_lit <- promoteLitExp lit - return $ DVarE singMethName `DSigE` (singFamily `DAppT` prom_lit) - -maybeSigT :: DType -> Maybe DKind -> DType -maybeSigT ty Nothing = ty -maybeSigT ty (Just ki) = ty `DSigT` ki 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,170 +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.Monad -import Data.Singletons.Single.Type -import Data.Singletons.Single.Fixity -import Data.Singletons.Promote.Type -import Data.Singletons.Single.Eq -import Data.Singletons.Util -import Data.Singletons.Names -import Data.Singletons.Syntax -import Control.Monad - --- We wish to consider the promotion of "Rep" to be * --- not a promoted data constructor. -singDataD :: DataDecl -> SgM [DDec] -singDataD (DataDecl _nd name tvbs ctors derivings) = do - aName <- qNewName "z" - let a = DVarT aName - let tvbNames = map extractTvbName tvbs - k <- promoteType (foldType (DConT name) (map DVarT tvbNames)) - ctors' <- mapM (singCtor a) ctors - ctorFixities <- - -- try to reify the fixity declarations for the constructors and then - -- singletonize them. In case the reification fails, we default to an - -- empty list of singletonized fixity declarations. - -- why this works: - -- 1. if we're in a call to 'genSingletons', the data type was defined - -- earlier and its constructors are in scope, the reification succeeds. - -- 2. if we're in a call to 'singletons', the reification will fail, but - -- the fixity declaration will get singletonized by itself (not from - -- here, look for other invocations of 'singInfixDecl') - singFixityDeclarations [ n | DCon _ _ n _ _ <- ctors ] - -- instance for SingKind - fromSingClauses <- mapM mkFromSingClause ctors - toSingClauses <- mapM mkToSingClause ctors - let singKindInst = - DInstanceD Nothing - (map (singKindConstraint . DVarT) tvbNames) - (DAppT (DConT singKindClassName) k) - [ DTySynInstD demoteName $ DTySynEqn - [k] - (foldType (DConT name) - (map (DAppT demote . DVarT) tvbNames)) - , DLetDec $ DFunD fromSingName (fromSingClauses `orIfEmpty` emptyMethod aName) - , DLetDec $ DFunD toSingName (toSingClauses `orIfEmpty` emptyMethod aName) ] - - -- SEq instance - sEqInsts <- if any (\case DConPr n -> n == eqName; _ -> False) derivings - then mapM (mkEqualityInstance k ctors') [sEqClassDesc, sDecideClassDesc] - else return [] - - -- e.g. type SNat = Sing :: Nat -> * - let kindedSynInst = - DTySynD (singTyConName name) - [] - (singFamily `DSigT` (DArrowT `DAppT` k `DAppT` DStarT)) - - return $ (DDataInstD Data [] singFamilyName [DSigT a k] ctors' []) : - kindedSynInst : - singKindInst : - sEqInsts ++ - ctorFixities - where -- in the Rep case, the names of the constructors are in the wrong scope - -- (they're types, not datacons), so we have to reinterpret them. - mkConName :: Name -> SgM Name - mkConName - | nameBase name == nameBase repName = mkDataName . nameBase - | otherwise = return - - mkFromSingClause :: DCon -> SgM DClause - mkFromSingClause c = do - let (cname, numArgs) = extractNameArgs c - cname' <- mkConName cname - varNames <- replicateM numArgs (qNewName "b") - return $ DClause [DConPa (singDataConName cname) (map DVarPa varNames)] - (foldExp - (DConE cname') - (map (DAppE (DVarE fromSingName) . DVarE) varNames)) - - mkToSingClause :: DCon -> SgM DClause - mkToSingClause (DCon _tvbs _cxt cname fields _rty) = do - let types = tysOfConFields fields - varNames <- mapM (const $ qNewName "b") types - svarNames <- mapM (const $ qNewName "c") types - promoted <- mapM promoteType types - cname' <- mkConName cname - let recursiveCalls = zipWith mkRecursiveCall varNames promoted - return $ - DClause [DConPa cname' (map DVarPa varNames)] - (multiCase recursiveCalls - (map (DConPa someSingDataName . listify . DVarPa) - svarNames) - (DAppE (DConE someSingDataName) - (foldExp (DConE (singDataConName cname)) - (map DVarE svarNames)))) - - mkRecursiveCall :: Name -> DKind -> DExp - mkRecursiveCall var_name ki = - DSigE (DAppE (DVarE toSingName) (DVarE var_name)) - (DAppT (DConT someSingTypeName) ki) - - emptyMethod :: Name -> [DClause] - emptyMethod n = [DClause [DVarPa n] (DCaseE (DVarE n) emptyMatches)] - --- refine a constructor. the first parameter is the type variable that --- the singleton GADT is parameterized by -singCtor :: DType -> DCon -> SgM DCon - -- polymorphic constructors are handled just - -- like monomorphic ones -- the polymorphism in - -- the kind is automatic -singCtor a (DCon _tvbs cxt name fields _rty) - | not (null (filter (not . isEqPred) cxt)) - = fail "Singling of constrained constructors not yet supported" - | otherwise - = do - let types = tysOfConFields fields - sName = singDataConName name - sCon = DConE sName - pCon = DConT name - indexNames <- mapM (const $ qNewName "n") types - let indices = map DVarT indexNames - kinds <- mapM promoteType types - args <- zipWithM buildArgType types indices - let tvbs = zipWith DKindedTV indexNames kinds - kindedIndices = zipWith DSigT indices kinds - - -- SingI instance - emitDecs - [DInstanceD Nothing - (map (DAppPr (DConPr singIName)) indices) - (DAppT (DConT singIName) - (foldType pCon kindedIndices)) - [DLetDec $ DValD (DVarPa singMethName) - (foldExp sCon (map (const $ DVarE singMethName) types))]] - - let noBang = Bang NoSourceUnpackedness NoSourceStrictness - conFields = case fields of - DNormalC _ -> DNormalC $ map (noBang,) args - DRecC rec_fields -> - DRecC [ (singValName field_name, noBang, arg) - | (field_name, _, _) <- rec_fields - | arg <- args ] - return $ DCon tvbs - [mkEqPred a (foldType pCon indices)] - sName - conFields - Nothing - where buildArgType :: DType -> DType -> SgM DType - buildArgType ty index = do - (ty', _, _, _) <- singType index ty - return ty' - - isEqPred :: DPred -> Bool - isEqPred (DAppPr f _) = isEqPred f - isEqPred (DSigPr p _) = isEqPred p - isEqPred (DVarPr _) = False - isEqPred (DConPr n) = n == equalityName - isEqPred DWildCardPr = False 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,119 +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.Util -import Data.Singletons.Names -import Control.Monad - --- making the SEq instance and the SDecide instance are rather similar, --- so we generalize -type EqualityClassDesc q = ((DCon, DCon) -> q DClause, Name, Name) -sEqClassDesc, sDecideClassDesc :: Quasi q => EqualityClassDesc q -sEqClassDesc = (mkEqMethClause, sEqClassName, sEqMethName) -sDecideClassDesc = (mkDecideMethClause, sDecideClassName, sDecideMethName) - --- pass the *singleton* constructors, not the originals -mkEqualityInstance :: Quasi q => DKind -> [DCon] - -> EqualityClassDesc q -> q DDec -mkEqualityInstance k ctors (mkMeth, className, methName) = do - let ctorPairs = [ (c1, c2) | c1 <- ctors, c2 <- ctors ] - methClauses <- if null ctors - then mkEmptyMethClauses - else mapM mkMeth ctorPairs - return $ DInstanceD Nothing - (map (DAppPr (DConPr className)) (getKindVars k)) - (DAppT (DConT className) k) - [DLetDec $ DFunD methName methClauses] - where getKindVars :: DKind -> [DKind] - getKindVars (DVarT x) = [DVarT x] - getKindVars (DAppT f a) = concatMap getKindVars [f, a] - getKindVars (DConT {}) = [] - getKindVars DStarT = [] - getKindVars DArrowT = [] - getKindVars other = - error ("getKindVars sees an unusual kind: " ++ show other) - - mkEmptyMethClauses :: Quasi q => q [DClause] - mkEmptyMethClauses = do - a <- qNewName "a" - return [DClause [DVarPa a, DWildPa] (DCaseE (DVarE a) emptyMatches)] - -mkEqMethClause :: Quasi q => (DCon, DCon) -> q DClause -mkEqMethClause (c1, c2) - | lname == rname = do - lnames <- replicateM lNumArgs (qNewName "a") - rnames <- replicateM lNumArgs (qNewName "b") - let lpats = map DVarPa lnames - rpats = map DVarPa rnames - lvars = map DVarE lnames - rvars = map DVarE rnames - return $ DClause - [DConPa lname lpats, DConPa rname rpats] - (allExp (zipWith (\l r -> foldExp (DVarE sEqMethName) [l, r]) - lvars rvars)) - | otherwise = - return $ DClause - [DConPa lname (replicate lNumArgs DWildPa), - DConPa rname (replicate rNumArgs DWildPa)] - (DConE $ singDataConName falseName) - where allExp :: [DExp] -> DExp - allExp [] = DConE $ singDataConName trueName - allExp [one] = one - allExp (h:t) = DAppE (DAppE (DVarE $ singValName andName) h) (allExp t) - - (lname, lNumArgs) = extractNameArgs c1 - (rname, rNumArgs) = extractNameArgs c2 - -mkDecideMethClause :: Quasi q => (DCon, DCon) -> q DClause -mkDecideMethClause (c1, c2) - | lname == rname = - if lNumArgs == 0 - then return $ DClause [DConPa lname [], DConPa rname []] - (DAppE (DConE provedName) (DConE reflName)) - else do - lnames <- replicateM lNumArgs (qNewName "a") - rnames <- replicateM lNumArgs (qNewName "b") - contra <- qNewName "contra" - let lpats = map DVarPa lnames - rpats = map DVarPa rnames - lvars = map DVarE lnames - rvars = map DVarE rnames - refl <- qNewName "refl" - return $ DClause - [DConPa lname lpats, DConPa rname rpats] - (DCaseE (mkTupleDExp $ - zipWith (\l r -> foldExp (DVarE sDecideMethName) [l, r]) - lvars rvars) - ((DMatch (mkTupleDPat (replicate lNumArgs - (DConPa provedName [DConPa reflName []]))) - (DAppE (DConE provedName) (DConE reflName))) : - [DMatch (mkTupleDPat (replicate i DWildPa ++ - DConPa disprovedName [DVarPa contra] : - replicate (lNumArgs - i - 1) DWildPa)) - (DAppE (DConE disprovedName) - (DLamE [refl] $ - DCaseE (DVarE refl) - [DMatch (DConPa reflName []) $ - (DAppE (DVarE contra) - (DConE reflName))])) - | i <- [0..lNumArgs-1] ])) - - | otherwise = do - x <- qNewName "x" - return $ DClause - [DConPa lname (replicate lNumArgs DWildPa), - DConPa rname (replicate rNumArgs DWildPa)] - (DAppE (DConE disprovedName) (DLamE [x] (DCaseE (DVarE x) emptyMatches))) - - where - (lname, lNumArgs) = extractNameArgs c1 - (rname, rNumArgs) = extractNameArgs c2 diff --git a/src/Data/Singletons/Single/Fixity.hs b/src/Data/Singletons/Single/Fixity.hs deleted file mode 100644 --- a/src/Data/Singletons/Single/Fixity.hs +++ /dev/null @@ -1,30 +0,0 @@ -module Data.Singletons.Single.Fixity where - -import Prelude hiding ( exp ) -import Language.Haskell.TH hiding ( cxt ) -import Language.Haskell.TH.Syntax (Quasi(..)) -import Data.Singletons.Util -import Data.Singletons.Names -import Language.Haskell.TH.Desugar - -singInfixDecl :: Fixity -> Name -> DLetDec -singInfixDecl fixity name - | isUpcase name = - -- is it a tycon name or a datacon name?? - -- it *must* be a datacon name, because symbolic tycons - -- can't be promoted. This is terrible. - DInfixD fixity (singDataConName name) - | otherwise = DInfixD fixity (singValName name) - -singFixityDeclaration :: DsMonad q => Name -> q [DDec] -singFixityDeclaration name = do - mFixity <- qReifyFixity name - return $ case mFixity of - Nothing -> [] - Just fixity -> [DLetDec $ singInfixDecl fixity name] - -singFixityDeclarations :: DsMonad q => [Name] -> q [DDec] -singFixityDeclarations = concatMapM trySingFixityDeclaration - where - trySingFixityDeclaration name = - qRecover (return []) (singFixityDeclaration name) diff --git a/src/Data/Singletons/Single/Monad.hs b/src/Data/Singletons/Single/Monad.hs deleted file mode 100644 --- a/src/Data/Singletons/Single/Monad.hs +++ /dev/null @@ -1,155 +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, lookupVarE, lookupConE, - wrapSingFun, wrapUnSingFun, - singM, singDecsM, - emitDecs, emitDecsM - ) where - -import Prelude hiding ( exp ) -import Data.Map ( Map ) -import qualified Data.Map as Map -import Data.Singletons.Promote.Monad ( emitDecs, emitDecsM ) -import Data.Singletons.Names -import Data.Singletons.Util -import Data.Singletons -import Language.Haskell.TH.Syntax hiding ( lift ) -import Language.Haskell.TH.Desugar -import Control.Monad.Reader -import Control.Monad.Writer -import Control.Applicative -import Control.Monad.Fail - --- environment during singling -data SgEnv = - SgEnv { sg_let_binds :: Map Name DExp -- from the *original* name - , sg_local_decls :: [Dec] - } - -emptySgEnv :: SgEnv -emptySgEnv = SgEnv { sg_let_binds = Map.empty - , 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 ) - -liftSgM :: Q a -> SgM a -liftSgM = SgM . lift . lift - -instance Quasi SgM where - qNewName = liftSgM `comp1` qNewName - qReport = liftSgM `comp2` qReport - qLookupName = liftSgM `comp2` qLookupName - qReify = liftSgM `comp1` qReify - qReifyInstances = liftSgM `comp2` qReifyInstances - qLocation = liftSgM qLocation - qRunIO = liftSgM `comp1` qRunIO - qAddDependentFile = liftSgM `comp1` qAddDependentFile - qReifyRoles = liftSgM `comp1` qReifyRoles - qReifyAnnotations = liftSgM `comp1` qReifyAnnotations - qReifyModule = liftSgM `comp1` qReifyModule - qAddTopDecls = liftSgM `comp1` qAddTopDecls - qAddModFinalizer = liftSgM `comp1` qAddModFinalizer - qGetQ = liftSgM qGetQ - qPutQ = liftSgM `comp1` qPutQ - - qReifyFixity = liftSgM `comp1` qReifyFixity - qReifyConStrictness = liftSgM `comp1` qReifyConStrictness - qIsExtEnabled = liftSgM `comp1` qIsExtEnabled - qExtsEnabled = liftSgM qExtsEnabled - qAddForeignFile = liftSgM `comp2` qAddForeignFile - - qRecover (SgM handler) (SgM body) = do - env <- ask - (result, aux) <- liftSgM $ - qRecover (runWriterT $ runReaderT handler env) - (runWriterT $ runReaderT body env) - tell aux - return result - -instance DsMonad SgM where - localDeclarations = asks sg_local_decls - -bindLets :: [(Name, DExp)] -> SgM a -> SgM a -bindLets lets1 = - local (\env@(SgEnv { sg_let_binds = lets2 }) -> - env { sg_let_binds = (Map.fromList lets1) `Map.union` lets2 }) - -lookupVarE :: Name -> SgM DExp -lookupVarE = lookup_var_con singValName (DVarE . singValName) - -lookupConE :: Name -> SgM DExp -lookupConE = lookup_var_con singDataConName (DConE . singDataConName) - -lookup_var_con :: (Name -> Name) -> (Name -> DExp) -> Name -> SgM DExp -lookup_var_con mk_sing_name mk_exp name = do - letExpansions <- asks sg_let_binds - sName <- mkDataName (nameBase (mk_sing_name name)) -- we want *term* names! - case Map.lookup name letExpansions of - Nothing -> do - -- try to get it from the global context - m_dinfo <- liftM2 (<|>) (dsReify sName) (dsReify name) - -- try the unrefined name too -- it's needed to bootstrap Enum - case m_dinfo of - Just (DVarI _ ty _) -> - let num_args = countArgs ty in - return $ wrapSingFun num_args (promoteValRhs name) (mk_exp name) - _ -> return $ mk_exp name -- lambda-bound - Just exp -> return exp - -wrapSingFun :: Int -> DType -> DExp -> DExp -wrapSingFun 0 _ = id -wrapSingFun n ty = - let wrap_fun = DVarE $ case n of - 1 -> 'singFun1 - 2 -> 'singFun2 - 3 -> 'singFun3 - 4 -> 'singFun4 - 5 -> 'singFun5 - 6 -> 'singFun6 - 7 -> 'singFun7 - _ -> error "No support for functions of arity > 7." - in - (wrap_fun `DAppTypeE` ty `DAppE`) - -wrapUnSingFun :: Int -> DType -> DExp -> DExp -wrapUnSingFun 0 _ = id -wrapUnSingFun n ty = - let unwrap_fun = DVarE $ case n of - 1 -> 'unSingFun1 - 2 -> 'unSingFun2 - 3 -> 'unSingFun3 - 4 -> 'unSingFun4 - 5 -> 'unSingFun5 - 6 -> 'unSingFun6 - 7 -> 'unSingFun7 - _ -> error "No support for functions of arity > 7." - in - (unwrap_fun `DAppTypeE` ty `DAppE`) - -singM :: DsMonad q => [Dec] -> SgM a -> q (a, [DDec]) -singM locals (SgM rdr) = do - other_locals <- localDeclarations - let wr = runReaderT rdr (emptySgEnv { sg_local_decls = other_locals ++ locals }) - q = runWriterT wr - runQ q - -singDecsM :: DsMonad q => [Dec] -> SgM [DDec] -> q [DDec] -singDecsM locals thing = do - (decs1, decs2) <- singM locals thing - return $ decs1 ++ decs2 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,55 +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.Syntax -import Data.Singletons.Names -import Data.Singletons.Single.Monad -import Data.Singletons.Promote.Type -import Data.Singletons.Util -import Control.Monad - -singType :: 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 - , DKind ) -- the kind of the result type -singType prom ty = do - let (_, cxt, args, res) = unravel ty - num_args = length args - cxt' <- mapM singPred cxt - arg_names <- replicateM num_args (qNewName "t") - prom_args <- mapM promoteType args - prom_res <- promoteType res - let args' = map (\n -> singFamily `DAppT` (DVarT n)) arg_names - res' = singFamily `DAppT` (foldl apply prom (map DVarT arg_names) `DSigT` prom_res) - tau = ravel args' res' - let ty' = DForallT (zipWith DKindedTV arg_names prom_args) - cxt' tau - return (ty', num_args, arg_names, prom_res) - -singPred :: DPred -> SgM DPred -singPred = singPredRec [] - -singPredRec :: [DType] -> DPred -> SgM DPred -singPredRec ctx (DAppPr pr ty) = singPredRec (ty : ctx) pr -singPredRec _ctx (DSigPr _pr _ki) = - fail "Singling of constraints with explicit kinds not yet supported" -singPredRec _ctx (DVarPr _n) = - fail "Singling of contraint variables not yet supported" -singPredRec ctx (DConPr n) - | n == equalityName - = fail "Singling of type equality constraints not yet supported" - | otherwise = do - kis <- mapM promoteType ctx - let sName = singClassName n - return $ foldl DAppPr (DConPr sName) kis -singPredRec _ctx DWildCardPr = return DWildCardPr -- it just might work 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,20 +0,0 @@ --- Data/Singletons/Hidden.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 PolyKinds #-} - -module Data.Singletons.SuppressUnusedWarnings where - -import Data.Proxy - --- | This class (which users should never see) is to be instantiated in order --- to use an otherwise-unused data constructor, such as the "kind-inference" --- data constructor for defunctionalization symbols. -class SuppressUnusedWarnings (t :: k) where - suppressUnusedWarnings :: Proxy t -> () diff --git a/src/Data/Singletons/Syntax.hs b/src/Data/Singletons/Syntax.hs deleted file mode 100644 --- a/src/Data/Singletons/Syntax.hs +++ /dev/null @@ -1,134 +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, - StandaloneDeriving, FlexibleInstances #-} - -module Data.Singletons.Syntax where - -import Prelude hiding ( exp ) -import Data.Monoid -import Language.Haskell.TH.Syntax -import Language.Haskell.TH.Desugar -import Data.Map.Strict ( Map ) -import qualified Data.Map.Strict as Map - -type VarPromotions = [(Name, Name)] -- from term-level name to type-level name - - -- the relevant part of declarations -data DataDecl = DataDecl NewOrData Name [DTyVarBndr] [DCon] [DPred] - -data ClassDecl ann = ClassDecl { cd_cxt :: DCxt - , cd_name :: Name - , cd_tvbs :: [DTyVarBndr] - , cd_fds :: [FunDep] - , cd_lde :: LetDecEnv ann } - -data InstDecl ann = InstDecl { id_cxt :: DCxt - , id_name :: Name - , id_arg_tys :: [DType] - , id_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 and lambda 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 ADExp DType - -data ADMatch = ADMatch VarPromotions DPat ADExp -data ADClause = ADClause VarPromotions - [DPat] 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 -type instance IfAnn Annotated yes no = yes -type instance IfAnn Unannotated yes no = no - -data family LetDecRHS (ann :: AnnotationFlag) -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 :: Map Name (LetDecRHS ann) - , lde_types :: Map Name DType -- type signatures - , lde_infix :: [(Fixity, Name)] -- infix declarations - , lde_proms :: IfAnn ann (Map Name DType) () -- possibly, promotions - } -type ALetDecEnv = LetDecEnv Annotated -type ULetDecEnv = LetDecEnv Unannotated - -instance Monoid ULetDecEnv where - mempty = LetDecEnv Map.empty Map.empty [] () - mappend (LetDecEnv defns1 types1 infx1 _) (LetDecEnv defns2 types2 infx2 _) = - LetDecEnv (defns1 <> defns2) (types1 <> types2) (infx1 <> infx2) () - -valueBinding :: Name -> ULetDecRHS -> ULetDecEnv -valueBinding n v = emptyLetDecEnv { lde_defns = Map.singleton n v } - -typeBinding :: Name -> DType -> ULetDecEnv -typeBinding n t = emptyLetDecEnv { lde_types = Map.singleton n t } - -infixDecl :: Fixity -> Name -> ULetDecEnv -infixDecl f n = emptyLetDecEnv { lde_infix = [(f,n)] } - -emptyLetDecEnv :: ULetDecEnv -emptyLetDecEnv = mempty - -buildLetDecEnv :: Quasi q => [DLetDec] -> q ULetDecEnv -buildLetDecEnv = go emptyLetDecEnv - where - go acc [] = return acc - go acc (DFunD name clauses : rest) = - go (valueBinding name (UFunction clauses) <> acc) rest - go acc (DValD (DVarPa name) exp : rest) = - go (valueBinding name (UValue exp) <> acc) rest - go acc (dec@(DValD {}) : rest) = do - flattened <- flattenDValD dec - go acc (flattened ++ rest) - go acc (DSigD name ty : rest) = - go (typeBinding name ty <> acc) rest - go acc (DInfixD f n : rest) = - go (infixDecl f n <> acc) rest - go acc (DPragmaD{} : rest) = go acc rest 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,146 +0,0 @@ -{-# LANGUAGE ExplicitNamespaces, CPP #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TH --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) --- Stability : experimental --- Portability : non-portable --- --- This module contains everything you need to derive your own singletons via --- Template Haskell. --- --- TURN ON @-XScopedTypeVariables@ IN YOUR MODULE IF YOU WANT THIS TO WORK. --- ----------------------------------------------------------------------------- - -module Data.Singletons.TH ( - -- * Primary Template Haskell generation functions - singletons, singletonsOnly, genSingletons, - promote, promoteOnly, 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, - - -- ** Utility functions - cases, sCases, - - -- * Basic singleton definitions - Sing(SFalse, STrue, STuple0, STuple2, STuple3, STuple4, STuple5, STuple6, STuple7), - module Data.Singletons, - - -- * Auxiliary definitions - -- | These definitions might be mentioned in code generated by Template Haskell, - -- so they must be in scope. - - PEq(..), If, sIf, (:&&), SEq(..), - POrd(..), SOrd(..), ThenCmp, sThenCmp, Foldl, sFoldl, - Any, - SDecide(..), (:~:)(..), Void, Refuted, Decision(..), - SomeSing(..), - - Error, ErrorSym0, - TrueSym0, FalseSym0, - LTSym0, EQSym0, GTSym0, - Tuple0Sym0, - Tuple2Sym0, Tuple2Sym1, Tuple2Sym2, - Tuple3Sym0, Tuple3Sym1, Tuple3Sym2, Tuple3Sym3, - Tuple4Sym0, Tuple4Sym1, Tuple4Sym2, Tuple4Sym3, Tuple4Sym4, - Tuple5Sym0, Tuple5Sym1, Tuple5Sym2, Tuple5Sym3, Tuple5Sym4, Tuple5Sym5, - Tuple6Sym0, Tuple6Sym1, Tuple6Sym2, Tuple6Sym3, Tuple6Sym4, Tuple6Sym5, Tuple6Sym6, - Tuple7Sym0, Tuple7Sym1, Tuple7Sym2, Tuple7Sym3, Tuple7Sym4, Tuple7Sym5, Tuple7Sym6, Tuple7Sym7, - CompareSym0, ThenCmpSym0, FoldlSym0, - - SuppressUnusedWarnings(..) - - ) where - -import Data.Singletons -import Data.Singletons.Single -import Data.Singletons.Promote -import Data.Singletons.Prelude.Instances -import Data.Singletons.Prelude.Bool -import Data.Singletons.Prelude.Eq -import Data.Singletons.Prelude.Ord -import Data.Singletons.Decide -import Data.Singletons.TypeLits -import Data.Singletons.SuppressUnusedWarnings -import Data.Singletons.Names -import Language.Haskell.TH.Desugar - -import GHC.Exts -import Language.Haskell.TH -import Data.Singletons.Util -import Control.Arrow ( first ) - --- | The function 'cases' generates a case expression where each right-hand side --- is identical. This may be useful if the type-checker requires knowledge of which --- constructor is used to satisfy equality or type-class constraints, but where --- each constructor is treated the same. -cases :: DsMonad q - => Name -- ^ The head of the type of the scrutinee. (Like @''Maybe@ or @''Bool@.) - -> q Exp -- ^ The scrutinee, in a Template Haskell quote - -> q Exp -- ^ The body, in a Template Haskell quote - -> q Exp -cases tyName expq bodyq = do - dinfo <- dsReify tyName - case dinfo of - Just (DTyConI (DDataD _ _ _ _ ctors _) _) -> - expToTH <$> buildCases (map extractNameArgs ctors) expq bodyq - Just _ -> - fail $ "Using <> with something other than a type constructor: " - ++ (show tyName) - _ -> fail $ "Cannot find " ++ show tyName - --- | The function 'sCases' generates a case expression where each right-hand side --- is identical. This may be useful if the type-checker requires knowledge of which --- constructor is used to satisfy equality or type-class constraints, but where --- each constructor is treated the same. For 'sCases', unlike 'cases', the --- scrutinee is a singleton. But make sure to pass in the name of the /original/ --- datatype, preferring @''Maybe@ over @''SMaybe@. -sCases :: DsMonad q - => Name -- ^ The head of the type the scrutinee's type is based on. - -- (Like @''Maybe@ or @''Bool@.) - -> q Exp -- ^ The scrutinee, in a Template Haskell quote - -> q Exp -- ^ The body, in a Template Haskell quote - -> q Exp -sCases tyName expq bodyq = do - dinfo <- dsReify tyName - case dinfo of - Just (DTyConI (DDataD _ _ _ _ ctors _) _) -> - let ctor_stuff = map (first singDataConName . extractNameArgs) ctors in - expToTH <$> buildCases ctor_stuff expq bodyq - Just _ -> - fail $ "Using <> with something other than a type constructor: " - ++ (show tyName) - _ -> fail $ "Cannot find " ++ show tyName - -buildCases :: DsMonad m - => [(Name, Int)] - -> m Exp -- scrutinee - -> m Exp -- body - -> m DExp -buildCases ctor_infos expq bodyq = - DCaseE <$> (dsExp =<< expq) <*> - mapM (\con -> DMatch (conToPat con) <$> (dsExp =<< bodyq)) ctor_infos - where - conToPat :: (Name, Int) -> DPat - conToPat (name, num_fields) = - DConPa name (replicate num_fields DWildPa) 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,70 +0,0 @@ -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TypeInType, ConstraintKinds, - GADTs, TypeFamilies #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TypeLits --- Copyright : (C) 2014 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines and exports singletons useful for the Nat and Symbol kinds. --- ----------------------------------------------------------------------------- - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Data.Singletons.TypeLits ( - Nat, Symbol, - Sing(SNat, SSym), - SNat, SSymbol, withKnownNat, withKnownSymbol, - Error, ErrorSym0, ErrorSym1, sError, - KnownNat, KnownNatSym0, KnownNatSym1, natVal, - KnownSymbol, KnownSymbolSym0, KnownSymbolSym1, symbolVal, - - (:^), (:^$), (:^$$), (:^$$$) - ) where - -import Data.Singletons.TypeLits.Internal -import Data.Singletons.Prelude.Num () -- for typelits instances - -import Data.Singletons.Promote - --- | 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 - --- | 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 - - -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]) 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,183 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TypeLits.Internal --- Copyright : (C) 2014 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) --- 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, - TypeInType, TemplateHaskell, StandaloneDeriving #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Data.Singletons.TypeLits.Internal ( - Sing(..), - - Nat, Symbol, - SNat, SSymbol, withKnownNat, withKnownSymbol, - Error, ErrorSym0, ErrorSym1, sError, - KnownNat, natVal, KnownSymbol, symbolVal, - - (:^), (:^$), (:^$$), (:^$$$) - ) where - -import Data.Singletons.Promote -import Data.Singletons -import Data.Singletons.Prelude.Eq -import Data.Singletons.Prelude.Ord -import Data.Singletons.Decide -import Data.Singletons.Prelude.Bool -import GHC.TypeLits as TL -import Data.Type.Equality -import Data.Proxy ( Proxy(..) ) -import Unsafe.Coerce - -import qualified Data.Text as T -import Data.Text ( Text ) - ----------------------------------------------------------------------- ----- TypeLits singletons --------------------------------------------- ----------------------------------------------------------------------- - -data instance Sing (n :: Nat) = KnownNat n => SNat - -instance KnownNat n => SingI n where - sing = SNat - -instance SingKind Nat where - type Demote Nat = Integer - fromSing (SNat :: Sing n) = natVal (Proxy :: Proxy n) - toSing n = case someNatVal n of - Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNat :: Sing n) - Nothing -> error "Negative singleton nat" - -data instance Sing (n :: Symbol) = KnownSymbol n => SSym - -instance KnownSymbol n => SingI n where - sing = SSym - -instance SingKind 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) - | natVal (Proxy :: Proxy n) == natVal (Proxy :: Proxy m) - = Proved $ unsafeCoerce Refl - | otherwise - = Disproved (\_ -> error errStr) - where errStr = "Broken Nat singletons" - -instance SDecide Symbol where - (SSym :: Sing n) %~ (SSym :: Sing m) - | symbolVal (Proxy :: Proxy n) == symbolVal (Proxy :: Proxy m) - = Proved $ unsafeCoerce Refl - | otherwise - = Disproved (\_ -> error errStr) - where errStr = "Broken Symbol singletons" - --- PEq instances -instance PEq Nat where - type (a :: Nat) :== (b :: Nat) = a == b -instance PEq Symbol where - type (a :: Symbol) :== (b :: Symbol) = a == b - --- need SEq instances for TypeLits kinds -instance SEq Nat where - a %:== b - | fromSing a == fromSing b = unsafeCoerce STrue - | otherwise = unsafeCoerce SFalse - -instance SEq Symbol where - a %:== b - | fromSing a == fromSing b = unsafeCoerce STrue - | otherwise = unsafeCoerce SFalse - --- POrd instances -instance POrd Nat where - type (a :: Nat) `Compare` (b :: Nat) = a `TL.CmpNat` b - -instance POrd Symbol where - type (a :: Symbol) `Compare` (b :: Symbol) = a `TL.CmpSymbol` b - --- | Kind-restricted synonym for 'Sing' for @Nat@s -type SNat (x :: Nat) = Sing x - --- | Kind-restricted synonym for 'Sing' for @Symbol@s -type SSymbol (x :: Symbol) = Sing x - --- SOrd instances -instance SOrd Nat where - a `sCompare` b = case fromSing a `compare` fromSing b of - LT -> unsafeCoerce SLT - EQ -> unsafeCoerce SEQ - GT -> unsafeCoerce SGT - -instance SOrd Symbol where - a `sCompare` b = case fromSing a `compare` fromSing b of - LT -> unsafeCoerce SLT - EQ -> unsafeCoerce SEQ - GT -> unsafeCoerce SGT - --- Convenience functions - --- | Given a singleton for @Nat@, call something requiring a --- @KnownNat@ instance. -withKnownNat :: Sing n -> (KnownNat n => r) -> r -withKnownNat SNat f = f - --- | Given a singleton for @Symbol@, call something requiring --- a @KnownSymbol@ instance. -withKnownSymbol :: Sing n -> (KnownSymbol n => r) -> r -withKnownSymbol SSym f = f - --- | The promotion of 'error'. This version is more poly-kinded for --- easier use. -type family Error (str :: k0) :: k -$(genDefunSymbols [''Error]) - --- | The singleton for 'error' -sError :: Sing (str :: Symbol) -> a -sError sstr = error (T.unpack (fromSing sstr)) - --- TODO: move this to a better home: -type a :^ b = a ^ b -infixr 8 :^ -$(genDefunSymbols [''(:^)]) - ------------------------------------------------------------- --- TypeLits singleton non-singleton instances ------------------------------------------------------------- - --- Thanks to @cumber on #179 - -instance Show (SNat n) where - showsPrec p n@SNat - = showParen (p > atPrec) - ( showString "SNat @" - . showsPrec (atPrec + 1) (natVal n) - ) - where atPrec = 10 - -instance Show (SSymbol s) where - showsPrec p s@SSym - = showParen (p > atPrec) - ( showString "SSym @" - . showsPrec (atPrec + 1) (symbolVal s) - ) - where atPrec = 10 - -deriving instance Show (SomeSing Nat) -deriving instance Show (SomeSing Symbol) diff --git a/src/Data/Singletons/TypeRepStar.hs b/src/Data/Singletons/TypeRepStar.hs deleted file mode 100644 --- a/src/Data/Singletons/TypeRepStar.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE RankNTypes, TypeFamilies, KindSignatures, FlexibleInstances, - GADTs, UndecidableInstances, ScopedTypeVariables, DataKinds, - MagicHash, TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TypeRepStar --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) --- Stability : experimental --- Portability : non-portable --- --- This module defines singleton instances making 'Typeable' the singleton for --- the kind @*@. The definitions don't fully line up with what is expected --- within the singletons library, so expect unusual results! --- ----------------------------------------------------------------------------- - -module Data.Singletons.TypeRepStar ( - Sing(STypeRep) - -- | Here is the definition of the singleton for @*@: - -- - -- > data instance Sing (a :: *) where - -- > STypeRep :: Typeable a => Sing a - -- - -- Instances for 'SingI', 'SingKind', 'SEq', 'SDecide', and 'TestCoercion' are - -- also supplied. - ) where - -import Data.Singletons.Prelude.Instances -import Data.Singletons -import Data.Singletons.Prelude.Eq -import Data.Typeable -import Unsafe.Coerce -import Data.Singletons.Decide - -import Data.Kind -import GHC.Exts ( Proxy# ) -import Data.Type.Coercion -import Data.Type.Equality - -data instance Sing (a :: *) where - STypeRep :: Typeable a => Sing a - -instance Typeable a => SingI (a :: *) where - sing = STypeRep -instance SingKind Type where - type Demote Type = TypeRep - fromSing (STypeRep :: Sing a) = typeOf (undefined :: a) - toSing = dirty_mk_STypeRep - -instance PEq Type where - type (a :: *) :== (b :: *) = a == b - -instance SEq Type where - (STypeRep :: Sing a) %:== (STypeRep :: Sing b) = - case (eqT :: Maybe (a :~: b)) of - Just Refl -> STrue - Nothing -> unsafeCoerce SFalse - -- the Data.Typeable interface isn't strong enough - -- to enable us to define this without unsafeCoerce - -instance SDecide Type where - (STypeRep :: Sing a) %~ (STypeRep :: Sing b) = - case (eqT :: Maybe (a :~: b)) of - Just Refl -> Proved Refl - Nothing -> Disproved (\Refl -> error "Data.Typeable.eqT failed") - --- TestEquality instance already defined, but we need this one: -instance TestCoercion Sing where - testCoercion (STypeRep :: Sing a) (STypeRep :: Sing b) = - case (eqT :: Maybe (a :~: b)) of - Just Refl -> Just Coercion - Nothing -> Nothing - --- everything below here is private and dirty. Don't look! - -newtype DI = Don'tInstantiate (forall a. Typeable a => Sing a) -dirty_mk_STypeRep :: TypeRep -> SomeSing * -dirty_mk_STypeRep rep = - let justLikeTypeable :: Proxy# a -> TypeRep - justLikeTypeable _ = rep - in - unsafeCoerce (Don'tInstantiate STypeRep) justLikeTypeable 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,479 +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, StandaloneDeriving, - UndecidableInstances, MagicHash, UnboxedTuples, - LambdaCase, NoMonomorphismRestriction #-} - -module Data.Singletons.Util where - -import Prelude hiding ( exp, foldl, concat, mapM, any, pred ) -import Language.Haskell.TH.Syntax hiding ( lift ) -import Language.Haskell.TH.Desugar -import Data.Char -import Control.Monad hiding ( mapM ) -import Control.Monad.Writer hiding ( mapM ) -import Control.Monad.Reader hiding ( mapM ) -import qualified Data.Map as Map -import Data.List.NonEmpty (NonEmpty) -import Data.Map ( Map ) -import Data.Foldable -import Data.Traversable -import Data.Generics -import Control.Monad.Fail ( MonadFail ) - --- The list of types that singletons processes by default -basicTypes :: [Name] -basicTypes = [ ''Maybe - , ''[] - , ''Either - , ''NonEmpty - ] ++ boundedBasicTypes - -boundedBasicTypes :: [Name] -boundedBasicTypes = - [ ''(,) - , ''(,,) - , ''(,,,) - , ''(,,,,) - , ''(,,,,,) - , ''(,,,,,,) - ] ++ enumBasicTypes - -enumBasicTypes :: [Name] -enumBasicTypes = [ ''Bool, ''Ordering, ''() ] - --- 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 Int -qNewUnique = do - Name _ flav <- qNewName "x" - case flav of - NameU n -> return n - _ -> error "Internal error: `qNewName` didn't return a NameU" - -checkForRep :: Quasi q => [Name] -> q () -checkForRep names = - when (any ((== "Rep") . nameBase) names) - (fail $ "A data type named <> is a special case.\n" ++ - "Promoting it will not work as expected.\n" ++ - "Please choose another name for your data type.") - -checkForRepInDecls :: Quasi q => [DDec] -> q () -checkForRepInDecls decls = - checkForRep (allNamesIn decls) - -tysOfConFields :: DConFields -> [DType] -tysOfConFields (DNormalC stys) = map snd stys -tysOfConFields (DRecC vstys) = map (\(_,_,ty) -> ty) vstys - --- extract the name and number of arguments to a constructor -extractNameArgs :: DCon -> (Name, Int) -extractNameArgs = liftSnd length . extractNameTypes - --- extract the name and types of constructor arguments -extractNameTypes :: DCon -> (Name, [DType]) -extractNameTypes (DCon _ _ n fields _) = (n, tysOfConFields fields) - -extractName :: DCon -> Name -extractName (DCon _ _ n _ _) = n - --- is an identifier uppercase? -isUpcase :: Name -> Bool -isUpcase n = let first = head (nameBase n) in isUpper first || first == ':' - --- make an identifier uppercase -upcase :: Name -> Name -upcase = 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 - | first == ':' - || first == '$' -- special case to avoid name clashes. See #29 - = symb ++ str - | otherwise - = symb ++ ':' : str - --- Ensures that the name is a suitable name for a data constructor -toDataConName :: Name -> Name -toDataConName n - | isUpcase n = n - | str@('$' : _) <- nameBase n = mkName (':' : str) - | otherwise = upcase n - - -noPrefix :: (String, String) -noPrefix = ("", "") - --- make an identifier lowercase -locase :: Name -> Name -locase n = - let str = nameBase n - first = head str in - if isHsLetter first - then mkName ((toLower first) : tail str) - else mkName (tail str) -- remove the ":" - --- put an uppercase prefix on a name. Takes two prefixes: one for identifiers --- and one for symbols -prefixUCName :: String -> String -> Name -> Name -prefixUCName pre tyPre n = case (nameBase n) of - (':' : rest) -> mkName (tyPre ++ rest) - alpha -> mkName (pre ++ alpha) - --- put a lowercase prefix on a name. Takes two prefixes: one for identifiers --- and one for symbols -prefixLCName :: String -> String -> Name -> Name -prefixLCName pre tyPre n = - let str = nameBase n - first = head str in - if isHsLetter first - then mkName (pre ++ str) - else mkName (tyPre ++ str) - -suffixName :: String -> String -> Name -> Name -suffixName ident symb n = - let str = nameBase n - first = head str in - if isHsLetter first - then mkName (str ++ ident) - else mkName (str ++ symb) - --- convert a number into both alphanumeric and symoblic forms -uniquePrefixes :: String -- alphanumeric prefix - -> String -- symbolic prefix - -> Int - -> (String, String) -- (alphanum, symbolic) -uniquePrefixes alpha symb n = (alpha ++ n_str, symb ++ convert n_str) - where - n_str = show n - - convert [] = [] - convert (d : ds) = - let d' = case d of - '0' -> '!' - '1' -> '#' - '2' -> '$' - '3' -> '%' - '4' -> '&' - '5' -> '*' - '6' -> '+' - '7' -> '.' - '8' -> '/' - '9' -> '>' - _ -> error "non-digit in show #" - in d' : convert ds - --- extract the kind from a TyVarBndr -extractTvbKind :: DTyVarBndr -> Maybe DKind -extractTvbKind (DPlainTV _) = Nothing -extractTvbKind (DKindedTV _ k) = Just k - --- extract the name from a TyVarBndr. -extractTvbName :: DTyVarBndr -> Name -extractTvbName (DPlainTV n) = n -extractTvbName (DKindedTV n _) = n - -tvbToType :: DTyVarBndr -> DType -tvbToType = DVarT . extractTvbName - -inferMaybeKindTV :: Name -> Maybe DKind -> DTyVarBndr -inferMaybeKindTV n Nothing = DPlainTV n -inferMaybeKindTV n (Just k) = DKindedTV n k - -resultSigToMaybeKind :: DFamilyResultSig -> Maybe DKind -resultSigToMaybeKind DNoSig = Nothing -resultSigToMaybeKind (DKindSig k) = Just k -resultSigToMaybeKind (DTyVarSig (DPlainTV _)) = Nothing -resultSigToMaybeKind (DTyVarSig (DKindedTV _ k)) = Just k - --- Get argument types from an arrow type. Removing ForallT is an --- important preprocessing step required by promoteType. -unravel :: DType -> ([DTyVarBndr], [DPred], [DType], DType) -unravel (DForallT tvbs cxt ty) = - let (tvbs', cxt', tys, res) = unravel ty in - (tvbs ++ tvbs', cxt ++ cxt', tys, res) -unravel (DAppT (DAppT DArrowT t1) t2) = - let (tvbs, cxt, tys, res) = unravel t2 in - (tvbs, cxt, t1 : tys, res) -unravel t = ([], [], [], t) - --- Reconstruct arrow kind from the list of kinds -ravel :: [DType] -> DType -> DType -ravel [] res = res -ravel (h:t) res = DAppT (DAppT DArrowT h) (ravel t res) - --- count the number of arguments in a type -countArgs :: DType -> Int -countArgs ty = length args - where (_, _, args, _) = unravel ty - --- changes all TyVars not to be NameU's. Workaround for GHC#11812 -noExactTyVars :: Data a => a -> a -noExactTyVars = everywhere go - where - go :: Data a => a -> a - go = mkT fix_tvb `extT` fix_ty `extT` fix_inj_ann - - no_exact_name :: Name -> Name - no_exact_name (Name (OccName occ) (NameU unique)) = mkName (occ ++ show unique) - no_exact_name n = n - - fix_tvb (DPlainTV n) = DPlainTV (no_exact_name n) - fix_tvb (DKindedTV n k) = DKindedTV (no_exact_name n) k - - fix_ty (DVarT n) = DVarT (no_exact_name n) - fix_ty ty = ty - - fix_inj_ann (InjectivityAnn lhs rhs) - = InjectivityAnn (no_exact_name lhs) (map no_exact_name rhs) - -substKind :: Map Name DKind -> DKind -> DKind -substKind = substType - -substType :: Map Name DType -> DType -> DType -substType subst ty | Map.null subst = ty -substType subst (DForallT tvbs cxt inner_ty) - = DForallT tvbs' cxt' inner_ty' - where - (subst', tvbs') = mapAccumL subst_tvb subst tvbs - cxt' = map (substPred subst') cxt - inner_ty' = substType subst' inner_ty - - 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)) - -substType subst (DAppT ty1 ty2) = substType subst ty1 `DAppT` substType subst ty2 -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 -substType _ ty@DStarT = ty - -substPred :: Map Name DType -> DPred -> DPred -substPred subst pred | Map.null subst = pred -substPred subst (DAppPr pred ty) = - DAppPr (substPred subst pred) (substType subst ty) -substPred subst (DSigPr pred ki) = DSigPr (substPred subst pred) ki -substPred _ pred@(DVarPr {}) = pred -substPred _ pred@(DConPr {}) = pred -substPred _ pred@DWildCardPr = pred - -substKindInPred :: Map Name DKind -> DPred -> DPred -substKindInPred subst pred | Map.null subst = pred -substKindInPred subst (DAppPr pred ty) = - DAppPr (substKindInPred subst pred) (substType subst ty) -substKindInPred subst (DSigPr pred ki) = DSigPr (substKindInPred subst pred) - (substKind subst ki) -substKindInPred _ pred@(DVarPr {}) = pred -substKindInPred _ pred@(DConPr {}) = pred -substKindInPred _ pred@DWildCardPr = pred - -substKindInTvb :: Map Name DKind -> DTyVarBndr -> DTyVarBndr -substKindInTvb _ tvb@(DPlainTV _) = tvb -substKindInTvb subst (DKindedTV n ki) = DKindedTV n (substKind subst ki) - -addStar :: DKind -> DKind -addStar t = DAppT (DAppT DArrowT t) DStarT - -addStar_maybe :: Maybe DKind -> Maybe DKind -addStar_maybe = fmap addStar - --- apply a type to a list of types -foldType :: DType -> [DType] -> DType -foldType = foldl DAppT - --- 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 - -emptyMatches :: [DMatch] -emptyMatches = [DMatch DWildPa (DAppE (DVarE 'error) (DLitE (StringL errStr)))] - where errStr = "Empty case reached -- this should be impossible" - --- build a pattern match over several expressions, each with only one pattern -multiCase :: [DExp] -> [DPat] -> DExp -> DExp -multiCase [] [] body = body -multiCase scruts pats body = - DCaseE (mkTupleDExp scruts) [DMatch (mkTupleDPat pats) body] - --- Make a desugar function into a TH function. -wrapDesugar :: (Desugar th ds, DsMonad q) => (th -> ds -> q ds) -> th -> q th -wrapDesugar f th = do - ds <- desugar th - fmap sweeten $ f th ds - --- a monad transformer for writing a monoid alongside returning a Q -newtype QWithAux m q a = QWA { runQWA :: WriterT m q a } - deriving ( Functor, Applicative, Monad, MonadTrans - , MonadWriter m, MonadReader r - , MonadFail ) - --- make a Quasi instance for easy lifting -instance (Quasi q, Monoid m) => Quasi (QWithAux m q) where - qNewName = lift `comp1` qNewName - qReport = lift `comp2` qReport - qLookupName = lift `comp2` qLookupName - qReify = lift `comp1` qReify - qReifyInstances = lift `comp2` qReifyInstances - qLocation = lift qLocation - qRunIO = lift `comp1` qRunIO - qAddDependentFile = lift `comp1` qAddDependentFile - qReifyRoles = lift `comp1` qReifyRoles - qReifyAnnotations = lift `comp1` qReifyAnnotations - qReifyModule = lift `comp1` qReifyModule - qAddTopDecls = lift `comp1` qAddTopDecls - qAddModFinalizer = lift `comp1` qAddModFinalizer - qGetQ = lift qGetQ - qPutQ = lift `comp1` qPutQ - - qReifyFixity = lift `comp1` qReifyFixity - qReifyConStrictness = lift `comp1` qReifyConStrictness - qIsExtEnabled = lift `comp1` qIsExtEnabled - qExtsEnabled = lift qExtsEnabled - qAddForeignFile = lift `comp2` qAddForeignFile - - qRecover exp handler = do - (result, aux) <- lift $ qRecover (evalForPair exp) (evalForPair handler) - tell aux - return result - -instance (DsMonad q, Monoid m) => DsMonad (QWithAux m q) where - localDeclarations = lift localDeclarations - --- helper functions for composition -comp1 :: (b -> c) -> (a -> b) -> a -> c -comp1 = (.) - -comp2 :: (c -> d) -> (a -> b -> c) -> a -> b -> d -comp2 f g a b = f (g a b) - --- run a computation with an auxiliary monoid, discarding the monoid result -evalWithoutAux :: Quasi q => QWithAux m q a -> q a -evalWithoutAux = liftM fst . runWriterT . runQWA - --- run a computation with an auxiliary monoid, returning only the monoid result -evalForAux :: Quasi q => QWithAux m q a -> q m -evalForAux = execWriterT . runQWA - --- run a computation with an auxiliary monoid, return both the result --- of the computation and the monoid result -evalForPair :: QWithAux m q a -> q (a, m) -evalForPair = runWriterT . runQWA - --- in a computation with an auxiliary map, add a binding to the map -addBinding :: (Quasi q, Ord k) => k -> v -> QWithAux (Map.Map k v) q () -addBinding k v = tell (Map.singleton k v) - --- in a computation with an auxiliar list, add an element to the list -addElement :: Quasi q => elt -> QWithAux [elt] q () -addElement elt = tell [elt] - --- lift concatMap into a monad --- could this be more efficient? -concatMapM :: (Monad monad, Monoid monoid, Traversable t) - => (a -> monad monoid) -> t a -> monad monoid -concatMapM fn list = do - bss <- mapM fn list - return $ fold bss - --- make a one-element list -listify :: a -> [a] -listify = (:[]) - -fstOf3 :: (a,b,c) -> a -fstOf3 (a,_,_) = a - -liftFst :: (a -> b) -> (a, c) -> (b, c) -liftFst f (a, c) = (f a, c) - -liftSnd :: (a -> b) -> (c, a) -> (c, b) -liftSnd f (c, a) = (c, f a) - -snocView :: [a] -> ([a], a) -snocView [] = error "snocView nil" -snocView [x] = ([], x) -snocView (x : xs) = liftFst (x:) (snocView xs) - -partitionWith :: (a -> Either b c) -> [a] -> ([b], [c]) -partitionWith f = go [] [] - where go bs cs [] = (reverse bs, reverse cs) - go bs cs (a:as) = - case f a of - Left b -> go (b:bs) cs as - Right c -> go bs (c:cs) as - -partitionWithM :: Monad m => (a -> m (Either b c)) -> [a] -> m ([b], [c]) -partitionWithM f = go [] [] - where go bs cs [] = return (reverse bs, reverse cs) - go bs cs (a:as) = do - fa <- f a - case fa of - Left b -> go (b:bs) cs as - Right c -> go bs (c:cs) as - -partitionLetDecs :: [DDec] -> ([DLetDec], [DDec]) -partitionLetDecs = partitionWith (\case DLetDec ld -> Left ld - dec -> Right dec) - -{-# INLINEABLE zipWith3M #-} -zipWith3M :: Monad m => (a -> b -> m c) -> [a] -> [b] -> m [c] -zipWith3M f (a:as) (b:bs) = (:) <$> f a b <*> zipWith3M f as bs -zipWith3M _ _ _ = return [] - -mapAndUnzip3M :: Monad m => (a -> m (b,c,d)) -> [a] -> m ([b],[c],[d]) -mapAndUnzip3M _ [] = return ([],[],[]) -mapAndUnzip3M f (x:xs) = do - (r1, r2, r3) <- f x - (rs1, rs2, rs3) <- mapAndUnzip3M f xs - return (r1:rs1, r2:rs2, r3:rs3) - --- is it a letter or underscore? -isHsLetter :: Char -> Bool -isHsLetter c = isLetter c || c == '_' diff --git a/tests/ByHand.hs b/tests/ByHand.hs new file mode 100644 --- /dev/null +++ b/tests/ByHand.hs @@ -0,0 +1,1088 @@ +{- ByHand.hs + +(c) Richard Eisenberg 2012 +rae@cs.brynmawr.edu + +Shows the derivations for the singleton definitions done by hand. +This file is a great way to understand the singleton encoding better. + +-} + +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors -Wno-orphans #-} + +{-# LANGUAGE PolyKinds, DataKinds, TypeFamilies, KindSignatures, GADTs, + FlexibleInstances, FlexibleContexts, UndecidableInstances, + RankNTypes, TypeOperators, MultiParamTypeClasses, + FunctionalDependencies, ScopedTypeVariables, + LambdaCase, EmptyCase, + TypeApplications, EmptyCase, CPP #-} + +#if __GLASGOW_HASKELL__ < 806 +{-# LANGUAGE TypeInType #-} +#endif + +#if __GLASGOW_HASKELL__ >= 810 +{-# LANGUAGE StandaloneKindSignatures #-} +#endif +module ByHand where + +import Data.Kind +import Data.Type.Equality hiding (type (==), apply) +import Data.Proxy +import Data.Singletons +import Data.Singletons.Decide +import Prelude hiding ((+), (-), map, zipWith) +import Unsafe.Coerce + +----------------------------------- +-- Original ADTs ------------------ +----------------------------------- + +#if __GLASGOW_HASKELL__ >= 810 +type Nat :: Type +#endif +data Nat where + Zero :: Nat + Succ :: Nat -> Nat + deriving Eq + +-- Defined using names to avoid fighting with concrete syntax +#if __GLASGOW_HASKELL__ >= 810 +type List :: Type -> Type +#endif +data List :: Type -> Type where + Nil :: List a + Cons :: a -> List a -> List a + deriving Eq + +----------------------------------- +-- One-time definitions ----------- +----------------------------------- + +-- Promoted equality type class +#if __GLASGOW_HASKELL__ >= 810 +type PEq :: Type -> Constraint +#endif +class PEq k where + type (==) (a :: k) (b :: k) :: Bool + -- omitting definition of /= + +-- Singleton type equality type class +#if __GLASGOW_HASKELL__ >= 810 +type SEq :: Type -> Constraint +#endif +class SEq k where + (%==) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Sing (a == b) + -- omitting definition of %/= + +#if __GLASGOW_HASKELL__ >= 810 +type If :: Bool -> a -> a -> a +#endif +type family If (cond :: Bool) (tru :: a) (fls :: a) :: a where + If True tru fls = tru + If False tru fls = fls + +sIf :: Sing a -> Sing b -> Sing c -> Sing (If a b c) +sIf STrue b _ = b +sIf SFalse _ c = c + +----------------------------------- +-- Auto-generated code ------------ +----------------------------------- + +-- Nat + +#if __GLASGOW_HASKELL__ >= 810 +type SNat :: Nat -> Type +#endif +data SNat :: Nat -> Type where + SZero :: SNat Zero + SSucc :: SNat n -> SNat (Succ n) +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @Nat = +#else +type instance Sing = +#endif + SNat + +#if _ +_GLASGOW_HASKELL__ >= 810 +type SuccSym0 :: Nat ~> Nat +#endif +data SuccSym0 :: Nat ~> Nat +type instance Apply SuccSym0 x = Succ x + +#if __GLASGOW_HASKELL__ >= 810 +type EqualsNat :: Nat -> Nat -> Bool +#endif +type family EqualsNat (a :: Nat) (b :: Nat) :: Bool where + EqualsNat Zero Zero = True + EqualsNat (Succ a) (Succ b) = a == b + EqualsNat (n1 :: Nat) (n2 :: Nat) = False +instance PEq Nat where + type a == b = EqualsNat a b + +instance SEq Nat where + SZero %== SZero = STrue + SZero %== (SSucc _) = SFalse + (SSucc _) %== SZero = SFalse + (SSucc n) %== (SSucc n') = n %== n' + +instance SDecide Nat where + SZero %~ SZero = Proved Refl + (SSucc m) %~ (SSucc n) = + case m %~ n of + Proved Refl -> Proved Refl + Disproved contra -> Disproved (\Refl -> contra Refl) + SZero %~ (SSucc _) = Disproved (\case) + (SSucc _) %~ SZero = Disproved (\case) + +instance SingI Zero where + sing = SZero +instance SingI n => SingI (Succ n) where + sing = SSucc sing +instance SingI1 Succ where + liftSing = SSucc +instance SingKind Nat where + type Demote Nat = Nat + fromSing SZero = Zero + fromSing (SSucc n) = Succ (fromSing n) + toSing Zero = SomeSing SZero + toSing (Succ n) = withSomeSing n (\n' -> SomeSing $ SSucc n') + +-- Bool + +#if __GLASGOW_HASKELL__ >= 810 +type SBool :: Bool -> Type +#endif +data SBool :: Bool -> Type where + SFalse :: SBool False + STrue :: SBool True +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @Bool = +#else +type instance Sing = +#endif + SBool + +{- +(&&) :: Bool -> Bool -> Bool +False && _ = False +True && x = x +-} + +#if __GLASGOW_HASKELL__ >= 810 +type (&&) :: Bool -> Bool -> Bool +#endif +type family (a :: Bool) && (b :: Bool) :: Bool where + False && _ = False + True && x = x + +(%&&) :: forall (a :: Bool) (b :: Bool). Sing a -> Sing b -> Sing (a && b) +SFalse %&& SFalse = SFalse +SFalse %&& STrue = SFalse +STrue %&& SFalse = SFalse +STrue %&& STrue = STrue + +instance SingI False where + sing = SFalse +instance SingI True where + sing = STrue +instance SingKind Bool where + type Demote Bool = Bool + fromSing SFalse = False + fromSing STrue = True + toSing False = SomeSing SFalse + toSing True = SomeSing STrue + +-- Maybe + +#if __GLASGOW_HASKELL__ >= 810 +type SMaybe :: forall k. Maybe k -> Type +#endif +data SMaybe :: forall k. Maybe k -> Type where + SNothing :: SMaybe Nothing + SJust :: forall k (a :: k). Sing a -> SMaybe (Just a) +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @(Maybe k) = +#else +type instance Sing = +#endif + SMaybe + +#if __GLASGOW_HASKELL__ >= 810 +type EqualsMaybe :: Maybe k -> Maybe k -> Bool +#endif +type family EqualsMaybe (a :: Maybe k) (b :: Maybe k) :: Bool where + EqualsMaybe Nothing Nothing = True + EqualsMaybe (Just a) (Just a') = a == a' + EqualsMaybe (x :: Maybe k) (y :: Maybe k) = False +instance PEq a => PEq (Maybe a) where + type m1 == m2 = EqualsMaybe m1 m2 + +instance SDecide k => SDecide (Maybe k) where + SNothing %~ SNothing = Proved Refl + (SJust x) %~ (SJust y) = + case x %~ y of + Proved Refl -> Proved Refl + Disproved contra -> Disproved (\Refl -> contra Refl) + SNothing %~ (SJust _) = Disproved (\case) + (SJust _) %~ SNothing = Disproved (\case) + +instance SEq k => SEq (Maybe k) where + SNothing %== SNothing = STrue + SNothing %== (SJust _) = SFalse + (SJust _) %== SNothing = SFalse + (SJust a) %== (SJust a') = a %== a' + +instance SingI (Nothing :: Maybe k) where + sing = SNothing +instance SingI a => SingI (Just (a :: k)) where + sing = SJust sing +instance SingI1 Just where + liftSing = SJust +instance SingKind k => SingKind (Maybe k) where + type Demote (Maybe k) = Maybe (Demote k) + fromSing SNothing = Nothing + fromSing (SJust a) = Just (fromSing a) + toSing Nothing = SomeSing SNothing + toSing (Just x) = + case toSing x :: SomeSing k of + SomeSing x' -> SomeSing $ SJust x' + +-- List + +#if __GLASGOW_HASKELL__ >= 810 +type SList :: forall k. List k -> Type +#endif +data SList :: forall k. List k -> Type where + SNil :: SList Nil + SCons :: forall k (h :: k) (t :: List k). Sing h -> SList t -> SList (Cons h t) +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @(List k) = +#else +type instance Sing = +#endif + SList + +#if __GLASGOW_HASKELL__ >= 810 +type NilSym0 :: List a +#endif +type family NilSym0 :: List a where + NilSym0 = Nil + +#if __GLASGOW_HASKELL__ >= 810 +type ConsSym0 :: forall a. a ~> List a ~> List a +type ConsSym1 :: forall a. a -> List a ~> List a +type ConsSym2 :: forall a. a -> List a -> List a +#endif +data ConsSym0 :: forall a. a ~> List a ~> List a +data ConsSym1 :: forall a. a -> List a ~> List a +type family ConsSym2 (x :: a) (y :: List a) :: List a where + ConsSym2 x y = Cons x y +type instance Apply ConsSym0 a = ConsSym1 a +type instance Apply (ConsSym1 a) b = Cons a b + +#if __GLASGOW_HASKELL__ >= 810 +type EqualsList :: List k -> List k -> Bool +#endif +type family EqualsList (a :: List k) (b :: List k) :: Bool where + EqualsList Nil Nil = True + EqualsList (Cons a b) (Cons a' b') = (a == a') && (b == b') + EqualsList (x :: List k) (y :: List k) = False +instance PEq a => PEq (List a) where + type l1 == l2 = EqualsList l1 l2 + +instance SEq k => SEq (List k) where + SNil %== SNil = STrue + SNil %== (SCons _ _) = SFalse + (SCons _ _) %== SNil = SFalse + (SCons a b) %== (SCons a' b') = (a %== a') %&& (b %== b') + +instance SDecide k => SDecide (List k) where + SNil %~ SNil = Proved Refl + (SCons h1 t1) %~ (SCons h2 t2) = + case (h1 %~ h2, t1 %~ t2) of + (Proved Refl, Proved Refl) -> Proved Refl + (Disproved contra, _) -> Disproved (\Refl -> contra Refl) + (_, Disproved contra) -> Disproved (\Refl -> contra Refl) + SNil %~ (SCons _ _) = Disproved (\case) + (SCons _ _) %~ SNil = Disproved (\case) + +instance SingI Nil where + sing = SNil +instance (SingI h, SingI t) => + SingI (Cons (h :: k) (t :: List k)) where + sing = SCons sing sing +instance SingI h => SingI1 (Cons (h :: k)) where + liftSing = SCons sing +instance SingI2 Cons where + liftSing2 = SCons +instance SingKind k => SingKind (List k) where + type Demote (List k) = List (Demote k) + fromSing SNil = Nil + fromSing (SCons h t) = Cons (fromSing h) (fromSing t) + toSing Nil = SomeSing SNil + toSing (Cons h t) = + case ( toSing h :: SomeSing k + , toSing t :: SomeSing (List k) ) of + (SomeSing h', SomeSing t') -> SomeSing $ SCons h' t' + +-- Either + +#if __GLASGOW_HASKELL__ >= 810 +type SEither :: forall k1 k2. Either k1 k2 -> Type +#endif +data SEither :: forall k1 k2. Either k1 k2 -> Type where + SLeft :: forall k1 (a :: k1). Sing a -> SEither (Left a) + SRight :: forall k2 (b :: k2). Sing b -> SEither (Right b) +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @(Either k1 k2) = +#else +type instance Sing = +#endif + SEither + +instance (SingI a) => SingI (Left (a :: k)) where + sing = SLeft sing +instance SingI1 Left where + liftSing = SLeft +instance (SingI b) => SingI (Right (b :: k)) where + sing = SRight sing +instance SingI1 Right where + liftSing = SRight +instance (SingKind k1, SingKind k2) => SingKind (Either k1 k2) where + type Demote (Either k1 k2) = Either (Demote k1) (Demote k2) + fromSing (SLeft x) = Left (fromSing x) + fromSing (SRight x) = Right (fromSing x) + toSing (Left x) = + case toSing x :: SomeSing k1 of + SomeSing x' -> SomeSing $ SLeft x' + toSing (Right x) = + case toSing x :: SomeSing k2 of + SomeSing x' -> SomeSing $ SRight x' + +instance (SDecide k1, SDecide k2) => SDecide (Either k1 k2) where + (SLeft x) %~ (SLeft y) = + case x %~ y of + Proved Refl -> Proved Refl + Disproved contra -> Disproved (\Refl -> contra Refl) + (SRight x) %~ (SRight y) = + case x %~ y of + Proved Refl -> Proved Refl + Disproved contra -> Disproved (\Refl -> contra Refl) + (SLeft _) %~ (SRight _) = Disproved (\case) + (SRight _) %~ (SLeft _) = Disproved (\case) + +-- Composite + +#if __GLASGOW_HASKELL__ >= 810 +type Composite :: Type -> Type -> Type +#endif +data Composite :: Type -> Type -> Type where + MkComp :: Either (Maybe a) b -> Composite a b + +#if __GLASGOW_HASKELL__ >= 810 +type SComposite :: forall k1 k2. Composite k1 k2 -> Type +#endif +data SComposite :: forall k1 k2. Composite k1 k2 -> Type where + SMkComp :: forall k1 k2 (a :: Either (Maybe k1) k2). SEither a -> SComposite (MkComp a) +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @(Composite k1 k2) = +#else +type instance Sing = +#endif + SComposite + +instance SingI a => SingI (MkComp (a :: Either (Maybe k1) k2)) where + sing = SMkComp sing +instance SingI1 MkComp where + liftSing = SMkComp +instance (SingKind k1, SingKind k2) => SingKind (Composite k1 k2) where + type Demote (Composite k1 k2) = + Composite (Demote k1) (Demote k2) + fromSing (SMkComp x) = MkComp (fromSing x) + toSing (MkComp x) = + case toSing x :: SomeSing (Either (Maybe k1) k2) of + SomeSing x' -> SomeSing $ SMkComp x' + +instance (SDecide k1, SDecide k2) => SDecide (Composite k1 k2) where + (SMkComp x) %~ (SMkComp y) = + case x %~ y of + Proved Refl -> Proved Refl + Disproved contra -> Disproved (\Refl -> contra Refl) + +-- Empty + +#if __GLASGOW_HASKELL__ >= 810 +type Empty :: Type +#endif +data Empty + +#if __GLASGOW_HASKELL__ >= 810 +type SEmpty :: Empty -> Type +#endif +data SEmpty :: Empty -> Type + +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @Empty = +#else +type instance Sing = +#endif + SEmpty +instance SingKind Empty where + type Demote Empty = Empty + fromSing = \case + toSing x = SomeSing (case x of) + +-- Type + +#if __GLASGOW_HASKELL__ >= 810 +type Vec :: Type -> Nat -> Type +#endif +data Vec :: Type -> Nat -> Type where + VNil :: Vec a Zero + VCons :: a -> Vec a n -> Vec a (Succ n) + +#if __GLASGOW_HASKELL__ >= 810 +type Rep :: Type +#endif +data Rep = Nat | Maybe Rep | Vec Rep Nat + +#if __GLASGOW_HASKELL__ >= 810 +type SRep :: Type -> Type +#endif +data SRep :: Type -> Type where + SNat :: SRep Nat + SMaybe :: SRep a -> SRep (Maybe a) + SVec :: SRep a -> SNat n -> SRep (Vec a n) +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @Type = +#else +type instance Sing = +#endif + SRep + +instance SingI Nat where + sing = SNat +instance SingI a => SingI (Maybe a) where + sing = SMaybe sing +instance SingI1 Maybe where + liftSing = SMaybe +instance (SingI a, SingI n) => SingI (Vec a n) where + sing = SVec sing sing +instance SingI a => SingI1 (Vec a) where + liftSing = SVec sing +instance SingI2 Vec where + liftSing2 = SVec + +instance SingKind Type where + type Demote Type = Rep + + fromSing SNat = Nat + fromSing (SMaybe a) = Maybe (fromSing a) + fromSing (SVec a n) = Vec (fromSing a) (fromSing n) + + toSing Nat = SomeSing SNat + toSing (Maybe a) = + case toSing a :: SomeSing Type of + SomeSing a' -> SomeSing $ SMaybe a' + toSing (Vec a n) = + case ( toSing a :: SomeSing Type + , toSing n :: SomeSing Nat) of + (SomeSing a', SomeSing n') -> SomeSing $ SVec a' n' + +instance SDecide Type where + SNat %~ SNat = Proved Refl + SNat %~ (SMaybe {}) = Disproved (\case) + SNat %~ (SVec {}) = Disproved (\case) + (SMaybe {}) %~ SNat = Disproved (\case) + (SMaybe a) %~ (SMaybe b) = + case a %~ b of + Proved Refl -> Proved Refl + Disproved contra -> Disproved (\Refl -> contra Refl) + (SMaybe {}) %~ (SVec {}) = Disproved (\case) + (SVec {}) %~ SNat = Disproved (\case) + (SVec {}) %~ (SMaybe {}) = Disproved (\case) + (SVec a1 n1) %~ (SVec a2 n2) = + case (a1 %~ a2, n1 %~ n2) of + (Proved Refl, Proved Refl) -> Proved Refl + (Disproved contra, _) -> Disproved (\Refl -> contra Refl) + (_, Disproved contra) -> Disproved (\Refl -> contra Refl) + +#if __GLASGOW_HASKELL__ >= 810 +type EqualsType :: Type -> Type -> Bool +#endif +type family EqualsType (a :: Type) (b :: Type) :: Bool where + EqualsType a a = True + EqualsType _ _ = False +instance PEq Type where + type a == b = EqualsType a b + +instance SEq Type where + a %== b = + case a %~ b of + Proved Refl -> STrue + Disproved _ -> unsafeCoerce SFalse + +----------------------------------- +-- Some example functions --------- +----------------------------------- + +isJust :: Maybe a -> Bool +isJust Nothing = False +isJust (Just _) = True + +#if __GLASGOW_HASKELL__ >= 810 +type IsJust :: Maybe k -> Bool +#endif +type family IsJust (a :: Maybe k) :: Bool where + IsJust Nothing = False + IsJust (Just a) = True + +-- defunctionalization symbols +#if __GLASGOW_HASKELL__ >= 810 +type IsJustSym0 :: forall a. Maybe a ~> Bool +#endif +data IsJustSym0 :: forall a. Maybe a ~> Bool +type instance Apply IsJustSym0 a = IsJust a + +sIsJust :: Sing a -> Sing (IsJust a) +sIsJust SNothing = SFalse +sIsJust (SJust _) = STrue + +pred :: Nat -> Nat +pred Zero = Zero +pred (Succ n) = n + +#if __GLASGOW_HASKELL__ >= 810 +type Pred :: Nat -> Nat +#endif +type family Pred (a :: Nat) :: Nat where + Pred Zero = Zero + Pred (Succ n) = n + +#if __GLASGOW_HASKELL__ >= 810 +type PredSym0 :: Nat ~> Nat +#endif +data PredSym0 :: Nat ~> Nat +type instance Apply PredSym0 a = Pred a + +sPred :: forall (t :: Nat). Sing t -> Sing (Pred t) +sPred SZero = SZero +sPred (SSucc n) = n + +map :: (a -> b) -> List a -> List b +map _ Nil = Nil +map f (Cons h t) = Cons (f h) (map f t) + +#if __GLASGOW_HASKELL__ >= 810 +type Map :: (k1 ~> k2) -> List k1 -> List k2 +#endif +type family Map (f :: k1 ~> k2) (l :: List k1) :: List k2 where + Map f Nil = Nil + Map f (Cons h t) = Cons (Apply f h) (Map f t) + +-- defunctionalization symbols +#if __GLASGOW_HASKELL__ >= 810 +type MapSym0 :: forall a b. (a ~> b) ~> List a ~> List b +type MapSym1 :: forall a b. (a ~> b) -> List a ~> List b +#endif +data MapSym0 :: forall a b. (a ~> b) ~> List a ~> List b +data MapSym1 :: forall a b. (a ~> b) -> List a ~> List b +type instance Apply MapSym0 f = MapSym1 f +type instance Apply (MapSym1 f) xs = Map f xs + +sMap :: forall k1 k2 (a :: List k1) (f :: k1 ~> k2). + (forall b. Proxy f -> Sing b -> Sing (Apply f b)) -> Sing a -> Sing (Map f a) +sMap _ SNil = SNil +sMap f (SCons h t) = SCons (f Proxy h) (sMap f t) + +-- Alternative implementation of sMap with Proxy outside of callback. +-- Not generated by the library. +sMap2 :: forall k1 k2 (a :: List k1) (f :: k1 ~> k2). Proxy f -> + (forall b. Sing b -> Sing (Apply f b)) -> Sing a -> Sing (Map f a) +sMap2 _ _ SNil = SNil +sMap2 p f (SCons h t) = SCons (f h) (sMap2 p f t) + +-- test sMap +foo :: Sing (Cons (Succ (Succ Zero)) (Cons (Succ Zero) Nil)) +foo = sMap (\(_ :: Proxy (TyCon1 Succ)) -> SSucc) (SCons (SSucc SZero) (SCons SZero SNil)) + +-- test sMap2 +bar :: Sing (Cons (Succ (Succ Zero)) (Cons (Succ Zero) Nil)) +bar = sMap2 (Proxy :: Proxy SuccSym0) (SSucc) (SCons (SSucc SZero) (SCons SZero SNil)) + +baz :: Sing (Cons Zero (Cons Zero Nil)) +baz = sMap2 (Proxy :: Proxy PredSym0) (sPred) (SCons (SSucc SZero) (SCons SZero SNil)) + +zipWith :: (a -> b -> c) -> List a -> List b -> List c +zipWith f (Cons x xs) (Cons y ys) = Cons (f x y) (zipWith f xs ys) +zipWith _ Nil (Cons _ _) = Nil +zipWith _ (Cons _ _) Nil = Nil +zipWith _ Nil Nil = Nil + +#if __GLASGOW_HASKELL__ >= 810 +type ZipWith :: (a ~> b ~> c) -> List a -> List b -> List c +#endif +type family ZipWith (k1 :: a ~> b ~> c) (k2 :: List a) (k3 :: List b) :: List c where + ZipWith f (Cons x xs) (Cons y ys) = Cons (Apply (Apply f x) y) (ZipWith f xs ys) + ZipWith f Nil (Cons z1 z2) = Nil + ZipWith f (Cons z1 z2) Nil = Nil + ZipWith f Nil Nil = Nil + +#if __GLASGOW_HASKELL__ >= 810 +type ZipWithSym0 :: forall a b c. (a ~> b ~> c) ~> List a ~> List b ~> List c +type ZipWithSym1 :: forall a b c. (a ~> b ~> c) -> List a ~> List b ~> List c +type ZipWithSym2 :: forall a b c. (a ~> b ~> c) -> List a -> List b ~> List c +#endif +data ZipWithSym0 :: forall a b c. (a ~> b ~> c) ~> List a ~> List b ~> List c +data ZipWithSym1 :: forall a b c. (a ~> b ~> c) -> List a ~> List b ~> List c +data ZipWithSym2 :: forall a b c. (a ~> b ~> c) -> List a -> List b ~> List c +type instance Apply ZipWithSym0 f = ZipWithSym1 f +type instance Apply (ZipWithSym1 f) xs = ZipWithSym2 f xs +type instance Apply (ZipWithSym2 f xs) ys = ZipWith f xs ys + + +sZipWith :: forall a b c (k1 :: a ~> b ~> c) (k2 :: List a) (k3 :: List b). + (forall (t1 :: a). Proxy k1 -> Sing t1 -> forall (t2 :: b). Sing t2 -> Sing (Apply (Apply k1 t1) t2)) + -> Sing k2 -> Sing k3 -> Sing (ZipWith k1 k2 k3) +sZipWith f (SCons x xs) (SCons y ys) = SCons (f Proxy x y) (sZipWith f xs ys) +sZipWith _ SNil (SCons _ _) = SNil +sZipWith _ (SCons _ _) SNil = SNil +sZipWith _ SNil SNil = SNil + +either :: (a -> c) -> (b -> c) -> Either a b -> c +either l _ (Left x) = l x +either _ r (Right x) = r x + +#if __GLASGOW_HASKELL__ >= 810 +type Either_ :: (a ~> c) -> (b ~> c) -> Either a b -> c +#endif +type family Either_ (l :: a ~> c) (r :: b ~> c) (e :: Either a b) :: c where + Either_ l r (Left x) = Apply l x + Either_ l r (Right x) = Apply r x + +-- defunctionalization symbols +#if __GLASGOW_HASKELL__ >= 810 +type Either_Sym0 :: forall a c b. (a ~> c) ~> (b ~> c) ~> Either a b ~> c +type Either_Sym1 :: forall a c b. (a ~> c) -> (b ~> c) ~> Either a b ~> c +type Either_Sym2 :: forall a c b. (a ~> c) -> (b ~> c) -> Either a b ~> c +#endif +data Either_Sym0 :: forall a c b. (a ~> c) ~> (b ~> c) ~> Either a b ~> c +data Either_Sym1 :: forall a c b. (a ~> c) -> (b ~> c) ~> Either a b ~> c +data Either_Sym2 :: forall a c b. (a ~> c) -> (b ~> c) -> Either a b ~> c +type instance Apply Either_Sym0 k1 = Either_Sym1 k1 +type instance Apply (Either_Sym1 k1) k2 = Either_Sym2 k1 k2 +type instance Apply (Either_Sym2 k1 k2) k3 = Either_ k1 k2 k3 + +sEither :: forall a b c + (l :: a ~> c) + (r :: b ~> c) + (e :: Either a b). + (forall n. Proxy l -> Sing n -> Sing (Apply l n)) -> + (forall n. Proxy r -> Sing n -> Sing (Apply r n)) -> + Sing e -> Sing (Either_ l r e) +sEither l _ (SLeft x) = l Proxy x +sEither _ r (SRight x) = r Proxy x + +-- Alternative implementation of sEither with Proxy outside of callbacks. +-- Not generated by the library. +sEither2 :: forall a b c + (l :: a ~> c) + (r :: b ~> c) + (e :: Either a b). + Proxy l -> Proxy r -> + (forall n. Sing n -> Sing (Apply l n)) -> + (forall n. Sing n -> Sing (Apply r n)) -> + Sing e -> Sing (Either_ l r e) +sEither2 _ _ l _ (SLeft x) = l x +sEither2 _ _ _ r (SRight x) = r x + +eitherFoo :: Sing (Succ (Succ Zero)) +eitherFoo = sEither (\(_ :: Proxy SuccSym0) -> SSucc) + (\(_ :: Proxy PredSym0) -> sPred) (SLeft (SSucc SZero)) + +eitherBar :: Sing Zero +eitherBar = sEither2 (Proxy :: Proxy SuccSym0) + (Proxy :: Proxy PredSym0) + SSucc + sPred (SRight (SSucc SZero)) + +eitherToNat :: Either Nat Nat -> Nat +eitherToNat (Left x) = x +eitherToNat (Right x) = x + +#if __GLASGOW_HASKELL__ >= 810 +type EitherToNat :: Either Nat Nat -> Nat +#endif +type family EitherToNat (e :: Either Nat Nat) :: Nat where + EitherToNat (Left x) = x + EitherToNat (Right x) = x + +sEitherToNat :: Sing a -> Sing (EitherToNat a) +sEitherToNat (SLeft x) = x +sEitherToNat (SRight x) = x + +liftMaybe :: (a -> b) -> Maybe a -> Maybe b +liftMaybe _ Nothing = Nothing +liftMaybe f (Just a) = Just (f a) + +#if __GLASGOW_HASKELL__ >= 810 +type LiftMaybe :: (a ~> b) -> Maybe a -> Maybe b +#endif +type family LiftMaybe (f :: a ~> b) (x :: Maybe a) :: Maybe b where + LiftMaybe f Nothing = Nothing + LiftMaybe f (Just a) = Just (Apply f a) + +#if __GLASGOW_HASKELL__ >= 810 +type LiftMaybeSym0 :: forall a b. (a ~> b) ~> Maybe a ~> Maybe b +type LiftMaybeSym1 :: forall a b. (a ~> b) -> Maybe a ~> Maybe b +#endif +data LiftMaybeSym0 :: forall a b. (a ~> b) ~> Maybe a ~> Maybe b +data LiftMaybeSym1 :: forall a b. (a ~> b) -> Maybe a ~> Maybe b +type instance Apply LiftMaybeSym0 k1 = LiftMaybeSym1 k1 +type instance Apply (LiftMaybeSym1 k1) k2 = LiftMaybe k1 k2 + +sLiftMaybe :: forall a b (f :: a ~> b) (x :: Maybe a). + (forall (y :: a). Proxy f -> Sing y -> Sing (Apply f y)) -> + Sing x -> Sing (LiftMaybe f x) +sLiftMaybe _ SNothing = SNothing +sLiftMaybe f (SJust a) = SJust (f Proxy a) + +(+) :: Nat -> Nat -> Nat +Zero + x = x +(Succ x) + y = Succ (x + y) + +#if __GLASGOW_HASKELL__ >= 810 +type (+) :: Nat -> Nat -> Nat +#endif +type family (+) (m :: Nat) (n :: Nat) :: Nat where + Zero + x = x + (Succ x) + y = Succ (x + y) + +-- defunctionalization symbols +#if __GLASGOW_HASKELL__ >= 810 +type (+@#@$) :: Nat ~> Nat ~> Nat +type (+@#@$$) :: Nat -> Nat ~> Nat +#endif +data (+@#@$) :: Nat ~> Nat ~> Nat +data (+@#@$$) :: Nat -> Nat ~> Nat +type instance Apply (+@#@$) k1 = (+@#@$$) k1 +type instance Apply ((+@#@$$) k1) k2 = (+) k1 k2 + +(%+) :: Sing m -> Sing n -> Sing (m + n) +SZero %+ x = x +(SSucc x) %+ y = SSucc (x %+ y) + +(-) :: Nat -> Nat -> Nat +Zero - _ = Zero +(Succ x) - Zero = Succ x +(Succ x) - (Succ y) = x - y + +#if __GLASGOW_HASKELL__ >= 810 +type (-) :: Nat -> Nat -> Nat +#endif +type family (-) (m :: Nat) (n :: Nat) :: Nat where + Zero - x = Zero + (Succ x) - Zero = Succ x + (Succ x) - (Succ y) = x - y + +#if __GLASGOW_HASKELL__ >= 810 +type (-@#@$) :: Nat ~> Nat ~> Nat +type (-@#@$$) :: Nat -> Nat ~> Nat +#endif +data (-@#@$) :: Nat ~> Nat ~> Nat +data (-@#@$$) :: Nat -> Nat ~> Nat +type instance Apply (-@#@$) k1 = (-@#@$$) k1 +type instance Apply ((-@#@$$) k1) k2 = (-) k1 k2 + +(%-) :: Sing m -> Sing n -> Sing (m - n) +SZero %- _ = SZero +(SSucc x) %- SZero = SSucc x +(SSucc x) %- (SSucc y) = x %- y + +isZero :: Nat -> Bool +isZero n = if n == Zero then True else False + +#if __GLASGOW_HASKELL__ >= 810 +type IsZero :: Nat -> Bool +#endif +type family IsZero (n :: Nat) :: Bool where + IsZero n = If (n == Zero) True False + +#if __GLASGOW_HASKELL__ >= 810 +type IsZeroSym0 :: Nat ~> Bool +#endif +data IsZeroSym0 :: Nat ~> Bool +type instance Apply IsZeroSym0 a = IsZero a + +sIsZero :: Sing n -> Sing (IsZero n) +sIsZero n = sIf (n %== SZero) STrue SFalse + +{- +(||) :: Bool -> Bool -> Bool +False || x = x +True || _ = True +-} + +#if __GLASGOW_HASKELL__ >= 810 +type (||) :: Bool -> Bool -> Bool +#endif +type family (a :: Bool) || (b :: Bool) :: Bool where + False || x = x + True || x = True + +#if __GLASGOW_HASKELL__ >= 810 +type (||@#@$) :: Bool ~> Bool ~> Bool +type (||@#@$$) :: Bool -> Bool ~> Bool +#endif +data (||@#@$) :: Bool ~> Bool ~> Bool +data (||@#@$$) :: Bool -> Bool ~> Bool +type instance Apply (||@#@$) a = (||@#@$$) a +type instance Apply ((||@#@$$) a) b = (||) a b + +(%||) :: Sing a -> Sing b -> Sing (a || b) +SFalse %|| x = x +STrue %|| _ = STrue + +contains :: Eq a => a -> List a -> Bool +contains _ Nil = False +contains elt (Cons h t) = (elt == h) || contains elt t + +#if __GLASGOW_HASKELL__ >= 810 +type Contains :: k -> List k -> Bool +#endif +type family Contains (a :: k) (b :: List k) :: Bool where + Contains elt Nil = False + Contains elt (Cons h t) = (elt == h) || (Contains elt t) + +#if __GLASGOW_HASKELL__ >= 810 +type ContainsSym0 :: forall a. a ~> List a ~> Bool +type ContainsSym1 :: forall a. a -> List a ~> Bool +#endif +data ContainsSym0 :: forall a. a ~> List a ~> Bool +data ContainsSym1 :: forall a. a -> List a ~> Bool +type instance Apply ContainsSym0 a = ContainsSym1 a +type instance Apply (ContainsSym1 a) b = Contains a b + +{- +sContains :: forall k. SEq k => + forall (a :: k). Sing a -> + forall (list :: List k). Sing list -> Sing (Contains a list) +sContains _ SNil = SFalse +sContains elt (SCons h t) = (elt %== h) %|| (sContains elt t) +-} + +sContains :: forall a (t1 :: a) (t2 :: List a). SEq a => Sing t1 + -> Sing t2 -> Sing (Contains t1 t2) +sContains _ SNil = + let lambda :: forall wild. Sing (Contains wild Nil) + lambda = SFalse + in + lambda +sContains elt (SCons h t) = + let lambda :: forall elt h t. (elt ~ t1, (Cons h t) ~ t2) => Sing elt -> Sing h -> Sing t -> Sing (Contains elt (Cons h t)) + lambda elt' h' t' = (elt' %== h') %|| sContains elt' t' + in + lambda elt h t + +cont :: Eq a => a -> List a -> Bool +cont = \elt list -> case list of + Nil -> False + Cons h t -> (elt == h) || cont elt t + +#if __GLASGOW_HASKELL__ >= 810 +type Cont :: a ~> List a ~> Bool +#endif +type family Cont :: a ~> List a ~> Bool where + Cont = Lambda10Sym0 + +data Lambda10Sym0 f where + KindInferenceLambda10Sym0 :: (Lambda10Sym0 @@ arg) ~ Lambda10Sym1 arg + => Proxy arg + -> Lambda10Sym0 f +type instance Lambda10Sym0 `Apply` x = Lambda10Sym1 x + +data Lambda10Sym1 a f where + KindInferenceLambda10Sym1 :: (Lambda10Sym1 a @@ arg) ~ Lambda10Sym2 a arg + => Proxy arg + -> Lambda10Sym1 a f +type instance (Lambda10Sym1 a) `Apply` b = Lambda10Sym2 a b + +type Lambda10Sym2 a b = Lambda10 a b + +type family Lambda10 a b where + Lambda10 elt list = Case10 elt list list + +type family Case10 a b scrut where + Case10 elt list Nil = False + Case10 elt list (Cons h t) = (||@#@$) @@ ((==@#@$) @@ elt @@ h) @@ (Cont @@ elt @@ t) + +data (==@#@$) f where + (:###==@#@$) :: ((==@#@$) @@ arg) ~ (==@#@$$) arg + => Proxy arg + -> (==@#@$) f +type instance (==@#@$) `Apply` x = (==@#@$$) x + +data (==@#@$$) a f where + (:###==@#@$$) :: ((==@#@$$) x @@ arg) ~ (==@#@$$$) x arg + => Proxy arg + -> (==@#@$$) x y +type instance (==@#@$$) a `Apply` b = (==) a b + +type family (==@#@$$$) a b where + (==@#@$$$) a b = (==) a b + + +impNat :: forall m n. SingI n => Proxy n -> Sing m -> Sing (n + m) +impNat _ sm = (sing :: Sing n) %+ sm + +callImpNat :: forall n m. Sing n -> Sing m -> Sing (n + m) +callImpNat sn sm = withSingI sn (impNat (Proxy :: Proxy n) sm) + +instance Show (SNat n) where + show SZero = "SZero" + show (SSucc n) = "SSucc (" ++ (show n) ++ ")" + +findIndices :: (a -> Bool) -> [a] -> [Nat] +findIndices p ls = loop Zero ls + where + loop _ [] = [] + loop n (x:xs) | p x = n : loop (Succ n) xs + | otherwise = loop (Succ n) xs + +#if __GLASGOW_HASKELL__ >= 810 +type FindIndices :: (a ~> Bool) -> List a -> List Nat +#endif +type family FindIndices (f :: a ~> Bool) (ls :: List a) :: List Nat where + FindIndices p ls = (Let123LoopSym2 p ls) @@ Zero @@ ls + +type family Let123Loop p ls (arg1 :: Nat) (arg2 :: List a) :: List Nat where + Let123Loop p ls z Nil = Nil + Let123Loop p ls n (x `Cons` xs) = Case123 p ls n x xs (p @@ x) + +type family Case123 p ls n x xs scrut where + Case123 p ls n x xs True = n `Cons` ((Let123LoopSym2 p ls) @@ (Succ n) @@ xs) + Case123 p ls n x xs False = (Let123LoopSym2 p ls) @@ (Succ n) @@ xs + +data Let123LoopSym2 a b c where + Let123LoopSym2KindInfernece :: ((Let123LoopSym2 a b @@ z) ~ Let123LoopSym3 a b z) + => Proxy z + -> Let123LoopSym2 a b c +type instance Apply (Let123LoopSym2 a b) c = Let123LoopSym3 a b c + +data Let123LoopSym3 a b c d where + KindInferenceLet123LoopSym3 :: ((Let123LoopSym3 a b c @@ z) ~ Let123LoopSym4 a b c z) + => Proxy z + -> Let123LoopSym3 a b c d +type instance Apply (Let123LoopSym3 a b c) d = Let123Loop a b c d + +type family Let123LoopSym4 a b c d where + Let123LoopSym4 a b c d = Let123Loop a b c d + +data FindIndicesSym0 a where + KindInferenceFindIndicesSym0 :: (FindIndicesSym0 @@ z) ~ FindIndicesSym1 z + => Proxy z + -> FindIndicesSym0 a +type instance Apply FindIndicesSym0 a = FindIndicesSym1 a + +data FindIndicesSym1 a b where + KindInferenceFindIndicesSym1 :: (FindIndicesSym1 a @@ z) ~ FindIndicesSym2 a z + => Proxy z + -> FindIndicesSym1 a b +type instance Apply (FindIndicesSym1 a) b = FindIndices a b + +type family FindIndicesSym2 a b where + FindIndicesSym2 a b = FindIndices a b + +sFindIndices :: forall a (t1 :: a ~> Bool) (t2 :: (List a)). + Sing t1 + -> Sing t2 + -> Sing (FindIndicesSym0 @@ t1 @@ t2) +sFindIndices sP sLs = + let sLoop :: forall (u1 :: Nat) (u2 :: List a). + Sing u1 -> Sing u2 + -> Sing ((Let123LoopSym2 t1 t2) @@ u1 @@ u2) + sLoop _ SNil = SNil + sLoop sN (sX `SCons` sXs) = case sP @@ sX of + STrue -> (singFun2 @ConsSym0 SCons) @@ sN @@ + ((singFun2 @(Let123LoopSym2 t1 t2) sLoop) @@ ((singFun1 @SuccSym0 SSucc) @@ sN) @@ sXs) + SFalse -> (singFun2 @(Let123LoopSym2 t1 t2) sLoop) @@ ((singFun1 @SuccSym0 SSucc) @@ sN) @@ sXs + in + (singFun2 @(Let123LoopSym2 t1 t2) sLoop) @@ SZero @@ sLs + + +fI :: forall a. (a -> Bool) -> [a] -> [Nat] +fI = \p ls -> + let loop :: Nat -> [a] -> [Nat] + loop _ [] = [] + loop n (x:xs) = case p x of + True -> n : loop (Succ n) xs + False -> loop (Succ n) xs + in + loop Zero ls + +type FI = Lambda22Sym0 + +type FISym0 = FI + +type family Lambda22 p ls where + Lambda22 p ls = (Let123LoopSym2 p ls) @@ Zero @@ ls + +data Lambda22Sym0 a where + KindInferenceLambda22Sym0 :: (Lambda22Sym0 @@ z) ~ Lambda22Sym1 z + => Proxy z + -> Lambda22Sym0 a +type instance Apply Lambda22Sym0 a = Lambda22Sym1 a + +data Lambda22Sym1 a b where + KindInferenceLambda22Sym1 :: (Lambda22Sym1 a @@ z) ~ Lambda22Sym2 a z + => Proxy z + -> Lambda22Sym1 a b +type instance Apply (Lambda22Sym1 a) b = Lambda22 a b + +type family Lambda22Sym2 a b where + Lambda22Sym2 a b = Lambda22 a b + +{- +sFI :: forall a (t1 :: a ~> Bool) (t2 :: List a). Sing t1 + -> Sing t2 + -> Sing (FISym0 @@ t1 @@ t2) +sFI = unSingFun2 (singFun2 @FI (\p ls -> + let lambda :: forall {-(t1 :: a ~> Bool)-} t1 t2. Sing t1 -> Sing t2 -> Sing (Lambda22Sym0 @@ t1 @@ t2) + lambda sP sLs = + let sLoop :: (Lambda22Sym0 @@ t1 @@ t2) ~ (Let123LoopSym2 t1 t2 @@ Zero @@ t2) => forall (u1 :: Nat). Sing u1 + -> forall {-(u2 :: List a)-} u2. Sing u2 + -> Sing ((Let123LoopSym2 t1 t2) @@ u1 @@ u2) + sLoop _ SNil = SNil + sLoop sN (sX `SCons` sXs) = case sP @@ sX of + STrue -> (singFun2 @ConsSym0 SCons) @@ sN @@ + ((singFun2 @(Let123LoopSym2 t1 t2) sLoop) @@ ((singFun1 @SuccSym0 SSucc) @@ sN) @@ sXs) + SFalse -> (singFun2 @(Let123LoopSym2 t1 t2) sLoop) @@ ((singFun1 @SuccSym0 SSucc) @@ sN) @@ sXs + in + (singFun2 @(Let123LoopSym2 t1 t2) sLoop) @@ SZero @@ sLs + in + lambda p ls + )) +-} + +------------------------------------------------------------ + +#if __GLASGOW_HASKELL__ >= 810 +type G :: Type -> Type +#endif +data G :: Type -> Type where + MkG :: G Bool + +#if __GLASGOW_HASKELL__ >= 810 +type SG :: forall a. G a -> Type +#endif +data SG :: forall a. G a -> Type where + SMkG :: SG MkG +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @(G a) = +#else +type instance Sing = +#endif + SG diff --git a/tests/ByHand2.hs b/tests/ByHand2.hs new file mode 100644 --- /dev/null +++ b/tests/ByHand2.hs @@ -0,0 +1,302 @@ +{-# LANGUAGE DataKinds, PolyKinds, TypeFamilies, GADTs, TypeOperators, + DefaultSignatures, ScopedTypeVariables, InstanceSigs, + MultiParamTypeClasses, FunctionalDependencies, + UndecidableInstances, CPP, TypeApplications #-} +{-# OPTIONS_GHC -Wno-missing-signatures -Wno-orphans #-} + +#if __GLASGOW_HASKELL__ < 806 +{-# LANGUAGE TypeInType #-} +#endif + +#if __GLASGOW_HASKELL__ >= 810 +{-# LANGUAGE StandaloneKindSignatures #-} +#endif +module ByHand2 where + +import Data.Kind +import Data.Singletons (Sing) + +#if __GLASGOW_HASKELL__ >= 810 +type Nat :: Type +#endif +data Nat = Zero | Succ Nat + +#if __GLASGOW_HASKELL__ >= 810 +type SNat :: Nat -> Type +#endif +data SNat :: Nat -> Type where + SZero :: SNat 'Zero + SSucc :: SNat n -> SNat ('Succ n) +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @Nat = +#else +type instance Sing = +#endif + SNat + +{- +type Bool :: Type +data Bool = False | True +-} + +#if __GLASGOW_HASKELL__ >= 810 +type SBool :: Bool -> Type +#endif +data SBool :: Bool -> Type where + SFalse :: SBool 'False + STrue :: SBool 'True +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @Bool = +#else +type instance Sing = +#endif + SBool + +{- +type Ordering :: Type +data Ordering = LT | EQ | GT +-} + +#if __GLASGOW_HASKELL__ >= 810 +type SOrdering :: Ordering -> Type +#endif +data SOrdering :: Ordering -> Type where + SLT :: SOrdering 'LT + SEQ :: SOrdering 'EQ + SGT :: SOrdering 'GT +#if __GLASGOW_HASKELL__ >= 808 +type instance Sing @Ordering = +#else +type instance Sing = +#endif + SOrdering + +{- +not :: Bool -> Bool +not True = False +not False = True +-} + +#if __GLASGOW_HASKELL__ >= 810 +type Not :: Bool -> Bool +#endif +type family Not (x :: Bool) :: Bool where + Not 'True = 'False + Not 'False = 'True + +sNot :: Sing b -> Sing (Not b) +sNot STrue = SFalse +sNot SFalse = STrue + +{- +type Eq :: Type -> Constraint +class Eq a where + (==) :: a -> a -> Bool + (/=) :: a -> a -> Bool + infix 4 ==, /= + + x == y = not (x /= y) + x /= y = not (x == y) +-} + +#if __GLASGOW_HASKELL__ >= 810 +type PEq :: Type -> Constraint +#endif +class PEq a where + type (==) (x :: a) (y :: a) :: Bool + type (/=) (x :: a) (y :: a) :: Bool + + type x == y = Not (x /= y) + type x /= y = Not (x == y) + +#if __GLASGOW_HASKELL__ >= 810 +type SEq :: Type -> Constraint +#endif +class SEq a where + (%==) :: Sing (x :: a) -> Sing (y :: a) -> Sing (x == y) + (%/=) :: Sing (x :: a) -> Sing (y :: a) -> Sing (x /= y) + + default (%==) :: ((x == y) ~ (Not (x /= y))) => Sing (x :: a) -> Sing (y :: a) -> Sing (x == y) + x %== y = sNot (x %/= y) + + default (%/=) :: ((x /= y) ~ (Not (x == y))) => Sing (x :: a) -> Sing (y :: a) -> Sing (x /= y) + x %/= y = sNot (x %== y) + +instance Eq Nat where + Zero == Zero = True + Zero == Succ _ = False + Succ _ == Zero = False + Succ x == Succ y = x == y + +instance PEq Nat where + type 'Zero == 'Zero = 'True + type 'Succ x == 'Zero = 'False + type 'Zero == 'Succ x = 'False + type 'Succ x == 'Succ y = x == y + +instance SEq Nat where + (%==) :: forall (x :: Nat) (y :: Nat). Sing x -> Sing y -> Sing (x == y) + SZero %== SZero = STrue + SSucc _ %== SZero = SFalse + SZero %== SSucc _ = SFalse + SSucc x %== SSucc y = x %== y + +{- +instance Eq Ordering where + LT == LT = True + LT == EQ = False + LT == GT = False + EQ == LT = False + EQ == EQ = True + EQ == GT = False + GT == LT = False + GT == EQ = False + GT == GT = True +-} + +instance PEq Ordering where + type 'LT == 'LT = 'True + type 'LT == 'EQ = 'False + type 'LT == 'GT = 'False + type 'EQ == 'LT = 'False + type 'EQ == 'EQ = 'True + type 'EQ == 'GT = 'False + type 'GT == 'LT = 'False + type 'GT == 'EQ = 'False + type 'GT == 'GT = 'True + +instance SEq Ordering where + SLT %== SLT = STrue + SLT %== SEQ = SFalse + SLT %== SGT = SFalse + SEQ %== SLT = SFalse + SEQ %== SEQ = STrue + SEQ %== SGT = SFalse + SGT %== SLT = SFalse + SGT %== SEQ = SFalse + SGT %== SGT = STrue + +{- +type Ord :: Type -> Constraint +class Eq a => Ord a where + compare :: a -> a -> Ordering + (<) :: a -> a -> Bool + + x < y = compare x y == LT +-} + +#if __GLASGOW_HASKELL__ >= 810 +type POrd :: Type -> Constraint +#endif +class PEq a => POrd a where + type Compare (x :: a) (y :: a) :: Ordering + type (<) (x :: a) (y :: a) :: Bool + + type x < y = Compare x y == 'LT + +#if __GLASGOW_HASKELL__ >= 810 +type SOrd :: Type -> Constraint +#endif +class SEq a => SOrd a where + sCompare :: Sing (x :: a) -> Sing (y :: a) -> Sing (Compare x y) + (%<) :: Sing (x :: a) -> Sing (y :: a) -> Sing (x < y) + + default (%<) :: ((x < y) ~ (Compare x y == 'LT)) => Sing (x :: a) -> Sing (y :: a) -> Sing (x < y) + x %< y = sCompare x y %== SLT + +instance Ord Nat where + compare Zero Zero = EQ + compare Zero (Succ _) = LT + compare (Succ _) Zero = GT + compare (Succ a) (Succ b) = compare a b + +instance POrd Nat where + type Compare 'Zero 'Zero = 'EQ + type Compare 'Zero ('Succ x) = 'LT + type Compare ('Succ x) 'Zero = 'GT + type Compare ('Succ x) ('Succ y) = Compare x y + +instance SOrd Nat where + sCompare SZero SZero = SEQ + sCompare SZero (SSucc _) = SLT + sCompare (SSucc _) SZero = SGT + sCompare (SSucc x) (SSucc y) = sCompare x y + +#if __GLASGOW_HASKELL__ >= 810 +type Pointed :: Type -> Constraint +#endif +class Pointed a where + point :: a + +#if __GLASGOW_HASKELL__ >= 810 +type PPointed :: Type -> Constraint +#endif +class PPointed a where + type Point :: a + +#if __GLASGOW_HASKELL__ >= 810 +type SPointed :: Type -> Constraint +#endif +class SPointed a where + sPoint :: Sing (Point :: a) + +instance Pointed Nat where + point = Zero + +instance PPointed Nat where + type Point = 'Zero + +instance SPointed Nat where + sPoint = SZero + +-------------------------------- + +#if __GLASGOW_HASKELL__ >= 810 +type FD :: Type -> Type -> Constraint +#endif +class FD a b | a -> b where + meth :: a -> a + l2r :: a -> b + +instance FD Bool Nat where + meth = not + l2r False = Zero + l2r True = Succ Zero + +t1 = meth True +t2 = l2r False + +#if __GLASGOW_HASKELL__ >= 810 +type PFD :: Type -> Type -> Constraint +#endif +class PFD a b | a -> b where + type Meth (x :: a) :: a + type L2r (x :: a) :: b + +instance PFD Bool Nat where + type Meth a = Not a + type L2r 'False = 'Zero + type L2r 'True = 'Succ 'Zero + +type T1 = Meth 'True + +#if __GLASGOW_HASKELL__ >= 810 +type T2 :: Nat +#endif +type T2 = (L2r 'False :: Nat) + +#if __GLASGOW_HASKELL__ >= 810 +type SFD :: Type -> Type -> Constraint +#endif +class SFD a b | a -> b where + sMeth :: forall (x :: a). Sing x -> Sing (Meth x :: a) + sL2r :: forall (x :: a). Sing x -> Sing (L2r x :: b) + +instance SFD Bool Nat where + sMeth x = sNot x + sL2r SFalse = SZero + sL2r STrue = SSucc SZero + +sT1 = sMeth STrue +sT2 :: Sing T2 +sT2 = sL2r SFalse diff --git a/tests/SingletonsTestSuite.hs b/tests/SingletonsTestSuite.hs --- a/tests/SingletonsTestSuite.hs +++ b/tests/SingletonsTestSuite.hs @@ -1,87 +1,6 @@ -module Main ( - main - ) where - -import Test.Tasty ( TestTree, defaultMain, testGroup ) -import SingletonsTestSuiteUtils ( compileAndDumpStdTest, compileAndDumpTest - , testCompileAndDumpGroup, ghcOpts - -- , cleanFiles - ) +-- | 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 = do --- cleanFiles We really need to parallelize the testsuite. - defaultMain tests - -tests :: TestTree -tests = - testGroup "Testsuite" $ [ - testCompileAndDumpGroup "Singletons" - [ compileAndDumpStdTest "Nat" - , compileAndDumpStdTest "Empty" - , compileAndDumpStdTest "Maybe" - , compileAndDumpStdTest "BoxUnBox" - , compileAndDumpStdTest "Operators" - , compileAndDumpStdTest "HigherOrder" - , compileAndDumpStdTest "Contains" - , compileAndDumpStdTest "AsPattern" - , compileAndDumpStdTest "DataValues" - , compileAndDumpStdTest "EqInstances" - , compileAndDumpStdTest "CaseExpressions" - , compileAndDumpStdTest "Star" - , compileAndDumpStdTest "ReturnFunc" - , compileAndDumpStdTest "Lambdas" - , compileAndDumpStdTest "LambdasComprehensive" - , compileAndDumpStdTest "Error" - , compileAndDumpStdTest "TopLevelPatterns" - , compileAndDumpStdTest "LetStatements" - , compileAndDumpStdTest "LambdaCase" - , compileAndDumpStdTest "Sections" - , compileAndDumpStdTest "PatternMatching" - , compileAndDumpStdTest "Records" - , compileAndDumpStdTest "T29" - , compileAndDumpStdTest "T33" - , compileAndDumpStdTest "T54" - , compileAndDumpStdTest "Classes" - , compileAndDumpStdTest "Classes2" - , compileAndDumpStdTest "FunDeps" - , compileAndDumpStdTest "T78" - , compileAndDumpStdTest "OrdDeriving" - , compileAndDumpStdTest "BoundedDeriving" - , compileAndDumpStdTest "BadBoundedDeriving" - , compileAndDumpStdTest "EnumDeriving" - , compileAndDumpStdTest "BadEnumDeriving" - , compileAndDumpStdTest "Fixity" - , compileAndDumpStdTest "Undef" - , compileAndDumpStdTest "T124" - , compileAndDumpStdTest "T136" - , compileAndDumpStdTest "T136b" - , compileAndDumpStdTest "T153" - , compileAndDumpStdTest "T157" - , compileAndDumpStdTest "T159" - , compileAndDumpStdTest "T167" - , compileAndDumpStdTest "T145" - , compileAndDumpStdTest "PolyKinds" - , compileAndDumpStdTest "PolyKindsApp" - , compileAndDumpStdTest "T166" - , compileAndDumpStdTest "T172" - , compileAndDumpStdTest "T175" - , compileAndDumpStdTest "T176" - , compileAndDumpStdTest "T178" - ], - testCompileAndDumpGroup "Promote" - [ compileAndDumpStdTest "Constructors" - , compileAndDumpStdTest "GenDefunSymbols" - , compileAndDumpStdTest "Newtypes" - , compileAndDumpStdTest "Pragmas" - , compileAndDumpStdTest "Prelude" - , compileAndDumpStdTest "T180" - ], - testGroup "Database client" - [ compileAndDumpTest "GradingClient/Database" ghcOpts - , compileAndDumpTest "GradingClient/Main" ghcOpts - ], - testCompileAndDumpGroup "InsertionSort" - [ compileAndDumpStdTest "InsertionSortImp" - ] - ] +main = pure () diff --git a/tests/SingletonsTestSuiteUtils.hs b/tests/SingletonsTestSuiteUtils.hs deleted file mode 100644 --- a/tests/SingletonsTestSuiteUtils.hs +++ /dev/null @@ -1,260 +0,0 @@ -{-# LANGUAGE CPP, DeriveDataTypeable #-} -module SingletonsTestSuiteUtils ( - compileAndDumpTest - , compileAndDumpStdTest - , testCompileAndDumpGroup - , ghcOpts - , cleanFiles - ) where - -import Control.Exception ( Exception, throw ) -import Control.Monad ( liftM ) -import Data.List ( intercalate, find, isPrefixOf ) -import Data.Typeable ( Typeable ) -import System.Exit ( ExitCode(..) ) -import System.FilePath ( takeBaseName, pathSeparator ) -import System.IO ( IOMode(..), hGetContents, openFile ) -import System.Process ( CreateProcess(..), StdStream(..) - , createProcess, proc, waitForProcess - , readProcess, callCommand ) -import System.Directory ( doesFileExist ) -import Test.Tasty ( TestTree, testGroup ) -import Test.Tasty.Golden ( goldenVsFileDiff ) - -import Distribution.Package ( PackageIdentifier(..) ) -import Distribution.Text ( simpleParse ) -import Distribution.Version ( mkVersion ) -import System.IO.Unsafe ( unsafePerformIO ) - -#ifndef CURRENT_PACKAGE_KEY -#include "../dist/build/autogen/cabal_macros.h" -#endif - --- Some infractructure for handling external process errors -data ProcessException = ProcessException String deriving (Typeable) - -instance Exception ProcessException - -instance Show ProcessException where - show (ProcessException msg) = msg --- GHC executable name (if on path) or full path -ghcPath :: FilePath -ghcPath = "ghc" - --- directory storing compile-and-run tests and golden files -goldenPath :: FilePath -goldenPath = "tests/compile-and-dump/" - --- path containing compiled *.hi files. Relative to goldenPath. --- See Note [-package-name hack] -includePath :: FilePath -includePath = "../../dist/build" - -ghcVersion :: String -ghcVersion = ".ghc82" - --- The mtl package made an incompatible change between 2.1.3.1 and 2.2.1. Because --- test files are compiled outside of the cabal infrastructure, we need to check --- the mtl version and behave accordingly. Argh. The more general solution to this --- is to use cabal_macros.h and then use the package specifications in dist/setup-config. --- This also uses a cabal sandbox, if it is around. -extraOpts :: [String] -extraOpts = unsafePerformIO $ do - (ghcPackageDbOpts, ghcPkgOpts) <- do - sandboxed <- doesFileExist "cabal.sandbox.config" - if sandboxed - then do - let prefix = "package-db: " - opts_from_config config = - case find (prefix `isPrefixOf`) $ lines config of - Nothing -> ([], []) - Just db_line -> let package_db = drop (length prefix) db_line in - ( [ "-no-user-package-db" - , "-package-db " ++ package_db ] - , [ "--no-user-package-db" -- ghc-pkg is slightly different! - , "--package-db=" ++ package_db ] ) - opts_from_config `liftM` readFile "cabal.sandbox.config" - else return ([], []) - mtl_string <- readProcess "ghc-pkg" (ghcPkgOpts ++ ["latest", "mtl"]) "" - let Just (PackageIdentifier { pkgVersion = ver }) = simpleParse mtl_string - firstModernVersion = mkVersion [2,2,1] - mtlOpt | ver >= firstModernVersion = ["-DMODERN_MTL"] - | otherwise = [] - return $ ghcPackageDbOpts ++ mtlOpt - - --- GHC options used when running the tests -ghcOpts :: [String] -ghcOpts = extraOpts ++ [ - "-v0" - , "-c" - , "-this-unit-id " ++ CURRENT_PACKAGE_KEY -- See Note [-this-unit-id hack] - , "-ddump-splices" - , "-dsuppress-uniques" - , "-fforce-recomp" - , "-fprint-explicit-kinds" - , "-O0" - , "-i" ++ includePath -- necessary because some tests use these modules - , "-itests/compile-and-dump" - , "-XTemplateHaskell" - , "-XDataKinds" - , "-XKindSignatures" - , "-XTypeFamilies" - , "-XTypeOperators" - , "-XMultiParamTypeClasses" - , "-XGADTs" - , "-XFlexibleInstances" - , "-XUndecidableInstances" - , "-XRankNTypes" - , "-XScopedTypeVariables" - , "-XPolyKinds" - , "-XFlexibleContexts" - , "-XIncoherentInstances" - , "-XLambdaCase" - , "-XUnboxedTuples" - , "-XInstanceSigs" - , "-XDefaultSignatures" - , "-XCPP" - , "-XTypeInType" - ] - --- Note [-this-unit-id hack] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- We want to avoid installing singletons package before running the --- testsuite, because in this way we prevent double compilation of the --- library. To do this we pass -this-unit-id option to GHC to convince --- it that the test files are actually part of the current --- package. This means that library doesn't have to be installed --- globally and interface files generated during library compilation --- can be used when compiling test cases. We use "-i" option to point --- GHC to directory containing compiled interface files. - --- Compile a test using specified GHC options. Save output to file, filter with --- sed and compare it with golden file. This function also builds golden file --- from a template file. Putting it here is a bit of a hack but it's easy and it --- works. --- --- First parameter is a path to the test file relative to goldenPath directory --- with no ".hs". -compileAndDumpTest :: FilePath -> [String] -> TestTree -compileAndDumpTest testName opts = - goldenVsFileDiff - (takeBaseName testName) - (\ref new -> ["diff", "-w", "-B", ref, new]) -- see Note [Diff options] - goldenFilePath - actualFilePath - compileWithGHC - where - testPath = testName ++ ".hs" - templateFilePath = goldenPath ++ testName ++ ghcVersion ++ ".template" - goldenFilePath = goldenPath ++ testName ++ ".golden" - actualFilePath = goldenPath ++ testName ++ ".actual" - - compileWithGHC :: IO () - compileWithGHC = do - hActualFile <- openFile actualFilePath WriteMode - (_, _, _, pid) <- createProcess (proc ghcPath (testPath : opts)) - { std_out = UseHandle hActualFile - , std_err = UseHandle hActualFile - , cwd = Just goldenPath } - _ <- waitForProcess pid -- see Note [Ignore exit code] - filterWithSed actualFilePath -- see Note [Normalization with sed] - buildGoldenFile templateFilePath goldenFilePath - return () - --- Compile-and-dump test using standard GHC options defined by the testsuite. --- It takes two parameters: name of a file containing a test (no ".hs" --- extension) and directory where the test is located (relative to --- goldenPath). Test name and path are passed separately so that this function --- can be used easily with testCompileAndDumpGroup. -compileAndDumpStdTest :: FilePath -> FilePath -> TestTree -compileAndDumpStdTest testName testPath = - compileAndDumpTest (testPath ++ (pathSeparator : testName)) ghcOpts - --- A convenience function for defining a group of compile-and-dump tests stored --- in the same subdirectory. It takes the name of subdirectory and list of --- functions that given the name of subdirectory create a TestTree. Designed for --- use with compileAndDumpStdTest. -testCompileAndDumpGroup :: FilePath -> [FilePath -> TestTree] -> TestTree -testCompileAndDumpGroup testDir tests = - testGroup testDir $ map ($ testDir) tests - --- Note [Ignore exit code] --- ~~~~~~~~~~~~~~~~~~~~~~~ ----- It may happen that compilation of a source file fails. We could find out --- whether that happened by inspecting the exit code of GHC process. But it --- would be tricky to get a helpful message from the failing test: we would need --- to display stderr which we just wrote into a file. Luckliy we don't have to --- do that - we can ignore the problem here and let the test fail when the --- actual file is compared with the golden file. - --- Note [Diff options] --- ~~~~~~~~~~~~~~~~~~~ --- --- We use following diff options: --- -w - Ignore all white space. --- -B - Ignore changes whose lines are all blank. - --- Note [Normalization with sed] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- Output file is normalized with sed. Line numbers generated in splices: --- --- Foo:(40,3)-(42,4) --- Foo.hs:7:3: --- Equals_1235967303 --- --- are turned into: --- --- Foo:(0,0)-(0,0) --- Foo.hs:0:0: --- Equals_0123456789 --- --- This allows to insert comments into test file without the need to modify the --- golden file to adjust line numbers. --- --- Note that GNU sed (on Linux) and BSD sed (on MacOS) are slightly different. --- We use conditional compilation to deal with this. - -filterWithSed :: FilePath -> IO () -filterWithSed file = runProcessWithOpts CreatePipe "sed" -#ifdef darwin_HOST_OS - [ "-i", "''" -#else - [ "-i" -#endif - , "-e", "'s/([0-9]*,[0-9]*)-([0-9]*,[0-9]*)/(0,0)-(0,0)/g'" - , "-e", "'s/:[0-9][0-9]*:[0-9][0-9]*/:0:0/g'" - , "-e", "'s/:[0-9]*:[0-9]*-[0-9]*/:0:0:/g'" - , "-e", "'s/[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]/0123456789/g'" - , "-e", "'s/[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]/0123456789876543210/g'" - , "-e", "'s/[!#$%&*+./>]\\{10\\}/%%%%%%%%%%/g'" - , "-e", "'s/[!#$%&*+./>]\\{19\\}/%%%%%%%%%%%%%%%%%%%/g'" - , file - ] - -buildGoldenFile :: FilePath -> FilePath -> IO () -buildGoldenFile templateFilePath goldenFilePath = do - hGoldenFile <- openFile goldenFilePath WriteMode - runProcessWithOpts (UseHandle hGoldenFile) "awk" - [ "-f", "tests/compile-and-dump/buildGoldenFiles.awk" - , templateFilePath - ] - -runProcessWithOpts :: StdStream -> String -> [String] -> IO () -runProcessWithOpts stdout program opts = do - (_, _, Just serr, pid) <- - createProcess (proc "bash" ["-c", (intercalate " " (program : opts))]) - { std_out = stdout - , std_err = CreatePipe } - ecode <- waitForProcess pid - case ecode of - ExitSuccess -> return () - ExitFailure _ -> do - err <- hGetContents serr -- Text would be faster than String, but this is - -- a corner case so probably not worth it. - throw $ ProcessException ("Error when running " ++ program ++ ":\n" ++ err) - -cleanFiles :: IO () -cleanFiles = callCommand "rm -f tests/compile-and-dump/*/*.{hi,o}" diff --git a/tests/compile-and-dump/GradingClient/Database.ghc82.template b/tests/compile-and-dump/GradingClient/Database.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/GradingClient/Database.ghc82.template +++ /dev/null @@ -1,4784 +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 family Equals_0123456789876543210 (a :: Nat) (b :: Nat) :: Bool where - Equals_0123456789876543210 Zero Zero = TrueSym0 - Equals_0123456789876543210 (Succ a) (Succ b) = (:==) a b - Equals_0123456789876543210 (a :: Nat) (b :: Nat) = FalseSym0 - instance PEq Nat where - type (:==) (a :: Nat) (b :: Nat) = Equals_0123456789876543210 a b - type ZeroSym0 = Zero - type SuccSym1 (t :: Nat) = Succ t - instance SuppressUnusedWarnings SuccSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) SuccSym0KindInference) GHC.Tuple.()) - data SuccSym0 (l :: TyFun Nat Nat) - = forall arg. SameKind (Apply SuccSym0 arg) (SuccSym1 arg) => - SuccSym0KindInference - type instance Apply SuccSym0 l = Succ l - type family Compare_0123456789876543210 (a :: Nat) (a :: Nat) :: Ordering where - Compare_0123456789876543210 Zero Zero = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) '[] - Compare_0123456789876543210 (Succ a_0123456789876543210) (Succ b_0123456789876543210) = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) (Apply (Apply (:$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) '[]) - Compare_0123456789876543210 Zero (Succ _z_0123456789876543210) = LTSym0 - Compare_0123456789876543210 (Succ _z_0123456789876543210) Zero = GTSym0 - type Compare_0123456789876543210Sym2 (t :: Nat) (t :: Nat) = - Compare_0123456789876543210 t t - instance SuppressUnusedWarnings Compare_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Compare_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Compare_0123456789876543210Sym1 (l :: Nat) (l :: TyFun Nat Ordering) - = forall arg. SameKind (Apply (Compare_0123456789876543210Sym1 l) arg) (Compare_0123456789876543210Sym2 l arg) => - Compare_0123456789876543210Sym1KindInference - type instance Apply (Compare_0123456789876543210Sym1 l) l = Compare_0123456789876543210 l l - instance SuppressUnusedWarnings Compare_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Compare_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Compare_0123456789876543210Sym0 (l :: TyFun Nat (TyFun Nat Ordering - -> Type)) - = forall arg. SameKind (Apply Compare_0123456789876543210Sym0 arg) (Compare_0123456789876543210Sym1 arg) => - Compare_0123456789876543210Sym0KindInference - type instance Apply Compare_0123456789876543210Sym0 l = Compare_0123456789876543210Sym1 l - instance POrd Nat where - type Compare (a :: Nat) (a :: Nat) = Apply (Apply Compare_0123456789876543210Sym0 a) a - data instance Sing (z :: Nat) - = z ~ Zero => SZero | - forall (n :: Nat). z ~ Succ n => SSucc (Sing (n :: Nat)) - type SNat = (Sing :: Nat -> Type) - instance SingKind Nat where - type Demote Nat = Nat - fromSing SZero = Zero - fromSing (SSucc b) = Succ (fromSing b) - toSing Zero = SomeSing SZero - toSing (Succ b) - = case toSing b :: SomeSing Nat of { - SomeSing c -> SomeSing (SSucc c) } - instance SEq Nat where - (%:==) SZero SZero = STrue - (%:==) SZero (SSucc _) = SFalse - (%:==) (SSucc _) SZero = SFalse - (%:==) (SSucc a) (SSucc b) = ((%:==) a) b - instance SDecide Nat where - (%~) SZero SZero = Proved Refl - (%~) SZero (SSucc _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SSucc _) SZero - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SSucc a) (SSucc b) - = case ((%~) a) b of - Proved Refl -> Proved Refl - Disproved contra - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - instance SOrd Nat => SOrd Nat where - sCompare :: - forall (t1 :: Nat) (t2 :: Nat). - Sing t1 - -> Sing t2 - -> Sing (Apply (Apply (CompareSym0 :: TyFun Nat (TyFun Nat Ordering - -> Type) - -> Type) t1 :: TyFun Nat Ordering - -> Type) t2 :: Ordering) - 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 SingI Zero where - sing = SZero - instance SingI n => SingI (Succ (n :: Nat)) where - sing = SSucc sing -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 GHC.Types.[]) = True - attrNotIn (Attr name u) (Sch (Attr name' _ GHC.Types.: t)) - = ((name /= name') && ((attrNotIn ((Attr name) u)) (Sch t))) - disjoint :: Schema -> Schema -> Bool - disjoint (Sch GHC.Types.[]) _ = True - disjoint (Sch (h GHC.Types.: t)) s - = (((attrNotIn h) s) && ((disjoint (Sch t)) s)) - occurs :: [AChar] -> Schema -> Bool - occurs _ (Sch GHC.Types.[]) = False - occurs name (Sch (Attr name' _ GHC.Types.: attrs)) - = ((name == name') || ((occurs name) (Sch attrs))) - lookup :: [AChar] -> Schema -> U - lookup _ (Sch GHC.Types.[]) = undefined - lookup name (Sch (Attr name' u GHC.Types.: attrs)) - = if (name == name') then u else (lookup name) (Sch attrs) - type family Equals_0123456789876543210 (a :: U) (b :: U) :: Bool where - Equals_0123456789876543210 BOOL BOOL = TrueSym0 - Equals_0123456789876543210 STRING STRING = TrueSym0 - Equals_0123456789876543210 NAT NAT = TrueSym0 - Equals_0123456789876543210 (VEC a a) (VEC b b) = (:&&) ((:==) a b) ((:==) a b) - Equals_0123456789876543210 (a :: U) (b :: U) = FalseSym0 - instance PEq U where - type (:==) (a :: U) (b :: U) = Equals_0123456789876543210 a b - type BOOLSym0 = BOOL - type STRINGSym0 = STRING - type NATSym0 = NAT - type VECSym2 (t :: U) (t :: Nat) = VEC t t - instance SuppressUnusedWarnings VECSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) VECSym1KindInference) GHC.Tuple.()) - data VECSym1 (l :: U) (l :: TyFun Nat U) - = forall arg. SameKind (Apply (VECSym1 l) arg) (VECSym2 l arg) => - VECSym1KindInference - type instance Apply (VECSym1 l) l = VEC l l - instance SuppressUnusedWarnings VECSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) VECSym0KindInference) GHC.Tuple.()) - data VECSym0 (l :: TyFun U (TyFun Nat U -> Type)) - = forall arg. SameKind (Apply VECSym0 arg) (VECSym1 arg) => - VECSym0KindInference - type instance Apply VECSym0 l = VECSym1 l - type family Equals_0123456789876543210 (a :: AChar) (b :: AChar) :: Bool where - Equals_0123456789876543210 CA CA = TrueSym0 - Equals_0123456789876543210 CB CB = TrueSym0 - Equals_0123456789876543210 CC CC = TrueSym0 - Equals_0123456789876543210 CD CD = TrueSym0 - Equals_0123456789876543210 CE CE = TrueSym0 - Equals_0123456789876543210 CF CF = TrueSym0 - Equals_0123456789876543210 CG CG = TrueSym0 - Equals_0123456789876543210 CH CH = TrueSym0 - Equals_0123456789876543210 CI CI = TrueSym0 - Equals_0123456789876543210 CJ CJ = TrueSym0 - Equals_0123456789876543210 CK CK = TrueSym0 - Equals_0123456789876543210 CL CL = TrueSym0 - Equals_0123456789876543210 CM CM = TrueSym0 - Equals_0123456789876543210 CN CN = TrueSym0 - Equals_0123456789876543210 CO CO = TrueSym0 - Equals_0123456789876543210 CP CP = TrueSym0 - Equals_0123456789876543210 CQ CQ = TrueSym0 - Equals_0123456789876543210 CR CR = TrueSym0 - Equals_0123456789876543210 CS CS = TrueSym0 - Equals_0123456789876543210 CT CT = TrueSym0 - Equals_0123456789876543210 CU CU = TrueSym0 - Equals_0123456789876543210 CV CV = TrueSym0 - Equals_0123456789876543210 CW CW = TrueSym0 - Equals_0123456789876543210 CX CX = TrueSym0 - Equals_0123456789876543210 CY CY = TrueSym0 - Equals_0123456789876543210 CZ CZ = TrueSym0 - Equals_0123456789876543210 (a :: AChar) (b :: AChar) = FalseSym0 - instance PEq AChar where - type (:==) (a :: AChar) (b :: AChar) = Equals_0123456789876543210 a b - type CASym0 = CA - type CBSym0 = CB - type CCSym0 = CC - type CDSym0 = CD - type CESym0 = CE - type CFSym0 = CF - type CGSym0 = CG - type CHSym0 = CH - type CISym0 = CI - type CJSym0 = CJ - type CKSym0 = CK - type CLSym0 = CL - type CMSym0 = CM - type CNSym0 = CN - type COSym0 = CO - type CPSym0 = CP - type CQSym0 = CQ - type CRSym0 = CR - type CSSym0 = CS - type CTSym0 = CT - type CUSym0 = CU - type CVSym0 = CV - type CWSym0 = CW - type CXSym0 = CX - type CYSym0 = CY - type CZSym0 = CZ - type AttrSym2 (t :: [AChar]) (t :: U) = Attr t t - instance SuppressUnusedWarnings AttrSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) AttrSym1KindInference) GHC.Tuple.()) - data AttrSym1 (l :: [AChar]) (l :: TyFun U Attribute) - = forall arg. SameKind (Apply (AttrSym1 l) arg) (AttrSym2 l arg) => - AttrSym1KindInference - type instance Apply (AttrSym1 l) l = Attr l l - instance SuppressUnusedWarnings AttrSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) AttrSym0KindInference) GHC.Tuple.()) - data AttrSym0 (l :: TyFun [AChar] (TyFun U Attribute -> Type)) - = forall arg. SameKind (Apply AttrSym0 arg) (AttrSym1 arg) => - AttrSym0KindInference - type instance Apply AttrSym0 l = AttrSym1 l - type SchSym1 (t :: [Attribute]) = Sch t - instance SuppressUnusedWarnings SchSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) SchSym0KindInference) GHC.Tuple.()) - data SchSym0 (l :: TyFun [Attribute] Schema) - = forall arg. SameKind (Apply SchSym0 arg) (SchSym1 arg) => - SchSym0KindInference - type instance Apply SchSym0 l = Sch l - type Let0123456789876543210Scrutinee_0123456789876543210Sym4 t t t t = - Let0123456789876543210Scrutinee_0123456789876543210 t t t t - instance SuppressUnusedWarnings Let0123456789876543210Scrutinee_0123456789876543210Sym3 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) - Let0123456789876543210Scrutinee_0123456789876543210Sym3KindInference) - GHC.Tuple.()) - data Let0123456789876543210Scrutinee_0123456789876543210Sym3 l l l l - = forall arg. SameKind (Apply (Let0123456789876543210Scrutinee_0123456789876543210Sym3 l l l) arg) (Let0123456789876543210Scrutinee_0123456789876543210Sym4 l l l arg) => - Let0123456789876543210Scrutinee_0123456789876543210Sym3KindInference - type instance Apply (Let0123456789876543210Scrutinee_0123456789876543210Sym3 l l l) l = Let0123456789876543210Scrutinee_0123456789876543210 l l l l - instance SuppressUnusedWarnings Let0123456789876543210Scrutinee_0123456789876543210Sym2 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) - Let0123456789876543210Scrutinee_0123456789876543210Sym2KindInference) - GHC.Tuple.()) - data Let0123456789876543210Scrutinee_0123456789876543210Sym2 l l l - = forall arg. SameKind (Apply (Let0123456789876543210Scrutinee_0123456789876543210Sym2 l l) arg) (Let0123456789876543210Scrutinee_0123456789876543210Sym3 l l arg) => - Let0123456789876543210Scrutinee_0123456789876543210Sym2KindInference - type instance Apply (Let0123456789876543210Scrutinee_0123456789876543210Sym2 l l) l = Let0123456789876543210Scrutinee_0123456789876543210Sym3 l l l - instance SuppressUnusedWarnings Let0123456789876543210Scrutinee_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) - Let0123456789876543210Scrutinee_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Let0123456789876543210Scrutinee_0123456789876543210Sym1 l l - = forall arg. SameKind (Apply (Let0123456789876543210Scrutinee_0123456789876543210Sym1 l) arg) (Let0123456789876543210Scrutinee_0123456789876543210Sym2 l arg) => - Let0123456789876543210Scrutinee_0123456789876543210Sym1KindInference - type instance Apply (Let0123456789876543210Scrutinee_0123456789876543210Sym1 l) l = Let0123456789876543210Scrutinee_0123456789876543210Sym2 l l - instance SuppressUnusedWarnings Let0123456789876543210Scrutinee_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Let0123456789876543210Scrutinee_0123456789876543210Sym0 l - = forall arg. SameKind (Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 arg) (Let0123456789876543210Scrutinee_0123456789876543210Sym1 arg) => - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference - type instance Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 l = Let0123456789876543210Scrutinee_0123456789876543210Sym1 l - type family Let0123456789876543210Scrutinee_0123456789876543210 name name' u attrs where - Let0123456789876543210Scrutinee_0123456789876543210 name name' u attrs = Apply (Apply (:==$) name) name' - type family Case_0123456789876543210 name name' u attrs t where - Case_0123456789876543210 name name' u attrs True = u - Case_0123456789876543210 name name' u attrs False = Apply (Apply LookupSym0 name) (Apply SchSym0 attrs) - type LookupSym2 (t :: [AChar]) (t :: Schema) = Lookup t t - instance SuppressUnusedWarnings LookupSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) LookupSym1KindInference) GHC.Tuple.()) - data LookupSym1 (l :: [AChar]) (l :: TyFun Schema U) - = forall arg. SameKind (Apply (LookupSym1 l) arg) (LookupSym2 l arg) => - LookupSym1KindInference - type instance Apply (LookupSym1 l) l = Lookup l l - instance SuppressUnusedWarnings LookupSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) LookupSym0KindInference) GHC.Tuple.()) - data LookupSym0 (l :: TyFun [AChar] (TyFun Schema U -> Type)) - = forall arg. SameKind (Apply LookupSym0 arg) (LookupSym1 arg) => - LookupSym0KindInference - type instance Apply LookupSym0 l = LookupSym1 l - type OccursSym2 (t :: [AChar]) (t :: Schema) = Occurs t t - instance SuppressUnusedWarnings OccursSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) OccursSym1KindInference) GHC.Tuple.()) - data OccursSym1 (l :: [AChar]) (l :: TyFun Schema Bool) - = forall arg. SameKind (Apply (OccursSym1 l) arg) (OccursSym2 l arg) => - OccursSym1KindInference - type instance Apply (OccursSym1 l) l = Occurs l l - instance SuppressUnusedWarnings OccursSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) OccursSym0KindInference) GHC.Tuple.()) - data OccursSym0 (l :: TyFun [AChar] (TyFun Schema Bool -> Type)) - = forall arg. SameKind (Apply OccursSym0 arg) (OccursSym1 arg) => - OccursSym0KindInference - type instance Apply OccursSym0 l = OccursSym1 l - type AttrNotInSym2 (t :: Attribute) (t :: Schema) = AttrNotIn t t - instance SuppressUnusedWarnings AttrNotInSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) AttrNotInSym1KindInference) GHC.Tuple.()) - data AttrNotInSym1 (l :: Attribute) (l :: TyFun Schema Bool) - = forall arg. SameKind (Apply (AttrNotInSym1 l) arg) (AttrNotInSym2 l arg) => - AttrNotInSym1KindInference - type instance Apply (AttrNotInSym1 l) l = AttrNotIn l l - instance SuppressUnusedWarnings AttrNotInSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) AttrNotInSym0KindInference) GHC.Tuple.()) - data AttrNotInSym0 (l :: TyFun Attribute (TyFun Schema Bool - -> Type)) - = forall arg. SameKind (Apply AttrNotInSym0 arg) (AttrNotInSym1 arg) => - AttrNotInSym0KindInference - type instance Apply AttrNotInSym0 l = AttrNotInSym1 l - type DisjointSym2 (t :: Schema) (t :: Schema) = Disjoint t t - instance SuppressUnusedWarnings DisjointSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) DisjointSym1KindInference) GHC.Tuple.()) - data DisjointSym1 (l :: Schema) (l :: TyFun Schema Bool) - = forall arg. SameKind (Apply (DisjointSym1 l) arg) (DisjointSym2 l arg) => - DisjointSym1KindInference - type instance Apply (DisjointSym1 l) l = Disjoint l l - instance SuppressUnusedWarnings DisjointSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) DisjointSym0KindInference) GHC.Tuple.()) - data DisjointSym0 (l :: TyFun Schema (TyFun Schema Bool -> Type)) - = forall arg. SameKind (Apply DisjointSym0 arg) (DisjointSym1 arg) => - DisjointSym0KindInference - type instance Apply DisjointSym0 l = DisjointSym1 l - type AppendSym2 (t :: Schema) (t :: Schema) = Append t t - instance SuppressUnusedWarnings AppendSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) AppendSym1KindInference) GHC.Tuple.()) - data AppendSym1 (l :: Schema) (l :: TyFun Schema Schema) - = forall arg. SameKind (Apply (AppendSym1 l) arg) (AppendSym2 l arg) => - AppendSym1KindInference - type instance Apply (AppendSym1 l) l = Append l l - instance SuppressUnusedWarnings AppendSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) AppendSym0KindInference) GHC.Tuple.()) - data AppendSym0 (l :: TyFun Schema (TyFun Schema Schema -> Type)) - = forall arg. SameKind (Apply AppendSym0 arg) (AppendSym1 arg) => - AppendSym0KindInference - type instance Apply AppendSym0 l = AppendSym1 l - type family Lookup (a :: [AChar]) (a :: Schema) :: U where - Lookup _z_0123456789876543210 (Sch '[]) = Any - Lookup name (Sch ((:) (Attr name' u) attrs)) = Case_0123456789876543210 name name' u attrs (Let0123456789876543210Scrutinee_0123456789876543210Sym4 name name' u attrs) - type family Occurs (a :: [AChar]) (a :: Schema) :: Bool where - Occurs _z_0123456789876543210 (Sch '[]) = FalseSym0 - Occurs name (Sch ((:) (Attr name' _z_0123456789876543210) attrs)) = Apply (Apply (:||$) (Apply (Apply (:==$) name) name')) (Apply (Apply OccursSym0 name) (Apply SchSym0 attrs)) - type family AttrNotIn (a :: Attribute) (a :: Schema) :: Bool where - AttrNotIn _z_0123456789876543210 (Sch '[]) = TrueSym0 - AttrNotIn (Attr name u) (Sch ((:) (Attr name' _z_0123456789876543210) t)) = Apply (Apply (:&&$) (Apply (Apply (:/=$) name) name')) (Apply (Apply AttrNotInSym0 (Apply (Apply AttrSym0 name) u)) (Apply SchSym0 t)) - type family Disjoint (a :: Schema) (a :: Schema) :: Bool where - Disjoint (Sch '[]) _z_0123456789876543210 = TrueSym0 - Disjoint (Sch ((:) h t)) s = Apply (Apply (:&&$) (Apply (Apply AttrNotInSym0 h) s)) (Apply (Apply DisjointSym0 (Apply SchSym0 t)) s) - type family Append (a :: Schema) (a :: Schema) :: Schema where - Append (Sch s1) (Sch s2) = Apply SchSym0 (Apply (Apply (:++$) s1) s2) - sLookup :: - forall (t :: [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) - sAttrNotIn :: - forall (t :: Attribute) (t :: Schema). - Sing t -> Sing t -> Sing (Apply (Apply AttrNotInSym0 t) t :: Bool) - sDisjoint :: - forall (t :: Schema) (t :: Schema). - Sing t -> Sing t -> Sing (Apply (Apply DisjointSym0 t) t :: Bool) - sAppend :: - forall (t :: Schema) (t :: Schema). - Sing t -> Sing t -> Sing (Apply (Apply AppendSym0 t) t :: Schema) - sLookup _ (SSch SNil) = undefined - 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 case sScrutinee_0123456789876543210 of - STrue -> sU - SFalse - -> (applySing ((applySing ((singFun2 @LookupSym0) sLookup)) sName)) - ((applySing ((singFun1 @SchSym0) SSch)) sAttrs) :: - Sing (Case_0123456789876543210 name name' u attrs (Let0123456789876543210Scrutinee_0123456789876543210Sym4 name name' u attrs) :: U) - 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)) - 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)) - 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) - sAppend (SSch (sS1 :: Sing s1)) (SSch (sS2 :: Sing s2)) - = (applySing ((singFun1 @SchSym0) SSch)) - ((applySing ((applySing ((singFun2 @(:++$)) (%:++))) sS1)) sS2) - data instance Sing (z :: U) - = z ~ BOOL => SBOOL | - z ~ STRING => SSTRING | - z ~ NAT => SNAT | - forall (n :: U) (n :: Nat). z ~ VEC n n => - SVEC (Sing (n :: U)) (Sing (n :: Nat)) - type SU = (Sing :: U -> Type) - 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 b) - = case - (GHC.Tuple.(,) (toSing b :: SomeSing U)) (toSing b :: SomeSing Nat) - of { - GHC.Tuple.(,) (SomeSing c) (SomeSing c) -> SomeSing ((SVEC c) c) } - instance 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 where - (%~) SBOOL SBOOL = Proved Refl - (%~) SBOOL SSTRING - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SBOOL SNAT - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SBOOL (SVEC _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SSTRING SBOOL - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SSTRING SSTRING = Proved Refl - (%~) SSTRING SNAT - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SSTRING (SVEC _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SNAT SBOOL - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SNAT SSTRING - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SNAT SNAT = Proved Refl - (%~) SNAT (SVEC _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SVEC _ _) SBOOL - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SVEC _ _) SSTRING - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SVEC _ _) SNAT - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SVEC a a) (SVEC b b) - = case (GHC.Tuple.(,) (((%~) a) b)) (((%~) a) b) of - GHC.Tuple.(,) (Proved Refl) (Proved Refl) -> Proved Refl - GHC.Tuple.(,) (Disproved contra) _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - GHC.Tuple.(,) _ (Disproved contra) - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - data instance Sing (z :: AChar) - = z ~ CA => SCA | - z ~ CB => SCB | - z ~ CC => SCC | - z ~ CD => SCD | - z ~ CE => SCE | - z ~ CF => SCF | - z ~ CG => SCG | - z ~ CH => SCH | - z ~ CI => SCI | - z ~ CJ => SCJ | - z ~ CK => SCK | - z ~ CL => SCL | - z ~ CM => SCM | - z ~ CN => SCN | - z ~ CO => SCO | - z ~ CP => SCP | - z ~ CQ => SCQ | - z ~ CR => SCR | - z ~ CS => SCS | - z ~ CT => SCT | - z ~ CU => SCU | - z ~ CV => SCV | - z ~ CW => SCW | - z ~ CX => SCX | - z ~ CY => SCY | - z ~ CZ => SCZ - type SAChar = (Sing :: AChar -> Type) - 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 - 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 { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCC - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCD - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCE - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCF - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCG - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCH - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCI - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCJ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCK - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCL - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCM - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCN - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCO - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCP - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCQ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCR - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCS - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCT - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCU - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCV - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCW - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCX - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCY - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCA SCZ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCA - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCB = Proved Refl - (%~) SCB SCC - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCD - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCE - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCF - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCG - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCH - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCI - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCJ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCK - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCL - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCM - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCN - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCO - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCP - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCQ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCR - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCS - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCT - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCU - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCV - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCW - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCX - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCY - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCB SCZ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCA - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCB - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCC = Proved Refl - (%~) SCC SCD - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCE - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCF - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCG - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCH - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCI - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCJ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCK - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCL - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCM - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCN - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCO - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCP - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCQ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCR - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCS - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCT - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCU - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCV - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCW - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCX - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCY - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCC SCZ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCA - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCB - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCC - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCD = Proved Refl - (%~) SCD SCE - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCF - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCG - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCH - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCI - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCJ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCK - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCL - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCM - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCN - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCO - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCP - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCQ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCR - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCS - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCT - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCU - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCV - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCW - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCX - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCY - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCD SCZ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCA - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCB - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCC - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCD - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCE = Proved Refl - (%~) SCE SCF - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCG - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCH - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCI - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCJ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCK - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCL - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCM - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCN - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCO - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCP - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCQ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCR - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCS - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCT - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCU - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCV - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCW - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCX - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCY - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCE SCZ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCA - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCB - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCC - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCD - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCE - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCF = Proved Refl - (%~) SCF SCG - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCH - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCI - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCJ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCK - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCL - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCM - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCN - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCO - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCP - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCQ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCR - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCS - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCT - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCU - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCV - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCW - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCX - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCY - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCF SCZ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCA - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCB - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCC - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCD - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCE - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCF - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCG = Proved Refl - (%~) SCG SCH - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCI - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCJ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCK - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCL - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCM - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCN - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCO - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCP - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCQ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCR - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCS - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCT - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCU - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCV - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCW - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCX - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCY - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCG SCZ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCA - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCB - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCC - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCD - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCE - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCF - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCG - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCH = Proved Refl - (%~) SCH SCI - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCJ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCK - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCL - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCM - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCN - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCO - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCP - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCQ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCR - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCS - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCT - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCU - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCV - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCW - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCX - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCY - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCH SCZ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCA - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCB - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCC - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCD - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCE - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCF - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCG - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCH - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCI = Proved Refl - (%~) SCI SCJ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCK - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCL - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCM - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCN - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCO - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCP - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCQ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCR - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCS - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCT - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCU - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCV - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCW - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCX - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCY - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCI SCZ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCA - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCB - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCC - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCD - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCE - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCF - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCG - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCH - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCI - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCJ = Proved Refl - (%~) SCJ SCK - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCL - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCM - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCN - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCO - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCP - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCQ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCR - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCS - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCT - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCU - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCV - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCW - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCX - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCY - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCJ SCZ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCA - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCB - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCC - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCD - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCE - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCF - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCG - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCH - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCI - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCJ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCK = Proved Refl - (%~) SCK SCL - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCM - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCN - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCO - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCP - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCQ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCR - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCS - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCT - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCU - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCV - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCW - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCX - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCY - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCK SCZ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCA - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCB - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCC - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCD - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCE - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCF - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCG - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCH - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCI - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCJ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCK - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCL = Proved Refl - (%~) SCL SCM - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCN - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCO - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCP - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCQ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCR - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCS - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCT - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCU - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCV - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCW - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCX - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCY - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCL SCZ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCA - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCB - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCC - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCD - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCE - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCF - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCG - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCH - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCI - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCJ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCK - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCL - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCM = Proved Refl - (%~) SCM SCN - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCO - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCP - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCQ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCR - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCS - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCT - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCU - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCV - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCW - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCX - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCY - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCM SCZ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCA - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCB - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCC - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCD - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCE - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCF - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCG - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCH - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCI - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCJ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCK - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCL - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCM - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCN = Proved Refl - (%~) SCN SCO - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCP - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCQ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCR - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCS - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCT - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCU - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCV - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCW - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCX - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCY - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCN SCZ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCA - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCB - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCC - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCD - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCE - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCF - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCG - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCH - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCI - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCJ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCK - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCL - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCM - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCN - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCO = Proved Refl - (%~) SCO SCP - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCQ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCR - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCS - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCT - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCU - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCV - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCW - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCX - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCY - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCO SCZ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCA - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCB - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCC - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCD - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCE - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCF - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCG - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCH - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCI - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCJ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCK - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCL - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCM - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCN - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCO - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCP = Proved Refl - (%~) SCP SCQ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCR - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCS - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCT - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCU - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCV - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCW - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCX - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCY - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCP SCZ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCA - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCB - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCC - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCD - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCE - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCF - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCG - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCH - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCI - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCJ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCK - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCL - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCM - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCN - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCO - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCP - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCQ = Proved Refl - (%~) SCQ SCR - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCS - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCT - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCU - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCV - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCW - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCX - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCY - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCQ SCZ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCA - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCB - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCC - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCD - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCE - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCF - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCG - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCH - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCI - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCJ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCK - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCL - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCM - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCN - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCO - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCP - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCQ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCR = Proved Refl - (%~) SCR SCS - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCT - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCU - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCV - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCW - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCX - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCY - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCR SCZ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCA - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCB - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCC - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCD - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCE - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCF - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCG - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCH - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCI - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCJ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCK - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCL - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCM - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCN - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCO - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCP - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCQ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCR - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCS = Proved Refl - (%~) SCS SCT - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCU - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCV - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCW - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCX - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCY - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCS SCZ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCA - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCB - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCC - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCD - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCE - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCF - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCG - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCH - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCI - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCJ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCK - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCL - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCM - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCN - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCO - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCP - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCQ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCR - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCS - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCT = Proved Refl - (%~) SCT SCU - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCV - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCW - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCX - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCY - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCT SCZ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCA - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCB - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCC - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCD - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCE - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCF - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCG - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCH - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCI - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCJ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCK - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCL - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCM - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCN - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCO - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCP - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCQ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCR - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCS - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCT - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCU = Proved Refl - (%~) SCU SCV - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCW - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCX - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCY - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCU SCZ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCA - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCB - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCC - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCD - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCE - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCF - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCG - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCH - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCI - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCJ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCK - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCL - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCM - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCN - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCO - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCP - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCQ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCR - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCS - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCT - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCU - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCV = Proved Refl - (%~) SCV SCW - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCX - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCY - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCV SCZ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCA - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCB - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCC - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCD - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCE - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCF - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCG - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCH - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCI - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCJ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCK - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCL - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCM - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCN - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCO - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCP - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCQ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCR - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCS - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCT - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCU - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCV - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCW = Proved Refl - (%~) SCW SCX - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCY - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCW SCZ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCA - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCB - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCC - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCD - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCE - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCF - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCG - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCH - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCI - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCJ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCK - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCL - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCM - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCN - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCO - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCP - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCQ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCR - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCS - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCT - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCU - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCV - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCW - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCX = Proved Refl - (%~) SCX SCY - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCX SCZ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCA - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCB - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCC - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCD - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCE - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCF - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCG - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCH - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCI - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCJ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCK - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCL - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCM - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCN - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCO - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCP - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCQ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCR - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCS - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCT - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCU - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCV - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCW - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCX - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCY SCY = Proved Refl - (%~) SCY SCZ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCA - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCB - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCC - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCD - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCE - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCF - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCG - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCH - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCI - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCJ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCK - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCL - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCM - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCN - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCO - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCP - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCQ - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCR - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCS - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCT - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCU - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCV - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCW - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCX - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCY - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SCZ SCZ = Proved Refl - data instance Sing (z :: Attribute) - = forall (n :: [AChar]) (n :: U). z ~ Attr n n => - SAttr (Sing (n :: [AChar])) (Sing (n :: U)) - type SAttribute = (Sing :: Attribute -> Type) - instance SingKind Attribute where - type Demote Attribute = Attribute - fromSing (SAttr b b) = (Attr (fromSing b)) (fromSing b) - toSing (Attr b b) - = case - (GHC.Tuple.(,) (toSing b :: SomeSing [AChar])) - (toSing b :: SomeSing U) - of { - GHC.Tuple.(,) (SomeSing c) (SomeSing c) -> SomeSing ((SAttr c) c) } - data instance Sing (z :: Schema) - = forall (n :: [Attribute]). z ~ Sch n => - SSch (Sing (n :: [Attribute])) - type SSchema = (Sing :: Schema -> Type) - instance SingKind Schema where - type Demote Schema = Schema - fromSing (SSch b) = Sch (fromSing b) - toSing (Sch b) - = case toSing b :: SomeSing [Attribute] of { - SomeSing c -> SomeSing (SSch c) } - instance SingI BOOL where - sing = SBOOL - instance SingI STRING where - sing = SSTRING - instance SingI NAT where - sing = SNAT - instance (SingI n, SingI n) => - SingI (VEC (n :: U) (n :: Nat)) where - sing = (SVEC sing) sing - instance SingI CA where - sing = SCA - instance SingI CB where - sing = SCB - instance SingI CC where - sing = SCC - instance SingI CD where - sing = SCD - instance SingI CE where - sing = SCE - instance SingI CF where - sing = SCF - instance SingI CG where - sing = SCG - instance SingI CH where - sing = SCH - instance SingI CI where - sing = SCI - instance SingI CJ where - sing = SCJ - instance SingI CK where - sing = SCK - instance SingI CL where - sing = SCL - instance SingI CM where - sing = SCM - instance SingI CN where - sing = SCN - instance SingI CO where - sing = SCO - instance SingI CP where - sing = SCP - instance SingI CQ where - sing = SCQ - instance SingI CR where - sing = SCR - instance SingI CS where - sing = SCS - instance SingI CT where - sing = SCT - instance SingI CU where - sing = SCU - instance SingI CV where - sing = SCV - instance SingI CW where - sing = SCW - instance SingI CX where - sing = SCX - instance SingI CY where - sing = SCY - instance SingI CZ where - sing = SCZ - instance (SingI n, SingI n) => - SingI (Attr (n :: [AChar]) (n :: U)) where - sing = (SAttr sing) sing - instance SingI n => SingI (Sch (n :: [Attribute])) where - sing = SSch sing -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,557 +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, CPP, InstanceSigs #-} -{-# OPTIONS_GHC -fno-warn-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.SuppressUnusedWarnings -import Data.Singletons.TH -import Control.Monad -import Data.List hiding ( tail ) -import Data.Kind - -#ifdef MODERN_MTL -import Control.Monad.Except ( throwError ) -#else -import Control.Monad.Error ( throwError ) -#endif - - -$(singletons [d| - -- Basic Nat type - data Nat = Zero | Succ Nat deriving (Eq, Ord) - |]) - --- Conversions to any from Integers -fromNat :: Nat -> Integer -fromNat Zero = 0 -fromNat (Succ n) = (fromNat n) + 1 - -toNat :: Integer -> Nat -toNat 0 = Zero -toNat n | n > 0 = Succ (toNat (n - 1)) -toNat _ = error "Converting negative to Nat" - --- Display and read Nats using decimal digits -instance Show Nat where - show = show . fromNat -instance Read Nat where - readsPrec n s = map (\(a,rest) -> (toNat a,rest)) $ readsPrec n s - -$(singletons [d| - -- Our "U"niverse of types. These types can be stored in our database. - data U = BOOL - | STRING - | NAT - | VEC U Nat deriving (Read, Eq, Show) - - -- A re-definition of Char as an algebraic data type. - -- This is necessary to allow for promotion and type-level Strings. - data AChar = CA | CB | CC | CD | CE | CF | CG | CH | CI - | CJ | CK | CL | CM | CN | CO | CP | CQ | CR - | CS | CT | CU | CV | CW | CX | CY | CZ - deriving (Read, Show, Eq) - - -- A named attribute in our database - data Attribute = Attr [AChar] U - - -- A schema is an ordered list of named attributes - data Schema = Sch [Attribute] - - -- append two schemas - append :: Schema -> Schema -> Schema - append (Sch s1) (Sch s2) = Sch (s1 ++ s2) - - -- predicate to check that a schema is free of a certain attribute - attrNotIn :: Attribute -> Schema -> Bool - attrNotIn _ (Sch []) = True - attrNotIn (Attr name u) (Sch ((Attr name' _) : t)) = - (name /= name') && (attrNotIn (Attr name u) (Sch t)) - - -- predicate to check that two schemas are disjoint - disjoint :: Schema -> Schema -> Bool - disjoint (Sch []) _ = True - disjoint (Sch (h : t)) s = (attrNotIn h s) && (disjoint (Sch t) s) - - -- predicate to check if a name occurs in a schema - occurs :: [AChar] -> Schema -> Bool - occurs _ (Sch []) = False - occurs name (Sch ((Attr name' _) : attrs)) = - name == name' || occurs name (Sch attrs) - - -- looks up an element type from a schema - lookup :: [AChar] -> Schema -> U - lookup _ (Sch []) = undefined - lookup name (Sch ((Attr name' u) : attrs)) = - if name == name' then u else lookup name (Sch attrs) - |]) - --- The El type family gives us the type associated with a constructor --- of U: -type family El (u :: U) :: * -type instance El BOOL = Bool -type instance El STRING = String -type instance El NAT = Nat -type instance El (VEC u n) = Vec (El u) n - --- Length-indexed vectors -data Vec :: * -> Nat -> * where - VNil :: Vec a Zero - VCons :: a -> Vec a n -> Vec a (Succ n) - --- Read instances are keyed by the index of the vector to aid in parsing -instance Read (Vec a Zero) where - readsPrec _ s = [(VNil, s)] -instance (Read a, Read (Vec a n)) => Read (Vec a (Succ n)) where - readsPrec n s = do - (a, rest) <- readsPrec n s - (tail, restrest) <- readsPrec n rest - return (VCons a tail, restrest) - --- Because the Read instances are keyed by the length of the vector, --- it is not obvious to the compiler that all Vecs have a Read instance. --- We must make a short inductive proof of this fact. - --- First, we define a datatype to store the resulting instance, keyed --- by the parameters to Vec: -data VecReadInstance a n where - VecReadInstance :: Read (Vec a n) => VecReadInstance a n - --- Then, we make a function that produces an instance of Read for a --- Vec, given the datatype it is over and its length, both encoded --- using singleton types: -vecReadInstance :: Read (El u) => SU u -> SNat n -> VecReadInstance (El u) n -vecReadInstance _ SZero = VecReadInstance -vecReadInstance u (SSucc n) = case vecReadInstance u n of - VecReadInstance -> VecReadInstance - --- The Show instance can be straightforwardly defined: -instance Show a => Show (Vec a n) where - show VNil = "" - show (VCons h t) = (show h) ++ " " ++ (show t) - --- We need to be able to Read and Show elements of our database, so --- we must know that any type of the form (El u) for some (u :: U) --- has a Read and Show instance. Because we can't declare this instance --- directly (as, in general, declaring an instance of a type family --- would be unsound), we provide inductive proofs that these instances --- exist: -data ElUReadInstance u where - ElUReadInstance :: Read (El u) => ElUReadInstance u - -elUReadInstance :: Sing u -> ElUReadInstance u -elUReadInstance SBOOL = ElUReadInstance -elUReadInstance SSTRING = ElUReadInstance -elUReadInstance SNAT = ElUReadInstance -elUReadInstance (SVEC u n) = case elUReadInstance u of - ElUReadInstance -> case vecReadInstance u n of - VecReadInstance -> ElUReadInstance - -data ElUShowInstance u where - ElUShowInstance :: Show (El u) => ElUShowInstance u - -elUShowInstance :: Sing u -> ElUShowInstance u -elUShowInstance SBOOL = ElUShowInstance -elUShowInstance SSTRING = ElUShowInstance -elUShowInstance SNAT = ElUShowInstance -elUShowInstance (SVEC u _) = case elUShowInstance u of - ElUShowInstance -> ElUShowInstance - -showAttrProof :: Sing (Attr nm u) -> ElUShowInstance u -showAttrProof (SAttr _ u) = elUShowInstance u - --- A Row is one row of our database table, keyed by its schema. -data Row :: Schema -> * where - EmptyRow :: [Int] -> Row (Sch '[]) -- the Ints are the unique id of the row - ConsRow :: El u -> Row (Sch s) -> Row (Sch ((Attr name u) ': s)) - --- We build Show instances for a Row element by element: -instance Show (Row (Sch '[])) where - show (EmptyRow n) = "(id=" ++ (show n) ++ ")" -instance (Show (El u), Show (Row (Sch attrs))) => - Show (Row (Sch ((Attr name u) ': attrs))) where - show (ConsRow h t) = case t of - EmptyRow n -> (show h) ++ " (id=" ++ (show n) ++ ")" - _ -> (show h) ++ ", " ++ (show t) - --- A Handle in our system is an abstract handle to a loaded table. --- The constructor is not exported. In our simplistic case, we --- just store the list of rows. A more sophisticated implementation --- could store some identifier to the connection to an external database. -data Handle :: Schema -> * where - Handle :: [Row s] -> Handle s - --- The following functions parse our very simple flat file database format. - --- The file, with a name ending in ".dat", consists of a sequence of lines, --- where each line contains one entry in the table. There is no row separator; --- if a row contains n pieces of data, that row is represented in n lines in --- the file. - --- A schema is stored in a file of the same name, except ending in ".schema". --- Each line in the file is a constructor of U indicating the type of the --- corresponding row element. - --- Use Either for error handling in parsing functions -type ErrorM = Either String - --- This function is relatively uninteresting except for its use of --- pattern matching to introduce the instances of Read and Show for --- elements -readRow :: Int -> SSchema s -> [String] -> ErrorM (Row s, [String]) -readRow id (SSch SNil) strs = - return (EmptyRow [id], strs) -readRow _ (SSch (SCons _ _)) [] = - throwError "Ran out of data while processing row" -readRow id (SSch (SCons (SAttr _ u) at)) (sh:st) = do - (rowTail, strTail) <- readRow id (SSch at) st - case elUReadInstance u of - ElUReadInstance -> - let results = readsPrec 0 sh in - if null results - then throwError $ "No parse of " ++ sh ++ " as a " ++ - (show (fromSing u)) - else - let item = fst $ head results in - case elUShowInstance u of - ElUShowInstance -> return (ConsRow item rowTail, strTail) - -readRows :: SSchema s -> [String] -> [Row s] -> ErrorM [Row s] -readRows _ [] soFar = return soFar -readRows sch lst soFar = do - (row, rest) <- readRow (length soFar) sch lst - readRows sch rest (row : soFar) - --- Given the name of a database and its schema, return a handle to the --- database. -connect :: String -> SSchema s -> IO (Handle s) -connect name schema = do - schString <- readFile (name ++ ".schema") - let schEntries = lines schString - usFound = map read schEntries -- load schema just using "read" - (Sch attrs) = fromSing schema - usExpected = map (\(Attr _ u) -> u) attrs - unless (usFound == usExpected) -- compare found schema with expected - (fail "Expected schema does not match found schema") - dataString <- readFile (name ++ ".dat") - let dataEntries = lines dataString - result = readRows schema dataEntries [] -- read actual data - case result of - Left errorMsg -> fail errorMsg - Right rows -> return $ Handle rows - --- In order to define strongly-typed projection from a row, we need to have a notion --- that one schema is a subset of another. We permit the schemas to have their columns --- in different orders. We define this subset relation via two inductively defined --- propositions. In Haskell, these inductively defined propositions take the form of --- GADTs. In their original form, they would look like this: -{- -data InProof :: Attribute -> Schema -> * where - InElt :: InProof attr (Sch (attr ': schTail)) - InTail :: InProof attr (Sch attrs) -> InProof attr (Sch (a ': attrs)) - -data SubsetProof :: Schema -> Schema -> * where - SubsetEmpty :: SubsetProof (Sch '[]) s' - SubsetCons :: InProof attr s' -> SubsetProof (Sch attrs) s' -> - SubsetProof (Sch (attr ': attrs)) s' --} --- However, it would be convenient to users of the database library not to require --- building these proofs manually. So, we define type classes so that the compiler --- builds the proofs automatically. To make everything work well together, we also --- make the parameters to the proof GADT constructors implicit -- i.e. in the form --- of type class constraints. - -data InProof :: Attribute -> Schema -> * where - InElt :: InProof attr (Sch (attr ': schTail)) - InTail :: InC name u (Sch attrs) => InProof (Attr name u) (Sch (a ': attrs)) - -class InC (name :: [AChar]) (u :: U) (sch :: Schema) where - inProof :: InProof (Attr name u) sch -instance InC name u (Sch ((Attr name u) ': schTail)) where - inProof = InElt -instance InC name u (Sch attrs) => InC name u (Sch (a ': attrs)) where - inProof = InTail - -data SubsetProof :: Schema -> Schema -> * where - SubsetEmpty :: SubsetProof (Sch '[]) s' - SubsetCons :: (InC name u s', SubsetC (Sch attrs) s') => - SubsetProof (Sch ((Attr name u) ': attrs)) s' - -class SubsetC (s :: Schema) (s' :: Schema) where - subset :: SubsetProof s s' - -instance SubsetC (Sch '[]) s' where - subset = SubsetEmpty -instance (InC name u s', SubsetC (Sch attrs) s') => - SubsetC (Sch ((Attr name u) ': attrs)) s' where - subset = SubsetCons - --- To access the data in a structured (and well-typed!) way, we use --- an RA (short for Relational Algebra). An RA is indexed by the schema --- of the data it produces. -data RA :: Schema -> * where - -- The RA includes all data represented by the handle. - Read :: Handle s -> RA s - - -- The RA is a union of the rows represented by the two RAs provided. - -- Note that the schemas of the two RAs must be the same for this - -- constructor use to type-check. - Union :: RA s -> RA s -> RA s - - -- The RA is the list of rows in the first RA, omitting those in the - -- second. Once again, the schemas must match. - Diff :: RA s -> RA s -> RA s - - -- The RA is a Cartesian product of the two RAs provided. Note that - -- the schemas of the two provided RAs must be disjoint. - Product :: (Disjoint s s' ~ True, SingI s, SingI s') => - RA s -> RA s' -> RA (Append s s') - - -- The RA is a projection conforming to the schema provided. The - -- type-checker ensures that this schema is a subset of the data - -- included in the provided RA. - Project :: (SubsetC s' s, SingI s) => - SSchema s' -> RA s -> RA s' - - -- The RA contains only those rows of the provided RA for which - -- the provided expression evaluates to True. Note that the - -- schema of the provided RA and the resultant RA are the same - -- because the columns of data are the same. Also note that - -- the expression must return a Bool for this to type-check. - Select :: Expr s BOOL -> RA s -> RA s - --- Other constructors would be added in a more robust database --- implementation. - --- An Expr is used with the Select constructor to choose some --- subset of rows from a table. Expressions are indexed by the --- schema over which they operate and the return value they --- produce. -data Expr :: Schema -> U -> * where - -- Equality among two elements - Equal :: Eq (El u) => Expr s u -> Expr s u -> Expr s BOOL - - -- A less-than comparison among two Nats - LessThan :: Expr s NAT -> Expr s NAT -> Expr s BOOL - - -- A literal number - LiteralNat :: Integer -> Expr s NAT - - -- Projection in an expression -- evaluates to the value - -- of the named attribute. - Element :: (Occurs nm s ~ True) => - SSchema s -> Sing nm -> Expr s (Lookup nm s) - - -- A more robust implementation would include more constructors - --- Retrieves the id from a row. Ids are used when computing unions and --- differences. -getId :: Row s -> [Int] -getId (EmptyRow n) = n -getId (ConsRow _ t) = getId t - --- Changes the id of a row to a new value -changeId :: [Int] -> Row s -> Row s -changeId n (EmptyRow _) = EmptyRow n -changeId n (ConsRow h t) = ConsRow h (changeId n t) - --- Equality for rows based on ids. -eqRow :: Row s -> Row s -> Bool -eqRow r1 r2 = getId r1 == getId r2 - --- Equality for attributes based on names -eqAttr :: Attribute -> Attribute -> Bool -eqAttr (Attr nm _) (Attr nm' _) = nm == nm' - --- Appends two rows. There are three suspicious case statements -- they are --- suspicious in that the different branches are all exactly identical. Here --- is why they are needed: - --- The two case statements on r are necessary to deconstruct the index in the --- type of r; GHC does not use the fact that s' must be (Sch a') for some a'. --- By doing a case analysis on r, GHC uses the types given in the different --- constructors for Row, both of which give the form of s' as (Sch a'). This --- deconstruction is necessary for the type family Append to compute, because --- Append is defined only when its second argument is of the form (Sch a'). - --- The case statement on rowAppend t r is necessary to avoid potential --- overlapping instances for the SingRep class; the instances are needed for --- the call to ConsRow. The potential for overlapping instances comes from --- ambiguity in the component types of (Append s s'). By doing case analysis --- on rowAppend t r, these variables become fixed, and the potential for --- overlapping instances disappears. - --- We use the "cases" Singletons library operation to produce the case --- analysis in the first clause. This "cases" operation produces a case --- statement where each branch is identical and each constructor parameter --- is ignored. The "cases" operation does not work for the second clause --- because the code in the clause depends on definitions generated earlier. --- Template Haskell restricts certain dependencies between auto-generated --- code blocks to prevent the possibility of circular dependencies. --- In this case, if the $(singletons ...) blocks above were in a different --- module, the "cases" operation would be applicable here. - -$( return [] ) - -rowAppend :: Row s -> Row s' -> Row (Append s s') -rowAppend (EmptyRow n) r = $(cases ''Row [| r |] - [| changeId (n ++ (getId r)) r |]) -rowAppend (ConsRow h t) r = case r of - EmptyRow _ -> - case rowAppend t r of - EmptyRow _ -> ConsRow h (rowAppend t r) - ConsRow _ _ -> ConsRow h (rowAppend t r) - ConsRow _ _ -> - case rowAppend t r of - EmptyRow _ -> ConsRow h (rowAppend t r) - ConsRow _ _ -> ConsRow h (rowAppend t r) - --- Choose the elements of one list based on truth values in another -choose :: [Bool] -> [a] -> [a] -choose [] _ = [] -choose (False : btail) (_ : t) = choose btail t -choose (True : btail) (h : t) = h : (choose btail t) -choose _ [] = [] - --- The query function is the eliminator for an RA. It returns a list of --- rows containing the data produced by the RA. -query :: forall s. SingI s => RA s -> IO [Row s] -query (Read (Handle rows)) = return rows -query (Union ra rb) = do - rowsa <- query ra - rowsb <- query rb - return $ unionBy eqRow rowsa rowsb -query (Diff ra rb) = do - rowsa <- query ra - rowsb <- query rb - return $ deleteFirstsBy eqRow rowsa rowsb -query (Product ra rb) = do - rowsa <- query ra - rowsb <- query rb - return $ do -- entering the [] Monad - rowa <- rowsa - rowb <- rowsb - return $ rowAppend rowa rowb -query (Project sch ra) = do - rows <- query ra - return $ map (projectRow sch) rows - where -- The projectRow function uses the relationship encoded in the Subset - -- relation to project the requested columns of data in a type-safe manner. - - -- It recurs on the structure of the provided schema, creating the output - -- row to be in the same order as the input schema. This is necessary for - -- the output to type-check, as it is indexed by the input schema. - - -- We use explicit quantification to get access to scoped type variables. - projectRow :: forall (sch :: Schema) (s' :: Schema). - SubsetC sch s' => SSchema sch -> Row s' -> Row sch - - -- Base case: empty schema - projectRow (SSch SNil) r = EmptyRow (getId r) - - -- In the recursive case, we need to pattern-match on the proof that - -- the provided schema is a subset of the provided RA. We extract this - -- proof (of type SubsetProof s s') from the SubsetC instance using the - -- subset method. - projectRow (SSch (SCons attr tail)) r = - case subset :: SubsetProof sch s' of - - -- Because we know that the schema is non-empty, the only possibility - -- here is SubsetCons: - SubsetCons -> - let rtail = projectRow (SSch tail) r in - case attr of - SAttr _ u -> case elUShowInstance u of - ElUShowInstance -> ConsRow (extractElt attr r) rtail - - -- GHC correctly determines that this case is impossible if it is - -- not commented. - -- SubsetEmpty -> undefined <== IMPOSSIBLE - - -- However, the current version of GHC (7.5) does not suppress warnings - -- for incomplete pattern matches when the remaining cases are impossible. - -- So, we include this case (impossible to reach for any terminated value) - -- to suppress the warning. - - -- 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.ghc82.template b/tests/compile-and-dump/GradingClient/Main.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/GradingClient/Main.ghc82.template +++ /dev/null @@ -1,123 +0,0 @@ -GradingClient/Main.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| lastName, firstName, yearName, gradeName, majorName :: [AChar] - lastName = [CL, CA, CS, CT] - firstName = [CF, CI, CR, CS, CT] - yearName = [CY, CE, CA, CR] - gradeName = [CG, CR, CA, CD, CE] - majorName = [CM, CA, CJ, CO, CR] - gradingSchema :: Schema - gradingSchema - = Sch - [Attr lastName STRING, Attr firstName STRING, Attr yearName NAT, - Attr gradeName NAT, Attr majorName BOOL] - names :: Schema - names = Sch [Attr firstName STRING, Attr lastName STRING] |] - ======> - lastName :: [AChar] - firstName :: [AChar] - yearName :: [AChar] - gradeName :: [AChar] - majorName :: [AChar] - lastName = [CL, CA, CS, CT] - firstName = [CF, CI, CR, CS, CT] - yearName = [CY, CE, CA, CR] - gradeName = [CG, CR, CA, CD, CE] - majorName = [CM, CA, CJ, CO, CR] - gradingSchema :: Schema - gradingSchema - = Sch - [(Attr lastName) STRING, (Attr firstName) STRING, - (Attr yearName) NAT, (Attr gradeName) NAT, (Attr majorName) BOOL] - names :: Schema - names = Sch [(Attr firstName) STRING, (Attr lastName) STRING] - type MajorNameSym0 = MajorName - type GradeNameSym0 = GradeName - type YearNameSym0 = YearName - type FirstNameSym0 = FirstName - type LastNameSym0 = LastName - type GradingSchemaSym0 = GradingSchema - type NamesSym0 = Names - type family MajorName :: [AChar] where - = Apply (Apply (:$) CMSym0) (Apply (Apply (:$) CASym0) (Apply (Apply (:$) CJSym0) (Apply (Apply (:$) COSym0) (Apply (Apply (:$) CRSym0) '[])))) - type family GradeName :: [AChar] where - = Apply (Apply (:$) CGSym0) (Apply (Apply (:$) CRSym0) (Apply (Apply (:$) CASym0) (Apply (Apply (:$) CDSym0) (Apply (Apply (:$) CESym0) '[])))) - type family YearName :: [AChar] where - = Apply (Apply (:$) CYSym0) (Apply (Apply (:$) CESym0) (Apply (Apply (:$) CASym0) (Apply (Apply (:$) CRSym0) '[]))) - type family FirstName :: [AChar] where - = Apply (Apply (:$) CFSym0) (Apply (Apply (:$) CISym0) (Apply (Apply (:$) CRSym0) (Apply (Apply (:$) CSSym0) (Apply (Apply (:$) CTSym0) '[])))) - type family LastName :: [AChar] where - = Apply (Apply (:$) CLSym0) (Apply (Apply (:$) CASym0) (Apply (Apply (:$) CSSym0) (Apply (Apply (:$) CTSym0) '[]))) - type family GradingSchema :: Schema where - = Apply SchSym0 (Apply (Apply (:$) (Apply (Apply AttrSym0 LastNameSym0) STRINGSym0)) (Apply (Apply (:$) (Apply (Apply AttrSym0 FirstNameSym0) STRINGSym0)) (Apply (Apply (:$) (Apply (Apply AttrSym0 YearNameSym0) NATSym0)) (Apply (Apply (:$) (Apply (Apply AttrSym0 GradeNameSym0) NATSym0)) (Apply (Apply (:$) (Apply (Apply AttrSym0 MajorNameSym0) BOOLSym0)) '[]))))) - type family Names :: Schema where - = Apply SchSym0 (Apply (Apply (:$) (Apply (Apply AttrSym0 FirstNameSym0) STRINGSym0)) (Apply (Apply (:$) (Apply (Apply AttrSym0 LastNameSym0) STRINGSym0)) '[])) - sMajorName :: Sing (MajorNameSym0 :: [AChar]) - sGradeName :: Sing (GradeNameSym0 :: [AChar]) - sYearName :: Sing (YearNameSym0 :: [AChar]) - sFirstName :: Sing (FirstNameSym0 :: [AChar]) - sLastName :: Sing (LastNameSym0 :: [AChar]) - sGradingSchema :: Sing (GradingSchemaSym0 :: Schema) - sNames :: Sing (NamesSym0 :: Schema) - 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))) - 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))))) - 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)) 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.ghc82.template b/tests/compile-and-dump/InsertionSort/InsertionSortImp.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/InsertionSort/InsertionSortImp.ghc82.template +++ /dev/null @@ -1,177 +0,0 @@ -InsertionSort/InsertionSortImp.hs:(0,0)-(0,0): Splicing declarations - singletons [d| data Nat = Zero | Succ Nat |] - ======> - data Nat = Zero | Succ Nat - type ZeroSym0 = Zero - type SuccSym1 (t :: Nat) = Succ t - instance SuppressUnusedWarnings SuccSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) SuccSym0KindInference) GHC.Tuple.()) - data SuccSym0 (l :: TyFun Nat Nat) - = forall arg. SameKind (Apply SuccSym0 arg) (SuccSym1 arg) => - SuccSym0KindInference - type instance Apply SuccSym0 l = Succ l - data instance Sing (z :: Nat) - = z ~ Zero => SZero | - forall (n :: Nat). z ~ Succ n => SSucc (Sing (n :: Nat)) - type SNat = (Sing :: Nat -> GHC.Types.Type) - instance SingKind Nat where - type Demote Nat = Nat - fromSing SZero = Zero - fromSing (SSucc b) = Succ (fromSing b) - toSing Zero = SomeSing SZero - toSing (Succ b) - = 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 -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 GHC.Types.[] = [n] - insert n (h GHC.Types.: t) - = if (leq n) h then - (n GHC.Types.: (h GHC.Types.: t)) - else - (h GHC.Types.: ((insert n) t)) - insertionSort :: [Nat] -> [Nat] - insertionSort GHC.Types.[] = [] - insertionSort (h GHC.Types.: t) = (insert h) (insertionSort t) - type Let0123456789876543210Scrutinee_0123456789876543210Sym3 t t t = - Let0123456789876543210Scrutinee_0123456789876543210 t t t - instance SuppressUnusedWarnings Let0123456789876543210Scrutinee_0123456789876543210Sym2 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) - Let0123456789876543210Scrutinee_0123456789876543210Sym2KindInference) - GHC.Tuple.()) - data Let0123456789876543210Scrutinee_0123456789876543210Sym2 l l l - = forall arg. SameKind (Apply (Let0123456789876543210Scrutinee_0123456789876543210Sym2 l l) arg) (Let0123456789876543210Scrutinee_0123456789876543210Sym3 l l arg) => - Let0123456789876543210Scrutinee_0123456789876543210Sym2KindInference - type instance Apply (Let0123456789876543210Scrutinee_0123456789876543210Sym2 l l) l = Let0123456789876543210Scrutinee_0123456789876543210 l l l - instance SuppressUnusedWarnings Let0123456789876543210Scrutinee_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) - Let0123456789876543210Scrutinee_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Let0123456789876543210Scrutinee_0123456789876543210Sym1 l l - = forall arg. SameKind (Apply (Let0123456789876543210Scrutinee_0123456789876543210Sym1 l) arg) (Let0123456789876543210Scrutinee_0123456789876543210Sym2 l arg) => - Let0123456789876543210Scrutinee_0123456789876543210Sym1KindInference - type instance Apply (Let0123456789876543210Scrutinee_0123456789876543210Sym1 l) l = Let0123456789876543210Scrutinee_0123456789876543210Sym2 l l - instance SuppressUnusedWarnings Let0123456789876543210Scrutinee_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Let0123456789876543210Scrutinee_0123456789876543210Sym0 l - = forall arg. SameKind (Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 arg) (Let0123456789876543210Scrutinee_0123456789876543210Sym1 arg) => - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference - type instance Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 l = Let0123456789876543210Scrutinee_0123456789876543210Sym1 l - 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 LeqSym2 (t :: Nat) (t :: Nat) = Leq t t - instance SuppressUnusedWarnings LeqSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) LeqSym1KindInference) GHC.Tuple.()) - data LeqSym1 (l :: Nat) (l :: TyFun Nat Bool) - = forall arg. SameKind (Apply (LeqSym1 l) arg) (LeqSym2 l arg) => - LeqSym1KindInference - type instance Apply (LeqSym1 l) l = Leq l l - instance SuppressUnusedWarnings LeqSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) LeqSym0KindInference) GHC.Tuple.()) - data LeqSym0 (l :: TyFun Nat (TyFun Nat Bool -> GHC.Types.Type)) - = forall arg. SameKind (Apply LeqSym0 arg) (LeqSym1 arg) => - LeqSym0KindInference - type instance Apply LeqSym0 l = LeqSym1 l - type InsertSym2 (t :: Nat) (t :: [Nat]) = Insert t t - instance SuppressUnusedWarnings InsertSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) InsertSym1KindInference) GHC.Tuple.()) - data InsertSym1 (l :: Nat) (l :: TyFun [Nat] [Nat]) - = forall arg. SameKind (Apply (InsertSym1 l) arg) (InsertSym2 l arg) => - InsertSym1KindInference - type instance Apply (InsertSym1 l) l = Insert l l - instance SuppressUnusedWarnings InsertSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) InsertSym0KindInference) GHC.Tuple.()) - data InsertSym0 (l :: TyFun Nat (TyFun [Nat] [Nat] - -> GHC.Types.Type)) - = forall arg. SameKind (Apply InsertSym0 arg) (InsertSym1 arg) => - InsertSym0KindInference - type instance Apply InsertSym0 l = InsertSym1 l - type InsertionSortSym1 (t :: [Nat]) = InsertionSort t - instance SuppressUnusedWarnings InsertionSortSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) InsertionSortSym0KindInference) GHC.Tuple.()) - data InsertionSortSym0 (l :: TyFun [Nat] [Nat]) - = forall arg. SameKind (Apply InsertionSortSym0 arg) (InsertionSortSym1 arg) => - InsertionSortSym0KindInference - type instance Apply InsertionSortSym0 l = InsertionSort l - type family Leq (a :: Nat) (a :: Nat) :: Bool where - Leq Zero _z_0123456789876543210 = TrueSym0 - Leq (Succ _z_0123456789876543210) Zero = FalseSym0 - Leq (Succ a) (Succ b) = Apply (Apply LeqSym0 a) b - type family Insert (a :: Nat) (a :: [Nat]) :: [Nat] where - Insert n '[] = Apply (Apply (:$) n) '[] - Insert n ((:) h t) = Case_0123456789876543210 n h t (Let0123456789876543210Scrutinee_0123456789876543210Sym3 n h t) - type family InsertionSort (a :: [Nat]) :: [Nat] where - InsertionSort '[] = '[] - InsertionSort ((:) h t) = Apply (Apply InsertSym0 h) (Apply InsertionSortSym0 t) - sLeq :: - forall (t :: Nat) (t :: Nat). - Sing t -> Sing t -> Sing (Apply (Apply LeqSym0 t) t :: Bool) - sInsert :: - forall (t :: Nat) (t :: [Nat]). - Sing t -> Sing t -> Sing (Apply (Apply InsertSym0 t) t :: [Nat]) - sInsertionSort :: - forall (t :: [Nat]). - Sing t -> Sing (Apply InsertionSortSym0 t :: [Nat]) - sLeq SZero _ = STrue - sLeq (SSucc _) SZero = SFalse - sLeq (SSucc (sA :: Sing a)) (SSucc (sB :: Sing b)) - = (applySing ((applySing ((singFun2 @LeqSym0) sLeq)) sA)) sB - 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 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) :: - Sing (Case_0123456789876543210 n h t (Let0123456789876543210Scrutinee_0123456789876543210Sym3 n h t) :: [Nat]) - sInsertionSort SNil = SNil - sInsertionSort (SCons (sH :: Sing h) (sT :: Sing t)) - = (applySing ((applySing ((singFun2 @InsertSym0) sInsert)) sH)) - ((applySing ((singFun1 @InsertionSortSym0) sInsertionSort)) sT) 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] -> * 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.ghc82.template b/tests/compile-and-dump/Promote/Constructors.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Promote/Constructors.ghc82.template +++ /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 - type (:+$$$) (t :: Foo) (t :: Foo) = (:+) t t - instance SuppressUnusedWarnings (:+$$) where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) (:+$$###)) GHC.Tuple.()) - data (:+$$) (l :: Foo) (l :: TyFun Foo Foo) - = forall arg. SameKind (Apply ((:+$$) l) arg) ((:+$$$) l arg) => - (:+$$###) - type instance Apply ((:+$$) l) l = (:+) l l - instance SuppressUnusedWarnings (:+$) where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) (:+$###)) GHC.Tuple.()) - data (:+$) (l :: TyFun Foo (TyFun Foo Foo -> GHC.Types.Type)) - = forall arg. SameKind (Apply (:+$) arg) ((:+$$) arg) => (:+$###) - type instance Apply (:+$) l = (:+$$) l - type BarSym5 (t :: Bar) (t :: Bar) (t :: Bar) (t :: Bar) (t :: Foo) = - Bar t t t t t - instance SuppressUnusedWarnings BarSym4 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) BarSym4KindInference) GHC.Tuple.()) - data BarSym4 (l :: Bar) (l :: Bar) (l :: Bar) (l :: Bar) (l :: TyFun Foo Bar) - = forall arg. SameKind (Apply (BarSym4 l l l l) arg) (BarSym5 l l l l arg) => - BarSym4KindInference - type instance Apply (BarSym4 l l l l) l = Bar l l l l l - instance SuppressUnusedWarnings BarSym3 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) BarSym3KindInference) GHC.Tuple.()) - data BarSym3 (l :: Bar) (l :: Bar) (l :: Bar) (l :: TyFun Bar (TyFun Foo Bar - -> GHC.Types.Type)) - = forall arg. SameKind (Apply (BarSym3 l l l) arg) (BarSym4 l l l arg) => - BarSym3KindInference - type instance Apply (BarSym3 l l l) l = BarSym4 l l l l - instance SuppressUnusedWarnings BarSym2 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) BarSym2KindInference) GHC.Tuple.()) - data BarSym2 (l :: Bar) (l :: Bar) (l :: TyFun Bar (TyFun Bar (TyFun Foo Bar - -> GHC.Types.Type) - -> GHC.Types.Type)) - = forall arg. SameKind (Apply (BarSym2 l l) arg) (BarSym3 l l arg) => - BarSym2KindInference - type instance Apply (BarSym2 l l) l = BarSym3 l l l - instance SuppressUnusedWarnings BarSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) BarSym1KindInference) GHC.Tuple.()) - data BarSym1 (l :: Bar) (l :: TyFun Bar (TyFun Bar (TyFun Bar (TyFun Foo Bar - -> GHC.Types.Type) - -> GHC.Types.Type) - -> GHC.Types.Type)) - = forall arg. SameKind (Apply (BarSym1 l) arg) (BarSym2 l arg) => - BarSym1KindInference - type instance Apply (BarSym1 l) l = BarSym2 l l - instance SuppressUnusedWarnings BarSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) BarSym0KindInference) GHC.Tuple.()) - data BarSym0 (l :: TyFun Bar (TyFun Bar (TyFun Bar (TyFun Bar (TyFun Foo Bar - -> GHC.Types.Type) - -> GHC.Types.Type) - -> GHC.Types.Type) - -> GHC.Types.Type)) - = forall arg. SameKind (Apply BarSym0 arg) (BarSym1 arg) => - BarSym0KindInference - type instance Apply BarSym0 l = BarSym1 l diff --git a/tests/compile-and-dump/Promote/Constructors.hs b/tests/compile-and-dump/Promote/Constructors.hs deleted file mode 100644 --- a/tests/compile-and-dump/Promote/Constructors.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-unused-imports #-} - -module Promote.Constructors where - -import Data.Singletons.SuppressUnusedWarnings -import Data.Singletons.TH - --- Tests defunctionalization symbol generation for : --- * infix constructors --- * constructors with arity > 2 - -$(promote [d| - data Foo = Foo | Foo :+ Foo - data Bar = Bar Bar Bar Bar Bar Foo - |]) diff --git a/tests/compile-and-dump/Promote/GenDefunSymbols.ghc82.template b/tests/compile-and-dump/Promote/GenDefunSymbols.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Promote/GenDefunSymbols.ghc82.template +++ /dev/null @@ -1,47 +0,0 @@ -Promote/GenDefunSymbols.hs:0:0:: Splicing declarations - genDefunSymbols [''LiftMaybe, ''NatT, ''(:+)] - ======> - type LiftMaybeSym2 (t :: TyFun a0123456789876543210 b0123456789876543210 - -> Type) (t :: Maybe a0123456789876543210) = - LiftMaybe t t - instance SuppressUnusedWarnings LiftMaybeSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) LiftMaybeSym1KindInference) GHC.Tuple.()) - data LiftMaybeSym1 (l :: TyFun a0123456789876543210 b0123456789876543210 - -> Type) (l :: TyFun (Maybe a0123456789876543210) (Maybe b0123456789876543210)) - = forall arg. Data.Singletons.SameKind (Apply (LiftMaybeSym1 l) arg) (LiftMaybeSym2 l arg) => - LiftMaybeSym1KindInference - type instance Apply (LiftMaybeSym1 l) l = LiftMaybe l l - instance SuppressUnusedWarnings LiftMaybeSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) LiftMaybeSym0KindInference) GHC.Tuple.()) - data LiftMaybeSym0 (l :: TyFun (TyFun a0123456789876543210 b0123456789876543210 - -> Type) (TyFun (Maybe a0123456789876543210) (Maybe b0123456789876543210) - -> Type)) - = forall arg. Data.Singletons.SameKind (Apply LiftMaybeSym0 arg) (LiftMaybeSym1 arg) => - LiftMaybeSym0KindInference - type instance Apply LiftMaybeSym0 l = LiftMaybeSym1 l - type ZeroSym0 = Zero - type SuccSym1 (t :: NatT) = Succ t - instance SuppressUnusedWarnings SuccSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) SuccSym0KindInference) GHC.Tuple.()) - data SuccSym0 (l :: TyFun NatT NatT) - = forall arg. Data.Singletons.SameKind (Apply SuccSym0 arg) (SuccSym1 arg) => - SuccSym0KindInference - type instance Apply SuccSym0 l = Succ l - type (:+$$$) (t :: Nat) (t :: Nat) = (:+) t t - instance SuppressUnusedWarnings (:+$$) where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) (:+$$###)) GHC.Tuple.()) - data (:+$$) (l :: Nat) l - = forall arg. Data.Singletons.SameKind (Apply ((:+$$) l) arg) ((:+$$$) l arg) => - (:+$$###) - type instance Apply ((:+$$) l) l = (:+) l l - instance SuppressUnusedWarnings (:+$) where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) (:+$###)) GHC.Tuple.()) - data (:+$) l - = forall arg. Data.Singletons.SameKind (Apply (:+$) arg) ((:+$$) arg) => - (:+$###) - type instance Apply (:+$) l = (:+$$) l 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,19 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-unused-imports #-} - -module Promote.GenDefunSymbols where - -import Data.Singletons (Apply, TyFun) -import Data.Singletons.Promote -import Data.Singletons.SuppressUnusedWarnings -import GHC.TypeLits hiding (type (*)) -import Data.Kind - -type family LiftMaybe (f :: TyFun a b -> *) (x :: Maybe a) :: Maybe b where - LiftMaybe f Nothing = Nothing - LiftMaybe f (Just a) = Just (Apply f a) - -data NatT = Zero | Succ NatT - -type a :+ b = a + b - -$(genDefunSymbols [ ''LiftMaybe, ''NatT, ''(:+) ]) diff --git a/tests/compile-and-dump/Promote/Newtypes.ghc82.template b/tests/compile-and-dump/Promote/Newtypes.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Promote/Newtypes.ghc82.template +++ /dev/null @@ -1,42 +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 UnBarSym1 (t :: Bar) = UnBar t - instance SuppressUnusedWarnings UnBarSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) UnBarSym0KindInference) GHC.Tuple.()) - data UnBarSym0 (l :: TyFun Bar Nat) - = forall arg. SameKind (Apply UnBarSym0 arg) (UnBarSym1 arg) => - UnBarSym0KindInference - type instance Apply UnBarSym0 l = UnBar l - type family UnBar (a :: Bar) :: Nat where - UnBar (Bar field) = field - type family Equals_0123456789876543210 (a :: Foo) (b :: Foo) :: Bool where - Equals_0123456789876543210 (Foo a) (Foo b) = (:==) a b - Equals_0123456789876543210 (a :: Foo) (b :: Foo) = FalseSym0 - instance PEq Foo where - type (:==) (a :: Foo) (b :: Foo) = Equals_0123456789876543210 a b - type FooSym1 (t :: Nat) = Foo t - instance SuppressUnusedWarnings FooSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) FooSym0KindInference) GHC.Tuple.()) - data FooSym0 (l :: TyFun Nat Foo) - = forall arg. SameKind (Apply FooSym0 arg) (FooSym1 arg) => - FooSym0KindInference - type instance Apply FooSym0 l = Foo l - type BarSym1 (t :: Nat) = Bar t - instance SuppressUnusedWarnings BarSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) BarSym0KindInference) GHC.Tuple.()) - data BarSym0 (l :: TyFun Nat Bar) - = forall arg. SameKind (Apply BarSym0 arg) (BarSym1 arg) => - BarSym0KindInference - type instance Apply BarSym0 l = Bar l 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,12 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-unused-imports #-} - -module Promote.Newtypes where - -import Data.Singletons.SuppressUnusedWarnings -import Data.Singletons.TH -import Singletons.Nat - -$(promote [d| - newtype Foo = Foo Nat deriving (Eq) - newtype Bar = Bar { unBar :: Nat } - |]) diff --git a/tests/compile-and-dump/Promote/Pragmas.ghc82.template b/tests/compile-and-dump/Promote/Pragmas.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Promote/Pragmas.ghc82.template +++ /dev/null @@ -1,12 +0,0 @@ -Promote/Pragmas.hs:(0,0)-(0,0): Splicing declarations - promote - [d| {-# INLINE foo #-} - foo :: Bool - foo = True |] - ======> - {-# INLINE foo #-} - foo :: Bool - foo = True - type FooSym0 = Foo - type family Foo :: Bool where - = 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.Promotion.Prelude - -$(promote [d| - {-# INLINE foo #-} - foo :: Bool - foo = True - |]) diff --git a/tests/compile-and-dump/Promote/Prelude.ghc82.template b/tests/compile-and-dump/Promote/Prelude.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Promote/Prelude.ghc82.template +++ /dev/null @@ -1,17 +0,0 @@ -Promote/Prelude.hs:(0,0)-(0,0): Splicing declarations - promoteOnly - [d| odd :: Nat -> Bool - odd 0 = False - odd n = not . odd $ n - 1 |] - ======> - type OddSym1 (t :: Nat) = Odd t - instance SuppressUnusedWarnings OddSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) OddSym0KindInference) GHC.Tuple.()) - data OddSym0 (l :: TyFun Nat Bool) - = forall arg. Data.Singletons.SameKind (Apply OddSym0 arg) (OddSym1 arg) => - OddSym0KindInference - type instance Apply OddSym0 l = Odd l - type family Odd (a :: Nat) :: Bool where - Odd 0 = FalseSym0 - Odd n = Apply (Apply ($$) (Apply (Apply (:.$) NotSym0) OddSym0)) (Apply (Apply (:-$) n) (FromInteger 1)) diff --git a/tests/compile-and-dump/Promote/Prelude.hs b/tests/compile-and-dump/Promote/Prelude.hs deleted file mode 100644 --- a/tests/compile-and-dump/Promote/Prelude.hs +++ /dev/null @@ -1,133 +0,0 @@ -module Promote.Prelude where - -import Data.Promotion.TH -import Data.Promotion.Prelude -import Data.Promotion.Prelude.List -import Data.Proxy -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.ghc82.template b/tests/compile-and-dump/Promote/T180.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Promote/T180.ghc82.template +++ /dev/null @@ -1,48 +0,0 @@ -Promote/T180.hs:(0,0)-(0,0): Splicing declarations - promote - [d| z (X1 x) = x - z (X2 x) = x - - data X = X1 {y :: Symbol} | X2 {y :: Symbol} |] - ======> - data X = X1 {y :: Symbol} | X2 {y :: Symbol} - z (X1 x) = x - z (X2 x) = x - type ZSym1 t = Z t - instance SuppressUnusedWarnings ZSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) ZSym0KindInference) GHC.Tuple.()) - data ZSym0 l - = forall arg. SameKind (Apply ZSym0 arg) (ZSym1 arg) => - ZSym0KindInference - type instance Apply ZSym0 l = Z l - type family Z a where - Z (X1 x) = x - Z (X2 x) = x - type YSym1 (t :: X) = Y t - instance SuppressUnusedWarnings YSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) YSym0KindInference) GHC.Tuple.()) - data YSym0 (l :: TyFun X Symbol) - = forall arg. SameKind (Apply YSym0 arg) (YSym1 arg) => - YSym0KindInference - type instance Apply YSym0 l = Y l - type family Y (a :: X) :: Symbol where - Y (X1 field) = field - Y (X2 field) = field - type X1Sym1 (t :: Symbol) = X1 t - instance SuppressUnusedWarnings X1Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) X1Sym0KindInference) GHC.Tuple.()) - data X1Sym0 (l :: TyFun Symbol X) - = forall arg. SameKind (Apply X1Sym0 arg) (X1Sym1 arg) => - X1Sym0KindInference - type instance Apply X1Sym0 l = X1 l - type X2Sym1 (t :: Symbol) = X2 t - instance SuppressUnusedWarnings X2Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) X2Sym0KindInference) GHC.Tuple.()) - data X2Sym0 (l :: TyFun Symbol X) - = forall arg. SameKind (Apply X2Sym0 arg) (X2Sym1 arg) => - X2Sym0KindInference - type instance Apply X2Sym0 l = X2 l 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/Singletons/AsPattern.ghc82.template b/tests/compile-and-dump/Singletons/AsPattern.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/AsPattern.ghc82.template +++ /dev/null @@ -1,347 +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@GHC.Types.[] = p - foo p@[_] = p - foo p@(_ GHC.Types.: (_ GHC.Types.: _)) = p - type BazSym3 (t :: Nat) (t :: Nat) (t :: Nat) = Baz t t t - instance SuppressUnusedWarnings BazSym2 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) BazSym2KindInference) GHC.Tuple.()) - data BazSym2 (l :: Nat) (l :: Nat) (l :: TyFun Nat Baz) - = forall arg. SameKind (Apply (BazSym2 l l) arg) (BazSym3 l l arg) => - BazSym2KindInference - type instance Apply (BazSym2 l l) l = Baz l l l - instance SuppressUnusedWarnings BazSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) BazSym1KindInference) GHC.Tuple.()) - data BazSym1 (l :: Nat) (l :: TyFun Nat (TyFun Nat Baz - -> GHC.Types.Type)) - = forall arg. SameKind (Apply (BazSym1 l) arg) (BazSym2 l arg) => - BazSym1KindInference - type instance Apply (BazSym1 l) l = BazSym2 l l - instance SuppressUnusedWarnings BazSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) BazSym0KindInference) GHC.Tuple.()) - data BazSym0 (l :: TyFun Nat (TyFun Nat (TyFun Nat Baz - -> GHC.Types.Type) - -> GHC.Types.Type)) - = forall arg. SameKind (Apply BazSym0 arg) (BazSym1 arg) => - BazSym0KindInference - type instance Apply BazSym0 l = BazSym1 l - type Let0123456789876543210PSym0 = Let0123456789876543210P - type family Let0123456789876543210P where - = '[] - type Let0123456789876543210PSym1 t = Let0123456789876543210P t - instance SuppressUnusedWarnings Let0123456789876543210PSym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Let0123456789876543210PSym0KindInference) - GHC.Tuple.()) - data Let0123456789876543210PSym0 l - = forall arg. SameKind (Apply Let0123456789876543210PSym0 arg) (Let0123456789876543210PSym1 arg) => - Let0123456789876543210PSym0KindInference - type instance Apply Let0123456789876543210PSym0 l = Let0123456789876543210P l - type family Let0123456789876543210P wild_0123456789876543210 where - Let0123456789876543210P wild_0123456789876543210 = Apply (Apply (:$) wild_0123456789876543210) '[] - type Let0123456789876543210PSym3 t t t = - Let0123456789876543210P t t t - instance SuppressUnusedWarnings Let0123456789876543210PSym2 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Let0123456789876543210PSym2KindInference) - GHC.Tuple.()) - data Let0123456789876543210PSym2 l l l - = forall arg. SameKind (Apply (Let0123456789876543210PSym2 l l) arg) (Let0123456789876543210PSym3 l l arg) => - Let0123456789876543210PSym2KindInference - type instance Apply (Let0123456789876543210PSym2 l l) l = Let0123456789876543210P l l l - instance SuppressUnusedWarnings Let0123456789876543210PSym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Let0123456789876543210PSym1KindInference) - GHC.Tuple.()) - data Let0123456789876543210PSym1 l l - = forall arg. SameKind (Apply (Let0123456789876543210PSym1 l) arg) (Let0123456789876543210PSym2 l arg) => - Let0123456789876543210PSym1KindInference - type instance Apply (Let0123456789876543210PSym1 l) l = Let0123456789876543210PSym2 l l - instance SuppressUnusedWarnings Let0123456789876543210PSym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Let0123456789876543210PSym0KindInference) - GHC.Tuple.()) - data Let0123456789876543210PSym0 l - = forall arg. SameKind (Apply Let0123456789876543210PSym0 arg) (Let0123456789876543210PSym1 arg) => - Let0123456789876543210PSym0KindInference - type instance Apply Let0123456789876543210PSym0 l = Let0123456789876543210PSym1 l - type family Let0123456789876543210P wild_0123456789876543210 wild_0123456789876543210 wild_0123456789876543210 where - Let0123456789876543210P wild_0123456789876543210 wild_0123456789876543210 wild_0123456789876543210 = Apply (Apply (:$) wild_0123456789876543210) (Apply (Apply (:$) wild_0123456789876543210) wild_0123456789876543210) - type Let0123456789876543210PSym2 t t = Let0123456789876543210P t t - instance SuppressUnusedWarnings Let0123456789876543210PSym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Let0123456789876543210PSym1KindInference) - GHC.Tuple.()) - data Let0123456789876543210PSym1 l l - = forall arg. SameKind (Apply (Let0123456789876543210PSym1 l) arg) (Let0123456789876543210PSym2 l arg) => - Let0123456789876543210PSym1KindInference - type instance Apply (Let0123456789876543210PSym1 l) l = Let0123456789876543210P l l - instance SuppressUnusedWarnings Let0123456789876543210PSym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Let0123456789876543210PSym0KindInference) - GHC.Tuple.()) - data Let0123456789876543210PSym0 l - = forall arg. SameKind (Apply Let0123456789876543210PSym0 arg) (Let0123456789876543210PSym1 arg) => - Let0123456789876543210PSym0KindInference - type instance Apply Let0123456789876543210PSym0 l = Let0123456789876543210PSym1 l - 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 - = NothingSym0 - type Let0123456789876543210PSym3 t t t = - Let0123456789876543210P t t t - instance SuppressUnusedWarnings Let0123456789876543210PSym2 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Let0123456789876543210PSym2KindInference) - GHC.Tuple.()) - data Let0123456789876543210PSym2 l l l - = forall arg. SameKind (Apply (Let0123456789876543210PSym2 l l) arg) (Let0123456789876543210PSym3 l l arg) => - Let0123456789876543210PSym2KindInference - type instance Apply (Let0123456789876543210PSym2 l l) l = Let0123456789876543210P l l l - instance SuppressUnusedWarnings Let0123456789876543210PSym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Let0123456789876543210PSym1KindInference) - GHC.Tuple.()) - data Let0123456789876543210PSym1 l l - = forall arg. SameKind (Apply (Let0123456789876543210PSym1 l) arg) (Let0123456789876543210PSym2 l arg) => - Let0123456789876543210PSym1KindInference - type instance Apply (Let0123456789876543210PSym1 l) l = Let0123456789876543210PSym2 l l - instance SuppressUnusedWarnings Let0123456789876543210PSym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Let0123456789876543210PSym0KindInference) - GHC.Tuple.()) - data Let0123456789876543210PSym0 l - = forall arg. SameKind (Apply Let0123456789876543210PSym0 arg) (Let0123456789876543210PSym1 arg) => - Let0123456789876543210PSym0KindInference - type instance Apply Let0123456789876543210PSym0 l = Let0123456789876543210PSym1 l - type family Let0123456789876543210P wild_0123456789876543210 wild_0123456789876543210 wild_0123456789876543210 where - Let0123456789876543210P wild_0123456789876543210 wild_0123456789876543210 wild_0123456789876543210 = Apply JustSym0 (Apply (Apply (Apply BazSym0 wild_0123456789876543210) wild_0123456789876543210) wild_0123456789876543210) - type Let0123456789876543210XSym1 t = Let0123456789876543210X t - instance SuppressUnusedWarnings Let0123456789876543210XSym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Let0123456789876543210XSym0KindInference) - GHC.Tuple.()) - data Let0123456789876543210XSym0 l - = forall arg. SameKind (Apply Let0123456789876543210XSym0 arg) (Let0123456789876543210XSym1 arg) => - Let0123456789876543210XSym0KindInference - type instance Apply Let0123456789876543210XSym0 l = Let0123456789876543210X l - type family Let0123456789876543210X wild_0123456789876543210 where - Let0123456789876543210X wild_0123456789876543210 = Apply JustSym0 wild_0123456789876543210 - type Let0123456789876543210PSym0 = Let0123456789876543210P - type family Let0123456789876543210P where - = NothingSym0 - type FooSym1 (t :: [Nat]) = Foo t - instance SuppressUnusedWarnings FooSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) FooSym0KindInference) GHC.Tuple.()) - data FooSym0 (l :: TyFun [Nat] [Nat]) - = forall arg. SameKind (Apply FooSym0 arg) (FooSym1 arg) => - FooSym0KindInference - type instance Apply FooSym0 l = Foo l - type TupSym1 (t :: (Nat, Nat)) = Tup t - instance SuppressUnusedWarnings TupSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) TupSym0KindInference) GHC.Tuple.()) - data TupSym0 (l :: TyFun (Nat, Nat) (Nat, Nat)) - = forall arg. SameKind (Apply TupSym0 arg) (TupSym1 arg) => - TupSym0KindInference - type instance Apply TupSym0 l = Tup l - type Baz_Sym1 (t :: Maybe Baz) = Baz_ t - instance SuppressUnusedWarnings Baz_Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Baz_Sym0KindInference) GHC.Tuple.()) - data Baz_Sym0 (l :: TyFun (Maybe Baz) (Maybe Baz)) - = forall arg. SameKind (Apply Baz_Sym0 arg) (Baz_Sym1 arg) => - Baz_Sym0KindInference - type instance Apply Baz_Sym0 l = Baz_ l - type BarSym1 (t :: Maybe Nat) = Bar t - instance SuppressUnusedWarnings BarSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) BarSym0KindInference) GHC.Tuple.()) - data BarSym0 (l :: TyFun (Maybe Nat) (Maybe Nat)) - = forall arg. SameKind (Apply BarSym0 arg) (BarSym1 arg) => - BarSym0KindInference - type instance Apply BarSym0 l = Bar l - type MaybePlusSym1 (t :: Maybe Nat) = MaybePlus t - instance SuppressUnusedWarnings MaybePlusSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) MaybePlusSym0KindInference) GHC.Tuple.()) - data MaybePlusSym0 (l :: TyFun (Maybe Nat) (Maybe Nat)) - = forall arg. SameKind (Apply MaybePlusSym0 arg) (MaybePlusSym1 arg) => - MaybePlusSym0KindInference - type instance Apply MaybePlusSym0 l = MaybePlus l - type family Foo (a :: [Nat]) :: [Nat] where - Foo '[] = Let0123456789876543210PSym0 - Foo '[wild_0123456789876543210] = Let0123456789876543210PSym1 wild_0123456789876543210 - Foo ((:) wild_0123456789876543210 ((:) wild_0123456789876543210 wild_0123456789876543210)) = Let0123456789876543210PSym3 wild_0123456789876543210 wild_0123456789876543210 wild_0123456789876543210 - type family Tup (a :: (Nat, Nat)) :: (Nat, Nat) where - Tup '(wild_0123456789876543210, - wild_0123456789876543210) = Let0123456789876543210PSym2 wild_0123456789876543210 wild_0123456789876543210 - type family Baz_ (a :: Maybe Baz) :: Maybe Baz where - Baz_ Nothing = Let0123456789876543210PSym0 - Baz_ (Just (Baz wild_0123456789876543210 wild_0123456789876543210 wild_0123456789876543210)) = Let0123456789876543210PSym3 wild_0123456789876543210 wild_0123456789876543210 wild_0123456789876543210 - type family Bar (a :: Maybe Nat) :: Maybe Nat where - Bar (Just wild_0123456789876543210) = Let0123456789876543210XSym1 wild_0123456789876543210 - Bar Nothing = NothingSym0 - type family MaybePlus (a :: Maybe Nat) :: Maybe Nat where - MaybePlus (Just n) = Apply JustSym0 (Apply (Apply PlusSym0 (Apply SuccSym0 ZeroSym0)) n) - MaybePlus Nothing = Let0123456789876543210PSym0 - sFoo :: - forall (t :: [Nat]). Sing t -> Sing (Apply FooSym0 t :: [Nat]) - sTup :: - forall (t :: (Nat, Nat)). - Sing t -> Sing (Apply TupSym0 t :: (Nat, Nat)) - sBaz_ :: - forall (t :: Maybe Baz). - Sing t -> Sing (Apply Baz_Sym0 t :: Maybe Baz) - sBar :: - forall (t :: Maybe Nat). - Sing t -> Sing (Apply BarSym0 t :: Maybe Nat) - sMaybePlus :: - forall (t :: Maybe Nat). - Sing t -> Sing (Apply MaybePlusSym0 t :: Maybe Nat) - sFoo SNil - = let - sP :: Sing Let0123456789876543210PSym0 - sP = SNil - in sP - sFoo - (SCons (sWild_0123456789876543210 :: Sing wild_0123456789876543210) - SNil) - = let - sP :: Sing (Let0123456789876543210PSym1 wild_0123456789876543210) - sP - = (applySing - ((applySing ((singFun2 @(:$)) SCons)) sWild_0123456789876543210)) - SNil - in sP - sFoo - (SCons (sWild_0123456789876543210 :: Sing wild_0123456789876543210) - (SCons (sWild_0123456789876543210 :: Sing wild_0123456789876543210) - (sWild_0123456789876543210 :: Sing wild_0123456789876543210))) - = let - sP :: - Sing (Let0123456789876543210PSym3 wild_0123456789876543210 wild_0123456789876543210 wild_0123456789876543210) - sP - = (applySing - ((applySing ((singFun2 @(:$)) SCons)) sWild_0123456789876543210)) - ((applySing - ((applySing ((singFun2 @(:$)) SCons)) sWild_0123456789876543210)) - sWild_0123456789876543210) - in sP - sTup - (STuple2 (sWild_0123456789876543210 :: Sing wild_0123456789876543210) - (sWild_0123456789876543210 :: Sing wild_0123456789876543210)) - = let - sP :: - Sing (Let0123456789876543210PSym2 wild_0123456789876543210 wild_0123456789876543210) - sP - = (applySing - ((applySing ((singFun2 @Tuple2Sym0) STuple2)) - sWild_0123456789876543210)) - sWild_0123456789876543210 - in sP - sBaz_ SNothing - = let - sP :: Sing Let0123456789876543210PSym0 - sP = SNothing - in sP - sBaz_ - (SJust (SBaz (sWild_0123456789876543210 :: Sing wild_0123456789876543210) - (sWild_0123456789876543210 :: Sing wild_0123456789876543210) - (sWild_0123456789876543210 :: Sing wild_0123456789876543210))) - = let - sP :: - Sing (Let0123456789876543210PSym3 wild_0123456789876543210 wild_0123456789876543210 wild_0123456789876543210) - sP - = (applySing ((singFun1 @JustSym0) SJust)) - ((applySing - ((applySing - ((applySing ((singFun3 @BazSym0) SBaz)) sWild_0123456789876543210)) - sWild_0123456789876543210)) - sWild_0123456789876543210) - in sP - sBar - (SJust (sWild_0123456789876543210 :: Sing wild_0123456789876543210)) - = let - sX :: Sing (Let0123456789876543210XSym1 wild_0123456789876543210) - sX - = (applySing ((singFun1 @JustSym0) SJust)) - sWild_0123456789876543210 - in sX - sBar SNothing = SNothing - sMaybePlus (SJust (sN :: Sing n)) - = (applySing ((singFun1 @JustSym0) SJust)) - ((applySing - ((applySing ((singFun2 @PlusSym0) sPlus)) - ((applySing ((singFun1 @SuccSym0) SSucc)) SZero))) - sN) - sMaybePlus SNothing - = let - sP :: Sing Let0123456789876543210PSym0 - sP = SNothing - in sP - data instance Sing (z :: Baz) - = forall (n :: Nat) (n :: Nat) (n :: Nat). z ~ Baz n n n => - SBaz (Sing (n :: Nat)) (Sing (n :: Nat)) (Sing (n :: Nat)) - type SBaz = (Sing :: Baz -> GHC.Types.Type) - instance SingKind Baz where - type Demote Baz = Baz - fromSing (SBaz b b b) - = ((Baz (fromSing b)) (fromSing b)) (fromSing b) - toSing (Baz b b b) - = case - ((GHC.Tuple.(,,) (toSing b :: SomeSing Nat)) - (toSing b :: SomeSing Nat)) - (toSing b :: SomeSing Nat) - of { - GHC.Tuple.(,,) (SomeSing c) (SomeSing c) (SomeSing c) - -> SomeSing (((SBaz c) c) c) } - instance (SingI n, SingI n, SingI n) => - SingI (Baz (n :: Nat) (n :: Nat) (n :: Nat)) where - sing = ((SBaz sing) sing) sing diff --git a/tests/compile-and-dump/Singletons/AsPattern.hs b/tests/compile-and-dump/Singletons/AsPattern.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/AsPattern.hs +++ /dev/null @@ -1,33 +0,0 @@ -module Singletons.AsPattern where - -import Data.Proxy -import Data.Singletons -import Data.Singletons.TH -import Data.Singletons.Prelude.Maybe -import Data.Singletons.Prelude.List -import Singletons.Nat -import Data.Singletons.SuppressUnusedWarnings - -$(singletons [d| - maybePlus :: Maybe Nat -> Maybe Nat - maybePlus (Just n) = Just (plus (Succ Zero) n) - maybePlus p@Nothing = p - - bar :: Maybe Nat -> Maybe Nat - bar x@(Just _) = x - bar Nothing = Nothing - - data Baz = Baz Nat Nat Nat - - baz_ :: Maybe Baz -> Maybe Baz - baz_ p@Nothing = p - baz_ p@(Just (Baz _ _ _)) = p - - tup :: (Nat, Nat) -> (Nat, Nat) - tup p@(_, _) = p - - foo :: [Nat] -> [Nat] - foo p@[] = p - foo p@[_] = p - foo p@(_:_:_) = p - |]) diff --git a/tests/compile-and-dump/Singletons/BadBoundedDeriving.ghc82.template b/tests/compile-and-dump/Singletons/BadBoundedDeriving.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/BadBoundedDeriving.ghc82.template +++ /dev/null @@ -1,6 +0,0 @@ - -Singletons/BadBoundedDeriving.hs:0:0: error: - Can't derive Bounded instance for Foo_0 a_1. - | -6 | $(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,8 +0,0 @@ -module Singletons.BadBoundedDeriving where - -import Data.Singletons.Prelude -import Data.Singletons.TH - -$(singletons [d| - data Foo a = Foo | Bar a deriving (Bounded) - |]) diff --git a/tests/compile-and-dump/Singletons/BadEnumDeriving.ghc82.template b/tests/compile-and-dump/Singletons/BadEnumDeriving.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/BadEnumDeriving.ghc82.template +++ /dev/null @@ -1,6 +0,0 @@ - -Singletons/BadEnumDeriving.hs:0:0: error: - Can't derive Enum instance for Foo_0 a_1. - | -5 | $(singletons [d| - | ^^^^^^^^^^^^^^... diff --git a/tests/compile-and-dump/Singletons/BadEnumDeriving.hs b/tests/compile-and-dump/Singletons/BadEnumDeriving.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/BadEnumDeriving.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Singletons.BadEnumDeriving where - -import Data.Singletons.TH - -$(singletons [d| - data Foo a = Foo a - deriving Enum - |]) diff --git a/tests/compile-and-dump/Singletons/BoundedDeriving.ghc82.template b/tests/compile-and-dump/Singletons/BoundedDeriving.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/BoundedDeriving.ghc82.template +++ /dev/null @@ -1,225 +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 :: *) (b :: *) - = Foo41 | Foo42 - deriving Bounded - data Pair - = Pair Bool Bool - deriving Bounded |] - ======> - data Foo1 - = Foo1 - deriving Bounded - data Foo2 - = A | B | C | D | E - deriving Bounded - data Foo3 a - = Foo3 a - deriving Bounded - data Foo4 (a :: Type) (b :: Type) - = Foo41 | Foo42 - deriving Bounded - data Pair - = Pair Bool Bool - deriving Bounded - type Foo1Sym0 = Foo1 - type ASym0 = A - type BSym0 = B - type CSym0 = C - type DSym0 = D - type ESym0 = E - type Foo3Sym1 (t :: a0123456789876543210) = Foo3 t - instance SuppressUnusedWarnings Foo3Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo3Sym0KindInference) GHC.Tuple.()) - data Foo3Sym0 (l :: TyFun a0123456789876543210 (Foo3 a0123456789876543210)) - = forall arg. SameKind (Apply Foo3Sym0 arg) (Foo3Sym1 arg) => - Foo3Sym0KindInference - type instance Apply Foo3Sym0 l = Foo3 l - type Foo41Sym0 = Foo41 - type Foo42Sym0 = Foo42 - type PairSym2 (t :: Bool) (t :: Bool) = Pair t t - instance SuppressUnusedWarnings PairSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) PairSym1KindInference) GHC.Tuple.()) - data PairSym1 (l :: Bool) (l :: TyFun Bool Pair) - = forall arg. SameKind (Apply (PairSym1 l) arg) (PairSym2 l arg) => - PairSym1KindInference - type instance Apply (PairSym1 l) l = Pair l l - instance SuppressUnusedWarnings PairSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) PairSym0KindInference) GHC.Tuple.()) - data PairSym0 (l :: TyFun Bool (TyFun Bool Pair -> Type)) - = forall arg. SameKind (Apply PairSym0 arg) (PairSym1 arg) => - PairSym0KindInference - type instance Apply PairSym0 l = PairSym1 l - type family MinBound_0123456789876543210 :: Foo1 where - = Foo1Sym0 - type MinBound_0123456789876543210Sym0 = - MinBound_0123456789876543210 - type family MaxBound_0123456789876543210 :: Foo1 where - = Foo1Sym0 - type MaxBound_0123456789876543210Sym0 = - MaxBound_0123456789876543210 - instance PBounded Foo1 where - type = MinBound_0123456789876543210Sym0 - type = MaxBound_0123456789876543210Sym0 - type family MinBound_0123456789876543210 :: Foo2 where - = ASym0 - type MinBound_0123456789876543210Sym0 = - MinBound_0123456789876543210 - type family MaxBound_0123456789876543210 :: Foo2 where - = ESym0 - type MaxBound_0123456789876543210Sym0 = - MaxBound_0123456789876543210 - instance PBounded Foo2 where - type = MinBound_0123456789876543210Sym0 - type = MaxBound_0123456789876543210Sym0 - type family MinBound_0123456789876543210 :: Foo3 a where - = Apply Foo3Sym0 MinBoundSym0 - type MinBound_0123456789876543210Sym0 = - MinBound_0123456789876543210 - type family MaxBound_0123456789876543210 :: Foo3 a where - = Apply Foo3Sym0 MaxBoundSym0 - type MaxBound_0123456789876543210Sym0 = - MaxBound_0123456789876543210 - instance PBounded (Foo3 a) where - type = MinBound_0123456789876543210Sym0 - type = MaxBound_0123456789876543210Sym0 - type family MinBound_0123456789876543210 :: Foo4 a b where - = Foo41Sym0 - type MinBound_0123456789876543210Sym0 = - MinBound_0123456789876543210 - type family MaxBound_0123456789876543210 :: Foo4 a b where - = Foo42Sym0 - type MaxBound_0123456789876543210Sym0 = - MaxBound_0123456789876543210 - instance PBounded (Foo4 a b) where - type = MinBound_0123456789876543210Sym0 - type = MaxBound_0123456789876543210Sym0 - type family MinBound_0123456789876543210 :: Pair where - = Apply (Apply PairSym0 MinBoundSym0) MinBoundSym0 - type MinBound_0123456789876543210Sym0 = - MinBound_0123456789876543210 - type family MaxBound_0123456789876543210 :: Pair where - = Apply (Apply PairSym0 MaxBoundSym0) MaxBoundSym0 - type MaxBound_0123456789876543210Sym0 = - MaxBound_0123456789876543210 - instance PBounded Pair where - type = MinBound_0123456789876543210Sym0 - type = MaxBound_0123456789876543210Sym0 - data instance Sing (z :: Foo1) = z ~ Foo1 => SFoo1 - type SFoo1 = (Sing :: Foo1 -> Type) - instance SingKind Foo1 where - type Demote Foo1 = Foo1 - fromSing SFoo1 = Foo1 - toSing Foo1 = SomeSing SFoo1 - data instance Sing (z :: Foo2) - = z ~ A => SA | - z ~ B => SB | - z ~ C => SC | - z ~ D => SD | - z ~ E => SE - type SFoo2 = (Sing :: Foo2 -> Type) - 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 instance Sing (z :: Foo3 a) - = forall (n :: a). z ~ Foo3 n => SFoo3 (Sing (n :: a)) - type SFoo3 = (Sing :: Foo3 a -> Type) - instance SingKind a => SingKind (Foo3 a) where - type Demote (Foo3 a) = Foo3 (Demote a) - fromSing (SFoo3 b) = Foo3 (fromSing b) - toSing (Foo3 b) - = case toSing b :: SomeSing a of { - SomeSing c -> SomeSing (SFoo3 c) } - data instance Sing (z :: Foo4 a b) - = z ~ Foo41 => SFoo41 | z ~ Foo42 => SFoo42 - type SFoo4 = (Sing :: Foo4 a b -> Type) - 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 instance Sing (z :: Pair) - = forall (n :: Bool) (n :: Bool). z ~ Pair n n => - SPair (Sing (n :: Bool)) (Sing (n :: Bool)) - type SPair = (Sing :: Pair -> Type) - instance SingKind Pair where - type Demote Pair = Pair - fromSing (SPair b b) = (Pair (fromSing b)) (fromSing b) - toSing (Pair b b) - = case - (GHC.Tuple.(,) (toSing b :: SomeSing Bool)) - (toSing b :: SomeSing Bool) - of { - GHC.Tuple.(,) (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 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 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 - -$(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 :: *) (b :: *) = Foo41 | Foo42 deriving Bounded - - data Pair = Pair Bool Bool - deriving Bounded - - |]) - -foo1a :: Proxy (MinBound :: Foo1) -foo1a = Proxy - -foo1b :: Proxy 'Foo1 -foo1b = foo1a - -foo1c :: Proxy (MaxBound :: Foo1) -foo1c = Proxy - -foo1d :: Proxy 'Foo1 -foo1d = foo1c - -foo2a :: Proxy (MinBound :: Foo2) -foo2a = Proxy - -foo2b :: Proxy 'A -foo2b = foo2a - -foo2c :: Proxy (MaxBound :: Foo2) -foo2c = Proxy - -foo2d :: Proxy 'E -foo2d = foo2c - -foo3a :: Proxy (MinBound :: Foo3 Bool) -foo3a = Proxy - -foo3b :: Proxy ('Foo3 False) -foo3b = foo3a - -foo3c :: Proxy (MaxBound :: Foo3 Bool) -foo3c = Proxy - -foo3d :: Proxy ('Foo3 True) -foo3d = foo3c diff --git a/tests/compile-and-dump/Singletons/BoxUnBox.ghc82.template b/tests/compile-and-dump/Singletons/BoxUnBox.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/BoxUnBox.ghc82.template +++ /dev/null @@ -1,42 +0,0 @@ -Singletons/BoxUnBox.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| unBox :: Box a -> a - unBox (FBox a) = a - - data Box a = FBox a |] - ======> - data Box a = FBox a - unBox :: Box a -> a - unBox (FBox a) = a - type FBoxSym1 (t :: a0123456789876543210) = FBox t - instance SuppressUnusedWarnings FBoxSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) FBoxSym0KindInference) GHC.Tuple.()) - data FBoxSym0 (l :: TyFun a0123456789876543210 (Box a0123456789876543210)) - = forall arg. SameKind (Apply FBoxSym0 arg) (FBoxSym1 arg) => - FBoxSym0KindInference - type instance Apply FBoxSym0 l = FBox l - type UnBoxSym1 (t :: Box a0123456789876543210) = UnBox t - instance SuppressUnusedWarnings UnBoxSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) UnBoxSym0KindInference) GHC.Tuple.()) - data UnBoxSym0 (l :: TyFun (Box a0123456789876543210) a0123456789876543210) - = forall arg. SameKind (Apply UnBoxSym0 arg) (UnBoxSym1 arg) => - UnBoxSym0KindInference - type instance Apply UnBoxSym0 l = UnBox l - type family UnBox (a :: Box a) :: a where - UnBox (FBox a) = a - sUnBox :: - forall (t :: Box a). Sing t -> Sing (Apply UnBoxSym0 t :: a) - sUnBox (SFBox (sA :: Sing a)) = sA - data instance Sing (z :: Box a) - = forall (n :: a). z ~ FBox n => SFBox (Sing (n :: a)) - type SBox = (Sing :: Box a -> GHC.Types.Type) - instance SingKind a => SingKind (Box a) where - type Demote (Box a) = Box (Demote a) - fromSing (SFBox b) = FBox (fromSing b) - toSing (FBox b) - = case toSing b :: SomeSing a of { - SomeSing c -> SomeSing (SFBox c) } - instance SingI n => SingI (FBox (n :: a)) where - sing = SFBox sing 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,12 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-unused-imports #-} - -module Singletons.BoxUnBox where - -import Data.Singletons.TH -import Data.Singletons.SuppressUnusedWarnings - -$(singletons [d| - data Box a = FBox a - unBox :: Box a -> a - unBox (FBox a) = a - |]) diff --git a/tests/compile-and-dump/Singletons/CaseExpressions.ghc82.template b/tests/compile-and-dump/Singletons/CaseExpressions.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/CaseExpressions.ghc82.template +++ /dev/null @@ -1,273 +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 x y arg_0123456789876543210 t where - Case_0123456789876543210 x y arg_0123456789876543210 _z_0123456789876543210 = x - type family Lambda_0123456789876543210 x y t where - Lambda_0123456789876543210 x y arg_0123456789876543210 = Case_0123456789876543210 x y arg_0123456789876543210 arg_0123456789876543210 - type Lambda_0123456789876543210Sym3 t t t = - Lambda_0123456789876543210 t t t - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym2 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym2KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym2 l l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym2 l l) arg) (Lambda_0123456789876543210Sym3 l l arg) => - Lambda_0123456789876543210Sym2KindInference - type instance Apply (Lambda_0123456789876543210Sym2 l l) l = Lambda_0123456789876543210 l l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym1 l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym1 l) arg) (Lambda_0123456789876543210Sym2 l arg) => - Lambda_0123456789876543210Sym1KindInference - type instance Apply (Lambda_0123456789876543210Sym1 l) l = Lambda_0123456789876543210Sym2 l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym0 l - = forall arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0KindInference - type instance Apply Lambda_0123456789876543210Sym0 l = Lambda_0123456789876543210Sym1 l - type family Case_0123456789876543210 x t where - Case_0123456789876543210 x y = Apply (Apply (Apply Lambda_0123456789876543210Sym0 x) y) y - type Let0123456789876543210ZSym2 t t = Let0123456789876543210Z t t - instance SuppressUnusedWarnings Let0123456789876543210ZSym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Let0123456789876543210ZSym1KindInference) - GHC.Tuple.()) - data Let0123456789876543210ZSym1 l l - = forall arg. SameKind (Apply (Let0123456789876543210ZSym1 l) arg) (Let0123456789876543210ZSym2 l arg) => - Let0123456789876543210ZSym1KindInference - type instance Apply (Let0123456789876543210ZSym1 l) l = Let0123456789876543210Z l l - instance SuppressUnusedWarnings Let0123456789876543210ZSym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Let0123456789876543210ZSym0KindInference) - GHC.Tuple.()) - data Let0123456789876543210ZSym0 l - = forall arg. SameKind (Apply Let0123456789876543210ZSym0 arg) (Let0123456789876543210ZSym1 arg) => - Let0123456789876543210ZSym0KindInference - type instance Apply Let0123456789876543210ZSym0 l = Let0123456789876543210ZSym1 l - type family Let0123456789876543210Z x y :: a where - Let0123456789876543210Z x y = y - type family Case_0123456789876543210 x t where - Case_0123456789876543210 x y = Let0123456789876543210ZSym2 x y - type Let0123456789876543210Scrutinee_0123456789876543210Sym2 t t = - Let0123456789876543210Scrutinee_0123456789876543210 t t - instance SuppressUnusedWarnings Let0123456789876543210Scrutinee_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) - Let0123456789876543210Scrutinee_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Let0123456789876543210Scrutinee_0123456789876543210Sym1 l l - = forall arg. SameKind (Apply (Let0123456789876543210Scrutinee_0123456789876543210Sym1 l) arg) (Let0123456789876543210Scrutinee_0123456789876543210Sym2 l arg) => - Let0123456789876543210Scrutinee_0123456789876543210Sym1KindInference - type instance Apply (Let0123456789876543210Scrutinee_0123456789876543210Sym1 l) l = Let0123456789876543210Scrutinee_0123456789876543210 l l - instance SuppressUnusedWarnings Let0123456789876543210Scrutinee_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Let0123456789876543210Scrutinee_0123456789876543210Sym0 l - = forall arg. SameKind (Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 arg) (Let0123456789876543210Scrutinee_0123456789876543210Sym1 arg) => - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference - type instance Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 l = Let0123456789876543210Scrutinee_0123456789876543210Sym1 l - 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, _z_0123456789876543210) = p - type Let0123456789876543210Scrutinee_0123456789876543210Sym1 t = - Let0123456789876543210Scrutinee_0123456789876543210 t - instance SuppressUnusedWarnings Let0123456789876543210Scrutinee_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Let0123456789876543210Scrutinee_0123456789876543210Sym0 l - = forall arg. SameKind (Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 arg) (Let0123456789876543210Scrutinee_0123456789876543210Sym1 arg) => - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference - type instance Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 l = Let0123456789876543210Scrutinee_0123456789876543210 l - type family Let0123456789876543210Scrutinee_0123456789876543210 d where - Let0123456789876543210Scrutinee_0123456789876543210 d = Apply JustSym0 d - type family Case_0123456789876543210 d t where - Case_0123456789876543210 d (Just y) = y - type family Case_0123456789876543210 d x t where - Case_0123456789876543210 d x (Just y) = y - Case_0123456789876543210 d x Nothing = d - type Foo5Sym1 (t :: a0123456789876543210) = Foo5 t - instance SuppressUnusedWarnings Foo5Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo5Sym0KindInference) GHC.Tuple.()) - data Foo5Sym0 (l :: TyFun a0123456789876543210 a0123456789876543210) - = forall arg. SameKind (Apply Foo5Sym0 arg) (Foo5Sym1 arg) => - Foo5Sym0KindInference - type instance Apply Foo5Sym0 l = Foo5 l - type Foo4Sym1 (t :: a0123456789876543210) = Foo4 t - instance SuppressUnusedWarnings Foo4Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo4Sym0KindInference) GHC.Tuple.()) - data Foo4Sym0 (l :: TyFun a0123456789876543210 a0123456789876543210) - = forall arg. SameKind (Apply Foo4Sym0 arg) (Foo4Sym1 arg) => - Foo4Sym0KindInference - type instance Apply Foo4Sym0 l = Foo4 l - type Foo3Sym2 (t :: a0123456789876543210) (t :: b0123456789876543210) = - Foo3 t t - instance SuppressUnusedWarnings Foo3Sym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo3Sym1KindInference) GHC.Tuple.()) - data Foo3Sym1 (l :: a0123456789876543210) (l :: TyFun b0123456789876543210 a0123456789876543210) - = forall arg. SameKind (Apply (Foo3Sym1 l) arg) (Foo3Sym2 l arg) => - Foo3Sym1KindInference - type instance Apply (Foo3Sym1 l) l = Foo3 l l - instance SuppressUnusedWarnings Foo3Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo3Sym0KindInference) GHC.Tuple.()) - data Foo3Sym0 (l :: TyFun a0123456789876543210 (TyFun b0123456789876543210 a0123456789876543210 - -> GHC.Types.Type)) - = forall arg. SameKind (Apply Foo3Sym0 arg) (Foo3Sym1 arg) => - Foo3Sym0KindInference - type instance Apply Foo3Sym0 l = Foo3Sym1 l - type Foo2Sym2 (t :: a0123456789876543210) (t :: Maybe a0123456789876543210) = - Foo2 t t - instance SuppressUnusedWarnings Foo2Sym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo2Sym1KindInference) GHC.Tuple.()) - data Foo2Sym1 (l :: a0123456789876543210) (l :: TyFun (Maybe a0123456789876543210) a0123456789876543210) - = forall arg. SameKind (Apply (Foo2Sym1 l) arg) (Foo2Sym2 l arg) => - Foo2Sym1KindInference - type instance Apply (Foo2Sym1 l) l = Foo2 l l - instance SuppressUnusedWarnings Foo2Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo2Sym0KindInference) GHC.Tuple.()) - data Foo2Sym0 (l :: TyFun a0123456789876543210 (TyFun (Maybe a0123456789876543210) a0123456789876543210 - -> GHC.Types.Type)) - = forall arg. SameKind (Apply Foo2Sym0 arg) (Foo2Sym1 arg) => - Foo2Sym0KindInference - type instance Apply Foo2Sym0 l = Foo2Sym1 l - type Foo1Sym2 (t :: a0123456789876543210) (t :: Maybe a0123456789876543210) = - Foo1 t t - instance SuppressUnusedWarnings Foo1Sym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo1Sym1KindInference) GHC.Tuple.()) - data Foo1Sym1 (l :: a0123456789876543210) (l :: TyFun (Maybe a0123456789876543210) a0123456789876543210) - = forall arg. SameKind (Apply (Foo1Sym1 l) arg) (Foo1Sym2 l arg) => - Foo1Sym1KindInference - type instance Apply (Foo1Sym1 l) l = Foo1 l l - instance SuppressUnusedWarnings Foo1Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo1Sym0KindInference) GHC.Tuple.()) - data Foo1Sym0 (l :: TyFun a0123456789876543210 (TyFun (Maybe a0123456789876543210) a0123456789876543210 - -> GHC.Types.Type)) - = forall arg. SameKind (Apply Foo1Sym0 arg) (Foo1Sym1 arg) => - Foo1Sym0KindInference - type instance Apply Foo1Sym0 l = Foo1Sym1 l - type family Foo5 (a :: a) :: a where - Foo5 x = Case_0123456789876543210 x x - type family Foo4 (a :: a) :: a where - Foo4 x = Case_0123456789876543210 x x - type family Foo3 (a :: a) (a :: b) :: a where - Foo3 a b = Case_0123456789876543210 a b (Let0123456789876543210Scrutinee_0123456789876543210Sym2 a b) - type family Foo2 (a :: a) (a :: Maybe a) :: a where - Foo2 d _z_0123456789876543210 = Case_0123456789876543210 d (Let0123456789876543210Scrutinee_0123456789876543210Sym1 d) - type family Foo1 (a :: a) (a :: Maybe a) :: a where - Foo1 d x = Case_0123456789876543210 d x x - sFoo5 :: forall (t :: a). Sing t -> Sing (Apply Foo5Sym0 t :: a) - sFoo4 :: forall (t :: a). Sing t -> Sing (Apply Foo4Sym0 t :: a) - sFoo3 :: - forall (t :: a) (t :: b). - Sing t -> Sing t -> Sing (Apply (Apply Foo3Sym0 t) t :: a) - sFoo2 :: - forall (t :: a) (t :: Maybe a). - Sing t -> Sing t -> Sing (Apply (Apply Foo2Sym0 t) t :: a) - sFoo1 :: - forall (t :: a) (t :: Maybe a). - Sing t -> Sing t -> Sing (Apply (Apply Foo1Sym0 t) t :: a) - sFoo5 (sX :: Sing x) - = case sX of { - sY :: Sing y - -> (applySing - ((singFun1 @(Apply (Apply Lambda_0123456789876543210Sym0 x) y)) - (\ sArg_0123456789876543210 - -> case sArg_0123456789876543210 of { - _ :: Sing arg_0123456789876543210 - -> case sArg_0123456789876543210 of { _ -> sX } :: - Sing (Case_0123456789876543210 x y arg_0123456789876543210 arg_0123456789876543210) }))) - sY } :: - Sing (Case_0123456789876543210 x x :: a) - sFoo4 (sX :: Sing x) - = case sX of { - sY :: Sing y - -> let - sZ :: Sing (Let0123456789876543210ZSym2 x y :: a) - sZ = sY - in sZ } :: - Sing (Case_0123456789876543210 x x :: a) - 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 case sScrutinee_0123456789876543210 of { - STuple2 (sP :: Sing p) _ -> sP } :: - Sing (Case_0123456789876543210 a b (Let0123456789876543210Scrutinee_0123456789876543210Sym2 a b) :: a) - sFoo2 (sD :: Sing d) _ - = let - sScrutinee_0123456789876543210 :: - Sing (Let0123456789876543210Scrutinee_0123456789876543210Sym1 d) - sScrutinee_0123456789876543210 - = (applySing ((singFun1 @JustSym0) SJust)) sD - in case sScrutinee_0123456789876543210 of { - SJust (sY :: Sing y) -> sY } :: - Sing (Case_0123456789876543210 d (Let0123456789876543210Scrutinee_0123456789876543210Sym1 d) :: a) - sFoo1 (sD :: Sing d) (sX :: Sing x) - = case sX of - SJust (sY :: Sing y) -> sY - SNothing -> sD :: - Sing (Case_0123456789876543210 d x x :: a) 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,67 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} - -module Singletons.CaseExpressions where - -import Data.Singletons -import Data.Singletons.TH -import Data.Singletons.Prelude.Maybe -import Data.Singletons.SuppressUnusedWarnings - -$(singletons [d| - foo1 :: a -> Maybe a -> a - foo1 d x = case x of - Just y -> y - Nothing -> d - - foo2 :: a -> Maybe a -> a - foo2 d _ = case (Just d) of - Just y -> y --- Nothing -> d --- the above line causes an "inaccessible code" error. w00t. - - foo3 :: a -> b -> a - foo3 a b = case (a, b) of - (p, _) -> p - - - foo4 :: forall a. a -> a - foo4 x = case x of - y -> let z :: a - z = y - in z - - foo5 :: a -> a - foo5 x = case x of - y -> (\_ -> x) y - |]) - -foo1a :: Proxy (Foo1 Int (Just Char)) -foo1a = Proxy - -foo1b :: Proxy Char -foo1b = foo1a - -foo2a :: Proxy (Foo2 Char Nothing) -foo2a = Proxy - -foo2b :: Proxy Char -foo2b = foo2a - -foo3a :: Proxy (Foo3 Int Char) -foo3a = Proxy - -foo3b :: Proxy Int -foo3b = foo3a - -foo4a :: Proxy (Foo4 Int) -foo4a = Proxy - -foo4b :: Proxy Int -foo4b = foo4a - -foo5a :: Proxy (Foo5 Int) -foo5a = Proxy - -foo5b :: Proxy Int -foo5b = foo5a diff --git a/tests/compile-and-dump/Singletons/Classes.ghc82.template b/tests/compile-and-dump/Singletons/Classes.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Classes.ghc82.template +++ /dev/null @@ -1,529 +0,0 @@ -Singletons/Classes.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| infix 4 <=> - - const :: a -> b -> a - const x _ = x - fooCompare :: Foo -> Foo -> Ordering - fooCompare A A = EQ - fooCompare A B = LT - fooCompare B B = GT - fooCompare B A = EQ - - class MyOrd a where - mycompare :: a -> a -> Ordering - (<=>) :: a -> a -> Ordering - (<=>) = mycompare - infix 4 <=> - data Foo = A | B - data Foo2 = F | G - - instance MyOrd () where - mycompare _ = const EQ - instance MyOrd Nat where - Zero `mycompare` Zero = EQ - Zero `mycompare` (Succ _) = LT - (Succ _) `mycompare` Zero = GT - (Succ n) `mycompare` (Succ m) = m `mycompare` n - instance MyOrd Foo where - mycompare = fooCompare - instance Eq Foo2 where - F == F = True - G == G = True - F == G = False - G == F = False |] - ======> - const :: a -> b -> a - const x _ = x - class MyOrd a where - mycompare :: a -> a -> Ordering - (<=>) :: a -> a -> Ordering - (<=>) = mycompare - infix 4 <=> - instance MyOrd Nat where - mycompare Zero Zero = EQ - mycompare Zero (Succ _) = LT - mycompare (Succ _) Zero = GT - mycompare (Succ n) (Succ m) = (m `mycompare` n) - instance MyOrd () where - mycompare _ = const EQ - data Foo = A | B - fooCompare :: Foo -> Foo -> Ordering - fooCompare A A = EQ - fooCompare A B = LT - fooCompare B B = GT - fooCompare B A = EQ - instance MyOrd Foo where - mycompare = fooCompare - data Foo2 = F | G - instance Eq Foo2 where - (==) F F = True - (==) G G = True - (==) F G = False - (==) G F = False - type ASym0 = A - type BSym0 = B - type FSym0 = F - type GSym0 = G - type FooCompareSym2 (t :: Foo) (t :: Foo) = FooCompare t t - instance SuppressUnusedWarnings FooCompareSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) FooCompareSym1KindInference) GHC.Tuple.()) - data FooCompareSym1 (l :: Foo) (l :: TyFun Foo Ordering) - = forall arg. SameKind (Apply (FooCompareSym1 l) arg) (FooCompareSym2 l arg) => - FooCompareSym1KindInference - type instance Apply (FooCompareSym1 l) l = FooCompare l l - instance SuppressUnusedWarnings FooCompareSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) FooCompareSym0KindInference) GHC.Tuple.()) - data FooCompareSym0 (l :: TyFun Foo (TyFun Foo Ordering - -> GHC.Types.Type)) - = forall arg. SameKind (Apply FooCompareSym0 arg) (FooCompareSym1 arg) => - FooCompareSym0KindInference - type instance Apply FooCompareSym0 l = FooCompareSym1 l - type ConstSym2 (t :: a0123456789876543210) (t :: b0123456789876543210) = - Const t t - instance SuppressUnusedWarnings ConstSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) ConstSym1KindInference) GHC.Tuple.()) - data ConstSym1 (l :: a0123456789876543210) (l :: TyFun b0123456789876543210 a0123456789876543210) - = forall arg. SameKind (Apply (ConstSym1 l) arg) (ConstSym2 l arg) => - ConstSym1KindInference - type instance Apply (ConstSym1 l) l = Const l l - instance SuppressUnusedWarnings ConstSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) ConstSym0KindInference) GHC.Tuple.()) - data ConstSym0 (l :: TyFun a0123456789876543210 (TyFun b0123456789876543210 a0123456789876543210 - -> GHC.Types.Type)) - = forall arg. SameKind (Apply ConstSym0 arg) (ConstSym1 arg) => - ConstSym0KindInference - type instance Apply ConstSym0 l = ConstSym1 l - type family FooCompare (a :: Foo) (a :: Foo) :: Ordering where - FooCompare A A = EQSym0 - FooCompare A B = LTSym0 - FooCompare B B = GTSym0 - FooCompare B A = EQSym0 - type family Const (a :: a) (a :: b) :: a where - Const x _z_0123456789876543210 = x - infix 4 :<=> - type MycompareSym2 (t :: a0123456789876543210) (t :: a0123456789876543210) = - Mycompare t t - instance SuppressUnusedWarnings MycompareSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) MycompareSym1KindInference) GHC.Tuple.()) - data MycompareSym1 (l :: a0123456789876543210) (l :: TyFun a0123456789876543210 Ordering) - = forall arg. SameKind (Apply (MycompareSym1 l) arg) (MycompareSym2 l arg) => - MycompareSym1KindInference - type instance Apply (MycompareSym1 l) l = Mycompare l l - instance SuppressUnusedWarnings MycompareSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) MycompareSym0KindInference) GHC.Tuple.()) - data MycompareSym0 (l :: TyFun a0123456789876543210 (TyFun a0123456789876543210 Ordering - -> GHC.Types.Type)) - = forall arg. SameKind (Apply MycompareSym0 arg) (MycompareSym1 arg) => - MycompareSym0KindInference - type instance Apply MycompareSym0 l = MycompareSym1 l - type (:<=>$$$) (t :: a0123456789876543210) (t :: a0123456789876543210) = - (:<=>) t t - instance SuppressUnusedWarnings (:<=>$$) where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) (:<=>$$###)) GHC.Tuple.()) - data (:<=>$$) (l :: a0123456789876543210) (l :: TyFun a0123456789876543210 Ordering) - = forall arg. SameKind (Apply ((:<=>$$) l) arg) ((:<=>$$$) l arg) => - (:<=>$$###) - type instance Apply ((:<=>$$) l) l = (:<=>) l l - instance SuppressUnusedWarnings (:<=>$) where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) (:<=>$###)) GHC.Tuple.()) - data (:<=>$) (l :: TyFun a0123456789876543210 (TyFun a0123456789876543210 Ordering - -> GHC.Types.Type)) - = forall arg. SameKind (Apply (:<=>$) arg) ((:<=>$$) arg) => - (:<=>$###) - type instance Apply (:<=>$) l = (:<=>$$) l - type family TFHelper_0123456789876543210 (a :: a) (a :: a) :: Ordering where - TFHelper_0123456789876543210 a_0123456789876543210 a_0123456789876543210 = Apply (Apply MycompareSym0 a_0123456789876543210) a_0123456789876543210 - type TFHelper_0123456789876543210Sym2 (t :: a0123456789876543210) (t :: a0123456789876543210) = - TFHelper_0123456789876543210 t t - instance SuppressUnusedWarnings TFHelper_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) TFHelper_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data TFHelper_0123456789876543210Sym1 (l :: a0123456789876543210) (l :: TyFun a0123456789876543210 Ordering) - = forall arg. SameKind (Apply (TFHelper_0123456789876543210Sym1 l) arg) (TFHelper_0123456789876543210Sym2 l arg) => - TFHelper_0123456789876543210Sym1KindInference - type instance Apply (TFHelper_0123456789876543210Sym1 l) l = TFHelper_0123456789876543210 l l - instance SuppressUnusedWarnings TFHelper_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) TFHelper_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data TFHelper_0123456789876543210Sym0 (l :: TyFun a0123456789876543210 (TyFun a0123456789876543210 Ordering - -> GHC.Types.Type)) - = forall arg. SameKind (Apply TFHelper_0123456789876543210Sym0 arg) (TFHelper_0123456789876543210Sym1 arg) => - TFHelper_0123456789876543210Sym0KindInference - type instance Apply TFHelper_0123456789876543210Sym0 l = TFHelper_0123456789876543210Sym1 l - class PMyOrd (a :: GHC.Types.Type) where - type Mycompare (arg :: a) (arg :: a) :: Ordering - type (:<=>) (arg :: a) (arg :: a) :: Ordering - type (:<=>) a a = Apply (Apply TFHelper_0123456789876543210Sym0 a) a - type family Mycompare_0123456789876543210 (a :: Nat) (a :: Nat) :: Ordering where - Mycompare_0123456789876543210 Zero Zero = EQSym0 - Mycompare_0123456789876543210 Zero (Succ _z_0123456789876543210) = LTSym0 - Mycompare_0123456789876543210 (Succ _z_0123456789876543210) Zero = GTSym0 - Mycompare_0123456789876543210 (Succ n) (Succ m) = Apply (Apply MycompareSym0 m) n - type Mycompare_0123456789876543210Sym2 (t :: Nat) (t :: Nat) = - Mycompare_0123456789876543210 t t - instance SuppressUnusedWarnings Mycompare_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Mycompare_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Mycompare_0123456789876543210Sym1 (l :: Nat) (l :: TyFun Nat Ordering) - = forall arg. SameKind (Apply (Mycompare_0123456789876543210Sym1 l) arg) (Mycompare_0123456789876543210Sym2 l arg) => - Mycompare_0123456789876543210Sym1KindInference - type instance Apply (Mycompare_0123456789876543210Sym1 l) l = Mycompare_0123456789876543210 l l - instance SuppressUnusedWarnings Mycompare_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Mycompare_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Mycompare_0123456789876543210Sym0 (l :: TyFun Nat (TyFun Nat Ordering - -> GHC.Types.Type)) - = forall arg. SameKind (Apply Mycompare_0123456789876543210Sym0 arg) (Mycompare_0123456789876543210Sym1 arg) => - Mycompare_0123456789876543210Sym0KindInference - type instance Apply Mycompare_0123456789876543210Sym0 l = Mycompare_0123456789876543210Sym1 l - instance PMyOrd Nat where - type Mycompare (a :: Nat) (a :: Nat) = Apply (Apply Mycompare_0123456789876543210Sym0 a) a - type family Mycompare_0123456789876543210 (a :: ()) (a :: ()) :: Ordering where - Mycompare_0123456789876543210 _z_0123456789876543210 a_0123456789876543210 = Apply (Apply ConstSym0 EQSym0) a_0123456789876543210 - type Mycompare_0123456789876543210Sym2 (t :: ()) (t :: ()) = - Mycompare_0123456789876543210 t t - instance SuppressUnusedWarnings Mycompare_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Mycompare_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Mycompare_0123456789876543210Sym1 (l :: ()) (l :: TyFun () Ordering) - = forall arg. SameKind (Apply (Mycompare_0123456789876543210Sym1 l) arg) (Mycompare_0123456789876543210Sym2 l arg) => - Mycompare_0123456789876543210Sym1KindInference - type instance Apply (Mycompare_0123456789876543210Sym1 l) l = Mycompare_0123456789876543210 l l - instance SuppressUnusedWarnings Mycompare_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Mycompare_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Mycompare_0123456789876543210Sym0 (l :: TyFun () (TyFun () Ordering - -> GHC.Types.Type)) - = forall arg. SameKind (Apply Mycompare_0123456789876543210Sym0 arg) (Mycompare_0123456789876543210Sym1 arg) => - Mycompare_0123456789876543210Sym0KindInference - type instance Apply Mycompare_0123456789876543210Sym0 l = Mycompare_0123456789876543210Sym1 l - instance PMyOrd () where - type Mycompare (a :: ()) (a :: ()) = Apply (Apply Mycompare_0123456789876543210Sym0 a) a - type family Mycompare_0123456789876543210 (a :: Foo) (a :: Foo) :: Ordering where - Mycompare_0123456789876543210 a_0123456789876543210 a_0123456789876543210 = Apply (Apply FooCompareSym0 a_0123456789876543210) a_0123456789876543210 - type Mycompare_0123456789876543210Sym2 (t :: Foo) (t :: Foo) = - Mycompare_0123456789876543210 t t - instance SuppressUnusedWarnings Mycompare_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Mycompare_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Mycompare_0123456789876543210Sym1 (l :: Foo) (l :: TyFun Foo Ordering) - = forall arg. SameKind (Apply (Mycompare_0123456789876543210Sym1 l) arg) (Mycompare_0123456789876543210Sym2 l arg) => - Mycompare_0123456789876543210Sym1KindInference - type instance Apply (Mycompare_0123456789876543210Sym1 l) l = Mycompare_0123456789876543210 l l - instance SuppressUnusedWarnings Mycompare_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Mycompare_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Mycompare_0123456789876543210Sym0 (l :: TyFun Foo (TyFun Foo Ordering - -> GHC.Types.Type)) - = forall arg. SameKind (Apply Mycompare_0123456789876543210Sym0 arg) (Mycompare_0123456789876543210Sym1 arg) => - Mycompare_0123456789876543210Sym0KindInference - type instance Apply Mycompare_0123456789876543210Sym0 l = Mycompare_0123456789876543210Sym1 l - instance PMyOrd Foo where - type Mycompare (a :: Foo) (a :: Foo) = Apply (Apply Mycompare_0123456789876543210Sym0 a) a - type family TFHelper_0123456789876543210 (a :: Foo2) (a :: Foo2) :: Bool where - TFHelper_0123456789876543210 F F = TrueSym0 - TFHelper_0123456789876543210 G G = TrueSym0 - TFHelper_0123456789876543210 F G = FalseSym0 - TFHelper_0123456789876543210 G F = FalseSym0 - type TFHelper_0123456789876543210Sym2 (t :: Foo2) (t :: Foo2) = - TFHelper_0123456789876543210 t t - instance SuppressUnusedWarnings TFHelper_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) TFHelper_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data TFHelper_0123456789876543210Sym1 (l :: Foo2) (l :: TyFun Foo2 Bool) - = forall arg. SameKind (Apply (TFHelper_0123456789876543210Sym1 l) arg) (TFHelper_0123456789876543210Sym2 l arg) => - TFHelper_0123456789876543210Sym1KindInference - type instance Apply (TFHelper_0123456789876543210Sym1 l) l = TFHelper_0123456789876543210 l l - instance SuppressUnusedWarnings TFHelper_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) TFHelper_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data TFHelper_0123456789876543210Sym0 (l :: TyFun Foo2 (TyFun Foo2 Bool - -> GHC.Types.Type)) - = forall arg. SameKind (Apply TFHelper_0123456789876543210Sym0 arg) (TFHelper_0123456789876543210Sym1 arg) => - TFHelper_0123456789876543210Sym0KindInference - type instance Apply TFHelper_0123456789876543210Sym0 l = TFHelper_0123456789876543210Sym1 l - instance PEq Foo2 where - type (:==) (a :: Foo2) (a :: Foo2) = 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 (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 - data instance Sing (z :: Foo) = z ~ A => SA | z ~ B => SB - type SFoo = (Sing :: Foo -> GHC.Types.Type) - instance SingKind Foo where - type Demote Foo = Foo - fromSing SA = A - fromSing SB = B - toSing A = SomeSing SA - toSing B = SomeSing SB - data instance Sing (z :: Foo2) = z ~ F => SF | z ~ G => SG - type SFoo2 = (Sing :: Foo2 -> GHC.Types.Type) - 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 -Singletons/Classes.hs:(0,0)-(0,0): Splicing declarations - promote - [d| instance Ord Foo2 where - F `compare` F = EQ - F `compare` _ = LT - _ `compare` _ = GT - instance MyOrd Foo2 where - F `mycompare` F = EQ - F `mycompare` _ = LT - _ `mycompare` _ = GT |] - ======> - instance MyOrd Foo2 where - mycompare F F = EQ - mycompare F _ = LT - mycompare _ _ = GT - instance Ord Foo2 where - compare F F = EQ - compare F _ = LT - compare _ _ = GT - type family Mycompare_0123456789876543210 (a :: Foo2) (a :: Foo2) :: Ordering where - Mycompare_0123456789876543210 F F = EQSym0 - Mycompare_0123456789876543210 F _z_0123456789876543210 = LTSym0 - Mycompare_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 = GTSym0 - type Mycompare_0123456789876543210Sym2 (t :: Foo2) (t :: Foo2) = - Mycompare_0123456789876543210 t t - instance SuppressUnusedWarnings Mycompare_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Mycompare_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Mycompare_0123456789876543210Sym1 (l :: Foo2) (l :: TyFun Foo2 Ordering) - = forall arg. SameKind (Apply (Mycompare_0123456789876543210Sym1 l) arg) (Mycompare_0123456789876543210Sym2 l arg) => - Mycompare_0123456789876543210Sym1KindInference - type instance Apply (Mycompare_0123456789876543210Sym1 l) l = Mycompare_0123456789876543210 l l - instance SuppressUnusedWarnings Mycompare_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Mycompare_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Mycompare_0123456789876543210Sym0 (l :: TyFun Foo2 (TyFun Foo2 Ordering - -> GHC.Types.Type)) - = forall arg. SameKind (Apply Mycompare_0123456789876543210Sym0 arg) (Mycompare_0123456789876543210Sym1 arg) => - Mycompare_0123456789876543210Sym0KindInference - type instance Apply Mycompare_0123456789876543210Sym0 l = Mycompare_0123456789876543210Sym1 l - instance PMyOrd Foo2 where - type Mycompare (a :: Foo2) (a :: Foo2) = Apply (Apply Mycompare_0123456789876543210Sym0 a) a - type family Compare_0123456789876543210 (a :: Foo2) (a :: Foo2) :: Ordering where - Compare_0123456789876543210 F F = EQSym0 - Compare_0123456789876543210 F _z_0123456789876543210 = LTSym0 - Compare_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 = GTSym0 - type Compare_0123456789876543210Sym2 (t :: Foo2) (t :: Foo2) = - Compare_0123456789876543210 t t - instance SuppressUnusedWarnings Compare_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Compare_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Compare_0123456789876543210Sym1 (l :: Foo2) (l :: TyFun Foo2 Ordering) - = forall arg. SameKind (Apply (Compare_0123456789876543210Sym1 l) arg) (Compare_0123456789876543210Sym2 l arg) => - Compare_0123456789876543210Sym1KindInference - type instance Apply (Compare_0123456789876543210Sym1 l) l = Compare_0123456789876543210 l l - instance SuppressUnusedWarnings Compare_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Compare_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Compare_0123456789876543210Sym0 (l :: TyFun Foo2 (TyFun Foo2 Ordering - -> GHC.Types.Type)) - = forall arg. SameKind (Apply Compare_0123456789876543210Sym0 arg) (Compare_0123456789876543210Sym1 arg) => - Compare_0123456789876543210Sym0KindInference - type instance Apply Compare_0123456789876543210Sym0 l = Compare_0123456789876543210Sym1 l - instance POrd Foo2 where - type Compare (a :: Foo2) (a :: Foo2) = Apply (Apply Compare_0123456789876543210Sym0 a) a -Singletons/Classes.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| data Nat' = Zero' | Succ' Nat' - - instance MyOrd Nat' where - Zero' `mycompare` Zero' = EQ - Zero' `mycompare` (Succ' _) = LT - (Succ' _) `mycompare` Zero' = GT - (Succ' n) `mycompare` (Succ' m) = m `mycompare` n |] - ======> - data Nat' = Zero' | Succ' Nat' - instance MyOrd Nat' where - mycompare Zero' Zero' = EQ - mycompare Zero' (Succ' _) = LT - mycompare (Succ' _) Zero' = GT - mycompare (Succ' n) (Succ' m) = (m `mycompare` n) - type Zero'Sym0 = Zero' - type Succ'Sym1 (t :: Nat') = Succ' t - instance SuppressUnusedWarnings Succ'Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Succ'Sym0KindInference) GHC.Tuple.()) - data Succ'Sym0 (l :: TyFun Nat' Nat') - = forall arg. SameKind (Apply Succ'Sym0 arg) (Succ'Sym1 arg) => - Succ'Sym0KindInference - type instance Apply Succ'Sym0 l = Succ' l - type family Mycompare_0123456789876543210 (a :: Nat') (a :: Nat') :: Ordering where - Mycompare_0123456789876543210 Zero' Zero' = EQSym0 - Mycompare_0123456789876543210 Zero' (Succ' _z_0123456789876543210) = LTSym0 - Mycompare_0123456789876543210 (Succ' _z_0123456789876543210) Zero' = GTSym0 - Mycompare_0123456789876543210 (Succ' n) (Succ' m) = Apply (Apply MycompareSym0 m) n - type Mycompare_0123456789876543210Sym2 (t :: Nat') (t :: Nat') = - Mycompare_0123456789876543210 t t - instance SuppressUnusedWarnings Mycompare_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Mycompare_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Mycompare_0123456789876543210Sym1 (l :: Nat') (l :: TyFun Nat' Ordering) - = forall arg. SameKind (Apply (Mycompare_0123456789876543210Sym1 l) arg) (Mycompare_0123456789876543210Sym2 l arg) => - Mycompare_0123456789876543210Sym1KindInference - type instance Apply (Mycompare_0123456789876543210Sym1 l) l = Mycompare_0123456789876543210 l l - instance SuppressUnusedWarnings Mycompare_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Mycompare_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Mycompare_0123456789876543210Sym0 (l :: TyFun Nat' (TyFun Nat' Ordering - -> GHC.Types.Type)) - = forall arg. SameKind (Apply Mycompare_0123456789876543210Sym0 arg) (Mycompare_0123456789876543210Sym1 arg) => - Mycompare_0123456789876543210Sym0KindInference - type instance Apply Mycompare_0123456789876543210Sym0 l = Mycompare_0123456789876543210Sym1 l - instance PMyOrd Nat' where - type Mycompare (a :: Nat') (a :: Nat') = Apply (Apply Mycompare_0123456789876543210Sym0 a) a - data instance Sing (z :: Nat') - = z ~ Zero' => SZero' | - forall (n :: Nat'). z ~ Succ' n => SSucc' (Sing (n :: Nat')) - type SNat' = (Sing :: Nat' -> GHC.Types.Type) - instance SingKind Nat' where - type Demote Nat' = Nat' - fromSing SZero' = Zero' - fromSing (SSucc' b) = Succ' (fromSing b) - toSing Zero' = SomeSing SZero' - toSing (Succ' b) - = 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' (TyFun Nat' Ordering - -> GHC.Types.Type) - -> GHC.Types.Type) t :: TyFun Nat' Ordering - -> GHC.Types.Type) 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 SingI Zero' where - sing = SZero' - instance SingI n => SingI (Succ' (n :: Nat')) where - sing = SSucc' sing 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.ghc82.template b/tests/compile-and-dump/Singletons/Classes2.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Classes2.ghc82.template +++ /dev/null @@ -1,86 +0,0 @@ -Singletons/Classes2.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| data NatFoo = ZeroFoo | SuccFoo NatFoo - - instance MyOrd NatFoo where - ZeroFoo `mycompare` ZeroFoo = EQ - ZeroFoo `mycompare` (SuccFoo _) = LT - (SuccFoo _) `mycompare` ZeroFoo = GT - (SuccFoo n) `mycompare` (SuccFoo m) = m `mycompare` n |] - ======> - data NatFoo = ZeroFoo | SuccFoo NatFoo - instance MyOrd NatFoo where - mycompare ZeroFoo ZeroFoo = EQ - mycompare ZeroFoo (SuccFoo _) = LT - mycompare (SuccFoo _) ZeroFoo = GT - mycompare (SuccFoo n) (SuccFoo m) = (m `mycompare` n) - type ZeroFooSym0 = ZeroFoo - type SuccFooSym1 (t :: NatFoo) = SuccFoo t - instance SuppressUnusedWarnings SuccFooSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) SuccFooSym0KindInference) GHC.Tuple.()) - data SuccFooSym0 (l :: TyFun NatFoo NatFoo) - = forall arg. SameKind (Apply SuccFooSym0 arg) (SuccFooSym1 arg) => - SuccFooSym0KindInference - type instance Apply SuccFooSym0 l = SuccFoo l - type family Mycompare_0123456789876543210 (a :: NatFoo) (a :: NatFoo) :: Ordering where - Mycompare_0123456789876543210 ZeroFoo ZeroFoo = EQSym0 - Mycompare_0123456789876543210 ZeroFoo (SuccFoo _z_0123456789876543210) = LTSym0 - Mycompare_0123456789876543210 (SuccFoo _z_0123456789876543210) ZeroFoo = GTSym0 - Mycompare_0123456789876543210 (SuccFoo n) (SuccFoo m) = Apply (Apply MycompareSym0 m) n - type Mycompare_0123456789876543210Sym2 (t :: NatFoo) (t :: NatFoo) = - Mycompare_0123456789876543210 t t - instance SuppressUnusedWarnings Mycompare_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Mycompare_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Mycompare_0123456789876543210Sym1 (l :: NatFoo) (l :: TyFun NatFoo Ordering) - = forall arg. SameKind (Apply (Mycompare_0123456789876543210Sym1 l) arg) (Mycompare_0123456789876543210Sym2 l arg) => - Mycompare_0123456789876543210Sym1KindInference - type instance Apply (Mycompare_0123456789876543210Sym1 l) l = Mycompare_0123456789876543210 l l - instance SuppressUnusedWarnings Mycompare_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Mycompare_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Mycompare_0123456789876543210Sym0 (l :: TyFun NatFoo (TyFun NatFoo Ordering - -> GHC.Types.Type)) - = forall arg. SameKind (Apply Mycompare_0123456789876543210Sym0 arg) (Mycompare_0123456789876543210Sym1 arg) => - Mycompare_0123456789876543210Sym0KindInference - type instance Apply Mycompare_0123456789876543210Sym0 l = Mycompare_0123456789876543210Sym1 l - instance PMyOrd NatFoo where - type Mycompare (a :: NatFoo) (a :: NatFoo) = Apply (Apply Mycompare_0123456789876543210Sym0 a) a - data instance Sing (z :: NatFoo) - = z ~ ZeroFoo => SZeroFoo | - forall (n :: NatFoo). z ~ SuccFoo n => - SSuccFoo (Sing (n :: NatFoo)) - type SNatFoo = (Sing :: NatFoo -> GHC.Types.Type) - instance SingKind NatFoo where - type Demote NatFoo = NatFoo - fromSing SZeroFoo = ZeroFoo - fromSing (SSuccFoo b) = SuccFoo (fromSing b) - toSing ZeroFoo = SomeSing SZeroFoo - toSing (SuccFoo b) - = 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 (TyFun NatFoo Ordering - -> GHC.Types.Type) - -> GHC.Types.Type) t1 :: TyFun NatFoo Ordering - -> GHC.Types.Type) t2 :: Ordering) - 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 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.ghc82.template b/tests/compile-and-dump/Singletons/Contains.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Contains.ghc82.template +++ /dev/null @@ -1,41 +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 _ GHC.Types.[] = False - contains elt (h GHC.Types.: t) = ((elt == h) || ((contains elt) t)) - type ContainsSym2 (t :: a0123456789876543210) (t :: [a0123456789876543210]) = - Contains t t - instance SuppressUnusedWarnings ContainsSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) ContainsSym1KindInference) GHC.Tuple.()) - data ContainsSym1 (l :: a0123456789876543210) (l :: TyFun [a0123456789876543210] Bool) - = forall arg. SameKind (Apply (ContainsSym1 l) arg) (ContainsSym2 l arg) => - ContainsSym1KindInference - type instance Apply (ContainsSym1 l) l = Contains l l - instance SuppressUnusedWarnings ContainsSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) ContainsSym0KindInference) GHC.Tuple.()) - data ContainsSym0 (l :: TyFun a0123456789876543210 (TyFun [a0123456789876543210] Bool - -> GHC.Types.Type)) - = forall arg. SameKind (Apply ContainsSym0 arg) (ContainsSym1 arg) => - ContainsSym0KindInference - type instance Apply ContainsSym0 l = ContainsSym1 l - type family Contains (a :: a) (a :: [a]) :: Bool where - Contains _z_0123456789876543210 '[] = FalseSym0 - Contains elt ((:) h t) = Apply (Apply (:||$) (Apply (Apply (:==$) elt) h)) (Apply (Apply ContainsSym0 elt) t) - sContains :: - forall (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) 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.ghc82.template b/tests/compile-and-dump/Singletons/DataValues.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/DataValues.ghc82.template +++ /dev/null @@ -1,93 +0,0 @@ -Singletons/DataValues.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| pr = Pair (Succ Zero) ([Zero]) - complex = Pair (Pair (Just Zero) Zero) False - tuple = (False, Just Zero, True) - aList = [Zero, Succ Zero, Succ (Succ Zero)] - - data Pair a b - = Pair a b - deriving Show |] - ======> - data Pair a b - = Pair a b - deriving Show - pr = (Pair (Succ Zero)) [Zero] - complex = (Pair ((Pair (Just Zero)) Zero)) False - tuple = (False, Just Zero, True) - aList = [Zero, Succ Zero, Succ (Succ Zero)] - type PairSym2 (t :: a0123456789876543210) (t :: b0123456789876543210) = - Pair t t - instance SuppressUnusedWarnings PairSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) PairSym1KindInference) GHC.Tuple.()) - data PairSym1 (l :: a0123456789876543210) (l :: TyFun b0123456789876543210 (Pair a0123456789876543210 b0123456789876543210)) - = forall arg. SameKind (Apply (PairSym1 l) arg) (PairSym2 l arg) => - PairSym1KindInference - type instance Apply (PairSym1 l) l = Pair l l - instance SuppressUnusedWarnings PairSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) PairSym0KindInference) GHC.Tuple.()) - data PairSym0 (l :: TyFun a0123456789876543210 (TyFun b0123456789876543210 (Pair a0123456789876543210 b0123456789876543210) - -> GHC.Types.Type)) - = forall arg. SameKind (Apply PairSym0 arg) (PairSym1 arg) => - PairSym0KindInference - type instance Apply PairSym0 l = PairSym1 l - type AListSym0 = AList - type TupleSym0 = Tuple - type ComplexSym0 = Complex - type PrSym0 = Pr - type family AList where - = Apply (Apply (:$) ZeroSym0) (Apply (Apply (:$) (Apply SuccSym0 ZeroSym0)) (Apply (Apply (:$) (Apply SuccSym0 (Apply SuccSym0 ZeroSym0))) '[])) - type family Tuple where - = Apply (Apply (Apply Tuple3Sym0 FalseSym0) (Apply JustSym0 ZeroSym0)) TrueSym0 - type family Complex where - = Apply (Apply PairSym0 (Apply (Apply PairSym0 (Apply JustSym0 ZeroSym0)) ZeroSym0)) FalseSym0 - type family Pr where - = Apply (Apply PairSym0 (Apply SuccSym0 ZeroSym0)) (Apply (Apply (:$) ZeroSym0) '[]) - 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 instance Sing (z :: Pair a b) - = forall (n :: a) (n :: b). z ~ Pair n n => - SPair (Sing (n :: a)) (Sing (n :: b)) - type SPair = (Sing :: Pair a b -> GHC.Types.Type) - 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 b) - = case - (GHC.Tuple.(,) (toSing b :: SomeSing a)) (toSing b :: SomeSing b) - of { - GHC.Tuple.(,) (SomeSing c) (SomeSing c) -> SomeSing ((SPair c) c) } - instance (SingI n, SingI n) => SingI (Pair (n :: a) (n :: b)) where - sing = (SPair sing) sing 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,19 +0,0 @@ -module Singletons.DataValues where - -import Data.Singletons.TH -import Data.Singletons.Prelude -import Singletons.Nat -import Data.Singletons.SuppressUnusedWarnings - -$(singletons [d| - data Pair a b = Pair a b deriving Show - - 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.ghc82.template b/tests/compile-and-dump/Singletons/Empty.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Empty.ghc82.template +++ /dev/null @@ -1,14 +0,0 @@ -Singletons/Empty.hs:(0,0)-(0,0): Splicing declarations - singletons [d| data Empty |] - ======> - data Empty - data instance Sing (z :: Empty) - type SEmpty = (Sing :: Empty -> GHC.Types.Type) - instance SingKind Empty where - type Demote Empty = Empty - fromSing z - = case z of { - _ -> error "Empty case reached -- this should be impossible" } - toSing z - = case z of { - _ -> error "Empty case reached -- this should be impossible" } 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/EnumDeriving.ghc82.template b/tests/compile-and-dump/Singletons/EnumDeriving.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/EnumDeriving.ghc82.template +++ /dev/null @@ -1,188 +0,0 @@ -Singletons/EnumDeriving.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| data Foo - = Bar | Baz | Bum - deriving Enum - data Quux = Q1 | Q2 |] - ======> - data Foo - = Bar | Baz | Bum - deriving Enum - data Quux = Q1 | Q2 - type BarSym0 = Bar - type BazSym0 = Baz - type BumSym0 = Bum - type Q1Sym0 = Q1 - type Q2Sym0 = Q2 - type family Case_0123456789876543210 n t where - Case_0123456789876543210 n True = BumSym0 - Case_0123456789876543210 n False = Apply ErrorSym0 "toEnum: bad argument" - type family Case_0123456789876543210 n t where - Case_0123456789876543210 n True = BazSym0 - Case_0123456789876543210 n False = Case_0123456789876543210 n (Apply (Apply (:==$) n) (FromInteger 2)) - type family Case_0123456789876543210 n t where - Case_0123456789876543210 n True = BarSym0 - Case_0123456789876543210 n False = Case_0123456789876543210 n (Apply (Apply (:==$) n) (FromInteger 1)) - type family ToEnum_0123456789876543210 (a :: GHC.Types.Nat) :: Foo where - ToEnum_0123456789876543210 n = Case_0123456789876543210 n (Apply (Apply (:==$) n) (FromInteger 0)) - type ToEnum_0123456789876543210Sym1 (t :: GHC.Types.Nat) = - ToEnum_0123456789876543210 t - instance SuppressUnusedWarnings ToEnum_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) ToEnum_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data ToEnum_0123456789876543210Sym0 (l :: TyFun GHC.Types.Nat Foo) - = forall arg. SameKind (Apply ToEnum_0123456789876543210Sym0 arg) (ToEnum_0123456789876543210Sym1 arg) => - ToEnum_0123456789876543210Sym0KindInference - type instance Apply ToEnum_0123456789876543210Sym0 l = ToEnum_0123456789876543210 l - type family FromEnum_0123456789876543210 (a :: Foo) :: GHC.Types.Nat where - FromEnum_0123456789876543210 Bar = FromInteger 0 - FromEnum_0123456789876543210 Baz = FromInteger 1 - FromEnum_0123456789876543210 Bum = FromInteger 2 - type FromEnum_0123456789876543210Sym1 (t :: Foo) = - FromEnum_0123456789876543210 t - instance SuppressUnusedWarnings FromEnum_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) FromEnum_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data FromEnum_0123456789876543210Sym0 (l :: TyFun Foo GHC.Types.Nat) - = forall arg. SameKind (Apply FromEnum_0123456789876543210Sym0 arg) (FromEnum_0123456789876543210Sym1 arg) => - FromEnum_0123456789876543210Sym0KindInference - type instance Apply FromEnum_0123456789876543210Sym0 l = FromEnum_0123456789876543210 l - instance PEnum Foo where - type ToEnum (a :: GHC.Types.Nat) = Apply ToEnum_0123456789876543210Sym0 a - type FromEnum (a :: Foo) = Apply FromEnum_0123456789876543210Sym0 a - data instance Sing (z :: Foo) - = z ~ Bar => SBar | z ~ Baz => SBaz | z ~ Bum => SBum - type SFoo = (Sing :: Foo -> GHC.Types.Type) - 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 instance Sing (z :: Quux) = z ~ Q1 => SQ1 | z ~ Q2 => SQ2 - type SQuux = (Sing :: Quux -> GHC.Types.Type) - 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 (ToEnumSym0 :: TyFun GHC.Types.Nat Foo - -> GHC.Types.Type) t :: Foo) - sFromEnum :: - forall (t :: Foo). - Sing t - -> Sing (Apply (FromEnumSym0 :: TyFun Foo GHC.Types.Nat - -> GHC.Types.Type) t :: GHC.Types.Nat) - sToEnum (sN :: Sing n) - = case - (applySing ((applySing ((singFun2 @(:==$)) (%:==))) sN)) - (sFromInteger (sing :: Sing 0)) - of - STrue -> SBar - SFalse - -> case - (applySing ((applySing ((singFun2 @(:==$)) (%:==))) sN)) - (sFromInteger (sing :: Sing 1)) - of - STrue -> SBaz - SFalse - -> case - (applySing ((applySing ((singFun2 @(:==$)) (%:==))) sN)) - (sFromInteger (sing :: Sing 2)) - of - STrue -> SBum - SFalse -> sError (sing :: Sing "toEnum: bad argument") :: - Sing (Case_0123456789876543210 n (Apply (Apply (:==$) n) (FromInteger 2)) :: Foo) :: - Sing (Case_0123456789876543210 n (Apply (Apply (:==$) n) (FromInteger 1)) :: Foo) :: - Sing (Case_0123456789876543210 n (Apply (Apply (:==$) n) (FromInteger 0)) :: Foo) - sFromEnum SBar = sFromInteger (sing :: Sing 0) - sFromEnum SBaz = sFromInteger (sing :: Sing 1) - sFromEnum SBum = 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) (FromInteger 1)) - type family ToEnum_0123456789876543210 (a :: GHC.Types.Nat) :: Quux where - ToEnum_0123456789876543210 n = Case_0123456789876543210 n (Apply (Apply (:==$) n) (FromInteger 0)) - type ToEnum_0123456789876543210Sym1 (t :: GHC.Types.Nat) = - ToEnum_0123456789876543210 t - instance SuppressUnusedWarnings ToEnum_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) ToEnum_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data ToEnum_0123456789876543210Sym0 (l :: TyFun GHC.Types.Nat Quux) - = forall arg. SameKind (Apply ToEnum_0123456789876543210Sym0 arg) (ToEnum_0123456789876543210Sym1 arg) => - ToEnum_0123456789876543210Sym0KindInference - type instance Apply ToEnum_0123456789876543210Sym0 l = ToEnum_0123456789876543210 l - type family FromEnum_0123456789876543210 (a :: Quux) :: GHC.Types.Nat where - FromEnum_0123456789876543210 Q1 = FromInteger 0 - FromEnum_0123456789876543210 Q2 = FromInteger 1 - type FromEnum_0123456789876543210Sym1 (t :: Quux) = - FromEnum_0123456789876543210 t - instance SuppressUnusedWarnings FromEnum_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) FromEnum_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data FromEnum_0123456789876543210Sym0 (l :: TyFun Quux GHC.Types.Nat) - = forall arg. SameKind (Apply FromEnum_0123456789876543210Sym0 arg) (FromEnum_0123456789876543210Sym1 arg) => - FromEnum_0123456789876543210Sym0KindInference - type instance Apply FromEnum_0123456789876543210Sym0 l = FromEnum_0123456789876543210 l - instance PEnum Quux where - type ToEnum (a :: GHC.Types.Nat) = Apply ToEnum_0123456789876543210Sym0 a - type FromEnum (a :: Quux) = Apply FromEnum_0123456789876543210Sym0 a - instance SEnum Quux where - sToEnum :: - forall (t :: GHC.Types.Nat). - Sing t - -> Sing (Apply (ToEnumSym0 :: TyFun GHC.Types.Nat Quux - -> GHC.Types.Type) t :: Quux) - sFromEnum :: - forall (t :: Quux). - Sing t - -> Sing (Apply (FromEnumSym0 :: TyFun Quux GHC.Types.Nat - -> GHC.Types.Type) t :: GHC.Types.Nat) - sToEnum (sN :: Sing n) - = case - (applySing ((applySing ((singFun2 @(:==$)) (%:==))) sN)) - (sFromInteger (sing :: Sing 0)) - of - STrue -> SQ1 - SFalse - -> case - (applySing ((applySing ((singFun2 @(:==$)) (%:==))) sN)) - (sFromInteger (sing :: Sing 1)) - of - STrue -> SQ2 - SFalse -> sError (sing :: Sing "toEnum: bad argument") :: - Sing (Case_0123456789876543210 n (Apply (Apply (:==$) n) (FromInteger 1)) :: Quux) :: - Sing (Case_0123456789876543210 n (Apply (Apply (:==$) n) (FromInteger 0)) :: Quux) - sFromEnum SQ1 = sFromInteger (sing :: Sing 0) - sFromEnum SQ2 = 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,12 +0,0 @@ -module Singletons.EnumDeriving where - -import Data.Singletons.Prelude -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.ghc82.template b/tests/compile-and-dump/Singletons/EqInstances.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/EqInstances.ghc82.template +++ /dev/null @@ -1,23 +0,0 @@ -Singletons/EqInstances.hs:0:0:: Splicing declarations - singEqInstances [''Foo, ''Empty] - ======> - instance SEq Foo where - (%:==) SFLeaf SFLeaf = STrue - (%:==) SFLeaf ((:%+:) _ _) = SFalse - (%:==) ((:%+:) _ _) SFLeaf = SFalse - (%:==) ((:%+:) a a) ((:%+:) b b) - = ((%:&&) (((%:==) a) b)) (((%:==) a) b) - type family Equals_0123456789876543210 (a :: Foo) (b :: Foo) :: Bool where - Equals_0123456789876543210 FLeaf FLeaf = TrueSym0 - Equals_0123456789876543210 ((:+:) a a) ((:+:) b b) = (:&&) ((:==) a b) ((:==) a b) - Equals_0123456789876543210 (a :: Foo) (b :: Foo) = FalseSym0 - instance PEq Foo where - type (:==) (a :: Foo) (b :: Foo) = Equals_0123456789876543210 a b - instance SEq Empty where - (%:==) a _ - = case a of { - _ -> error "Empty case reached -- this should be impossible" } - type family Equals_0123456789876543210 (a :: Empty) (b :: Empty) :: Bool where - Equals_0123456789876543210 (a :: Empty) (b :: Empty) = FalseSym0 - instance PEq Empty where - type (:==) (a :: Empty) (b :: Empty) = 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.ghc82.template b/tests/compile-and-dump/Singletons/Error.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Error.ghc82.template +++ /dev/null @@ -1,24 +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 GHC.Types.: _) = a - head GHC.Types.[] = error "Data.Singletons.List.head: empty list" - type HeadSym1 (t :: [a0123456789876543210]) = Head t - instance SuppressUnusedWarnings HeadSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) HeadSym0KindInference) GHC.Tuple.()) - data HeadSym0 (l :: TyFun [a0123456789876543210] a0123456789876543210) - = forall arg. SameKind (Apply HeadSym0 arg) (HeadSym1 arg) => - HeadSym0KindInference - type instance Apply HeadSym0 l = Head l - type family Head (a :: [a]) :: a where - Head ((:) a _z_0123456789876543210) = a - Head '[] = Apply ErrorSym0 "Data.Singletons.List.head: empty list" - sHead :: forall (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") 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) -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.ghc82.template b/tests/compile-and-dump/Singletons/Fixity.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Fixity.ghc82.template +++ /dev/null @@ -1,68 +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 (:====$$$) (t :: a0123456789876543210) (t :: a0123456789876543210) = - (:====) t t - instance SuppressUnusedWarnings (:====$$) where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) (:====$$###)) GHC.Tuple.()) - data (:====$$) (l :: a0123456789876543210) (l :: TyFun a0123456789876543210 a0123456789876543210) - = forall arg. SameKind (Apply ((:====$$) l) arg) ((:====$$$) l arg) => - (:====$$###) - type instance Apply ((:====$$) l) l = (:====) l l - instance SuppressUnusedWarnings (:====$) where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) (:====$###)) GHC.Tuple.()) - data (:====$) (l :: TyFun a0123456789876543210 (TyFun a0123456789876543210 a0123456789876543210 - -> GHC.Types.Type)) - = forall arg. SameKind (Apply (:====$) arg) ((:====$$) arg) => - (:====$###) - type instance Apply (:====$) l = (:====$$) l - type family (:====) (a :: a) (a :: a) :: a where - (:====) a _z_0123456789876543210 = a - infix 4 :==== - infix 4 :<=> - type (:<=>$$$) (t :: a0123456789876543210) (t :: a0123456789876543210) = - (:<=>) t t - instance SuppressUnusedWarnings (:<=>$$) where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) (:<=>$$###)) GHC.Tuple.()) - data (:<=>$$) (l :: a0123456789876543210) (l :: TyFun a0123456789876543210 Ordering) - = forall arg. SameKind (Apply ((:<=>$$) l) arg) ((:<=>$$$) l arg) => - (:<=>$$###) - type instance Apply ((:<=>$$) l) l = (:<=>) l l - instance SuppressUnusedWarnings (:<=>$) where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) (:<=>$###)) GHC.Tuple.()) - data (:<=>$) (l :: TyFun a0123456789876543210 (TyFun a0123456789876543210 Ordering - -> GHC.Types.Type)) - = forall arg. SameKind (Apply (:<=>$) arg) ((:<=>$$) arg) => - (:<=>$###) - type instance Apply (:<=>$) l = (:<=>$$) l - class PMyOrd (a :: GHC.Types.Type) where - type (:<=>) (arg :: a) (arg :: a) :: Ordering - infix 4 %:==== - infix 4 %:<=> - (%:====) :: - forall (t :: a) (t :: a). - Sing t -> Sing t -> Sing (Apply (Apply (:====$) t) t :: a) - (%:====) (sA :: Sing a) _ = sA - class SMyOrd a where - (%:<=>) :: - forall (t :: a) (t :: a). - Sing t -> Sing t -> Sing (Apply (Apply (:<=>$) t) t :: Ordering) 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.ghc82.template b/tests/compile-and-dump/Singletons/FunDeps.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/FunDeps.ghc82.template +++ /dev/null @@ -1,86 +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 - = Apply MethSym0 TrueSym0 - type MethSym1 (t :: a0123456789876543210) = Meth t - instance SuppressUnusedWarnings MethSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) MethSym0KindInference) GHC.Tuple.()) - data MethSym0 (l :: TyFun a0123456789876543210 a0123456789876543210) - = forall arg. SameKind (Apply MethSym0 arg) (MethSym1 arg) => - MethSym0KindInference - type instance Apply MethSym0 l = Meth l - type L2rSym1 (t :: a0123456789876543210) = L2r t - instance SuppressUnusedWarnings L2rSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) L2rSym0KindInference) GHC.Tuple.()) - data L2rSym0 (l :: TyFun a0123456789876543210 b0123456789876543210) - = forall arg. SameKind (Apply L2rSym0 arg) (L2rSym1 arg) => - L2rSym0KindInference - type instance Apply L2rSym0 l = L2r l - class PFD (a :: GHC.Types.Type) (b :: GHC.Types.Type) | a -> b where - type Meth (arg :: a) :: a - type L2r (arg :: a) :: b - type family Meth_0123456789876543210 (a :: Bool) :: Bool where - Meth_0123456789876543210 a_0123456789876543210 = Apply NotSym0 a_0123456789876543210 - type Meth_0123456789876543210Sym1 (t :: Bool) = - Meth_0123456789876543210 t - instance SuppressUnusedWarnings Meth_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Meth_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Meth_0123456789876543210Sym0 (l :: TyFun Bool Bool) - = forall arg. SameKind (Apply Meth_0123456789876543210Sym0 arg) (Meth_0123456789876543210Sym1 arg) => - Meth_0123456789876543210Sym0KindInference - type instance Apply Meth_0123456789876543210Sym0 l = Meth_0123456789876543210 l - type family L2r_0123456789876543210 (a :: Bool) :: Nat where - L2r_0123456789876543210 False = FromInteger 0 - L2r_0123456789876543210 True = FromInteger 1 - type L2r_0123456789876543210Sym1 (t :: Bool) = - L2r_0123456789876543210 t - instance SuppressUnusedWarnings L2r_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) L2r_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data L2r_0123456789876543210Sym0 (l :: TyFun Bool Nat) - = forall arg. SameKind (Apply L2r_0123456789876543210Sym0 arg) (L2r_0123456789876543210Sym1 arg) => - L2r_0123456789876543210Sym0KindInference - type instance Apply L2r_0123456789876543210Sym0 l = L2r_0123456789876543210 l - instance PFD Bool Nat where - type Meth (a :: Bool) = Apply Meth_0123456789876543210Sym0 a - type L2r (a :: Bool) = 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) 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/HigherOrder.ghc82.template b/tests/compile-and-dump/Singletons/HigherOrder.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/HigherOrder.ghc82.template +++ /dev/null @@ -1,423 +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 _ GHC.Types.[] = [] - map f (h GHC.Types.: t) = ((f h) GHC.Types.: ((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 GHC.Types.: xs) (y GHC.Types.: ys) - = (((f x) y) GHC.Types.: (((zipWith f) xs) ys)) - zipWith _ GHC.Types.[] GHC.Types.[] = [] - zipWith _ (_ GHC.Types.: _) GHC.Types.[] = [] - zipWith _ GHC.Types.[] (_ GHC.Types.: _) = [] - foo :: ((a -> b) -> a -> b) -> (a -> b) -> a -> b - foo f g a = (f g) a - splunge :: [Nat] -> [Bool] -> [Nat] - splunge ns bs - = ((zipWith (\ n b -> if b then Succ (Succ n) else n)) ns) bs - etad :: [Nat] -> [Bool] -> [Nat] - etad = zipWith (\ n b -> if b then Succ (Succ n) else n) - type LeftSym1 (t :: a0123456789876543210) = Left t - instance SuppressUnusedWarnings LeftSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) LeftSym0KindInference) GHC.Tuple.()) - data LeftSym0 (l :: TyFun a0123456789876543210 (Either a0123456789876543210 b0123456789876543210)) - = forall arg. SameKind (Apply LeftSym0 arg) (LeftSym1 arg) => - LeftSym0KindInference - type instance Apply LeftSym0 l = Left l - type RightSym1 (t :: b0123456789876543210) = Right t - instance SuppressUnusedWarnings RightSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) RightSym0KindInference) GHC.Tuple.()) - data RightSym0 (l :: TyFun b0123456789876543210 (Either a0123456789876543210 b0123456789876543210)) - = forall arg. SameKind (Apply RightSym0 arg) (RightSym1 arg) => - RightSym0KindInference - type instance Apply RightSym0 l = Right l - type family Case_0123456789876543210 ns bs n b t where - Case_0123456789876543210 ns bs n b True = Apply SuccSym0 (Apply SuccSym0 n) - Case_0123456789876543210 ns bs n b False = n - type family Lambda_0123456789876543210 ns bs t t where - Lambda_0123456789876543210 ns bs n b = Case_0123456789876543210 ns bs n b b - type Lambda_0123456789876543210Sym4 t t t t = - Lambda_0123456789876543210 t t t t - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym3 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym3KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym3 l l l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym3 l l l) arg) (Lambda_0123456789876543210Sym4 l l l arg) => - Lambda_0123456789876543210Sym3KindInference - type instance Apply (Lambda_0123456789876543210Sym3 l l l) l = Lambda_0123456789876543210 l l l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym2 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym2KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym2 l l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym2 l l) arg) (Lambda_0123456789876543210Sym3 l l arg) => - Lambda_0123456789876543210Sym2KindInference - type instance Apply (Lambda_0123456789876543210Sym2 l l) l = Lambda_0123456789876543210Sym3 l l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym1 l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym1 l) arg) (Lambda_0123456789876543210Sym2 l arg) => - Lambda_0123456789876543210Sym1KindInference - type instance Apply (Lambda_0123456789876543210Sym1 l) l = Lambda_0123456789876543210Sym2 l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym0 l - = forall arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0KindInference - type instance Apply Lambda_0123456789876543210Sym0 l = Lambda_0123456789876543210Sym1 l - type family Case_0123456789876543210 n b a_0123456789876543210 a_0123456789876543210 t where - Case_0123456789876543210 n b a_0123456789876543210 a_0123456789876543210 True = Apply SuccSym0 (Apply SuccSym0 n) - Case_0123456789876543210 n b a_0123456789876543210 a_0123456789876543210 False = n - type family Lambda_0123456789876543210 a_0123456789876543210 a_0123456789876543210 t t where - Lambda_0123456789876543210 a_0123456789876543210 a_0123456789876543210 n b = Case_0123456789876543210 n b a_0123456789876543210 a_0123456789876543210 b - type Lambda_0123456789876543210Sym4 t t t t = - Lambda_0123456789876543210 t t t t - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym3 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym3KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym3 l l l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym3 l l l) arg) (Lambda_0123456789876543210Sym4 l l l arg) => - Lambda_0123456789876543210Sym3KindInference - type instance Apply (Lambda_0123456789876543210Sym3 l l l) l = Lambda_0123456789876543210 l l l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym2 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym2KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym2 l l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym2 l l) arg) (Lambda_0123456789876543210Sym3 l l arg) => - Lambda_0123456789876543210Sym2KindInference - type instance Apply (Lambda_0123456789876543210Sym2 l l) l = Lambda_0123456789876543210Sym3 l l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym1 l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym1 l) arg) (Lambda_0123456789876543210Sym2 l arg) => - Lambda_0123456789876543210Sym1KindInference - type instance Apply (Lambda_0123456789876543210Sym1 l) l = Lambda_0123456789876543210Sym2 l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym0 l - = forall arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0KindInference - type instance Apply Lambda_0123456789876543210Sym0 l = Lambda_0123456789876543210Sym1 l - type FooSym3 (t :: TyFun (TyFun a0123456789876543210 b0123456789876543210 - -> GHC.Types.Type) (TyFun a0123456789876543210 b0123456789876543210 - -> GHC.Types.Type) - -> GHC.Types.Type) (t :: TyFun a0123456789876543210 b0123456789876543210 - -> GHC.Types.Type) (t :: a0123456789876543210) = - Foo t t t - instance SuppressUnusedWarnings FooSym2 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) FooSym2KindInference) GHC.Tuple.()) - data FooSym2 (l :: TyFun (TyFun a0123456789876543210 b0123456789876543210 - -> GHC.Types.Type) (TyFun a0123456789876543210 b0123456789876543210 - -> GHC.Types.Type) - -> GHC.Types.Type) (l :: TyFun a0123456789876543210 b0123456789876543210 - -> GHC.Types.Type) (l :: TyFun a0123456789876543210 b0123456789876543210) - = forall arg. SameKind (Apply (FooSym2 l l) arg) (FooSym3 l l arg) => - FooSym2KindInference - type instance Apply (FooSym2 l l) l = Foo l l l - instance SuppressUnusedWarnings FooSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) FooSym1KindInference) GHC.Tuple.()) - data FooSym1 (l :: TyFun (TyFun a0123456789876543210 b0123456789876543210 - -> GHC.Types.Type) (TyFun a0123456789876543210 b0123456789876543210 - -> GHC.Types.Type) - -> GHC.Types.Type) (l :: TyFun (TyFun a0123456789876543210 b0123456789876543210 - -> GHC.Types.Type) (TyFun a0123456789876543210 b0123456789876543210 - -> GHC.Types.Type)) - = forall arg. SameKind (Apply (FooSym1 l) arg) (FooSym2 l arg) => - FooSym1KindInference - type instance Apply (FooSym1 l) l = FooSym2 l l - instance SuppressUnusedWarnings FooSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) FooSym0KindInference) GHC.Tuple.()) - data FooSym0 (l :: TyFun (TyFun (TyFun a0123456789876543210 b0123456789876543210 - -> GHC.Types.Type) (TyFun a0123456789876543210 b0123456789876543210 - -> GHC.Types.Type) - -> GHC.Types.Type) (TyFun (TyFun a0123456789876543210 b0123456789876543210 - -> GHC.Types.Type) (TyFun a0123456789876543210 b0123456789876543210 - -> GHC.Types.Type) - -> GHC.Types.Type)) - = forall arg. SameKind (Apply FooSym0 arg) (FooSym1 arg) => - FooSym0KindInference - type instance Apply FooSym0 l = FooSym1 l - type ZipWithSym3 (t :: TyFun a0123456789876543210 (TyFun b0123456789876543210 c0123456789876543210 - -> GHC.Types.Type) - -> GHC.Types.Type) (t :: [a0123456789876543210]) (t :: [b0123456789876543210]) = - ZipWith t t t - instance SuppressUnusedWarnings ZipWithSym2 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) ZipWithSym2KindInference) GHC.Tuple.()) - data ZipWithSym2 (l :: TyFun a0123456789876543210 (TyFun b0123456789876543210 c0123456789876543210 - -> GHC.Types.Type) - -> GHC.Types.Type) (l :: [a0123456789876543210]) (l :: TyFun [b0123456789876543210] [c0123456789876543210]) - = forall arg. SameKind (Apply (ZipWithSym2 l l) arg) (ZipWithSym3 l l arg) => - ZipWithSym2KindInference - type instance Apply (ZipWithSym2 l l) l = ZipWith l l l - instance SuppressUnusedWarnings ZipWithSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) ZipWithSym1KindInference) GHC.Tuple.()) - data ZipWithSym1 (l :: TyFun a0123456789876543210 (TyFun b0123456789876543210 c0123456789876543210 - -> GHC.Types.Type) - -> GHC.Types.Type) (l :: TyFun [a0123456789876543210] (TyFun [b0123456789876543210] [c0123456789876543210] - -> GHC.Types.Type)) - = forall arg. SameKind (Apply (ZipWithSym1 l) arg) (ZipWithSym2 l arg) => - ZipWithSym1KindInference - type instance Apply (ZipWithSym1 l) l = ZipWithSym2 l l - instance SuppressUnusedWarnings ZipWithSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) ZipWithSym0KindInference) GHC.Tuple.()) - data ZipWithSym0 (l :: TyFun (TyFun a0123456789876543210 (TyFun b0123456789876543210 c0123456789876543210 - -> GHC.Types.Type) - -> GHC.Types.Type) (TyFun [a0123456789876543210] (TyFun [b0123456789876543210] [c0123456789876543210] - -> GHC.Types.Type) - -> GHC.Types.Type)) - = forall arg. SameKind (Apply ZipWithSym0 arg) (ZipWithSym1 arg) => - ZipWithSym0KindInference - type instance Apply ZipWithSym0 l = ZipWithSym1 l - type SplungeSym2 (t :: [Nat]) (t :: [Bool]) = Splunge t t - instance SuppressUnusedWarnings SplungeSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) SplungeSym1KindInference) GHC.Tuple.()) - data SplungeSym1 (l :: [Nat]) (l :: TyFun [Bool] [Nat]) - = forall arg. SameKind (Apply (SplungeSym1 l) arg) (SplungeSym2 l arg) => - SplungeSym1KindInference - type instance Apply (SplungeSym1 l) l = Splunge l l - instance SuppressUnusedWarnings SplungeSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) SplungeSym0KindInference) GHC.Tuple.()) - data SplungeSym0 (l :: TyFun [Nat] (TyFun [Bool] [Nat] - -> GHC.Types.Type)) - = forall arg. SameKind (Apply SplungeSym0 arg) (SplungeSym1 arg) => - SplungeSym0KindInference - type instance Apply SplungeSym0 l = SplungeSym1 l - type EtadSym2 (t :: [Nat]) (t :: [Bool]) = Etad t t - instance SuppressUnusedWarnings EtadSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) EtadSym1KindInference) GHC.Tuple.()) - data EtadSym1 (l :: [Nat]) (l :: TyFun [Bool] [Nat]) - = forall arg. SameKind (Apply (EtadSym1 l) arg) (EtadSym2 l arg) => - EtadSym1KindInference - type instance Apply (EtadSym1 l) l = Etad l l - instance SuppressUnusedWarnings EtadSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) EtadSym0KindInference) GHC.Tuple.()) - data EtadSym0 (l :: TyFun [Nat] (TyFun [Bool] [Nat] - -> GHC.Types.Type)) - = forall arg. SameKind (Apply EtadSym0 arg) (EtadSym1 arg) => - EtadSym0KindInference - type instance Apply EtadSym0 l = EtadSym1 l - type LiftMaybeSym2 (t :: TyFun a0123456789876543210 b0123456789876543210 - -> GHC.Types.Type) (t :: Maybe a0123456789876543210) = - LiftMaybe t t - instance SuppressUnusedWarnings LiftMaybeSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) LiftMaybeSym1KindInference) GHC.Tuple.()) - data LiftMaybeSym1 (l :: TyFun a0123456789876543210 b0123456789876543210 - -> GHC.Types.Type) (l :: TyFun (Maybe a0123456789876543210) (Maybe b0123456789876543210)) - = forall arg. SameKind (Apply (LiftMaybeSym1 l) arg) (LiftMaybeSym2 l arg) => - LiftMaybeSym1KindInference - type instance Apply (LiftMaybeSym1 l) l = LiftMaybe l l - instance SuppressUnusedWarnings LiftMaybeSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) LiftMaybeSym0KindInference) GHC.Tuple.()) - data LiftMaybeSym0 (l :: TyFun (TyFun a0123456789876543210 b0123456789876543210 - -> GHC.Types.Type) (TyFun (Maybe a0123456789876543210) (Maybe b0123456789876543210) - -> GHC.Types.Type)) - = forall arg. SameKind (Apply LiftMaybeSym0 arg) (LiftMaybeSym1 arg) => - LiftMaybeSym0KindInference - type instance Apply LiftMaybeSym0 l = LiftMaybeSym1 l - type MapSym2 (t :: TyFun a0123456789876543210 b0123456789876543210 - -> GHC.Types.Type) (t :: [a0123456789876543210]) = - Map t t - instance SuppressUnusedWarnings MapSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) MapSym1KindInference) GHC.Tuple.()) - data MapSym1 (l :: TyFun a0123456789876543210 b0123456789876543210 - -> GHC.Types.Type) (l :: TyFun [a0123456789876543210] [b0123456789876543210]) - = forall arg. SameKind (Apply (MapSym1 l) arg) (MapSym2 l arg) => - MapSym1KindInference - type instance Apply (MapSym1 l) l = Map l l - instance SuppressUnusedWarnings MapSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) MapSym0KindInference) GHC.Tuple.()) - data MapSym0 (l :: TyFun (TyFun a0123456789876543210 b0123456789876543210 - -> GHC.Types.Type) (TyFun [a0123456789876543210] [b0123456789876543210] - -> GHC.Types.Type)) - = forall arg. SameKind (Apply MapSym0 arg) (MapSym1 arg) => - MapSym0KindInference - type instance Apply MapSym0 l = MapSym1 l - type family Foo (a :: TyFun (TyFun a b - -> GHC.Types.Type) (TyFun a b -> GHC.Types.Type) - -> GHC.Types.Type) (a :: TyFun a b - -> GHC.Types.Type) (a :: a) :: b where - Foo f g a = Apply (Apply f g) a - type family ZipWith (a :: TyFun a (TyFun b c -> GHC.Types.Type) - -> GHC.Types.Type) (a :: [a]) (a :: [b]) :: [c] where - ZipWith f ((:) x xs) ((:) y ys) = Apply (Apply (:$) (Apply (Apply f x) y)) (Apply (Apply (Apply ZipWithSym0 f) xs) ys) - ZipWith _z_0123456789876543210 '[] '[] = '[] - ZipWith _z_0123456789876543210 ((:) _z_0123456789876543210 _z_0123456789876543210) '[] = '[] - ZipWith _z_0123456789876543210 '[] ((:) _z_0123456789876543210 _z_0123456789876543210) = '[] - type family Splunge (a :: [Nat]) (a :: [Bool]) :: [Nat] where - Splunge ns bs = Apply (Apply (Apply ZipWithSym0 (Apply (Apply Lambda_0123456789876543210Sym0 ns) bs)) ns) bs - type family Etad (a :: [Nat]) (a :: [Bool]) :: [Nat] where - Etad a_0123456789876543210 a_0123456789876543210 = Apply (Apply (Apply ZipWithSym0 (Apply (Apply Lambda_0123456789876543210Sym0 a_0123456789876543210) a_0123456789876543210)) a_0123456789876543210) a_0123456789876543210 - type family LiftMaybe (a :: TyFun a b - -> GHC.Types.Type) (a :: Maybe a) :: Maybe b where - LiftMaybe f (Just x) = Apply JustSym0 (Apply f x) - LiftMaybe _z_0123456789876543210 Nothing = NothingSym0 - type family Map (a :: TyFun a b - -> GHC.Types.Type) (a :: [a]) :: [b] where - Map _z_0123456789876543210 '[] = '[] - Map f ((:) h t) = Apply (Apply (:$) (Apply f h)) (Apply (Apply MapSym0 f) t) - sFoo :: - forall (t :: TyFun (TyFun a b -> GHC.Types.Type) (TyFun a b - -> GHC.Types.Type) - -> GHC.Types.Type) - (t :: TyFun a b -> GHC.Types.Type) - (t :: a). - Sing t - -> Sing t - -> Sing t -> Sing (Apply (Apply (Apply FooSym0 t) t) t :: b) - sZipWith :: - forall (t :: TyFun a (TyFun b c -> GHC.Types.Type) - -> GHC.Types.Type) - (t :: [a]) - (t :: [b]). - Sing t - -> Sing t - -> Sing t -> Sing (Apply (Apply (Apply ZipWithSym0 t) t) t :: [c]) - sSplunge :: - forall (t :: [Nat]) (t :: [Bool]). - Sing t -> Sing t -> Sing (Apply (Apply SplungeSym0 t) t :: [Nat]) - sEtad :: - forall (t :: [Nat]) (t :: [Bool]). - Sing t -> Sing t -> Sing (Apply (Apply EtadSym0 t) t :: [Nat]) - sLiftMaybe :: - forall (t :: TyFun a b -> GHC.Types.Type) (t :: Maybe a). - Sing t - -> Sing t -> Sing (Apply (Apply LiftMaybeSym0 t) t :: Maybe b) - sMap :: - forall (t :: TyFun a b -> GHC.Types.Type) (t :: [a]). - Sing t -> Sing t -> Sing (Apply (Apply MapSym0 t) t :: [b]) - 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 - sSplunge (sNs :: Sing ns) (sBs :: Sing bs) - = (applySing - ((applySing - ((applySing ((singFun3 @ZipWithSym0) sZipWith)) - ((singFun2 @(Apply (Apply Lambda_0123456789876543210Sym0 ns) bs)) - (\ sN sB - -> case (GHC.Tuple.(,) sN) sB of { - GHC.Tuple.(,) (_ :: Sing n) (_ :: Sing b) - -> case sB of - STrue - -> (applySing ((singFun1 @SuccSym0) SSucc)) - ((applySing ((singFun1 @SuccSym0) SSucc)) sN) - SFalse -> sN :: - Sing (Case_0123456789876543210 ns bs n b b) })))) - sNs)) - sBs - 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 (GHC.Tuple.(,) sN) sB of { - GHC.Tuple.(,) (_ :: Sing n) (_ :: Sing b) - -> case sB of - STrue - -> (applySing ((singFun1 @SuccSym0) SSucc)) - ((applySing ((singFun1 @SuccSym0) SSucc)) sN) - SFalse -> sN :: - Sing (Case_0123456789876543210 n b a_0123456789876543210 a_0123456789876543210 b) })))) - sA_0123456789876543210)) - sA_0123456789876543210 - 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) - data instance Sing (z :: Either a b) - = forall (n :: a). z ~ Left n => SLeft (Sing (n :: a)) | - forall (n :: b). z ~ Right n => SRight (Sing (n :: b)) - type SEither = (Sing :: Either a b -> GHC.Types.Type) - 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) - = case toSing b :: SomeSing a of { - SomeSing c -> SomeSing (SLeft c) } - toSing (Right 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 n => SingI (Right (n :: b)) where - sing = SRight sing diff --git a/tests/compile-and-dump/Singletons/HigherOrder.hs b/tests/compile-and-dump/Singletons/HigherOrder.hs 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 (TyCon2 Either) '[Int, Bool] '[Char, Double]) -foo1a = Proxy - -foo1b :: Proxy ('[Either Int Char, Either Bool Double]) -foo1b = foo1a - -foo2a :: Proxy (Map (TyCon1 (Either Int)) '[Bool, Double]) -foo2a = Proxy - -foo2b :: Proxy ('[Either Int Bool, Either Int Double]) -foo2b = foo2a - -foo3a :: Proxy (Map PredSym0 '[Succ Zero, Succ (Succ Zero)]) -foo3a = Proxy - -foo3b :: Proxy '[Zero, Succ Zero] -foo3b = foo3a diff --git a/tests/compile-and-dump/Singletons/LambdaCase.ghc82.template b/tests/compile-and-dump/Singletons/LambdaCase.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/LambdaCase.ghc82.template +++ /dev/null @@ -1,222 +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 a b x_0123456789876543210 t where - Case_0123456789876543210 a b x_0123456789876543210 '(p, - _z_0123456789876543210) = p - type family Lambda_0123456789876543210 a b t where - Lambda_0123456789876543210 a b x_0123456789876543210 = Case_0123456789876543210 a b x_0123456789876543210 x_0123456789876543210 - type Lambda_0123456789876543210Sym3 t t t = - Lambda_0123456789876543210 t t t - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym2 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym2KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym2 l l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym2 l l) arg) (Lambda_0123456789876543210Sym3 l l arg) => - Lambda_0123456789876543210Sym2KindInference - type instance Apply (Lambda_0123456789876543210Sym2 l l) l = Lambda_0123456789876543210 l l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym1 l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym1 l) arg) (Lambda_0123456789876543210Sym2 l arg) => - Lambda_0123456789876543210Sym1KindInference - type instance Apply (Lambda_0123456789876543210Sym1 l) l = Lambda_0123456789876543210Sym2 l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym0 l - = forall arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0KindInference - type instance Apply Lambda_0123456789876543210Sym0 l = Lambda_0123456789876543210Sym1 l - type family Case_0123456789876543210 d x_0123456789876543210 t where - Case_0123456789876543210 d x_0123456789876543210 (Just y) = y - Case_0123456789876543210 d x_0123456789876543210 Nothing = d - type family Lambda_0123456789876543210 d t where - Lambda_0123456789876543210 d x_0123456789876543210 = Case_0123456789876543210 d x_0123456789876543210 x_0123456789876543210 - type Lambda_0123456789876543210Sym2 t t = - Lambda_0123456789876543210 t t - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym1 l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym1 l) arg) (Lambda_0123456789876543210Sym2 l arg) => - Lambda_0123456789876543210Sym1KindInference - type instance Apply (Lambda_0123456789876543210Sym1 l) l = Lambda_0123456789876543210 l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym0 l - = forall arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0KindInference - type instance Apply Lambda_0123456789876543210Sym0 l = Lambda_0123456789876543210Sym1 l - type family Case_0123456789876543210 d x x_0123456789876543210 t where - Case_0123456789876543210 d x x_0123456789876543210 (Just y) = y - Case_0123456789876543210 d x x_0123456789876543210 Nothing = d - type family Lambda_0123456789876543210 d x t where - Lambda_0123456789876543210 d x x_0123456789876543210 = Case_0123456789876543210 d x x_0123456789876543210 x_0123456789876543210 - type Lambda_0123456789876543210Sym3 t t t = - Lambda_0123456789876543210 t t t - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym2 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym2KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym2 l l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym2 l l) arg) (Lambda_0123456789876543210Sym3 l l arg) => - Lambda_0123456789876543210Sym2KindInference - type instance Apply (Lambda_0123456789876543210Sym2 l l) l = Lambda_0123456789876543210 l l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym1 l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym1 l) arg) (Lambda_0123456789876543210Sym2 l arg) => - Lambda_0123456789876543210Sym1KindInference - type instance Apply (Lambda_0123456789876543210Sym1 l) l = Lambda_0123456789876543210Sym2 l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym0 l - = forall arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0KindInference - type instance Apply Lambda_0123456789876543210Sym0 l = Lambda_0123456789876543210Sym1 l - type Foo3Sym2 (t :: a0123456789876543210) (t :: b0123456789876543210) = - Foo3 t t - instance SuppressUnusedWarnings Foo3Sym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo3Sym1KindInference) GHC.Tuple.()) - data Foo3Sym1 (l :: a0123456789876543210) (l :: TyFun b0123456789876543210 a0123456789876543210) - = forall arg. SameKind (Apply (Foo3Sym1 l) arg) (Foo3Sym2 l arg) => - Foo3Sym1KindInference - type instance Apply (Foo3Sym1 l) l = Foo3 l l - instance SuppressUnusedWarnings Foo3Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo3Sym0KindInference) GHC.Tuple.()) - data Foo3Sym0 (l :: TyFun a0123456789876543210 (TyFun b0123456789876543210 a0123456789876543210 - -> GHC.Types.Type)) - = forall arg. SameKind (Apply Foo3Sym0 arg) (Foo3Sym1 arg) => - Foo3Sym0KindInference - type instance Apply Foo3Sym0 l = Foo3Sym1 l - type Foo2Sym2 (t :: a0123456789876543210) (t :: Maybe a0123456789876543210) = - Foo2 t t - instance SuppressUnusedWarnings Foo2Sym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo2Sym1KindInference) GHC.Tuple.()) - data Foo2Sym1 (l :: a0123456789876543210) (l :: TyFun (Maybe a0123456789876543210) a0123456789876543210) - = forall arg. SameKind (Apply (Foo2Sym1 l) arg) (Foo2Sym2 l arg) => - Foo2Sym1KindInference - type instance Apply (Foo2Sym1 l) l = Foo2 l l - instance SuppressUnusedWarnings Foo2Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo2Sym0KindInference) GHC.Tuple.()) - data Foo2Sym0 (l :: TyFun a0123456789876543210 (TyFun (Maybe a0123456789876543210) a0123456789876543210 - -> GHC.Types.Type)) - = forall arg. SameKind (Apply Foo2Sym0 arg) (Foo2Sym1 arg) => - Foo2Sym0KindInference - type instance Apply Foo2Sym0 l = Foo2Sym1 l - type Foo1Sym2 (t :: a0123456789876543210) (t :: Maybe a0123456789876543210) = - Foo1 t t - instance SuppressUnusedWarnings Foo1Sym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo1Sym1KindInference) GHC.Tuple.()) - data Foo1Sym1 (l :: a0123456789876543210) (l :: TyFun (Maybe a0123456789876543210) a0123456789876543210) - = forall arg. SameKind (Apply (Foo1Sym1 l) arg) (Foo1Sym2 l arg) => - Foo1Sym1KindInference - type instance Apply (Foo1Sym1 l) l = Foo1 l l - instance SuppressUnusedWarnings Foo1Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo1Sym0KindInference) GHC.Tuple.()) - data Foo1Sym0 (l :: TyFun a0123456789876543210 (TyFun (Maybe a0123456789876543210) a0123456789876543210 - -> GHC.Types.Type)) - = forall arg. SameKind (Apply Foo1Sym0 arg) (Foo1Sym1 arg) => - Foo1Sym0KindInference - type instance Apply Foo1Sym0 l = Foo1Sym1 l - type family Foo3 (a :: a) (a :: b) :: a where - Foo3 a b = Apply (Apply (Apply Lambda_0123456789876543210Sym0 a) b) (Apply (Apply Tuple2Sym0 a) b) - type family Foo2 (a :: a) (a :: Maybe a) :: a where - Foo2 d _z_0123456789876543210 = Apply (Apply Lambda_0123456789876543210Sym0 d) (Apply JustSym0 d) - type family Foo1 (a :: a) (a :: Maybe a) :: a where - Foo1 d x = Apply (Apply (Apply Lambda_0123456789876543210Sym0 d) x) x - sFoo3 :: - forall (t :: a) (t :: b). - Sing t -> Sing t -> Sing (Apply (Apply Foo3Sym0 t) t :: a) - sFoo2 :: - forall (t :: a) (t :: Maybe a). - Sing t -> Sing t -> Sing (Apply (Apply Foo2Sym0 t) t :: a) - sFoo1 :: - forall (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 - -> case sX_0123456789876543210 of { - STuple2 (sP :: Sing p) _ -> sP } :: - Sing (Case_0123456789876543210 a b x_0123456789876543210 x_0123456789876543210) }))) - ((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 - -> case sX_0123456789876543210 of - SJust (sY :: Sing y) -> sY - SNothing -> sD :: - Sing (Case_0123456789876543210 d x_0123456789876543210 x_0123456789876543210) }))) - ((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 - -> case sX_0123456789876543210 of - SJust (sY :: Sing y) -> sY - SNothing -> sD :: - Sing (Case_0123456789876543210 d x x_0123456789876543210 x_0123456789876543210) }))) - sX 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.ghc82.template b/tests/compile-and-dump/Singletons/Lambdas.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Lambdas.ghc82.template +++ /dev/null @@ -1,704 +0,0 @@ -Singletons/Lambdas.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| foo0 :: a -> b -> a - foo0 = (\ x y -> x) - foo1 :: a -> b -> a - foo1 x = (\ _ -> x) - foo2 :: a -> b -> a - foo2 x y = (\ _ -> x) y - foo3 :: a -> a - foo3 x = (\ y -> y) x - foo4 :: a -> b -> c -> a - foo4 x y z = (\ _ _ -> x) y z - foo5 :: a -> b -> b - foo5 x y = (\ x -> x) y - foo6 :: a -> b -> a - foo6 a b = (\ x -> \ _ -> x) a b - foo7 :: a -> b -> b - foo7 x y = (\ (_, b) -> b) (x, y) - foo8 :: Foo a b -> a - foo8 x = (\ (Foo a _) -> a) x - - data Foo a b = Foo a b |] - ======> - foo0 :: a -> b -> a - foo0 = \ x y -> x - foo1 :: a -> b -> a - foo1 x = \ _ -> x - foo2 :: a -> b -> a - foo2 x y = (\ _ -> x) y - foo3 :: a -> a - foo3 x = (\ y -> y) x - foo4 :: a -> b -> c -> a - foo4 x y z = ((\ _ _ -> x) y) z - foo5 :: a -> b -> b - foo5 x y = (\ x -> x) y - foo6 :: a -> b -> a - foo6 a b = ((\ x -> \ _ -> x) a) b - foo7 :: a -> b -> b - foo7 x y = (\ (_, b) -> b) (x, y) - data Foo a b = Foo a b - foo8 :: Foo a b -> a - foo8 x = (\ Foo a _ -> a) x - type FooSym2 (t :: a0123456789876543210) (t :: b0123456789876543210) = - Foo t t - instance SuppressUnusedWarnings FooSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) FooSym1KindInference) GHC.Tuple.()) - data FooSym1 (l :: a0123456789876543210) (l :: TyFun b0123456789876543210 (Foo a0123456789876543210 b0123456789876543210)) - = forall arg. SameKind (Apply (FooSym1 l) arg) (FooSym2 l arg) => - FooSym1KindInference - type instance Apply (FooSym1 l) l = Foo l l - instance SuppressUnusedWarnings FooSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) FooSym0KindInference) GHC.Tuple.()) - data FooSym0 (l :: TyFun a0123456789876543210 (TyFun b0123456789876543210 (Foo a0123456789876543210 b0123456789876543210) - -> GHC.Types.Type)) - = forall arg. SameKind (Apply FooSym0 arg) (FooSym1 arg) => - FooSym0KindInference - type instance Apply FooSym0 l = FooSym1 l - type family Case_0123456789876543210 x arg_0123456789876543210 t where - Case_0123456789876543210 x arg_0123456789876543210 (Foo a _z_0123456789876543210) = a - type family Lambda_0123456789876543210 x t where - Lambda_0123456789876543210 x arg_0123456789876543210 = Case_0123456789876543210 x arg_0123456789876543210 arg_0123456789876543210 - type Lambda_0123456789876543210Sym2 t t = - Lambda_0123456789876543210 t t - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym1 l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym1 l) arg) (Lambda_0123456789876543210Sym2 l arg) => - Lambda_0123456789876543210Sym1KindInference - type instance Apply (Lambda_0123456789876543210Sym1 l) l = Lambda_0123456789876543210 l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym0 l - = forall arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0KindInference - type instance Apply Lambda_0123456789876543210Sym0 l = Lambda_0123456789876543210Sym1 l - type family Case_0123456789876543210 x y arg_0123456789876543210 t where - Case_0123456789876543210 x y arg_0123456789876543210 '(_z_0123456789876543210, - b) = b - type family Lambda_0123456789876543210 x y t where - Lambda_0123456789876543210 x y arg_0123456789876543210 = Case_0123456789876543210 x y arg_0123456789876543210 arg_0123456789876543210 - type Lambda_0123456789876543210Sym3 t t t = - Lambda_0123456789876543210 t t t - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym2 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym2KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym2 l l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym2 l l) arg) (Lambda_0123456789876543210Sym3 l l arg) => - Lambda_0123456789876543210Sym2KindInference - type instance Apply (Lambda_0123456789876543210Sym2 l l) l = Lambda_0123456789876543210 l l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym1 l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym1 l) arg) (Lambda_0123456789876543210Sym2 l arg) => - Lambda_0123456789876543210Sym1KindInference - type instance Apply (Lambda_0123456789876543210Sym1 l) l = Lambda_0123456789876543210Sym2 l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym0 l - = forall arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0KindInference - type instance Apply Lambda_0123456789876543210Sym0 l = Lambda_0123456789876543210Sym1 l - type family Case_0123456789876543210 a b x arg_0123456789876543210 t where - Case_0123456789876543210 a b x arg_0123456789876543210 _z_0123456789876543210 = x - type family Lambda_0123456789876543210 a b x t where - Lambda_0123456789876543210 a b x arg_0123456789876543210 = Case_0123456789876543210 a b x arg_0123456789876543210 arg_0123456789876543210 - type Lambda_0123456789876543210Sym4 t t t t = - Lambda_0123456789876543210 t t t t - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym3 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym3KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym3 l l l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym3 l l l) arg) (Lambda_0123456789876543210Sym4 l l l arg) => - Lambda_0123456789876543210Sym3KindInference - type instance Apply (Lambda_0123456789876543210Sym3 l l l) l = Lambda_0123456789876543210 l l l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym2 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym2KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym2 l l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym2 l l) arg) (Lambda_0123456789876543210Sym3 l l arg) => - Lambda_0123456789876543210Sym2KindInference - type instance Apply (Lambda_0123456789876543210Sym2 l l) l = Lambda_0123456789876543210Sym3 l l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym1 l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym1 l) arg) (Lambda_0123456789876543210Sym2 l arg) => - Lambda_0123456789876543210Sym1KindInference - type instance Apply (Lambda_0123456789876543210Sym1 l) l = Lambda_0123456789876543210Sym2 l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym0 l - = forall arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0KindInference - type instance Apply Lambda_0123456789876543210Sym0 l = Lambda_0123456789876543210Sym1 l - type family Lambda_0123456789876543210 a b t where - Lambda_0123456789876543210 a b x = Apply (Apply (Apply Lambda_0123456789876543210Sym0 a) b) x - type Lambda_0123456789876543210Sym3 t t t = - Lambda_0123456789876543210 t t t - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym2 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym2KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym2 l l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym2 l l) arg) (Lambda_0123456789876543210Sym3 l l arg) => - Lambda_0123456789876543210Sym2KindInference - type instance Apply (Lambda_0123456789876543210Sym2 l l) l = Lambda_0123456789876543210 l l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym1 l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym1 l) arg) (Lambda_0123456789876543210Sym2 l arg) => - Lambda_0123456789876543210Sym1KindInference - type instance Apply (Lambda_0123456789876543210Sym1 l) l = Lambda_0123456789876543210Sym2 l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym0 l - = forall arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0KindInference - type instance Apply Lambda_0123456789876543210Sym0 l = Lambda_0123456789876543210Sym1 l - type family Lambda_0123456789876543210 x y t where - Lambda_0123456789876543210 x y x = x - type Lambda_0123456789876543210Sym3 t t t = - Lambda_0123456789876543210 t t t - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym2 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym2KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym2 l l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym2 l l) arg) (Lambda_0123456789876543210Sym3 l l arg) => - Lambda_0123456789876543210Sym2KindInference - type instance Apply (Lambda_0123456789876543210Sym2 l l) l = Lambda_0123456789876543210 l l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym1 l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym1 l) arg) (Lambda_0123456789876543210Sym2 l arg) => - Lambda_0123456789876543210Sym1KindInference - type instance Apply (Lambda_0123456789876543210Sym1 l) l = Lambda_0123456789876543210Sym2 l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym0 l - = forall arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0KindInference - type instance Apply Lambda_0123456789876543210Sym0 l = Lambda_0123456789876543210Sym1 l - type family Case_0123456789876543210 x y z arg_0123456789876543210 arg_0123456789876543210 t where - Case_0123456789876543210 x y z arg_0123456789876543210 arg_0123456789876543210 '(_z_0123456789876543210, - _z_0123456789876543210) = x - type family Lambda_0123456789876543210 x y z t t where - Lambda_0123456789876543210 x y z arg_0123456789876543210 arg_0123456789876543210 = Case_0123456789876543210 x y z arg_0123456789876543210 arg_0123456789876543210 (Apply (Apply Tuple2Sym0 arg_0123456789876543210) arg_0123456789876543210) - type Lambda_0123456789876543210Sym5 t t t t t = - Lambda_0123456789876543210 t t t t t - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym4 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym4KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym4 l l l l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym4 l l l l) arg) (Lambda_0123456789876543210Sym5 l l l l arg) => - Lambda_0123456789876543210Sym4KindInference - type instance Apply (Lambda_0123456789876543210Sym4 l l l l) l = Lambda_0123456789876543210 l l l l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym3 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym3KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym3 l l l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym3 l l l) arg) (Lambda_0123456789876543210Sym4 l l l arg) => - Lambda_0123456789876543210Sym3KindInference - type instance Apply (Lambda_0123456789876543210Sym3 l l l) l = Lambda_0123456789876543210Sym4 l l l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym2 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym2KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym2 l l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym2 l l) arg) (Lambda_0123456789876543210Sym3 l l arg) => - Lambda_0123456789876543210Sym2KindInference - type instance Apply (Lambda_0123456789876543210Sym2 l l) l = Lambda_0123456789876543210Sym3 l l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym1 l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym1 l) arg) (Lambda_0123456789876543210Sym2 l arg) => - Lambda_0123456789876543210Sym1KindInference - type instance Apply (Lambda_0123456789876543210Sym1 l) l = Lambda_0123456789876543210Sym2 l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym0 l - = forall arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0KindInference - type instance Apply Lambda_0123456789876543210Sym0 l = Lambda_0123456789876543210Sym1 l - type family Lambda_0123456789876543210 x t where - Lambda_0123456789876543210 x y = y - type Lambda_0123456789876543210Sym2 t t = - Lambda_0123456789876543210 t t - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym1 l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym1 l) arg) (Lambda_0123456789876543210Sym2 l arg) => - Lambda_0123456789876543210Sym1KindInference - type instance Apply (Lambda_0123456789876543210Sym1 l) l = Lambda_0123456789876543210 l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym0 l - = forall arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0KindInference - type instance Apply Lambda_0123456789876543210Sym0 l = Lambda_0123456789876543210Sym1 l - type family Case_0123456789876543210 x y arg_0123456789876543210 t where - Case_0123456789876543210 x y arg_0123456789876543210 _z_0123456789876543210 = x - type family Lambda_0123456789876543210 x y t where - Lambda_0123456789876543210 x y arg_0123456789876543210 = Case_0123456789876543210 x y arg_0123456789876543210 arg_0123456789876543210 - type Lambda_0123456789876543210Sym3 t t t = - Lambda_0123456789876543210 t t t - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym2 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym2KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym2 l l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym2 l l) arg) (Lambda_0123456789876543210Sym3 l l arg) => - Lambda_0123456789876543210Sym2KindInference - type instance Apply (Lambda_0123456789876543210Sym2 l l) l = Lambda_0123456789876543210 l l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym1 l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym1 l) arg) (Lambda_0123456789876543210Sym2 l arg) => - Lambda_0123456789876543210Sym1KindInference - type instance Apply (Lambda_0123456789876543210Sym1 l) l = Lambda_0123456789876543210Sym2 l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym0 l - = forall arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0KindInference - type instance Apply Lambda_0123456789876543210Sym0 l = Lambda_0123456789876543210Sym1 l - type family Case_0123456789876543210 x arg_0123456789876543210 a_0123456789876543210 t where - Case_0123456789876543210 x arg_0123456789876543210 a_0123456789876543210 _z_0123456789876543210 = x - type family Lambda_0123456789876543210 x a_0123456789876543210 t where - Lambda_0123456789876543210 x a_0123456789876543210 arg_0123456789876543210 = Case_0123456789876543210 x arg_0123456789876543210 a_0123456789876543210 arg_0123456789876543210 - type Lambda_0123456789876543210Sym3 t t t = - Lambda_0123456789876543210 t t t - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym2 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym2KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym2 l l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym2 l l) arg) (Lambda_0123456789876543210Sym3 l l arg) => - Lambda_0123456789876543210Sym2KindInference - type instance Apply (Lambda_0123456789876543210Sym2 l l) l = Lambda_0123456789876543210 l l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym1 l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym1 l) arg) (Lambda_0123456789876543210Sym2 l arg) => - Lambda_0123456789876543210Sym1KindInference - type instance Apply (Lambda_0123456789876543210Sym1 l) l = Lambda_0123456789876543210Sym2 l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym0 l - = forall arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0KindInference - type instance Apply Lambda_0123456789876543210Sym0 l = Lambda_0123456789876543210Sym1 l - type family Lambda_0123456789876543210 a_0123456789876543210 a_0123456789876543210 t t where - Lambda_0123456789876543210 a_0123456789876543210 a_0123456789876543210 x y = x - type Lambda_0123456789876543210Sym4 t t t t = - Lambda_0123456789876543210 t t t t - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym3 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym3KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym3 l l l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym3 l l l) arg) (Lambda_0123456789876543210Sym4 l l l arg) => - Lambda_0123456789876543210Sym3KindInference - type instance Apply (Lambda_0123456789876543210Sym3 l l l) l = Lambda_0123456789876543210 l l l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym2 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym2KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym2 l l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym2 l l) arg) (Lambda_0123456789876543210Sym3 l l arg) => - Lambda_0123456789876543210Sym2KindInference - type instance Apply (Lambda_0123456789876543210Sym2 l l) l = Lambda_0123456789876543210Sym3 l l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym1 l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym1 l) arg) (Lambda_0123456789876543210Sym2 l arg) => - Lambda_0123456789876543210Sym1KindInference - type instance Apply (Lambda_0123456789876543210Sym1 l) l = Lambda_0123456789876543210Sym2 l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym0 l - = forall arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0KindInference - type instance Apply Lambda_0123456789876543210Sym0 l = Lambda_0123456789876543210Sym1 l - type Foo8Sym1 (t :: Foo a0123456789876543210 b0123456789876543210) = - Foo8 t - instance SuppressUnusedWarnings Foo8Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo8Sym0KindInference) GHC.Tuple.()) - data Foo8Sym0 (l :: TyFun (Foo a0123456789876543210 b0123456789876543210) a0123456789876543210) - = forall arg. SameKind (Apply Foo8Sym0 arg) (Foo8Sym1 arg) => - Foo8Sym0KindInference - type instance Apply Foo8Sym0 l = Foo8 l - type Foo7Sym2 (t :: a0123456789876543210) (t :: b0123456789876543210) = - Foo7 t t - instance SuppressUnusedWarnings Foo7Sym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo7Sym1KindInference) GHC.Tuple.()) - data Foo7Sym1 (l :: a0123456789876543210) (l :: TyFun b0123456789876543210 b0123456789876543210) - = forall arg. SameKind (Apply (Foo7Sym1 l) arg) (Foo7Sym2 l arg) => - Foo7Sym1KindInference - type instance Apply (Foo7Sym1 l) l = Foo7 l l - instance SuppressUnusedWarnings Foo7Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo7Sym0KindInference) GHC.Tuple.()) - data Foo7Sym0 (l :: TyFun a0123456789876543210 (TyFun b0123456789876543210 b0123456789876543210 - -> GHC.Types.Type)) - = forall arg. SameKind (Apply Foo7Sym0 arg) (Foo7Sym1 arg) => - Foo7Sym0KindInference - type instance Apply Foo7Sym0 l = Foo7Sym1 l - type Foo6Sym2 (t :: a0123456789876543210) (t :: b0123456789876543210) = - Foo6 t t - instance SuppressUnusedWarnings Foo6Sym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo6Sym1KindInference) GHC.Tuple.()) - data Foo6Sym1 (l :: a0123456789876543210) (l :: TyFun b0123456789876543210 a0123456789876543210) - = forall arg. SameKind (Apply (Foo6Sym1 l) arg) (Foo6Sym2 l arg) => - Foo6Sym1KindInference - type instance Apply (Foo6Sym1 l) l = Foo6 l l - instance SuppressUnusedWarnings Foo6Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo6Sym0KindInference) GHC.Tuple.()) - data Foo6Sym0 (l :: TyFun a0123456789876543210 (TyFun b0123456789876543210 a0123456789876543210 - -> GHC.Types.Type)) - = forall arg. SameKind (Apply Foo6Sym0 arg) (Foo6Sym1 arg) => - Foo6Sym0KindInference - type instance Apply Foo6Sym0 l = Foo6Sym1 l - type Foo5Sym2 (t :: a0123456789876543210) (t :: b0123456789876543210) = - Foo5 t t - instance SuppressUnusedWarnings Foo5Sym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo5Sym1KindInference) GHC.Tuple.()) - data Foo5Sym1 (l :: a0123456789876543210) (l :: TyFun b0123456789876543210 b0123456789876543210) - = forall arg. SameKind (Apply (Foo5Sym1 l) arg) (Foo5Sym2 l arg) => - Foo5Sym1KindInference - type instance Apply (Foo5Sym1 l) l = Foo5 l l - instance SuppressUnusedWarnings Foo5Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo5Sym0KindInference) GHC.Tuple.()) - data Foo5Sym0 (l :: TyFun a0123456789876543210 (TyFun b0123456789876543210 b0123456789876543210 - -> GHC.Types.Type)) - = forall arg. SameKind (Apply Foo5Sym0 arg) (Foo5Sym1 arg) => - Foo5Sym0KindInference - type instance Apply Foo5Sym0 l = Foo5Sym1 l - type Foo4Sym3 (t :: a0123456789876543210) (t :: b0123456789876543210) (t :: c0123456789876543210) = - Foo4 t t t - instance SuppressUnusedWarnings Foo4Sym2 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo4Sym2KindInference) GHC.Tuple.()) - data Foo4Sym2 (l :: a0123456789876543210) (l :: b0123456789876543210) (l :: TyFun c0123456789876543210 a0123456789876543210) - = forall arg. SameKind (Apply (Foo4Sym2 l l) arg) (Foo4Sym3 l l arg) => - Foo4Sym2KindInference - type instance Apply (Foo4Sym2 l l) l = Foo4 l l l - instance SuppressUnusedWarnings Foo4Sym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo4Sym1KindInference) GHC.Tuple.()) - data Foo4Sym1 (l :: a0123456789876543210) (l :: TyFun b0123456789876543210 (TyFun c0123456789876543210 a0123456789876543210 - -> GHC.Types.Type)) - = forall arg. SameKind (Apply (Foo4Sym1 l) arg) (Foo4Sym2 l arg) => - Foo4Sym1KindInference - type instance Apply (Foo4Sym1 l) l = Foo4Sym2 l l - instance SuppressUnusedWarnings Foo4Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo4Sym0KindInference) GHC.Tuple.()) - data Foo4Sym0 (l :: TyFun a0123456789876543210 (TyFun b0123456789876543210 (TyFun c0123456789876543210 a0123456789876543210 - -> GHC.Types.Type) - -> GHC.Types.Type)) - = forall arg. SameKind (Apply Foo4Sym0 arg) (Foo4Sym1 arg) => - Foo4Sym0KindInference - type instance Apply Foo4Sym0 l = Foo4Sym1 l - type Foo3Sym1 (t :: a0123456789876543210) = Foo3 t - instance SuppressUnusedWarnings Foo3Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo3Sym0KindInference) GHC.Tuple.()) - data Foo3Sym0 (l :: TyFun a0123456789876543210 a0123456789876543210) - = forall arg. SameKind (Apply Foo3Sym0 arg) (Foo3Sym1 arg) => - Foo3Sym0KindInference - type instance Apply Foo3Sym0 l = Foo3 l - type Foo2Sym2 (t :: a0123456789876543210) (t :: b0123456789876543210) = - Foo2 t t - instance SuppressUnusedWarnings Foo2Sym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo2Sym1KindInference) GHC.Tuple.()) - data Foo2Sym1 (l :: a0123456789876543210) (l :: TyFun b0123456789876543210 a0123456789876543210) - = forall arg. SameKind (Apply (Foo2Sym1 l) arg) (Foo2Sym2 l arg) => - Foo2Sym1KindInference - type instance Apply (Foo2Sym1 l) l = Foo2 l l - instance SuppressUnusedWarnings Foo2Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo2Sym0KindInference) GHC.Tuple.()) - data Foo2Sym0 (l :: TyFun a0123456789876543210 (TyFun b0123456789876543210 a0123456789876543210 - -> GHC.Types.Type)) - = forall arg. SameKind (Apply Foo2Sym0 arg) (Foo2Sym1 arg) => - Foo2Sym0KindInference - type instance Apply Foo2Sym0 l = Foo2Sym1 l - type Foo1Sym2 (t :: a0123456789876543210) (t :: b0123456789876543210) = - Foo1 t t - instance SuppressUnusedWarnings Foo1Sym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo1Sym1KindInference) GHC.Tuple.()) - data Foo1Sym1 (l :: a0123456789876543210) (l :: TyFun b0123456789876543210 a0123456789876543210) - = forall arg. SameKind (Apply (Foo1Sym1 l) arg) (Foo1Sym2 l arg) => - Foo1Sym1KindInference - type instance Apply (Foo1Sym1 l) l = Foo1 l l - instance SuppressUnusedWarnings Foo1Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo1Sym0KindInference) GHC.Tuple.()) - data Foo1Sym0 (l :: TyFun a0123456789876543210 (TyFun b0123456789876543210 a0123456789876543210 - -> GHC.Types.Type)) - = forall arg. SameKind (Apply Foo1Sym0 arg) (Foo1Sym1 arg) => - Foo1Sym0KindInference - type instance Apply Foo1Sym0 l = Foo1Sym1 l - type Foo0Sym2 (t :: a0123456789876543210) (t :: b0123456789876543210) = - Foo0 t t - instance SuppressUnusedWarnings Foo0Sym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo0Sym1KindInference) GHC.Tuple.()) - data Foo0Sym1 (l :: a0123456789876543210) (l :: TyFun b0123456789876543210 a0123456789876543210) - = forall arg. SameKind (Apply (Foo0Sym1 l) arg) (Foo0Sym2 l arg) => - Foo0Sym1KindInference - type instance Apply (Foo0Sym1 l) l = Foo0 l l - instance SuppressUnusedWarnings Foo0Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo0Sym0KindInference) GHC.Tuple.()) - data Foo0Sym0 (l :: TyFun a0123456789876543210 (TyFun b0123456789876543210 a0123456789876543210 - -> GHC.Types.Type)) - = forall arg. SameKind (Apply Foo0Sym0 arg) (Foo0Sym1 arg) => - Foo0Sym0KindInference - type instance Apply Foo0Sym0 l = Foo0Sym1 l - type family Foo8 (a :: Foo a b) :: a where - Foo8 x = Apply (Apply Lambda_0123456789876543210Sym0 x) x - type family Foo7 (a :: a) (a :: b) :: b where - Foo7 x y = Apply (Apply (Apply Lambda_0123456789876543210Sym0 x) y) (Apply (Apply Tuple2Sym0 x) y) - type family Foo6 (a :: a) (a :: b) :: a where - Foo6 a b = Apply (Apply (Apply (Apply Lambda_0123456789876543210Sym0 a) b) a) b - type family Foo5 (a :: a) (a :: b) :: b where - Foo5 x y = Apply (Apply (Apply Lambda_0123456789876543210Sym0 x) y) y - type family Foo4 (a :: a) (a :: b) (a :: c) :: a where - Foo4 x y z = Apply (Apply (Apply (Apply (Apply Lambda_0123456789876543210Sym0 x) y) z) y) z - type family Foo3 (a :: a) :: a where - Foo3 x = Apply (Apply Lambda_0123456789876543210Sym0 x) x - type family Foo2 (a :: a) (a :: b) :: a where - Foo2 x y = Apply (Apply (Apply Lambda_0123456789876543210Sym0 x) y) y - type family Foo1 (a :: a) (a :: b) :: a where - Foo1 x a_0123456789876543210 = Apply (Apply (Apply Lambda_0123456789876543210Sym0 x) a_0123456789876543210) a_0123456789876543210 - type family Foo0 (a :: a) (a :: b) :: a where - Foo0 a_0123456789876543210 a_0123456789876543210 = Apply (Apply (Apply (Apply Lambda_0123456789876543210Sym0 a_0123456789876543210) a_0123456789876543210) a_0123456789876543210) a_0123456789876543210 - sFoo8 :: - forall (t :: Foo a b). Sing t -> Sing (Apply Foo8Sym0 t :: a) - sFoo7 :: - forall (t :: a) (t :: b). - Sing t -> Sing t -> Sing (Apply (Apply Foo7Sym0 t) t :: b) - sFoo6 :: - forall (t :: a) (t :: b). - Sing t -> Sing t -> Sing (Apply (Apply Foo6Sym0 t) t :: a) - sFoo5 :: - forall (t :: a) (t :: b). - Sing t -> Sing t -> Sing (Apply (Apply Foo5Sym0 t) t :: b) - sFoo4 :: - forall (t :: a) (t :: b) (t :: c). - Sing t - -> Sing t - -> Sing t -> Sing (Apply (Apply (Apply Foo4Sym0 t) t) t :: a) - sFoo3 :: forall (t :: a). Sing t -> Sing (Apply Foo3Sym0 t :: a) - sFoo2 :: - forall (t :: a) (t :: b). - Sing t -> Sing t -> Sing (Apply (Apply Foo2Sym0 t) t :: a) - sFoo1 :: - forall (t :: a) (t :: b). - Sing t -> Sing t -> Sing (Apply (Apply Foo1Sym0 t) t :: a) - sFoo0 :: - forall (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 - -> case sArg_0123456789876543210 of { - SFoo (sA :: Sing a) _ -> sA } :: - Sing (Case_0123456789876543210 x arg_0123456789876543210 arg_0123456789876543210) }))) - 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 - -> case sArg_0123456789876543210 of { - STuple2 _ (sB :: Sing b) -> sB } :: - Sing (Case_0123456789876543210 x y arg_0123456789876543210 arg_0123456789876543210) }))) - ((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 a) b) x)) - (\ sArg_0123456789876543210 - -> case sArg_0123456789876543210 of { - _ :: Sing arg_0123456789876543210 - -> case sArg_0123456789876543210 of { _ -> sX } :: - Sing (Case_0123456789876543210 a b x arg_0123456789876543210 arg_0123456789876543210) }) }))) - 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 - (GHC.Tuple.(,) sArg_0123456789876543210) sArg_0123456789876543210 - of { - GHC.Tuple.(,) (_ :: Sing arg_0123456789876543210) - (_ :: Sing arg_0123456789876543210) - -> case - (applySing - ((applySing ((singFun2 @Tuple2Sym0) STuple2)) - sArg_0123456789876543210)) - sArg_0123456789876543210 - of { - STuple2 _ _ -> sX } :: - Sing (Case_0123456789876543210 x y z arg_0123456789876543210 arg_0123456789876543210 (Apply (Apply Tuple2Sym0 arg_0123456789876543210) arg_0123456789876543210)) }))) - 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 - -> case sArg_0123456789876543210 of { _ -> sX } :: - Sing (Case_0123456789876543210 x y arg_0123456789876543210 arg_0123456789876543210) }))) - 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 - -> case sArg_0123456789876543210 of { _ -> sX } :: - Sing (Case_0123456789876543210 x arg_0123456789876543210 a_0123456789876543210 arg_0123456789876543210) }))) - 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 (GHC.Tuple.(,) sX) sY of { - GHC.Tuple.(,) (_ :: Sing x) (_ :: Sing y) -> sX }))) - sA_0123456789876543210)) - sA_0123456789876543210 - data instance Sing (z :: Foo a b) - = forall (n :: a) (n :: b). z ~ Foo n n => - SFoo (Sing (n :: a)) (Sing (n :: b)) - type SFoo = (Sing :: Foo a b -> GHC.Types.Type) - 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 b) - = case - (GHC.Tuple.(,) (toSing b :: SomeSing a)) (toSing b :: SomeSing b) - of { - GHC.Tuple.(,) (SomeSing c) (SomeSing c) -> SomeSing ((SFoo c) c) } - instance (SingI n, SingI n) => SingI (Foo (n :: a) (n :: b)) where - sing = (SFoo sing) sing diff --git a/tests/compile-and-dump/Singletons/Lambdas.hs b/tests/compile-and-dump/Singletons/Lambdas.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Lambdas.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-unused-matches -fno-warn-name-shadowing -fno-warn-unused-imports #-} - -{-# LANGUAGE UnboxedTuples #-} --- We expect unused binds and name shadowing in foo5 test. -module Singletons.Lambdas where - -import Data.Proxy -import Data.Singletons -import Data.Singletons.TH - -$(singletons [d| - -- nothing in scope - foo0 :: a -> b -> a - foo0 = (\x y -> x) - - -- eta-reduced function - foo1 :: a -> b -> a - foo1 x = (\_ -> x) - - -- same as before, but without eta-reduction - foo2 :: a -> b -> a - foo2 x y = (\_ -> x) y - - foo3 :: a -> a - foo3 x = (\y -> y) x - - -- more lambda parameters + returning in-scope variable - foo4 :: a -> b -> c -> a - foo4 x y z = (\_ _ -> x) y z - - -- name shadowing - -- Note: due to -dsuppress-uniques output of this test does not really - -- prove that the result is correct. Compiling this file manually and - -- examining dumped splise of relevant Lamdba reveals that indeed that Lambda - -- returns its last parameter (ie. y passed in a call) rather than the - -- first one (ie. x that is shadowed by the binder in a lambda). - foo5 :: a -> b -> b - foo5 x y = (\x -> x) y - - -- nested lambdas - foo6 :: a -> b -> a - foo6 a b = (\x -> \_ -> x) a b - - -- tuple patterns - foo7 :: a -> b -> b - foo7 x y = (\(_, b) -> b) (x, y) - - -- constructor patters=ns - data Foo a b = Foo a b - foo8 :: Foo a b -> a - foo8 x = (\(Foo a _) -> a) x - |]) - -foo1a :: Proxy (Foo1 Int Char) -foo1a = Proxy - -foo1b :: Proxy Int -foo1b = foo1a - -foo2a :: Proxy (Foo2 Int Char) -foo2a = Proxy - -foo2b :: Proxy Int -foo2b = foo2a - -foo3a :: Proxy (Foo3 Int) -foo3a = Proxy - -foo3b :: Proxy Int -foo3b = foo3a - -foo4a :: Proxy (Foo4 Int Char Bool) -foo4a = Proxy - -foo4b :: Proxy Int -foo4b = foo4a - -foo5a :: Proxy (Foo5 Int Bool) -foo5a = Proxy - -foo5b :: Proxy Bool -foo5b = foo5a - -foo6a :: Proxy (Foo6 Int Char) -foo6a = Proxy - -foo6b :: Proxy Int -foo6b = foo6a - -foo7a :: Proxy (Foo7 Int Char) -foo7a = Proxy - -foo7b :: Proxy Char -foo7b = foo7a diff --git a/tests/compile-and-dump/Singletons/LambdasComprehensive.ghc82.template b/tests/compile-and-dump/Singletons/LambdasComprehensive.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/LambdasComprehensive.ghc82.template +++ /dev/null @@ -1,71 +0,0 @@ -Singletons/LambdasComprehensive.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| foo :: [Nat] - foo - = map (\ x -> either_ pred Succ x) [Left Zero, Right (Succ Zero)] - bar :: [Nat] - bar = map (either_ pred Succ) [Left Zero, Right (Succ Zero)] |] - ======> - foo :: [Nat] - foo - = (map (\ x -> ((either_ pred) Succ) x)) - [Left Zero, Right (Succ Zero)] - bar :: [Nat] - bar = (map ((either_ pred) Succ)) [Left Zero, Right (Succ Zero)] - type family Lambda_0123456789876543210 t where - Lambda_0123456789876543210 x = Apply (Apply (Apply Either_Sym0 PredSym0) SuccSym0) x - type Lambda_0123456789876543210Sym1 t = - Lambda_0123456789876543210 t - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym0 l - = forall arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0KindInference - type instance Apply Lambda_0123456789876543210Sym0 l = Lambda_0123456789876543210 l - type BarSym0 = Bar - type FooSym0 = Foo - type family Bar :: [Nat] where - = Apply (Apply MapSym0 (Apply (Apply Either_Sym0 PredSym0) SuccSym0)) (Apply (Apply (:$) (Apply LeftSym0 ZeroSym0)) (Apply (Apply (:$) (Apply RightSym0 (Apply SuccSym0 ZeroSym0))) '[])) - type family Foo :: [Nat] where - = Apply (Apply MapSym0 Lambda_0123456789876543210Sym0) (Apply (Apply (:$) (Apply LeftSym0 ZeroSym0)) (Apply (Apply (:$) (Apply RightSym0 (Apply SuccSym0 ZeroSym0))) '[])) - sBar :: Sing (BarSym0 :: [Nat]) - sFoo :: Sing (FooSym0 :: [Nat]) - sBar - = (applySing - ((applySing ((singFun2 @MapSym0) sMap)) - ((applySing - ((applySing ((singFun3 @Either_Sym0) sEither_)) - ((singFun1 @PredSym0) sPred))) - ((singFun1 @SuccSym0) SSucc)))) - ((applySing - ((applySing ((singFun2 @(:$)) SCons)) - ((applySing ((singFun1 @LeftSym0) SLeft)) SZero))) - ((applySing - ((applySing ((singFun2 @(:$)) SCons)) - ((applySing ((singFun1 @RightSym0) SRight)) - ((applySing ((singFun1 @SuccSym0) SSucc)) SZero)))) - SNil)) - sFoo - = (applySing - ((applySing ((singFun2 @MapSym0) sMap)) - ((singFun1 @Lambda_0123456789876543210Sym0) - (\ sX - -> case sX of { - _ :: Sing x - -> (applySing - ((applySing - ((applySing ((singFun3 @Either_Sym0) sEither_)) - ((singFun1 @PredSym0) sPred))) - ((singFun1 @SuccSym0) SSucc))) - sX })))) - ((applySing - ((applySing ((singFun2 @(:$)) SCons)) - ((applySing ((singFun1 @LeftSym0) SLeft)) SZero))) - ((applySing - ((applySing ((singFun2 @(:$)) SCons)) - ((applySing ((singFun1 @RightSym0) SRight)) - ((applySing ((singFun1 @SuccSym0) SSucc)) SZero)))) - SNil)) diff --git a/tests/compile-and-dump/Singletons/LambdasComprehensive.hs b/tests/compile-and-dump/Singletons/LambdasComprehensive.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/LambdasComprehensive.hs +++ /dev/null @@ -1,29 +0,0 @@ -module Singletons.LambdasComprehensive where - -import Data.Singletons.SuppressUnusedWarnings -import Data.Singletons.TH -import Data.Singletons.Prelude -import Singletons.Nat - -import Prelude hiding (pred) - -$(singletons [d| - foo :: [Nat] - foo = map (\x -> either_ pred Succ x) [Left Zero, Right (Succ Zero)] - - -- this is the same as above except that it does not use lambdas - bar :: [Nat] - bar = map (either_ pred Succ) [Left Zero, Right (Succ Zero)] - |]) - -fooTest1a :: Proxy Foo -fooTest1a = Proxy - -fooTest1b :: Proxy [Zero, Succ (Succ Zero)] -fooTest1b = fooTest1a - -barTest1a :: Proxy Bar -barTest1a = Proxy - -barTest1b :: Proxy [Zero, Succ (Succ Zero)] -barTest1b = barTest1a diff --git a/tests/compile-and-dump/Singletons/LetStatements.ghc82.template b/tests/compile-and-dump/Singletons/LetStatements.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/LetStatements.ghc82.template +++ /dev/null @@ -1,908 +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, - _z_0123456789876543210) = y_0123456789876543210 - type family Case_0123456789876543210 x t where - Case_0123456789876543210 x '(_z_0123456789876543210, - y_0123456789876543210) = y_0123456789876543210 - type Let0123456789876543210YSym1 t = Let0123456789876543210Y t - instance SuppressUnusedWarnings Let0123456789876543210YSym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Let0123456789876543210YSym0KindInference) - GHC.Tuple.()) - data Let0123456789876543210YSym0 l - = forall arg. SameKind (Apply Let0123456789876543210YSym0 arg) (Let0123456789876543210YSym1 arg) => - Let0123456789876543210YSym0KindInference - type instance Apply Let0123456789876543210YSym0 l = Let0123456789876543210Y l - type Let0123456789876543210ZSym1 t = Let0123456789876543210Z t - instance SuppressUnusedWarnings Let0123456789876543210ZSym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Let0123456789876543210ZSym0KindInference) - GHC.Tuple.()) - data Let0123456789876543210ZSym0 l - = forall arg. SameKind (Apply Let0123456789876543210ZSym0 arg) (Let0123456789876543210ZSym1 arg) => - Let0123456789876543210ZSym0KindInference - type instance Apply Let0123456789876543210ZSym0 l = Let0123456789876543210Z l - type Let0123456789876543210X_0123456789876543210Sym1 t = - Let0123456789876543210X_0123456789876543210 t - instance SuppressUnusedWarnings Let0123456789876543210X_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) - Let0123456789876543210X_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Let0123456789876543210X_0123456789876543210Sym0 l - = forall arg. SameKind (Apply Let0123456789876543210X_0123456789876543210Sym0 arg) (Let0123456789876543210X_0123456789876543210Sym1 arg) => - Let0123456789876543210X_0123456789876543210Sym0KindInference - type instance Apply Let0123456789876543210X_0123456789876543210Sym0 l = Let0123456789876543210X_0123456789876543210 l - type family Let0123456789876543210Y x where - Let0123456789876543210Y x = Case_0123456789876543210 x (Let0123456789876543210X_0123456789876543210Sym1 x) - type family Let0123456789876543210Z x where - Let0123456789876543210Z x = Case_0123456789876543210 x (Let0123456789876543210X_0123456789876543210Sym1 x) - type family Let0123456789876543210X_0123456789876543210 x where - Let0123456789876543210X_0123456789876543210 x = Apply (Apply Tuple2Sym0 (Apply SuccSym0 x)) x - type Let0123456789876543210BarSym1 t = Let0123456789876543210Bar t - instance SuppressUnusedWarnings Let0123456789876543210BarSym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Let0123456789876543210BarSym0KindInference) - GHC.Tuple.()) - data Let0123456789876543210BarSym0 l - = forall arg. SameKind (Apply Let0123456789876543210BarSym0 arg) (Let0123456789876543210BarSym1 arg) => - Let0123456789876543210BarSym0KindInference - type instance Apply Let0123456789876543210BarSym0 l = Let0123456789876543210Bar l - type family Let0123456789876543210Bar x :: a where - Let0123456789876543210Bar x = x - type (:<<<%%%%%%%%%%%%%%%%%%%:+$$$$) t (t :: Nat) (t :: Nat) = - (:<<<%%%%%%%%%%%%%%%%%%%:+) t t t - instance SuppressUnusedWarnings (:<<<%%%%%%%%%%%%%%%%%%%:+$$$) where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) (:<<<%%%%%%%%%%%%%%%%%%%:+$$$###)) GHC.Tuple.()) - data (:<<<%%%%%%%%%%%%%%%%%%%:+$$$) l (l :: Nat) (l :: TyFun Nat Nat) - = forall arg. SameKind (Apply ((:<<<%%%%%%%%%%%%%%%%%%%:+$$$) l l) arg) ((:<<<%%%%%%%%%%%%%%%%%%%:+$$$$) l l arg) => - (:<<<%%%%%%%%%%%%%%%%%%%:+$$$###) - type instance Apply ((:<<<%%%%%%%%%%%%%%%%%%%:+$$$) l l) l = (:<<<%%%%%%%%%%%%%%%%%%%:+) l l l - instance SuppressUnusedWarnings (:<<<%%%%%%%%%%%%%%%%%%%:+$$) where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) (:<<<%%%%%%%%%%%%%%%%%%%:+$$###)) GHC.Tuple.()) - data (:<<<%%%%%%%%%%%%%%%%%%%:+$$) l (l :: TyFun Nat (TyFun Nat Nat - -> GHC.Types.Type)) - = forall arg. SameKind (Apply ((:<<<%%%%%%%%%%%%%%%%%%%:+$$) l) arg) ((:<<<%%%%%%%%%%%%%%%%%%%:+$$$) l arg) => - (:<<<%%%%%%%%%%%%%%%%%%%:+$$###) - type instance Apply ((:<<<%%%%%%%%%%%%%%%%%%%:+$$) l) l = (:<<<%%%%%%%%%%%%%%%%%%%:+$$$) l l - instance SuppressUnusedWarnings (:<<<%%%%%%%%%%%%%%%%%%%:+$) where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) (:<<<%%%%%%%%%%%%%%%%%%%:+$###)) GHC.Tuple.()) - data (:<<<%%%%%%%%%%%%%%%%%%%:+$) l - = forall arg. SameKind (Apply (:<<<%%%%%%%%%%%%%%%%%%%:+$) arg) ((:<<<%%%%%%%%%%%%%%%%%%%:+$$) arg) => - (:<<<%%%%%%%%%%%%%%%%%%%:+$###) - type instance Apply (:<<<%%%%%%%%%%%%%%%%%%%:+$) l = (:<<<%%%%%%%%%%%%%%%%%%%:+$$) l - type family (:<<<%%%%%%%%%%%%%%%%%%%:+) x (a :: Nat) (a :: Nat) :: Nat where - (:<<<%%%%%%%%%%%%%%%%%%%:+) x Zero m = m - (:<<<%%%%%%%%%%%%%%%%%%%:+) x (Succ n) m = Apply SuccSym0 (Apply (Apply ((:<<<%%%%%%%%%%%%%%%%%%%:+$$) x) n) x) - type Let0123456789876543210ZSym1 t = Let0123456789876543210Z t - instance SuppressUnusedWarnings Let0123456789876543210ZSym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Let0123456789876543210ZSym0KindInference) - GHC.Tuple.()) - data Let0123456789876543210ZSym0 l - = forall arg. SameKind (Apply Let0123456789876543210ZSym0 arg) (Let0123456789876543210ZSym1 arg) => - Let0123456789876543210ZSym0KindInference - type instance Apply Let0123456789876543210ZSym0 l = Let0123456789876543210Z l - type (:<<<%%%%%%%%%%%%%%%%%%%:+$$$$) t (t :: Nat) (t :: Nat) = - (:<<<%%%%%%%%%%%%%%%%%%%:+) t t t - instance SuppressUnusedWarnings (:<<<%%%%%%%%%%%%%%%%%%%:+$$$) where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) (:<<<%%%%%%%%%%%%%%%%%%%:+$$$###)) GHC.Tuple.()) - data (:<<<%%%%%%%%%%%%%%%%%%%:+$$$) l (l :: Nat) (l :: TyFun Nat Nat) - = forall arg. SameKind (Apply ((:<<<%%%%%%%%%%%%%%%%%%%:+$$$) l l) arg) ((:<<<%%%%%%%%%%%%%%%%%%%:+$$$$) l l arg) => - (:<<<%%%%%%%%%%%%%%%%%%%:+$$$###) - type instance Apply ((:<<<%%%%%%%%%%%%%%%%%%%:+$$$) l l) l = (:<<<%%%%%%%%%%%%%%%%%%%:+) l l l - instance SuppressUnusedWarnings (:<<<%%%%%%%%%%%%%%%%%%%:+$$) where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) (:<<<%%%%%%%%%%%%%%%%%%%:+$$###)) GHC.Tuple.()) - data (:<<<%%%%%%%%%%%%%%%%%%%:+$$) l (l :: TyFun Nat (TyFun Nat Nat - -> GHC.Types.Type)) - = forall arg. SameKind (Apply ((:<<<%%%%%%%%%%%%%%%%%%%:+$$) l) arg) ((:<<<%%%%%%%%%%%%%%%%%%%:+$$$) l arg) => - (:<<<%%%%%%%%%%%%%%%%%%%:+$$###) - type instance Apply ((:<<<%%%%%%%%%%%%%%%%%%%:+$$) l) l = (:<<<%%%%%%%%%%%%%%%%%%%:+$$$) l l - instance SuppressUnusedWarnings (:<<<%%%%%%%%%%%%%%%%%%%:+$) where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) (:<<<%%%%%%%%%%%%%%%%%%%:+$###)) GHC.Tuple.()) - data (:<<<%%%%%%%%%%%%%%%%%%%:+$) l - = forall arg. SameKind (Apply (:<<<%%%%%%%%%%%%%%%%%%%:+$) arg) ((:<<<%%%%%%%%%%%%%%%%%%%:+$$) arg) => - (:<<<%%%%%%%%%%%%%%%%%%%:+$###) - type instance Apply (:<<<%%%%%%%%%%%%%%%%%%%:+$) l = (:<<<%%%%%%%%%%%%%%%%%%%:+$$) l - type family Let0123456789876543210Z x :: Nat where - Let0123456789876543210Z x = x - type family (:<<<%%%%%%%%%%%%%%%%%%%:+) x (a :: Nat) (a :: Nat) :: Nat where - (:<<<%%%%%%%%%%%%%%%%%%%:+) x Zero m = m - (:<<<%%%%%%%%%%%%%%%%%%%:+) x (Succ n) m = Apply SuccSym0 (Apply (Apply ((:<<<%%%%%%%%%%%%%%%%%%%:+$$) x) n) m) - type (:<<<%%%%%%%%%%%%%%%%%%%:+$$$$) t (t :: Nat) (t :: Nat) = - (:<<<%%%%%%%%%%%%%%%%%%%:+) t t t - instance SuppressUnusedWarnings (:<<<%%%%%%%%%%%%%%%%%%%:+$$$) where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) (:<<<%%%%%%%%%%%%%%%%%%%:+$$$###)) GHC.Tuple.()) - data (:<<<%%%%%%%%%%%%%%%%%%%:+$$$) l (l :: Nat) (l :: TyFun Nat Nat) - = forall arg. SameKind (Apply ((:<<<%%%%%%%%%%%%%%%%%%%:+$$$) l l) arg) ((:<<<%%%%%%%%%%%%%%%%%%%:+$$$$) l l arg) => - (:<<<%%%%%%%%%%%%%%%%%%%:+$$$###) - type instance Apply ((:<<<%%%%%%%%%%%%%%%%%%%:+$$$) l l) l = (:<<<%%%%%%%%%%%%%%%%%%%:+) l l l - instance SuppressUnusedWarnings (:<<<%%%%%%%%%%%%%%%%%%%:+$$) where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) (:<<<%%%%%%%%%%%%%%%%%%%:+$$###)) GHC.Tuple.()) - data (:<<<%%%%%%%%%%%%%%%%%%%:+$$) l (l :: TyFun Nat (TyFun Nat Nat - -> GHC.Types.Type)) - = forall arg. SameKind (Apply ((:<<<%%%%%%%%%%%%%%%%%%%:+$$) l) arg) ((:<<<%%%%%%%%%%%%%%%%%%%:+$$$) l arg) => - (:<<<%%%%%%%%%%%%%%%%%%%:+$$###) - type instance Apply ((:<<<%%%%%%%%%%%%%%%%%%%:+$$) l) l = (:<<<%%%%%%%%%%%%%%%%%%%:+$$$) l l - instance SuppressUnusedWarnings (:<<<%%%%%%%%%%%%%%%%%%%:+$) where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) (:<<<%%%%%%%%%%%%%%%%%%%:+$###)) GHC.Tuple.()) - data (:<<<%%%%%%%%%%%%%%%%%%%:+$) l - = forall arg. SameKind (Apply (:<<<%%%%%%%%%%%%%%%%%%%:+$) arg) ((:<<<%%%%%%%%%%%%%%%%%%%:+$$) arg) => - (:<<<%%%%%%%%%%%%%%%%%%%:+$###) - type instance Apply (:<<<%%%%%%%%%%%%%%%%%%%:+$) l = (:<<<%%%%%%%%%%%%%%%%%%%:+$$) l - 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 x a_0123456789876543210 t where - Lambda_0123456789876543210 x a_0123456789876543210 x = x - type Lambda_0123456789876543210Sym3 t t t = - Lambda_0123456789876543210 t t t - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym2 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym2KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym2 l l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym2 l l) arg) (Lambda_0123456789876543210Sym3 l l arg) => - Lambda_0123456789876543210Sym2KindInference - type instance Apply (Lambda_0123456789876543210Sym2 l l) l = Lambda_0123456789876543210 l l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym1 l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym1 l) arg) (Lambda_0123456789876543210Sym2 l arg) => - Lambda_0123456789876543210Sym1KindInference - type instance Apply (Lambda_0123456789876543210Sym1 l) l = Lambda_0123456789876543210Sym2 l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym0 l - = forall arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0KindInference - type instance Apply Lambda_0123456789876543210Sym0 l = Lambda_0123456789876543210Sym1 l - type Let0123456789876543210ZSym2 t (t :: Nat) = - Let0123456789876543210Z t t - instance SuppressUnusedWarnings Let0123456789876543210ZSym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Let0123456789876543210ZSym1KindInference) - GHC.Tuple.()) - data Let0123456789876543210ZSym1 l (l :: TyFun Nat Nat) - = forall arg. SameKind (Apply (Let0123456789876543210ZSym1 l) arg) (Let0123456789876543210ZSym2 l arg) => - Let0123456789876543210ZSym1KindInference - type instance Apply (Let0123456789876543210ZSym1 l) l = Let0123456789876543210Z l l - instance SuppressUnusedWarnings Let0123456789876543210ZSym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Let0123456789876543210ZSym0KindInference) - GHC.Tuple.()) - data Let0123456789876543210ZSym0 l - = forall arg. SameKind (Apply Let0123456789876543210ZSym0 arg) (Let0123456789876543210ZSym1 arg) => - Let0123456789876543210ZSym0KindInference - type instance Apply Let0123456789876543210ZSym0 l = Let0123456789876543210ZSym1 l - type family Let0123456789876543210Z x (a :: Nat) :: Nat where - Let0123456789876543210Z x a_0123456789876543210 = Apply (Apply (Apply Lambda_0123456789876543210Sym0 x) a_0123456789876543210) a_0123456789876543210 - type family Lambda_0123456789876543210 x t where - Lambda_0123456789876543210 x x = x - type Lambda_0123456789876543210Sym2 t t = - Lambda_0123456789876543210 t t - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym1 l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym1 l) arg) (Lambda_0123456789876543210Sym2 l arg) => - Lambda_0123456789876543210Sym1KindInference - type instance Apply (Lambda_0123456789876543210Sym1 l) l = Lambda_0123456789876543210 l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym0 l - = forall arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0KindInference - type instance Apply Lambda_0123456789876543210Sym0 l = Lambda_0123456789876543210Sym1 l - type Let0123456789876543210ZSym1 t = Let0123456789876543210Z t - instance SuppressUnusedWarnings Let0123456789876543210ZSym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Let0123456789876543210ZSym0KindInference) - GHC.Tuple.()) - data Let0123456789876543210ZSym0 l - = forall arg. SameKind (Apply Let0123456789876543210ZSym0 arg) (Let0123456789876543210ZSym1 arg) => - Let0123456789876543210ZSym0KindInference - type instance Apply Let0123456789876543210ZSym0 l = Let0123456789876543210Z l - type family Let0123456789876543210Z x :: Nat where - Let0123456789876543210Z x = Apply (Apply Lambda_0123456789876543210Sym0 x) ZeroSym0 - type Let0123456789876543210XSym1 t = Let0123456789876543210X t - instance SuppressUnusedWarnings Let0123456789876543210XSym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Let0123456789876543210XSym0KindInference) - GHC.Tuple.()) - data Let0123456789876543210XSym0 l - = forall arg. SameKind (Apply Let0123456789876543210XSym0 arg) (Let0123456789876543210XSym1 arg) => - Let0123456789876543210XSym0KindInference - type instance Apply Let0123456789876543210XSym0 l = Let0123456789876543210X l - type family Let0123456789876543210X x :: Nat where - Let0123456789876543210X x = ZeroSym0 - type Let0123456789876543210FSym2 t (t :: Nat) = - Let0123456789876543210F t t - instance SuppressUnusedWarnings Let0123456789876543210FSym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Let0123456789876543210FSym1KindInference) - GHC.Tuple.()) - data Let0123456789876543210FSym1 l (l :: TyFun Nat Nat) - = forall arg. SameKind (Apply (Let0123456789876543210FSym1 l) arg) (Let0123456789876543210FSym2 l arg) => - Let0123456789876543210FSym1KindInference - type instance Apply (Let0123456789876543210FSym1 l) l = Let0123456789876543210F l l - instance SuppressUnusedWarnings Let0123456789876543210FSym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Let0123456789876543210FSym0KindInference) - GHC.Tuple.()) - data Let0123456789876543210FSym0 l - = forall arg. SameKind (Apply Let0123456789876543210FSym0 arg) (Let0123456789876543210FSym1 arg) => - Let0123456789876543210FSym0KindInference - type instance Apply Let0123456789876543210FSym0 l = Let0123456789876543210FSym1 l - type family Let0123456789876543210F x (a :: Nat) :: Nat where - Let0123456789876543210F x y = Apply SuccSym0 y - type Let0123456789876543210ZSym1 t = Let0123456789876543210Z t - instance SuppressUnusedWarnings Let0123456789876543210ZSym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Let0123456789876543210ZSym0KindInference) - GHC.Tuple.()) - data Let0123456789876543210ZSym0 l - = forall arg. SameKind (Apply Let0123456789876543210ZSym0 arg) (Let0123456789876543210ZSym1 arg) => - Let0123456789876543210ZSym0KindInference - type instance Apply Let0123456789876543210ZSym0 l = Let0123456789876543210Z l - type family Let0123456789876543210Z x :: Nat where - Let0123456789876543210Z x = Apply (Let0123456789876543210FSym1 x) x - type Let0123456789876543210ZSym2 t t = Let0123456789876543210Z t t - instance SuppressUnusedWarnings Let0123456789876543210ZSym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Let0123456789876543210ZSym1KindInference) - GHC.Tuple.()) - data Let0123456789876543210ZSym1 l l - = forall arg. SameKind (Apply (Let0123456789876543210ZSym1 l) arg) (Let0123456789876543210ZSym2 l arg) => - Let0123456789876543210ZSym1KindInference - type instance Apply (Let0123456789876543210ZSym1 l) l = Let0123456789876543210Z l l - instance SuppressUnusedWarnings Let0123456789876543210ZSym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Let0123456789876543210ZSym0KindInference) - GHC.Tuple.()) - data Let0123456789876543210ZSym0 l - = forall arg. SameKind (Apply Let0123456789876543210ZSym0 arg) (Let0123456789876543210ZSym1 arg) => - Let0123456789876543210ZSym0KindInference - type instance Apply Let0123456789876543210ZSym0 l = Let0123456789876543210ZSym1 l - type family Let0123456789876543210Z x y :: Nat where - Let0123456789876543210Z x y = Apply SuccSym0 y - type Let0123456789876543210FSym2 t (t :: Nat) = - Let0123456789876543210F t t - instance SuppressUnusedWarnings Let0123456789876543210FSym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Let0123456789876543210FSym1KindInference) - GHC.Tuple.()) - data Let0123456789876543210FSym1 l (l :: TyFun Nat Nat) - = forall arg. SameKind (Apply (Let0123456789876543210FSym1 l) arg) (Let0123456789876543210FSym2 l arg) => - Let0123456789876543210FSym1KindInference - type instance Apply (Let0123456789876543210FSym1 l) l = Let0123456789876543210F l l - instance SuppressUnusedWarnings Let0123456789876543210FSym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Let0123456789876543210FSym0KindInference) - GHC.Tuple.()) - data Let0123456789876543210FSym0 l - = forall arg. SameKind (Apply Let0123456789876543210FSym0 arg) (Let0123456789876543210FSym1 arg) => - Let0123456789876543210FSym0KindInference - type instance Apply Let0123456789876543210FSym0 l = Let0123456789876543210FSym1 l - type family Let0123456789876543210F x (a :: Nat) :: Nat where - Let0123456789876543210F x y = Apply SuccSym0 (Let0123456789876543210ZSym2 x y) - type Let0123456789876543210FSym2 t (t :: Nat) = - Let0123456789876543210F t t - instance SuppressUnusedWarnings Let0123456789876543210FSym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Let0123456789876543210FSym1KindInference) - GHC.Tuple.()) - data Let0123456789876543210FSym1 l (l :: TyFun Nat Nat) - = forall arg. SameKind (Apply (Let0123456789876543210FSym1 l) arg) (Let0123456789876543210FSym2 l arg) => - Let0123456789876543210FSym1KindInference - type instance Apply (Let0123456789876543210FSym1 l) l = Let0123456789876543210F l l - instance SuppressUnusedWarnings Let0123456789876543210FSym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Let0123456789876543210FSym0KindInference) - GHC.Tuple.()) - data Let0123456789876543210FSym0 l - = forall arg. SameKind (Apply Let0123456789876543210FSym0 arg) (Let0123456789876543210FSym1 arg) => - Let0123456789876543210FSym0KindInference - type instance Apply Let0123456789876543210FSym0 l = Let0123456789876543210FSym1 l - type family Let0123456789876543210F x (a :: Nat) :: Nat where - Let0123456789876543210F x y = Apply SuccSym0 y - type Let0123456789876543210YSym1 t = Let0123456789876543210Y t - instance SuppressUnusedWarnings Let0123456789876543210YSym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Let0123456789876543210YSym0KindInference) - GHC.Tuple.()) - data Let0123456789876543210YSym0 l - = forall arg. SameKind (Apply Let0123456789876543210YSym0 arg) (Let0123456789876543210YSym1 arg) => - Let0123456789876543210YSym0KindInference - type instance Apply Let0123456789876543210YSym0 l = Let0123456789876543210Y l - type family Let0123456789876543210Y x :: Nat where - Let0123456789876543210Y x = Apply SuccSym0 x - type Let0123456789876543210YSym0 = Let0123456789876543210Y - type Let0123456789876543210ZSym0 = Let0123456789876543210Z - type family Let0123456789876543210Y where - = Apply SuccSym0 ZeroSym0 - type family Let0123456789876543210Z where - = Apply SuccSym0 Let0123456789876543210YSym0 - type Let0123456789876543210YSym1 t = Let0123456789876543210Y t - instance SuppressUnusedWarnings Let0123456789876543210YSym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Let0123456789876543210YSym0KindInference) - GHC.Tuple.()) - data Let0123456789876543210YSym0 l - = forall arg. SameKind (Apply Let0123456789876543210YSym0 arg) (Let0123456789876543210YSym1 arg) => - Let0123456789876543210YSym0KindInference - type instance Apply Let0123456789876543210YSym0 l = Let0123456789876543210Y l - type family Let0123456789876543210Y x :: Nat where - Let0123456789876543210Y x = Apply SuccSym0 ZeroSym0 - type Foo14Sym1 (t :: Nat) = Foo14 t - instance SuppressUnusedWarnings Foo14Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo14Sym0KindInference) GHC.Tuple.()) - data Foo14Sym0 (l :: TyFun Nat (Nat, Nat)) - = forall arg. SameKind (Apply Foo14Sym0 arg) (Foo14Sym1 arg) => - Foo14Sym0KindInference - type instance Apply Foo14Sym0 l = Foo14 l - type Foo13_Sym1 (t :: a0123456789876543210) = Foo13_ t - instance SuppressUnusedWarnings Foo13_Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo13_Sym0KindInference) GHC.Tuple.()) - data Foo13_Sym0 (l :: TyFun a0123456789876543210 a0123456789876543210) - = forall arg. SameKind (Apply Foo13_Sym0 arg) (Foo13_Sym1 arg) => - Foo13_Sym0KindInference - type instance Apply Foo13_Sym0 l = Foo13_ l - type Foo13Sym1 (t :: a0123456789876543210) = Foo13 t - instance SuppressUnusedWarnings Foo13Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo13Sym0KindInference) GHC.Tuple.()) - data Foo13Sym0 (l :: TyFun a0123456789876543210 a0123456789876543210) - = forall arg. SameKind (Apply Foo13Sym0 arg) (Foo13Sym1 arg) => - Foo13Sym0KindInference - type instance Apply Foo13Sym0 l = Foo13 l - type Foo12Sym1 (t :: Nat) = Foo12 t - instance SuppressUnusedWarnings Foo12Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo12Sym0KindInference) GHC.Tuple.()) - data Foo12Sym0 (l :: TyFun Nat Nat) - = forall arg. SameKind (Apply Foo12Sym0 arg) (Foo12Sym1 arg) => - Foo12Sym0KindInference - type instance Apply Foo12Sym0 l = Foo12 l - type Foo11Sym1 (t :: Nat) = Foo11 t - instance SuppressUnusedWarnings Foo11Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo11Sym0KindInference) GHC.Tuple.()) - data Foo11Sym0 (l :: TyFun Nat Nat) - = forall arg. SameKind (Apply Foo11Sym0 arg) (Foo11Sym1 arg) => - Foo11Sym0KindInference - type instance Apply Foo11Sym0 l = Foo11 l - type Foo10Sym1 (t :: Nat) = Foo10 t - instance SuppressUnusedWarnings Foo10Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo10Sym0KindInference) GHC.Tuple.()) - data Foo10Sym0 (l :: TyFun Nat Nat) - = forall arg. SameKind (Apply Foo10Sym0 arg) (Foo10Sym1 arg) => - Foo10Sym0KindInference - type instance Apply Foo10Sym0 l = Foo10 l - type Foo9Sym1 (t :: Nat) = Foo9 t - instance SuppressUnusedWarnings Foo9Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo9Sym0KindInference) GHC.Tuple.()) - data Foo9Sym0 (l :: TyFun Nat Nat) - = forall arg. SameKind (Apply Foo9Sym0 arg) (Foo9Sym1 arg) => - Foo9Sym0KindInference - type instance Apply Foo9Sym0 l = Foo9 l - type Foo8Sym1 (t :: Nat) = Foo8 t - instance SuppressUnusedWarnings Foo8Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo8Sym0KindInference) GHC.Tuple.()) - data Foo8Sym0 (l :: TyFun Nat Nat) - = forall arg. SameKind (Apply Foo8Sym0 arg) (Foo8Sym1 arg) => - Foo8Sym0KindInference - type instance Apply Foo8Sym0 l = Foo8 l - type Foo7Sym1 (t :: Nat) = Foo7 t - instance SuppressUnusedWarnings Foo7Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo7Sym0KindInference) GHC.Tuple.()) - data Foo7Sym0 (l :: TyFun Nat Nat) - = forall arg. SameKind (Apply Foo7Sym0 arg) (Foo7Sym1 arg) => - Foo7Sym0KindInference - type instance Apply Foo7Sym0 l = Foo7 l - type Foo6Sym1 (t :: Nat) = Foo6 t - instance SuppressUnusedWarnings Foo6Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo6Sym0KindInference) GHC.Tuple.()) - data Foo6Sym0 (l :: TyFun Nat Nat) - = forall arg. SameKind (Apply Foo6Sym0 arg) (Foo6Sym1 arg) => - Foo6Sym0KindInference - type instance Apply Foo6Sym0 l = Foo6 l - type Foo5Sym1 (t :: Nat) = Foo5 t - instance SuppressUnusedWarnings Foo5Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo5Sym0KindInference) GHC.Tuple.()) - data Foo5Sym0 (l :: TyFun Nat Nat) - = forall arg. SameKind (Apply Foo5Sym0 arg) (Foo5Sym1 arg) => - Foo5Sym0KindInference - type instance Apply Foo5Sym0 l = Foo5 l - type Foo4Sym1 (t :: Nat) = Foo4 t - instance SuppressUnusedWarnings Foo4Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo4Sym0KindInference) GHC.Tuple.()) - data Foo4Sym0 (l :: TyFun Nat Nat) - = forall arg. SameKind (Apply Foo4Sym0 arg) (Foo4Sym1 arg) => - Foo4Sym0KindInference - type instance Apply Foo4Sym0 l = Foo4 l - type Foo3Sym1 (t :: Nat) = Foo3 t - instance SuppressUnusedWarnings Foo3Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo3Sym0KindInference) GHC.Tuple.()) - data Foo3Sym0 (l :: TyFun Nat Nat) - = forall arg. SameKind (Apply Foo3Sym0 arg) (Foo3Sym1 arg) => - Foo3Sym0KindInference - type instance Apply Foo3Sym0 l = Foo3 l - type Foo2Sym0 = Foo2 - type Foo1Sym1 (t :: Nat) = Foo1 t - instance SuppressUnusedWarnings Foo1Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo1Sym0KindInference) GHC.Tuple.()) - data Foo1Sym0 (l :: TyFun Nat Nat) - = forall arg. SameKind (Apply Foo1Sym0 arg) (Foo1Sym1 arg) => - Foo1Sym0KindInference - type instance Apply Foo1Sym0 l = Foo1 l - type family Foo14 (a :: Nat) :: (Nat, Nat) where - Foo14 x = Apply (Apply Tuple2Sym0 (Let0123456789876543210ZSym1 x)) (Let0123456789876543210YSym1 x) - type family Foo13_ (a :: a) :: a where - Foo13_ y = y - type family Foo13 (a :: a) :: a where - Foo13 x = Apply Foo13_Sym0 (Let0123456789876543210BarSym1 x) - type family Foo12 (a :: Nat) :: Nat where - Foo12 x = Apply (Apply ((:<<<%%%%%%%%%%%%%%%%%%%:+$$) x) x) (Apply SuccSym0 (Apply SuccSym0 ZeroSym0)) - type family Foo11 (a :: Nat) :: Nat where - Foo11 x = Apply (Apply ((:<<<%%%%%%%%%%%%%%%%%%%:+$$) x) (Apply SuccSym0 ZeroSym0)) (Let0123456789876543210ZSym1 x) - type family Foo10 (a :: Nat) :: Nat where - Foo10 x = Apply (Apply ((:<<<%%%%%%%%%%%%%%%%%%%:+$$) x) (Apply SuccSym0 ZeroSym0)) x - type family Foo9 (a :: Nat) :: Nat where - Foo9 x = Apply (Let0123456789876543210ZSym1 x) x - type family Foo8 (a :: Nat) :: Nat where - Foo8 x = Let0123456789876543210ZSym1 x - type family Foo7 (a :: Nat) :: Nat where - Foo7 x = Let0123456789876543210XSym1 x - type family Foo6 (a :: Nat) :: Nat where - Foo6 x = Let0123456789876543210ZSym1 x - type family Foo5 (a :: Nat) :: Nat where - Foo5 x = Apply (Let0123456789876543210FSym1 x) x - type family Foo4 (a :: Nat) :: Nat where - Foo4 x = Apply (Let0123456789876543210FSym1 x) x - type family Foo3 (a :: Nat) :: Nat where - Foo3 x = Let0123456789876543210YSym1 x - type family Foo2 :: Nat where - = Let0123456789876543210ZSym0 - type family Foo1 (a :: Nat) :: Nat where - Foo1 x = Let0123456789876543210YSym1 x - sFoo14 :: - forall (t :: Nat). Sing t -> Sing (Apply Foo14Sym0 t :: (Nat, Nat)) - sFoo13_ :: - forall (t :: a). Sing t -> Sing (Apply Foo13_Sym0 t :: a) - sFoo13 :: forall (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 - sY :: Sing (Let0123456789876543210YSym1 x) - sZ :: Sing (Let0123456789876543210ZSym1 x) - sX_0123456789876543210 :: - Sing (Let0123456789876543210X_0123456789876543210Sym1 x) - sY - = case sX_0123456789876543210 of { - STuple2 (sY_0123456789876543210 :: Sing y_0123456789876543210) _ - -> sY_0123456789876543210 } :: - Sing (Case_0123456789876543210 x (Let0123456789876543210X_0123456789876543210Sym1 x)) - sZ - = case sX_0123456789876543210 of { - STuple2 _ (sY_0123456789876543210 :: Sing y_0123456789876543210) - -> sY_0123456789876543210 } :: - Sing (Case_0123456789876543210 x (Let0123456789876543210X_0123456789876543210Sym1 x)) - 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 x) a_0123456789876543210)) - (\ 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 x y :: 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 - sY :: Sing Let0123456789876543210YSym0 - sZ :: Sing Let0123456789876543210ZSym0 - sY = (applySing ((singFun1 @SuccSym0) SSucc)) SZero - sZ = (applySing ((singFun1 @SuccSym0) SSucc)) sY - in sZ - sFoo1 (sX :: Sing x) - = let - sY :: Sing (Let0123456789876543210YSym1 x :: Nat) - sY = (applySing ((singFun1 @SuccSym0) SSucc)) SZero - in sY 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 -fno-warn-unused-binds -fno-warn-unused-matches - -fno-warn-name-shadowing -fno-warn-unused-imports #-} - -module Singletons.LetStatements where - -import Data.Singletons -import Data.Singletons.Prelude -import Data.Singletons.SuppressUnusedWarnings -import Data.Singletons.TH -import Singletons.Nat - -$(singletons [d| - -- type signature required for a constant - foo1 :: Nat -> Nat - foo1 x = let y :: Nat - y = Succ Zero - in y - - -- nothing in scope, no type signatures required - foo2 :: Nat - foo2 = let y = Succ Zero - z = Succ y - in z - - -- using in-scope variable - foo3 :: Nat -> Nat - foo3 x = let y :: Nat - y = Succ x - in y - - -- passing in-scope variable to a function. Tests also adding in-scope binders - -- at the call site of f - foo4 :: Nat -> Nat - foo4 x = let f :: Nat -> Nat - f y = Succ y - in f x - - -- nested lets, version 1. This could potentially be problematic. - foo5 :: Nat -> Nat - foo5 x = let f :: Nat -> Nat - f y = let z :: Nat - z = Succ y - in Succ z - in f x - - -- nested lets, version 2. This shouldn't cause any problems, so that's just a - -- sanity check. - foo6 :: Nat -> Nat - foo6 x = let f :: Nat -> Nat - f y = Succ y - in let z :: Nat - z = f x - in z - - -- name shadowing - foo7 :: Nat -> Nat - foo7 x = let x :: Nat - x = Zero - in x - - -- lambda binder in let shadows pattern-bound variable - foo8 :: Nat -> Nat - foo8 x = let z :: Nat - z = (\x -> x) Zero - in z - - -- let-declaring lambdas - foo9 :: Nat -> Nat - foo9 x = let z :: Nat -> Nat - z = (\x -> x) - in z x - -- infix declaration - foo10 :: Nat -> Nat - foo10 x = let (+) :: Nat -> Nat -> Nat - Zero + m = m - (Succ n) + m = Succ (n + m) - in (Succ Zero) + x - - -- infix call uses let-bound binder - foo11 :: Nat -> Nat - foo11 x = let (+) :: Nat -> Nat -> Nat - Zero + m = m - (Succ n) + m = Succ (n + m) - z :: Nat - z = x - in (Succ Zero) + z - - -- infix let-declaration uses in-scope variable - foo12 :: Nat -> Nat - foo12 x = let (+) :: Nat -> Nat -> Nat - Zero + m = m - (Succ n) + m = Succ (n + x) - in x + (Succ (Succ Zero)) - - -- make sure that calls to functions declared outside of let don't receive - -- extra parameters with in-scope bindings. See #18. - foo13 :: forall a. a -> a - foo13 x = let bar :: a - bar = x - in foo13_ bar - - foo13_ :: a -> a - foo13_ y = y - - -- tuple patterns in let statements. See #20 - foo14 :: Nat -> (Nat, Nat) - foo14 x = let (y, z) = (Succ x, x) - in (z, y) - |]) - -foo1a :: Proxy (Foo1 Zero) -foo1a = Proxy - -foo1b :: Proxy (Succ Zero) -foo1b = foo1a - -foo2a :: Proxy Foo2 -foo2a = Proxy - -foo2b :: Proxy (Succ (Succ Zero)) -foo2b = foo2a - -foo3a :: Proxy (Foo3 (Succ Zero)) -foo3a = Proxy - -foo3b :: Proxy (Succ (Succ Zero)) -foo3b = foo3a - -foo4a :: Proxy (Foo4 (Succ Zero)) -foo4a = Proxy - -foo4b :: Proxy (Succ (Succ Zero)) -foo4b = foo4a - -foo5a :: Proxy (Foo5 Zero) -foo5a = Proxy - -foo5b :: Proxy (Succ (Succ Zero)) -foo5b = foo5a - -foo6a :: Proxy (Foo6 Zero) -foo6a = Proxy - -foo6b :: Proxy (Succ Zero) -foo6b = foo6a - -foo7a :: Proxy (Foo7 (Succ (Succ Zero))) -foo7a = Proxy - -foo7b :: Proxy Zero -foo7b = foo7a - -foo8a :: Proxy (Foo8 (Succ (Succ Zero))) -foo8a = Proxy - -foo8b :: Proxy Zero -foo8b = foo8a - -foo9a :: Proxy (Foo9 (Succ (Succ Zero))) -foo9a = Proxy - -foo9b :: Proxy (Succ (Succ Zero)) -foo9b = foo9a - -foo10a :: Proxy (Foo10 (Succ (Succ Zero))) -foo10a = Proxy - -foo10b :: Proxy (Succ (Succ (Succ Zero))) -foo10b = foo10a - -foo11a :: Proxy (Foo11 (Succ (Succ Zero))) -foo11a = Proxy - -foo11b :: Proxy (Succ (Succ (Succ Zero))) -foo11b = foo11a - -foo12a :: Proxy (Foo12 (Succ (Succ (Succ Zero)))) -foo12a = Proxy - -foo12b :: Proxy (Succ (Succ (Succ (Succ (Succ (Succ Zero)))))) -foo12b = foo12a - -foo13a :: Proxy (Foo13 Zero) -foo13a = Proxy - -foo13b :: Proxy Zero -foo13b = foo13a - -foo14a :: Proxy (Foo14 Zero) -foo14a = Proxy - -foo14b :: Proxy '(Zero, Succ Zero) -foo14b = foo14a diff --git a/tests/compile-and-dump/Singletons/Maybe.ghc82.template b/tests/compile-and-dump/Singletons/Maybe.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Maybe.ghc82.template +++ /dev/null @@ -1,62 +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 family Equals_0123456789876543210 (a :: Maybe k) (b :: Maybe k) :: Bool where - Equals_0123456789876543210 Nothing Nothing = TrueSym0 - Equals_0123456789876543210 (Just a) (Just b) = (:==) a b - Equals_0123456789876543210 (a :: Maybe k) (b :: Maybe k) = FalseSym0 - instance PEq (Maybe k) where - type (:==) (a :: Maybe k) (b :: Maybe k) = Equals_0123456789876543210 a b - type NothingSym0 = Nothing - type JustSym1 (t :: a0123456789876543210) = Just t - instance SuppressUnusedWarnings JustSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) JustSym0KindInference) GHC.Tuple.()) - data JustSym0 (l :: TyFun a0123456789876543210 (Maybe a0123456789876543210)) - = forall arg. SameKind (Apply JustSym0 arg) (JustSym1 arg) => - JustSym0KindInference - type instance Apply JustSym0 l = Just l - data instance Sing (z :: Maybe a) - = z ~ Nothing => SNothing | - forall (n :: a). z ~ Just n => SJust (Sing (n :: a)) - type SMaybe = (Sing :: Maybe a -> GHC.Types.Type) - 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) - = case toSing b :: SomeSing a of { - SomeSing c -> SomeSing (SJust c) } - 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 { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SJust _) SNothing - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SJust a) (SJust b) - = case ((%~) a) b of - Proved Refl -> Proved Refl - Disproved contra - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - instance SingI Nothing where - sing = SNothing - instance SingI n => SingI (Just (n :: a)) where - sing = SJust sing 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,11 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-unused-imports #-} - -module Singletons.Maybe where - -import Data.Singletons.TH -import Data.Singletons.SuppressUnusedWarnings -import Prelude hiding (Maybe, Nothing, Just) - -$(singletons [d| - data Maybe a = Nothing | Just a deriving (Eq, Show) - |]) diff --git a/tests/compile-and-dump/Singletons/Nat.ghc82.template b/tests/compile-and-dump/Singletons/Nat.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Nat.ghc82.template +++ /dev/null @@ -1,119 +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) |] - ======> - data Nat - where - Zero :: Nat - Succ :: Nat -> Nat - deriving (Eq, Show, Read) - plus :: Nat -> Nat -> Nat - plus Zero m = m - plus (Succ n) m = Succ ((plus n) m) - pred :: Nat -> Nat - pred Zero = Zero - pred (Succ n) = n - type family Equals_0123456789876543210 (a :: Nat) (b :: Nat) :: Bool where - Equals_0123456789876543210 Zero Zero = TrueSym0 - Equals_0123456789876543210 (Succ a) (Succ b) = (:==) a b - Equals_0123456789876543210 (a :: Nat) (b :: Nat) = FalseSym0 - instance PEq Nat where - type (:==) (a :: Nat) (b :: Nat) = Equals_0123456789876543210 a b - type ZeroSym0 = Zero - type SuccSym1 (t :: Nat) = Succ t - instance SuppressUnusedWarnings SuccSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) SuccSym0KindInference) GHC.Tuple.()) - data SuccSym0 (l :: TyFun Nat Nat) - = forall arg. SameKind (Apply SuccSym0 arg) (SuccSym1 arg) => - SuccSym0KindInference - type instance Apply SuccSym0 l = Succ l - type PredSym1 (t :: Nat) = Pred t - instance SuppressUnusedWarnings PredSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) PredSym0KindInference) GHC.Tuple.()) - data PredSym0 (l :: TyFun Nat Nat) - = forall arg. SameKind (Apply PredSym0 arg) (PredSym1 arg) => - PredSym0KindInference - type instance Apply PredSym0 l = Pred l - type PlusSym2 (t :: Nat) (t :: Nat) = Plus t t - instance SuppressUnusedWarnings PlusSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) PlusSym1KindInference) GHC.Tuple.()) - data PlusSym1 (l :: Nat) (l :: TyFun Nat Nat) - = forall arg. SameKind (Apply (PlusSym1 l) arg) (PlusSym2 l arg) => - PlusSym1KindInference - type instance Apply (PlusSym1 l) l = Plus l l - instance SuppressUnusedWarnings PlusSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) PlusSym0KindInference) GHC.Tuple.()) - data PlusSym0 (l :: TyFun Nat (TyFun Nat Nat -> GHC.Types.Type)) - = forall arg. SameKind (Apply PlusSym0 arg) (PlusSym1 arg) => - PlusSym0KindInference - type instance Apply PlusSym0 l = PlusSym1 l - type family Pred (a :: Nat) :: Nat where - Pred Zero = ZeroSym0 - Pred (Succ n) = n - type family Plus (a :: Nat) (a :: Nat) :: Nat where - Plus Zero m = m - Plus (Succ n) m = Apply SuccSym0 (Apply (Apply PlusSym0 n) m) - sPred :: - forall (t :: Nat). Sing t -> Sing (Apply PredSym0 t :: 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) - data instance Sing (z :: Nat) - = z ~ Zero => SZero | - forall (n :: Nat). z ~ Succ n => SSucc (Sing (n :: Nat)) - type SNat = (Sing :: Nat -> GHC.Types.Type) - instance SingKind Nat where - type Demote Nat = Nat - fromSing SZero = Zero - fromSing (SSucc b) = Succ (fromSing b) - toSing Zero = SomeSing SZero - toSing (Succ b) - = case toSing b :: SomeSing Nat of { - SomeSing c -> SomeSing (SSucc c) } - instance SEq Nat where - (%:==) SZero SZero = STrue - (%:==) SZero (SSucc _) = SFalse - (%:==) (SSucc _) SZero = SFalse - (%:==) (SSucc a) (SSucc b) = ((%:==) a) b - instance SDecide Nat where - (%~) SZero SZero = Proved Refl - (%~) SZero (SSucc _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SSucc _) SZero - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SSucc a) (SSucc b) - = case ((%~) a) b of - Proved Refl -> Proved Refl - Disproved contra - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - instance SingI Zero where - sing = SZero - instance SingI n => SingI (Succ (n :: Nat)) where - sing = SSucc sing diff --git a/tests/compile-and-dump/Singletons/Nat.hs b/tests/compile-and-dump/Singletons/Nat.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Nat.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-unused-imports #-} - -module Singletons.Nat where - -import Data.Singletons.TH -import Data.Singletons -import Data.Proxy -import Data.Singletons.SuppressUnusedWarnings - -$(singletons [d| - data Nat where - Zero :: Nat - Succ :: Nat -> Nat - deriving (Eq, Show, Read) - - plus :: Nat -> Nat -> Nat - plus Zero m = m - plus (Succ n) m = Succ (plus n m) - - pred :: Nat -> Nat - pred Zero = Zero - pred (Succ n) = n - |]) diff --git a/tests/compile-and-dump/Singletons/Operators.ghc82.template b/tests/compile-and-dump/Singletons/Operators.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Operators.ghc82.template +++ /dev/null @@ -1,101 +0,0 @@ -Singletons/Operators.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| child :: Foo -> Foo - child FLeaf = FLeaf - child (a :+: _) = a - (+) :: Nat -> Nat -> Nat - Zero + m = m - (Succ n) + m = Succ (n + m) - - data Foo - where - FLeaf :: Foo - (:+:) :: Foo -> Foo -> Foo |] - ======> - data Foo - where - FLeaf :: Foo - (:+:) :: Foo -> Foo -> Foo - child :: Foo -> Foo - child FLeaf = FLeaf - child (a :+: _) = a - (+) :: Nat -> Nat -> Nat - (+) Zero m = m - (+) (Succ n) m = Succ (n + m) - type FLeafSym0 = FLeaf - type (:+:$$$) (t :: Foo) (t :: Foo) = (:+:) t t - instance SuppressUnusedWarnings (:+:$$) where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) (:+:$$###)) GHC.Tuple.()) - data (:+:$$) (l :: Foo) (l :: TyFun Foo Foo) - = forall arg. SameKind (Apply ((:+:$$) l) arg) ((:+:$$$) l arg) => - (:+:$$###) - type instance Apply ((:+:$$) l) l = (:+:) l l - instance SuppressUnusedWarnings (:+:$) where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) (:+:$###)) GHC.Tuple.()) - data (:+:$) (l :: TyFun Foo (TyFun Foo Foo -> GHC.Types.Type)) - = forall arg. SameKind (Apply (:+:$) arg) ((:+:$$) arg) => - (:+:$###) - type instance Apply (:+:$) l = (:+:$$) l - type (:+$$$) (t :: Nat) (t :: Nat) = (:+) t t - instance SuppressUnusedWarnings (:+$$) where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) (:+$$###)) GHC.Tuple.()) - data (:+$$) (l :: Nat) (l :: TyFun Nat Nat) - = forall arg. SameKind (Apply ((:+$$) l) arg) ((:+$$$) l arg) => - (:+$$###) - type instance Apply ((:+$$) l) l = (:+) l l - instance SuppressUnusedWarnings (:+$) where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) (:+$###)) GHC.Tuple.()) - data (:+$) (l :: TyFun Nat (TyFun Nat Nat -> GHC.Types.Type)) - = forall arg. SameKind (Apply (:+$) arg) ((:+$$) arg) => (:+$###) - type instance Apply (:+$) l = (:+$$) l - type ChildSym1 (t :: Foo) = Child t - instance SuppressUnusedWarnings ChildSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) ChildSym0KindInference) GHC.Tuple.()) - data ChildSym0 (l :: TyFun Foo Foo) - = forall arg. SameKind (Apply ChildSym0 arg) (ChildSym1 arg) => - ChildSym0KindInference - type instance Apply ChildSym0 l = Child l - type family (:+) (a :: Nat) (a :: Nat) :: Nat where - (:+) Zero m = m - (:+) (Succ n) m = Apply SuccSym0 (Apply (Apply (:+$) n) m) - type family Child (a :: Foo) :: Foo where - Child FLeaf = FLeafSym0 - Child ((:+:) a _z_0123456789876543210) = 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 - data instance Sing (z :: Foo) - = z ~ FLeaf => SFLeaf | - forall (n :: Foo) (n :: Foo). z ~ (:+:) n n => - (:%+:) (Sing (n :: Foo)) (Sing (n :: Foo)) - type SFoo = (Sing :: Foo -> GHC.Types.Type) - instance SingKind Foo where - type Demote Foo = Foo - fromSing SFLeaf = FLeaf - fromSing ((:%+:) b b) = ((:+:) (fromSing b)) (fromSing b) - toSing FLeaf = SomeSing SFLeaf - toSing ((:+:) b b) - = case - (GHC.Tuple.(,) (toSing b :: SomeSing Foo)) - (toSing b :: SomeSing Foo) - of { - GHC.Tuple.(,) (SomeSing c) (SomeSing c) - -> SomeSing (((:%+:) c) c) } - instance SingI FLeaf where - sing = SFLeaf - instance (SingI n, SingI n) => - SingI ((:+:) (n :: Foo) (n :: Foo)) where - sing = ((:%+:) sing) sing 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,23 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-unused-imports #-} - -module Singletons.Operators where - -import Data.Proxy -import Data.Singletons -import Data.Singletons.TH -import Singletons.Nat -import Data.Singletons.SuppressUnusedWarnings - -$(singletons [d| - data Foo where - 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.ghc82.template b/tests/compile-and-dump/Singletons/OrdDeriving.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/OrdDeriving.ghc82.template +++ /dev/null @@ -1,1109 +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 family Equals_0123456789876543210 (a :: Nat) (b :: Nat) :: Bool where - Equals_0123456789876543210 Zero Zero = TrueSym0 - Equals_0123456789876543210 (Succ a) (Succ b) = (:==) a b - Equals_0123456789876543210 (a :: Nat) (b :: Nat) = FalseSym0 - instance PEq Nat where - type (:==) (a :: Nat) (b :: Nat) = Equals_0123456789876543210 a b - type ZeroSym0 = Zero - type SuccSym1 (t :: Nat) = Succ t - instance SuppressUnusedWarnings SuccSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) SuccSym0KindInference) GHC.Tuple.()) - data SuccSym0 (l :: TyFun Nat Nat) - = forall arg. SameKind (Apply SuccSym0 arg) (SuccSym1 arg) => - SuccSym0KindInference - type instance Apply SuccSym0 l = Succ l - type family Equals_0123456789876543210 (a :: Foo k k k k) (b :: Foo k k k k) :: Bool where - Equals_0123456789876543210 (A a a a a) (A b b b b) = (:&&) ((:==) a b) ((:&&) ((:==) a b) ((:&&) ((:==) a b) ((:==) a b))) - Equals_0123456789876543210 (B a a a a) (B b b b b) = (:&&) ((:==) a b) ((:&&) ((:==) a b) ((:&&) ((:==) a b) ((:==) a b))) - Equals_0123456789876543210 (C a a a a) (C b b b b) = (:&&) ((:==) a b) ((:&&) ((:==) a b) ((:&&) ((:==) a b) ((:==) a b))) - Equals_0123456789876543210 (D a a a a) (D b b b b) = (:&&) ((:==) a b) ((:&&) ((:==) a b) ((:&&) ((:==) a b) ((:==) a b))) - Equals_0123456789876543210 (E a a a a) (E b b b b) = (:&&) ((:==) a b) ((:&&) ((:==) a b) ((:&&) ((:==) a b) ((:==) a b))) - Equals_0123456789876543210 (F a a a a) (F b b b b) = (:&&) ((:==) a b) ((:&&) ((:==) a b) ((:&&) ((:==) a b) ((:==) a b))) - Equals_0123456789876543210 (a :: Foo k k k k) (b :: Foo k k k k) = FalseSym0 - instance PEq (Foo k k k k) where - type (:==) (a :: Foo k k k k) (b :: Foo k k k k) = Equals_0123456789876543210 a b - type ASym4 (t :: a0123456789876543210) (t :: b0123456789876543210) (t :: c0123456789876543210) (t :: d0123456789876543210) = - A t t t t - instance SuppressUnusedWarnings ASym3 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) ASym3KindInference) GHC.Tuple.()) - data ASym3 (l :: a0123456789876543210) (l :: b0123456789876543210) (l :: c0123456789876543210) (l :: TyFun d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210)) - = forall arg. SameKind (Apply (ASym3 l l l) arg) (ASym4 l l l arg) => - ASym3KindInference - type instance Apply (ASym3 l l l) l = A l l l l - instance SuppressUnusedWarnings ASym2 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) ASym2KindInference) GHC.Tuple.()) - data ASym2 (l :: a0123456789876543210) (l :: b0123456789876543210) (l :: TyFun c0123456789876543210 (TyFun d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) - -> GHC.Types.Type)) - = forall arg. SameKind (Apply (ASym2 l l) arg) (ASym3 l l arg) => - ASym2KindInference - type instance Apply (ASym2 l l) l = ASym3 l l l - instance SuppressUnusedWarnings ASym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) ASym1KindInference) GHC.Tuple.()) - data ASym1 (l :: a0123456789876543210) (l :: TyFun b0123456789876543210 (TyFun c0123456789876543210 (TyFun d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) - -> GHC.Types.Type) - -> GHC.Types.Type)) - = forall arg. SameKind (Apply (ASym1 l) arg) (ASym2 l arg) => - ASym1KindInference - type instance Apply (ASym1 l) l = ASym2 l l - instance SuppressUnusedWarnings ASym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) ASym0KindInference) GHC.Tuple.()) - data ASym0 (l :: TyFun a0123456789876543210 (TyFun b0123456789876543210 (TyFun c0123456789876543210 (TyFun d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) - -> GHC.Types.Type) - -> GHC.Types.Type) - -> GHC.Types.Type)) - = forall arg. SameKind (Apply ASym0 arg) (ASym1 arg) => - ASym0KindInference - type instance Apply ASym0 l = ASym1 l - type BSym4 (t :: a0123456789876543210) (t :: b0123456789876543210) (t :: c0123456789876543210) (t :: d0123456789876543210) = - B t t t t - instance SuppressUnusedWarnings BSym3 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) BSym3KindInference) GHC.Tuple.()) - data BSym3 (l :: a0123456789876543210) (l :: b0123456789876543210) (l :: c0123456789876543210) (l :: TyFun d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210)) - = forall arg. SameKind (Apply (BSym3 l l l) arg) (BSym4 l l l arg) => - BSym3KindInference - type instance Apply (BSym3 l l l) l = B l l l l - instance SuppressUnusedWarnings BSym2 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) BSym2KindInference) GHC.Tuple.()) - data BSym2 (l :: a0123456789876543210) (l :: b0123456789876543210) (l :: TyFun c0123456789876543210 (TyFun d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) - -> GHC.Types.Type)) - = forall arg. SameKind (Apply (BSym2 l l) arg) (BSym3 l l arg) => - BSym2KindInference - type instance Apply (BSym2 l l) l = BSym3 l l l - instance SuppressUnusedWarnings BSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) BSym1KindInference) GHC.Tuple.()) - data BSym1 (l :: a0123456789876543210) (l :: TyFun b0123456789876543210 (TyFun c0123456789876543210 (TyFun d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) - -> GHC.Types.Type) - -> GHC.Types.Type)) - = forall arg. SameKind (Apply (BSym1 l) arg) (BSym2 l arg) => - BSym1KindInference - type instance Apply (BSym1 l) l = BSym2 l l - instance SuppressUnusedWarnings BSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) BSym0KindInference) GHC.Tuple.()) - data BSym0 (l :: TyFun a0123456789876543210 (TyFun b0123456789876543210 (TyFun c0123456789876543210 (TyFun d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) - -> GHC.Types.Type) - -> GHC.Types.Type) - -> GHC.Types.Type)) - = forall arg. SameKind (Apply BSym0 arg) (BSym1 arg) => - BSym0KindInference - type instance Apply BSym0 l = BSym1 l - type CSym4 (t :: a0123456789876543210) (t :: b0123456789876543210) (t :: c0123456789876543210) (t :: d0123456789876543210) = - C t t t t - instance SuppressUnusedWarnings CSym3 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) CSym3KindInference) GHC.Tuple.()) - data CSym3 (l :: a0123456789876543210) (l :: b0123456789876543210) (l :: c0123456789876543210) (l :: TyFun d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210)) - = forall arg. SameKind (Apply (CSym3 l l l) arg) (CSym4 l l l arg) => - CSym3KindInference - type instance Apply (CSym3 l l l) l = C l l l l - instance SuppressUnusedWarnings CSym2 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) CSym2KindInference) GHC.Tuple.()) - data CSym2 (l :: a0123456789876543210) (l :: b0123456789876543210) (l :: TyFun c0123456789876543210 (TyFun d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) - -> GHC.Types.Type)) - = forall arg. SameKind (Apply (CSym2 l l) arg) (CSym3 l l arg) => - CSym2KindInference - type instance Apply (CSym2 l l) l = CSym3 l l l - instance SuppressUnusedWarnings CSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) CSym1KindInference) GHC.Tuple.()) - data CSym1 (l :: a0123456789876543210) (l :: TyFun b0123456789876543210 (TyFun c0123456789876543210 (TyFun d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) - -> GHC.Types.Type) - -> GHC.Types.Type)) - = forall arg. SameKind (Apply (CSym1 l) arg) (CSym2 l arg) => - CSym1KindInference - type instance Apply (CSym1 l) l = CSym2 l l - instance SuppressUnusedWarnings CSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) CSym0KindInference) GHC.Tuple.()) - data CSym0 (l :: TyFun a0123456789876543210 (TyFun b0123456789876543210 (TyFun c0123456789876543210 (TyFun d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) - -> GHC.Types.Type) - -> GHC.Types.Type) - -> GHC.Types.Type)) - = forall arg. SameKind (Apply CSym0 arg) (CSym1 arg) => - CSym0KindInference - type instance Apply CSym0 l = CSym1 l - type DSym4 (t :: a0123456789876543210) (t :: b0123456789876543210) (t :: c0123456789876543210) (t :: d0123456789876543210) = - D t t t t - instance SuppressUnusedWarnings DSym3 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) DSym3KindInference) GHC.Tuple.()) - data DSym3 (l :: a0123456789876543210) (l :: b0123456789876543210) (l :: c0123456789876543210) (l :: TyFun d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210)) - = forall arg. SameKind (Apply (DSym3 l l l) arg) (DSym4 l l l arg) => - DSym3KindInference - type instance Apply (DSym3 l l l) l = D l l l l - instance SuppressUnusedWarnings DSym2 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) DSym2KindInference) GHC.Tuple.()) - data DSym2 (l :: a0123456789876543210) (l :: b0123456789876543210) (l :: TyFun c0123456789876543210 (TyFun d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) - -> GHC.Types.Type)) - = forall arg. SameKind (Apply (DSym2 l l) arg) (DSym3 l l arg) => - DSym2KindInference - type instance Apply (DSym2 l l) l = DSym3 l l l - instance SuppressUnusedWarnings DSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) DSym1KindInference) GHC.Tuple.()) - data DSym1 (l :: a0123456789876543210) (l :: TyFun b0123456789876543210 (TyFun c0123456789876543210 (TyFun d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) - -> GHC.Types.Type) - -> GHC.Types.Type)) - = forall arg. SameKind (Apply (DSym1 l) arg) (DSym2 l arg) => - DSym1KindInference - type instance Apply (DSym1 l) l = DSym2 l l - instance SuppressUnusedWarnings DSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) DSym0KindInference) GHC.Tuple.()) - data DSym0 (l :: TyFun a0123456789876543210 (TyFun b0123456789876543210 (TyFun c0123456789876543210 (TyFun d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) - -> GHC.Types.Type) - -> GHC.Types.Type) - -> GHC.Types.Type)) - = forall arg. SameKind (Apply DSym0 arg) (DSym1 arg) => - DSym0KindInference - type instance Apply DSym0 l = DSym1 l - type ESym4 (t :: a0123456789876543210) (t :: b0123456789876543210) (t :: c0123456789876543210) (t :: d0123456789876543210) = - E t t t t - instance SuppressUnusedWarnings ESym3 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) ESym3KindInference) GHC.Tuple.()) - data ESym3 (l :: a0123456789876543210) (l :: b0123456789876543210) (l :: c0123456789876543210) (l :: TyFun d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210)) - = forall arg. SameKind (Apply (ESym3 l l l) arg) (ESym4 l l l arg) => - ESym3KindInference - type instance Apply (ESym3 l l l) l = E l l l l - instance SuppressUnusedWarnings ESym2 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) ESym2KindInference) GHC.Tuple.()) - data ESym2 (l :: a0123456789876543210) (l :: b0123456789876543210) (l :: TyFun c0123456789876543210 (TyFun d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) - -> GHC.Types.Type)) - = forall arg. SameKind (Apply (ESym2 l l) arg) (ESym3 l l arg) => - ESym2KindInference - type instance Apply (ESym2 l l) l = ESym3 l l l - instance SuppressUnusedWarnings ESym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) ESym1KindInference) GHC.Tuple.()) - data ESym1 (l :: a0123456789876543210) (l :: TyFun b0123456789876543210 (TyFun c0123456789876543210 (TyFun d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) - -> GHC.Types.Type) - -> GHC.Types.Type)) - = forall arg. SameKind (Apply (ESym1 l) arg) (ESym2 l arg) => - ESym1KindInference - type instance Apply (ESym1 l) l = ESym2 l l - instance SuppressUnusedWarnings ESym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) ESym0KindInference) GHC.Tuple.()) - data ESym0 (l :: TyFun a0123456789876543210 (TyFun b0123456789876543210 (TyFun c0123456789876543210 (TyFun d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) - -> GHC.Types.Type) - -> GHC.Types.Type) - -> GHC.Types.Type)) - = forall arg. SameKind (Apply ESym0 arg) (ESym1 arg) => - ESym0KindInference - type instance Apply ESym0 l = ESym1 l - type FSym4 (t :: a0123456789876543210) (t :: b0123456789876543210) (t :: c0123456789876543210) (t :: d0123456789876543210) = - F t t t t - instance SuppressUnusedWarnings FSym3 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) FSym3KindInference) GHC.Tuple.()) - data FSym3 (l :: a0123456789876543210) (l :: b0123456789876543210) (l :: c0123456789876543210) (l :: TyFun d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210)) - = forall arg. SameKind (Apply (FSym3 l l l) arg) (FSym4 l l l arg) => - FSym3KindInference - type instance Apply (FSym3 l l l) l = F l l l l - instance SuppressUnusedWarnings FSym2 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) FSym2KindInference) GHC.Tuple.()) - data FSym2 (l :: a0123456789876543210) (l :: b0123456789876543210) (l :: TyFun c0123456789876543210 (TyFun d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) - -> GHC.Types.Type)) - = forall arg. SameKind (Apply (FSym2 l l) arg) (FSym3 l l arg) => - FSym2KindInference - type instance Apply (FSym2 l l) l = FSym3 l l l - instance SuppressUnusedWarnings FSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) FSym1KindInference) GHC.Tuple.()) - data FSym1 (l :: a0123456789876543210) (l :: TyFun b0123456789876543210 (TyFun c0123456789876543210 (TyFun d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) - -> GHC.Types.Type) - -> GHC.Types.Type)) - = forall arg. SameKind (Apply (FSym1 l) arg) (FSym2 l arg) => - FSym1KindInference - type instance Apply (FSym1 l) l = FSym2 l l - instance SuppressUnusedWarnings FSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) FSym0KindInference) GHC.Tuple.()) - data FSym0 (l :: TyFun a0123456789876543210 (TyFun b0123456789876543210 (TyFun c0123456789876543210 (TyFun d0123456789876543210 (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) - -> GHC.Types.Type) - -> GHC.Types.Type) - -> GHC.Types.Type)) - = forall arg. SameKind (Apply FSym0 arg) (FSym1 arg) => - FSym0KindInference - type instance Apply FSym0 l = FSym1 l - type family Compare_0123456789876543210 (a :: Nat) (a :: Nat) :: Ordering where - Compare_0123456789876543210 Zero Zero = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) '[] - Compare_0123456789876543210 (Succ a_0123456789876543210) (Succ b_0123456789876543210) = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) (Apply (Apply (:$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) '[]) - Compare_0123456789876543210 Zero (Succ _z_0123456789876543210) = LTSym0 - Compare_0123456789876543210 (Succ _z_0123456789876543210) Zero = GTSym0 - type Compare_0123456789876543210Sym2 (t :: Nat) (t :: Nat) = - Compare_0123456789876543210 t t - instance SuppressUnusedWarnings Compare_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Compare_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Compare_0123456789876543210Sym1 (l :: Nat) (l :: TyFun Nat Ordering) - = forall arg. SameKind (Apply (Compare_0123456789876543210Sym1 l) arg) (Compare_0123456789876543210Sym2 l arg) => - Compare_0123456789876543210Sym1KindInference - type instance Apply (Compare_0123456789876543210Sym1 l) l = Compare_0123456789876543210 l l - instance SuppressUnusedWarnings Compare_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Compare_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Compare_0123456789876543210Sym0 (l :: TyFun Nat (TyFun Nat Ordering - -> GHC.Types.Type)) - = forall arg. SameKind (Apply Compare_0123456789876543210Sym0 arg) (Compare_0123456789876543210Sym1 arg) => - Compare_0123456789876543210Sym0KindInference - type instance Apply Compare_0123456789876543210Sym0 l = Compare_0123456789876543210Sym1 l - instance POrd Nat where - type Compare (a :: Nat) (a :: Nat) = Apply (Apply Compare_0123456789876543210Sym0 a) a - type family Compare_0123456789876543210 (a :: Foo a b c d) (a :: Foo a b c d) :: Ordering where - Compare_0123456789876543210 (A a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210) (A b_0123456789876543210 b_0123456789876543210 b_0123456789876543210 b_0123456789876543210) = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) (Apply (Apply (:$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) '[])))) - Compare_0123456789876543210 (B a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210) (B b_0123456789876543210 b_0123456789876543210 b_0123456789876543210 b_0123456789876543210) = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) (Apply (Apply (:$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) '[])))) - Compare_0123456789876543210 (C a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210) (C b_0123456789876543210 b_0123456789876543210 b_0123456789876543210 b_0123456789876543210) = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) (Apply (Apply (:$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) '[])))) - Compare_0123456789876543210 (D a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210) (D b_0123456789876543210 b_0123456789876543210 b_0123456789876543210 b_0123456789876543210) = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) (Apply (Apply (:$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) '[])))) - Compare_0123456789876543210 (E a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210) (E b_0123456789876543210 b_0123456789876543210 b_0123456789876543210 b_0123456789876543210) = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) (Apply (Apply (:$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) '[])))) - Compare_0123456789876543210 (F a_0123456789876543210 a_0123456789876543210 a_0123456789876543210 a_0123456789876543210) (F b_0123456789876543210 b_0123456789876543210 b_0123456789876543210 b_0123456789876543210) = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) (Apply (Apply (:$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) '[])))) - Compare_0123456789876543210 (A _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) (B _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) = LTSym0 - Compare_0123456789876543210 (A _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) (C _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) = LTSym0 - Compare_0123456789876543210 (A _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) (D _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) = LTSym0 - Compare_0123456789876543210 (A _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) (E _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) = LTSym0 - Compare_0123456789876543210 (A _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) (F _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) = LTSym0 - Compare_0123456789876543210 (B _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) (A _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) = GTSym0 - Compare_0123456789876543210 (B _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) (C _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) = LTSym0 - Compare_0123456789876543210 (B _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) (D _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) = LTSym0 - Compare_0123456789876543210 (B _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) (E _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) = LTSym0 - Compare_0123456789876543210 (B _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) (F _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) = LTSym0 - Compare_0123456789876543210 (C _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) (A _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) = GTSym0 - Compare_0123456789876543210 (C _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) (B _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) = GTSym0 - Compare_0123456789876543210 (C _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) (D _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) = LTSym0 - Compare_0123456789876543210 (C _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) (E _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) = LTSym0 - Compare_0123456789876543210 (C _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) (F _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) = LTSym0 - Compare_0123456789876543210 (D _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) (A _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) = GTSym0 - Compare_0123456789876543210 (D _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) (B _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) = GTSym0 - Compare_0123456789876543210 (D _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) (C _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) = GTSym0 - Compare_0123456789876543210 (D _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) (E _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) = LTSym0 - Compare_0123456789876543210 (D _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) (F _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) = LTSym0 - Compare_0123456789876543210 (E _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) (A _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) = GTSym0 - Compare_0123456789876543210 (E _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) (B _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) = GTSym0 - Compare_0123456789876543210 (E _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) (C _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) = GTSym0 - Compare_0123456789876543210 (E _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) (D _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) = GTSym0 - Compare_0123456789876543210 (E _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) (F _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) = LTSym0 - Compare_0123456789876543210 (F _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) (A _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) = GTSym0 - Compare_0123456789876543210 (F _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) (B _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) = GTSym0 - Compare_0123456789876543210 (F _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) (C _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) = GTSym0 - Compare_0123456789876543210 (F _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) (D _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) = GTSym0 - Compare_0123456789876543210 (F _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) (E _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210 _z_0123456789876543210) = GTSym0 - type Compare_0123456789876543210Sym2 (t :: Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) (t :: Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) = - Compare_0123456789876543210 t t - instance SuppressUnusedWarnings Compare_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Compare_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Compare_0123456789876543210Sym1 (l :: Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) (l :: TyFun (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) Ordering) - = forall arg. SameKind (Apply (Compare_0123456789876543210Sym1 l) arg) (Compare_0123456789876543210Sym2 l arg) => - Compare_0123456789876543210Sym1KindInference - type instance Apply (Compare_0123456789876543210Sym1 l) l = Compare_0123456789876543210 l l - instance SuppressUnusedWarnings Compare_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Compare_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Compare_0123456789876543210Sym0 (l :: TyFun (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) (TyFun (Foo a0123456789876543210 b0123456789876543210 c0123456789876543210 d0123456789876543210) Ordering - -> GHC.Types.Type)) - = forall arg. SameKind (Apply Compare_0123456789876543210Sym0 arg) (Compare_0123456789876543210Sym1 arg) => - Compare_0123456789876543210Sym0KindInference - type instance Apply Compare_0123456789876543210Sym0 l = Compare_0123456789876543210Sym1 l - instance POrd (Foo a b c d) where - type Compare (a :: Foo a b c d) (a :: Foo a b c d) = Apply (Apply Compare_0123456789876543210Sym0 a) a - data instance Sing (z :: Nat) - = z ~ Zero => SZero | - forall (n :: Nat). z ~ Succ n => SSucc (Sing (n :: Nat)) - type SNat = (Sing :: Nat -> GHC.Types.Type) - instance SingKind Nat where - type Demote Nat = Nat - fromSing SZero = Zero - fromSing (SSucc b) = Succ (fromSing b) - toSing Zero = SomeSing SZero - toSing (Succ b) - = case toSing b :: SomeSing Nat of { - SomeSing c -> SomeSing (SSucc c) } - instance SEq Nat where - (%:==) SZero SZero = STrue - (%:==) SZero (SSucc _) = SFalse - (%:==) (SSucc _) SZero = SFalse - (%:==) (SSucc a) (SSucc b) = ((%:==) a) b - instance SDecide Nat where - (%~) SZero SZero = Proved Refl - (%~) SZero (SSucc _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SSucc _) SZero - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SSucc a) (SSucc b) - = case ((%~) a) b of - Proved Refl -> Proved Refl - Disproved contra - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - data instance Sing (z :: Foo a b c d) - = forall (n :: a) (n :: b) (n :: c) (n :: d). z ~ A n n n n => - SA (Sing (n :: a)) (Sing (n :: b)) (Sing (n :: c)) (Sing (n :: d)) | - forall (n :: a) (n :: b) (n :: c) (n :: d). z ~ B n n n n => - SB (Sing (n :: a)) (Sing (n :: b)) (Sing (n :: c)) (Sing (n :: d)) | - forall (n :: a) (n :: b) (n :: c) (n :: d). z ~ C n n n n => - SC (Sing (n :: a)) (Sing (n :: b)) (Sing (n :: c)) (Sing (n :: d)) | - forall (n :: a) (n :: b) (n :: c) (n :: d). z ~ D n n n n => - SD (Sing (n :: a)) (Sing (n :: b)) (Sing (n :: c)) (Sing (n :: d)) | - forall (n :: a) (n :: b) (n :: c) (n :: d). z ~ E n n n n => - SE (Sing (n :: a)) (Sing (n :: b)) (Sing (n :: c)) (Sing (n :: d)) | - forall (n :: a) (n :: b) (n :: c) (n :: d). z ~ F n n n n => - SF (Sing (n :: a)) (Sing (n :: b)) (Sing (n :: c)) (Sing (n :: d)) - type SFoo = (Sing :: Foo a b c d -> GHC.Types.Type) - 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 b b b) - = case - (((GHC.Tuple.(,,,) (toSing b :: SomeSing a)) - (toSing b :: SomeSing b)) - (toSing b :: SomeSing c)) - (toSing b :: SomeSing d) - of { - GHC.Tuple.(,,,) (SomeSing c) (SomeSing c) (SomeSing c) (SomeSing c) - -> SomeSing ((((SA c) c) c) c) } - toSing (B b b b b) - = case - (((GHC.Tuple.(,,,) (toSing b :: SomeSing a)) - (toSing b :: SomeSing b)) - (toSing b :: SomeSing c)) - (toSing b :: SomeSing d) - of { - GHC.Tuple.(,,,) (SomeSing c) (SomeSing c) (SomeSing c) (SomeSing c) - -> SomeSing ((((SB c) c) c) c) } - toSing (C b b b b) - = case - (((GHC.Tuple.(,,,) (toSing b :: SomeSing a)) - (toSing b :: SomeSing b)) - (toSing b :: SomeSing c)) - (toSing b :: SomeSing d) - of { - GHC.Tuple.(,,,) (SomeSing c) (SomeSing c) (SomeSing c) (SomeSing c) - -> SomeSing ((((SC c) c) c) c) } - toSing (D b b b b) - = case - (((GHC.Tuple.(,,,) (toSing b :: SomeSing a)) - (toSing b :: SomeSing b)) - (toSing b :: SomeSing c)) - (toSing b :: SomeSing d) - of { - GHC.Tuple.(,,,) (SomeSing c) (SomeSing c) (SomeSing c) (SomeSing c) - -> SomeSing ((((SD c) c) c) c) } - toSing (E b b b b) - = case - (((GHC.Tuple.(,,,) (toSing b :: SomeSing a)) - (toSing b :: SomeSing b)) - (toSing b :: SomeSing c)) - (toSing b :: SomeSing d) - of { - GHC.Tuple.(,,,) (SomeSing c) (SomeSing c) (SomeSing c) (SomeSing c) - -> SomeSing ((((SE c) c) c) c) } - toSing (F b b b b) - = case - (((GHC.Tuple.(,,,) (toSing b :: SomeSing a)) - (toSing b :: SomeSing b)) - (toSing b :: SomeSing c)) - (toSing b :: SomeSing d) - of { - GHC.Tuple.(,,,) (SomeSing c) (SomeSing c) (SomeSing c) (SomeSing c) - -> SomeSing ((((SF c) c) c) c) } - 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 - (((GHC.Tuple.(,,,) (((%~) a) b)) (((%~) a) b)) (((%~) a) b)) - (((%~) a) b) - of - GHC.Tuple.(,,,) (Proved Refl) - (Proved Refl) - (Proved Refl) - (Proved Refl) - -> Proved Refl - GHC.Tuple.(,,,) (Disproved contra) _ _ _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - GHC.Tuple.(,,,) _ (Disproved contra) _ _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - GHC.Tuple.(,,,) _ _ (Disproved contra) _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - GHC.Tuple.(,,,) _ _ _ (Disproved contra) - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - (%~) (SA _ _ _ _) (SB _ _ _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SA _ _ _ _) (SC _ _ _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SA _ _ _ _) (SD _ _ _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SA _ _ _ _) (SE _ _ _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SA _ _ _ _) (SF _ _ _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SB _ _ _ _) (SA _ _ _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SB a a a a) (SB b b b b) - = case - (((GHC.Tuple.(,,,) (((%~) a) b)) (((%~) a) b)) (((%~) a) b)) - (((%~) a) b) - of - GHC.Tuple.(,,,) (Proved Refl) - (Proved Refl) - (Proved Refl) - (Proved Refl) - -> Proved Refl - GHC.Tuple.(,,,) (Disproved contra) _ _ _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - GHC.Tuple.(,,,) _ (Disproved contra) _ _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - GHC.Tuple.(,,,) _ _ (Disproved contra) _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - GHC.Tuple.(,,,) _ _ _ (Disproved contra) - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - (%~) (SB _ _ _ _) (SC _ _ _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SB _ _ _ _) (SD _ _ _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SB _ _ _ _) (SE _ _ _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SB _ _ _ _) (SF _ _ _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SC _ _ _ _) (SA _ _ _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SC _ _ _ _) (SB _ _ _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SC a a a a) (SC b b b b) - = case - (((GHC.Tuple.(,,,) (((%~) a) b)) (((%~) a) b)) (((%~) a) b)) - (((%~) a) b) - of - GHC.Tuple.(,,,) (Proved Refl) - (Proved Refl) - (Proved Refl) - (Proved Refl) - -> Proved Refl - GHC.Tuple.(,,,) (Disproved contra) _ _ _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - GHC.Tuple.(,,,) _ (Disproved contra) _ _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - GHC.Tuple.(,,,) _ _ (Disproved contra) _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - GHC.Tuple.(,,,) _ _ _ (Disproved contra) - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - (%~) (SC _ _ _ _) (SD _ _ _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SC _ _ _ _) (SE _ _ _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SC _ _ _ _) (SF _ _ _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SD _ _ _ _) (SA _ _ _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SD _ _ _ _) (SB _ _ _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SD _ _ _ _) (SC _ _ _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SD a a a a) (SD b b b b) - = case - (((GHC.Tuple.(,,,) (((%~) a) b)) (((%~) a) b)) (((%~) a) b)) - (((%~) a) b) - of - GHC.Tuple.(,,,) (Proved Refl) - (Proved Refl) - (Proved Refl) - (Proved Refl) - -> Proved Refl - GHC.Tuple.(,,,) (Disproved contra) _ _ _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - GHC.Tuple.(,,,) _ (Disproved contra) _ _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - GHC.Tuple.(,,,) _ _ (Disproved contra) _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - GHC.Tuple.(,,,) _ _ _ (Disproved contra) - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - (%~) (SD _ _ _ _) (SE _ _ _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SD _ _ _ _) (SF _ _ _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SE _ _ _ _) (SA _ _ _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SE _ _ _ _) (SB _ _ _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SE _ _ _ _) (SC _ _ _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SE _ _ _ _) (SD _ _ _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SE a a a a) (SE b b b b) - = case - (((GHC.Tuple.(,,,) (((%~) a) b)) (((%~) a) b)) (((%~) a) b)) - (((%~) a) b) - of - GHC.Tuple.(,,,) (Proved Refl) - (Proved Refl) - (Proved Refl) - (Proved Refl) - -> Proved Refl - GHC.Tuple.(,,,) (Disproved contra) _ _ _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - GHC.Tuple.(,,,) _ (Disproved contra) _ _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - GHC.Tuple.(,,,) _ _ (Disproved contra) _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - GHC.Tuple.(,,,) _ _ _ (Disproved contra) - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - (%~) (SE _ _ _ _) (SF _ _ _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SF _ _ _ _) (SA _ _ _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SF _ _ _ _) (SB _ _ _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SF _ _ _ _) (SC _ _ _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SF _ _ _ _) (SD _ _ _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SF _ _ _ _) (SE _ _ _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SF a a a a) (SF b b b b) - = case - (((GHC.Tuple.(,,,) (((%~) a) b)) (((%~) a) b)) (((%~) a) b)) - (((%~) a) b) - of - GHC.Tuple.(,,,) (Proved Refl) - (Proved Refl) - (Proved Refl) - (Proved Refl) - -> Proved Refl - GHC.Tuple.(,,,) (Disproved contra) _ _ _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - GHC.Tuple.(,,,) _ (Disproved contra) _ _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - GHC.Tuple.(,,,) _ _ (Disproved contra) _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - GHC.Tuple.(,,,) _ _ _ (Disproved contra) - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - instance SOrd Nat => SOrd Nat where - sCompare :: - forall (t1 :: Nat) (t2 :: Nat). - Sing t1 - -> Sing t2 - -> Sing (Apply (Apply (CompareSym0 :: TyFun Nat (TyFun Nat Ordering - -> GHC.Types.Type) - -> GHC.Types.Type) t1 :: TyFun Nat Ordering - -> GHC.Types.Type) t2 :: Ordering) - 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) (TyFun (Foo a b c d) Ordering - -> GHC.Types.Type) - -> GHC.Types.Type) t1 :: TyFun (Foo a b c d) Ordering - -> GHC.Types.Type) t2 :: Ordering) - 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 SingI Zero where - sing = SZero - instance SingI n => SingI (Succ (n :: Nat)) where - sing = SSucc sing - 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 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 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 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 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 n, SingI n, SingI n, SingI n) => - SingI (F (n :: a) (n :: b) (n :: c) (n :: d)) where - sing = (((SF sing) sing) sing) sing 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/PatternMatching.ghc82.template b/tests/compile-and-dump/Singletons/PatternMatching.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/PatternMatching.ghc82.template +++ /dev/null @@ -1,450 +0,0 @@ -Singletons/PatternMatching.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| pr = Pair (Succ Zero) ([Zero]) - complex = Pair (Pair (Just Zero) Zero) False - tuple = (False, Just Zero, True) - aList = [Zero, Succ Zero, Succ (Succ Zero)] - - data Pair a b - = Pair a b - deriving Show |] - ======> - data Pair a b - = Pair a b - deriving Show - pr = (Pair (Succ Zero)) [Zero] - complex = (Pair ((Pair (Just Zero)) Zero)) False - tuple = (False, Just Zero, True) - aList = [Zero, Succ Zero, Succ (Succ Zero)] - type PairSym2 (t :: a0123456789876543210) (t :: b0123456789876543210) = - Pair t t - instance SuppressUnusedWarnings PairSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) PairSym1KindInference) GHC.Tuple.()) - data PairSym1 (l :: a0123456789876543210) (l :: TyFun b0123456789876543210 (Pair a0123456789876543210 b0123456789876543210)) - = forall arg. SameKind (Apply (PairSym1 l) arg) (PairSym2 l arg) => - PairSym1KindInference - type instance Apply (PairSym1 l) l = Pair l l - instance SuppressUnusedWarnings PairSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) PairSym0KindInference) GHC.Tuple.()) - data PairSym0 (l :: TyFun a0123456789876543210 (TyFun b0123456789876543210 (Pair a0123456789876543210 b0123456789876543210) - -> GHC.Types.Type)) - = forall arg. SameKind (Apply PairSym0 arg) (PairSym1 arg) => - PairSym0KindInference - type instance Apply PairSym0 l = PairSym1 l - type AListSym0 = AList - type TupleSym0 = Tuple - type ComplexSym0 = Complex - type PrSym0 = Pr - type family AList where - = Apply (Apply (:$) ZeroSym0) (Apply (Apply (:$) (Apply SuccSym0 ZeroSym0)) (Apply (Apply (:$) (Apply SuccSym0 (Apply SuccSym0 ZeroSym0))) '[])) - type family Tuple where - = Apply (Apply (Apply Tuple3Sym0 FalseSym0) (Apply JustSym0 ZeroSym0)) TrueSym0 - type family Complex where - = Apply (Apply PairSym0 (Apply (Apply PairSym0 (Apply JustSym0 ZeroSym0)) ZeroSym0)) FalseSym0 - type family Pr where - = Apply (Apply PairSym0 (Apply SuccSym0 ZeroSym0)) (Apply (Apply (:$) ZeroSym0) '[]) - 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 instance Sing (z :: Pair a b) - = forall (n :: a) (n :: b). z ~ Pair n n => - SPair (Sing (n :: a)) (Sing (n :: b)) - type SPair = (Sing :: Pair a b -> GHC.Types.Type) - 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 b) - = case - (GHC.Tuple.(,) (toSing b :: SomeSing a)) (toSing b :: SomeSing b) - of { - GHC.Tuple.(,) (SomeSing c) (SomeSing c) -> SomeSing ((SPair c) c) } - instance (SingI n, SingI n) => SingI (Pair (n :: a) (n :: b)) where - sing = (SPair sing) sing -Singletons/PatternMatching.hs:(0,0)-(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 { _ -> GHC.Tuple.() } - type family Case_0123456789876543210 x t where - Case_0123456789876543210 x _z_0123456789876543210 = Tuple0Sym0 - type Let0123456789876543210TSym2 t t = Let0123456789876543210T t t - instance SuppressUnusedWarnings Let0123456789876543210TSym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Let0123456789876543210TSym1KindInference) - GHC.Tuple.()) - data Let0123456789876543210TSym1 l l - = forall arg. SameKind (Apply (Let0123456789876543210TSym1 l) arg) (Let0123456789876543210TSym2 l arg) => - Let0123456789876543210TSym1KindInference - type instance Apply (Let0123456789876543210TSym1 l) l = Let0123456789876543210T l l - instance SuppressUnusedWarnings Let0123456789876543210TSym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Let0123456789876543210TSym0KindInference) - GHC.Tuple.()) - data Let0123456789876543210TSym0 l - = forall arg. SameKind (Apply Let0123456789876543210TSym0 arg) (Let0123456789876543210TSym1 arg) => - Let0123456789876543210TSym0KindInference - type instance Apply Let0123456789876543210TSym0 l = Let0123456789876543210TSym1 l - type family Let0123456789876543210T x y where - Let0123456789876543210T x y = Apply (Apply Tuple2Sym0 x) y - type family Case_0123456789876543210 x y a b arg_0123456789876543210 t where - Case_0123456789876543210 x y a b arg_0123456789876543210 _z_0123456789876543210 = a - type family Lambda_0123456789876543210 x y a b t where - Lambda_0123456789876543210 x y a b arg_0123456789876543210 = Case_0123456789876543210 x y a b arg_0123456789876543210 arg_0123456789876543210 - type Lambda_0123456789876543210Sym5 t t t t t = - Lambda_0123456789876543210 t t t t t - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym4 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym4KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym4 l l l l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym4 l l l l) arg) (Lambda_0123456789876543210Sym5 l l l l arg) => - Lambda_0123456789876543210Sym4KindInference - type instance Apply (Lambda_0123456789876543210Sym4 l l l l) l = Lambda_0123456789876543210 l l l l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym3 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym3KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym3 l l l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym3 l l l) arg) (Lambda_0123456789876543210Sym4 l l l arg) => - Lambda_0123456789876543210Sym3KindInference - type instance Apply (Lambda_0123456789876543210Sym3 l l l) l = Lambda_0123456789876543210Sym4 l l l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym2 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym2KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym2 l l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym2 l l) arg) (Lambda_0123456789876543210Sym3 l l arg) => - Lambda_0123456789876543210Sym2KindInference - type instance Apply (Lambda_0123456789876543210Sym2 l l) l = Lambda_0123456789876543210Sym3 l l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym1 l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym1 l) arg) (Lambda_0123456789876543210Sym2 l arg) => - Lambda_0123456789876543210Sym1KindInference - type instance Apply (Lambda_0123456789876543210Sym1 l) l = Lambda_0123456789876543210Sym2 l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym0 l - = forall arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0KindInference - type instance Apply Lambda_0123456789876543210Sym0 l = Lambda_0123456789876543210Sym1 l - type family Case_0123456789876543210 x y t where - Case_0123456789876543210 x y '(a, - b) = Apply (Apply (Apply (Apply (Apply Lambda_0123456789876543210Sym0 x) y) a) b) b - type family Case_0123456789876543210 x y arg_0123456789876543210 t where - Case_0123456789876543210 x y arg_0123456789876543210 _z_0123456789876543210 = x - type family Lambda_0123456789876543210 x y t where - Lambda_0123456789876543210 x y arg_0123456789876543210 = Case_0123456789876543210 x y arg_0123456789876543210 arg_0123456789876543210 - type Lambda_0123456789876543210Sym3 t t t = - Lambda_0123456789876543210 t t t - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym2 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym2KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym2 l l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym2 l l) arg) (Lambda_0123456789876543210Sym3 l l arg) => - Lambda_0123456789876543210Sym2KindInference - type instance Apply (Lambda_0123456789876543210Sym2 l l) l = Lambda_0123456789876543210 l l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym1 l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym1 l) arg) (Lambda_0123456789876543210Sym2 l arg) => - Lambda_0123456789876543210Sym1KindInference - type instance Apply (Lambda_0123456789876543210Sym1 l) l = Lambda_0123456789876543210Sym2 l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym0 l - = forall arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0KindInference - type instance Apply Lambda_0123456789876543210Sym0 l = Lambda_0123456789876543210Sym1 l - type family Case_0123456789876543210 t where - Case_0123456789876543210 '[_z_0123456789876543210, - y_0123456789876543210, - Succ _z_0123456789876543210] = y_0123456789876543210 - type family Case_0123456789876543210 t where - Case_0123456789876543210 '[_z_0123456789876543210, - _z_0123456789876543210, - Succ y_0123456789876543210] = y_0123456789876543210 - type family Case_0123456789876543210 t where - Case_0123456789876543210 '(y_0123456789876543210, - _z_0123456789876543210, - _z_0123456789876543210) = y_0123456789876543210 - type family Case_0123456789876543210 t where - Case_0123456789876543210 '(_z_0123456789876543210, - y_0123456789876543210, - _z_0123456789876543210) = y_0123456789876543210 - type family Case_0123456789876543210 t where - Case_0123456789876543210 '(_z_0123456789876543210, - _z_0123456789876543210, - y_0123456789876543210) = y_0123456789876543210 - type family Case_0123456789876543210 t where - Case_0123456789876543210 (Pair (Pair y_0123456789876543210 _z_0123456789876543210) _z_0123456789876543210) = y_0123456789876543210 - type family Case_0123456789876543210 t where - Case_0123456789876543210 (Pair (Pair _z_0123456789876543210 y_0123456789876543210) _z_0123456789876543210) = y_0123456789876543210 - type family Case_0123456789876543210 t where - Case_0123456789876543210 (Pair (Pair _z_0123456789876543210 _z_0123456789876543210) y_0123456789876543210) = y_0123456789876543210 - type family Case_0123456789876543210 t where - Case_0123456789876543210 (Pair y_0123456789876543210 _z_0123456789876543210) = y_0123456789876543210 - type family Case_0123456789876543210 t where - Case_0123456789876543210 (Pair _z_0123456789876543210 y_0123456789876543210) = y_0123456789876543210 - type SillySym1 (t :: a0123456789876543210) = Silly t - instance SuppressUnusedWarnings SillySym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) SillySym0KindInference) GHC.Tuple.()) - data SillySym0 (l :: TyFun a0123456789876543210 ()) - = forall arg. SameKind (Apply SillySym0 arg) (SillySym1 arg) => - SillySym0KindInference - type instance Apply SillySym0 l = Silly l - type Foo2Sym1 (t :: (a0123456789876543210, b0123456789876543210)) = - Foo2 t - instance SuppressUnusedWarnings Foo2Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo2Sym0KindInference) GHC.Tuple.()) - data Foo2Sym0 (l :: TyFun (a0123456789876543210, - b0123456789876543210) a0123456789876543210) - = forall arg. SameKind (Apply Foo2Sym0 arg) (Foo2Sym1 arg) => - Foo2Sym0KindInference - type instance Apply Foo2Sym0 l = Foo2 l - type Foo1Sym1 (t :: (a0123456789876543210, b0123456789876543210)) = - Foo1 t - instance SuppressUnusedWarnings Foo1Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Foo1Sym0KindInference) GHC.Tuple.()) - data Foo1Sym0 (l :: TyFun (a0123456789876543210, - b0123456789876543210) a0123456789876543210) - = forall arg. SameKind (Apply Foo1Sym0 arg) (Foo1Sym1 arg) => - Foo1Sym0KindInference - type instance Apply Foo1Sym0 l = Foo1 l - type LszSym0 = Lsz - type BlimySym0 = Blimy - type TfSym0 = Tf - type TjzSym0 = Tjz - type TtSym0 = Tt - type JzSym0 = Jz - type ZzSym0 = Zz - type FlsSym0 = Fls - type SzSym0 = Sz - type LzSym0 = Lz - type X_0123456789876543210Sym0 = X_0123456789876543210 - type X_0123456789876543210Sym0 = X_0123456789876543210 - type X_0123456789876543210Sym0 = X_0123456789876543210 - type X_0123456789876543210Sym0 = X_0123456789876543210 - type family Silly (a :: a) :: () where - Silly x = Case_0123456789876543210 x x - type family Foo2 (a :: (a, b)) :: a where - Foo2 '(x, - y) = Case_0123456789876543210 x y (Let0123456789876543210TSym2 x y) - type family Foo1 (a :: (a, b)) :: a where - Foo1 '(x, - y) = Apply (Apply (Apply Lambda_0123456789876543210Sym0 x) y) y - type family Lsz :: Nat where - = Case_0123456789876543210 X_0123456789876543210Sym0 - type family Blimy where - = Case_0123456789876543210 X_0123456789876543210Sym0 - type family Tf where - = Case_0123456789876543210 X_0123456789876543210Sym0 - type family Tjz where - = Case_0123456789876543210 X_0123456789876543210Sym0 - type family Tt where - = Case_0123456789876543210 X_0123456789876543210Sym0 - type family Jz where - = Case_0123456789876543210 X_0123456789876543210Sym0 - type family Zz where - = Case_0123456789876543210 X_0123456789876543210Sym0 - type family Fls :: Bool where - = Case_0123456789876543210 X_0123456789876543210Sym0 - type family Sz where - = Case_0123456789876543210 X_0123456789876543210Sym0 - type family Lz where - = Case_0123456789876543210 X_0123456789876543210Sym0 - type family X_0123456789876543210 where - = PrSym0 - type family X_0123456789876543210 where - = ComplexSym0 - type family X_0123456789876543210 where - = TupleSym0 - type family X_0123456789876543210 where - = AListSym0 - sSilly :: forall (t :: a). Sing t -> Sing (Apply SillySym0 t :: ()) - sFoo2 :: - forall (t :: (a, b)). Sing t -> Sing (Apply Foo2Sym0 t :: a) - sFoo1 :: - forall (t :: (a, b)). Sing t -> Sing (Apply Foo1Sym0 t :: a) - sLsz :: Sing (LszSym0 :: Nat) - sBlimy :: Sing BlimySym0 - sTf :: Sing TfSym0 - sTjz :: Sing TjzSym0 - sTt :: Sing TtSym0 - sJz :: Sing JzSym0 - sZz :: Sing ZzSym0 - sFls :: Sing (FlsSym0 :: Bool) - sSz :: Sing SzSym0 - sLz :: Sing LzSym0 - sX_0123456789876543210 :: Sing X_0123456789876543210Sym0 - sX_0123456789876543210 :: Sing X_0123456789876543210Sym0 - sX_0123456789876543210 :: Sing X_0123456789876543210Sym0 - sX_0123456789876543210 :: Sing X_0123456789876543210Sym0 - sSilly (sX :: Sing x) - = case sX of { _ -> STuple0 } :: - Sing (Case_0123456789876543210 x x :: ()) - sFoo2 (STuple2 (sX :: Sing x) (sY :: Sing y)) - = let - sT :: Sing (Let0123456789876543210TSym2 x y) - sT - = (applySing ((applySing ((singFun2 @Tuple2Sym0) STuple2)) sX)) sY - in case sT of { - STuple2 (sA :: Sing a) (sB :: Sing b) - -> (applySing - ((singFun1 - @(Apply (Apply (Apply (Apply Lambda_0123456789876543210Sym0 x) y) a) b)) - (\ sArg_0123456789876543210 - -> case sArg_0123456789876543210 of { - _ :: Sing arg_0123456789876543210 - -> case sArg_0123456789876543210 of { _ -> sA } :: - Sing (Case_0123456789876543210 x y a b arg_0123456789876543210 arg_0123456789876543210) }))) - sB } :: - Sing (Case_0123456789876543210 x y (Let0123456789876543210TSym2 x y) :: a) - 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 - -> case sArg_0123456789876543210 of { _ -> sX } :: - Sing (Case_0123456789876543210 x y arg_0123456789876543210 arg_0123456789876543210) }))) - sY - sLsz - = case sX_0123456789876543210 of { - SCons _ - (SCons (sY_0123456789876543210 :: Sing y_0123456789876543210) - (SCons (SSucc _) SNil)) - -> sY_0123456789876543210 } :: - Sing (Case_0123456789876543210 X_0123456789876543210Sym0 :: Nat) - sBlimy - = case sX_0123456789876543210 of { - SCons _ - (SCons _ - (SCons (SSucc (sY_0123456789876543210 :: Sing y_0123456789876543210)) - SNil)) - -> sY_0123456789876543210 } :: - Sing (Case_0123456789876543210 X_0123456789876543210Sym0) - sTf - = case sX_0123456789876543210 of { - STuple3 (sY_0123456789876543210 :: Sing y_0123456789876543210) _ _ - -> sY_0123456789876543210 } :: - Sing (Case_0123456789876543210 X_0123456789876543210Sym0) - sTjz - = case sX_0123456789876543210 of { - STuple3 _ (sY_0123456789876543210 :: Sing y_0123456789876543210) _ - -> sY_0123456789876543210 } :: - Sing (Case_0123456789876543210 X_0123456789876543210Sym0) - sTt - = case sX_0123456789876543210 of { - STuple3 _ _ (sY_0123456789876543210 :: Sing y_0123456789876543210) - -> sY_0123456789876543210 } :: - Sing (Case_0123456789876543210 X_0123456789876543210Sym0) - sJz - = case sX_0123456789876543210 of { - SPair (SPair (sY_0123456789876543210 :: Sing y_0123456789876543210) - _) - _ - -> sY_0123456789876543210 } :: - Sing (Case_0123456789876543210 X_0123456789876543210Sym0) - sZz - = case sX_0123456789876543210 of { - SPair (SPair _ - (sY_0123456789876543210 :: Sing y_0123456789876543210)) - _ - -> sY_0123456789876543210 } :: - Sing (Case_0123456789876543210 X_0123456789876543210Sym0) - sFls - = case sX_0123456789876543210 of { - SPair (SPair _ _) - (sY_0123456789876543210 :: Sing y_0123456789876543210) - -> sY_0123456789876543210 } :: - Sing (Case_0123456789876543210 X_0123456789876543210Sym0 :: Bool) - sSz - = case sX_0123456789876543210 of { - SPair (sY_0123456789876543210 :: Sing y_0123456789876543210) _ - -> sY_0123456789876543210 } :: - Sing (Case_0123456789876543210 X_0123456789876543210Sym0) - sLz - = case sX_0123456789876543210 of { - SPair _ (sY_0123456789876543210 :: Sing y_0123456789876543210) - -> sY_0123456789876543210 } :: - Sing (Case_0123456789876543210 X_0123456789876543210Sym0) - sX_0123456789876543210 = sPr - sX_0123456789876543210 = sComplex - sX_0123456789876543210 = sTuple - sX_0123456789876543210 = sAList 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,50 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-unused-matches #-} -{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} - -module Singletons.PatternMatching where - -import Data.Singletons.Prelude -import Data.Singletons.TH -import Singletons.Nat - -$(singletons [d| - data Pair a b = Pair a b deriving Show - pr = Pair (Succ Zero) ([Zero]) - complex = Pair (Pair (Just Zero) Zero) False - tuple = (False, Just Zero, True) - aList = [Zero, Succ Zero, Succ (Succ Zero)] - |]) - -$(singletons [d| - Pair sz lz = pr - Pair (Pair jz zz) fls = complex - (tf, tjz, tt) = tuple - [_, lsz, (Succ blimy)] = aList - lsz :: Nat - fls :: Bool - - 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.ghc82.template b/tests/compile-and-dump/Singletons/PolyKinds.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/PolyKinds.ghc82.template +++ /dev/null @@ -1,22 +0,0 @@ -Singletons/PolyKinds.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| class Cls (a :: k) where - fff :: Proxy (a :: k) -> () |] - ======> - class Cls (a :: k) where - fff :: Proxy (a :: k) -> () - type FffSym1 (t :: Proxy (a0123456789876543210 :: k0123456789876543210)) = - Fff t - instance SuppressUnusedWarnings FffSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) FffSym0KindInference) GHC.Tuple.()) - data FffSym0 (l :: TyFun (Proxy (a0123456789876543210 :: k0123456789876543210)) ()) - = forall arg. SameKind (Apply FffSym0 arg) (FffSym1 arg) => - FffSym0KindInference - type instance Apply FffSym0 l = Fff l - 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 :: ()) 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.ghc82.template b/tests/compile-and-dump/Singletons/PolyKindsApp.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/PolyKindsApp.ghc82.template +++ /dev/null @@ -1,12 +0,0 @@ -Singletons/PolyKindsApp.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| class Cls (a :: k -> Type) where - fff :: (a :: k -> Type) (b :: k) |] - ======> - class Cls (a :: k -> Type) where - fff :: (a :: k -> Type) (b :: k) - type FffSym0 = Fff - class PCls (a :: k -> Type) where - type Fff :: (a :: k -> Type) (b :: k) - class SCls (a :: k -> Type) where - sFff :: 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 -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.ghc82.template b/tests/compile-and-dump/Singletons/Records.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Records.ghc82.template +++ /dev/null @@ -1,60 +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 Field1Sym1 (t :: Record a0123456789876543210) = Field1 t - instance SuppressUnusedWarnings Field1Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Field1Sym0KindInference) GHC.Tuple.()) - data Field1Sym0 (l :: TyFun (Record a0123456789876543210) a0123456789876543210) - = forall arg. SameKind (Apply Field1Sym0 arg) (Field1Sym1 arg) => - Field1Sym0KindInference - type instance Apply Field1Sym0 l = Field1 l - type Field2Sym1 (t :: Record a0123456789876543210) = Field2 t - instance SuppressUnusedWarnings Field2Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Field2Sym0KindInference) GHC.Tuple.()) - data Field2Sym0 (l :: TyFun (Record a0123456789876543210) Bool) - = forall arg. SameKind (Apply Field2Sym0 arg) (Field2Sym1 arg) => - Field2Sym0KindInference - type instance Apply Field2Sym0 l = Field2 l - type family Field1 (a :: Record a) :: a where - Field1 (MkRecord field _z_0123456789876543210) = field - type family Field2 (a :: Record a) :: Bool where - Field2 (MkRecord _z_0123456789876543210 field) = field - type MkRecordSym2 (t :: a0123456789876543210) (t :: Bool) = - MkRecord t t - instance SuppressUnusedWarnings MkRecordSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) MkRecordSym1KindInference) GHC.Tuple.()) - data MkRecordSym1 (l :: a0123456789876543210) (l :: TyFun Bool (Record a0123456789876543210)) - = forall arg. SameKind (Apply (MkRecordSym1 l) arg) (MkRecordSym2 l arg) => - MkRecordSym1KindInference - type instance Apply (MkRecordSym1 l) l = MkRecord l l - instance SuppressUnusedWarnings MkRecordSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) MkRecordSym0KindInference) GHC.Tuple.()) - data MkRecordSym0 (l :: TyFun a0123456789876543210 (TyFun Bool (Record a0123456789876543210) - -> GHC.Types.Type)) - = forall arg. SameKind (Apply MkRecordSym0 arg) (MkRecordSym1 arg) => - MkRecordSym0KindInference - type instance Apply MkRecordSym0 l = MkRecordSym1 l - data instance Sing (z :: Record a) - = forall (n :: a) (n :: Bool). z ~ MkRecord n n => - SMkRecord {sField1 :: (Sing (n :: a)), - sField2 :: (Sing (n :: Bool))} - type SRecord = (Sing :: Record a -> GHC.Types.Type) - 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 b) - = case - (GHC.Tuple.(,) (toSing b :: SomeSing a)) - (toSing b :: SomeSing Bool) - of { - GHC.Tuple.(,) (SomeSing c) (SomeSing c) - -> SomeSing ((SMkRecord c) c) } - instance (SingI n, SingI n) => - SingI (MkRecord (n :: a) (n :: Bool)) where - sing = (SMkRecord sing) sing diff --git a/tests/compile-and-dump/Singletons/Records.hs b/tests/compile-and-dump/Singletons/Records.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Records.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -module Singletons.Records where - -import Data.Singletons.SuppressUnusedWarnings -import Data.Singletons.TH -import Data.Singletons.Prelude - -$(singletons [d| - data Record a = MkRecord { field1 :: a - , field2 :: Bool } - - |]) - --- This fails - see #66 --- $(singletons [d| --- neg :: Record a -> Record a --- neg rec@(MkRecord { field1 = _, field2 = b } ) = rec {field2 = not b} --- |]) - -foo1a :: Proxy (Field2 (MkRecord 5 True)) -foo1a = Proxy - -foo1b :: Proxy True -foo1b = foo1a - -foo2a :: Proxy (Field1 (MkRecord 5 True)) -foo2a = Proxy - -foo2b :: Proxy 5 -foo2b = foo2a diff --git a/tests/compile-and-dump/Singletons/ReturnFunc.ghc82.template b/tests/compile-and-dump/Singletons/ReturnFunc.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/ReturnFunc.ghc82.template +++ /dev/null @@ -1,76 +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 IdSym1 (t :: a0123456789876543210) = Id t - instance SuppressUnusedWarnings IdSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) IdSym0KindInference) GHC.Tuple.()) - data IdSym0 (l :: TyFun a0123456789876543210 a0123456789876543210) - = forall arg. SameKind (Apply IdSym0 arg) (IdSym1 arg) => - IdSym0KindInference - type instance Apply IdSym0 l = Id l - type IdFooSym2 (t :: c0123456789876543210) (t :: a0123456789876543210) = - IdFoo t t - instance SuppressUnusedWarnings IdFooSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) IdFooSym1KindInference) GHC.Tuple.()) - data IdFooSym1 (l :: c0123456789876543210) (l :: TyFun a0123456789876543210 a0123456789876543210) - = forall arg. SameKind (Apply (IdFooSym1 l) arg) (IdFooSym2 l arg) => - IdFooSym1KindInference - type instance Apply (IdFooSym1 l) l = IdFoo l l - instance SuppressUnusedWarnings IdFooSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) IdFooSym0KindInference) GHC.Tuple.()) - data IdFooSym0 (l :: TyFun c0123456789876543210 (TyFun a0123456789876543210 a0123456789876543210 - -> GHC.Types.Type)) - = forall arg. SameKind (Apply IdFooSym0 arg) (IdFooSym1 arg) => - IdFooSym0KindInference - type instance Apply IdFooSym0 l = IdFooSym1 l - type ReturnFuncSym2 (t :: Nat) (t :: Nat) = ReturnFunc t t - instance SuppressUnusedWarnings ReturnFuncSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) ReturnFuncSym1KindInference) GHC.Tuple.()) - data ReturnFuncSym1 (l :: Nat) (l :: TyFun Nat Nat) - = forall arg. SameKind (Apply (ReturnFuncSym1 l) arg) (ReturnFuncSym2 l arg) => - ReturnFuncSym1KindInference - type instance Apply (ReturnFuncSym1 l) l = ReturnFunc l l - instance SuppressUnusedWarnings ReturnFuncSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) ReturnFuncSym0KindInference) GHC.Tuple.()) - data ReturnFuncSym0 (l :: TyFun Nat (TyFun Nat Nat - -> GHC.Types.Type)) - = forall arg. SameKind (Apply ReturnFuncSym0 arg) (ReturnFuncSym1 arg) => - ReturnFuncSym0KindInference - type instance Apply ReturnFuncSym0 l = ReturnFuncSym1 l - type family Id (a :: a) :: a where - Id x = x - type family IdFoo (a :: c) (a :: a) :: a where - IdFoo _z_0123456789876543210 a_0123456789876543210 = Apply IdSym0 a_0123456789876543210 - type family ReturnFunc (a :: Nat) (a :: Nat) :: Nat where - ReturnFunc _z_0123456789876543210 a_0123456789876543210 = Apply SuccSym0 a_0123456789876543210 - sId :: forall (t :: a). Sing t -> Sing (Apply IdSym0 t :: a) - sIdFoo :: - forall (t :: c) (t :: a). - Sing t -> Sing t -> Sing (Apply (Apply IdFooSym0 t) t :: a) - sReturnFunc :: - forall (t :: Nat) (t :: Nat). - Sing t -> Sing t -> Sing (Apply (Apply ReturnFuncSym0 t) t :: Nat) - sId (sX :: Sing x) = sX - sIdFoo _ (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing ((singFun1 @IdSym0) sId)) sA_0123456789876543210 - sReturnFunc - _ - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing ((singFun1 @SuccSym0) SSucc)) sA_0123456789876543210 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,25 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-unused-imports #-} - -module Singletons.ReturnFunc where - -import Data.Singletons -import Data.Singletons.SuppressUnusedWarnings -import Data.Singletons.TH -import Singletons.Nat - --- tests the "num args" feature of promoteDec. The idea is that when clauses of --- a function have less patterns than required by the type signature the --- promoted type family should have this fact reflected in its return kind, --- which should be turned into a series of nested TyFuns (type level functions) - -$(singletons [d| - returnFunc :: Nat -> Nat -> Nat - returnFunc _ = Succ - - -- promotion of two functions below also depends on "num args" - id :: a -> a - id x = x - - idFoo :: c -> a -> a - idFoo _ = id - |]) diff --git a/tests/compile-and-dump/Singletons/Sections.ghc82.template b/tests/compile-and-dump/Singletons/Sections.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Sections.ghc82.template +++ /dev/null @@ -1,112 +0,0 @@ -Singletons/Sections.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| (+) :: Nat -> Nat -> Nat - Zero + m = m - (Succ n) + m = Succ (n + m) - foo1 :: [Nat] - foo1 = map ((Succ Zero) +) [Zero, Succ Zero] - foo2 :: [Nat] - foo2 = map (+ (Succ Zero)) [Zero, Succ Zero] - foo3 :: [Nat] - foo3 = zipWith (+) [Succ Zero, Succ Zero] [Zero, Succ Zero] |] - ======> - (+) :: Nat -> Nat -> Nat - (+) Zero m = m - (+) (Succ n) m = Succ (n + m) - foo1 :: [Nat] - foo1 = (map (Succ Zero +)) [Zero, Succ Zero] - foo2 :: [Nat] - foo2 = (map (+ Succ Zero)) [Zero, Succ Zero] - foo3 :: [Nat] - foo3 = ((zipWith (+)) [Succ Zero, Succ Zero]) [Zero, Succ Zero] - type family Lambda_0123456789876543210 t where - Lambda_0123456789876543210 lhs_0123456789876543210 = Apply (Apply (:+$) lhs_0123456789876543210) (Apply SuccSym0 ZeroSym0) - type Lambda_0123456789876543210Sym1 t = - Lambda_0123456789876543210 t - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym0 l - = forall arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0KindInference - type instance Apply Lambda_0123456789876543210Sym0 l = Lambda_0123456789876543210 l - type (:+$$$) (t :: Nat) (t :: Nat) = (:+) t t - instance SuppressUnusedWarnings (:+$$) where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) (:+$$###)) GHC.Tuple.()) - data (:+$$) (l :: Nat) (l :: TyFun Nat Nat) - = forall arg. SameKind (Apply ((:+$$) l) arg) ((:+$$$) l arg) => - (:+$$###) - type instance Apply ((:+$$) l) l = (:+) l l - instance SuppressUnusedWarnings (:+$) where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) (:+$###)) GHC.Tuple.()) - data (:+$) (l :: TyFun Nat (TyFun Nat Nat -> GHC.Types.Type)) - = forall arg. SameKind (Apply (:+$) arg) ((:+$$) arg) => (:+$###) - type instance Apply (:+$) l = (:+$$) l - type Foo1Sym0 = Foo1 - type Foo2Sym0 = Foo2 - type Foo3Sym0 = Foo3 - type family (:+) (a :: Nat) (a :: Nat) :: Nat where - (:+) Zero m = m - (:+) (Succ n) m = Apply SuccSym0 (Apply (Apply (:+$) n) m) - type family Foo1 :: [Nat] where - = Apply (Apply MapSym0 (Apply (:+$) (Apply SuccSym0 ZeroSym0))) (Apply (Apply (:$) ZeroSym0) (Apply (Apply (:$) (Apply SuccSym0 ZeroSym0)) '[])) - type family Foo2 :: [Nat] where - = Apply (Apply MapSym0 Lambda_0123456789876543210Sym0) (Apply (Apply (:$) ZeroSym0) (Apply (Apply (:$) (Apply SuccSym0 ZeroSym0)) '[])) - type family Foo3 :: [Nat] where - = Apply (Apply (Apply ZipWithSym0 (:+$)) (Apply (Apply (:$) (Apply SuccSym0 ZeroSym0)) (Apply (Apply (:$) (Apply SuccSym0 ZeroSym0)) '[]))) (Apply (Apply (:$) ZeroSym0) (Apply (Apply (:$) (Apply SuccSym0 ZeroSym0)) '[])) - (%:+) :: - forall (t :: Nat) (t :: Nat). - Sing t -> Sing t -> Sing (Apply (Apply (:+$) t) t :: Nat) - sFoo1 :: Sing (Foo1Sym0 :: [Nat]) - sFoo2 :: Sing (Foo2Sym0 :: [Nat]) - sFoo3 :: Sing (Foo3Sym0 :: [Nat]) - (%:+) SZero (sM :: Sing m) = sM - (%:+) (SSucc (sN :: Sing n)) (sM :: Sing m) - = (applySing ((singFun1 @SuccSym0) SSucc)) - ((applySing ((applySing ((singFun2 @(:+$)) (%:+))) sN)) sM) - 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)) - 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)) - 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)) 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/Star.ghc82.template b/tests/compile-and-dump/Singletons/Star.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Star.ghc82.template +++ /dev/null @@ -1,364 +0,0 @@ -Singletons/Star.hs:0:0:: Splicing declarations - singletonStar [''Nat, ''Int, ''String, ''Maybe, ''Vec] - ======> - data Rep - = Singletons.Star.Nat | - Singletons.Star.Int | - Singletons.Star.String | - Singletons.Star.Maybe Rep | - Singletons.Star.Vec Rep Nat - deriving (Eq, Show, Read) - type family Equals_0123456789876543210 (a :: Type) (b :: Type) :: Bool where - Equals_0123456789876543210 Nat Nat = TrueSym0 - Equals_0123456789876543210 Int Int = TrueSym0 - Equals_0123456789876543210 String String = TrueSym0 - Equals_0123456789876543210 (Maybe a) (Maybe b) = (:==) a b - Equals_0123456789876543210 (Vec a a) (Vec b b) = (:&&) ((:==) a b) ((:==) a b) - Equals_0123456789876543210 (a :: Type) (b :: Type) = FalseSym0 - instance PEq Type where - type (:==) (a :: Type) (b :: Type) = Equals_0123456789876543210 a b - type NatSym0 = Nat - type IntSym0 = Int - type StringSym0 = String - type MaybeSym1 (t :: Type) = Maybe t - instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings MaybeSym0 where - Data.Singletons.SuppressUnusedWarnings.suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) MaybeSym0KindInference) GHC.Tuple.()) - data MaybeSym0 (l :: TyFun Type Type) - = forall arg. SameKind (Apply MaybeSym0 arg) (MaybeSym1 arg) => - MaybeSym0KindInference - type instance Apply MaybeSym0 l = Maybe l - type VecSym2 (t :: Type) (t :: Nat) = Vec t t - instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings VecSym1 where - Data.Singletons.SuppressUnusedWarnings.suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) VecSym1KindInference) GHC.Tuple.()) - data VecSym1 (l :: Type) (l :: TyFun Nat Type) - = forall arg. SameKind (Apply (VecSym1 l) arg) (VecSym2 l arg) => - VecSym1KindInference - type instance Apply (VecSym1 l) l = Vec l l - instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings VecSym0 where - Data.Singletons.SuppressUnusedWarnings.suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) VecSym0KindInference) GHC.Tuple.()) - data VecSym0 (l :: TyFun Type (TyFun Nat Type -> Type)) - = forall arg. SameKind (Apply VecSym0 arg) (VecSym1 arg) => - VecSym0KindInference - type instance Apply VecSym0 l = VecSym1 l - type family Compare_0123456789876543210 (a :: Type) (a :: Type) :: Ordering where - Compare_0123456789876543210 Nat Nat = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) '[] - Compare_0123456789876543210 Int Int = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) '[] - Compare_0123456789876543210 String String = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) '[] - Compare_0123456789876543210 (Maybe a_0123456789876543210) (Maybe b_0123456789876543210) = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) (Apply (Apply (:$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) '[]) - Compare_0123456789876543210 (Vec a_0123456789876543210 a_0123456789876543210) (Vec b_0123456789876543210 b_0123456789876543210) = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) (Apply (Apply (:$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) (Apply (Apply (:$) (Apply (Apply CompareSym0 a_0123456789876543210) b_0123456789876543210)) '[])) - Compare_0123456789876543210 Nat Int = LTSym0 - Compare_0123456789876543210 Nat String = LTSym0 - Compare_0123456789876543210 Nat (Maybe _z_0123456789876543210) = LTSym0 - Compare_0123456789876543210 Nat (Vec _z_0123456789876543210 _z_0123456789876543210) = LTSym0 - Compare_0123456789876543210 Int Nat = GTSym0 - Compare_0123456789876543210 Int String = LTSym0 - Compare_0123456789876543210 Int (Maybe _z_0123456789876543210) = LTSym0 - Compare_0123456789876543210 Int (Vec _z_0123456789876543210 _z_0123456789876543210) = LTSym0 - Compare_0123456789876543210 String Nat = GTSym0 - Compare_0123456789876543210 String Int = GTSym0 - Compare_0123456789876543210 String (Maybe _z_0123456789876543210) = LTSym0 - Compare_0123456789876543210 String (Vec _z_0123456789876543210 _z_0123456789876543210) = LTSym0 - Compare_0123456789876543210 (Maybe _z_0123456789876543210) Nat = GTSym0 - Compare_0123456789876543210 (Maybe _z_0123456789876543210) Int = GTSym0 - Compare_0123456789876543210 (Maybe _z_0123456789876543210) String = GTSym0 - Compare_0123456789876543210 (Maybe _z_0123456789876543210) (Vec _z_0123456789876543210 _z_0123456789876543210) = LTSym0 - Compare_0123456789876543210 (Vec _z_0123456789876543210 _z_0123456789876543210) Nat = GTSym0 - Compare_0123456789876543210 (Vec _z_0123456789876543210 _z_0123456789876543210) Int = GTSym0 - Compare_0123456789876543210 (Vec _z_0123456789876543210 _z_0123456789876543210) String = GTSym0 - Compare_0123456789876543210 (Vec _z_0123456789876543210 _z_0123456789876543210) (Maybe _z_0123456789876543210) = GTSym0 - type Compare_0123456789876543210Sym2 (t :: Type) (t :: Type) = - Compare_0123456789876543210 t t - instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings Compare_0123456789876543210Sym1 where - Data.Singletons.SuppressUnusedWarnings.suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Compare_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Compare_0123456789876543210Sym1 (l :: Type) (l :: TyFun Type Ordering) - = forall arg. SameKind (Apply (Compare_0123456789876543210Sym1 l) arg) (Compare_0123456789876543210Sym2 l arg) => - Compare_0123456789876543210Sym1KindInference - type instance Apply (Compare_0123456789876543210Sym1 l) l = Compare_0123456789876543210 l l - instance Data.Singletons.SuppressUnusedWarnings.SuppressUnusedWarnings Compare_0123456789876543210Sym0 where - Data.Singletons.SuppressUnusedWarnings.suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Compare_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Compare_0123456789876543210Sym0 (l :: TyFun Type (TyFun Type Ordering - -> Type)) - = forall arg. SameKind (Apply Compare_0123456789876543210Sym0 arg) (Compare_0123456789876543210Sym1 arg) => - Compare_0123456789876543210Sym0KindInference - type instance Apply Compare_0123456789876543210Sym0 l = Compare_0123456789876543210Sym1 l - instance POrd Type where - type Compare (a :: Type) (a :: Type) = Apply (Apply Compare_0123456789876543210Sym0 a) a - instance (SOrd Type, SOrd Nat) => SOrd Type where - sCompare :: - forall (t1 :: Type) (t2 :: Type). - Sing t1 - -> Sing t2 - -> Sing (Apply (Apply (CompareSym0 :: TyFun Type (TyFun Type Ordering - -> Type) - -> Type) t1 :: TyFun Type Ordering - -> Type) t2 :: Ordering) - 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 - data instance Sing (z :: Type) - = z ~ Nat => SNat | - z ~ Int => SInt | - z ~ String => SString | - forall (n :: Type). z ~ Maybe n => SMaybe (Sing (n :: Type)) | - forall (n :: Type) (n :: Nat). z ~ Vec n n => - SVec (Sing (n :: Type)) (Sing (n :: Nat)) - type SRep = (Sing :: Type -> Type) - 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) - = case toSing b :: SomeSing Type of { - SomeSing c -> SomeSing (SMaybe c) } - toSing (Singletons.Star.Vec b b) - = case - (GHC.Tuple.(,) (toSing b :: SomeSing Type)) - (toSing b :: SomeSing Nat) - of { - GHC.Tuple.(,) (SomeSing c) (SomeSing c) -> SomeSing ((SVec c) c) } - instance 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 where - (%~) SNat SNat = Proved Refl - (%~) SNat SInt - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SNat SString - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SNat (SMaybe _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SNat (SVec _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SInt SNat - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SInt SInt = Proved Refl - (%~) SInt SString - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SInt (SMaybe _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SInt (SVec _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SString SNat - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SString SInt - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SString SString = Proved Refl - (%~) SString (SMaybe _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SString (SVec _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SMaybe _) SNat - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SMaybe _) SInt - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SMaybe _) SString - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SMaybe a) (SMaybe b) - = case ((%~) a) b of - Proved Refl -> Proved Refl - Disproved contra - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - (%~) (SMaybe _) (SVec _ _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SVec _ _) SNat - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SVec _ _) SInt - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SVec _ _) SString - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SVec _ _) (SMaybe _) - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) (SVec a a) (SVec b b) - = case (GHC.Tuple.(,) (((%~) a) b)) (((%~) a) b) of - GHC.Tuple.(,) (Proved Refl) (Proved Refl) -> Proved Refl - GHC.Tuple.(,) (Disproved contra) _ - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - GHC.Tuple.(,) _ (Disproved contra) - -> Disproved (\ refl -> case refl of { Refl -> contra Refl }) - 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 n, SingI n) => - SingI (Vec (n :: Type) (n :: Nat)) where - sing = (SVec sing) sing 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,15 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-unused-imports #-} - -module Singletons.Star where - -import Data.Singletons.Prelude -import Data.Singletons.Decide -import Data.Singletons.CustomStar -import Singletons.Nat -import Data.Kind - -data Vec :: * -> Nat -> * 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.ghc82.template b/tests/compile-and-dump/Singletons/T124.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T124.ghc82.template +++ /dev/null @@ -1,29 +0,0 @@ -Singletons/T124.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| foo :: Bool -> () - foo True = () - foo False = () |] - ======> - foo :: Bool -> () - foo True = GHC.Tuple.() - foo False = GHC.Tuple.() - type FooSym1 (t :: Bool) = Foo t - instance SuppressUnusedWarnings FooSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) FooSym0KindInference) GHC.Tuple.()) - data FooSym0 (l :: TyFun Bool ()) - = forall arg. SameKind (Apply FooSym0 arg) (FooSym1 arg) => - FooSym0KindInference - type instance Apply FooSym0 l = Foo l - type family Foo (a :: Bool) :: () where - Foo True = Tuple0Sym0 - Foo False = Tuple0Sym0 - sFoo :: forall (t :: Bool). Sing t -> Sing (Apply FooSym0 t :: ()) - sFoo STrue = STuple0 - sFoo SFalse = STuple0 -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.ghc82.template b/tests/compile-and-dump/Singletons/T136.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T136.ghc82.template +++ /dev/null @@ -1,171 +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 GHC.Types.[] = [True] - succ (False GHC.Types.: as) = (True GHC.Types.: as) - succ (True GHC.Types.: as) = (False GHC.Types.: (succ as)) - pred GHC.Types.[] = error "pred 0" - pred (False GHC.Types.: as) = (True GHC.Types.: (pred as)) - pred (True GHC.Types.: as) = (False GHC.Types.: as) - toEnum i - | (i < 0) = error "negative toEnum" - | (i == 0) = [] - | otherwise = succ (toEnum (pred i)) - fromEnum GHC.Types.[] = 0 - fromEnum (False GHC.Types.: as) = (2 * (fromEnum as)) - fromEnum (True GHC.Types.: as) = (1 + (2 * (fromEnum as))) - type family Succ_0123456789876543210 (a :: [Bool]) :: [Bool] where - Succ_0123456789876543210 '[] = Apply (Apply (:$) TrueSym0) '[] - Succ_0123456789876543210 ((:) False as) = Apply (Apply (:$) TrueSym0) as - Succ_0123456789876543210 ((:) True as) = Apply (Apply (:$) FalseSym0) (Apply SuccSym0 as) - type Succ_0123456789876543210Sym1 (t :: [Bool]) = - Succ_0123456789876543210 t - instance SuppressUnusedWarnings Succ_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Succ_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Succ_0123456789876543210Sym0 (l :: TyFun [Bool] [Bool]) - = forall arg. SameKind (Apply Succ_0123456789876543210Sym0 arg) (Succ_0123456789876543210Sym1 arg) => - Succ_0123456789876543210Sym0KindInference - type instance Apply Succ_0123456789876543210Sym0 l = Succ_0123456789876543210 l - type family Pred_0123456789876543210 (a :: [Bool]) :: [Bool] where - Pred_0123456789876543210 '[] = Apply ErrorSym0 "pred 0" - Pred_0123456789876543210 ((:) False as) = Apply (Apply (:$) TrueSym0) (Apply PredSym0 as) - Pred_0123456789876543210 ((:) True as) = Apply (Apply (:$) FalseSym0) as - type Pred_0123456789876543210Sym1 (t :: [Bool]) = - Pred_0123456789876543210 t - instance SuppressUnusedWarnings Pred_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Pred_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Pred_0123456789876543210Sym0 (l :: TyFun [Bool] [Bool]) - = forall arg. SameKind (Apply Pred_0123456789876543210Sym0 arg) (Pred_0123456789876543210Sym1 arg) => - Pred_0123456789876543210Sym0KindInference - type instance Apply Pred_0123456789876543210Sym0 l = Pred_0123456789876543210 l - type family Case_0123456789876543210 i arg_0123456789876543210 t where - Case_0123456789876543210 i arg_0123456789876543210 True = '[] - Case_0123456789876543210 i arg_0123456789876543210 False = Apply SuccSym0 (Apply ToEnumSym0 (Apply PredSym0 i)) - type family Case_0123456789876543210 i arg_0123456789876543210 t where - Case_0123456789876543210 i arg_0123456789876543210 True = Apply ErrorSym0 "negative toEnum" - Case_0123456789876543210 i arg_0123456789876543210 False = Case_0123456789876543210 i arg_0123456789876543210 (Apply (Apply (:==$) i) (FromInteger 0)) - type family Case_0123456789876543210 arg_0123456789876543210 t where - Case_0123456789876543210 arg_0123456789876543210 i = Case_0123456789876543210 i arg_0123456789876543210 (Apply (Apply (:<$) i) (FromInteger 0)) - type family ToEnum_0123456789876543210 (a :: GHC.Types.Nat) :: [Bool] where - ToEnum_0123456789876543210 arg_0123456789876543210 = Case_0123456789876543210 arg_0123456789876543210 arg_0123456789876543210 - type ToEnum_0123456789876543210Sym1 (t :: GHC.Types.Nat) = - ToEnum_0123456789876543210 t - instance SuppressUnusedWarnings ToEnum_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) ToEnum_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data ToEnum_0123456789876543210Sym0 (l :: TyFun GHC.Types.Nat [Bool]) - = forall arg. SameKind (Apply ToEnum_0123456789876543210Sym0 arg) (ToEnum_0123456789876543210Sym1 arg) => - ToEnum_0123456789876543210Sym0KindInference - type instance Apply ToEnum_0123456789876543210Sym0 l = ToEnum_0123456789876543210 l - type family FromEnum_0123456789876543210 (a :: [Bool]) :: GHC.Types.Nat where - FromEnum_0123456789876543210 '[] = FromInteger 0 - FromEnum_0123456789876543210 ((:) False as) = Apply (Apply (:*$) (FromInteger 2)) (Apply FromEnumSym0 as) - FromEnum_0123456789876543210 ((:) True as) = Apply (Apply (:+$) (FromInteger 1)) (Apply (Apply (:*$) (FromInteger 2)) (Apply FromEnumSym0 as)) - type FromEnum_0123456789876543210Sym1 (t :: [Bool]) = - FromEnum_0123456789876543210 t - instance SuppressUnusedWarnings FromEnum_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) FromEnum_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data FromEnum_0123456789876543210Sym0 (l :: TyFun [Bool] GHC.Types.Nat) - = forall arg. SameKind (Apply FromEnum_0123456789876543210Sym0 arg) (FromEnum_0123456789876543210Sym1 arg) => - FromEnum_0123456789876543210Sym0KindInference - type instance Apply FromEnum_0123456789876543210Sym0 l = FromEnum_0123456789876543210 l - instance PEnum [Bool] where - type Succ (a :: [Bool]) = Apply Succ_0123456789876543210Sym0 a - type Pred (a :: [Bool]) = Apply Pred_0123456789876543210Sym0 a - type ToEnum (a :: GHC.Types.Nat) = Apply ToEnum_0123456789876543210Sym0 a - type FromEnum (a :: [Bool]) = Apply FromEnum_0123456789876543210Sym0 a - instance SEnum [Bool] where - sSucc :: - forall (t :: [Bool]). - Sing t - -> Sing (Apply (SuccSym0 :: TyFun [Bool] [Bool] - -> GHC.Types.Type) t :: [Bool]) - sPred :: - forall (t :: [Bool]). - Sing t - -> Sing (Apply (PredSym0 :: TyFun [Bool] [Bool] - -> GHC.Types.Type) t :: [Bool]) - sToEnum :: - forall (t :: GHC.Types.Nat). - Sing t - -> Sing (Apply (ToEnumSym0 :: TyFun GHC.Types.Nat [Bool] - -> GHC.Types.Type) t :: [Bool]) - sFromEnum :: - forall (t :: [Bool]). - Sing t - -> Sing (Apply (FromEnumSym0 :: TyFun [Bool] GHC.Types.Nat - -> GHC.Types.Type) t :: GHC.Types.Nat) - 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) - = case sArg_0123456789876543210 of { - sI :: Sing i - -> case - (applySing ((applySing ((singFun2 @(:<$)) (%:<))) sI)) - (sFromInteger (sing :: Sing 0)) - of - STrue -> sError (sing :: Sing "negative toEnum") - SFalse - -> 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)) :: - Sing (Case_0123456789876543210 i arg_0123456789876543210 (Apply (Apply (:==$) i) (FromInteger 0)) :: [Bool]) :: - Sing (Case_0123456789876543210 i arg_0123456789876543210 (Apply (Apply (:<$) i) (FromInteger 0)) :: [Bool]) } :: - Sing (Case_0123456789876543210 arg_0123456789876543210 arg_0123456789876543210 :: [Bool]) - 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.ghc82.template b/tests/compile-and-dump/Singletons/T136b.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T136b.ghc82.template +++ /dev/null @@ -1,49 +0,0 @@ -Singletons/T136b.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| class C a where - meth :: a -> a |] - ======> - class C a where - meth :: a -> a - type MethSym1 (t :: a0123456789876543210) = Meth t - instance SuppressUnusedWarnings MethSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) MethSym0KindInference) GHC.Tuple.()) - data MethSym0 (l :: TyFun a0123456789876543210 a0123456789876543210) - = forall arg. SameKind (Apply MethSym0 arg) (MethSym1 arg) => - MethSym0KindInference - type instance Apply MethSym0 l = Meth l - class PC (a :: GHC.Types.Type) where - type Meth (arg :: a) :: a - class SC a where - sMeth :: forall (t :: a). Sing t -> Sing (Apply MethSym0 t :: a) -Singletons/T136b.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| instance C Bool where - meth = not |] - ======> - instance C Bool where - meth = not - type family Meth_0123456789876543210 (a :: Bool) :: Bool where - Meth_0123456789876543210 a_0123456789876543210 = Apply NotSym0 a_0123456789876543210 - type Meth_0123456789876543210Sym1 (t :: Bool) = - Meth_0123456789876543210 t - instance SuppressUnusedWarnings Meth_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Meth_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Meth_0123456789876543210Sym0 (l :: TyFun Bool Bool) - = forall arg. SameKind (Apply Meth_0123456789876543210Sym0 arg) (Meth_0123456789876543210Sym1 arg) => - Meth_0123456789876543210Sym0KindInference - type instance Apply Meth_0123456789876543210Sym0 l = Meth_0123456789876543210 l - instance PC Bool where - type Meth (a :: Bool) = Apply Meth_0123456789876543210Sym0 a - instance SC Bool where - sMeth :: - forall (t :: Bool). - Sing t - -> Sing (Apply (MethSym0 :: TyFun Bool Bool - -> GHC.Types.Type) t :: Bool) - 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.ghc82.template b/tests/compile-and-dump/Singletons/T145.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T145.ghc82.template +++ /dev/null @@ -1,30 +0,0 @@ -Singletons/T145.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| class Column (f :: Type -> Type) where - col :: f a -> a -> Bool |] - ======> - class Column (f :: Type -> Type) where - col :: f a -> a -> Bool - type ColSym2 (t :: f0123456789876543210 a0123456789876543210) (t :: a0123456789876543210) = - Col t t - instance SuppressUnusedWarnings ColSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) ColSym1KindInference) GHC.Tuple.()) - data ColSym1 (l :: f0123456789876543210 a0123456789876543210) (l :: TyFun a0123456789876543210 Bool) - = forall arg. SameKind (Apply (ColSym1 l) arg) (ColSym2 l arg) => - ColSym1KindInference - type instance Apply (ColSym1 l) l = Col l l - instance SuppressUnusedWarnings ColSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) ColSym0KindInference) GHC.Tuple.()) - data ColSym0 (l :: TyFun (f0123456789876543210 a0123456789876543210) (TyFun a0123456789876543210 Bool - -> Type)) - = forall arg. SameKind (Apply ColSym0 arg) (ColSym1 arg) => - ColSym0KindInference - type instance Apply ColSym0 l = ColSym1 l - class PColumn (f :: Type -> Type) where - type Col (arg :: f a) (arg :: a) :: Bool - class SColumn (f :: Type -> Type) where - sCol :: - forall (t :: f a) (t :: a). - Sing t -> Sing t -> Sing (Apply (Apply ColSym0 t) t :: Bool) 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 - -$(singletons [d| - class Column (f :: Type -> Type) where - col :: f a -> a -> Bool - |]) diff --git a/tests/compile-and-dump/Singletons/T153.ghc82.template b/tests/compile-and-dump/Singletons/T153.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T153.ghc82.template +++ /dev/null diff --git a/tests/compile-and-dump/Singletons/T153.hs b/tests/compile-and-dump/Singletons/T153.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T153.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE LambdaCase, GADTs, ScopedTypeVariables, TypeInType, - 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.ghc82.template b/tests/compile-and-dump/Singletons/T157.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T157.ghc82.template +++ /dev/null diff --git a/tests/compile-and-dump/Singletons/T157.hs b/tests/compile-and-dump/Singletons/T157.hs deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T157.hs +++ /dev/null @@ -1,6 +0,0 @@ -module T157 where - -import Data.Singletons.Prelude - -foo :: SList '["a", "b", "c"] -foo = sing `SCons` sing `SCons` sing diff --git a/tests/compile-and-dump/Singletons/T159.ghc82.template b/tests/compile-and-dump/Singletons/T159.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T159.ghc82.template +++ /dev/null @@ -1,181 +0,0 @@ -Singletons/T159.hs:0:0:: Splicing declarations - genSingletons [''T0, ''T1] - ======> - type ASym0 = A - type BSym0 = B - type CSym0 = C - type DSym0 = D - type ESym0 = E - type FSym0 = F - data instance Sing (z :: T0) - = z ~ A => SA | - z ~ B => SB | - z ~ C => SC | - z ~ D => SD | - z ~ E => SE | - z ~ F => SF - type ST0 = (Sing :: T0 -> GHC.Types.Type) - instance SingKind T0 where - type Demote T0 = T0 - fromSing SA = A - fromSing SB = B - fromSing SC = C - fromSing SD = D - fromSing SE = E - fromSing SF = F - toSing A = SomeSing SA - toSing B = SomeSing SB - toSing C = SomeSing SC - toSing D = SomeSing SD - toSing E = SomeSing SE - toSing F = SomeSing SF - instance SingI A where - sing = SA - instance SingI B where - sing = SB - instance SingI C where - sing = SC - instance SingI D where - sing = SD - instance SingI E where - sing = SE - instance SingI F where - sing = SF - type N1Sym0 = N1 - type C1Sym2 (t :: T0) (t :: T1) = C1 t t - instance SuppressUnusedWarnings C1Sym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) C1Sym1KindInference) GHC.Tuple.()) - data C1Sym1 (l :: T0) (l :: TyFun T1 T1) - = forall arg. SameKind (Apply (C1Sym1 l) arg) (C1Sym2 l arg) => - C1Sym1KindInference - type instance Apply (C1Sym1 l) l = C1 l l - instance SuppressUnusedWarnings C1Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) C1Sym0KindInference) GHC.Tuple.()) - data C1Sym0 (l :: TyFun T0 (TyFun T1 T1 -> GHC.Types.Type)) - = forall arg. SameKind (Apply C1Sym0 arg) (C1Sym1 arg) => - C1Sym0KindInference - type instance Apply C1Sym0 l = C1Sym1 l - type (:&&$$$) (t :: T0) (t :: T1) = (:&&) t t - instance SuppressUnusedWarnings (:&&$$) where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) (:&&$$###)) GHC.Tuple.()) - data (:&&$$) (l :: T0) (l :: TyFun T1 T1) - = forall arg. SameKind (Apply ((:&&$$) l) arg) ((:&&$$$) l arg) => - (:&&$$###) - type instance Apply ((:&&$$) l) l = (:&&) l l - instance SuppressUnusedWarnings (:&&$) where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) (:&&$###)) GHC.Tuple.()) - data (:&&$) (l :: TyFun T0 (TyFun T1 T1 -> GHC.Types.Type)) - = forall arg. SameKind (Apply (:&&$) arg) ((:&&$$) arg) => - (:&&$###) - type instance Apply (:&&$) l = (:&&$$) l - data instance Sing (z :: T1) - = z ~ N1 => SN1 | - forall (n :: T0) (n :: T1). z ~ C1 n n => - SC1 (Sing (n :: T0)) (Sing (n :: T1)) | - forall (n :: T0) (n :: T1). z ~ (:&&) n n => - (:%&&) (Sing (n :: T0)) (Sing (n :: T1)) - type ST1 = (Sing :: T1 -> GHC.Types.Type) - 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 b) - = case - (GHC.Tuple.(,) (toSing b :: SomeSing T0)) (toSing b :: SomeSing T1) - of { - GHC.Tuple.(,) (SomeSing c) (SomeSing c) -> SomeSing ((SC1 c) c) } - toSing ((:&&) b b) - = case - (GHC.Tuple.(,) (toSing b :: SomeSing T0)) (toSing b :: SomeSing T1) - of { - GHC.Tuple.(,) (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 n, SingI n) => - SingI ((:&&) (n :: T0) (n :: T1)) where - sing = ((:%&&) sing) sing -Singletons/T159.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| infixr 5 :|| - infixr 5 `C2` - - data T2 = N2 | C2 T0 T2 | T0 :|| T2 |] - ======> - data T2 = N2 | C2 T0 T2 | T0 :|| T2 - infixr 5 `C2` - infixr 5 :|| - type N2Sym0 = N2 - type C2Sym2 (t :: T0) (t :: T2) = C2 t t - instance SuppressUnusedWarnings C2Sym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) C2Sym1KindInference) GHC.Tuple.()) - data C2Sym1 (l :: T0) (l :: TyFun T2 T2) - = forall arg. SameKind (Apply (C2Sym1 l) arg) (C2Sym2 l arg) => - C2Sym1KindInference - type instance Apply (C2Sym1 l) l = C2 l l - instance SuppressUnusedWarnings C2Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) C2Sym0KindInference) GHC.Tuple.()) - data C2Sym0 (l :: TyFun T0 (TyFun T2 T2 -> GHC.Types.Type)) - = forall arg. SameKind (Apply C2Sym0 arg) (C2Sym1 arg) => - C2Sym0KindInference - type instance Apply C2Sym0 l = C2Sym1 l - type (:||$$$) (t :: T0) (t :: T2) = (:||) t t - instance SuppressUnusedWarnings (:||$$) where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) (:||$$###)) GHC.Tuple.()) - data (:||$$) (l :: T0) (l :: TyFun T2 T2) - = forall arg. SameKind (Apply ((:||$$) l) arg) ((:||$$$) l arg) => - (:||$$###) - type instance Apply ((:||$$) l) l = (:||) l l - instance SuppressUnusedWarnings (:||$) where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) (:||$###)) GHC.Tuple.()) - data (:||$) (l :: TyFun T0 (TyFun T2 T2 -> GHC.Types.Type)) - = forall arg. SameKind (Apply (:||$) arg) ((:||$$) arg) => - (:||$###) - type instance Apply (:||$) l = (:||$$) l - infixr 5 :%|| - infixr 5 `SC2` - data instance Sing (z :: T2) - = z ~ N2 => SN2 | - forall (n :: T0) (n :: T2). z ~ C2 n n => - SC2 (Sing (n :: T0)) (Sing (n :: T2)) | - forall (n :: T0) (n :: T2). z ~ (:||) n n => - (:%||) (Sing (n :: T0)) (Sing (n :: T2)) - type ST2 = (Sing :: T2 -> GHC.Types.Type) - 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 b) - = case - (GHC.Tuple.(,) (toSing b :: SomeSing T0)) (toSing b :: SomeSing T2) - of { - GHC.Tuple.(,) (SomeSing c) (SomeSing c) -> SomeSing ((SC2 c) c) } - toSing ((:||) b b) - = case - (GHC.Tuple.(,) (toSing b :: SomeSing T0)) (toSing b :: SomeSing T2) - of { - GHC.Tuple.(,) (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 n, SingI n) => - SingI ((:||) (n :: T0) (n :: T2)) where - sing = ((:%||) sing) sing 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/T166.ghc82.template b/tests/compile-and-dump/Singletons/T166.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T166.ghc82.template +++ /dev/null @@ -1,11 +0,0 @@ - -Singletons/T166.hs:0:0: error: - Function being promoted to FooSym0 has too many arguments. - | -14 | $(singletonsOnly [d| - | ^^^^^^^^^^^^^^^^^^... - -Singletons/T166.hs:0:0: error: Q monad failure - | -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.ghc82.template b/tests/compile-and-dump/Singletons/T167.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T167.ghc82.template +++ /dev/null @@ -1,149 +0,0 @@ -Singletons/T167.hs:(0,0)-(0,0): Splicing declarations - singletonsOnly - [d| class Foo a where - foosPrec :: Nat -> a -> DiffList - fooList :: a -> DiffList - fooList = undefined - - instance Foo a => Foo [a] where - foosPrec _ = fooList |] - ======> - type FoosPrecSym3 (t :: Nat) (t :: a0123456789876543210) (t :: [Bool]) = - FoosPrec t t t - instance SuppressUnusedWarnings FoosPrecSym2 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) FoosPrecSym2KindInference) GHC.Tuple.()) - data FoosPrecSym2 (l :: Nat) (l :: a0123456789876543210) (l :: TyFun [Bool] [Bool]) - = forall arg. SameKind (Apply (FoosPrecSym2 l l) arg) (FoosPrecSym3 l l arg) => - FoosPrecSym2KindInference - type instance Apply (FoosPrecSym2 l l) l = FoosPrec l l l - instance SuppressUnusedWarnings FoosPrecSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) FoosPrecSym1KindInference) GHC.Tuple.()) - data FoosPrecSym1 (l :: Nat) (l :: TyFun a0123456789876543210 (TyFun [Bool] [Bool] - -> GHC.Types.Type)) - = forall arg. SameKind (Apply (FoosPrecSym1 l) arg) (FoosPrecSym2 l arg) => - FoosPrecSym1KindInference - type instance Apply (FoosPrecSym1 l) l = FoosPrecSym2 l l - instance SuppressUnusedWarnings FoosPrecSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) FoosPrecSym0KindInference) GHC.Tuple.()) - data FoosPrecSym0 (l :: TyFun Nat (TyFun a0123456789876543210 (TyFun [Bool] [Bool] - -> GHC.Types.Type) - -> GHC.Types.Type)) - = forall arg. SameKind (Apply FoosPrecSym0 arg) (FoosPrecSym1 arg) => - FoosPrecSym0KindInference - type instance Apply FoosPrecSym0 l = FoosPrecSym1 l - type FooListSym2 (t :: a0123456789876543210) (t :: [Bool]) = - FooList t t - instance SuppressUnusedWarnings FooListSym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) FooListSym1KindInference) GHC.Tuple.()) - data FooListSym1 (l :: a0123456789876543210) (l :: TyFun [Bool] [Bool]) - = forall arg. SameKind (Apply (FooListSym1 l) arg) (FooListSym2 l arg) => - FooListSym1KindInference - type instance Apply (FooListSym1 l) l = FooList l l - instance SuppressUnusedWarnings FooListSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) FooListSym0KindInference) GHC.Tuple.()) - data FooListSym0 (l :: TyFun a0123456789876543210 (TyFun [Bool] [Bool] - -> GHC.Types.Type)) - = forall arg. SameKind (Apply FooListSym0 arg) (FooListSym1 arg) => - FooListSym0KindInference - type instance Apply FooListSym0 l = FooListSym1 l - type family FooList_0123456789876543210 (a :: a) (a :: [Bool]) :: [Bool] where - FooList_0123456789876543210 a_0123456789876543210 a_0123456789876543210 = Apply (Apply Any a_0123456789876543210) a_0123456789876543210 - type FooList_0123456789876543210Sym2 (t :: a0123456789876543210) (t :: [Bool]) = - FooList_0123456789876543210 t t - instance SuppressUnusedWarnings FooList_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) FooList_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data FooList_0123456789876543210Sym1 (l :: a0123456789876543210) (l :: TyFun [Bool] [Bool]) - = forall arg. SameKind (Apply (FooList_0123456789876543210Sym1 l) arg) (FooList_0123456789876543210Sym2 l arg) => - FooList_0123456789876543210Sym1KindInference - type instance Apply (FooList_0123456789876543210Sym1 l) l = FooList_0123456789876543210 l l - instance SuppressUnusedWarnings FooList_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) FooList_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data FooList_0123456789876543210Sym0 (l :: TyFun a0123456789876543210 (TyFun [Bool] [Bool] - -> GHC.Types.Type)) - = forall arg. SameKind (Apply FooList_0123456789876543210Sym0 arg) (FooList_0123456789876543210Sym1 arg) => - FooList_0123456789876543210Sym0KindInference - type instance Apply FooList_0123456789876543210Sym0 l = FooList_0123456789876543210Sym1 l - class PFoo (a :: GHC.Types.Type) where - type FoosPrec (arg :: Nat) (arg :: a) (arg :: [Bool]) :: [Bool] - type FooList (arg :: a) (arg :: [Bool]) :: [Bool] - type FooList a a = Apply (Apply FooList_0123456789876543210Sym0 a) a - type family FoosPrec_0123456789876543210 (a :: Nat) (a :: [a]) (a :: [Bool]) :: [Bool] where - FoosPrec_0123456789876543210 _z_0123456789876543210 a_0123456789876543210 a_0123456789876543210 = Apply (Apply FooListSym0 a_0123456789876543210) a_0123456789876543210 - type FoosPrec_0123456789876543210Sym3 (t :: Nat) (t :: [a0123456789876543210]) (t :: [Bool]) = - FoosPrec_0123456789876543210 t t t - instance SuppressUnusedWarnings FoosPrec_0123456789876543210Sym2 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) FoosPrec_0123456789876543210Sym2KindInference) - GHC.Tuple.()) - data FoosPrec_0123456789876543210Sym2 (l :: Nat) (l :: [a0123456789876543210]) (l :: TyFun [Bool] [Bool]) - = forall arg. SameKind (Apply (FoosPrec_0123456789876543210Sym2 l l) arg) (FoosPrec_0123456789876543210Sym3 l l arg) => - FoosPrec_0123456789876543210Sym2KindInference - type instance Apply (FoosPrec_0123456789876543210Sym2 l l) l = FoosPrec_0123456789876543210 l l l - instance SuppressUnusedWarnings FoosPrec_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) FoosPrec_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data FoosPrec_0123456789876543210Sym1 (l :: Nat) (l :: TyFun [a0123456789876543210] (TyFun [Bool] [Bool] - -> GHC.Types.Type)) - = forall arg. SameKind (Apply (FoosPrec_0123456789876543210Sym1 l) arg) (FoosPrec_0123456789876543210Sym2 l arg) => - FoosPrec_0123456789876543210Sym1KindInference - type instance Apply (FoosPrec_0123456789876543210Sym1 l) l = FoosPrec_0123456789876543210Sym2 l l - instance SuppressUnusedWarnings FoosPrec_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) FoosPrec_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data FoosPrec_0123456789876543210Sym0 (l :: TyFun Nat (TyFun [a0123456789876543210] (TyFun [Bool] [Bool] - -> GHC.Types.Type) - -> GHC.Types.Type)) - = forall arg. SameKind (Apply FoosPrec_0123456789876543210Sym0 arg) (FoosPrec_0123456789876543210Sym1 arg) => - FoosPrec_0123456789876543210Sym0KindInference - type instance Apply FoosPrec_0123456789876543210Sym0 l = FoosPrec_0123456789876543210Sym1 l - instance PFoo [a] where - type FoosPrec (a :: Nat) (a :: [a]) (a :: [Bool]) = 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) - = undefined - 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 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,27 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeInType #-} -{-# 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.ghc82.template b/tests/compile-and-dump/Singletons/T172.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T172.ghc82.template +++ /dev/null @@ -1,30 +0,0 @@ -Singletons/T172.hs:(0,0)-(0,0): Splicing declarations - singletonsOnly - [d| ($>) :: Nat -> Nat -> Nat - ($>) = (+) |] - ======> - type ($>$$$) (t :: Nat) (t :: Nat) = ($>) t t - instance SuppressUnusedWarnings ($>$$) where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) (:$>$$###)) GHC.Tuple.()) - data ($>$$) (l :: Nat) (l :: TyFun Nat Nat) - = forall arg. SameKind (Apply (($>$$) l) arg) (($>$$$) l arg) => - (:$>$$###) - type instance Apply (($>$$) l) l = ($>) l l - instance SuppressUnusedWarnings ($>$) where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) (:$>$###)) GHC.Tuple.()) - data ($>$) (l :: TyFun Nat (TyFun Nat Nat -> GHC.Types.Type)) - = forall arg. SameKind (Apply ($>$) arg) (($>$$) arg) => (:$>$###) - type instance Apply ($>$) l = ($>$$) l - type family ($>) (a :: Nat) (a :: Nat) :: Nat where - ($>) a_0123456789876543210 a_0123456789876543210 = Apply (Apply (:+$) a_0123456789876543210) a_0123456789876543210 - (%$>) :: - forall (t :: Nat) (t :: Nat). - Sing t -> Sing t -> Sing (Apply (Apply ($>$) t) t :: Nat) - (%$>) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - ((applySing ((singFun2 @(:+$)) (%:+))) sA_0123456789876543210)) - sA_0123456789876543210 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.ghc82.template b/tests/compile-and-dump/Singletons/T175.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T175.ghc82.template +++ /dev/null @@ -1,45 +0,0 @@ -Singletons/T175.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| quux2 :: Bar2 a => a - quux2 = baz - - class Foo a where - baz :: a - class Foo a => Bar1 a where - quux1 :: a - quux1 = baz - class Foo a => Bar2 a |] - ======> - class Foo a where - baz :: a - class Foo a => Bar1 a where - quux1 :: a - quux1 = baz - class Foo a => Bar2 a - quux2 :: Bar2 a => a - quux2 = baz - type Quux2Sym0 = Quux2 - type family Quux2 :: a where - = BazSym0 - type BazSym0 = Baz - class PFoo (a :: GHC.Types.Type) where - type Baz :: a - type Quux1Sym0 = Quux1 - type family Quux1_0123456789876543210 :: a where - = BazSym0 - type Quux1_0123456789876543210Sym0 = Quux1_0123456789876543210 - class PFoo a => PBar1 (a :: GHC.Types.Type) where - type Quux1 :: a - type Quux1 = Quux1_0123456789876543210Sym0 - class PFoo a => PBar2 (a :: GHC.Types.Type) - sQuux2 :: 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,29 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeInType #-} -{-# 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.ghc82.template b/tests/compile-and-dump/Singletons/T176.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T176.ghc82.template +++ /dev/null @@ -1,137 +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 x arg_0123456789876543210 t where - Case_0123456789876543210 x arg_0123456789876543210 _z_0123456789876543210 = Baz1Sym0 - type family Lambda_0123456789876543210 x t where - Lambda_0123456789876543210 x arg_0123456789876543210 = Case_0123456789876543210 x arg_0123456789876543210 arg_0123456789876543210 - type Lambda_0123456789876543210Sym2 t t = - Lambda_0123456789876543210 t t - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym1 l l - = forall arg. SameKind (Apply (Lambda_0123456789876543210Sym1 l) arg) (Lambda_0123456789876543210Sym2 l arg) => - Lambda_0123456789876543210Sym1KindInference - type instance Apply (Lambda_0123456789876543210Sym1 l) l = Lambda_0123456789876543210 l l - instance SuppressUnusedWarnings Lambda_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Lambda_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Lambda_0123456789876543210Sym0 l - = forall arg. SameKind (Apply Lambda_0123456789876543210Sym0 arg) (Lambda_0123456789876543210Sym1 arg) => - Lambda_0123456789876543210Sym0KindInference - type instance Apply Lambda_0123456789876543210Sym0 l = Lambda_0123456789876543210Sym1 l - type Quux2Sym1 (t :: a0123456789876543210) = Quux2 t - instance SuppressUnusedWarnings Quux2Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Quux2Sym0KindInference) GHC.Tuple.()) - data Quux2Sym0 (l :: TyFun a0123456789876543210 a0123456789876543210) - = forall arg. SameKind (Apply Quux2Sym0 arg) (Quux2Sym1 arg) => - Quux2Sym0KindInference - type instance Apply Quux2Sym0 l = Quux2 l - type Quux1Sym1 (t :: a0123456789876543210) = Quux1 t - instance SuppressUnusedWarnings Quux1Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Quux1Sym0KindInference) GHC.Tuple.()) - data Quux1Sym0 (l :: TyFun a0123456789876543210 a0123456789876543210) - = forall arg. SameKind (Apply Quux1Sym0 arg) (Quux1Sym1 arg) => - Quux1Sym0KindInference - type instance Apply Quux1Sym0 l = Quux1 l - type family Quux2 (a :: a) :: a where - Quux2 x = Apply (Apply Bar2Sym0 x) Baz2Sym0 - type family Quux1 (a :: a) :: a where - Quux1 x = Apply (Apply Bar1Sym0 x) (Apply Lambda_0123456789876543210Sym0 x) - type Bar1Sym2 (t :: a0123456789876543210) (t :: TyFun a0123456789876543210 b0123456789876543210 - -> Type) = - Bar1 t t - instance SuppressUnusedWarnings Bar1Sym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Bar1Sym1KindInference) GHC.Tuple.()) - data Bar1Sym1 (l :: a0123456789876543210) (l :: TyFun (TyFun a0123456789876543210 b0123456789876543210 - -> Type) b0123456789876543210) - = forall arg. SameKind (Apply (Bar1Sym1 l) arg) (Bar1Sym2 l arg) => - Bar1Sym1KindInference - type instance Apply (Bar1Sym1 l) l = Bar1 l l - instance SuppressUnusedWarnings Bar1Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Bar1Sym0KindInference) GHC.Tuple.()) - data Bar1Sym0 (l :: TyFun a0123456789876543210 (TyFun (TyFun a0123456789876543210 b0123456789876543210 - -> Type) b0123456789876543210 - -> Type)) - = forall arg. SameKind (Apply Bar1Sym0 arg) (Bar1Sym1 arg) => - Bar1Sym0KindInference - type instance Apply Bar1Sym0 l = Bar1Sym1 l - type Baz1Sym0 = Baz1 - class PFoo1 (a :: Type) where - type Bar1 (arg :: a) (arg :: TyFun a b -> Type) :: b - type Baz1 :: a - type Bar2Sym2 (t :: a0123456789876543210) (t :: b0123456789876543210) = - Bar2 t t - instance SuppressUnusedWarnings Bar2Sym1 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Bar2Sym1KindInference) GHC.Tuple.()) - data Bar2Sym1 (l :: a0123456789876543210) (l :: TyFun b0123456789876543210 b0123456789876543210) - = forall arg. SameKind (Apply (Bar2Sym1 l) arg) (Bar2Sym2 l arg) => - Bar2Sym1KindInference - type instance Apply (Bar2Sym1 l) l = Bar2 l l - instance SuppressUnusedWarnings Bar2Sym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) Bar2Sym0KindInference) GHC.Tuple.()) - data Bar2Sym0 (l :: TyFun a0123456789876543210 (TyFun b0123456789876543210 b0123456789876543210 - -> Type)) - = forall arg. SameKind (Apply Bar2Sym0 arg) (Bar2Sym1 arg) => - Bar2Sym0KindInference - type instance Apply Bar2Sym0 l = Bar2Sym1 l - type Baz2Sym0 = Baz2 - class PFoo2 (a :: Type) where - type Bar2 (arg :: a) (arg :: b) :: b - type Baz2 :: a - sQuux2 :: - forall (t :: a). SFoo2 a => Sing t -> Sing (Apply Quux2Sym0 t :: a) - sQuux1 :: - forall (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 - -> case sArg_0123456789876543210 of { _ -> sBaz1 } :: - Sing (Case_0123456789876543210 x arg_0123456789876543210 arg_0123456789876543210) })) - class SFoo1 a where - sBar1 :: - forall (t :: a) (t :: TyFun a b -> Type). - Sing t -> Sing t -> Sing (Apply (Apply Bar1Sym0 t) t :: b) - sBaz1 :: Sing (Baz1Sym0 :: a) - class SFoo2 a where - sBar2 :: - forall (t :: a) (t :: b). - Sing t -> Sing t -> Sing (Apply (Apply Bar2Sym0 t) t :: b) - sBaz2 :: Sing (Baz2Sym0 :: a) 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,30 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeInType #-} -{-# 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.ghc82.template b/tests/compile-and-dump/Singletons/T178.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T178.ghc82.template +++ /dev/null @@ -1,161 +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 family Equals_0123456789876543210 (a :: Occ) (b :: Occ) :: Bool where - Equals_0123456789876543210 Str Str = TrueSym0 - Equals_0123456789876543210 Opt Opt = TrueSym0 - Equals_0123456789876543210 Many Many = TrueSym0 - Equals_0123456789876543210 (a :: Occ) (b :: Occ) = FalseSym0 - instance PEq Occ where - type (:==) (a :: Occ) (b :: Occ) = Equals_0123456789876543210 a b - type StrSym0 = Str - type OptSym0 = Opt - type ManySym0 = Many - type EmptySym0 = Empty - type family Empty :: [(Symbol, Occ)] where - = '[] - type family Compare_0123456789876543210 (a :: Occ) (a :: Occ) :: Ordering where - Compare_0123456789876543210 Str Str = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) '[] - Compare_0123456789876543210 Opt Opt = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) '[] - Compare_0123456789876543210 Many Many = Apply (Apply (Apply FoldlSym0 ThenCmpSym0) EQSym0) '[] - Compare_0123456789876543210 Str Opt = LTSym0 - Compare_0123456789876543210 Str Many = LTSym0 - Compare_0123456789876543210 Opt Str = GTSym0 - Compare_0123456789876543210 Opt Many = LTSym0 - Compare_0123456789876543210 Many Str = GTSym0 - Compare_0123456789876543210 Many Opt = GTSym0 - type Compare_0123456789876543210Sym2 (t :: Occ) (t :: Occ) = - Compare_0123456789876543210 t t - instance SuppressUnusedWarnings Compare_0123456789876543210Sym1 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Compare_0123456789876543210Sym1KindInference) - GHC.Tuple.()) - data Compare_0123456789876543210Sym1 (l :: Occ) (l :: TyFun Occ Ordering) - = forall arg. SameKind (Apply (Compare_0123456789876543210Sym1 l) arg) (Compare_0123456789876543210Sym2 l arg) => - Compare_0123456789876543210Sym1KindInference - type instance Apply (Compare_0123456789876543210Sym1 l) l = Compare_0123456789876543210 l l - instance SuppressUnusedWarnings Compare_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) Compare_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Compare_0123456789876543210Sym0 (l :: TyFun Occ (TyFun Occ Ordering - -> GHC.Types.Type)) - = forall arg. SameKind (Apply Compare_0123456789876543210Sym0 arg) (Compare_0123456789876543210Sym1 arg) => - Compare_0123456789876543210Sym0KindInference - type instance Apply Compare_0123456789876543210Sym0 l = Compare_0123456789876543210Sym1 l - instance POrd Occ where - type Compare (a :: Occ) (a :: Occ) = Apply (Apply Compare_0123456789876543210Sym0 a) a - sEmpty :: Sing (EmptySym0 :: [(Symbol, Occ)]) - sEmpty = SNil - data instance Sing (z :: Occ) - = z ~ Str => SStr | z ~ Opt => SOpt | z ~ Many => SMany - type SOcc = (Sing :: Occ -> GHC.Types.Type) - 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 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 { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SStr SMany - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SOpt SStr - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SOpt SOpt = Proved Refl - (%~) SOpt SMany - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SMany SStr - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SMany SOpt - = Disproved - (\ x - -> case x of { - _ -> error "Empty case reached -- this should be impossible" }) - (%~) SMany SMany = Proved Refl - instance SOrd Occ where - sCompare :: - forall (t1 :: Occ) (t2 :: Occ). - Sing t1 - -> Sing t2 - -> Sing (Apply (Apply (CompareSym0 :: TyFun Occ (TyFun Occ Ordering - -> GHC.Types.Type) - -> GHC.Types.Type) t1 :: TyFun Occ Ordering - -> GHC.Types.Type) t2 :: Ordering) - sCompare SStr SStr - = (applySing - ((applySing - ((applySing ((singFun3 @FoldlSym0) sFoldl)) - ((singFun2 @ThenCmpSym0) sThenCmp))) - SEQ)) - SNil - sCompare SOpt SOpt - = (applySing - ((applySing - ((applySing ((singFun3 @FoldlSym0) sFoldl)) - ((singFun2 @ThenCmpSym0) sThenCmp))) - SEQ)) - SNil - sCompare SMany SMany - = (applySing - ((applySing - ((applySing ((singFun3 @FoldlSym0) sFoldl)) - ((singFun2 @ThenCmpSym0) sThenCmp))) - SEQ)) - 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 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,16 +0,0 @@ -module T178 where - -import GHC.TypeLits -import Data.Singletons.TH -import Data.Singletons.Prelude - -$(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/T29.ghc82.template b/tests/compile-and-dump/Singletons/T29.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T29.ghc82.template +++ /dev/null @@ -1,93 +0,0 @@ -Singletons/T29.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| foo :: Bool -> Bool - foo x = not $ x - bar :: Bool -> Bool - bar x = not . not . not $ x - baz :: Bool -> Bool - baz x = not $! x - ban :: Bool -> Bool - ban x = not . not . not $! x |] - ======> - foo :: Bool -> Bool - foo x = (not $ x) - bar :: Bool -> Bool - bar x = ((not . (not . not)) $ x) - baz :: Bool -> Bool - baz x = (not $! x) - ban :: Bool -> Bool - ban x = ((not . (not . not)) $! x) - type BanSym1 (t :: Bool) = Ban t - instance SuppressUnusedWarnings BanSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) BanSym0KindInference) GHC.Tuple.()) - data BanSym0 (l :: TyFun Bool Bool) - = forall arg. SameKind (Apply BanSym0 arg) (BanSym1 arg) => - BanSym0KindInference - type instance Apply BanSym0 l = Ban l - type BazSym1 (t :: Bool) = Baz t - instance SuppressUnusedWarnings BazSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) BazSym0KindInference) GHC.Tuple.()) - data BazSym0 (l :: TyFun Bool Bool) - = forall arg. SameKind (Apply BazSym0 arg) (BazSym1 arg) => - BazSym0KindInference - type instance Apply BazSym0 l = Baz l - type BarSym1 (t :: Bool) = Bar t - instance SuppressUnusedWarnings BarSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) BarSym0KindInference) GHC.Tuple.()) - data BarSym0 (l :: TyFun Bool Bool) - = forall arg. SameKind (Apply BarSym0 arg) (BarSym1 arg) => - BarSym0KindInference - type instance Apply BarSym0 l = Bar l - type FooSym1 (t :: Bool) = Foo t - instance SuppressUnusedWarnings FooSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) FooSym0KindInference) GHC.Tuple.()) - data FooSym0 (l :: TyFun Bool Bool) - = forall arg. SameKind (Apply FooSym0 arg) (FooSym1 arg) => - FooSym0KindInference - type instance Apply FooSym0 l = Foo l - type family Ban (a :: Bool) :: Bool where - Ban x = Apply (Apply ($!$) (Apply (Apply (:.$) NotSym0) (Apply (Apply (:.$) NotSym0) NotSym0))) x - type family Baz (a :: Bool) :: Bool where - Baz x = Apply (Apply ($!$) NotSym0) x - type family Bar (a :: Bool) :: Bool where - Bar x = Apply (Apply ($$) (Apply (Apply (:.$) NotSym0) (Apply (Apply (:.$) NotSym0) NotSym0))) x - type family Foo (a :: Bool) :: Bool where - Foo x = Apply (Apply ($$) NotSym0) x - sBan :: - forall (t :: Bool). Sing t -> Sing (Apply BanSym0 t :: 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 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/T33.ghc82.template b/tests/compile-and-dump/Singletons/T33.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T33.ghc82.template +++ /dev/null @@ -1,32 +0,0 @@ -Singletons/T33.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| foo :: (Bool, Bool) -> () - foo ~(_, _) = () |] - ======> - foo :: (Bool, Bool) -> () - foo ~(_, _) = GHC.Tuple.() - type FooSym1 (t :: (Bool, Bool)) = Foo t - instance SuppressUnusedWarnings FooSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) FooSym0KindInference) GHC.Tuple.()) - data FooSym0 (l :: TyFun (Bool, Bool) ()) - = forall arg. SameKind (Apply FooSym0 arg) (FooSym1 arg) => - FooSym0KindInference - type instance Apply FooSym0 l = Foo l - type family Foo (a :: (Bool, Bool)) :: () where - Foo '(_z_0123456789876543210, _z_0123456789876543210) = Tuple0Sym0 - sFoo :: - forall (t :: (Bool, Bool)). Sing t -> Sing (Apply FooSym0 t :: ()) - sFoo (STuple2 _ _) = STuple0 - -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/T54.ghc82.template b/tests/compile-and-dump/Singletons/T54.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T54.ghc82.template +++ /dev/null @@ -1,47 +0,0 @@ -Singletons/T54.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| g :: Bool -> Bool - g e = (case [not] of { [_] -> not }) e |] - ======> - g :: Bool -> Bool - g e = (case [not] of { [_] -> not }) e - type Let0123456789876543210Scrutinee_0123456789876543210Sym1 t = - Let0123456789876543210Scrutinee_0123456789876543210 t - instance SuppressUnusedWarnings Let0123456789876543210Scrutinee_0123456789876543210Sym0 where - suppressUnusedWarnings _ - = snd - ((GHC.Tuple.(,) - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference) - GHC.Tuple.()) - data Let0123456789876543210Scrutinee_0123456789876543210Sym0 l - = forall arg. SameKind (Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 arg) (Let0123456789876543210Scrutinee_0123456789876543210Sym1 arg) => - Let0123456789876543210Scrutinee_0123456789876543210Sym0KindInference - type instance Apply Let0123456789876543210Scrutinee_0123456789876543210Sym0 l = Let0123456789876543210Scrutinee_0123456789876543210 l - type family Let0123456789876543210Scrutinee_0123456789876543210 e where - Let0123456789876543210Scrutinee_0123456789876543210 e = Apply (Apply (:$) NotSym0) '[] - type family Case_0123456789876543210 e t where - Case_0123456789876543210 e '[_z_0123456789876543210] = NotSym0 - type GSym1 (t :: Bool) = G t - instance SuppressUnusedWarnings GSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) GSym0KindInference) GHC.Tuple.()) - data GSym0 (l :: TyFun Bool Bool) - = forall arg. SameKind (Apply GSym0 arg) (GSym1 arg) => - GSym0KindInference - type instance Apply GSym0 l = G l - type family G (a :: Bool) :: Bool where - G e = Apply (Case_0123456789876543210 e (Let0123456789876543210Scrutinee_0123456789876543210Sym1 e)) e - sG :: forall (t :: Bool). Sing t -> Sing (Apply GSym0 t :: Bool) - sG (sE :: Sing e) - = (applySing - (let - sScrutinee_0123456789876543210 :: - Sing (Let0123456789876543210Scrutinee_0123456789876543210Sym1 e) - sScrutinee_0123456789876543210 - = (applySing - ((applySing ((singFun2 @(:$)) SCons)) ((singFun1 @NotSym0) sNot))) - SNil - in case sScrutinee_0123456789876543210 of { - SCons _ SNil -> (singFun1 @NotSym0) sNot } :: - Sing (Case_0123456789876543210 e (Let0123456789876543210Scrutinee_0123456789876543210Sym1 e)))) - sE 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 -fno-warn-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.ghc82.template b/tests/compile-and-dump/Singletons/T78.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/T78.ghc82.template +++ /dev/null @@ -1,28 +0,0 @@ -Singletons/T78.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| foo :: MaybeBool -> Bool - foo (Just False) = False - foo (Just True) = True - foo Nothing = False |] - ======> - foo :: MaybeBool -> Bool - foo (Just False) = False - foo (Just True) = True - foo Nothing = False - type FooSym1 (t :: Maybe Bool) = Foo t - instance SuppressUnusedWarnings FooSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) FooSym0KindInference) GHC.Tuple.()) - data FooSym0 (l :: TyFun (Maybe Bool) Bool) - = forall arg. SameKind (Apply FooSym0 arg) (FooSym1 arg) => - FooSym0KindInference - type instance Apply FooSym0 l = Foo l - type family Foo (a :: Maybe Bool) :: Bool where - Foo (Just False) = FalseSym0 - Foo (Just True) = TrueSym0 - Foo Nothing = FalseSym0 - sFoo :: - forall (t :: Maybe Bool). Sing t -> Sing (Apply FooSym0 t :: Bool) - sFoo (SJust SFalse) = SFalse - sFoo (SJust STrue) = STrue - sFoo SNothing = SFalse 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.ghc82.template b/tests/compile-and-dump/Singletons/TopLevelPatterns.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/TopLevelPatterns.ghc82.template +++ /dev/null @@ -1,304 +0,0 @@ -Singletons/TopLevelPatterns.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| data Bool = False | True - data Foo = Bar Bool Bool |] - ======> - data Bool = False | True - data Foo = Bar Bool Bool - type FalseSym0 = False - type TrueSym0 = True - type BarSym2 (t :: Bool) (t :: Bool) = Bar t t - instance SuppressUnusedWarnings BarSym1 where - suppressUnusedWarnings _ - = Data.Tuple.snd - ((GHC.Tuple.(,) BarSym1KindInference) GHC.Tuple.()) - data BarSym1 (l :: Bool) (l :: TyFun Bool Foo) - = forall arg. SameKind (Apply (BarSym1 l) arg) (BarSym2 l arg) => - BarSym1KindInference - type instance Apply (BarSym1 l) l = Bar l l - instance SuppressUnusedWarnings BarSym0 where - suppressUnusedWarnings _ - = Data.Tuple.snd - ((GHC.Tuple.(,) BarSym0KindInference) GHC.Tuple.()) - data BarSym0 (l :: TyFun Bool (TyFun Bool Foo -> GHC.Types.Type)) - = forall arg. SameKind (Apply BarSym0 arg) (BarSym1 arg) => - BarSym0KindInference - type instance Apply BarSym0 l = BarSym1 l - data instance Sing (z :: Bool) - = z ~ False => SFalse | z ~ True => STrue - type SBool = (Sing :: Bool -> GHC.Types.Type) - instance SingKind Bool where - type Demote Bool = Bool - fromSing SFalse = False - fromSing STrue = True - toSing False = SomeSing SFalse - toSing True = SomeSing STrue - data instance Sing (z :: Foo) - = forall (n :: Bool) (n :: Bool). z ~ Bar n n => - SBar (Sing (n :: Bool)) (Sing (n :: Bool)) - type SFoo = (Sing :: Foo -> GHC.Types.Type) - instance SingKind Foo where - type Demote Foo = Foo - fromSing (SBar b b) = (Bar (fromSing b)) (fromSing b) - toSing (Bar b b) - = case - (GHC.Tuple.(,) (toSing b :: SomeSing Bool)) - (toSing b :: SomeSing Bool) - of { - GHC.Tuple.(,) (SomeSing c) (SomeSing c) -> SomeSing ((SBar c) c) } - instance SingI False where - sing = SFalse - instance SingI True where - sing = STrue - instance (SingI n, SingI n) => - SingI (Bar (n :: Bool) (n :: Bool)) where - sing = (SBar sing) sing -Singletons/TopLevelPatterns.hs:(0,0)-(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 a_0123456789876543210 t where - Case_0123456789876543210 a_0123456789876543210 '[y_0123456789876543210, - _z_0123456789876543210] = y_0123456789876543210 - type family Case_0123456789876543210 a_0123456789876543210 t where - Case_0123456789876543210 a_0123456789876543210 '[_z_0123456789876543210, - y_0123456789876543210] = y_0123456789876543210 - type family Case_0123456789876543210 a_0123456789876543210 t where - Case_0123456789876543210 a_0123456789876543210 '(y_0123456789876543210, - _z_0123456789876543210) = y_0123456789876543210 - type family Case_0123456789876543210 a_0123456789876543210 t where - Case_0123456789876543210 a_0123456789876543210 '(_z_0123456789876543210, - y_0123456789876543210) = y_0123456789876543210 - type family Case_0123456789876543210 t where - Case_0123456789876543210 (Bar y_0123456789876543210 _z_0123456789876543210) = y_0123456789876543210 - type family Case_0123456789876543210 t where - Case_0123456789876543210 (Bar _z_0123456789876543210 y_0123456789876543210) = y_0123456789876543210 - type family Case_0123456789876543210 t where - Case_0123456789876543210 '[y_0123456789876543210, - _z_0123456789876543210] = y_0123456789876543210 - type family Case_0123456789876543210 t where - Case_0123456789876543210 '[_z_0123456789876543210, - y_0123456789876543210] = y_0123456789876543210 - type False_Sym0 = False_ - type NotSym1 (t :: Bool) = Not t - instance SuppressUnusedWarnings NotSym0 where - suppressUnusedWarnings _ - = Data.Tuple.snd - ((GHC.Tuple.(,) NotSym0KindInference) GHC.Tuple.()) - data NotSym0 (l :: TyFun Bool Bool) - = forall arg. SameKind (Apply NotSym0 arg) (NotSym1 arg) => - NotSym0KindInference - type instance Apply NotSym0 l = Not l - type IdSym1 (t :: a0123456789876543210) = Id t - instance SuppressUnusedWarnings IdSym0 where - suppressUnusedWarnings _ - = Data.Tuple.snd ((GHC.Tuple.(,) IdSym0KindInference) GHC.Tuple.()) - data IdSym0 (l :: TyFun a0123456789876543210 a0123456789876543210) - = forall arg. SameKind (Apply IdSym0 arg) (IdSym1 arg) => - IdSym0KindInference - type instance Apply IdSym0 l = Id l - type FSym1 (t :: Bool) = F t - instance SuppressUnusedWarnings FSym0 where - suppressUnusedWarnings _ - = Data.Tuple.snd ((GHC.Tuple.(,) FSym0KindInference) GHC.Tuple.()) - data FSym0 (l :: TyFun Bool Bool) - = forall arg. SameKind (Apply FSym0 arg) (FSym1 arg) => - FSym0KindInference - type instance Apply FSym0 l = F l - type GSym1 (t :: Bool) = G t - instance SuppressUnusedWarnings GSym0 where - suppressUnusedWarnings _ - = Data.Tuple.snd ((GHC.Tuple.(,) GSym0KindInference) GHC.Tuple.()) - data GSym0 (l :: TyFun Bool Bool) - = forall arg. SameKind (Apply GSym0 arg) (GSym1 arg) => - GSym0KindInference - type instance Apply GSym0 l = G l - type HSym1 (t :: Bool) = H t - instance SuppressUnusedWarnings HSym0 where - suppressUnusedWarnings _ - = Data.Tuple.snd ((GHC.Tuple.(,) HSym0KindInference) GHC.Tuple.()) - data HSym0 (l :: TyFun Bool Bool) - = forall arg. SameKind (Apply HSym0 arg) (HSym1 arg) => - HSym0KindInference - type instance Apply HSym0 l = H l - type ISym1 (t :: Bool) = I t - instance SuppressUnusedWarnings ISym0 where - suppressUnusedWarnings _ - = Data.Tuple.snd ((GHC.Tuple.(,) ISym0KindInference) GHC.Tuple.()) - data ISym0 (l :: TyFun Bool Bool) - = forall arg. SameKind (Apply ISym0 arg) (ISym1 arg) => - ISym0KindInference - type instance Apply ISym0 l = I l - type JSym0 = J - type KSym0 = K - type LSym0 = L - type MSym0 = M - type OtherwiseSym0 = Otherwise - type X_0123456789876543210Sym0 = X_0123456789876543210 - type X_0123456789876543210Sym0 = X_0123456789876543210 - type X_0123456789876543210Sym0 = X_0123456789876543210 - type X_0123456789876543210Sym0 = X_0123456789876543210 - type family False_ where - = FalseSym0 - type family Not (a :: Bool) :: Bool where - Not True = FalseSym0 - Not False = TrueSym0 - type family Id (a :: a) :: a where - Id x = x - type family F (a :: Bool) :: Bool where - F a_0123456789876543210 = Apply (Case_0123456789876543210 a_0123456789876543210 X_0123456789876543210Sym0) a_0123456789876543210 - type family G (a :: Bool) :: Bool where - G a_0123456789876543210 = Apply (Case_0123456789876543210 a_0123456789876543210 X_0123456789876543210Sym0) a_0123456789876543210 - type family H (a :: Bool) :: Bool where - H a_0123456789876543210 = Apply (Case_0123456789876543210 a_0123456789876543210 X_0123456789876543210Sym0) a_0123456789876543210 - type family I (a :: Bool) :: Bool where - I a_0123456789876543210 = Apply (Case_0123456789876543210 a_0123456789876543210 X_0123456789876543210Sym0) a_0123456789876543210 - type family J :: Bool where - = Case_0123456789876543210 X_0123456789876543210Sym0 - type family K :: Bool where - = Case_0123456789876543210 X_0123456789876543210Sym0 - type family L :: Bool where - = Case_0123456789876543210 X_0123456789876543210Sym0 - type family M :: Bool where - = Case_0123456789876543210 X_0123456789876543210Sym0 - type family Otherwise :: Bool where - = TrueSym0 - type family X_0123456789876543210 where - = Apply (Apply (:$) NotSym0) (Apply (Apply (:$) IdSym0) '[]) - type family X_0123456789876543210 where - = Apply (Apply Tuple2Sym0 FSym0) GSym0 - type family X_0123456789876543210 where - = Apply (Apply BarSym0 TrueSym0) (Apply HSym0 FalseSym0) - type family X_0123456789876543210 where - = Apply (Apply (:$) (Apply NotSym0 TrueSym0)) (Apply (Apply (:$) (Apply IdSym0 FalseSym0)) '[]) - sFalse_ :: Sing False_Sym0 - sNot :: - forall (t :: Bool). Sing t -> Sing (Apply NotSym0 t :: Bool) - sId :: forall (t :: a). Sing t -> Sing (Apply IdSym0 t :: a) - sF :: forall (t :: Bool). Sing t -> Sing (Apply FSym0 t :: Bool) - sG :: forall (t :: Bool). Sing t -> Sing (Apply GSym0 t :: Bool) - sH :: forall (t :: Bool). Sing t -> Sing (Apply HSym0 t :: Bool) - sI :: forall (t :: Bool). Sing t -> Sing (Apply ISym0 t :: Bool) - sJ :: Sing (JSym0 :: Bool) - sK :: Sing (KSym0 :: Bool) - sL :: Sing (LSym0 :: Bool) - sM :: Sing (MSym0 :: Bool) - sOtherwise :: Sing (OtherwiseSym0 :: Bool) - sX_0123456789876543210 :: Sing X_0123456789876543210Sym0 - sX_0123456789876543210 :: Sing X_0123456789876543210Sym0 - sX_0123456789876543210 :: Sing X_0123456789876543210Sym0 - sX_0123456789876543210 :: Sing X_0123456789876543210Sym0 - sFalse_ = SFalse - sNot STrue = SFalse - sNot SFalse = STrue - sId (sX :: Sing x) = sX - sF (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - (case sX_0123456789876543210 of { - SCons (sY_0123456789876543210 :: Sing y_0123456789876543210) - (SCons _ SNil) - -> sY_0123456789876543210 } :: - Sing (Case_0123456789876543210 a_0123456789876543210 X_0123456789876543210Sym0))) - sA_0123456789876543210 - sG (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - (case sX_0123456789876543210 of { - SCons _ - (SCons (sY_0123456789876543210 :: Sing y_0123456789876543210) SNil) - -> sY_0123456789876543210 } :: - Sing (Case_0123456789876543210 a_0123456789876543210 X_0123456789876543210Sym0))) - sA_0123456789876543210 - sH (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - (case sX_0123456789876543210 of { - STuple2 (sY_0123456789876543210 :: Sing y_0123456789876543210) _ - -> sY_0123456789876543210 } :: - Sing (Case_0123456789876543210 a_0123456789876543210 X_0123456789876543210Sym0))) - sA_0123456789876543210 - sI (sA_0123456789876543210 :: Sing a_0123456789876543210) - = (applySing - (case sX_0123456789876543210 of { - STuple2 _ (sY_0123456789876543210 :: Sing y_0123456789876543210) - -> sY_0123456789876543210 } :: - Sing (Case_0123456789876543210 a_0123456789876543210 X_0123456789876543210Sym0))) - sA_0123456789876543210 - sJ - = case sX_0123456789876543210 of { - SBar (sY_0123456789876543210 :: Sing y_0123456789876543210) _ - -> sY_0123456789876543210 } :: - Sing (Case_0123456789876543210 X_0123456789876543210Sym0 :: Bool) - sK - = case sX_0123456789876543210 of { - SBar _ (sY_0123456789876543210 :: Sing y_0123456789876543210) - -> sY_0123456789876543210 } :: - Sing (Case_0123456789876543210 X_0123456789876543210Sym0 :: Bool) - sL - = case sX_0123456789876543210 of { - SCons (sY_0123456789876543210 :: Sing y_0123456789876543210) - (SCons _ SNil) - -> sY_0123456789876543210 } :: - Sing (Case_0123456789876543210 X_0123456789876543210Sym0 :: Bool) - sM - = case sX_0123456789876543210 of { - SCons _ - (SCons (sY_0123456789876543210 :: Sing y_0123456789876543210) SNil) - -> sY_0123456789876543210 } :: - Sing (Case_0123456789876543210 X_0123456789876543210Sym0 :: Bool) - sOtherwise = STrue - sX_0123456789876543210 - = (applySing - ((applySing ((singFun2 @(:$)) SCons)) ((singFun1 @NotSym0) sNot))) - ((applySing - ((applySing ((singFun2 @(:$)) SCons)) ((singFun1 @IdSym0) sId))) - SNil) - sX_0123456789876543210 - = (applySing - ((applySing ((singFun2 @Tuple2Sym0) STuple2)) - ((singFun1 @FSym0) sF))) - ((singFun1 @GSym0) sG) - sX_0123456789876543210 - = (applySing ((applySing ((singFun2 @BarSym0) SBar)) STrue)) - ((applySing ((singFun1 @HSym0) sH)) SFalse) - sX_0123456789876543210 - = (applySing - ((applySing ((singFun2 @(:$)) SCons)) - ((applySing ((singFun1 @NotSym0) sNot)) STrue))) - ((applySing - ((applySing ((singFun2 @(:$)) SCons)) - ((applySing ((singFun1 @IdSym0) sId)) SFalse))) - SNil) 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 -fno-warn-incomplete-patterns #-} - -module Singletons.TopLevelPatterns where - -import Data.Singletons -import Data.Singletons.Prelude.List -import Data.Singletons.SuppressUnusedWarnings -import Data.Singletons.TH hiding (STrue, SFalse, TrueSym0, FalseSym0) - -$(singletons [d| - data Bool = False | True - data Foo = Bar Bool Bool - |]) - -$(singletons [d| - otherwise :: Bool - otherwise = True - - id :: a -> a - id x = x - - not :: Bool -> Bool - not True = False - not False = True - - false_ = False - - 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/Undef.ghc82.template b/tests/compile-and-dump/Singletons/Undef.ghc82.template deleted file mode 100644 --- a/tests/compile-and-dump/Singletons/Undef.ghc82.template +++ /dev/null @@ -1,39 +0,0 @@ -Singletons/Undef.hs:(0,0)-(0,0): Splicing declarations - singletons - [d| foo :: Bool -> Bool - foo = undefined - bar :: Bool -> Bool - bar = error "urk" |] - ======> - foo :: Bool -> Bool - foo = undefined - bar :: Bool -> Bool - bar = error "urk" - type BarSym1 (t :: Bool) = Bar t - instance SuppressUnusedWarnings BarSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) BarSym0KindInference) GHC.Tuple.()) - data BarSym0 (l :: TyFun Bool Bool) - = forall arg. SameKind (Apply BarSym0 arg) (BarSym1 arg) => - BarSym0KindInference - type instance Apply BarSym0 l = Bar l - type FooSym1 (t :: Bool) = Foo t - instance SuppressUnusedWarnings FooSym0 where - suppressUnusedWarnings _ - = snd ((GHC.Tuple.(,) FooSym0KindInference) GHC.Tuple.()) - data FooSym0 (l :: TyFun Bool Bool) - = forall arg. SameKind (Apply FooSym0 arg) (FooSym1 arg) => - FooSym0KindInference - type instance Apply FooSym0 l = Foo l - type family Bar (a :: Bool) :: Bool where - Bar a_0123456789876543210 = Apply (Apply ErrorSym0 "urk") a_0123456789876543210 - type family Foo (a :: Bool) :: Bool where - Foo a_0123456789876543210 = Apply Any 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") - sFoo (sA_0123456789876543210 :: Sing a_0123456789876543210) - = undefined 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 @@ -module Singletons.Undef where - -import Data.Singletons.TH -import Data.Singletons.Prelude - -$(singletons [d| - foo :: Bool -> Bool - foo = undefined - - bar :: Bool -> Bool - bar = error "urk" - |]) diff --git a/tests/compile-and-dump/buildGoldenFiles.awk b/tests/compile-and-dump/buildGoldenFiles.awk deleted file mode 100644 --- a/tests/compile-and-dump/buildGoldenFiles.awk +++ /dev/null @@ -1,1 +0,0 @@ -/INSERT/{while((getline line < $2) > 0 ){if(line !~ /INSERT/){print line}}close($2);next}1