singletons-th 3.2 → 3.3
raw patch · 35 files changed
+9261/−8284 lines, 35 filesdep ~basedep ~template-haskelldep ~th-desugarsetup-changed
Dependency ranges changed: base, template-haskell, th-desugar
Files
- CHANGES.md +184/−159
- LICENSE +27/−27
- README.md +26/−26
- Setup.hs +2/−2
- singletons-th.cabal +105/−104
- src/Data/Singletons/TH.hs +173/−173
- src/Data/Singletons/TH/CustomStar.hs +158/−158
- src/Data/Singletons/TH/Deriving/Bounded.hs +67/−59
- src/Data/Singletons/TH/Deriving/Enum.hs +60/−60
- src/Data/Singletons/TH/Deriving/Eq.hs +62/−62
- src/Data/Singletons/TH/Deriving/Foldable.hs +97/−97
- src/Data/Singletons/TH/Deriving/Functor.hs +93/−93
- src/Data/Singletons/TH/Deriving/Infer.hs +160/−160
- src/Data/Singletons/TH/Deriving/Ord.hs +71/−71
- src/Data/Singletons/TH/Deriving/Show.hs +164/−164
- src/Data/Singletons/TH/Deriving/Traversable.hs +67/−67
- src/Data/Singletons/TH/Deriving/Util.hs +299/−299
- src/Data/Singletons/TH/Names.hs +274/−269
- src/Data/Singletons/TH/Options.hs +341/−341
- src/Data/Singletons/TH/Partition.hs +333/−326
- src/Data/Singletons/TH/Promote.hs +1205/−1094
- src/Data/Singletons/TH/Promote/Defun.hs +826/−823
- src/Data/Singletons/TH/Promote/Monad.hs +435/−117
- src/Data/Singletons/TH/Promote/Type.hs +175/−175
- src/Data/Singletons/TH/Single.hs +1118/−1093
- src/Data/Singletons/TH/Single/Data.hs +644/−405
- src/Data/Singletons/TH/Single/Decide.hs +134/−112
- src/Data/Singletons/TH/Single/Defun.hs +238/−238
- src/Data/Singletons/TH/Single/Fixity.hs +178/−170
- src/Data/Singletons/TH/Single/Monad.hs +205/−182
- src/Data/Singletons/TH/Single/Ord.hs +43/−0
- src/Data/Singletons/TH/Single/Type.hs +336/−336
- src/Data/Singletons/TH/SuppressUnusedWarnings.hs +21/−21
- src/Data/Singletons/TH/Syntax.hs +243/−224
- src/Data/Singletons/TH/Util.hs +697/−577
CHANGES.md view
@@ -1,159 +1,184 @@-Changelog for the `singletons-th` project -========================================= - -3.2 [2023.03.12] ----------------- -* Require building with GHC 9.6. -* Derived `POrd` and `SOrd` instances (arising from a use of `deriving Ord`) - now use `(<>) @Ordering` in their implementations instead of the custom - `thenCmp :: Ordering -> Ordering -> Ordering` function. While most code will - likely continue to work after this change, this may break code that attempts - to prove properties about the implementation of a derived `POrd`/`SOrd` - instance. -* Fix a bug in which the `singDecideInstances` and `showSingInstances`, as well - as `deriving Show` declarations, would not respect custom - `promotedDataTypeOrConName` options. -* Allow building with `mtl-2.3.*`. - -3.1.1 [2022.08.23] ------------------- -* Require building with GHC 9.4. -* Improve error messages when attempting to promote a partial application of - a function arrow `(->)`, which is not currently supported. - -3.1 [2021.10.30] ----------------- -* Require building with GHC 9.2. -* Allow promoting and singling type applications in data constructor patterns. -* Make the Template Haskell machinery generate `SingI1` and `SingI2` instances - when possible. -* Make `genDefunSymbols` and related functions less likely to trigger - [GHC#19743](https://gitlab.haskell.org/ghc/ghc/-/issues/19743). - -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` 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). -* Require building with GHC 9.0. -* `Data.Singletons.CustomStar` and `Data.Singletons.SuppressUnusedWarnings` - have been renamed to `Data.Singletons.TH.CustomStar` and - `Data.Singletons.SuppressUnusedWarnings`, respectively, to give every module - in `singletons-th` a consistent module prefix. -* Due to the `singletons` package split, the `singletons-th` modules - `Data.Singletons.TH` and `Data.Singletons.TH.CustomStar` (formerly known as - `Data.Singletons.CustomStar`) no longer re-export any definitions from the - `singletons-base` module `Prelude.Singletons` (formerly known as - `Data.Singletons.Prelude`). The `singletons-base` library now provides - versions of these modules—`Data.Singletons.Base.CustomStar` and - `Data.Singletons.Base.TH`, respectively—that do re-export definitions - from `Prelude.Singletons`. -* "Fully saturated" defunctionalization symbols (e.g., `IdSym1`) are now - defined as type families instead of type synonyms. This has two notable - benefits: - - * Fully saturated defunctionalization symbols can now be given standalone - kind signatures, which ensures that the order of kind variables is the - same as the user originally declared them. - * This fixes a minor regression in `singletons-2.7` in which the quality - of `:kind!` output in GHCi would become worse when using promoted type - families generated by Template Haskell. - - Under certain circumstances, this can be a breaking change: - - * Since more TH-generated promoted functions now have type families on - their right-hand sides, some programs will now require - `UndecidableInstances` where they didn't before. - * Certain definitions that made use of overlapping patterns, such as - `natMinus` below, will no longer typecheck: - - ```hs - $(singletons [d| - data Nat = Z | S Nat - - natMinus :: Nat -> Nat -> Nat - natMinus Z _ = Z - natMinus (S a) (S b) = natMinus a b - natMinus a Z = a - |]) - ``` - - This can be worked around by avoiding the use of overlapping patterns. - In the case of `natMinus`, this amounts to changing the third equation - to match on its first argument: - - ```hs - $(singletons [d| - natMinus :: Nat -> Nat -> Nat - natMinus Z _ = Z - natMinus (S a) (S b) = natMinus a b - natMinus a@(S _) Z = a - |]) - ``` -* The specification for how `singletons` deals with record selectors has been - simplified. Previously, `singletons` would try to avoid promoting so-called - "naughty" selectors (those whose types mention existential type variables - that do not appear in the constructor's return type) to top-level functions. - Determing if a selector is naughty is quite challenging in practice, as - determining if a type variable is existential or not in the context of - Template Haskell is difficult in the general case. As a result, `singletons` - now adopts the dumb-but-predictable approach of always promoting record - selectors to top-level functions, naughty or not. - - This means that attempting to promote code with a naughty record selector, - like in the example below, will no longer work: - - ```hs - $(promote [d| - data Some :: (Type -> Type) -> Type where - MkSome :: { getSome :: f a } -> Some f - -- getSome is naughty due to mentioning the type variable `a` - |]) - ``` - - Please open an issue if you find this restriction burdensome in practice. -* The `singEqInstanceOnly` and `singEqInstancesOnly` functions, which generate - `SEq` (but not `PEq`) instances, have been removed. There is not much point - in keeping these functions around now that `PEq` now longer has a special - default implementation. Use `singEqInstance{s}` instead. -* The Template Haskell machinery will no longer promote `TypeRep` to `Type`, - as this special case never worked properly in the first place. -* The Template Haskell machinery will now preserve strict fields in data types - when generating their singled counterparts. -* Introduce a new `promotedDataTypeOrConName` option to - `Data.Singletons.TH.Options`. Overriding this option can be useful in - situations where one wishes to promote types such as `Nat`, `Symbol`, or - data types built on top of them. See the - "Arrows, `Nat`, `Symbol`, and literals" section of the `README` for more - information. -* Define a `Quote` instance for `OptionsM`. A notable benefit of this instance - is that it avoids the need to explicitly `lift` TH quotes into `OptionsM`. - Before, you would have to do this: - - ```hs - import Control.Monad.Trans.Class (lift) - - withOptions defaultOptions - $ singletons - $ lift [d| data T = MkT |] - ``` - - But now, it suffices to simply do this: - - ```hs - withOptions defaultOptions - $ singletons [d| data T = MkT |] - ``` +Changelog for the `singletons-th` project+=========================================++3.3 [2023.10.13]+----------------+* Require building with GHC 9.8.+* Singled data types with derived `Eq` or `Ord` instances now generate `Eq` or+ `Ord` instances for the singleton type itself, e.g.,++ ```hs+ instance Eq (SExample a) where+ _ == _ = True++ instance Ord (SExample a) where+ compare _ _ = EQ+ ```+* `singletons-th` now makes an effort to promote definitions that use scoped+ type variables. See the "Scoped type variables" section of the `README` for+ more information about what `singletons-th` can (and can't) do.+* `singletons-th` now supports singling type-level definitions that use+ `TypeAbstractions`.+* Fix a bug in which data types using visible dependent quantification would+ generate ill-scoped code when singled.+* Fix a bug in which singling a local variable that shadows a top-level+ definition would fail to typecheck in some circumstances.+* Fix a bug in which `singletons-th` would incorrectly promote/single records+ to top-level field selectors when `NoFieldSelectors` was active.++3.2 [2023.03.12]+----------------+* Require building with GHC 9.6.+* Derived `POrd` and `SOrd` instances (arising from a use of `deriving Ord`)+ now use `(<>) @Ordering` in their implementations instead of the custom+ `thenCmp :: Ordering -> Ordering -> Ordering` function. While most code will+ likely continue to work after this change, this may break code that attempts+ to prove properties about the implementation of a derived `POrd`/`SOrd`+ instance.+* Fix a bug in which the `singDecideInstances` and `showSingInstances`, as well+ as `deriving Show` declarations, would not respect custom+ `promotedDataTypeOrConName` options.+* Allow building with `mtl-2.3.*`.++3.1.1 [2022.08.23]+------------------+* Require building with GHC 9.4.+* Improve error messages when attempting to promote a partial application of+ a function arrow `(->)`, which is not currently supported.++3.1 [2021.10.30]+----------------+* Require building with GHC 9.2.+* Allow promoting and singling type applications in data constructor patterns.+* Make the Template Haskell machinery generate `SingI1` and `SingI2` instances+ when possible.+* Make `genDefunSymbols` and related functions less likely to trigger+ [GHC#19743](https://gitlab.haskell.org/ghc/ghc/-/issues/19743).++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` 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).+* Require building with GHC 9.0.+* `Data.Singletons.CustomStar` and `Data.Singletons.SuppressUnusedWarnings`+ have been renamed to `Data.Singletons.TH.CustomStar` and+ `Data.Singletons.SuppressUnusedWarnings`, respectively, to give every module+ in `singletons-th` a consistent module prefix.+* Due to the `singletons` package split, the `singletons-th` modules+ `Data.Singletons.TH` and `Data.Singletons.TH.CustomStar` (formerly known as+ `Data.Singletons.CustomStar`) no longer re-export any definitions from the+ `singletons-base` module `Prelude.Singletons` (formerly known as+ `Data.Singletons.Prelude`). The `singletons-base` library now provides+ versions of these modules—`Data.Singletons.Base.CustomStar` and+ `Data.Singletons.Base.TH`, respectively—that do re-export definitions+ from `Prelude.Singletons`.+* "Fully saturated" defunctionalization symbols (e.g., `IdSym1`) are now+ defined as type families instead of type synonyms. This has two notable+ benefits:++ * Fully saturated defunctionalization symbols can now be given standalone+ kind signatures, which ensures that the order of kind variables is the+ same as the user originally declared them.+ * This fixes a minor regression in `singletons-2.7` in which the quality+ of `:kind!` output in GHCi would become worse when using promoted type+ families generated by Template Haskell.++ Under certain circumstances, this can be a breaking change:++ * Since more TH-generated promoted functions now have type families on+ their right-hand sides, some programs will now require+ `UndecidableInstances` where they didn't before.+ * Certain definitions that made use of overlapping patterns, such as+ `natMinus` below, will no longer typecheck:++ ```hs+ $(singletons [d|+ data Nat = Z | S Nat++ natMinus :: Nat -> Nat -> Nat+ natMinus Z _ = Z+ natMinus (S a) (S b) = natMinus a b+ natMinus a Z = a+ |])+ ```++ This can be worked around by avoiding the use of overlapping patterns.+ In the case of `natMinus`, this amounts to changing the third equation+ to match on its first argument:++ ```hs+ $(singletons [d|+ natMinus :: Nat -> Nat -> Nat+ natMinus Z _ = Z+ natMinus (S a) (S b) = natMinus a b+ natMinus a@(S _) Z = a+ |])+ ```+* The specification for how `singletons` deals with record selectors has been+ simplified. Previously, `singletons` would try to avoid promoting so-called+ "naughty" selectors (those whose types mention existential type variables+ that do not appear in the constructor's return type) to top-level functions.+ Determing if a selector is naughty is quite challenging in practice, as+ determining if a type variable is existential or not in the context of+ Template Haskell is difficult in the general case. As a result, `singletons`+ now adopts the dumb-but-predictable approach of always promoting record+ selectors to top-level functions, naughty or not.++ This means that attempting to promote code with a naughty record selector,+ like in the example below, will no longer work:++ ```hs+ $(promote [d|+ data Some :: (Type -> Type) -> Type where+ MkSome :: { getSome :: f a } -> Some f+ -- getSome is naughty due to mentioning the type variable `a`+ |])+ ```++ Please open an issue if you find this restriction burdensome in practice.+* The `singEqInstanceOnly` and `singEqInstancesOnly` functions, which generate+ `SEq` (but not `PEq`) instances, have been removed. There is not much point+ in keeping these functions around now that `PEq` now longer has a special+ default implementation. Use `singEqInstance{s}` instead.+* The Template Haskell machinery will no longer promote `TypeRep` to `Type`,+ as this special case never worked properly in the first place.+* The Template Haskell machinery will now preserve strict fields in data types+ when generating their singled counterparts.+* Introduce a new `promotedDataTypeOrConName` option to+ `Data.Singletons.TH.Options`. Overriding this option can be useful in+ situations where one wishes to promote types such as `Nat`, `Symbol`, or+ data types built on top of them. See the+ "Arrows, `Nat`, `Symbol`, and literals" section of the `README` for more+ information.+* Define a `Quote` instance for `OptionsM`. A notable benefit of this instance+ is that it avoids the need to explicitly `lift` TH quotes into `OptionsM`.+ Before, you would have to do this:++ ```hs+ import Control.Monad.Trans.Class (lift)++ withOptions defaultOptions+ $ singletons+ $ lift [d| data T = MkT |]+ ```++ But now, it suffices to simply do this:++ ```hs+ withOptions defaultOptions+ $ singletons [d| data T = MkT |]+ ```
LICENSE view
@@ -1,27 +1,27 @@-Copyright (c) 2012-2020, Richard Eisenberg -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -1. Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. - -2. Redistributions in binary form must reproduce the above copyright notice, -this list of conditions and the following disclaimer in the documentation -and/or other materials provided with the distribution. - -3. Neither the name of the author nor the names of its contributors may be -used to endorse or promote products derived from this software without -specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" -AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +Copyright (c) 2012-2020, Richard Eisenberg+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of its contributors may be+used to endorse or promote products derived from this software without+specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
README.md view
@@ -1,26 +1,26 @@-`singletons-th` -=============== - -[](http://hackage.haskell.org/package/singletons-th) - -`singletons-th` defines Template Haskell functionality that allows -_promotion_ of term-level functions to type-level equivalents and -_singling_ functions to dependently typed equivalents. 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. See also -[the paper published at Haskell Symposium, 2014](https://richarde.dev/papers/2014/promotion/promotion.pdf), -which describes how promotion works in greater detail. - -`singletons-th` generates code that relies on bleeding-edge GHC language -extensions. As such, `singletons-th` only supports the latest major version -of GHC (currently GHC 9.6). For more information, -consult the `singletons` -[`README`](https://github.com/goldfirere/singletons/blob/master/README.md). - -You may also be interested in the following related libraries: - -* The `singletons` library is a small, foundational library that defines - basic singleton-related types and definitions. -* The `singletons-base` library uses `singletons-th` to define promoted and - singled functions from the `base` library, including the `Prelude`. +`singletons-th`+===============++[](http://hackage.haskell.org/package/singletons-th)++`singletons-th` defines Template Haskell functionality that allows+_promotion_ of term-level functions to type-level equivalents and+_singling_ functions to dependently typed equivalents. 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. See also+[the paper published at Haskell Symposium, 2014](https://richarde.dev/papers/2014/promotion/promotion.pdf),+which describes how promotion works in greater detail.++`singletons-th` generates code that relies on bleeding-edge GHC language+extensions. As such, `singletons-th` only supports the latest major version+of GHC (currently GHC 9.8). For more information,+consult the `singletons`+[`README`](https://github.com/goldfirere/singletons/blob/master/README.md).++You may also be interested in the following related libraries:++* The `singletons` library is a small, foundational library that defines+ basic singleton-related types and definitions.+* The `singletons-base` library uses `singletons-th` to define promoted and+ singled functions from the `base` library, including the `Prelude`.
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple -main = defaultMain +import Distribution.Simple+main = defaultMain
singletons-th.cabal view
@@ -1,104 +1,105 @@-name: singletons-th -version: 3.2 -cabal-version: 1.24 -synopsis: A framework for generating singleton types -homepage: http://www.github.com/goldfirere/singletons -category: Dependent Types -author: Richard Eisenberg <rae@cs.brynmawr.edu>, Jan Stolarek <jan.stolarek@p.lodz.pl> -maintainer: Ryan Scott <ryan.gl.scott@gmail.com> -bug-reports: https://github.com/goldfirere/singletons/issues -stability: experimental -tested-with: GHC == 9.6.1 -extra-source-files: README.md, CHANGES.md -license: BSD3 -license-file: LICENSE -build-type: Simple -description: - @singletons-th@ defines Template Haskell functionality that allows - /promotion/ of term-level functions to type-level equivalents and - /singling/ functions to dependently typed equivalents. This library was - originally presented in /Dependently Typed Programming with Singletons/, - published at the Haskell Symposium, 2012. - (<https://richarde.dev/papers/2012/singletons/paper.pdf>) - See also the paper published at Haskell Symposium, 2014, which describes - how promotion works in greater detail: - <https://richarde.dev/papers/2014/promotion/promotion.pdf>. - . - @singletons-th@ generates code that relies on bleeding-edge GHC language - extensions. As such, @singletons-th@ only supports the latest major version - of GHC (currently GHC 9.6). For more information, - consult the @singletons@ - @<https://github.com/goldfirere/singletons/blob/master/README.md README>@. - . - You may also be interested in the following related libraries: - . - * The @singletons@ library is a small, foundational library that defines - basic singleton-related types and definitions. - . - * 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 - subdir: singletons-th - tag: v3.1.2 - -source-repository head - type: git - location: https://github.com/goldfirere/singletons.git - subdir: singletons-th - branch: master - -library - hs-source-dirs: src - build-depends: base >= 4.18 && < 4.19, - containers >= 0.5, - mtl >= 2.2.1 && < 2.4, - ghc-boot-th, - singletons == 3.0.*, - syb >= 0.4, - template-haskell >= 2.20 && < 2.21, - th-desugar >= 1.15 && < 1.16, - th-orphans >= 0.13.11 && < 0.14, - transformers >= 0.5.2 - default-language: GHC2021 - other-extensions: TemplateHaskellQuotes - exposed-modules: Data.Singletons.TH - Data.Singletons.TH.CustomStar - Data.Singletons.TH.Options - Data.Singletons.TH.SuppressUnusedWarnings - - other-modules: Data.Singletons.TH.Deriving.Bounded - Data.Singletons.TH.Deriving.Enum - Data.Singletons.TH.Deriving.Eq - Data.Singletons.TH.Deriving.Foldable - Data.Singletons.TH.Deriving.Functor - Data.Singletons.TH.Deriving.Infer - Data.Singletons.TH.Deriving.Ord - Data.Singletons.TH.Deriving.Show - Data.Singletons.TH.Deriving.Traversable - Data.Singletons.TH.Deriving.Util - Data.Singletons.TH.Names - Data.Singletons.TH.Partition - Data.Singletons.TH.Promote - Data.Singletons.TH.Promote.Defun - Data.Singletons.TH.Promote.Monad - Data.Singletons.TH.Promote.Type - Data.Singletons.TH.Single - Data.Singletons.TH.Single.Data - Data.Singletons.TH.Single.Decide - Data.Singletons.TH.Single.Defun - Data.Singletons.TH.Single.Fixity - Data.Singletons.TH.Single.Monad - Data.Singletons.TH.Single.Type - Data.Singletons.TH.Syntax - Data.Singletons.TH.Util - - -- singletons re-exports - reexported-modules: Data.Singletons - , Data.Singletons.Decide - , Data.Singletons.ShowSing - , Data.Singletons.Sigma - - ghc-options: -Wall -Wcompat +name: singletons-th+version: 3.3+cabal-version: 1.24+synopsis: A framework for generating singleton types+homepage: http://www.github.com/goldfirere/singletons+category: Dependent Types+author: Richard Eisenberg <rae@cs.brynmawr.edu>, Jan Stolarek <jan.stolarek@p.lodz.pl>+maintainer: Ryan Scott <ryan.gl.scott@gmail.com>+bug-reports: https://github.com/goldfirere/singletons/issues+stability: experimental+tested-with: GHC == 9.8.1+extra-source-files: README.md, CHANGES.md+license: BSD3+license-file: LICENSE+build-type: Simple+description:+ @singletons-th@ defines Template Haskell functionality that allows+ /promotion/ of term-level functions to type-level equivalents and+ /singling/ functions to dependently typed equivalents. This library was+ originally presented in /Dependently Typed Programming with Singletons/,+ published at the Haskell Symposium, 2012.+ (<https://richarde.dev/papers/2012/singletons/paper.pdf>)+ See also the paper published at Haskell Symposium, 2014, which describes+ how promotion works in greater detail:+ <https://richarde.dev/papers/2014/promotion/promotion.pdf>.+ .+ @singletons-th@ generates code that relies on bleeding-edge GHC language+ extensions. As such, @singletons-th@ only supports the latest major version+ of GHC (currently GHC 9.8). For more information,+ consult the @singletons@+ @<https://github.com/goldfirere/singletons/blob/master/README.md README>@.+ .+ You may also be interested in the following related libraries:+ .+ * The @singletons@ library is a small, foundational library that defines+ basic singleton-related types and definitions.+ .+ * 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+ subdir: singletons-th+ tag: v3.1.2++source-repository head+ type: git+ location: https://github.com/goldfirere/singletons.git+ subdir: singletons-th+ branch: master++library+ hs-source-dirs: src+ build-depends: base >= 4.19 && < 4.20,+ containers >= 0.5,+ mtl >= 2.2.1 && < 2.4,+ ghc-boot-th,+ singletons == 3.0.*,+ syb >= 0.4,+ template-haskell >= 2.21 && < 2.22,+ th-desugar >= 1.16 && < 1.17,+ th-orphans >= 0.13.11 && < 0.14,+ transformers >= 0.5.2+ default-language: GHC2021+ other-extensions: TemplateHaskellQuotes+ exposed-modules: Data.Singletons.TH+ Data.Singletons.TH.CustomStar+ Data.Singletons.TH.Options+ Data.Singletons.TH.SuppressUnusedWarnings++ other-modules: Data.Singletons.TH.Deriving.Bounded+ Data.Singletons.TH.Deriving.Enum+ Data.Singletons.TH.Deriving.Eq+ Data.Singletons.TH.Deriving.Foldable+ Data.Singletons.TH.Deriving.Functor+ Data.Singletons.TH.Deriving.Infer+ Data.Singletons.TH.Deriving.Ord+ Data.Singletons.TH.Deriving.Show+ Data.Singletons.TH.Deriving.Traversable+ Data.Singletons.TH.Deriving.Util+ Data.Singletons.TH.Names+ Data.Singletons.TH.Partition+ Data.Singletons.TH.Promote+ Data.Singletons.TH.Promote.Defun+ Data.Singletons.TH.Promote.Monad+ Data.Singletons.TH.Promote.Type+ Data.Singletons.TH.Single+ Data.Singletons.TH.Single.Data+ Data.Singletons.TH.Single.Decide+ Data.Singletons.TH.Single.Defun+ Data.Singletons.TH.Single.Fixity+ Data.Singletons.TH.Single.Monad+ Data.Singletons.TH.Single.Ord+ Data.Singletons.TH.Single.Type+ Data.Singletons.TH.Syntax+ Data.Singletons.TH.Util++ -- singletons re-exports+ reexported-modules: Data.Singletons+ , Data.Singletons.Decide+ , Data.Singletons.ShowSing+ , Data.Singletons.Sigma++ ghc-options: -Wall -Wcompat
src/Data/Singletons/TH.hs view
@@ -1,173 +1,173 @@------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TH --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- This module contains basic functionality for deriving your own singletons --- via Template Haskell. Note that this module does not define any singled --- definitions on its own. For a version of this module that comes pre-equipped --- with several singled definitions based on the "Prelude", see --- @Data.Singletons.Base.TH@ from the @singletons-base@ library. --- ----------------------------------------------------------------------------- - -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, - singDecideInstances, singDecideInstance, - - -- ** Functions to generate 'Ord' instances - promoteOrdInstances, promoteOrdInstance, - singOrdInstances, singOrdInstance, - - -- ** Functions to generate 'Bounded' instances - promoteBoundedInstances, promoteBoundedInstance, - singBoundedInstances, singBoundedInstance, - - -- ** Functions to generate 'Enum' instances - promoteEnumInstances, promoteEnumInstance, - singEnumInstances, singEnumInstance, - - -- ** Functions to generate 'Show' instances - promoteShowInstances, promoteShowInstance, - singShowInstances, singShowInstance, - showSingInstances, showSingInstance, - - -- ** Utility functions - singITyConInstances, singITyConInstance, - cases, sCases, - - -- * Basic singleton definitions - module Data.Singletons, - - -- * Auxiliary definitions - SDecide(..), (:~:)(..), Void, Refuted, Decision(..), - - SuppressUnusedWarnings(..) - - ) where - -import Control.Arrow ( first ) -import Data.Singletons -import Data.Singletons.Decide -import Data.Singletons.TH.Options -import Data.Singletons.TH.Promote -import Data.Singletons.TH.Single -import Data.Singletons.TH.SuppressUnusedWarnings -import Data.Singletons.TH.Util -import Language.Haskell.TH -import Language.Haskell.TH.Desugar - --- | 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. --- --- Here is a simple example to illustrate where 'cases' can be useful. Suppose --- you use @singletons-th@ to single this code: --- --- @ --- $('singletons' [d| --- foo :: Bool -> () --- foo True = () --- foo False = () --- |]) --- @ --- --- And that you want to write a function of this type: --- --- @ --- bar :: SBool b -> STuple0 (Foo b) --- @ --- --- How would you do this? You might be tempted to write the following: --- --- @ --- bar _ = STuple0 --- @ --- --- However, this won't typecheck, as Foo b won't reduce to @'()@ unless GHC --- knows @b@ is either 'True' or 'False'. In order to convince GHC of this, you --- must explicitly match on each of the data constructors of @SBool@: --- --- @ --- bar :: SBool b -> STuple0 (Foo b) --- bar b = case b of --- STrue -> STuple0 --- SFalse -> STuple0 --- @ --- --- This is doable, but it is somewhat tedious. After all, the right-hand side --- of each case alternative is exactly the same! This only becomes more tedious --- when you deal with data types with lots of lots of data constructors. For --- this reason, @singletons-th@ offers the 'cases' function to generate this --- boilerplate code for you. The following is equivalent to the implementation --- of @bar@ above: --- --- @ --- bar :: SBool b -> STuple0 (Foo b) --- bar b = $(cases ''SBool [| b |] [| STuple0 |]) --- @ -cases :: DsMonad q - => Name -- ^ The head of the type of the scrutinee. (e.g., @''SBool@) - -> 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 <<cases>> 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@. In other words, @sCases ''Maybe@ is equivalent to --- @'cases' ''SMaybe@. -sCases :: OptionsMonad q - => Name -- ^ The head of the type the scrutinee's type is based on. - -- (Like @''Maybe@ or @''Bool@.) - -> q Exp -- ^ The scrutinee, in a Template Haskell quote - -> q Exp -- ^ The body, in a Template Haskell quote - -> q Exp -sCases tyName expq bodyq = do - opts <- getOptions - dinfo <- dsReify tyName - case dinfo of - Just (DTyConI (DDataD _ _ _ _ _ ctors _) _) -> - let ctor_stuff = map (first (singledDataConName opts) . extractNameArgs) ctors in - expToTH <$> buildCases ctor_stuff expq bodyq - Just _ -> - fail $ "Using <<cases>> with something other than a type constructor: " - ++ (show tyName) - _ -> fail $ "Cannot find " ++ show tyName - -buildCases :: DsMonad m - => [(Name, Int)] - -> m Exp -- scrutinee - -> m Exp -- body - -> m DExp -buildCases ctor_infos expq bodyq = - DCaseE <$> (dsExp =<< expq) <*> - mapM (\con -> DMatch (conToPat con) <$> (dsExp =<< bodyq)) ctor_infos - where - conToPat :: (Name, Int) -> DPat - conToPat (name, num_fields) = - DConP name [] (replicate num_fields DWildP) +-----------------------------------------------------------------------------+-- |+-- Module : Data.Singletons.TH+-- Copyright : (C) 2013 Richard Eisenberg+-- License : BSD-style (see LICENSE)+-- Maintainer : Ryan Scott+-- Stability : experimental+-- Portability : non-portable+--+-- This module contains basic functionality for deriving your own singletons+-- via Template Haskell. Note that this module does not define any singled+-- definitions on its own. For a version of this module that comes pre-equipped+-- with several singled definitions based on the "Prelude", see+-- @Data.Singletons.Base.TH@ from the @singletons-base@ library.+--+----------------------------------------------------------------------------++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,+ singDecideInstances, singDecideInstance,++ -- ** Functions to generate 'Ord' instances+ promoteOrdInstances, promoteOrdInstance,+ singOrdInstances, singOrdInstance,++ -- ** Functions to generate 'Bounded' instances+ promoteBoundedInstances, promoteBoundedInstance,+ singBoundedInstances, singBoundedInstance,++ -- ** Functions to generate 'Enum' instances+ promoteEnumInstances, promoteEnumInstance,+ singEnumInstances, singEnumInstance,++ -- ** Functions to generate 'Show' instances+ promoteShowInstances, promoteShowInstance,+ singShowInstances, singShowInstance,+ showSingInstances, showSingInstance,++ -- ** Utility functions+ singITyConInstances, singITyConInstance,+ cases, sCases,++ -- * Basic singleton definitions+ module Data.Singletons,++ -- * Auxiliary definitions+ SDecide(..), (:~:)(..), Void, Refuted, Decision(..),++ SuppressUnusedWarnings(..)++ ) where++import Control.Arrow ( first )+import Data.Singletons+import Data.Singletons.Decide+import Data.Singletons.TH.Options+import Data.Singletons.TH.Promote+import Data.Singletons.TH.Single+import Data.Singletons.TH.SuppressUnusedWarnings+import Data.Singletons.TH.Util+import Language.Haskell.TH+import Language.Haskell.TH.Desugar++-- | 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.+--+-- Here is a simple example to illustrate where 'cases' can be useful. Suppose+-- you use @singletons-th@ to single this code:+--+-- @+-- $('singletons' [d|+-- foo :: Bool -> ()+-- foo True = ()+-- foo False = ()+-- |])+-- @+--+-- And that you want to write a function of this type:+--+-- @+-- bar :: SBool b -> STuple0 (Foo b)+-- @+--+-- How would you do this? You might be tempted to write the following:+--+-- @+-- bar _ = STuple0+-- @+--+-- However, this won't typecheck, as Foo b won't reduce to @'()@ unless GHC+-- knows @b@ is either 'True' or 'False'. In order to convince GHC of this, you+-- must explicitly match on each of the data constructors of @SBool@:+--+-- @+-- bar :: SBool b -> STuple0 (Foo b)+-- bar b = case b of+-- STrue -> STuple0+-- SFalse -> STuple0+-- @+--+-- This is doable, but it is somewhat tedious. After all, the right-hand side+-- of each case alternative is exactly the same! This only becomes more tedious+-- when you deal with data types with lots of lots of data constructors. For+-- this reason, @singletons-th@ offers the 'cases' function to generate this+-- boilerplate code for you. The following is equivalent to the implementation+-- of @bar@ above:+--+-- @+-- bar :: SBool b -> STuple0 (Foo b)+-- bar b = $(cases ''SBool [| b |] [| STuple0 |])+-- @+cases :: DsMonad q+ => Name -- ^ The head of the type of the scrutinee. (e.g., @''SBool@)+ -> 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 <<cases>> 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@. In other words, @sCases ''Maybe@ is equivalent to+-- @'cases' ''SMaybe@.+sCases :: OptionsMonad q+ => Name -- ^ The head of the type the scrutinee's type is based on.+ -- (Like @''Maybe@ or @''Bool@.)+ -> q Exp -- ^ The scrutinee, in a Template Haskell quote+ -> q Exp -- ^ The body, in a Template Haskell quote+ -> q Exp+sCases tyName expq bodyq = do+ opts <- getOptions+ dinfo <- dsReify tyName+ case dinfo of+ Just (DTyConI (DDataD _ _ _ _ _ ctors _) _) ->+ let ctor_stuff = map (first (singledDataConName opts) . extractNameArgs) ctors in+ expToTH <$> buildCases ctor_stuff expq bodyq+ Just _ ->+ fail $ "Using <<cases>> with something other than a type constructor: "+ ++ (show tyName)+ _ -> fail $ "Cannot find " ++ show tyName++buildCases :: DsMonad m+ => [(Name, Int)]+ -> m Exp -- scrutinee+ -> m Exp -- body+ -> m DExp+buildCases ctor_infos expq bodyq =+ DCaseE <$> (dsExp =<< expq) <*>+ mapM (\con -> DMatch (conToPat con) <$> (dsExp =<< bodyq)) ctor_infos+ where+ conToPat :: (Name, Int) -> DPat+ conToPat (name, num_fields) =+ DConP name [] (replicate num_fields DWildP)
src/Data/Singletons/TH/CustomStar.hs view
@@ -1,158 +1,158 @@-{-# LANGUAGE TemplateHaskellQuotes #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TH.CustomStar --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- This file implements 'singletonStar', which generates a datatype @Rep@ and associated --- singleton from a list of types. The promoted version of @Rep@ is kind @*@ and the --- Haskell types themselves. This is still very experimental, so expect unusual --- results! --- --- See also @Data.Singletons.Base.CustomStar@ from @singletons-base@, a --- variant of this module that also re-exports related definitions from --- @Prelude.Singletons@. --- ----------------------------------------------------------------------------- - -module Data.Singletons.TH.CustomStar ( - singletonStar, - - module Data.Singletons.TH - ) where - -import Language.Haskell.TH -import Data.Singletons.TH -import Data.Singletons.TH.Deriving.Eq -import Data.Singletons.TH.Deriving.Infer -import Data.Singletons.TH.Deriving.Ord -import Data.Singletons.TH.Deriving.Show -import Data.Singletons.TH.Promote -import Data.Singletons.TH.Promote.Monad -import Data.Singletons.TH.Names -import Data.Singletons.TH.Options -import Data.Singletons.TH.Single -import Data.Singletons.TH.Single.Data -import Data.Singletons.TH.Single.Monad -import Data.Singletons.TH.Syntax -import Data.Singletons.TH.Util -import Control.Monad -import Data.Maybe -import Language.Haskell.TH.Desugar - --- | 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-th@ library, the --- constructors become full types in @*@, not just promoted data constructors. --- --- For example, --- --- > $(singletonStar [''Nat, ''Bool, ''Maybe]) --- --- generates the following: --- --- > data Rep = Nat | Bool | Maybe Rep deriving (Eq, Ord, Read, Show) --- --- and its singleton. However, because @Rep@ is promoted to @*@, the singleton --- is perhaps slightly unexpected: --- --- > data SRep (a :: *) where --- > SNat :: Sing Nat --- > SBool :: Sing Bool --- > SMaybe :: Sing a -> Sing (Maybe a) --- > type instance Sing = SRep --- --- The unexpected part is that @Nat@, @Bool@, and @Maybe@ above are the real @Nat@, --- @Bool@, and @Maybe@, not just promoted data constructors. --- --- Please note that this function is /very/ experimental. Use at your own risk. -singletonStar :: OptionsMonad q - => [Name] -- ^ A list of Template Haskell @Name@s for types - -> q [Dec] -singletonStar names = do - kinds <- mapM getKind names - ctors <- zipWithM (mkCtor True) names kinds - let repDecl = DDataD Data [] repName [] (Just (DConT typeKindName)) ctors - [DDerivClause Nothing (map DConT [''Eq, ''Ord, ''Read, ''Show])] - fakeCtors <- zipWithM (mkCtor False) names kinds - let dataDecl = DataDecl Data repName [] fakeCtors - -- Why do we need withLocalDeclarations here? It's because we end up - -- expanding type synonyms when deriving instances for Rep, which requires - -- reifying Rep itself. Since Rep hasn't been spliced in yet, we must put it - -- into the local declarations. - withLocalDeclarations [decToTH repDecl] $ do - -- We opt to infer the constraints for the Eq instance here so that when it's - -- promoted, Rep will be promoted to Type. - dataDeclEqCxt <- inferConstraints (DConT ''Eq) (DConT repName) fakeCtors - let dataDeclEqInst = DerivedDecl (Just dataDeclEqCxt) (DConT repName) repName dataDecl - eqInst <- mkEqInstance Nothing (DConT repName) dataDecl - ordInst <- mkOrdInstance Nothing (DConT repName) dataDecl - showInst <- mkShowInstance Nothing (DConT repName) dataDecl - (pInsts, promDecls) <- promoteM [] $ do _ <- promoteDataDec dataDecl - traverse (promoteInstanceDec mempty mempty) - [eqInst, ordInst, showInst] - singletonDecls <- singDecsM [] $ do decs1 <- singDataD dataDecl - decs2 <- singDerivedEqDecs dataDeclEqInst - decs3 <- traverse singInstD pInsts - return (decs1 ++ decs2 ++ decs3) - return $ decsToTH $ repDecl : - promDecls ++ - singletonDecls - where -- get the kinds of the arguments to the tycon with the given name - getKind :: DsMonad q => Name -> q [DKind] - getKind name = do - info <- reifyWithLocals name - dinfo <- dsInfo info - case dinfo of - DTyConI (DDataD _ (_:_) _ _ _ _ _) _ -> - fail "Cannot make a representation of a constrained data type" - DTyConI (DDataD _ [] _ tvbs mk _ _) _ -> do - all_tvbs <- buildDataDTvbs tvbs mk - return $ map (fromMaybe (DConT typeKindName) . extractTvbKind) all_tvbs - DTyConI (DTySynD _ tvbs _) _ -> - return $ map (fromMaybe (DConT typeKindName) . extractTvbKind) tvbs - DPrimTyConI _ n _ -> - return $ replicate n $ DConT typeKindName - _ -> fail $ "Invalid thing for representation: " ++ (show name) - - -- first parameter is whether this is a real ctor (with a fresh name) - -- or a fake ctor (when the name is actually a Haskell type) - mkCtor :: DsMonad q => Bool -> Name -> [DKind] -> q DCon - mkCtor real name args = do - (types, vars) <- evalForPair $ mapM (kindToType []) args - dataName <- if real then mkDataName (nameBase name) else return name - return $ DCon (map (`DPlainTV` SpecifiedSpec) vars) [] dataName - (DNormalC False (map (\ty -> (noBang, ty)) types)) - (DConT repName) - where - noBang = Bang NoSourceUnpackedness NoSourceStrictness - - -- demote a kind back to a type, accumulating any unbound parameters - kindToType :: DsMonad q => [DTypeArg] -> DKind -> QWithAux [Name] q DType - kindToType _ (DForallT _ _) = fail "Explicit forall encountered in kind" - kindToType _ (DConstrainedT _ _) = fail "Explicit constraint encountered in kind" - kindToType args (DAppT f a) = do - a' <- kindToType [] a - kindToType (DTANormal a' : args) f - kindToType args (DAppKindT f a) = do - a' <- kindToType [] a - kindToType (DTyArg a' : args) f - kindToType args (DSigT t k) = do - t' <- kindToType [] t - k' <- kindToType [] k - return $ DSigT t' k' `applyDType` args - kindToType args (DVarT n) = do - addElement n - return $ DVarT n `applyDType` args - kindToType args (DConT n) = return $ DConT name `applyDType` args - where name | isTypeKindName n = repName - | otherwise = n - kindToType args DArrowT = return $ DArrowT `applyDType` args - kindToType args k@(DLitT {}) = return $ k `applyDType` args - kindToType args DWildCardT = return $ DWildCardT `applyDType` args +{-# LANGUAGE TemplateHaskellQuotes #-}++-----------------------------------------------------------------------------+-- |+-- Module : Data.Singletons.TH.CustomStar+-- Copyright : (C) 2013 Richard Eisenberg+-- License : BSD-style (see LICENSE)+-- Maintainer : Ryan Scott+-- Stability : experimental+-- Portability : non-portable+--+-- This file implements 'singletonStar', which generates a datatype @Rep@ and associated+-- singleton from a list of types. The promoted version of @Rep@ is kind @*@ and the+-- Haskell types themselves. This is still very experimental, so expect unusual+-- results!+--+-- See also @Data.Singletons.Base.CustomStar@ from @singletons-base@, a+-- variant of this module that also re-exports related definitions from+-- @Prelude.Singletons@.+--+----------------------------------------------------------------------------++module Data.Singletons.TH.CustomStar (+ singletonStar,++ module Data.Singletons.TH+ ) where++import Language.Haskell.TH+import Data.Singletons.TH+import Data.Singletons.TH.Deriving.Eq+import Data.Singletons.TH.Deriving.Infer+import Data.Singletons.TH.Deriving.Ord+import Data.Singletons.TH.Deriving.Show+import Data.Singletons.TH.Promote+import Data.Singletons.TH.Promote.Monad+import Data.Singletons.TH.Names+import Data.Singletons.TH.Options+import Data.Singletons.TH.Single+import Data.Singletons.TH.Single.Data+import Data.Singletons.TH.Single.Monad+import Data.Singletons.TH.Syntax+import Data.Singletons.TH.Util+import Control.Monad+import Data.Maybe+import Language.Haskell.TH.Desugar++-- | 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-th@ library, the+-- constructors become full types in @*@, not just promoted data constructors.+--+-- For example,+--+-- > $(singletonStar [''Nat, ''Bool, ''Maybe])+--+-- generates the following:+--+-- > data Rep = Nat | Bool | Maybe Rep deriving (Eq, Ord, Read, Show)+--+-- and its singleton. However, because @Rep@ is promoted to @*@, the singleton+-- is perhaps slightly unexpected:+--+-- > data SRep (a :: *) where+-- > SNat :: Sing Nat+-- > SBool :: Sing Bool+-- > SMaybe :: Sing a -> Sing (Maybe a)+-- > type instance Sing = SRep+--+-- The unexpected part is that @Nat@, @Bool@, and @Maybe@ above are the real @Nat@,+-- @Bool@, and @Maybe@, not just promoted data constructors.+--+-- Please note that this function is /very/ experimental. Use at your own risk.+singletonStar :: OptionsMonad q+ => [Name] -- ^ A list of Template Haskell @Name@s for types+ -> q [Dec]+singletonStar names = do+ kinds <- mapM getKind names+ ctors <- zipWithM (mkCtor True) names kinds+ let repDecl = DDataD Data [] repName [] (Just (DConT typeKindName)) ctors+ [DDerivClause Nothing (map DConT [''Eq, ''Ord, ''Read, ''Show])]+ fakeCtors <- zipWithM (mkCtor False) names kinds+ let dataDecl = DataDecl Data repName [] fakeCtors+ -- Why do we need withLocalDeclarations here? It's because we end up+ -- expanding type synonyms when deriving instances for Rep, which requires+ -- reifying Rep itself. Since Rep hasn't been spliced in yet, we must put it+ -- into the local declarations.+ withLocalDeclarations [decToTH repDecl] $ do+ -- We opt to infer the constraints for the Eq instance here so that when it's+ -- promoted, Rep will be promoted to Type.+ dataDeclEqCxt <- inferConstraints (DConT ''Eq) (DConT repName) fakeCtors+ let dataDeclEqInst = DerivedDecl (Just dataDeclEqCxt) (DConT repName) repName dataDecl+ eqInst <- mkEqInstance Nothing (DConT repName) dataDecl+ ordInst <- mkOrdInstance Nothing (DConT repName) dataDecl+ showInst <- mkShowInstance Nothing (DConT repName) dataDecl+ (pInsts, promDecls) <- promoteM [] $ do _ <- promoteDataDec dataDecl+ traverse (promoteInstanceDec mempty mempty)+ [eqInst, ordInst, showInst]+ singletonDecls <- singDecsM [] $ do decs1 <- singDataD dataDecl+ decs2 <- singDerivedEqDecs dataDeclEqInst+ decs3 <- traverse singInstD pInsts+ return (decs1 ++ decs2 ++ decs3)+ return $ decsToTH $ repDecl :+ promDecls +++ singletonDecls+ where -- get the kinds of the arguments to the tycon with the given name+ getKind :: DsMonad q => Name -> q [DKind]+ getKind name = do+ info <- reifyWithLocals name+ dinfo <- dsInfo info+ case dinfo of+ DTyConI (DDataD _ (_:_) _ _ _ _ _) _ ->+ fail "Cannot make a representation of a constrained data type"+ DTyConI (DDataD _ [] _ tvbs mk _ _) _ -> do+ all_tvbs <- buildDataDTvbs tvbs mk+ return $ map (fromMaybe (DConT typeKindName) . extractTvbKind) all_tvbs+ DTyConI (DTySynD _ tvbs _) _ ->+ return $ map (fromMaybe (DConT typeKindName) . extractTvbKind) tvbs+ DPrimTyConI _ n _ ->+ return $ replicate n $ DConT typeKindName+ _ -> fail $ "Invalid thing for representation: " ++ (show name)++ -- first parameter is whether this is a real ctor (with a fresh name)+ -- or a fake ctor (when the name is actually a Haskell type)+ mkCtor :: DsMonad q => Bool -> Name -> [DKind] -> q DCon+ mkCtor real name args = do+ (types, vars) <- evalForPair $ mapM (kindToType []) args+ dataName <- if real then mkDataName (nameBase name) else return name+ return $ DCon (map (`DPlainTV` SpecifiedSpec) vars) [] dataName+ (DNormalC False (map (\ty -> (noBang, ty)) types))+ (DConT repName)+ where+ noBang = Bang NoSourceUnpackedness NoSourceStrictness++ -- demote a kind back to a type, accumulating any unbound parameters+ kindToType :: DsMonad q => [DTypeArg] -> DKind -> QWithAux [Name] q DType+ kindToType _ (DForallT _ _) = fail "Explicit forall encountered in kind"+ kindToType _ (DConstrainedT _ _) = fail "Explicit constraint encountered in kind"+ kindToType args (DAppT f a) = do+ a' <- kindToType [] a+ kindToType (DTANormal a' : args) f+ kindToType args (DAppKindT f a) = do+ a' <- kindToType [] a+ kindToType (DTyArg a' : args) f+ kindToType args (DSigT t k) = do+ t' <- kindToType [] t+ k' <- kindToType [] k+ return $ DSigT t' k' `applyDType` args+ kindToType args (DVarT n) = do+ addElement n+ return $ DVarT n `applyDType` args+ kindToType args (DConT n) = return $ DConT name `applyDType` args+ where name | isTypeKindName n = repName+ | otherwise = n+ kindToType args DArrowT = return $ DArrowT `applyDType` args+ kindToType args k@(DLitT {}) = return $ k `applyDType` args+ kindToType args DWildCardT = return $ DWildCardT `applyDType` args
src/Data/Singletons/TH/Deriving/Bounded.hs view
@@ -1,59 +1,67 @@------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TH.Deriving.Bounded --- Copyright : (C) 2015 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Implements deriving of Bounded instances --- ----------------------------------------------------------------------------- - -module Data.Singletons.TH.Deriving.Bounded where - -import Language.Haskell.TH.Ppr -import Language.Haskell.TH.Desugar -import Data.Singletons.TH.Deriving.Infer -import Data.Singletons.TH.Deriving.Util -import Data.Singletons.TH.Names -import Data.Singletons.TH.Syntax -import Data.Singletons.TH.Util -import Control.Monad - --- monadic only for failure and parallelism with other functions --- that make instances -mkBoundedInstance :: DsMonad q => DerivDesc q -mkBoundedInstance mb_ctxt ty (DataDecl _ _ _ cons) = do - -- We can derive instance of Bounded if datatype is an enumeration (all - -- constructors must be nullary) or has only one constructor. See Section 11 - -- of Haskell 2010 Language Report. - -- Note that order of conditions below is important. - when (null cons - || (any (\(DCon _ _ _ f _) -> not . null . tysOfConFields $ f) cons - && (not . null . tail $ cons))) $ - fail ("Can't derive Bounded instance for " - ++ pprint (typeToTH ty) ++ ".") - -- at this point we know that either we have a datatype that has only one - -- constructor or a datatype where each constructor is nullary - let (DCon _ _ minName fields _) = head cons - (DCon _ _ maxName _ _) = last cons - fieldsCount = length $ tysOfConFields fields - (minRHS, maxRHS) = case fieldsCount of - 0 -> (DConE minName, DConE maxName) - _ -> - let minEqnRHS = foldExp (DConE minName) - (replicate fieldsCount (DVarE minBoundName)) - maxEqnRHS = foldExp (DConE maxName) - (replicate fieldsCount (DVarE maxBoundName)) - in (minEqnRHS, maxEqnRHS) - - mk_rhs rhs = UFunction [DClause [] rhs] - constraints <- inferConstraintsDef mb_ctxt (DConT boundedName) ty cons - return $ InstDecl { id_cxt = constraints - , id_name = boundedName - , id_arg_tys = [ty] - , id_sigs = mempty - , id_meths = [ (minBoundName, mk_rhs minRHS) - , (maxBoundName, mk_rhs maxRHS) ] } +-----------------------------------------------------------------------------+-- |+-- Module : Data.Singletons.TH.Deriving.Bounded+-- Copyright : (C) 2015 Richard Eisenberg+-- License : BSD-style (see LICENSE)+-- Maintainer : Ryan Scott+-- Stability : experimental+-- Portability : non-portable+--+-- Implements deriving of Bounded instances+--+----------------------------------------------------------------------------++module Data.Singletons.TH.Deriving.Bounded where++import Language.Haskell.TH.Ppr+import Language.Haskell.TH.Desugar+import Data.Singletons.TH.Deriving.Infer+import Data.Singletons.TH.Deriving.Util+import Data.Singletons.TH.Names+import Data.Singletons.TH.Syntax+import Data.Singletons.TH.Util+import Control.Monad++-- monadic only for failure and parallelism with other functions+-- that make instances+mkBoundedInstance :: DsMonad q => DerivDesc q+mkBoundedInstance mb_ctxt ty (DataDecl _ _ _ cons) = do+ -- We can derive instance of Bounded if datatype is an enumeration (all+ -- constructors must be nullary) or has only one constructor. See Section 11+ -- of Haskell 2010 Language Report.+ -- Note that order of conditions below is important.+ let illegal_bounded_inst =+ case cons of+ [] -> True+ _:cons' ->+ any (\(DCon _ _ _ f _) -> not . null . tysOfConFields $ f) cons+ && not (null cons')+ when illegal_bounded_inst $+ 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 internal_err = fail "Internal error (mkBoundedInstance): non-empty list of constructors"+ DCon _ _ minName fields _ <-+ case cons of+ (c:_) -> pure c+ [] -> internal_err+ let (_, DCon _ _ maxName _ _) = snocView cons+ fieldsCount = length $ tysOfConFields fields+ (minRHS, maxRHS) = case fieldsCount of+ 0 -> (DConE minName, DConE maxName)+ _ ->+ let minEqnRHS = foldExp (DConE minName)+ (replicate fieldsCount (DVarE minBoundName))+ maxEqnRHS = foldExp (DConE maxName)+ (replicate fieldsCount (DVarE maxBoundName))+ in (minEqnRHS, maxEqnRHS)++ mk_rhs rhs = UFunction [DClause [] rhs]+ constraints <- inferConstraintsDef mb_ctxt (DConT boundedName) ty cons+ return $ InstDecl { id_cxt = constraints+ , id_name = boundedName+ , id_arg_tys = [ty]+ , id_sigs = mempty+ , id_meths = [ (minBoundName, mk_rhs minRHS)+ , (maxBoundName, mk_rhs maxRHS) ] }
src/Data/Singletons/TH/Deriving/Enum.hs view
@@ -1,60 +1,60 @@------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TH.Deriving.Enum --- Copyright : (C) 2015 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Implements deriving of Enum instances --- ----------------------------------------------------------------------------- - -module Data.Singletons.TH.Deriving.Enum ( mkEnumInstance ) where - -import Language.Haskell.TH.Syntax -import Language.Haskell.TH.Ppr -import Language.Haskell.TH.Desugar -import Data.Singletons.TH.Deriving.Util -import Data.Singletons.TH.Names -import Data.Singletons.TH.Syntax -import Data.Singletons.TH.Util -import Control.Monad -import Data.Maybe - --- monadic for failure only -mkEnumInstance :: DsMonad q => DerivDesc q -mkEnumInstance mb_ctxt ty (DataDecl _ _ _ cons) = do - -- GHC only allows deriving Enum instances for enumeration types (i.e., those - -- data types whose constructors all lack fields). We perform the same - -- validity check here. - -- - -- GHC actually goes further than we do. GHC will give a specific error - -- message if you attempt to derive an instance for a "non-vanilla" data - -- type—that is, a data type that uses features not expressible with - -- Haskell98 syntax, such as existential quantification. Checking whether - -- a type variable is existentially quantified is difficult in Template - -- Haskell, so we omit this check. - when (null cons || - any (\(DCon _ _ _ f _) -> not (null $ tysOfConFields f)) cons) $ - fail ("Can't derive Enum instance for " ++ pprint (typeToTH ty) ++ ".") - - n <- qNewName "n" - let to_enum = UFunction [DClause [DVarP n] (to_enum_rhs cons [0..])] - to_enum_rhs [] _ = DVarE errorName `DAppE` DLitE (StringL "toEnum: bad argument") - to_enum_rhs (DCon _ _ name _ _ : rest) (num:nums) = - DCaseE (DVarE equalsName `DAppE` DVarE n `DAppE` DLitE (IntegerL num)) - [ DMatch (DConP trueName [] []) (DConE name) - , DMatch (DConP falseName [] []) (to_enum_rhs rest nums) ] - to_enum_rhs _ _ = error "Internal error: exhausted infinite list in to_enum_rhs" - - from_enum = UFunction (zipWith (\i con -> DClause [DConP (extractName con) [] []] - (DLitE (IntegerL i))) - [0..] cons) - return (InstDecl { id_cxt = fromMaybe [] mb_ctxt - , id_name = enumName - , id_arg_tys = [ty] - , id_sigs = mempty - , id_meths = [ (toEnumName, to_enum) - , (fromEnumName, from_enum) ] }) +-----------------------------------------------------------------------------+-- |+-- Module : Data.Singletons.TH.Deriving.Enum+-- Copyright : (C) 2015 Richard Eisenberg+-- License : BSD-style (see LICENSE)+-- Maintainer : Ryan Scott+-- Stability : experimental+-- Portability : non-portable+--+-- Implements deriving of Enum instances+--+----------------------------------------------------------------------------++module Data.Singletons.TH.Deriving.Enum ( mkEnumInstance ) where++import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Ppr+import Language.Haskell.TH.Desugar+import Data.Singletons.TH.Deriving.Util+import Data.Singletons.TH.Names+import Data.Singletons.TH.Syntax+import Data.Singletons.TH.Util+import Control.Monad+import Data.Maybe++-- monadic for failure only+mkEnumInstance :: DsMonad q => DerivDesc q+mkEnumInstance mb_ctxt ty (DataDecl _ _ _ cons) = do+ -- GHC only allows deriving Enum instances for enumeration types (i.e., those+ -- data types whose constructors all lack fields). We perform the same+ -- validity check here.+ --+ -- GHC actually goes further than we do. GHC will give a specific error+ -- message if you attempt to derive an instance for a "non-vanilla" data+ -- type—that is, a data type that uses features not expressible with+ -- Haskell98 syntax, such as existential quantification. Checking whether+ -- a type variable is existentially quantified is difficult in Template+ -- Haskell, so we omit this check.+ when (null cons ||+ any (\(DCon _ _ _ f _) -> not (null $ tysOfConFields f)) cons) $+ fail ("Can't derive Enum instance for " ++ pprint (typeToTH ty) ++ ".")++ n <- qNewName "n"+ let to_enum = UFunction [DClause [DVarP n] (to_enum_rhs cons [0..])]+ to_enum_rhs [] _ = DVarE errorName `DAppE` DLitE (StringL "toEnum: bad argument")+ to_enum_rhs (DCon _ _ name _ _ : rest) (num:nums) =+ DCaseE (DVarE equalsName `DAppE` DVarE n `DAppE` DLitE (IntegerL num))+ [ DMatch (DConP trueName [] []) (DConE name)+ , DMatch (DConP falseName [] []) (to_enum_rhs rest nums) ]+ to_enum_rhs _ _ = error "Internal error: exhausted infinite list in to_enum_rhs"++ from_enum = UFunction (zipWith (\i con -> DClause [DConP (extractName con) [] []]+ (DLitE (IntegerL i)))+ [0..] cons)+ return (InstDecl { id_cxt = fromMaybe [] mb_ctxt+ , id_name = enumName+ , id_arg_tys = [ty]+ , id_sigs = mempty+ , id_meths = [ (toEnumName, to_enum)+ , (fromEnumName, from_enum) ] })
src/Data/Singletons/TH/Deriving/Eq.hs view
@@ -1,62 +1,62 @@------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TH.Deriving.Eq --- Copyright : (C) 2020 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Implements deriving of Eq instances --- ----------------------------------------------------------------------------- -module Data.Singletons.TH.Deriving.Eq (mkEqInstance) where - -import Control.Monad -import Data.Singletons.TH.Deriving.Infer -import Data.Singletons.TH.Deriving.Util -import Data.Singletons.TH.Names -import Data.Singletons.TH.Syntax -import Data.Singletons.TH.Util -import Language.Haskell.TH.Desugar -import Language.Haskell.TH.Syntax - -mkEqInstance :: DsMonad q => DerivDesc q -mkEqInstance mb_ctxt ty (DataDecl _ _ _ cons) = do - let con_pairs = [ (c1, c2) | c1 <- cons, c2 <- cons ] - constraints <- inferConstraintsDef mb_ctxt (DConT eqName) ty cons - clauses <- if null cons - then pure [DClause [DWildP, DWildP] (DConE trueName)] - else traverse mkEqClause con_pairs - pure (InstDecl { id_cxt = constraints - , id_name = eqName - , id_arg_tys = [ty] - , id_sigs = mempty - , id_meths = [(equalsName, UFunction clauses)] }) - -mkEqClause :: Quasi q => (DCon, DCon) -> q DClause -mkEqClause (c1, c2) - | lname == rname = do - lnames <- replicateM lNumArgs (newUniqueName "a") - rnames <- replicateM lNumArgs (newUniqueName "b") - let lpats = map DVarP lnames - rpats = map DVarP rnames - lvars = map DVarE lnames - rvars = map DVarE rnames - pure $ DClause - [DConP lname [] lpats, DConP rname [] rpats] - (andExp (zipWith (\l r -> foldExp (DVarE equalsName) [l, r]) - lvars rvars)) - | otherwise = - pure $ DClause - [DConP lname [] (replicate lNumArgs DWildP), - DConP rname [] (replicate rNumArgs DWildP)] - (DConE falseName) - where - andExp :: [DExp] -> DExp - andExp [] = DConE trueName - andExp [one] = one - andExp (h:t) = DVarE andName `DAppE` h `DAppE` andExp t - - (lname, lNumArgs) = extractNameArgs c1 - (rname, rNumArgs) = extractNameArgs c2 +-----------------------------------------------------------------------------+-- |+-- Module : Data.Singletons.TH.Deriving.Eq+-- Copyright : (C) 2020 Ryan Scott+-- License : BSD-style (see LICENSE)+-- Maintainer : Ryan Scott+-- Stability : experimental+-- Portability : non-portable+--+-- Implements deriving of Eq instances+--+----------------------------------------------------------------------------+module Data.Singletons.TH.Deriving.Eq (mkEqInstance) where++import Control.Monad+import Data.Singletons.TH.Deriving.Infer+import Data.Singletons.TH.Deriving.Util+import Data.Singletons.TH.Names+import Data.Singletons.TH.Syntax+import Data.Singletons.TH.Util+import Language.Haskell.TH.Desugar+import Language.Haskell.TH.Syntax++mkEqInstance :: DsMonad q => DerivDesc q+mkEqInstance mb_ctxt ty (DataDecl _ _ _ cons) = do+ let con_pairs = [ (c1, c2) | c1 <- cons, c2 <- cons ]+ constraints <- inferConstraintsDef mb_ctxt (DConT eqName) ty cons+ clauses <- if null cons+ then pure [DClause [DWildP, DWildP] (DConE trueName)]+ else traverse mkEqClause con_pairs+ pure (InstDecl { id_cxt = constraints+ , id_name = eqName+ , id_arg_tys = [ty]+ , id_sigs = mempty+ , id_meths = [(equalsName, UFunction clauses)] })++mkEqClause :: Quasi q => (DCon, DCon) -> q DClause+mkEqClause (c1, c2)+ | lname == rname = do+ lnames <- replicateM lNumArgs (newUniqueName "a")+ rnames <- replicateM lNumArgs (newUniqueName "b")+ let lpats = map DVarP lnames+ rpats = map DVarP rnames+ lvars = map DVarE lnames+ rvars = map DVarE rnames+ pure $ DClause+ [DConP lname [] lpats, DConP rname [] rpats]+ (andExp (zipWith (\l r -> foldExp (DVarE equalsName) [l, r])+ lvars rvars))+ | otherwise =+ pure $ DClause+ [DConP lname [] (replicate lNumArgs DWildP),+ DConP rname [] (replicate rNumArgs DWildP)]+ (DConE falseName)+ where+ andExp :: [DExp] -> DExp+ andExp [] = DConE trueName+ andExp [one] = one+ andExp (h:t) = DVarE andName `DAppE` h `DAppE` andExp t++ (lname, lNumArgs) = extractNameArgs c1+ (rname, rNumArgs) = extractNameArgs c2
src/Data/Singletons/TH/Deriving/Foldable.hs view
@@ -1,97 +1,97 @@------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TH.Deriving.Foldable --- Copyright : (C) 2018 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Implements deriving of Foldable instances --- ----------------------------------------------------------------------------- - -module Data.Singletons.TH.Deriving.Foldable where - -import Data.Singletons.TH.Deriving.Infer -import Data.Singletons.TH.Deriving.Util -import Data.Singletons.TH.Names -import Data.Singletons.TH.Syntax -import Language.Haskell.TH.Desugar - -mkFoldableInstance :: forall q. DsMonad q => DerivDesc q -mkFoldableInstance mb_ctxt ty dd@(DataDecl _ _ _ cons) = do - functorLikeValidityChecks False dd - f <- newUniqueName "_f" - z <- newUniqueName "_z" - let ft_foldMap :: FFoldType (q DExp) - ft_foldMap = FT { ft_triv = mkSimpleLam $ \_ -> pure $ DVarE memptyName - -- foldMap f = \x -> mempty - , ft_var = pure $ DVarE f - -- foldMap f = f - , ft_ty_app = \_ g -> DAppE (DVarE foldMapName) <$> g - -- foldMap f = foldMap g - , ft_forall = \_ g -> g - , ft_bad_app = error "in other argument in ft_foldMap" - } - - ft_foldr :: FFoldType (q DExp) - ft_foldr = FT { ft_triv = mkSimpleLam2 $ \_ z' -> pure z' - -- foldr f = \x z -> z - , ft_var = pure $ DVarE f - -- foldr f = f - , ft_ty_app = \_ g -> do - gg <- g - mkSimpleLam2 $ \x z' -> pure $ - DVarE foldrName `DAppE` gg `DAppE` z' `DAppE` x - -- foldr f = (\x z -> foldr g z x) - , ft_forall = \_ g -> g - , ft_bad_app = error "in other argument in ft_foldr" - } - - clause_for_foldMap :: [DPat] -> DCon -> [DExp] -> q DClause - clause_for_foldMap = mkSimpleConClause $ \_ -> mkFoldMap - where - -- mappend v1 (mappend v2 ..) - mkFoldMap :: [DExp] -> DExp - mkFoldMap [] = DVarE memptyName - mkFoldMap xs = foldr1 (\x y -> DVarE mappendName `DAppE` x `DAppE` y) xs - - clause_for_foldr :: [DPat] -> DCon -> [DExp] -> q DClause - clause_for_foldr = mkSimpleConClause $ \_ -> mkFoldr - where - -- g1 v1 (g2 v2 (.. z)) - mkFoldr :: [DExp] -> DExp - mkFoldr = foldr DAppE (DVarE z) - - mk_foldMap_clause :: DCon -> q DClause - mk_foldMap_clause con = do - parts <- foldDataConArgs ft_foldMap con - clause_for_foldMap [DVarP f] con =<< sequence parts - - mk_foldr_clause :: DCon -> q DClause - mk_foldr_clause con = do - parts <- foldDataConArgs ft_foldr con - clause_for_foldr [DVarP f, DVarP z] con =<< sequence parts - - mk_foldMap :: q [DClause] - mk_foldMap = - case cons of - [] -> pure [DClause [DWildP, DWildP] (DVarE memptyName)] - _ -> traverse mk_foldMap_clause cons - - mk_foldr :: q [DClause] - mk_foldr = traverse mk_foldr_clause cons - - foldMap_clauses <- mk_foldMap - foldr_clauses <- mk_foldr - let meths = (foldMapName, UFunction foldMap_clauses) - : case cons of - [] -> [] - _ -> [(foldrName, UFunction foldr_clauses)] - constraints <- inferConstraintsDef mb_ctxt (DConT foldableName) ty cons - return $ InstDecl { id_cxt = constraints - , id_name = foldableName - , id_arg_tys = [ty] - , id_sigs = mempty - , id_meths = meths } +-----------------------------------------------------------------------------+-- |+-- Module : Data.Singletons.TH.Deriving.Foldable+-- Copyright : (C) 2018 Ryan Scott+-- License : BSD-style (see LICENSE)+-- Maintainer : Ryan Scott+-- Stability : experimental+-- Portability : non-portable+--+-- Implements deriving of Foldable instances+--+----------------------------------------------------------------------------++module Data.Singletons.TH.Deriving.Foldable where++import Data.Singletons.TH.Deriving.Infer+import Data.Singletons.TH.Deriving.Util+import Data.Singletons.TH.Names+import Data.Singletons.TH.Syntax+import Language.Haskell.TH.Desugar++mkFoldableInstance :: forall q. DsMonad q => DerivDesc q+mkFoldableInstance mb_ctxt ty dd@(DataDecl _ _ _ cons) = do+ functorLikeValidityChecks False dd+ f <- newUniqueName "_f"+ z <- newUniqueName "_z"+ let ft_foldMap :: FFoldType (q DExp)+ ft_foldMap = FT { ft_triv = mkSimpleLam $ \_ -> pure $ DVarE memptyName+ -- foldMap f = \x -> mempty+ , ft_var = pure $ DVarE f+ -- foldMap f = f+ , ft_ty_app = \_ g -> DAppE (DVarE foldMapName) <$> g+ -- foldMap f = foldMap g+ , ft_forall = \_ g -> g+ , ft_bad_app = error "in other argument in ft_foldMap"+ }++ ft_foldr :: FFoldType (q DExp)+ ft_foldr = FT { ft_triv = mkSimpleLam2 $ \_ z' -> pure z'+ -- foldr f = \x z -> z+ , ft_var = pure $ DVarE f+ -- foldr f = f+ , ft_ty_app = \_ g -> do+ gg <- g+ mkSimpleLam2 $ \x z' -> pure $+ DVarE foldrName `DAppE` gg `DAppE` z' `DAppE` x+ -- foldr f = (\x z -> foldr g z x)+ , ft_forall = \_ g -> g+ , ft_bad_app = error "in other argument in ft_foldr"+ }++ clause_for_foldMap :: [DPat] -> DCon -> [DExp] -> q DClause+ clause_for_foldMap = mkSimpleConClause $ \_ -> mkFoldMap+ where+ -- mappend v1 (mappend v2 ..)+ mkFoldMap :: [DExp] -> DExp+ mkFoldMap [] = DVarE memptyName+ mkFoldMap xs = foldr1 (\x y -> DVarE mappendName `DAppE` x `DAppE` y) xs++ clause_for_foldr :: [DPat] -> DCon -> [DExp] -> q DClause+ clause_for_foldr = mkSimpleConClause $ \_ -> mkFoldr+ where+ -- g1 v1 (g2 v2 (.. z))+ mkFoldr :: [DExp] -> DExp+ mkFoldr = foldr DAppE (DVarE z)++ mk_foldMap_clause :: DCon -> q DClause+ mk_foldMap_clause con = do+ parts <- foldDataConArgs ft_foldMap con+ clause_for_foldMap [DVarP f] con =<< sequence parts++ mk_foldr_clause :: DCon -> q DClause+ mk_foldr_clause con = do+ parts <- foldDataConArgs ft_foldr con+ clause_for_foldr [DVarP f, DVarP z] con =<< sequence parts++ mk_foldMap :: q [DClause]+ mk_foldMap =+ case cons of+ [] -> pure [DClause [DWildP, DWildP] (DVarE memptyName)]+ _ -> traverse mk_foldMap_clause cons++ mk_foldr :: q [DClause]+ mk_foldr = traverse mk_foldr_clause cons++ foldMap_clauses <- mk_foldMap+ foldr_clauses <- mk_foldr+ let meths = (foldMapName, UFunction foldMap_clauses)+ : case cons of+ [] -> []+ _ -> [(foldrName, UFunction foldr_clauses)]+ constraints <- inferConstraintsDef mb_ctxt (DConT foldableName) ty cons+ return $ InstDecl { id_cxt = constraints+ , id_name = foldableName+ , id_arg_tys = [ty]+ , id_sigs = mempty+ , id_meths = meths }
src/Data/Singletons/TH/Deriving/Functor.hs view
@@ -1,93 +1,93 @@------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TH.Deriving.Functor --- Copyright : (C) 2018 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Implements deriving of Functor instances --- ----------------------------------------------------------------------------- - -module Data.Singletons.TH.Deriving.Functor where - -import Data.Singletons.TH.Deriving.Infer -import Data.Singletons.TH.Deriving.Util -import Data.Singletons.TH.Names -import Data.Singletons.TH.Syntax -import Data.Singletons.TH.Util -import Language.Haskell.TH.Desugar - -mkFunctorInstance :: forall q. DsMonad q => DerivDesc q -mkFunctorInstance mb_ctxt ty dd@(DataDecl _ _ _ cons) = do - functorLikeValidityChecks False dd - f <- newUniqueName "_f" - z <- newUniqueName "_z" - let ft_fmap :: FFoldType (q DExp) - ft_fmap = FT { ft_triv = mkSimpleLam pure - -- fmap f = \x -> x - , ft_var = pure $ DVarE f - -- fmap f = f - , ft_ty_app = \_ g -> DAppE (DVarE fmapName) <$> g - -- fmap f = fmap g - , ft_forall = \_ g -> g - , ft_bad_app = error "in other argument in ft_fmap" - } - - ft_replace :: FFoldType (q Replacer) - ft_replace = FT { ft_triv = fmap Nested $ mkSimpleLam pure - -- (p <$) = \x -> x - , ft_var = fmap Immediate $ mkSimpleLam $ \_ -> pure $ DVarE z - -- (p <$) = const p - , ft_ty_app = \_ gm -> do - g <- gm - case g of - Nested g' -> pure . Nested $ DVarE fmapName `DAppE` g' - Immediate _ -> pure . Nested $ DVarE replaceName `DAppE` DVarE z - -- (p <$) = fmap (p <$) - , ft_forall = \_ g -> g - , ft_bad_app = error "in other argument in ft_replace" - } - - -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ... - clause_for_con :: [DPat] -> DCon -> [DExp] -> q DClause - clause_for_con = mkSimpleConClause $ \con_name -> - foldExp (DConE con_name) -- Con x1 x2 ... - - mk_fmap_clause :: DCon -> q DClause - mk_fmap_clause con = do - parts <- foldDataConArgs ft_fmap con - clause_for_con [DVarP f] con =<< sequence parts - - mk_replace_clause :: DCon -> q DClause - mk_replace_clause con = do - parts <- foldDataConArgs ft_replace con - clause_for_con [DVarP z] con =<< traverse (fmap replace) parts - - mk_fmap :: q [DClause] - mk_fmap = case cons of - [] -> do v <- newUniqueName "v" - pure [DClause [DWildP, DVarP v] (DCaseE (DVarE v) [])] - _ -> traverse mk_fmap_clause cons - - mk_replace :: q [DClause] - mk_replace = case cons of - [] -> do v <- newUniqueName "v" - pure [DClause [DWildP, DVarP v] (DCaseE (DVarE v) [])] - _ -> traverse mk_replace_clause cons - - fmap_clauses <- mk_fmap - replace_clauses <- mk_replace - constraints <- inferConstraintsDef mb_ctxt (DConT functorName) ty cons - return $ InstDecl { id_cxt = constraints - , id_name = functorName - , id_arg_tys = [ty] - , id_sigs = mempty - , id_meths = [ (fmapName, UFunction fmap_clauses) - , (replaceName, UFunction replace_clauses) - ] } - -data Replacer = Immediate { replace :: DExp } - | Nested { replace :: DExp } +-----------------------------------------------------------------------------+-- |+-- Module : Data.Singletons.TH.Deriving.Functor+-- Copyright : (C) 2018 Ryan Scott+-- License : BSD-style (see LICENSE)+-- Maintainer : Ryan Scott+-- Stability : experimental+-- Portability : non-portable+--+-- Implements deriving of Functor instances+--+----------------------------------------------------------------------------++module Data.Singletons.TH.Deriving.Functor where++import Data.Singletons.TH.Deriving.Infer+import Data.Singletons.TH.Deriving.Util+import Data.Singletons.TH.Names+import Data.Singletons.TH.Syntax+import Data.Singletons.TH.Util+import Language.Haskell.TH.Desugar++mkFunctorInstance :: forall q. DsMonad q => DerivDesc q+mkFunctorInstance mb_ctxt ty dd@(DataDecl _ _ _ cons) = do+ functorLikeValidityChecks False dd+ f <- newUniqueName "_f"+ z <- newUniqueName "_z"+ let ft_fmap :: FFoldType (q DExp)+ ft_fmap = FT { ft_triv = mkSimpleLam pure+ -- fmap f = \x -> x+ , ft_var = pure $ DVarE f+ -- fmap f = f+ , ft_ty_app = \_ g -> DAppE (DVarE fmapName) <$> g+ -- fmap f = fmap g+ , ft_forall = \_ g -> g+ , ft_bad_app = error "in other argument in ft_fmap"+ }++ ft_replace :: FFoldType (q Replacer)+ ft_replace = FT { ft_triv = fmap Nested $ mkSimpleLam pure+ -- (p <$) = \x -> x+ , ft_var = fmap Immediate $ mkSimpleLam $ \_ -> pure $ DVarE z+ -- (p <$) = const p+ , ft_ty_app = \_ gm -> do+ g <- gm+ case g of+ Nested g' -> pure . Nested $ DVarE fmapName `DAppE` g'+ Immediate _ -> pure . Nested $ DVarE replaceName `DAppE` DVarE z+ -- (p <$) = fmap (p <$)+ , ft_forall = \_ g -> g+ , ft_bad_app = error "in other argument in ft_replace"+ }++ -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...+ clause_for_con :: [DPat] -> DCon -> [DExp] -> q DClause+ clause_for_con = mkSimpleConClause $ \con_name ->+ foldExp (DConE con_name) -- Con x1 x2 ...++ mk_fmap_clause :: DCon -> q DClause+ mk_fmap_clause con = do+ parts <- foldDataConArgs ft_fmap con+ clause_for_con [DVarP f] con =<< sequence parts++ mk_replace_clause :: DCon -> q DClause+ mk_replace_clause con = do+ parts <- foldDataConArgs ft_replace con+ clause_for_con [DVarP z] con =<< traverse (fmap replace) parts++ mk_fmap :: q [DClause]+ mk_fmap = case cons of+ [] -> do v <- newUniqueName "v"+ pure [DClause [DWildP, DVarP v] (DCaseE (DVarE v) [])]+ _ -> traverse mk_fmap_clause cons++ mk_replace :: q [DClause]+ mk_replace = case cons of+ [] -> do v <- newUniqueName "v"+ pure [DClause [DWildP, DVarP v] (DCaseE (DVarE v) [])]+ _ -> traverse mk_replace_clause cons++ fmap_clauses <- mk_fmap+ replace_clauses <- mk_replace+ constraints <- inferConstraintsDef mb_ctxt (DConT functorName) ty cons+ return $ InstDecl { id_cxt = constraints+ , id_name = functorName+ , id_arg_tys = [ty]+ , id_sigs = mempty+ , id_meths = [ (fmapName, UFunction fmap_clauses)+ , (replaceName, UFunction replace_clauses)+ ] }++data Replacer = Immediate { replace :: DExp }+ | Nested { replace :: DExp }
src/Data/Singletons/TH/Deriving/Infer.hs view
@@ -1,160 +1,160 @@------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TH.Deriving.Infer --- Copyright : (C) 2015 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Infers constraints for a `deriving` class --- ----------------------------------------------------------------------------- - -module Data.Singletons.TH.Deriving.Infer ( inferConstraints, inferConstraintsDef ) where - -import Language.Haskell.TH.Desugar -import Language.Haskell.TH.Syntax -import Data.Singletons.TH.Deriving.Util -import Data.Singletons.TH.Util -import Data.List (nub) -import Data.Maybe (fromJust) - --- @inferConstraints cls inst_ty cons@ infers the instance context for a --- derived type class instance of @cls@ for @inst_ty@, using the constructors --- @cons@. For instance, if @cls@ is 'Ord' and @inst_ty@ is @Either a b@, then --- that means we are attempting to derive the instance: --- --- @ --- instance ??? => Ord (Either a b) --- @ --- --- The role of 'inferConstraints' is to determine what @???@ should be in that --- derived instance. To accomplish this, the list of @cons@ (in this example, --- @cons@ would be @[Left a, Right b]@) is used as follows: --- --- 1. For each @con@ in @cons@, find the types of each of its fields --- (call these @field_tys@), perhaps after renaming the type variables of --- @field_tys@. --- 2. For each @field_ty@ in @field_tys@, apply @cls@ to @field_ty@ to obtain --- a constraint. --- 3. The final instance context is the set of all such constraints obtained --- in step 2. --- --- To complete the running example, this algorithm would produce the instance --- context @(Ord a, Ord b)@, since @Left a@ has one field of type @a@, and --- @Right b@ has one field of type @b@. --- --- This algorithm is a crude approximation of what GHC actually does when --- deriving instances. It is crude in the sense that one can end up with --- redundant constraints. For instance, if the data type for which an 'Ord' --- instance is being derived is @data Foo = MkFoo Bool Foo@, then the --- inferred constraints would be @(Ord Bool, Ord Foo)@. Technically, neither --- constraint is necessary, but it is not simple in general to eliminate --- redundant constraints like these, so we do not attept to do so. (This is --- one reason why @singletons-th@ requires the use of the @UndecidableInstances@ --- GHC extension.) --- --- Observant readers will notice that the phrase \"perhaps afer renaming the --- type variables\" was casually dropped in step 1 of the above algorithm. --- For more information on what this means, refer to the documentation for --- infer_ct below. -inferConstraints :: forall q. DsMonad q => DPred -> DType -> [DCon] -> q DCxt -inferConstraints pr inst_ty = fmap nub . concatMapM infer_ct - where - -- A thorny situation arises when attempting to infer an instance context - -- for a GADT. Consider the following example: - -- - -- newtype Bar a where - -- MkBar :: b -> Bar b - -- deriving Show - -- - -- If we blindly apply 'Show' to the field type of @MkBar@, we will end up - -- with a derived instance of: - -- - -- instance Show b => Show (Bar a) - -- - -- This is completely wrong, since the type variable @b@ is never used in - -- the instance head! This reveals that we need a slightly more nuanced - -- strategy for gathering constraints for GADT constructors. To account - -- for this, when gathering @field_tys@ (from step 1 in the above algorithm) - -- we perform the following extra steps: - -- - -- 1(a). Take the return type of @con@ and match it with @inst_ty@ (e.g., - -- match @Bar b@ with @Bar a@). Doing so will produce a substitution - -- that maps the universally quantified type variables in the GADT - -- (i.e., @b@) to the corresponding type variables in the data type - -- constructor (i.e., @a@). - -- 1(b). Use the resulting substitution to rename the universally - -- quantified type variables of @con@ as necessary. - -- - -- After this renaming, the algorithm will produce an instance context of - -- @Show a@ (since @b@ was renamed to @a@), as expected. - infer_ct :: DCon -> q DCxt - infer_ct (DCon _ _ _ fields res_ty) = do - let field_tys = tysOfConFields fields - -- We need to match the constructor's result type with the type given - -- in the generated instance. But if we have: - -- - -- data Foo a where - -- MkFoo :: a -> Foo a - -- deriving Functor - -- - -- Then the generated instance will be: - -- - -- instance Functor Foo where ... - -- - -- Which means that if we're not careful, we might try to match the - -- types (Foo a) and (Foo), which will fail. - -- - -- To avoid this, we employ a grimy hack where we pad the instance - -- type with an extra (dummy) type variable. It doesn't matter what - -- we name it, since none of the inferred constraints will mention - -- it anyway. - eta_expanded_inst_ty - | is_functor_like = inst_ty `DAppT` DVarT (mkName "dummy") - | otherwise = inst_ty - res_ty' <- expandType res_ty - inst_ty' <- expandType eta_expanded_inst_ty - field_tys' <- case matchTy YesIgnore res_ty' inst_ty' of - Nothing -> fail $ showString "Unable to match type " - . showsPrec 11 res_ty' - . showString " with " - . showsPrec 11 inst_ty' - $ "" - Just subst -> traverse (substTy subst) field_tys - if is_functor_like - then mk_functor_like_constraints field_tys' res_ty' - else pure $ map (pr `DAppT`) field_tys' - - -- If we derive a Functor-like class, e.g., - -- - -- data Foo f g h a = MkFoo (f a) (g (h a)) deriving Functor - -- - -- Then we infer constraints by sticking Functor on the subtypes of kind - -- (Type -> Type). In the example above, that would give us - -- (Functor f, Functor g, Functor h). - mk_functor_like_constraints :: [DType] -> DType -> q DCxt - mk_functor_like_constraints fields res_ty = do - -- This function is partial. But that's OK, because - -- functorLikeValidityChecks ensures that this is total by the time - -- we invoke this. - let (_, res_ty_args) = unfoldDType res_ty - (_, last_res_ty_arg) = snocView $ filterDTANormals res_ty_args - last_tv = fromJust $ getDVarTName_maybe last_res_ty_arg - deep_subtypes <- concatMapM (deepSubtypesContaining last_tv) fields - pure $ map (pr `DAppT`) deep_subtypes - - is_functor_like :: Bool - is_functor_like - | (DConT pr_class_name, _) <- unfoldDType pr - = isFunctorLikeClassName pr_class_name - | otherwise - = False - --- For @inferConstraintsDef mb_cxt@, if @mb_cxt@ is 'Just' a context, then it will --- simply return that context. Otherwise, if @mb_cxt@ is 'Nothing', then --- 'inferConstraintsDef' will infer an instance context (using 'inferConstraints'). -inferConstraintsDef :: DsMonad q => Maybe DCxt -> DPred -> DType -> [DCon] -> q DCxt -inferConstraintsDef mb_ctxt pr inst_ty cons = - maybe (inferConstraints pr inst_ty cons) pure mb_ctxt +-----------------------------------------------------------------------------+-- |+-- Module : Data.Singletons.TH.Deriving.Infer+-- Copyright : (C) 2015 Richard Eisenberg+-- License : BSD-style (see LICENSE)+-- Maintainer : Ryan Scott+-- Stability : experimental+-- Portability : non-portable+--+-- Infers constraints for a `deriving` class+--+----------------------------------------------------------------------------++module Data.Singletons.TH.Deriving.Infer ( inferConstraints, inferConstraintsDef ) where++import Language.Haskell.TH.Desugar+import Language.Haskell.TH.Syntax+import Data.Singletons.TH.Deriving.Util+import Data.Singletons.TH.Util+import Data.List (nub)+import Data.Maybe (fromJust)++-- @inferConstraints cls inst_ty cons@ infers the instance context for a+-- derived type class instance of @cls@ for @inst_ty@, using the constructors+-- @cons@. For instance, if @cls@ is 'Ord' and @inst_ty@ is @Either a b@, then+-- that means we are attempting to derive the instance:+--+-- @+-- instance ??? => Ord (Either a b)+-- @+--+-- The role of 'inferConstraints' is to determine what @???@ should be in that+-- derived instance. To accomplish this, the list of @cons@ (in this example,+-- @cons@ would be @[Left a, Right b]@) is used as follows:+--+-- 1. For each @con@ in @cons@, find the types of each of its fields+-- (call these @field_tys@), perhaps after renaming the type variables of+-- @field_tys@.+-- 2. For each @field_ty@ in @field_tys@, apply @cls@ to @field_ty@ to obtain+-- a constraint.+-- 3. The final instance context is the set of all such constraints obtained+-- in step 2.+--+-- To complete the running example, this algorithm would produce the instance+-- context @(Ord a, Ord b)@, since @Left a@ has one field of type @a@, and+-- @Right b@ has one field of type @b@.+--+-- This algorithm is a crude approximation of what GHC actually does when+-- deriving instances. It is crude in the sense that one can end up with+-- redundant constraints. For instance, if the data type for which an 'Ord'+-- instance is being derived is @data Foo = MkFoo Bool Foo@, then the+-- inferred constraints would be @(Ord Bool, Ord Foo)@. Technically, neither+-- constraint is necessary, but it is not simple in general to eliminate+-- redundant constraints like these, so we do not attept to do so. (This is+-- one reason why @singletons-th@ requires the use of the @UndecidableInstances@+-- GHC extension.)+--+-- Observant readers will notice that the phrase \"perhaps afer renaming the+-- type variables\" was casually dropped in step 1 of the above algorithm.+-- For more information on what this means, refer to the documentation for+-- infer_ct below.+inferConstraints :: forall q. DsMonad q => DPred -> DType -> [DCon] -> q DCxt+inferConstraints pr inst_ty = fmap nub . concatMapM infer_ct+ where+ -- A thorny situation arises when attempting to infer an instance context+ -- for a GADT. Consider the following example:+ --+ -- newtype Bar a where+ -- MkBar :: b -> Bar b+ -- deriving Show+ --+ -- If we blindly apply 'Show' to the field type of @MkBar@, we will end up+ -- with a derived instance of:+ --+ -- instance Show b => Show (Bar a)+ --+ -- This is completely wrong, since the type variable @b@ is never used in+ -- the instance head! This reveals that we need a slightly more nuanced+ -- strategy for gathering constraints for GADT constructors. To account+ -- for this, when gathering @field_tys@ (from step 1 in the above algorithm)+ -- we perform the following extra steps:+ --+ -- 1(a). Take the return type of @con@ and match it with @inst_ty@ (e.g.,+ -- match @Bar b@ with @Bar a@). Doing so will produce a substitution+ -- that maps the universally quantified type variables in the GADT+ -- (i.e., @b@) to the corresponding type variables in the data type+ -- constructor (i.e., @a@).+ -- 1(b). Use the resulting substitution to rename the universally+ -- quantified type variables of @con@ as necessary.+ --+ -- After this renaming, the algorithm will produce an instance context of+ -- @Show a@ (since @b@ was renamed to @a@), as expected.+ infer_ct :: DCon -> q DCxt+ infer_ct (DCon _ _ _ fields res_ty) = do+ let field_tys = tysOfConFields fields+ -- We need to match the constructor's result type with the type given+ -- in the generated instance. But if we have:+ --+ -- data Foo a where+ -- MkFoo :: a -> Foo a+ -- deriving Functor+ --+ -- Then the generated instance will be:+ --+ -- instance Functor Foo where ...+ --+ -- Which means that if we're not careful, we might try to match the+ -- types (Foo a) and (Foo), which will fail.+ --+ -- To avoid this, we employ a grimy hack where we pad the instance+ -- type with an extra (dummy) type variable. It doesn't matter what+ -- we name it, since none of the inferred constraints will mention+ -- it anyway.+ eta_expanded_inst_ty+ | is_functor_like = inst_ty `DAppT` DVarT (mkName "dummy")+ | otherwise = inst_ty+ res_ty' <- expandType res_ty+ inst_ty' <- expandType eta_expanded_inst_ty+ field_tys' <- case matchTy YesIgnore res_ty' inst_ty' of+ Nothing -> fail $ showString "Unable to match type "+ . showsPrec 11 res_ty'+ . showString " with "+ . showsPrec 11 inst_ty'+ $ ""+ Just subst -> traverse (substTy subst) field_tys+ if is_functor_like+ then mk_functor_like_constraints field_tys' res_ty'+ else pure $ map (pr `DAppT`) field_tys'++ -- If we derive a Functor-like class, e.g.,+ --+ -- data Foo f g h a = MkFoo (f a) (g (h a)) deriving Functor+ --+ -- Then we infer constraints by sticking Functor on the subtypes of kind+ -- (Type -> Type). In the example above, that would give us+ -- (Functor f, Functor g, Functor h).+ mk_functor_like_constraints :: [DType] -> DType -> q DCxt+ mk_functor_like_constraints fields res_ty = do+ -- This function is partial. But that's OK, because+ -- functorLikeValidityChecks ensures that this is total by the time+ -- we invoke this.+ let (_, res_ty_args) = unfoldDType res_ty+ (_, last_res_ty_arg) = snocView $ filterDTANormals res_ty_args+ last_tv = fromJust $ getDVarTName_maybe last_res_ty_arg+ deep_subtypes <- concatMapM (deepSubtypesContaining last_tv) fields+ pure $ map (pr `DAppT`) deep_subtypes++ is_functor_like :: Bool+ is_functor_like+ | (DConT pr_class_name, _) <- unfoldDType pr+ = isFunctorLikeClassName pr_class_name+ | otherwise+ = False++-- For @inferConstraintsDef mb_cxt@, if @mb_cxt@ is 'Just' a context, then it will+-- simply return that context. Otherwise, if @mb_cxt@ is 'Nothing', then+-- 'inferConstraintsDef' will infer an instance context (using 'inferConstraints').+inferConstraintsDef :: DsMonad q => Maybe DCxt -> DPred -> DType -> [DCon] -> q DCxt+inferConstraintsDef mb_ctxt pr inst_ty cons =+ maybe (inferConstraints pr inst_ty cons) pure mb_ctxt
src/Data/Singletons/TH/Deriving/Ord.hs view
@@ -1,71 +1,71 @@------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TH.Deriving.Ord --- Copyright : (C) 2015 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Implements deriving of Ord instances --- ----------------------------------------------------------------------------- - -module Data.Singletons.TH.Deriving.Ord ( mkOrdInstance ) where - -import Language.Haskell.TH.Desugar -import Language.Haskell.TH.Syntax -import Data.Singletons.TH.Deriving.Infer -import Data.Singletons.TH.Deriving.Util -import Data.Singletons.TH.Names -import Data.Singletons.TH.Syntax -import Data.Singletons.TH.Util - --- | Make a *non-singleton* Ord instance -mkOrdInstance :: DsMonad q => DerivDesc q -mkOrdInstance mb_ctxt ty (DataDecl _ _ _ cons) = do - constraints <- inferConstraintsDef mb_ctxt (DConT ordName) ty cons - compare_eq_clauses <- mapM mk_equal_clause cons - let compare_noneq_clauses = map (uncurry mk_nonequal_clause) - [ (con1, con2) - | con1 <- zip cons [1..] - , con2 <- zip cons [1..] - , extractName (fst con1) /= - extractName (fst con2) ] - clauses | null cons = [mk_empty_clause] - | otherwise = compare_eq_clauses ++ compare_noneq_clauses - return (InstDecl { id_cxt = constraints - , id_name = ordName - , id_arg_tys = [ty] - , id_sigs = mempty - , id_meths = [(compareName, UFunction clauses)] }) - -mk_equal_clause :: Quasi q => DCon -> q DClause -mk_equal_clause (DCon _tvbs _cxt name fields _rty) = do - let tys = tysOfConFields fields - a_names <- mapM (const $ newUniqueName "a") tys - b_names <- mapM (const $ newUniqueName "b") tys - let pat1 = DConP name [] (map DVarP a_names) - pat2 = DConP name [] (map DVarP b_names) - return $ DClause [pat1, pat2] (DVarE foldlName `DAppE` - DVarE sappendName `DAppE` - DConE cmpEQName `DAppE` - mkListE (zipWith - (\a b -> DVarE compareName `DAppE` DVarE a - `DAppE` DVarE b) - a_names b_names)) - -mk_nonequal_clause :: (DCon, Int) -> (DCon, Int) -> DClause -mk_nonequal_clause (DCon _tvbs1 _cxt1 name1 fields1 _rty1, n1) - (DCon _tvbs2 _cxt2 name2 fields2 _rty2, n2) = - DClause [pat1, pat2] (case n1 `compare` n2 of - LT -> DConE cmpLTName - EQ -> DConE cmpEQName - GT -> DConE cmpGTName) - where - pat1 = DConP name1 [] (map (const DWildP) (tysOfConFields fields1)) - pat2 = DConP name2 [] (map (const DWildP) (tysOfConFields fields2)) - --- A variant of mk_equal_clause tailored to empty datatypes -mk_empty_clause :: DClause -mk_empty_clause = DClause [DWildP, DWildP] (DConE cmpEQName) +-----------------------------------------------------------------------------+-- |+-- Module : Data.Singletons.TH.Deriving.Ord+-- Copyright : (C) 2015 Richard Eisenberg+-- License : BSD-style (see LICENSE)+-- Maintainer : Ryan Scott+-- Stability : experimental+-- Portability : non-portable+--+-- Implements deriving of Ord instances+--+----------------------------------------------------------------------------++module Data.Singletons.TH.Deriving.Ord ( mkOrdInstance ) where++import Language.Haskell.TH.Desugar+import Language.Haskell.TH.Syntax+import Data.Singletons.TH.Deriving.Infer+import Data.Singletons.TH.Deriving.Util+import Data.Singletons.TH.Names+import Data.Singletons.TH.Syntax+import Data.Singletons.TH.Util++-- | Make a *non-singleton* Ord instance+mkOrdInstance :: DsMonad q => DerivDesc q+mkOrdInstance mb_ctxt ty (DataDecl _ _ _ cons) = do+ constraints <- inferConstraintsDef mb_ctxt (DConT ordName) ty cons+ compare_eq_clauses <- mapM mk_equal_clause cons+ let compare_noneq_clauses = map (uncurry mk_nonequal_clause)+ [ (con1, con2)+ | con1 <- zip cons [1..]+ , con2 <- zip cons [1..]+ , extractName (fst con1) /=+ extractName (fst con2) ]+ clauses | null cons = [mk_empty_clause]+ | otherwise = compare_eq_clauses ++ compare_noneq_clauses+ return (InstDecl { id_cxt = constraints+ , id_name = ordName+ , id_arg_tys = [ty]+ , id_sigs = mempty+ , id_meths = [(compareName, UFunction clauses)] })++mk_equal_clause :: Quasi q => DCon -> q DClause+mk_equal_clause (DCon _tvbs _cxt name fields _rty) = do+ let tys = tysOfConFields fields+ a_names <- mapM (const $ newUniqueName "a") tys+ b_names <- mapM (const $ newUniqueName "b") tys+ let pat1 = DConP name [] (map DVarP a_names)+ pat2 = DConP name [] (map DVarP b_names)+ return $ DClause [pat1, pat2] (DVarE foldlName `DAppE`+ DVarE sappendName `DAppE`+ DConE cmpEQName `DAppE`+ mkListE (zipWith+ (\a b -> DVarE compareName `DAppE` DVarE a+ `DAppE` DVarE b)+ a_names b_names))++mk_nonequal_clause :: (DCon, Int) -> (DCon, Int) -> DClause+mk_nonequal_clause (DCon _tvbs1 _cxt1 name1 fields1 _rty1, n1)+ (DCon _tvbs2 _cxt2 name2 fields2 _rty2, n2) =+ DClause [pat1, pat2] (case n1 `compare` n2 of+ LT -> DConE cmpLTName+ EQ -> DConE cmpEQName+ GT -> DConE cmpGTName)+ where+ pat1 = DConP name1 [] (map (const DWildP) (tysOfConFields fields1))+ pat2 = DConP name2 [] (map (const DWildP) (tysOfConFields fields2))++-- A variant of mk_equal_clause tailored to empty datatypes+mk_empty_clause :: DClause+mk_empty_clause = DClause [DWildP, DWildP] (DConE cmpEQName)
src/Data/Singletons/TH/Deriving/Show.hs view
@@ -1,164 +1,164 @@------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TH.Deriving.Show --- Copyright : (C) 2017 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Implements deriving of Show instances --- ----------------------------------------------------------------------------- - -module Data.Singletons.TH.Deriving.Show ( - mkShowInstance - , mkShowSingContext - ) where - -import Language.Haskell.TH.Syntax hiding (showName) -import Language.Haskell.TH.Desugar -import Data.Singletons.TH.Deriving.Infer -import Data.Singletons.TH.Deriving.Util -import Data.Singletons.TH.Names -import Data.Singletons.TH.Options -import Data.Singletons.TH.Syntax -import Data.Singletons.TH.Util -import Data.Maybe (fromMaybe) -import GHC.Lexeme (startsConSym, startsVarSym) -import GHC.Show (appPrec, appPrec1) - -mkShowInstance :: OptionsMonad q => DerivDesc q -mkShowInstance mb_ctxt ty (DataDecl _ _ _ cons) = do - clauses <- mk_showsPrec cons - constraints <- inferConstraintsDef mb_ctxt (DConT showName) ty cons - return $ InstDecl { id_cxt = constraints - , id_name = showName - , id_arg_tys = [ty] - , id_sigs = mempty - , id_meths = [ (showsPrecName, UFunction clauses) ] } - -mk_showsPrec :: OptionsMonad q => [DCon] -> q [DClause] -mk_showsPrec cons = do - p <- newUniqueName "p" -- The precedence argument (not always used) - if null cons - then do v <- newUniqueName "v" - pure [DClause [DWildP, DVarP v] (DCaseE (DVarE v) [])] - else mapM (mk_showsPrec_clause p) cons - -mk_showsPrec_clause :: forall q. DsMonad q - => Name -> DCon - -> q DClause -mk_showsPrec_clause p (DCon _ _ con_name con_fields _) = go con_fields - where - go :: DConFields -> q DClause - go con_fields' = do - case con_fields' of - - -- No fields: print just the constructor name, with no parentheses - DNormalC _ [] -> return $ - DClause [DWildP, DConP con_name [] []] $ - DVarE showStringName `DAppE` dStringE (parenInfixConName con_name "") - - -- Infix constructors have special Show treatment. - DNormalC True [_, _] -> do - argL <- newUniqueName "argL" - argR <- newUniqueName "argR" - fi <- fromMaybe defaultFixity <$> reifyFixityWithLocals con_name - let con_prec = case fi of Fixity prec _ -> prec - op_name = nameBase con_name - infixOpE = DAppE (DVarE showStringName) . dStringE $ - if isInfixDataCon op_name - then " " ++ op_name ++ " " - -- Make sure to handle infix data constructors - -- like (Int `Foo` Int) - else " `" ++ op_name ++ "` " - return $ DClause [DVarP p, DConP con_name [] [DVarP argL, DVarP argR]] $ - (DVarE showParenName `DAppE` (DVarE gtName `DAppE` DVarE p - `DAppE` dIntegerE con_prec)) - `DAppE` (DVarE composeName - `DAppE` showsPrecE (con_prec + 1) argL - `DAppE` (DVarE composeName - `DAppE` infixOpE - `DAppE` showsPrecE (con_prec + 1) argR)) - - DNormalC _ tys -> do - args <- mapM (const $ newUniqueName "arg") tys - let show_args = map (showsPrecE appPrec1) args - composed_args = foldr1 (\v q -> DVarE composeName - `DAppE` v - `DAppE` (DVarE composeName - `DAppE` DVarE showSpaceName - `DAppE` q)) show_args - named_args = DVarE composeName - `DAppE` (DVarE showStringName - `DAppE` dStringE (parenInfixConName con_name " ")) - `DAppE` composed_args - return $ DClause [DVarP p, DConP con_name [] $ map DVarP args] $ - DVarE showParenName - `DAppE` (DVarE gtName `DAppE` DVarE p `DAppE` dIntegerE appPrec) - `DAppE` named_args - - -- We show a record constructor with no fields the same way we'd show a - -- normal constructor with no fields. - DRecC [] -> go (DNormalC False []) - - DRecC tys -> do - args <- mapM (const $ newUniqueName "arg") tys - let show_args = - concatMap (\((arg_name, _, _), arg) -> - let arg_nameBase = nameBase arg_name - infix_rec = showParen (isSym arg_nameBase) - (showString arg_nameBase) "" - in [ DVarE showStringName `DAppE` dStringE (infix_rec ++ " = ") - , showsPrecE 0 arg - , DVarE showCommaSpaceName - ]) - (zip tys args) - brace_comma_args = (DVarE showCharName `DAppE` dCharE '{') - : take (length show_args - 1) show_args - composed_args = foldr (\x y -> DVarE composeName `DAppE` x `DAppE` y) - (DVarE showCharName `DAppE` dCharE '}') - brace_comma_args - named_args = DVarE composeName - `DAppE` (DVarE showStringName - `DAppE` dStringE (parenInfixConName con_name " ")) - `DAppE` composed_args - return $ DClause [DVarP p, DConP con_name [] $ map DVarP args] $ - DVarE showParenName - `DAppE` (DVarE gtName `DAppE` DVarE p `DAppE` dIntegerE appPrec) - `DAppE` named_args - --- | Parenthesize an infix constructor name if it is being applied as a prefix --- function (e.g., data Amp a = (:&) a a) -parenInfixConName :: Name -> ShowS -parenInfixConName conName = - let conNameBase = nameBase conName - in showParen (isInfixDataCon conNameBase) $ showString conNameBase - -showsPrecE :: Int -> Name -> DExp -showsPrecE prec n = DVarE showsPrecName `DAppE` dIntegerE prec `DAppE` DVarE n - -dCharE :: Char -> DExp -dCharE = DLitE . CharL - -dStringE :: String -> DExp -dStringE = DLitE . StringL - -dIntegerE :: Int -> DExp -dIntegerE = DLitE . IntegerL . fromIntegral - -isSym :: String -> Bool -isSym "" = False -isSym (c : _) = startsVarSym c || startsConSym c - --- | Turn a context like @('Show' a, 'Show' b)@ into @('ShowSing' a, 'ShowSing' b)@. --- This is necessary for standalone-derived 'Show' instances for singleton types. -mkShowSingContext :: DCxt -> DCxt -mkShowSingContext = map show_to_SingShow - where - show_to_SingShow :: DPred -> DPred - show_to_SingShow = modifyConNameDType $ \n -> - if n == showName - then showSingName - else n +-----------------------------------------------------------------------------+-- |+-- Module : Data.Singletons.TH.Deriving.Show+-- Copyright : (C) 2017 Ryan Scott+-- License : BSD-style (see LICENSE)+-- Maintainer : Ryan Scott+-- Stability : experimental+-- Portability : non-portable+--+-- Implements deriving of Show instances+--+----------------------------------------------------------------------------++module Data.Singletons.TH.Deriving.Show (+ mkShowInstance+ , mkShowSingContext+ ) where++import Language.Haskell.TH.Syntax hiding (showName)+import Language.Haskell.TH.Desugar+import Data.Singletons.TH.Deriving.Infer+import Data.Singletons.TH.Deriving.Util+import Data.Singletons.TH.Names+import Data.Singletons.TH.Options+import Data.Singletons.TH.Syntax+import Data.Singletons.TH.Util+import Data.Maybe (fromMaybe)+import GHC.Lexeme (startsConSym, startsVarSym)+import GHC.Show (appPrec, appPrec1)++mkShowInstance :: OptionsMonad q => DerivDesc q+mkShowInstance mb_ctxt ty (DataDecl _ _ _ cons) = do+ clauses <- mk_showsPrec cons+ constraints <- inferConstraintsDef mb_ctxt (DConT showName) ty cons+ return $ InstDecl { id_cxt = constraints+ , id_name = showName+ , id_arg_tys = [ty]+ , id_sigs = mempty+ , id_meths = [ (showsPrecName, UFunction clauses) ] }++mk_showsPrec :: OptionsMonad q => [DCon] -> q [DClause]+mk_showsPrec cons = do+ p <- newUniqueName "p" -- The precedence argument (not always used)+ if null cons+ then do v <- newUniqueName "v"+ pure [DClause [DWildP, DVarP v] (DCaseE (DVarE v) [])]+ else mapM (mk_showsPrec_clause p) cons++mk_showsPrec_clause :: forall q. DsMonad q+ => Name -> DCon+ -> q DClause+mk_showsPrec_clause p (DCon _ _ con_name con_fields _) = go con_fields+ where+ go :: DConFields -> q DClause+ go con_fields' = do+ case con_fields' of++ -- No fields: print just the constructor name, with no parentheses+ DNormalC _ [] -> return $+ DClause [DWildP, DConP con_name [] []] $+ DVarE showStringName `DAppE` dStringE (parenInfixConName con_name "")++ -- Infix constructors have special Show treatment.+ DNormalC True [_, _] -> do+ argL <- newUniqueName "argL"+ argR <- newUniqueName "argR"+ fi <- fromMaybe defaultFixity <$> reifyFixityWithLocals con_name+ let con_prec = case fi of Fixity prec _ -> prec+ op_name = nameBase con_name+ infixOpE = DAppE (DVarE showStringName) . dStringE $+ if isInfixDataCon op_name+ then " " ++ op_name ++ " "+ -- Make sure to handle infix data constructors+ -- like (Int `Foo` Int)+ else " `" ++ op_name ++ "` "+ return $ DClause [DVarP p, DConP con_name [] [DVarP argL, DVarP argR]] $+ (DVarE showParenName `DAppE` (DVarE gtName `DAppE` DVarE p+ `DAppE` dIntegerE con_prec))+ `DAppE` (DVarE composeName+ `DAppE` showsPrecE (con_prec + 1) argL+ `DAppE` (DVarE composeName+ `DAppE` infixOpE+ `DAppE` showsPrecE (con_prec + 1) argR))++ DNormalC _ tys -> do+ args <- mapM (const $ newUniqueName "arg") tys+ let show_args = map (showsPrecE appPrec1) args+ composed_args = foldr1 (\v q -> DVarE composeName+ `DAppE` v+ `DAppE` (DVarE composeName+ `DAppE` DVarE showSpaceName+ `DAppE` q)) show_args+ named_args = DVarE composeName+ `DAppE` (DVarE showStringName+ `DAppE` dStringE (parenInfixConName con_name " "))+ `DAppE` composed_args+ return $ DClause [DVarP p, DConP con_name [] $ map DVarP args] $+ DVarE showParenName+ `DAppE` (DVarE gtName `DAppE` DVarE p `DAppE` dIntegerE appPrec)+ `DAppE` named_args++ -- We show a record constructor with no fields the same way we'd show a+ -- normal constructor with no fields.+ DRecC [] -> go (DNormalC False [])++ DRecC tys -> do+ args <- mapM (const $ newUniqueName "arg") tys+ let show_args =+ concatMap (\((arg_name, _, _), arg) ->+ let arg_nameBase = nameBase arg_name+ infix_rec = showParen (isSym arg_nameBase)+ (showString arg_nameBase) ""+ in [ DVarE showStringName `DAppE` dStringE (infix_rec ++ " = ")+ , showsPrecE 0 arg+ , DVarE showCommaSpaceName+ ])+ (zip tys args)+ brace_comma_args = (DVarE showCharName `DAppE` dCharE '{')+ : take (length show_args - 1) show_args+ composed_args = foldr (\x y -> DVarE composeName `DAppE` x `DAppE` y)+ (DVarE showCharName `DAppE` dCharE '}')+ brace_comma_args+ named_args = DVarE composeName+ `DAppE` (DVarE showStringName+ `DAppE` dStringE (parenInfixConName con_name " "))+ `DAppE` composed_args+ return $ DClause [DVarP p, DConP con_name [] $ map DVarP args] $+ DVarE showParenName+ `DAppE` (DVarE gtName `DAppE` DVarE p `DAppE` dIntegerE appPrec)+ `DAppE` named_args++-- | Parenthesize an infix constructor name if it is being applied as a prefix+-- function (e.g., data Amp a = (:&) a a)+parenInfixConName :: Name -> ShowS+parenInfixConName conName =+ let conNameBase = nameBase conName+ in showParen (isInfixDataCon conNameBase) $ showString conNameBase++showsPrecE :: Int -> Name -> DExp+showsPrecE prec n = DVarE showsPrecName `DAppE` dIntegerE prec `DAppE` DVarE n++dCharE :: Char -> DExp+dCharE = DLitE . CharL++dStringE :: String -> DExp+dStringE = DLitE . StringL++dIntegerE :: Int -> DExp+dIntegerE = DLitE . IntegerL . fromIntegral++isSym :: String -> Bool+isSym "" = False+isSym (c : _) = startsVarSym c || startsConSym c++-- | Turn a context like @('Show' a, 'Show' b)@ into @('ShowSing' a, 'ShowSing' b)@.+-- This is necessary for standalone-derived 'Show' instances for singleton types.+mkShowSingContext :: DCxt -> DCxt+mkShowSingContext = map show_to_SingShow+ where+ show_to_SingShow :: DPred -> DPred+ show_to_SingShow = modifyConNameDType $ \n ->+ if n == showName+ then showSingName+ else n
src/Data/Singletons/TH/Deriving/Traversable.hs view
@@ -1,67 +1,67 @@------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TH.Deriving.Traversable --- Copyright : (C) 2018 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Implements deriving of Traversable instances --- ----------------------------------------------------------------------------- - -module Data.Singletons.TH.Deriving.Traversable where - -import Data.Singletons.TH.Deriving.Infer -import Data.Singletons.TH.Deriving.Util -import Data.Singletons.TH.Names -import Data.Singletons.TH.Syntax -import Language.Haskell.TH.Desugar - -mkTraversableInstance :: forall q. DsMonad q => DerivDesc q -mkTraversableInstance mb_ctxt ty dd@(DataDecl _ _ _ cons) = do - functorLikeValidityChecks False dd - f <- newUniqueName "_f" - let ft_trav :: FFoldType (q DExp) - ft_trav = FT { ft_triv = pure $ DVarE pureName - -- traverse f = pure x - , ft_var = pure $ DVarE f - -- traverse f = f x - , ft_ty_app = \_ g -> DAppE (DVarE traverseName) <$> g - -- traverse f = traverse g - , ft_forall = \_ g -> g - , ft_bad_app = error "in other argument in ft_trav" - } - - -- Con a1 a2 ... -> Con <$> g1 a1 <*> g2 a2 <*> ... - clause_for_con :: [DPat] -> DCon -> [DExp] -> q DClause - clause_for_con = mkSimpleConClause $ \con_name -> mkApCon (DConE con_name) - where - -- ((Con <$> x1) <*> x2) <*> ... - mkApCon :: DExp -> [DExp] -> DExp - mkApCon con [] = DVarE pureName `DAppE` con - mkApCon con [x] = DVarE fmapName `DAppE` con `DAppE` x - mkApCon con (x1:x2:xs) = - foldl appAp (DVarE liftA2Name `DAppE` con `DAppE` x1 `DAppE` x2) xs - where appAp x y = DVarE apName `DAppE` x `DAppE` y - - mk_trav_clause :: DCon -> q DClause - mk_trav_clause con = do - parts <- foldDataConArgs ft_trav con - clause_for_con [DVarP f] con =<< sequence parts - - mk_trav :: q [DClause] - mk_trav = case cons of - [] -> do v <- newUniqueName "v" - pure [DClause [DWildP, DVarP v] - (DVarE pureName `DAppE` DCaseE (DVarE v) [])] - _ -> traverse mk_trav_clause cons - - trav_clauses <- mk_trav - constraints <- inferConstraintsDef mb_ctxt (DConT traversableName) ty cons - return $ InstDecl { id_cxt = constraints - , id_name = traversableName - , id_arg_tys = [ty] - , id_sigs = mempty - , id_meths = [ (traverseName, UFunction trav_clauses) ] } +-----------------------------------------------------------------------------+-- |+-- Module : Data.Singletons.TH.Deriving.Traversable+-- Copyright : (C) 2018 Ryan Scott+-- License : BSD-style (see LICENSE)+-- Maintainer : Ryan Scott+-- Stability : experimental+-- Portability : non-portable+--+-- Implements deriving of Traversable instances+--+----------------------------------------------------------------------------++module Data.Singletons.TH.Deriving.Traversable where++import Data.Singletons.TH.Deriving.Infer+import Data.Singletons.TH.Deriving.Util+import Data.Singletons.TH.Names+import Data.Singletons.TH.Syntax+import Language.Haskell.TH.Desugar++mkTraversableInstance :: forall q. DsMonad q => DerivDesc q+mkTraversableInstance mb_ctxt ty dd@(DataDecl _ _ _ cons) = do+ functorLikeValidityChecks False dd+ f <- newUniqueName "_f"+ let ft_trav :: FFoldType (q DExp)+ ft_trav = FT { ft_triv = pure $ DVarE pureName+ -- traverse f = pure x+ , ft_var = pure $ DVarE f+ -- traverse f = f x+ , ft_ty_app = \_ g -> DAppE (DVarE traverseName) <$> g+ -- traverse f = traverse g+ , ft_forall = \_ g -> g+ , ft_bad_app = error "in other argument in ft_trav"+ }++ -- Con a1 a2 ... -> Con <$> g1 a1 <*> g2 a2 <*> ...+ clause_for_con :: [DPat] -> DCon -> [DExp] -> q DClause+ clause_for_con = mkSimpleConClause $ \con_name -> mkApCon (DConE con_name)+ where+ -- ((Con <$> x1) <*> x2) <*> ...+ mkApCon :: DExp -> [DExp] -> DExp+ mkApCon con [] = DVarE pureName `DAppE` con+ mkApCon con [x] = DVarE fmapName `DAppE` con `DAppE` x+ mkApCon con (x1:x2:xs) =+ foldl appAp (DVarE liftA2Name `DAppE` con `DAppE` x1 `DAppE` x2) xs+ where appAp x y = DVarE apName `DAppE` x `DAppE` y++ mk_trav_clause :: DCon -> q DClause+ mk_trav_clause con = do+ parts <- foldDataConArgs ft_trav con+ clause_for_con [DVarP f] con =<< sequence parts++ mk_trav :: q [DClause]+ mk_trav = case cons of+ [] -> do v <- newUniqueName "v"+ pure [DClause [DWildP, DVarP v]+ (DVarE pureName `DAppE` DCaseE (DVarE v) [])]+ _ -> traverse mk_trav_clause cons++ trav_clauses <- mk_trav+ constraints <- inferConstraintsDef mb_ctxt (DConT traversableName) ty cons+ return $ InstDecl { id_cxt = constraints+ , id_name = traversableName+ , id_arg_tys = [ty]+ , id_sigs = mempty+ , id_meths = [ (traverseName, UFunction trav_clauses) ] }
src/Data/Singletons/TH/Deriving/Util.hs view
@@ -1,299 +1,299 @@-{-# LANGUAGE MultiWayIf #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TH.Deriving.Util --- Copyright : (C) 2018 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Utilities used by the `deriving` machinery in singletons-th. --- ----------------------------------------------------------------------------- -module Data.Singletons.TH.Deriving.Util where - -import Control.Monad -import Data.Singletons.TH.Names -import Data.Singletons.TH.Syntax -import Data.Singletons.TH.Util -import Language.Haskell.TH.Desugar -import qualified Language.Haskell.TH.Desugar.OSet as OSet -import Language.Haskell.TH.Syntax - --- A generic type signature for describing how to produce a derived instance. -type DerivDesc q - = Maybe DCxt -- (Just ctx) if ctx was provided via StandaloneDeriving. - -- Nothing if using a deriving clause. - -> DType -- The data type argument to the class. - -> DataDecl -- The original data type information. - -> q UInstDecl -- The derived instance. - ------ --- Utilities for deriving Functor-like classes. --- Much of this was cargo-culted from the GHC source code. ------ - -data FFoldType a -- Describes how to fold over a DType in a functor like way - = FT { ft_triv :: a - -- ^ Does not contain variable - , ft_var :: a - -- ^ The variable itself - , ft_ty_app :: DType -> a -> a - -- ^ Type app, variable only in last argument - , ft_bad_app :: a - -- ^ Type app, variable other than in last argument - , ft_forall :: [DTyVarBndrSpec] -> a -> a - -- ^ Forall type - } - --- Note that in GHC, this function is pure. It must be monadic here since we: --- --- (1) Expand type synonyms --- (2) Detect type family applications --- --- Which require reification in Template Haskell, but are pure in Core. -functorLikeTraverse :: forall q a. - DsMonad q - => Name -- ^ Variable to look for - -> FFoldType a -- ^ How to fold - -> DType -- ^ Type to process - -> q a -functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar - , ft_ty_app = caseTyApp, ft_bad_app = caseWrongArg - , ft_forall = caseForAll }) - ty - = do ty' <- expandType ty - (res, _) <- go ty' - pure res - where - go :: DType - -> q (a, Bool) -- (result of type a, does type contain var) - go t@DAppT{} = do - let (f, args) = unfoldDType t - vis_args = filterDTANormals args - (_, fc) <- go f - (xrs, xcs) <- mapAndUnzipM go vis_args - let wrongArg :: q (a, Bool) - wrongArg = pure (caseWrongArg, True) - if | not (or xcs) - -> trivial -- Variable does not occur - -- At this point we know that xrs, xcs is not empty, - -- and at least one xr is True - | fc || or (init xcs) - -> wrongArg -- T (..var..) ty - | otherwise -- T (..no var..) ty - -> do itf <- isInTypeFamilyApp var f vis_args - if itf -- We can't decompose type families, so - -- error if we encounter one here. - then wrongArg - else pure (caseTyApp (last vis_args) (last xrs), True) - go (DAppKindT t k) = do - (_, kc) <- go k - if kc - then pure (caseWrongArg, True) - else go t - go (DSigT t k) = do - (_, kc) <- go k - if kc - then pure (caseWrongArg, True) - else go t - go (DVarT v) - | v == var = pure (caseVar, True) - | otherwise = trivial - go (DForallT tele t) = case tele of - DForallVis{} -> - fail "Unexpected visible forall in the type of a data constructor" - DForallInvis tvbs -> do - (tr, tc) <- go t - if var `notElem` map extractTvbName tvbs && tc - then pure (caseForAll tvbs tr, True) - else trivial - go (DConstrainedT _ t) = go t - go (DConT {}) = trivial - go DArrowT = trivial - go (DLitT {}) = trivial - go DWildCardT = trivial - - trivial :: q (a, Bool) - trivial = pure (caseTrivial, False) - --- | Detect if a Name occurs as an argument to some type family. This makes an --- effort to exclude /oversaturated/ arguments to type families. For instance, --- if one declared the following type family: --- --- @ --- type family F a :: Type -> Type --- @ --- --- Then in the type @F a b@, we would consider @a@ to be an argument to @F@, --- but not @b@. -isInTypeFamilyApp :: forall q. DsMonad q => Name -> DType -> [DType] -> q Bool -isInTypeFamilyApp name tyFun tyArgs = - case tyFun of - DConT tcName -> go tcName - _ -> pure False - where - go :: Name -> q Bool - go tcName = do - info <- dsReify tcName - case info of - Just (DTyConI dec _) - | DOpenTypeFamilyD (DTypeFamilyHead _ bndrs _ _) <- dec - -> withinFirstArgs bndrs - | DClosedTypeFamilyD (DTypeFamilyHead _ bndrs _ _) _ <- dec - -> withinFirstArgs bndrs - _ -> pure False - - withinFirstArgs :: [a] -> q Bool - withinFirstArgs bndrs = - let firstArgs = take (length bndrs) tyArgs - argFVs = foldMap fvDType firstArgs - in pure $ name `elem` argFVs - --- A crude approximation of cond_functorOK from GHC. This checks that: --- --- (1) There's at least one type variable in the data type. --- (2) It doesn't constrain the last type variable, e.g., data T a = Eq a => MkT a --- (3) It doesn't use the last type variable in the wrong place, e.g. data T a = MkT (X a a) --- --- This skips some things that cond_functorOK checks for but are tricky to --- implement in Template Haskell, such as if the last type variable in the --- constructor's return type is universally quantified. For example, --- functorLikeValidityChecks would accept the following example that --- cond_functorOK would reject: --- --- @ --- data T a b where --- MkT :: z -> T z z -- Last type variable is existential --- deriving instance Functor (T a) --- @ --- --- This isn't the end of the world, as it just means that the user will have to --- deal with a more complex error message when the generate code fails to --- typecheck. -functorLikeValidityChecks :: forall q. DsMonad q => Bool -> DataDecl -> q () -functorLikeValidityChecks allowConstrainedLastTyVar (DataDecl _df n data_tvbs cons) - | null data_tvbs -- (1) - = fail $ "Data type " ++ nameBase n ++ " must have some type parameters" - | otherwise - = mapM_ check_con cons - where - check_con :: DCon -> q () - check_con con = do - check_universal con - checks <- foldDataConArgs (ft_check (extractName con)) con - sequence_ checks - - -- (2) - check_universal :: DCon -> q () - check_universal (DCon _ con_theta con_name _ res_ty) - | allowConstrainedLastTyVar - = pure () - | (_, res_ty_args) <- unfoldDType res_ty - , (_, last_res_ty_arg) <- snocView $ filterDTANormals res_ty_args - , Just last_tv <- getDVarTName_maybe last_res_ty_arg - = do if last_tv `OSet.notMember` foldMap fvDType con_theta - then pure () - else fail $ badCon con_name existential - | otherwise - = fail $ badCon con_name existential - - -- (3) - ft_check :: Name -> FFoldType (q ()) - ft_check con_name = - FT { ft_triv = pure () - , ft_var = pure () - , ft_ty_app = \_ x -> x - , ft_bad_app = fail $ badCon con_name wrong_arg - , ft_forall = \_ x -> x - } - - badCon :: Name -> String -> String - badCon con_name msg = "Constructor " ++ nameBase con_name ++ " " ++ msg - - existential, wrong_arg :: String - existential = "must be truly polymorphic in the last argument of the data type" - wrong_arg = "must use the type variable only as the last argument of a data type" - --- Return all syntactic subterms of a type that contain the given variable somewhere. --- These are the things that should appear in Functor-like instance constraints. -deepSubtypesContaining :: DsMonad q => Name -> DType -> q [DType] -deepSubtypesContaining tv - = functorLikeTraverse tv - (FT { ft_triv = [] - , ft_var = [] - , ft_ty_app = (:) - , ft_bad_app = error "in other argument in deepSubtypesContaining" - , ft_forall = \tvbs xs -> filter (\x -> all (not_in_ty x) tvbs) xs }) - where - not_in_ty :: DType -> DTyVarBndrSpec -> Bool - not_in_ty ty tvb = extractTvbName tvb `OSet.notMember` fvDType ty - --- Fold over the arguments of a data constructor in a Functor-like way. -foldDataConArgs :: forall q a. DsMonad q => FFoldType a -> DCon -> q [a] -foldDataConArgs ft (DCon _ _ _ fields res_ty) = do - field_tys <- traverse expandType $ tysOfConFields fields - traverse foldArg field_tys - where - foldArg :: DType -> q a - foldArg - | (_, res_ty_args) <- unfoldDType res_ty - , (_, last_res_ty_arg) <- snocView $ filterDTANormals res_ty_args - , Just last_tv <- getDVarTName_maybe last_res_ty_arg - = functorLikeTraverse last_tv ft - | otherwise - = const (return (ft_triv ft)) - --- If a type is a type variable (or a variable with a kind signature), return --- 'Just' that. Otherwise, return 'Nothing'. -getDVarTName_maybe :: DType -> Maybe Name -getDVarTName_maybe (DSigT t _) = getDVarTName_maybe t -getDVarTName_maybe (DVarT n) = Just n -getDVarTName_maybe _ = Nothing - --- Make a 'DLamE' using a fresh variable. -mkSimpleLam :: Quasi q => (DExp -> q DExp) -> q DExp -mkSimpleLam lam = do - n <- newUniqueName "n" - body <- lam (DVarE n) - return $ DLamE [n] body - --- Make a 'DLamE' using two fresh variables. -mkSimpleLam2 :: Quasi q => (DExp -> DExp -> q DExp) -> q DExp -mkSimpleLam2 lam = do - n1 <- newUniqueName "n1" - n2 <- newUniqueName "n2" - body <- lam (DVarE n1) (DVarE n2) - return $ DLamE [n1, n2] body - --- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]" --- --- @mkSimpleConClause fold extra_pats con insides@ produces a match clause in --- which the LHS pattern-matches on @extra_pats@, followed by a match on the --- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@ --- and its arguments, applying an expression (from @insides@) to each of the --- respective arguments of @con@. -mkSimpleConClause :: Quasi q - => (Name -> [DExp] -> DExp) - -> [DPat] - -> DCon - -> [DExp] - -> q DClause -mkSimpleConClause fold extra_pats (DCon _ _ con_name _ _) insides = do - vars_needed <- replicateM (length insides) $ newUniqueName "a" - let pat = DConP con_name [] (map DVarP vars_needed) - rhs = fold con_name (zipWith (\i v -> i `DAppE` DVarE v) insides vars_needed) - pure $ DClause (extra_pats ++ [pat]) rhs - --- 'True' if the derived class's last argument is of kind (Type -> Type), --- and thus needs a different constraint inference approach. --- --- Really, we should be determining this information by inspecting the kind --- of the class being used. But that comes dangerously close to kind --- inference territory, so for now we simply hardcode which stock derivable --- classes are Functor-like. -isFunctorLikeClassName :: Name -> Bool -isFunctorLikeClassName class_name - = class_name `elem` [functorName, foldableName, traversableName] +{-# LANGUAGE MultiWayIf #-}++-----------------------------------------------------------------------------+-- |+-- Module : Data.Singletons.TH.Deriving.Util+-- Copyright : (C) 2018 Ryan Scott+-- License : BSD-style (see LICENSE)+-- Maintainer : Ryan Scott+-- Stability : experimental+-- Portability : non-portable+--+-- Utilities used by the `deriving` machinery in singletons-th.+--+----------------------------------------------------------------------------+module Data.Singletons.TH.Deriving.Util where++import Control.Monad+import Data.Singletons.TH.Names+import Data.Singletons.TH.Syntax+import Data.Singletons.TH.Util+import Language.Haskell.TH.Desugar+import qualified Language.Haskell.TH.Desugar.OSet as OSet+import Language.Haskell.TH.Syntax++-- A generic type signature for describing how to produce a derived instance.+type DerivDesc q+ = Maybe DCxt -- (Just ctx) if ctx was provided via StandaloneDeriving.+ -- Nothing if using a deriving clause.+ -> DType -- The data type argument to the class.+ -> DataDecl -- The original data type information.+ -> q UInstDecl -- The derived instance.++-----+-- Utilities for deriving Functor-like classes.+-- Much of this was cargo-culted from the GHC source code.+-----++data FFoldType a -- Describes how to fold over a DType in a functor like way+ = FT { ft_triv :: a+ -- ^ Does not contain variable+ , ft_var :: a+ -- ^ The variable itself+ , ft_ty_app :: DType -> a -> a+ -- ^ Type app, variable only in last argument+ , ft_bad_app :: a+ -- ^ Type app, variable other than in last argument+ , ft_forall :: [DTyVarBndrSpec] -> a -> a+ -- ^ Forall type+ }++-- Note that in GHC, this function is pure. It must be monadic here since we:+--+-- (1) Expand type synonyms+-- (2) Detect type family applications+--+-- Which require reification in Template Haskell, but are pure in Core.+functorLikeTraverse :: forall q a.+ DsMonad q+ => Name -- ^ Variable to look for+ -> FFoldType a -- ^ How to fold+ -> DType -- ^ Type to process+ -> q a+functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar+ , ft_ty_app = caseTyApp, ft_bad_app = caseWrongArg+ , ft_forall = caseForAll })+ ty+ = do ty' <- expandType ty+ (res, _) <- go ty'+ pure res+ where+ go :: DType+ -> q (a, Bool) -- (result of type a, does type contain var)+ go t@DAppT{} = do+ let (f, args) = unfoldDType t+ vis_args = filterDTANormals args+ (_, fc) <- go f+ (xrs, xcs) <- mapAndUnzipM go vis_args+ let wrongArg :: q (a, Bool)+ wrongArg = pure (caseWrongArg, True)+ if | not (or xcs)+ -> trivial -- Variable does not occur+ -- At this point we know that xrs, xcs is not empty,+ -- and at least one xr is True+ | fc || or (init xcs)+ -> wrongArg -- T (..var..) ty+ | otherwise -- T (..no var..) ty+ -> do itf <- isInTypeFamilyApp var f vis_args+ if itf -- We can't decompose type families, so+ -- error if we encounter one here.+ then wrongArg+ else pure (caseTyApp (last vis_args) (last xrs), True)+ go (DAppKindT t k) = do+ (_, kc) <- go k+ if kc+ then pure (caseWrongArg, True)+ else go t+ go (DSigT t k) = do+ (_, kc) <- go k+ if kc+ then pure (caseWrongArg, True)+ else go t+ go (DVarT v)+ | v == var = pure (caseVar, True)+ | otherwise = trivial+ go (DForallT tele t) = case tele of+ DForallVis{} ->+ fail "Unexpected visible forall in the type of a data constructor"+ DForallInvis tvbs -> do+ (tr, tc) <- go t+ if var `notElem` map extractTvbName tvbs && tc+ then pure (caseForAll tvbs tr, True)+ else trivial+ go (DConstrainedT _ t) = go t+ go (DConT {}) = trivial+ go DArrowT = trivial+ go (DLitT {}) = trivial+ go DWildCardT = trivial++ trivial :: q (a, Bool)+ trivial = pure (caseTrivial, False)++-- | Detect if a Name occurs as an argument to some type family. This makes an+-- effort to exclude /oversaturated/ arguments to type families. For instance,+-- if one declared the following type family:+--+-- @+-- type family F a :: Type -> Type+-- @+--+-- Then in the type @F a b@, we would consider @a@ to be an argument to @F@,+-- but not @b@.+isInTypeFamilyApp :: forall q. DsMonad q => Name -> DType -> [DType] -> q Bool+isInTypeFamilyApp name tyFun tyArgs =+ case tyFun of+ DConT tcName -> go tcName+ _ -> pure False+ where+ go :: Name -> q Bool+ go tcName = do+ info <- dsReify tcName+ case info of+ Just (DTyConI dec _)+ | DOpenTypeFamilyD (DTypeFamilyHead _ bndrs _ _) <- dec+ -> withinFirstArgs bndrs+ | DClosedTypeFamilyD (DTypeFamilyHead _ bndrs _ _) _ <- dec+ -> withinFirstArgs bndrs+ _ -> pure False++ withinFirstArgs :: [a] -> q Bool+ withinFirstArgs bndrs =+ let firstArgs = take (length bndrs) tyArgs+ argFVs = foldMap fvDType firstArgs+ in pure $ name `elem` argFVs++-- A crude approximation of cond_functorOK from GHC. This checks that:+--+-- (1) There's at least one type variable in the data type.+-- (2) It doesn't constrain the last type variable, e.g., data T a = Eq a => MkT a+-- (3) It doesn't use the last type variable in the wrong place, e.g. data T a = MkT (X a a)+--+-- This skips some things that cond_functorOK checks for but are tricky to+-- implement in Template Haskell, such as if the last type variable in the+-- constructor's return type is universally quantified. For example,+-- functorLikeValidityChecks would accept the following example that+-- cond_functorOK would reject:+--+-- @+-- data T a b where+-- MkT :: z -> T z z -- Last type variable is existential+-- deriving instance Functor (T a)+-- @+--+-- This isn't the end of the world, as it just means that the user will have to+-- deal with a more complex error message when the generate code fails to+-- typecheck.+functorLikeValidityChecks :: forall q. DsMonad q => Bool -> DataDecl -> q ()+functorLikeValidityChecks allowConstrainedLastTyVar (DataDecl _df n data_tvbs cons)+ | null data_tvbs -- (1)+ = fail $ "Data type " ++ nameBase n ++ " must have some type parameters"+ | otherwise+ = mapM_ check_con cons+ where+ check_con :: DCon -> q ()+ check_con con = do+ check_universal con+ checks <- foldDataConArgs (ft_check (extractName con)) con+ sequence_ checks++ -- (2)+ check_universal :: DCon -> q ()+ check_universal (DCon _ con_theta con_name _ res_ty)+ | allowConstrainedLastTyVar+ = pure ()+ | (_, res_ty_args) <- unfoldDType res_ty+ , (_, last_res_ty_arg) <- snocView $ filterDTANormals res_ty_args+ , Just last_tv <- getDVarTName_maybe last_res_ty_arg+ = do if last_tv `OSet.notMember` foldMap fvDType con_theta+ then pure ()+ else fail $ badCon con_name existential+ | otherwise+ = fail $ badCon con_name existential++ -- (3)+ ft_check :: Name -> FFoldType (q ())+ ft_check con_name =+ FT { ft_triv = pure ()+ , ft_var = pure ()+ , ft_ty_app = \_ x -> x+ , ft_bad_app = fail $ badCon con_name wrong_arg+ , ft_forall = \_ x -> x+ }++ badCon :: Name -> String -> String+ badCon con_name msg = "Constructor " ++ nameBase con_name ++ " " ++ msg++ existential, wrong_arg :: String+ existential = "must be truly polymorphic in the last argument of the data type"+ wrong_arg = "must use the type variable only as the last argument of a data type"++-- Return all syntactic subterms of a type that contain the given variable somewhere.+-- These are the things that should appear in Functor-like instance constraints.+deepSubtypesContaining :: DsMonad q => Name -> DType -> q [DType]+deepSubtypesContaining tv+ = functorLikeTraverse tv+ (FT { ft_triv = []+ , ft_var = []+ , ft_ty_app = (:)+ , ft_bad_app = error "in other argument in deepSubtypesContaining"+ , ft_forall = \tvbs xs -> filter (\x -> all (not_in_ty x) tvbs) xs })+ where+ not_in_ty :: DType -> DTyVarBndrSpec -> Bool+ not_in_ty ty tvb = extractTvbName tvb `OSet.notMember` fvDType ty++-- Fold over the arguments of a data constructor in a Functor-like way.+foldDataConArgs :: forall q a. DsMonad q => FFoldType a -> DCon -> q [a]+foldDataConArgs ft (DCon _ _ _ fields res_ty) = do+ field_tys <- traverse expandType $ tysOfConFields fields+ traverse foldArg field_tys+ where+ foldArg :: DType -> q a+ foldArg+ | (_, res_ty_args) <- unfoldDType res_ty+ , (_, last_res_ty_arg) <- snocView $ filterDTANormals res_ty_args+ , Just last_tv <- getDVarTName_maybe last_res_ty_arg+ = functorLikeTraverse last_tv ft+ | otherwise+ = const (return (ft_triv ft))++-- If a type is a type variable (or a variable with a kind signature), return+-- 'Just' that. Otherwise, return 'Nothing'.+getDVarTName_maybe :: DType -> Maybe Name+getDVarTName_maybe (DSigT t _) = getDVarTName_maybe t+getDVarTName_maybe (DVarT n) = Just n+getDVarTName_maybe _ = Nothing++-- Make a 'DLamE' using a fresh variable.+mkSimpleLam :: Quasi q => (DExp -> q DExp) -> q DExp+mkSimpleLam lam = do+ n <- newUniqueName "n"+ body <- lam (DVarE n)+ return $ DLamE [n] body++-- Make a 'DLamE' using two fresh variables.+mkSimpleLam2 :: Quasi q => (DExp -> DExp -> q DExp) -> q DExp+mkSimpleLam2 lam = do+ n1 <- newUniqueName "n1"+ n2 <- newUniqueName "n2"+ body <- lam (DVarE n1) (DVarE n2)+ return $ DLamE [n1, n2] body++-- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"+--+-- @mkSimpleConClause fold extra_pats con insides@ produces a match clause in+-- which the LHS pattern-matches on @extra_pats@, followed by a match on the+-- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@+-- and its arguments, applying an expression (from @insides@) to each of the+-- respective arguments of @con@.+mkSimpleConClause :: Quasi q+ => (Name -> [DExp] -> DExp)+ -> [DPat]+ -> DCon+ -> [DExp]+ -> q DClause+mkSimpleConClause fold extra_pats (DCon _ _ con_name _ _) insides = do+ vars_needed <- replicateM (length insides) $ newUniqueName "a"+ let pat = DConP con_name [] (map DVarP vars_needed)+ rhs = fold con_name (zipWith (\i v -> i `DAppE` DVarE v) insides vars_needed)+ pure $ DClause (extra_pats ++ [pat]) rhs++-- 'True' if the derived class's last argument is of kind (Type -> Type),+-- and thus needs a different constraint inference approach.+--+-- Really, we should be determining this information by inspecting the kind+-- of the class being used. But that comes dangerously close to kind+-- inference territory, so for now we simply hardcode which stock derivable+-- classes are Functor-like.+isFunctorLikeClassName :: Name -> Bool+isFunctorLikeClassName class_name+ = class_name `elem` [functorName, foldableName, traversableName]
src/Data/Singletons/TH/Names.hs view
@@ -1,269 +1,274 @@-{-# LANGUAGE TemplateHaskellQuotes #-} - -{- Data/Singletons/TH/Names.hs - -(c) Richard Eisenberg 2014 -rae@cs.brynmawr.edu - -Defining names and manipulations on names for use in promotion and singling. --} - -module Data.Singletons.TH.Names where - -import Data.Singletons -import Data.Singletons.Decide -import Data.Singletons.ShowSing -import Data.Singletons.TH.SuppressUnusedWarnings -import Data.Singletons.TH.Util -import Language.Haskell.TH.Syntax -import Language.Haskell.TH.Desugar -import GHC.TypeLits ( Symbol ) -import GHC.Exts ( Constraint ) -import GHC.Show ( showCommaSpace, showSpace ) -import Data.String (fromString) -import Data.Type.Equality ( TestEquality(..) ) -import Data.Type.Coercion ( TestCoercion(..) ) - -{- -Note [Wired-in Names] -~~~~~~~~~~~~~~~~~~~~~ -The list of Names below contains everything that the Template Haskell machinery -needs to have special knowledge of. These names can be broadly categorized into -two groups: - -1. Names of basic singleton definitions (Sing, SingKind, etc.). These are - spliced directly into TH-generated code. -2. Names of definitions from the Prelude. These are not spliced into - TH-generated code, but are instead used as the namesakes for promoted and - singled definitions. For example, the TH machinery must be aware of the Name - `fromInteger` so that it can promote and single the expression `42` to - `FromInteger 42` and `sFromInteger (sing @42)`, respectively. - -Note that we deliberately do not wire in promoted or singled Names, such as -FromInteger or sFromInteger, for two reasons: - -a. We want all promoted and singled names to go through the naming options in - D.S.TH.Options. Splicing the name FromInteger directly into TH-generated - code, for instance, would prevent users from overriding the default options - in order to promote `fromInteger` to something else (e.g., - MyCustomFromInteger). -b. Wired in names live in particular modules, so if we were to wire in the name - FromInteger, it would come from GHC.Num.Singletons. This would effectively - prevent anyone from defining their own version of FromInteger and - piggybacking on top of the TH machinery to generate it, however. As a - result, we generate the name FromInteger completely unqualified so that - it picks up whichever version of FromInteger is in scope. --} - -boolName, andName, compareName, minBoundName, - maxBoundName, repName, - nilName, consName, listName, tyFunArrowName, - applyName, applyTyConName, applyTyConAux1Name, - symbolName, stringName, - eqName, ordName, boundedName, orderingName, - singFamilyName, singIName, singI1Name, singI2Name, - singMethName, liftSingName, liftSing2Name, demoteName, withSingIName, - singKindClassName, someSingTypeName, someSingDataName, - sDecideClassName, sDecideMethName, - testEqualityClassName, testEqualityMethName, decideEqualityName, - testCoercionClassName, testCoercionMethName, decideCoercionName, - provedName, disprovedName, reflName, toSingName, fromSingName, - equalityName, applySingName, suppressClassName, suppressMethodName, - sameKindName, fromIntegerName, negateName, - errorName, foldlName, cmpEQName, cmpLTName, cmpGTName, - toEnumName, fromEnumName, enumName, - equalsName, constraintName, - showName, showSName, showCharName, showCommaSpaceName, showParenName, showsPrecName, - showSpaceName, showStringName, showSingName, - composeName, gtName, fromStringName, - foldableName, foldMapName, memptyName, mappendName, sappendName, foldrName, - functorName, fmapName, replaceName, - traversableName, traverseName, pureName, apName, liftA2Name :: Name -boolName = ''Bool -andName = '(&&) -compareName = 'compare -minBoundName = 'minBound -maxBoundName = 'maxBound -repName = mkName "Rep" -- this is actually defined in client code! -nilName = '[] -consName = '(:) -listName = ''[] -tyFunArrowName = ''(~>) -applyName = ''Apply -applyTyConName = ''ApplyTyCon -applyTyConAux1Name = ''ApplyTyConAux1 -symbolName = ''Symbol -stringName = ''String -eqName = ''Eq -ordName = ''Ord -boundedName = ''Bounded -orderingName = ''Ordering -singFamilyName = ''Sing -singIName = ''SingI -singI1Name = ''SingI1 -singI2Name = ''SingI2 -singMethName = 'sing -liftSingName = 'liftSing -liftSing2Name = 'liftSing2 -toSingName = 'toSing -fromSingName = 'fromSing -demoteName = ''Demote -withSingIName = 'withSingI -singKindClassName = ''SingKind -someSingTypeName = ''SomeSing -someSingDataName = 'SomeSing -sDecideClassName = ''SDecide -sDecideMethName = '(%~) -testEqualityClassName = ''TestEquality -testEqualityMethName = 'testEquality -decideEqualityName = 'decideEquality -testCoercionClassName = ''TestCoercion -testCoercionMethName = 'testCoercion -decideCoercionName = 'decideCoercion -provedName = 'Proved -disprovedName = 'Disproved -reflName = 'Refl -equalityName = ''(~) -applySingName = 'applySing -suppressClassName = ''SuppressUnusedWarnings -suppressMethodName = 'suppressUnusedWarnings -sameKindName = ''SameKind -fromIntegerName = 'fromInteger -negateName = 'negate -errorName = 'error -foldlName = 'foldl -cmpEQName = 'EQ -cmpLTName = 'LT -cmpGTName = 'GT -toEnumName = 'toEnum -fromEnumName = 'fromEnum -enumName = ''Enum -equalsName = '(==) -constraintName = ''Constraint -showName = ''Show -showSName = ''ShowS -showCharName = 'showChar -showParenName = 'showParen -showSpaceName = 'showSpace -showsPrecName = 'showsPrec -showStringName = 'showString -showSingName = ''ShowSing -composeName = '(.) -gtName = '(>) -showCommaSpaceName = 'showCommaSpace -fromStringName = 'fromString -foldableName = ''Foldable -foldMapName = 'foldMap -memptyName = 'mempty -mappendName = 'mappend -sappendName = '(<>) -foldrName = 'foldr -functorName = ''Functor -fmapName = 'fmap -replaceName = '(<$) -traversableName = ''Traversable -traverseName = 'traverse -pureName = 'pure -apName = '(<*>) -liftA2Name = 'liftA2 - -mkTyName :: Quasi q => Name -> q Name -mkTyName tmName = do - let nameStr = nameBase tmName - symbolic = not (isHsLetter (head nameStr)) - qNewName (if symbolic then "ty" else nameStr) - -mkTyConName :: Int -> Name -mkTyConName i = mkName $ "TyCon" ++ show i - -mkSingIName :: Int -> Name -mkSingIName 0 = singIName -mkSingIName 1 = singI1Name -mkSingIName 2 = singI2Name -mkSingIName n = error $ "SingI" ++ show n ++ " does not exist" - -mkSingMethName :: Int -> Name -mkSingMethName 0 = singMethName -mkSingMethName 1 = liftSingName -mkSingMethName 2 = liftSing2Name -mkSingMethName n = error $ "SingI" ++ show n ++ " does not exist" - -boolKi :: DKind -boolKi = DConT boolName - -singFamily :: DType -singFamily = DConT singFamilyName - -singKindConstraint :: DKind -> DPred -singKindConstraint = DAppT (DConT singKindClassName) - -demote :: DType -demote = DConT demoteName - -apply :: DType -> DType -> DType -apply t1 t2 = DAppT (DAppT (DConT applyName) t1) t2 - -mkListE :: [DExp] -> DExp -mkListE = - foldr (\h t -> DConE consName `DAppE` h `DAppE` t) (DConE nilName) - --- apply a type to a list of types using Apply type family --- This is defined here, not in Utils, to avoid cyclic dependencies -foldApply :: DType -> [DType] -> DType -foldApply = foldl apply - --- make an equality predicate -mkEqPred :: DType -> DType -> DPred -mkEqPred ty1 ty2 = foldType (DConT equalityName) [ty1, ty2] - --- | If a 'String' begins with one or more underscores, return --- @'Just' (us, rest)@, where @us@ contain all of the underscores at the --- beginning of the 'String' and @rest@ contains the remainder of the 'String'. --- Otherwise, return 'Nothing'. -splitUnderscores :: String -> Maybe (String, String) -splitUnderscores s = case span (== '_') s of - ([], _) -> Nothing - res -> Just res - --- Walk a DType, applying a function to all occurrences of constructor names. -modifyConNameDType :: (Name -> Name) -> DType -> DType -modifyConNameDType mod_con_name = go - where - go :: DType -> DType - go (DForallT tele p) = DForallT tele (go p) - go (DConstrainedT cxt p) = DConstrainedT (map go cxt) (go p) - go (DAppT p t) = DAppT (go p) t - go (DAppKindT p k) = DAppKindT (go p) k - go (DSigT p k) = DSigT (go p) k - go p@(DVarT _) = p - go (DConT n) = DConT (mod_con_name n) - go p@DWildCardT = p - go p@(DLitT {}) = p - go p@DArrowT = p - -{- -Note [Defunctionalization symbol suffixes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Before, we used to denote defunctionalization symbols by simply appending dollar -signs at the end (e.g., (+$) and (+$$)). But this can lead to ambiguity when you -have function names that consist of solely $ characters. For instance, if you -tried to promote ($) and ($$) simultaneously, you'd get these promoted types: - -$ -$$ - -And these defunctionalization symbols: - -$$ -$$$ - -But now there's a name clash between the promoted type for ($) and the -defunctionalization symbol for ($$)! The solution is to use a precede these -defunctionalization dollar signs with another string (we choose @#@). -So now the new defunctionalization symbols would be: - -$@#@$ -$@#@$$ - -And there is no conflict. --} +{-# LANGUAGE TemplateHaskellQuotes #-}++{- Data/Singletons/TH/Names.hs++(c) Richard Eisenberg 2014+rae@cs.brynmawr.edu++Defining names and manipulations on names for use in promotion and singling.+-}++module Data.Singletons.TH.Names where++import Data.Singletons+import Data.Singletons.Decide+import Data.Singletons.ShowSing+import Data.Singletons.TH.SuppressUnusedWarnings+import Data.Singletons.TH.Util+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Desugar+import GHC.TypeLits ( Symbol )+import GHC.Exts ( Constraint )+import GHC.Show ( showCommaSpace, showSpace )+import Data.String (fromString)+import Data.Type.Equality ( TestEquality(..) )+import Data.Type.Coercion ( TestCoercion(..) )++{-+Note [Wired-in Names]+~~~~~~~~~~~~~~~~~~~~~+The list of Names below contains everything that the Template Haskell machinery+needs to have special knowledge of. These names can be broadly categorized into+two groups:++1. Names of basic singleton definitions (Sing, SingKind, etc.). These are+ spliced directly into TH-generated code.+2. Names of definitions from the Prelude. These are not spliced into+ TH-generated code, but are instead used as the namesakes for promoted and+ singled definitions. For example, the TH machinery must be aware of the Name+ `fromInteger` so that it can promote and single the expression `42` to+ `FromInteger 42` and `sFromInteger (sing @42)`, respectively.++Note that we deliberately do not wire in promoted or singled Names, such as+FromInteger or sFromInteger, for two reasons:++a. We want all promoted and singled names to go through the naming options in+ D.S.TH.Options. Splicing the name FromInteger directly into TH-generated+ code, for instance, would prevent users from overriding the default options+ in order to promote `fromInteger` to something else (e.g.,+ MyCustomFromInteger).+b. Wired in names live in particular modules, so if we were to wire in the name+ FromInteger, it would come from GHC.Num.Singletons. This would effectively+ prevent anyone from defining their own version of FromInteger and+ piggybacking on top of the TH machinery to generate it, however. As a+ result, we generate the name FromInteger completely unqualified so that+ it picks up whichever version of FromInteger is in scope.+-}++boolName, andName, compareName, minBoundName,+ maxBoundName, repName,+ nilName, consName, listName, tyFunArrowName,+ applyName, applyTyConName, applyTyConAux1Name,+ symbolName, stringName,+ eqName, ordName, boundedName, orderingName,+ singFamilyName, singIName, singI1Name, singI2Name,+ singMethName, liftSingName, liftSing2Name, demoteName, withSingIName,+ singKindClassName, someSingTypeName, someSingDataName,+ sDecideClassName, sDecideMethName,+ testEqualityClassName, testEqualityMethName, decideEqualityName,+ testCoercionClassName, testCoercionMethName, decideCoercionName,+ provedName, disprovedName, reflName, toSingName, fromSingName,+ equalityName, applySingName, suppressClassName, suppressMethodName,+ sameKindName, fromIntegerName, negateName,+ errorName, foldlName, cmpEQName, cmpLTName, cmpGTName,+ toEnumName, fromEnumName, enumName,+ equalsName, constraintName,+ showName, showSName, showCharName, showCommaSpaceName, showParenName, showsPrecName,+ showSpaceName, showStringName, showSingName,+ composeName, gtName, fromStringName,+ foldableName, foldMapName, memptyName, mappendName, sappendName, foldrName,+ functorName, fmapName, replaceName,+ traversableName, traverseName, pureName, apName, liftA2Name :: Name+boolName = ''Bool+andName = '(&&)+compareName = 'compare+minBoundName = 'minBound+maxBoundName = 'maxBound+repName = mkName "Rep" -- this is actually defined in client code!+nilName = '[]+consName = '(:)+listName = ''[]+tyFunArrowName = ''(~>)+applyName = ''Apply+applyTyConName = ''ApplyTyCon+applyTyConAux1Name = ''ApplyTyConAux1+symbolName = ''Symbol+stringName = ''String+eqName = ''Eq+ordName = ''Ord+boundedName = ''Bounded+orderingName = ''Ordering+singFamilyName = ''Sing+singIName = ''SingI+singI1Name = ''SingI1+singI2Name = ''SingI2+singMethName = 'sing+liftSingName = 'liftSing+liftSing2Name = 'liftSing2+toSingName = 'toSing+fromSingName = 'fromSing+demoteName = ''Demote+withSingIName = 'withSingI+singKindClassName = ''SingKind+someSingTypeName = ''SomeSing+someSingDataName = 'SomeSing+sDecideClassName = ''SDecide+sDecideMethName = '(%~)+testEqualityClassName = ''TestEquality+testEqualityMethName = 'testEquality+decideEqualityName = 'decideEquality+testCoercionClassName = ''TestCoercion+testCoercionMethName = 'testCoercion+decideCoercionName = 'decideCoercion+provedName = 'Proved+disprovedName = 'Disproved+reflName = 'Refl+equalityName = ''(~)+applySingName = 'applySing+suppressClassName = ''SuppressUnusedWarnings+suppressMethodName = 'suppressUnusedWarnings+sameKindName = ''SameKind+fromIntegerName = 'fromInteger+negateName = 'negate+errorName = 'error+foldlName = 'foldl+cmpEQName = 'EQ+cmpLTName = 'LT+cmpGTName = 'GT+toEnumName = 'toEnum+fromEnumName = 'fromEnum+enumName = ''Enum+equalsName = '(==)+constraintName = ''Constraint+showName = ''Show+showSName = ''ShowS+showCharName = 'showChar+showParenName = 'showParen+showSpaceName = 'showSpace+showsPrecName = 'showsPrec+showStringName = 'showString+showSingName = ''ShowSing+composeName = '(.)+gtName = '(>)+showCommaSpaceName = 'showCommaSpace+fromStringName = 'fromString+foldableName = ''Foldable+foldMapName = 'foldMap+memptyName = 'mempty+mappendName = 'mappend+sappendName = '(<>)+foldrName = 'foldr+functorName = ''Functor+fmapName = 'fmap+replaceName = '(<$)+traversableName = ''Traversable+traverseName = 'traverse+pureName = 'pure+apName = '(<*>)+liftA2Name = 'liftA2++-- | Return a fresh alphanumeric 'Name'. In particular, if the supplied 'Name'+-- is symbolic (e.g., (%%)), then return a fresh 'Name' with the 'OccName' @ty@.+-- Otherwise, return a fresh 'Name' with the same 'OccName' as the supplied+-- 'Name'. See @Note [Tracking local variables]@ in+-- "Data.Singletons.TH.Promote.Monad" for why we do this.+mkTyName :: Quasi q => Name -> q Name+mkTyName tmName = do+ let nameStr = nameBase tmName+ symbolic = not (isHsLetter (headNameStr nameStr))+ qNewName (if symbolic then "ty" else nameStr)++mkTyConName :: Int -> Name+mkTyConName i = mkName $ "TyCon" ++ show i++mkSingIName :: Int -> Name+mkSingIName 0 = singIName+mkSingIName 1 = singI1Name+mkSingIName 2 = singI2Name+mkSingIName n = error $ "SingI" ++ show n ++ " does not exist"++mkSingMethName :: Int -> Name+mkSingMethName 0 = singMethName+mkSingMethName 1 = liftSingName+mkSingMethName 2 = liftSing2Name+mkSingMethName n = error $ "SingI" ++ show n ++ " does not exist"++boolKi :: DKind+boolKi = DConT boolName++singFamily :: DType+singFamily = DConT singFamilyName++singKindConstraint :: DKind -> DPred+singKindConstraint = DAppT (DConT singKindClassName)++demote :: DType+demote = DConT demoteName++apply :: DType -> DType -> DType+apply t1 t2 = DAppT (DAppT (DConT applyName) t1) t2++mkListE :: [DExp] -> DExp+mkListE =+ foldr (\h t -> DConE consName `DAppE` h `DAppE` t) (DConE nilName)++-- apply a type to a list of types using Apply type family+-- This is defined here, not in Utils, to avoid cyclic dependencies+foldApply :: DType -> [DType] -> DType+foldApply = foldl apply++-- make an equality predicate+mkEqPred :: DType -> DType -> DPred+mkEqPred ty1 ty2 = foldType (DConT equalityName) [ty1, ty2]++-- | If a 'String' begins with one or more underscores, return+-- @'Just' (us, rest)@, where @us@ contain all of the underscores at the+-- beginning of the 'String' and @rest@ contains the remainder of the 'String'.+-- Otherwise, return 'Nothing'.+splitUnderscores :: String -> Maybe (String, String)+splitUnderscores s = case span (== '_') s of+ ([], _) -> Nothing+ res -> Just res++-- Walk a DType, applying a function to all occurrences of constructor names.+modifyConNameDType :: (Name -> Name) -> DType -> DType+modifyConNameDType mod_con_name = go+ where+ go :: DType -> DType+ go (DForallT tele p) = DForallT tele (go p)+ go (DConstrainedT cxt p) = DConstrainedT (map go cxt) (go p)+ go (DAppT p t) = DAppT (go p) t+ go (DAppKindT p k) = DAppKindT (go p) k+ go (DSigT p k) = DSigT (go p) k+ go p@(DVarT _) = p+ go (DConT n) = DConT (mod_con_name n)+ go p@DWildCardT = p+ go p@(DLitT {}) = p+ go p@DArrowT = p++{-+Note [Defunctionalization symbol suffixes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Before, we used to denote defunctionalization symbols by simply appending dollar+signs at the end (e.g., (+$) and (+$$)). But this can lead to ambiguity when you+have function names that consist of solely $ characters. For instance, if you+tried to promote ($) and ($$) simultaneously, you'd get these promoted types:++$+$$++And these defunctionalization symbols:++$$+$$$++But now there's a name clash between the promoted type for ($) and the+defunctionalization symbol for ($$)! The solution is to use a precede these+defunctionalization dollar signs with another string (we choose @#@).+So now the new defunctionalization symbols would be:++$@#@$+$@#@$$++And there is no conflict.+-}
src/Data/Singletons/TH/Options.hs view
@@ -1,341 +1,341 @@------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TH.Options --- Copyright : (C) 2019 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- This module defines 'Options' that control finer details of how the Template --- Haskell machinery works, as well as an @mtl@-like 'OptionsMonad' class --- and an 'OptionsM' monad transformer. --- ----------------------------------------------------------------------------- - -module Data.Singletons.TH.Options - ( -- * Options - Options, defaultOptions - -- ** Options record selectors - , genQuotedDecs - , genSingKindInsts - , promotedDataTypeOrConName - , promotedClassName - , promotedValueName - , singledDataTypeName - , singledClassName - , singledDataConName - , singledValueName - , defunctionalizedName - -- ** Derived functions over Options - , promotedTopLevelValueName - , promotedLetBoundValueName - , defunctionalizedName0 - - -- * OptionsMonad - , OptionsMonad(..), OptionsM, withOptions - ) where - -import Control.Applicative -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Reader (ReaderT(..), ask) -import Control.Monad.RWS (RWST) -import Control.Monad.State (StateT) -import Control.Monad.Trans.Class (MonadTrans(..)) -import Control.Monad.Writer (WriterT) -import Data.Singletons.TH.Names -import Data.Singletons.TH.Util -import Language.Haskell.TH.Desugar -import Language.Haskell.TH.Instances () -- To obtain a Quote instance for ReaderT -import Language.Haskell.TH.Syntax hiding (Lift(..)) - --- | Options that control the finer details of how @singletons-th@'s Template --- Haskell machinery works. -data Options = Options - { genQuotedDecs :: Bool - -- ^ If 'True', then quoted declarations will be generated alongside their - -- promoted and singled counterparts. If 'False', then quoted - -- declarations will be discarded. - , genSingKindInsts :: Bool - -- ^ If 'True', then 'SingKind' instances will be generated. If 'False', - -- they will be omitted entirely. This can be useful in scenarios where - -- TH-generated 'SingKind' instances do not typecheck (for instance, - -- when generating singletons for GADTs). - , promotedDataTypeOrConName :: Name -> Name - -- ^ Given the name of the original data type or data constructor, produces - -- the name of the promoted equivalent. Unlike the singling-related - -- options, in which there are separate 'singledDataTypeName' and - -- 'singledDataConName' functions, we combine the handling of promoted - -- data types and data constructors into a single option. This is because - -- the names of promoted data types and data constructors can be - -- difficult to distinguish in certain contexts without expensive - -- compile-time checks. - -- - -- Because of the @DataKinds@ extension, most data type and data - -- constructor names can be used in promoted contexts without any - -- changes. As a result, this option will act like the identity function - -- 99% of the time. There are some situations where it can be useful to - -- override this option, however, as it can be used to promote primitive - -- data types that do not have proper type-level equivalents, such as - -- 'Natural' and 'Text'. See the - -- \"Arrows, 'Nat', 'Symbol', and literals\" section of the @singletons@ - -- @<https://github.com/goldfirere/singletons/blob/master/README.md README>@ - -- for more details. - , promotedClassName :: Name -> Name - -- ^ Given the name of the original, unrefined class, produces the name of - -- the promoted equivalent of the class. - , promotedValueName :: Name -> Maybe Uniq -> Name - -- ^ Given the name of the original, unrefined value, produces the name of - -- the promoted equivalent of the value. This is used for both top-level - -- and @let@-bound names, and the difference is encoded in the - -- @'Maybe' 'Uniq'@ argument. If promoting a top-level name, the argument - -- is 'Nothing'. If promoting a @let@-bound name, the argument is - -- @Just uniq@, where @uniq@ is a globally unique number that can be used - -- to distinguish the name from other local definitions of the same name - -- (e.g., if two functions both use @let x = ... in x@). - , singledDataTypeName :: Name -> Name - -- ^ Given the name of the original, unrefined data type, produces the name - -- of the corresponding singleton type. - , singledClassName :: Name -> Name - -- ^ Given the name of the original, unrefined class, produces the name of - -- the singled equivalent of the class. - , singledDataConName :: Name -> Name - -- ^ Given the name of the original, unrefined data constructor, produces - -- the name of the corresponding singleton data constructor. - , singledValueName :: Name -> Name - -- ^ Given the name of the original, unrefined value, produces the name of - -- the singled equivalent of the value. - , defunctionalizedName :: Name -> Int -> Name - -- ^ Given the original name and the number of parameters it is applied to - -- (the 'Int' argument), produces a type-level function name that can be - -- partially applied when given the same number of parameters. - -- - -- Note that defunctionalization works over both term-level names - -- (producing symbols for the promoted name) and type-level names - -- (producing symbols directly for the name itself). As a result, this - -- callback is used for names in both the term and type namespaces. - } - --- | Sensible default 'Options'. --- --- 'genQuotedDecs' defaults to 'True'. --- That is, quoted declarations are generated alongside their promoted and --- singled counterparts. --- --- 'genSingKindInsts' defaults to 'True'. --- That is, 'SingKind' instances are generated. --- --- The default behaviors for 'promotedClassName', 'promotedValueNamePrefix', --- 'singledDataTypeName', 'singledClassName', 'singledDataConName', --- 'singledValueName', and 'defunctionalizedName' are described in the --- \"On names\" section of the @singletons@ --- @<https://github.com/goldfirere/singletons/blob/master/README.md README>@. -defaultOptions :: Options -defaultOptions = Options - { genQuotedDecs = True - , genSingKindInsts = True - , promotedDataTypeOrConName = promoteDataTypeOrConName - , promotedClassName = promoteClassName - , promotedValueName = promoteValNameLhs - , singledDataTypeName = singTyConName - , singledClassName = singClassName - , singledDataConName = singDataConName - , singledValueName = singValName - , defunctionalizedName = promoteTySym - } - --- | Given the name of the original, unrefined, top-level value, produces the --- name of the promoted equivalent of the value. -promotedTopLevelValueName :: Options -> Name -> Name -promotedTopLevelValueName opts name = promotedValueName opts name Nothing - --- | Given the name of the original, unrefined, @let@-bound value and its --- globally unique number, produces the name of the promoted equivalent of the --- value. -promotedLetBoundValueName :: Options -> Name -> Uniq -> Name -promotedLetBoundValueName opts name = promotedValueName opts name . Just - --- | Given the original name of a function (term- or type-level), produces a --- type-level function name that can be partially applied even without being --- given any arguments (i.e., @0@ arguments). -defunctionalizedName0 :: Options -> Name -> Name -defunctionalizedName0 opts name = defunctionalizedName opts name 0 - --- | Class that describes monads that contain 'Options'. -class DsMonad m => OptionsMonad m where - getOptions :: m Options - -instance OptionsMonad Q where - getOptions = pure defaultOptions - -instance OptionsMonad m => OptionsMonad (DsM m) where - getOptions = lift getOptions - -instance (OptionsMonad q, Monoid m) => OptionsMonad (QWithAux m q) where - getOptions = lift getOptions - -instance OptionsMonad m => OptionsMonad (ReaderT r m) where - getOptions = lift getOptions - -instance OptionsMonad m => OptionsMonad (StateT s m) where - getOptions = lift getOptions - -instance (OptionsMonad m, Monoid w) => OptionsMonad (WriterT w m) where - getOptions = lift getOptions - -instance (OptionsMonad m, Monoid w) => OptionsMonad (RWST r w s m) where - getOptions = lift getOptions - --- | A convenient implementation of the 'OptionsMonad' class. Use by calling --- 'withOptions'. -newtype OptionsM m a = OptionsM (ReaderT Options m a) - deriving ( Functor, Applicative, Monad, MonadTrans - , Quote, Quasi, MonadFail, MonadIO, DsMonad ) - --- | Turn any 'DsMonad' into an 'OptionsMonad'. -instance DsMonad m => OptionsMonad (OptionsM m) where - getOptions = OptionsM ask - --- | Declare the 'Options' that a TH computation should use. -withOptions :: Options -> OptionsM m a -> m a -withOptions opts (OptionsM x) = runReaderT x opts - --- Used when a value name appears in a pattern context. --- Works only for proper variables (lower-case names). --- --- If the Maybe Uniq argument is Nothing, then the name is top-level (and --- thus globally unique on its own). --- If the Maybe Uniq argument is `Just uniq`, then the name is let-bound and --- should use `uniq` to make the promoted name globally unique. -promoteValNameLhs :: Name -> Maybe Uniq -> Name -promoteValNameLhs n mb_let_uniq - -- We can't promote promote idenitifers beginning with underscores to - -- type names, so we work around the issue by prepending "US" at the - -- front of the name (#229). - | Just (us, rest) <- splitUnderscores (nameBase n) - = mkName $ alpha ++ "US" ++ us ++ rest - - | otherwise - = mkName $ toUpcaseStr pres n - where - pres = maybe noPrefix (uniquePrefixes "Let" "<<<") mb_let_uniq - (alpha, _) = pres - --- generates type-level symbol for a given name. Int parameter represents --- saturation: 0 - no parameters passed to the symbol, 1 - one parameter --- passed to the symbol, and so on. Works on both promoted and unpromoted --- names. -promoteTySym :: Name -> Int -> Name -promoteTySym name sat - -- We can't promote promote idenitifers beginning with underscores to - -- type names, so we work around the issue by prepending "US" at the - -- front of the name (#229). - | Just (us, rest) <- splitUnderscores (nameBase name) - = default_case (mkName $ "US" ++ us ++ rest) - - | name == nilName - = mkName $ "NilSym" ++ (show sat) - - -- Treat unboxed tuples like tuples. - -- See Note [Promoting and singling unboxed tuples]. - | Just degree <- tupleNameDegree_maybe name <|> - unboxedTupleNameDegree_maybe name - = mkName $ "Tuple" ++ show degree ++ "Sym" ++ show sat - - | otherwise - = default_case name - where - default_case :: Name -> Name - default_case name' = - let capped = toUpcaseStr noPrefix name' in - if isHsLetter (head capped) - then mkName (capped ++ "Sym" ++ (show sat)) - else mkName (capped ++ "@#@" -- See Note [Defunctionalization symbol suffixes] - ++ (replicate (sat + 1) '$')) - -promoteClassName :: Name -> Name -promoteClassName = prefixName "P" "#" - -promoteDataTypeOrConName :: Name -> Name -promoteDataTypeOrConName nm - | nameBase nm == nameBase repName = typeKindName - -- See Note [Promoting and singling unboxed tuples] - | Just degree <- unboxedTupleNameDegree_maybe nm - = if isDataName nm then tupleDataName degree else tupleTypeName degree - | otherwise = nm - where - -- Is this name a data constructor name? A 'False' answer means "unsure". - isDataName :: Name -> Bool - isDataName (Name _ (NameG DataName _ _)) = True - isDataName _ = False - --- Singletons - -singDataConName :: Name -> Name -singDataConName nm - | nm == nilName = mkName "SNil" - | nm == consName = mkName "SCons" - | Just degree <- tupleNameDegree_maybe nm = mkTupleName degree - -- See Note [Promoting and singling unboxed tuples] - | Just degree <- unboxedTupleNameDegree_maybe nm = mkTupleName degree - | otherwise = prefixConName "S" "%" nm - -singTyConName :: Name -> Name -singTyConName name - | name == listName = mkName "SList" - | Just degree <- tupleNameDegree_maybe name = mkTupleName degree - -- See Note [Promoting and singling unboxed tuples] - | Just degree <- unboxedTupleNameDegree_maybe name = mkTupleName degree - | otherwise = prefixName "S" "%" name - -mkTupleName :: Int -> Name -mkTupleName n = mkName $ "STuple" ++ show n - -singClassName :: Name -> Name -singClassName = singTyConName - -singValName :: Name -> Name -singValName n - -- Push the 's' past the underscores, as this lets us avoid some unused - -- variable warnings (#229). - | Just (us, rest) <- splitUnderscores (nameBase n) - = prefixName (us ++ "s") "%" $ mkName rest - | otherwise - = prefixName "s" "%" $ upcase n - -{- -Note [Promoting and singling unboxed tuples] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Unfortunately, today's GHC is not quite up to the task of promoting types -involving unboxed tuples. Consider this example: - - swapperino :: (# a, b #) -> (# b, a #) - -What would this look like when promoted? Presumably, it would have a kind -signature like this: - - type Swapperino :: (# a, b #) -> (# b, a #) - -Surprisingly, this won't kindcheck: - - error: - • Expecting a lifted type, but ‘(# a, b #)’ is unlifted - • In a standalone kind signature for ‘Swapperino’: - (# a, b #) -> (# b, a #) - -Even though (->) is levity polymorphic, this levity polymorphism only kicks in -for types, not kinds. In other words, the (->) in the kind of Swapperino is -completely levity monomorphic and only accepts Type-kinded arguments. This -oddity is tracked upstream as GHC#14180. Until that is fixed, there is no hope -of using promoted unboxed tuples freely in kinds. - -However, we don't have to give up quite yet. As a crude-but-effective -workaround, we can simply promote value-level unboxed tuples to type-level boxed -tuples. In other words, we would promote swapperino to this: - - type Swapperino :: (a, b) -> (b, a) - -This trick is enough to make many (but not all) uses of unboxed tuples -Just Work™ when promoted. We use a similar trick when singling unboxed tuples -as well. --} +-----------------------------------------------------------------------------+-- |+-- Module : Data.Singletons.TH.Options+-- Copyright : (C) 2019 Ryan Scott+-- License : BSD-style (see LICENSE)+-- Maintainer : Ryan Scott+-- Stability : experimental+-- Portability : non-portable+--+-- This module defines 'Options' that control finer details of how the Template+-- Haskell machinery works, as well as an @mtl@-like 'OptionsMonad' class+-- and an 'OptionsM' monad transformer.+--+----------------------------------------------------------------------------++module Data.Singletons.TH.Options+ ( -- * Options+ Options, defaultOptions+ -- ** Options record selectors+ , genQuotedDecs+ , genSingKindInsts+ , promotedDataTypeOrConName+ , promotedClassName+ , promotedValueName+ , singledDataTypeName+ , singledClassName+ , singledDataConName+ , singledValueName+ , defunctionalizedName+ -- ** Derived functions over Options+ , promotedTopLevelValueName+ , promotedLetBoundValueName+ , defunctionalizedName0++ -- * OptionsMonad+ , OptionsMonad(..), OptionsM, withOptions+ ) where++import Control.Applicative+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Reader (ReaderT(..), ask)+import Control.Monad.RWS (RWST)+import Control.Monad.State (StateT)+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Writer (WriterT)+import Data.Singletons.TH.Names+import Data.Singletons.TH.Util+import Language.Haskell.TH.Desugar+import Language.Haskell.TH.Instances () -- To obtain a Quote instance for ReaderT+import Language.Haskell.TH.Syntax hiding (Lift(..))++-- | Options that control the finer details of how @singletons-th@'s Template+-- Haskell machinery works.+data Options = Options+ { genQuotedDecs :: Bool+ -- ^ If 'True', then quoted declarations will be generated alongside their+ -- promoted and singled counterparts. If 'False', then quoted+ -- declarations will be discarded.+ , genSingKindInsts :: Bool+ -- ^ If 'True', then 'SingKind' instances will be generated. If 'False',+ -- they will be omitted entirely. This can be useful in scenarios where+ -- TH-generated 'SingKind' instances do not typecheck (for instance,+ -- when generating singletons for GADTs).+ , promotedDataTypeOrConName :: Name -> Name+ -- ^ Given the name of the original data type or data constructor, produces+ -- the name of the promoted equivalent. Unlike the singling-related+ -- options, in which there are separate 'singledDataTypeName' and+ -- 'singledDataConName' functions, we combine the handling of promoted+ -- data types and data constructors into a single option. This is because+ -- the names of promoted data types and data constructors can be+ -- difficult to distinguish in certain contexts without expensive+ -- compile-time checks.+ --+ -- Because of the @DataKinds@ extension, most data type and data+ -- constructor names can be used in promoted contexts without any+ -- changes. As a result, this option will act like the identity function+ -- 99% of the time. There are some situations where it can be useful to+ -- override this option, however, as it can be used to promote primitive+ -- data types that do not have proper type-level equivalents, such as+ -- 'Natural' and 'Text'. See the+ -- \"Arrows, 'Nat', 'Symbol', and literals\" section of the @singletons@+ -- @<https://github.com/goldfirere/singletons/blob/master/README.md README>@+ -- for more details.+ , promotedClassName :: Name -> Name+ -- ^ Given the name of the original, unrefined class, produces the name of+ -- the promoted equivalent of the class.+ , promotedValueName :: Name -> Maybe Uniq -> Name+ -- ^ Given the name of the original, unrefined value, produces the name of+ -- the promoted equivalent of the value. This is used for both top-level+ -- and @let@-bound names, and the difference is encoded in the+ -- @'Maybe' 'Uniq'@ argument. If promoting a top-level name, the argument+ -- is 'Nothing'. If promoting a @let@-bound name, the argument is+ -- @Just uniq@, where @uniq@ is a globally unique number that can be used+ -- to distinguish the name from other local definitions of the same name+ -- (e.g., if two functions both use @let x = ... in x@).+ , singledDataTypeName :: Name -> Name+ -- ^ Given the name of the original, unrefined data type, produces the name+ -- of the corresponding singleton type.+ , singledClassName :: Name -> Name+ -- ^ Given the name of the original, unrefined class, produces the name of+ -- the singled equivalent of the class.+ , singledDataConName :: Name -> Name+ -- ^ Given the name of the original, unrefined data constructor, produces+ -- the name of the corresponding singleton data constructor.+ , singledValueName :: Name -> Name+ -- ^ Given the name of the original, unrefined value, produces the name of+ -- the singled equivalent of the value.+ , defunctionalizedName :: Name -> Int -> Name+ -- ^ Given the original name and the number of parameters it is applied to+ -- (the 'Int' argument), produces a type-level function name that can be+ -- partially applied when given the same number of parameters.+ --+ -- Note that defunctionalization works over both term-level names+ -- (producing symbols for the promoted name) and type-level names+ -- (producing symbols directly for the name itself). As a result, this+ -- callback is used for names in both the term and type namespaces.+ }++-- | Sensible default 'Options'.+--+-- 'genQuotedDecs' defaults to 'True'.+-- That is, quoted declarations are generated alongside their promoted and+-- singled counterparts.+--+-- 'genSingKindInsts' defaults to 'True'.+-- That is, 'SingKind' instances are generated.+--+-- The default behaviors for 'promotedClassName', 'promotedValueNamePrefix',+-- 'singledDataTypeName', 'singledClassName', 'singledDataConName',+-- 'singledValueName', and 'defunctionalizedName' are described in the+-- \"On names\" section of the @singletons@+-- @<https://github.com/goldfirere/singletons/blob/master/README.md README>@.+defaultOptions :: Options+defaultOptions = Options+ { genQuotedDecs = True+ , genSingKindInsts = True+ , promotedDataTypeOrConName = promoteDataTypeOrConName+ , promotedClassName = promoteClassName+ , promotedValueName = promoteValNameLhs+ , singledDataTypeName = singTyConName+ , singledClassName = singClassName+ , singledDataConName = singDataConName+ , singledValueName = singValName+ , defunctionalizedName = promoteTySym+ }++-- | Given the name of the original, unrefined, top-level value, produces the+-- name of the promoted equivalent of the value.+promotedTopLevelValueName :: Options -> Name -> Name+promotedTopLevelValueName opts name = promotedValueName opts name Nothing++-- | Given the name of the original, unrefined, @let@-bound value and its+-- globally unique number, produces the name of the promoted equivalent of the+-- value.+promotedLetBoundValueName :: Options -> Name -> Uniq -> Name+promotedLetBoundValueName opts name = promotedValueName opts name . Just++-- | Given the original name of a function (term- or type-level), produces a+-- type-level function name that can be partially applied even without being+-- given any arguments (i.e., @0@ arguments).+defunctionalizedName0 :: Options -> Name -> Name+defunctionalizedName0 opts name = defunctionalizedName opts name 0++-- | Class that describes monads that contain 'Options'.+class DsMonad m => OptionsMonad m where+ getOptions :: m Options++instance OptionsMonad Q where+ getOptions = pure defaultOptions++instance OptionsMonad m => OptionsMonad (DsM m) where+ getOptions = lift getOptions++instance (OptionsMonad q, Monoid m) => OptionsMonad (QWithAux m q) where+ getOptions = lift getOptions++instance OptionsMonad m => OptionsMonad (ReaderT r m) where+ getOptions = lift getOptions++instance OptionsMonad m => OptionsMonad (StateT s m) where+ getOptions = lift getOptions++instance (OptionsMonad m, Monoid w) => OptionsMonad (WriterT w m) where+ getOptions = lift getOptions++instance (OptionsMonad m, Monoid w) => OptionsMonad (RWST r w s m) where+ getOptions = lift getOptions++-- | A convenient implementation of the 'OptionsMonad' class. Use by calling+-- 'withOptions'.+newtype OptionsM m a = OptionsM (ReaderT Options m a)+ deriving ( Functor, Applicative, Monad, MonadTrans+ , Quote, Quasi, MonadFail, MonadIO, DsMonad )++-- | Turn any 'DsMonad' into an 'OptionsMonad'.+instance DsMonad m => OptionsMonad (OptionsM m) where+ getOptions = OptionsM ask++-- | Declare the 'Options' that a TH computation should use.+withOptions :: Options -> OptionsM m a -> m a+withOptions opts (OptionsM x) = runReaderT x opts++-- Used when a value name appears in a pattern context.+-- Works only for proper variables (lower-case names).+--+-- If the Maybe Uniq argument is Nothing, then the name is top-level (and+-- thus globally unique on its own).+-- If the Maybe Uniq argument is `Just uniq`, then the name is let-bound and+-- should use `uniq` to make the promoted name globally unique.+promoteValNameLhs :: Name -> Maybe Uniq -> Name+promoteValNameLhs n mb_let_uniq+ -- We can't promote promote idenitifers beginning with underscores to+ -- type names, so we work around the issue by prepending "US" at the+ -- front of the name (#229).+ | Just (us, rest) <- splitUnderscores (nameBase n)+ = mkName $ alpha ++ "US" ++ us ++ rest++ | otherwise+ = mkName $ toUpcaseStr pres n+ where+ pres = maybe noPrefix (uniquePrefixes "Let" "<<<") mb_let_uniq+ (alpha, _) = pres++-- generates type-level symbol for a given name. Int parameter represents+-- saturation: 0 - no parameters passed to the symbol, 1 - one parameter+-- passed to the symbol, and so on. Works on both promoted and unpromoted+-- names.+promoteTySym :: Name -> Int -> Name+promoteTySym name sat+ -- We can't promote promote idenitifers beginning with underscores to+ -- type names, so we work around the issue by prepending "US" at the+ -- front of the name (#229).+ | Just (us, rest) <- splitUnderscores (nameBase name)+ = default_case (mkName $ "US" ++ us ++ rest)++ | name == nilName+ = mkName $ "NilSym" ++ (show sat)++ -- Treat unboxed tuples like tuples.+ -- See Note [Promoting and singling unboxed tuples].+ | Just degree <- tupleNameDegree_maybe name <|>+ unboxedTupleNameDegree_maybe name+ = mkName $ "Tuple" ++ show degree ++ "Sym" ++ show sat++ | otherwise+ = default_case name+ where+ default_case :: Name -> Name+ default_case name' =+ let capped = toUpcaseStr noPrefix name' in+ if isHsLetter (headNameStr capped)+ then mkName (capped ++ "Sym" ++ (show sat))+ else mkName (capped ++ "@#@" -- See Note [Defunctionalization symbol suffixes]+ ++ (replicate (sat + 1) '$'))++promoteClassName :: Name -> Name+promoteClassName = prefixName "P" "#"++promoteDataTypeOrConName :: Name -> Name+promoteDataTypeOrConName nm+ | nameBase nm == nameBase repName = typeKindName+ -- See Note [Promoting and singling unboxed tuples]+ | Just degree <- unboxedTupleNameDegree_maybe nm+ = if isDataName nm then tupleDataName degree else tupleTypeName degree+ | otherwise = nm+ where+ -- Is this name a data constructor name? A 'False' answer means "unsure".+ isDataName :: Name -> Bool+ isDataName (Name _ (NameG DataName _ _)) = True+ isDataName _ = False++-- Singletons++singDataConName :: Name -> Name+singDataConName nm+ | nm == nilName = mkName "SNil"+ | nm == consName = mkName "SCons"+ | Just degree <- tupleNameDegree_maybe nm = mkTupleName degree+ -- See Note [Promoting and singling unboxed tuples]+ | Just degree <- unboxedTupleNameDegree_maybe nm = mkTupleName degree+ | otherwise = prefixConName "S" "%" nm++singTyConName :: Name -> Name+singTyConName name+ | name == listName = mkName "SList"+ | Just degree <- tupleNameDegree_maybe name = mkTupleName degree+ -- See Note [Promoting and singling unboxed tuples]+ | Just degree <- unboxedTupleNameDegree_maybe name = mkTupleName degree+ | otherwise = prefixName "S" "%" name++mkTupleName :: Int -> Name+mkTupleName n = mkName $ "STuple" ++ show n++singClassName :: Name -> Name+singClassName = singTyConName++singValName :: Name -> Name+singValName n+ -- Push the 's' past the underscores, as this lets us avoid some unused+ -- variable warnings (#229).+ | Just (us, rest) <- splitUnderscores (nameBase n)+ = prefixName (us ++ "s") "%" $ mkName rest+ | otherwise+ = prefixName "s" "%" $ upcase n++{-+Note [Promoting and singling unboxed tuples]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Unfortunately, today's GHC is not quite up to the task of promoting types+involving unboxed tuples. Consider this example:++ swapperino :: (# a, b #) -> (# b, a #)++What would this look like when promoted? Presumably, it would have a kind+signature like this:++ type Swapperino :: (# a, b #) -> (# b, a #)++Surprisingly, this won't kindcheck:++ error:+ • Expecting a lifted type, but ‘(# a, b #)’ is unlifted+ • In a standalone kind signature for ‘Swapperino’:+ (# a, b #) -> (# b, a #)++Even though (->) is levity polymorphic, this levity polymorphism only kicks in+for types, not kinds. In other words, the (->) in the kind of Swapperino is+completely levity monomorphic and only accepts Type-kinded arguments. This+oddity is tracked upstream as GHC#14180. Until that is fixed, there is no hope+of using promoted unboxed tuples freely in kinds.++However, we don't have to give up quite yet. As a crude-but-effective+workaround, we can simply promote value-level unboxed tuples to type-level boxed+tuples. In other words, we would promote swapperino to this:++ type Swapperino :: (a, b) -> (b, a)++This trick is enough to make many (but not all) uses of unboxed tuples+Just Work™ when promoted. We use a similar trick when singling unboxed tuples+as well.+-}
src/Data/Singletons/TH/Partition.hs view
@@ -1,326 +1,333 @@------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TH.Partition --- Copyright : (C) 2015 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Partitions a list of declarations into its bits --- ----------------------------------------------------------------------------- - -module Data.Singletons.TH.Partition where - -import Prelude hiding ( exp ) -import Data.Singletons.TH.Deriving.Bounded -import Data.Singletons.TH.Deriving.Enum -import Data.Singletons.TH.Deriving.Eq -import Data.Singletons.TH.Deriving.Foldable -import Data.Singletons.TH.Deriving.Functor -import Data.Singletons.TH.Deriving.Ord -import Data.Singletons.TH.Deriving.Show -import Data.Singletons.TH.Deriving.Traversable -import Data.Singletons.TH.Deriving.Util -import Data.Singletons.TH.Names -import Data.Singletons.TH.Options -import Data.Singletons.TH.Syntax -import Data.Singletons.TH.Util -import Language.Haskell.TH.Syntax hiding (showName) -import Language.Haskell.TH.Ppr -import Language.Haskell.TH.Desugar -import qualified Language.Haskell.TH.Desugar.OMap.Strict as OMap -import Language.Haskell.TH.Desugar.OMap.Strict (OMap) - -import Control.Monad -import Data.Bifunctor (bimap) -import qualified Data.Map as Map -import Data.Map (Map) -import Data.Maybe - -data PartitionedDecs = - PDecs { pd_let_decs :: [DLetDec] - , pd_class_decs :: [UClassDecl] - , pd_instance_decs :: [UInstDecl] - , pd_data_decs :: [DataDecl] - , pd_ty_syn_decs :: [TySynDecl] - , pd_open_type_family_decs :: [OpenTypeFamilyDecl] - , pd_closed_type_family_decs :: [ClosedTypeFamilyDecl] - , pd_derived_eq_decs :: [DerivedEqDecl] - , pd_derived_show_decs :: [DerivedShowDecl] - } - -instance Semigroup PartitionedDecs where - PDecs a1 b1 c1 d1 e1 f1 g1 h1 i1 <> PDecs a2 b2 c2 d2 e2 f2 g2 h2 i2 = - PDecs (a1 <> a2) (b1 <> b2) (c1 <> c2) (d1 <> d2) (e1 <> e2) - (f1 <> f2) (g1 <> g2) (h1 <> h2) (i1 <> i2) - -instance Monoid PartitionedDecs where - mempty = PDecs mempty mempty mempty mempty mempty - mempty mempty mempty mempty - --- | Split up a @[DDec]@ into its pieces, extracting 'Ord' instances --- from deriving clauses -partitionDecs :: OptionsMonad m => [DDec] -> m PartitionedDecs -partitionDecs = concatMapM partitionDec - -partitionDec :: OptionsMonad m => DDec -> m PartitionedDecs -partitionDec (DLetDec (DPragmaD {})) = return mempty -partitionDec (DLetDec letdec) = return $ mempty { pd_let_decs = [letdec] } - -partitionDec (DDataD df _cxt name tvbs mk cons derivings) = do - all_tvbs <- buildDataDTvbs tvbs mk - let data_decl = DataDecl df name all_tvbs cons - derived_dec = mempty { pd_data_decs = [data_decl] } - derived_decs - <- mapM (\(strat, deriv_pred) -> - let etad_tvbs - | (DConT pred_name, _) <- unfoldDType deriv_pred - , isFunctorLikeClassName pred_name - -- If deriving Functor, Foldable, or Traversable, - -- we need to use one less type variable than we normally do. - = take (length all_tvbs - 1) all_tvbs - | otherwise - = all_tvbs - ty = foldTypeTvbs (DConT name) etad_tvbs - in partitionDeriving strat deriv_pred Nothing ty data_decl) - $ concatMap flatten_clause derivings - return $ mconcat $ derived_dec : derived_decs - where - flatten_clause :: DDerivClause -> [(Maybe DDerivStrategy, DPred)] - flatten_clause (DDerivClause strat preds) = - map (\p -> (strat, p)) preds - -partitionDec (DClassD cxt name tvbs fds decs) = do - (lde, otfs) <- concatMapM partitionClassDec decs - return $ mempty { pd_class_decs = [ClassDecl { cd_cxt = cxt - , cd_name = name - , cd_tvbs = tvbs - , cd_fds = fds - , cd_lde = lde - , cd_atfs = otfs}] } -partitionDec (DInstanceD _ _ cxt ty decs) = do - (defns, sigs) <- liftM (bimap catMaybes mconcat) $ - mapAndUnzipM partitionInstanceDec decs - (name, tys) <- split_app_tys [] ty - return $ mempty { pd_instance_decs = [InstDecl { id_cxt = cxt - , id_name = name - , id_arg_tys = tys - , id_sigs = sigs - , id_meths = defns }] } - where - split_app_tys acc (DAppT t1 t2) = split_app_tys (t2:acc) t1 - split_app_tys acc (DConT name) = return (name, acc) - split_app_tys acc (DSigT t _) = split_app_tys acc t - split_app_tys _ _ = fail $ "Illegal instance head: " ++ show ty -partitionDec (DRoleAnnotD {}) = return mempty -- ignore these -partitionDec (DTySynD name tvbs rhs) = - -- See Note [Partitioning, type synonyms, and type families] - pure $ mempty { pd_ty_syn_decs = [TySynDecl name tvbs rhs] } -partitionDec (DClosedTypeFamilyD tf_head _) = - -- See Note [Partitioning, type synonyms, and type families] - pure $ mempty { pd_closed_type_family_decs = [TypeFamilyDecl tf_head] } -partitionDec (DOpenTypeFamilyD tf_head) = - -- See Note [Partitioning, type synonyms, and type families] - pure $ mempty { pd_open_type_family_decs = [TypeFamilyDecl tf_head] } -partitionDec (DTySynInstD {}) = pure mempty - -- There's no need to track type family instances, since - -- we already record the type family itself separately. -partitionDec (DKiSigD {}) = pure mempty - -- There's no need to track standalone kind signatures, since we use - -- dsReifyType to look them up. -partitionDec (DStandaloneDerivD mb_strat _ ctxt ty) = - case unfoldDType ty of - (cls_pred_ty, cls_tys) - | let cls_normal_tys = filterDTANormals cls_tys - , not (null cls_normal_tys) -- We can't handle zero-parameter type classes - , let cls_arg_tys = init cls_normal_tys - data_ty = last cls_normal_tys - data_ty_head = case unfoldDType data_ty of (ty_head, _) -> ty_head - , DConT data_tycon <- data_ty_head -- We can't handle deriving an instance for something - -- other than a type constructor application - -> do let cls_pred = foldType cls_pred_ty cls_arg_tys - dinfo <- dsReify data_tycon - case dinfo of - Just (DTyConI (DDataD df _ dn dtvbs dk dcons _) _) -> do - all_tvbs <- buildDataDTvbs dtvbs dk - let data_decl = DataDecl df dn all_tvbs dcons - partitionDeriving mb_strat cls_pred (Just ctxt) data_ty data_decl - Just _ -> - fail $ "Standalone derived instance for something other than a datatype: " - ++ show data_ty - _ -> fail $ "Cannot find " ++ show data_ty - _ -> return mempty -partitionDec dec = - fail $ "Declaration cannot be promoted: " ++ pprint (decToTH dec) - -partitionClassDec :: MonadFail m => DDec -> m (ULetDecEnv, [OpenTypeFamilyDecl]) -partitionClassDec (DLetDec (DSigD name ty)) = - pure (typeBinding name ty, mempty) -partitionClassDec (DLetDec (DValD (DVarP name) exp)) = - pure (valueBinding name (UValue exp), mempty) -partitionClassDec (DLetDec (DFunD name clauses)) = - pure (valueBinding name (UFunction clauses), mempty) -partitionClassDec (DLetDec (DInfixD fixity name)) = - pure (infixDecl fixity name, mempty) -partitionClassDec (DLetDec (DPragmaD {})) = - pure (mempty, mempty) -partitionClassDec (DOpenTypeFamilyD tf_head) = - -- See Note [Partitioning, type synonyms, and type families] - pure (mempty, [TypeFamilyDecl tf_head]) -partitionClassDec (DTySynInstD {}) = - -- There's no need to track associated type family default equations, since - -- we already record the type family itself separately. - pure (mempty, mempty) -partitionClassDec _ = - fail "Only method declarations can be promoted within a class." - -partitionInstanceDec :: MonadFail m => DDec - -> m ( Maybe (Name, ULetDecRHS) -- right-hand sides of methods - , OMap Name DType -- method type signatures - ) -partitionInstanceDec (DLetDec (DValD (DVarP name) exp)) = - pure (Just (name, UValue exp), mempty) -partitionInstanceDec (DLetDec (DFunD name clauses)) = - pure (Just (name, UFunction clauses), mempty) -partitionInstanceDec (DLetDec (DSigD name ty)) = - pure (Nothing, OMap.singleton name ty) -partitionInstanceDec (DLetDec (DPragmaD {})) = - pure (Nothing, mempty) -partitionInstanceDec (DTySynInstD {}) = - pure (Nothing, mempty) - -- There's no need to track associated type family instances, since - -- we already record the type family itself separately. -partitionInstanceDec _ = - fail "Only method bodies can be promoted within an instance." - -partitionDeriving - :: forall m. OptionsMonad m - => Maybe DDerivStrategy - -- ^ The deriving strategy, if present. - -> DPred -- ^ The class being derived (e.g., 'Eq'), possibly applied to - -- some number of arguments (e.g., @C Int Bool@). - -> Maybe DCxt -- ^ @'Just' ctx@ if @ctx@ was provided via @StandaloneDeriving@. - -- 'Nothing' if using a @deriving@ clause. - -> DType -- ^ The data type argument to the class. - -> DataDecl -- ^ The original data type information (e.g., its constructors). - -> m PartitionedDecs -partitionDeriving mb_strat deriv_pred mb_ctxt ty data_decl = - case unfoldDType deriv_pred of - (DConT deriv_name, arg_tys) - -- Here, we are more conservative than GHC: DeriveAnyClass only kicks - -- in if the user explicitly chooses to do so with the anyclass - -- deriving strategy - | Just DAnyclassStrategy <- mb_strat - -> return $ mk_derived_inst - InstDecl { id_cxt = fromMaybe [] mb_ctxt - -- For now at least, there's no point in attempting to - -- infer an instance context for DeriveAnyClass, since - -- the other language feature that requires it, - -- DefaultSignatures, can't be singled. Thus, inferring an - -- empty context will Just Work for all currently supported - -- default implementations. - -- - -- (Of course, if a user specifies a context with - -- StandaloneDeriving, use that.) - - , id_name = deriv_name - , id_arg_tys = filterDTANormals arg_tys ++ [ty] - , id_sigs = mempty - , id_meths = [] } - - | Just DNewtypeStrategy <- mb_strat - -> do qReportWarning "GeneralizedNewtypeDeriving is ignored by `singletons-th`." - return mempty - - | Just (DViaStrategy {}) <- mb_strat - -> do qReportWarning "DerivingVia is ignored by `singletons-th`." - return mempty - - -- Stock classes. These are derived only if `singletons-th` supports them - -- (and, optionally, if an explicit stock deriving strategy is used) - (DConT deriv_name, []) -- For now, all stock derivable class supported in - -- singletons-th take just one argument (the data - -- type itself) - | stock_or_default - , Just decs <- Map.lookup deriv_name stock_map - -> decs - - -- If we can't find a stock class, but the user bothered to use an - -- explicit stock keyword, we can at least warn them about it. - | Just DStockStrategy <- mb_strat - -> do qReportWarning $ "`singletons-th` doesn't recognize the stock class " - ++ nameBase deriv_name - return mempty - - _ -> return mempty -- singletons-th doesn't support deriving this instance - where - mk_instance :: DerivDesc m -> m UInstDecl - mk_instance maker = maker mb_ctxt ty data_decl - - mk_derived_inst dec = mempty { pd_instance_decs = [dec] } - - derived_decl :: DerivedDecl cls - derived_decl = DerivedDecl { ded_mb_cxt = mb_ctxt - , ded_type = ty - , ded_type_tycon = ty_tycon - , ded_decl = data_decl } - where - ty_tycon :: Name - ty_tycon = case unfoldDType ty of - (DConT tc, _) -> tc - (t, _) -> error $ "Not a data type: " ++ show t - stock_or_default = isStockOrDefault mb_strat - - -- A mapping from all stock derivable classes (that singletons-th supports) - -- to to derived code that they produce. - stock_map :: Map Name (m PartitionedDecs) - stock_map = Map.fromList - [ ( ordName, mk_derived_inst <$> mk_instance mkOrdInstance ) - , ( boundedName, mk_derived_inst <$> mk_instance mkBoundedInstance ) - , ( enumName, mk_derived_inst <$> mk_instance mkEnumInstance ) - , ( functorName, mk_derived_inst <$> mk_instance mkFunctorInstance ) - , ( foldableName, mk_derived_inst <$> mk_instance mkFoldableInstance ) - , ( traversableName, mk_derived_inst <$> mk_instance mkTraversableInstance ) - - -- See Note [DerivedDecl] in Data.Singletons.TH.Syntax - , ( eqName, do -- These will become PEq/SEq instances... - inst_for_promotion <- mk_instance mkEqInstance - -- ...and these will become SDecide/TestEquality/TestCoercion instances. - let inst_for_decide = derived_decl - return $ mempty { pd_instance_decs = [inst_for_promotion] - , pd_derived_eq_decs = [inst_for_decide] } ) - , ( showName, do -- These will become PShow/SShow instances... - inst_for_promotion <- mk_instance mkShowInstance - -- ...and this will become a Show instance. - let inst_for_show = derived_decl - pure $ mempty { pd_instance_decs = [inst_for_promotion] - , pd_derived_show_decs = [inst_for_show] } ) - ] - --- Is this being used with an explicit stock strategy, or no strategy at all? -isStockOrDefault :: Maybe DDerivStrategy -> Bool -isStockOrDefault Nothing = True -isStockOrDefault (Just DStockStrategy) = True -isStockOrDefault (Just _) = False - -{- -Note [Partitioning, type synonyms, and type families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The process of singling does not produce any new declarations corresponding to -type synonyms or type families, so they are "ignored" in a sense. Nevertheless, -we explicitly track them during partitioning, since we want to create -defunctionalization symbols for them. - -Also note that: - -1. Other uses of type synonyms in singled code will be expanded away. -2. Other uses of type families in singled code are unlikely to work at present - due to Trac #12564. -3. We track open type families, closed type families, and associated type - families separately, as each form of type family has different kind - inference behavior. See defunTopLevelTypeDecls and - defunAssociatedTypeFamilies in D.S.TH.Promote.Defun for how these differences - manifest. --} +-----------------------------------------------------------------------------+-- |+-- Module : Data.Singletons.TH.Partition+-- Copyright : (C) 2015 Richard Eisenberg+-- License : BSD-style (see LICENSE)+-- Maintainer : Ryan Scott+-- Stability : experimental+-- Portability : non-portable+--+-- Partitions a list of declarations into its bits+--+----------------------------------------------------------------------------++module Data.Singletons.TH.Partition where++import Prelude hiding ( exp )+import Data.Singletons.TH.Deriving.Bounded+import Data.Singletons.TH.Deriving.Enum+import Data.Singletons.TH.Deriving.Eq+import Data.Singletons.TH.Deriving.Foldable+import Data.Singletons.TH.Deriving.Functor+import Data.Singletons.TH.Deriving.Ord+import Data.Singletons.TH.Deriving.Show+import Data.Singletons.TH.Deriving.Traversable+import Data.Singletons.TH.Deriving.Util+import Data.Singletons.TH.Names+import Data.Singletons.TH.Options+import Data.Singletons.TH.Syntax+import Data.Singletons.TH.Util+import Language.Haskell.TH.Syntax hiding (showName)+import Language.Haskell.TH.Ppr+import Language.Haskell.TH.Desugar+import qualified Language.Haskell.TH.Desugar.OMap.Strict as OMap+import Language.Haskell.TH.Desugar.OMap.Strict (OMap)++import Control.Monad+import Data.Bifunctor (bimap)+import qualified Data.Map as Map+import Data.Map (Map)+import Data.Maybe++data PartitionedDecs =+ PDecs { pd_let_decs :: [DLetDec]+ , pd_class_decs :: [UClassDecl]+ , pd_instance_decs :: [UInstDecl]+ , pd_data_decs :: [DataDecl]+ , pd_ty_syn_decs :: [TySynDecl]+ , pd_open_type_family_decs :: [OpenTypeFamilyDecl]+ , pd_closed_type_family_decs :: [ClosedTypeFamilyDecl]+ , pd_derived_eq_decs :: [DerivedEqDecl]+ , pd_derived_ord_decs :: [DerivedOrdDecl]+ , pd_derived_show_decs :: [DerivedShowDecl]+ }++instance Semigroup PartitionedDecs where+ PDecs a1 b1 c1 d1 e1 f1 g1 h1 i1 j1 <> PDecs a2 b2 c2 d2 e2 f2 g2 h2 i2 j2 =+ PDecs (a1 <> a2) (b1 <> b2) (c1 <> c2) (d1 <> d2) (e1 <> e2)+ (f1 <> f2) (g1 <> g2) (h1 <> h2) (i1 <> i2) (j1 <> j2)++instance Monoid PartitionedDecs where+ mempty = PDecs mempty mempty mempty mempty mempty+ mempty mempty mempty mempty mempty++-- | Split up a @[DDec]@ into its pieces, extracting 'Ord' instances+-- from deriving clauses+partitionDecs :: OptionsMonad m => [DDec] -> m PartitionedDecs+partitionDecs = concatMapM partitionDec++partitionDec :: OptionsMonad m => DDec -> m PartitionedDecs+partitionDec (DLetDec (DPragmaD {})) = return mempty+partitionDec (DLetDec letdec) = return $ mempty { pd_let_decs = [letdec] }++partitionDec (DDataD df _cxt name tvbs mk cons derivings) = do+ all_tvbs <- buildDataDTvbs tvbs mk+ let data_decl = DataDecl df name all_tvbs cons+ derived_dec = mempty { pd_data_decs = [data_decl] }+ derived_decs+ <- mapM (\(strat, deriv_pred) ->+ let etad_tvbs+ | (DConT pred_name, _) <- unfoldDType deriv_pred+ , isFunctorLikeClassName pred_name+ -- If deriving Functor, Foldable, or Traversable,+ -- we need to use one less type variable than we normally do.+ = take (length all_tvbs - 1) all_tvbs+ | otherwise+ = all_tvbs+ ty = foldTypeTvbs (DConT name) etad_tvbs+ in partitionDeriving strat deriv_pred Nothing ty data_decl)+ $ concatMap flatten_clause derivings+ return $ mconcat $ derived_dec : derived_decs+ where+ flatten_clause :: DDerivClause -> [(Maybe DDerivStrategy, DPred)]+ flatten_clause (DDerivClause strat preds) =+ map (\p -> (strat, p)) preds++partitionDec (DClassD cxt name tvbs fds decs) = do+ (lde, otfs) <- concatMapM partitionClassDec decs+ return $ mempty { pd_class_decs = [ClassDecl { cd_cxt = cxt+ , cd_name = name+ , cd_tvbs = tvbs+ , cd_fds = fds+ , cd_lde = lde+ , cd_atfs = otfs}] }+partitionDec (DInstanceD _ _ cxt ty decs) = do+ (defns, sigs) <- liftM (bimap catMaybes mconcat) $+ mapAndUnzipM partitionInstanceDec decs+ (name, tys) <- split_app_tys [] ty+ return $ mempty { pd_instance_decs = [InstDecl { id_cxt = cxt+ , id_name = name+ , id_arg_tys = tys+ , id_sigs = sigs+ , id_meths = defns }] }+ where+ split_app_tys acc (DAppT t1 t2) = split_app_tys (t2:acc) t1+ split_app_tys acc (DConT name) = return (name, acc)+ split_app_tys acc (DSigT t _) = split_app_tys acc t+ split_app_tys _ _ = fail $ "Illegal instance head: " ++ show ty+partitionDec (DRoleAnnotD {}) = return mempty -- ignore these+partitionDec (DTySynD name tvbs rhs) =+ -- See Note [Partitioning, type synonyms, and type families]+ pure $ mempty { pd_ty_syn_decs = [TySynDecl name tvbs rhs] }+partitionDec (DClosedTypeFamilyD tf_head _) =+ -- See Note [Partitioning, type synonyms, and type families]+ pure $ mempty { pd_closed_type_family_decs = [TypeFamilyDecl tf_head] }+partitionDec (DOpenTypeFamilyD tf_head) =+ -- See Note [Partitioning, type synonyms, and type families]+ pure $ mempty { pd_open_type_family_decs = [TypeFamilyDecl tf_head] }+partitionDec (DTySynInstD {}) = pure mempty+ -- There's no need to track type family instances, since+ -- we already record the type family itself separately.+partitionDec (DKiSigD {}) = pure mempty+ -- There's no need to track standalone kind signatures, since we use+ -- dsReifyType to look them up.+partitionDec (DStandaloneDerivD mb_strat _ ctxt ty) =+ case unfoldDType ty of+ (cls_pred_ty, cls_tys)+ | let cls_normal_tys = filterDTANormals cls_tys+ , not (null cls_normal_tys) -- We can't handle zero-parameter type classes+ , let cls_arg_tys = init cls_normal_tys+ data_ty = last cls_normal_tys+ data_ty_head = case unfoldDType data_ty of (ty_head, _) -> ty_head+ , DConT data_tycon <- data_ty_head -- We can't handle deriving an instance for something+ -- other than a type constructor application+ -> do let cls_pred = foldType cls_pred_ty cls_arg_tys+ dinfo <- dsReify data_tycon+ case dinfo of+ Just (DTyConI (DDataD df _ dn dtvbs dk dcons _) _) -> do+ all_tvbs <- buildDataDTvbs dtvbs dk+ let data_decl = DataDecl df dn all_tvbs dcons+ partitionDeriving mb_strat cls_pred (Just ctxt) data_ty data_decl+ Just _ ->+ fail $ "Standalone derived instance for something other than a datatype: "+ ++ show data_ty+ _ -> fail $ "Cannot find " ++ show data_ty+ _ -> return mempty+partitionDec dec =+ fail $ "Declaration cannot be promoted: " ++ pprint (decToTH dec)++partitionClassDec :: MonadFail m => DDec -> m (ULetDecEnv, [OpenTypeFamilyDecl])+partitionClassDec (DLetDec (DSigD name ty)) =+ pure (typeBinding name ty, mempty)+partitionClassDec (DLetDec (DValD (DVarP name) exp)) =+ pure (valueBinding name (UValue exp), mempty)+partitionClassDec (DLetDec (DFunD name clauses)) =+ pure (valueBinding name (UFunction clauses), mempty)+partitionClassDec (DLetDec (DInfixD fixity name)) =+ pure (infixDecl fixity name, mempty)+partitionClassDec (DLetDec (DPragmaD {})) =+ pure (mempty, mempty)+partitionClassDec (DOpenTypeFamilyD tf_head) =+ -- See Note [Partitioning, type synonyms, and type families]+ pure (mempty, [TypeFamilyDecl tf_head])+partitionClassDec (DTySynInstD {}) =+ -- There's no need to track associated type family default equations, since+ -- we already record the type family itself separately.+ pure (mempty, mempty)+partitionClassDec _ =+ fail "Only method declarations can be promoted within a class."++partitionInstanceDec :: MonadFail m => DDec+ -> m ( Maybe (Name, ULetDecRHS) -- right-hand sides of methods+ , OMap Name DType -- method type signatures+ )+partitionInstanceDec (DLetDec (DValD (DVarP name) exp)) =+ pure (Just (name, UValue exp), mempty)+partitionInstanceDec (DLetDec (DFunD name clauses)) =+ pure (Just (name, UFunction clauses), mempty)+partitionInstanceDec (DLetDec (DSigD name ty)) =+ pure (Nothing, OMap.singleton name ty)+partitionInstanceDec (DLetDec (DPragmaD {})) =+ pure (Nothing, mempty)+partitionInstanceDec (DTySynInstD {}) =+ pure (Nothing, mempty)+ -- There's no need to track associated type family instances, since+ -- we already record the type family itself separately.+partitionInstanceDec _ =+ fail "Only method bodies can be promoted within an instance."++partitionDeriving+ :: forall m. OptionsMonad m+ => Maybe DDerivStrategy+ -- ^ The deriving strategy, if present.+ -> DPred -- ^ The class being derived (e.g., 'Eq'), possibly applied to+ -- some number of arguments (e.g., @C Int Bool@).+ -> Maybe DCxt -- ^ @'Just' ctx@ if @ctx@ was provided via @StandaloneDeriving@.+ -- 'Nothing' if using a @deriving@ clause.+ -> DType -- ^ The data type argument to the class.+ -> DataDecl -- ^ The original data type information (e.g., its constructors).+ -> m PartitionedDecs+partitionDeriving mb_strat deriv_pred mb_ctxt ty data_decl =+ case unfoldDType deriv_pred of+ (DConT deriv_name, arg_tys)+ -- Here, we are more conservative than GHC: DeriveAnyClass only kicks+ -- in if the user explicitly chooses to do so with the anyclass+ -- deriving strategy+ | Just DAnyclassStrategy <- mb_strat+ -> return $ mk_derived_inst+ InstDecl { id_cxt = fromMaybe [] mb_ctxt+ -- For now at least, there's no point in attempting to+ -- infer an instance context for DeriveAnyClass, since+ -- the other language feature that requires it,+ -- DefaultSignatures, can't be singled. Thus, inferring an+ -- empty context will Just Work for all currently supported+ -- default implementations.+ --+ -- (Of course, if a user specifies a context with+ -- StandaloneDeriving, use that.)++ , id_name = deriv_name+ , id_arg_tys = filterDTANormals arg_tys ++ [ty]+ , id_sigs = mempty+ , id_meths = [] }++ | Just DNewtypeStrategy <- mb_strat+ -> do qReportWarning "GeneralizedNewtypeDeriving is ignored by `singletons-th`."+ return mempty++ | Just (DViaStrategy {}) <- mb_strat+ -> do qReportWarning "DerivingVia is ignored by `singletons-th`."+ return mempty++ -- Stock classes. These are derived only if `singletons-th` supports them+ -- (and, optionally, if an explicit stock deriving strategy is used)+ (DConT deriv_name, []) -- For now, all stock derivable class supported in+ -- singletons-th take just one argument (the data+ -- type itself)+ | stock_or_default+ , Just decs <- Map.lookup deriv_name stock_map+ -> decs++ -- If we can't find a stock class, but the user bothered to use an+ -- explicit stock keyword, we can at least warn them about it.+ | Just DStockStrategy <- mb_strat+ -> do qReportWarning $ "`singletons-th` doesn't recognize the stock class "+ ++ nameBase deriv_name+ return mempty++ _ -> return mempty -- singletons-th doesn't support deriving this instance+ where+ mk_instance :: DerivDesc m -> m UInstDecl+ mk_instance maker = maker mb_ctxt ty data_decl++ mk_derived_inst dec = mempty { pd_instance_decs = [dec] }++ derived_decl :: DerivedDecl cls+ derived_decl = DerivedDecl { ded_mb_cxt = mb_ctxt+ , ded_type = ty+ , ded_type_tycon = ty_tycon+ , ded_decl = data_decl }+ where+ ty_tycon :: Name+ ty_tycon = case unfoldDType ty of+ (DConT tc, _) -> tc+ (t, _) -> error $ "Not a data type: " ++ show t+ stock_or_default = isStockOrDefault mb_strat++ -- A mapping from all stock derivable classes (that singletons-th supports)+ -- to to derived code that they produce.+ stock_map :: Map Name (m PartitionedDecs)+ stock_map = Map.fromList+ [ ( ordName, mk_derived_inst <$> mk_instance mkOrdInstance )+ , ( boundedName, mk_derived_inst <$> mk_instance mkBoundedInstance )+ , ( enumName, mk_derived_inst <$> mk_instance mkEnumInstance )+ , ( functorName, mk_derived_inst <$> mk_instance mkFunctorInstance )+ , ( foldableName, mk_derived_inst <$> mk_instance mkFoldableInstance )+ , ( traversableName, mk_derived_inst <$> mk_instance mkTraversableInstance )++ -- See Note [DerivedDecl] in Data.Singletons.TH.Syntax+ , ( eqName, do -- These will become PEq/SEq instances...+ inst_for_promotion <- mk_instance mkEqInstance+ -- ...and these will become SDecide/Eq/TestEquality/TestCoercion instances.+ let inst_for_decide = derived_decl+ return $ mempty { pd_instance_decs = [inst_for_promotion]+ , pd_derived_eq_decs = [inst_for_decide] } )+ , ( ordName, do -- These will become POrd/SOrd instances...+ inst_for_promotion <- mk_instance mkOrdInstance+ -- ...and this will become an Ord instance.+ let inst_for_ord = derived_decl+ pure $ mempty { pd_instance_decs = [inst_for_promotion]+ , pd_derived_ord_decs = [inst_for_ord] } )+ , ( showName, do -- These will become PShow/SShow instances...+ inst_for_promotion <- mk_instance mkShowInstance+ -- ...and this will become a Show instance.+ let inst_for_show = derived_decl+ pure $ mempty { pd_instance_decs = [inst_for_promotion]+ , pd_derived_show_decs = [inst_for_show] } )+ ]++-- Is this being used with an explicit stock strategy, or no strategy at all?+isStockOrDefault :: Maybe DDerivStrategy -> Bool+isStockOrDefault Nothing = True+isStockOrDefault (Just DStockStrategy) = True+isStockOrDefault (Just _) = False++{-+Note [Partitioning, type synonyms, and type families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The process of singling does not produce any new declarations corresponding to+type synonyms or type families, so they are "ignored" in a sense. Nevertheless,+we explicitly track them during partitioning, since we want to create+defunctionalization symbols for them.++Also note that:++1. Other uses of type synonyms in singled code will be expanded away.+2. Other uses of type families in singled code are unlikely to work at present+ due to Trac #12564.+3. We track open type families, closed type families, and associated type+ families separately, as each form of type family has different kind+ inference behavior. See defunTopLevelTypeDecls and+ defunAssociatedTypeFamilies in D.S.TH.Promote.Defun for how these differences+ manifest.+-}
src/Data/Singletons/TH/Promote.hs view
@@ -1,1094 +1,1205 @@-{- Data/Singletons/TH/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-th package. --} - -module Data.Singletons.TH.Promote where - -import Language.Haskell.TH hiding ( Q, cxt ) -import Language.Haskell.TH.Syntax ( NameSpace(..), Quasi(..), Uniq ) -import Language.Haskell.TH.Desugar -import qualified Language.Haskell.TH.Desugar.OMap.Strict as OMap -import Language.Haskell.TH.Desugar.OMap.Strict (OMap) -import Data.Singletons.TH.Deriving.Bounded -import Data.Singletons.TH.Deriving.Enum -import Data.Singletons.TH.Deriving.Eq -import Data.Singletons.TH.Deriving.Ord -import Data.Singletons.TH.Deriving.Show -import Data.Singletons.TH.Deriving.Util -import Data.Singletons.TH.Names -import Data.Singletons.TH.Options -import Data.Singletons.TH.Partition -import Data.Singletons.TH.Promote.Defun -import Data.Singletons.TH.Promote.Monad -import Data.Singletons.TH.Promote.Type -import Data.Singletons.TH.Syntax -import Data.Singletons.TH.Util -import Prelude hiding (exp) -import Control.Applicative (Alternative(..)) -import Control.Arrow (second) -import Control.Monad -import Control.Monad.Trans.Maybe -import Control.Monad.Writer -import Data.List (nub) -import qualified Data.Map.Strict as Map -import Data.Map.Strict ( Map ) -import Data.Maybe -import qualified GHC.LanguageExtensions.Type as LangExt - -{- -Note [Disable genQuotedDecs in genPromotions and genSingletons] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Somewhat curiously, the genPromotions and genSingletons functions set the -genQuotedDecs option to False, despite neither function accepting quoted -declarations as arguments in the first place. There is a good reason for doing -this, however. Imagine this code: - - class C a where - infixl 9 <%%> - (<%%>) :: a -> a -> a - $(genPromotions [''C]) - -If genQuotedDecs is set to True, then the (<%%>) type family will not receive -a fixity declaration (see -Note [singletons-th and fixity declarations] in D.S.TH.Single.Fixity, wrinkle 1 for -more details on this point). Therefore, we set genQuotedDecs to False to avoid -this problem. --} - --- | Generate promoted definitions for each of the provided type-level --- declaration 'Name's. This is generally only useful with classes. -genPromotions :: OptionsMonad q => [Name] -> q [Dec] -genPromotions names = do - opts <- getOptions - -- See Note [Disable genQuotedDecs in genPromotions and genSingletons] - withOptions opts{genQuotedDecs = False} $ do - checkForRep names - infos <- mapM reifyWithLocals names - dinfos <- mapM dsInfo infos - ddecs <- promoteM_ [] $ mapM_ promoteInfo dinfos - return $ decsToTH ddecs - --- | Promote every declaration given to the type level, retaining the originals. --- See the --- @<https://github.com/goldfirere/singletons/blob/master/README.md README>@ --- for further explanation. -promote :: OptionsMonad q => q [Dec] -> q [Dec] -promote qdecs = do - opts <- getOptions - withOptions opts{genQuotedDecs = True} $ promote' $ lift qdecs - --- | Promote each declaration, discarding the originals. Note that a promoted --- datatype uses the same definition as an original datatype, so this will --- not work with datatypes. Classes, instances, and functions are all fine. -promoteOnly :: OptionsMonad q => q [Dec] -> q [Dec] -promoteOnly qdecs = do - opts <- getOptions - withOptions opts{genQuotedDecs = False} $ promote' $ lift qdecs - --- The workhorse for 'promote' and 'promoteOnly'. The difference between the --- two functions is whether 'genQuotedDecs' is set to 'True' or 'False'. -promote' :: OptionsMonad q => q [Dec] -> q [Dec] -promote' qdecs = do - opts <- getOptions - decs <- qdecs - ddecs <- withLocalDeclarations decs $ dsDecs decs - promDecs <- promoteM_ decs $ promoteDecs ddecs - let origDecs | genQuotedDecs opts = decs - | otherwise = [] - return $ origDecs ++ decsToTH promDecs - --- | Generate defunctionalization symbols for each of the provided type-level --- declaration 'Name's. See the "Promotion and partial application" section of --- the @singletons@ --- @<https://github.com/goldfirere/singletons/blob/master/README.md README>@ --- for further explanation. -genDefunSymbols :: OptionsMonad q => [Name] -> q [Dec] -genDefunSymbols names = do - checkForRep names - infos <- mapM (dsInfo <=< reifyWithLocals) names - decs <- promoteMDecs [] $ concatMapM defunInfo infos - return $ decsToTH decs - --- | Produce instances for @PEq@ from the given types -promoteEqInstances :: OptionsMonad q => [Name] -> q [Dec] -promoteEqInstances = concatMapM promoteEqInstance - --- | Produce an instance for @PEq@ from the given type -promoteEqInstance :: OptionsMonad q => Name -> q [Dec] -promoteEqInstance = promoteInstance mkEqInstance "Eq" - --- | Produce instances for 'POrd' from the given types -promoteOrdInstances :: OptionsMonad q => [Name] -> q [Dec] -promoteOrdInstances = concatMapM promoteOrdInstance - --- | Produce an instance for 'POrd' from the given type -promoteOrdInstance :: OptionsMonad q => Name -> q [Dec] -promoteOrdInstance = promoteInstance mkOrdInstance "Ord" - --- | Produce instances for 'PBounded' from the given types -promoteBoundedInstances :: OptionsMonad q => [Name] -> q [Dec] -promoteBoundedInstances = concatMapM promoteBoundedInstance - --- | Produce an instance for 'PBounded' from the given type -promoteBoundedInstance :: OptionsMonad q => Name -> q [Dec] -promoteBoundedInstance = promoteInstance mkBoundedInstance "Bounded" - --- | Produce instances for 'PEnum' from the given types -promoteEnumInstances :: OptionsMonad q => [Name] -> q [Dec] -promoteEnumInstances = concatMapM promoteEnumInstance - --- | Produce an instance for 'PEnum' from the given type -promoteEnumInstance :: OptionsMonad q => Name -> q [Dec] -promoteEnumInstance = promoteInstance mkEnumInstance "Enum" - --- | Produce instances for 'PShow' from the given types -promoteShowInstances :: OptionsMonad q => [Name] -> q [Dec] -promoteShowInstances = concatMapM promoteShowInstance - --- | Produce an instance for 'PShow' from the given type -promoteShowInstance :: OptionsMonad q => Name -> q [Dec] -promoteShowInstance = promoteInstance mkShowInstance "Show" - -promoteInstance :: OptionsMonad q => DerivDesc q -> String -> Name -> q [Dec] -promoteInstance mk_inst class_name name = do - (df, tvbs, cons) <- getDataD ("I cannot make an instance of " ++ class_name - ++ " for it.") name - tvbs' <- mapM dsTvbUnit tvbs - let data_ty = foldTypeTvbs (DConT name) tvbs' - cons' <- concatMapM (dsCon tvbs' data_ty) cons - let data_decl = DataDecl df name tvbs' cons' - raw_inst <- mk_inst Nothing data_ty data_decl - decs <- promoteM_ [] $ void $ - promoteInstanceDec OMap.empty Map.empty raw_inst - return $ decsToTH decs - -promoteInfo :: DInfo -> PrM () -promoteInfo (DTyConI dec _instances) = promoteDecs [dec] -promoteInfo (DPrimTyConI _name _numArgs _unlifted) = - fail "Promotion of primitive type constructors not supported" -promoteInfo (DVarI _name _ty _mdec) = - fail "Promotion of individual values not supported" -promoteInfo (DTyVarI _name _ty) = - fail "Promotion of individual type variables not supported" -promoteInfo (DPatSynI {}) = - fail "Promotion of pattern synonyms not supported" - --- Promote a list of top-level declarations. -promoteDecs :: [DDec] -> PrM () -promoteDecs raw_decls = do - decls <- expand raw_decls -- expand type synonyms - checkForRepInDecls decls - PDecs { pd_let_decs = let_decs - , pd_class_decs = classes - , pd_instance_decs = insts - , pd_data_decs = datas - , pd_ty_syn_decs = ty_syns - , pd_open_type_family_decs = o_tyfams - , pd_closed_type_family_decs = c_tyfams } <- partitionDecs decls - - defunTopLevelTypeDecls ty_syns c_tyfams o_tyfams - rec_sel_let_decs <- promoteDataDecs datas - -- promoteLetDecs returns LetBinds, which we don't need at top level - _ <- promoteLetDecs Nothing $ rec_sel_let_decs ++ let_decs - mapM_ promoteClassDec classes - let orig_meth_sigs = foldMap (lde_types . cd_lde) classes - cls_tvbs_map = Map.fromList $ map (\cd -> (cd_name cd, cd_tvbs cd)) classes - mapM_ (promoteInstanceDec orig_meth_sigs cls_tvbs_map) insts - --- curious about ALetDecEnv? See the LetDecEnv module for an explanation. -promoteLetDecs :: Maybe Uniq -- let-binding unique (if locally bound) - -> [DLetDec] -> PrM ([LetBind], ALetDecEnv) -promoteLetDecs mb_let_uniq decls = do - opts <- getOptions - let_dec_env <- buildLetDecEnv decls - all_locals <- allLocals - let binds = [ (name, foldType (DConT sym) (map DVarT all_locals)) - | (name, _) <- OMap.assocs $ lde_defns let_dec_env - , let proName = promotedValueName opts name mb_let_uniq - sym = defunctionalizedName opts proName (length all_locals) ] - (decs, let_dec_env') <- letBind binds $ promoteLetDecEnv mb_let_uniq let_dec_env - emitDecs decs - return (binds, let_dec_env' { lde_proms = OMap.fromList binds }) - -promoteDataDecs :: [DataDecl] -> PrM [DLetDec] -promoteDataDecs = concatMapM promoteDataDec - --- "Promotes" a data type, much like D.S.TH.Single.Data.singDataD singles a data --- type. Promoting a data type is much easier than singling it, however, since --- DataKinds automatically promotes data types and kinds and data constructors --- to types. That means that promoteDataDec only has to do three things: --- --- 1. Emit defunctionalization symbols for each data constructor, --- --- 2. Emit promoted fixity declarations for each data constructor and promoted --- record selector (assuming the originals have fixity declarations), and --- --- 3. Assemble a top-level function that mimics the behavior of its record --- selectors. Note that promoteDataDec does not actually promote this record --- selector function—it merely returns its DLetDecs. Later, the promoteDecs --- function takes these DLetDecs and promotes them (using promoteLetDecs). --- This greatly simplifies the plumbing, since this allows all DLetDecs to --- be promoted in a single location. --- See Note [singletons-th and record selectors] in D.S.TH.Single.Data. -promoteDataDec :: DataDecl -> PrM [DLetDec] -promoteDataDec (DataDecl _ _ _ ctors) = do - let rec_sel_names = nub $ concatMap extractRecSelNames ctors - -- Note the use of nub: the same record selector name can - -- be used in multiple constructors! - rec_sel_let_decs <- getRecordSelectors ctors - ctorSyms <- buildDefunSymsDataD ctors - infix_decs <- promoteReifiedInfixDecls rec_sel_names - emitDecs $ ctorSyms ++ infix_decs - pure rec_sel_let_decs - -promoteClassDec :: UClassDecl -> PrM AClassDecl -promoteClassDec decl@(ClassDecl { cd_name = cls_name - , cd_tvbs = tvbs - , cd_fds = fundeps - , cd_atfs = atfs - , cd_lde = lde@LetDecEnv - { lde_defns = defaults - , lde_types = meth_sigs - , lde_infix = infix_decls } }) = do - opts <- getOptions - let pClsName = promotedClassName opts cls_name - meth_sigs_list = OMap.assocs meth_sigs - meth_names = map fst meth_sigs_list - defaults_list = OMap.assocs defaults - defaults_names = map fst defaults_list - mb_cls_sak <- dsReifyType cls_name - sig_decs <- mapM (uncurry promote_sig) meth_sigs_list - (default_decs, ann_rhss, prom_rhss) - <- mapAndUnzip3M (promoteMethod DefaultMethods meth_sigs) defaults_list - defunAssociatedTypeFamilies tvbs atfs - - infix_decls' <- mapMaybeM (uncurry (promoteInfixDecl Nothing)) $ - OMap.assocs infix_decls - cls_infix_decls <- promoteReifiedInfixDecls $ cls_name:meth_names - - -- no need to do anything to the fundeps. They work as is! - let pro_cls_dec = DClassD [] pClsName tvbs fundeps - (sig_decs ++ default_decs ++ infix_decls') - mb_pro_cls_sak = fmap (DKiSigD pClsName) mb_cls_sak - emitDecs $ maybeToList mb_pro_cls_sak ++ pro_cls_dec:cls_infix_decls - let defaults_list' = zip defaults_names ann_rhss - proms = zip defaults_names prom_rhss - return (decl { cd_lde = lde { lde_defns = OMap.fromList defaults_list' - , lde_proms = OMap.fromList proms } }) - where - promote_sig :: Name -> DType -> PrM DDec - promote_sig name ty = do - opts <- getOptions - let proName = promotedTopLevelValueName opts name - -- When computing the kind to use for the defunctionalization symbols, - -- /don't/ use the type variable binders from the method's type... - (_, argKs, resK) <- promoteUnraveled ty - args <- mapM (const $ qNewName "arg") argKs - let proTvbs = zipWith (`DKindedTV` ()) args argKs - -- ...instead, compute the type variable binders in a left-to-right order, - -- since that is the same order that the promoted method's kind will use. - -- See Note [Promoted class methods and kind variable ordering] - meth_sak_tvbs = changeDTVFlags SpecifiedSpec $ - toposortTyVarsOf $ argKs ++ [resK] - meth_sak = ravelVanillaDType meth_sak_tvbs [] argKs resK - m_fixity <- reifyFixityWithLocals name - emitDecsM $ defunctionalize proName m_fixity $ DefunSAK meth_sak - - return $ DOpenTypeFamilyD (DTypeFamilyHead proName - proTvbs - (DKindSig resK) - Nothing) - -{- -Note [Promoted class methods and kind variable ordering] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general, we make an effort to preserve the order of type variables when -promoting type signatures, but there is an annoying corner case where this is -difficult: class methods. When promoting class methods, the order of kind -variables in their kinds will often "just work" by happy coincidence, but -there are some situations where this does not happen. Consider the following -class: - - class C (b :: Type) where - m :: forall a. a -> b -> a - -The full type of `m` is `forall b. C b => forall a. a -> b -> a`, which binds -`b` before `a`. This order is preserved when singling `m`, but *not* when -promoting `m`. This is because the `C` class is promoted as follows: - - class PC (b :: Type) where - type M (x :: a) (y :: b) :: a - -Due to the way GHC kind-checks associated type families, the kind of `M` is -`forall a b. a -> b -> a`, which binds `b` *after* `a`. Moreover, the -`StandaloneKindSignatures` extension does not provide a way to explicitly -declare the full kind of an associated type family, so this limitation is -not easy to work around. - -The defunctionalization symbols for `M` will also follow a similar -order of type variables: - - type MSym0 :: forall a b. a ~> b ~> a - type MSym1 :: forall a b. a -> b ~> a - -There is one potential hack we could use to rectify this: - - type FlipConst x y = y - class PC (b :: Type) where - type M (x :: FlipConst '(b, a) a) (y :: b) :: a - -Using `FlipConst` would cause `b` to be mentioned before `a`, which would give -`M` the kind `forall b a. FlipConst '(b, a) a -> b -> a`. While the order of -type variables would be preserved, the downside is that the ugly `FlipConst` -type synonym leaks into the kind. I'm not particularly fond of this, so I have -decided not to use this hack unless someone specifically requests it. --} - --- returns (unpromoted method name, ALetDecRHS) pairs -promoteInstanceDec :: OMap Name DType - -- Class method type signatures - -> Map Name [DTyVarBndrUnit] - -- Class header type variable (e.g., if `class C a b` is - -- quoted, then this will have an entry for {C |-> [a, b]}) - -> UInstDecl -> PrM AInstDecl -promoteInstanceDec orig_meth_sigs cls_tvbs_map - decl@(InstDecl { id_name = cls_name - , id_arg_tys = inst_tys - , id_sigs = inst_sigs - , id_meths = meths }) = do - opts <- getOptions - cls_tvbs <- lookup_cls_tvbs - inst_kis <- mapM promoteType inst_tys - let pClsName = promotedClassName opts cls_name - cls_tvb_names = map extractTvbName cls_tvbs - subst = Map.fromList $ zip cls_tvb_names inst_kis - meth_impl = InstanceMethods inst_sigs subst - (meths', ann_rhss, _) - <- mapAndUnzip3M (promoteMethod meth_impl orig_meth_sigs) meths - emitDecs [DInstanceD Nothing Nothing [] (foldType (DConT pClsName) - inst_kis) meths'] - return (decl { id_meths = zip (map fst meths) ann_rhss }) - where - lookup_cls_tvbs :: PrM [DTyVarBndrUnit] - lookup_cls_tvbs = - -- First, try consulting the map of class names to their type variables. - -- It is important to do this first to ensure that we consider locally - -- declared classes before imported ones. See #410 for what happens if - -- you don't. - case Map.lookup cls_name cls_tvbs_map of - Just tvbs -> pure tvbs - Nothing -> reify_cls_tvbs - -- If the class isn't present in this map, we try reifying the class - -- as a last resort. - - reify_cls_tvbs :: PrM [DTyVarBndrUnit] - reify_cls_tvbs = do - opts <- getOptions - let pClsName = promotedClassName opts cls_name - mk_tvbs = extract_tvbs (dsReifyTypeNameInfo pClsName) - <|> extract_tvbs (dsReifyTypeNameInfo cls_name) - -- See Note [Using dsReifyTypeNameInfo when promoting instances] - mb_tvbs <- runMaybeT mk_tvbs - case mb_tvbs of - Just tvbs -> pure tvbs - Nothing -> fail $ "Cannot find class declaration annotation for " ++ show cls_name - - extract_tvbs :: PrM (Maybe DInfo) -> MaybeT PrM [DTyVarBndrUnit] - extract_tvbs reify_info = do - mb_info <- lift reify_info - case mb_info of - Just (DTyConI (DClassD _ _ tvbs _ _) _) -> pure tvbs - _ -> empty - -{- -Note [Using dsReifyTypeNameInfo when promoting instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -During the promotion of a class instance, it becomes necessary to reify the -original promoted class's info to learn various things. It's tempting to think -that just calling dsReify on the class name will be sufficient, but it's not. -Consider this class and its promotion: - - class Eq a where - (==) :: a -> a -> Bool - - class PEq a where - type (==) (x :: a) (y :: a) :: Bool - -Notice how both of these classes have an identifier named (==), one at the -value level, and one at the type level. Now imagine what happens when you -attempt to promote this Template Haskell declaration: - - [d| f :: Bool - f = () == () |] - -When promoting ==, singletons-th will come up with its promoted equivalent (which also -happens to be ==). However, this promoted name is a raw Name, since it is created -with mkName. This becomes an issue when we call dsReify the raw "==" Name, as -Template Haskell has to arbitrarily choose between reifying the info for the -value-level (==) and the type-level (==), and in this case, it happens to pick the -value-level (==) info. We want the type-level (==) info, however, because we care -about the promoted version of (==). - -Fortunately, there's a serviceable workaround. Instead of dsReify, we can use -dsReifyTypeNameInfo, which first calls lookupTypeName (to ensure we can find a Name -that's in the type namespace) and _then_ reifies it. --} - --- Which sort of class methods are being promoted? -data MethodSort - -- The method defaults in class declarations. - = DefaultMethods - -- The methods in instance declarations. - | InstanceMethods (OMap Name DType) -- ^ InstanceSigs - (Map Name DKind) -- ^ Instantiations for class tyvars - -- See Note [Promoted class method kinds] - deriving Show - -promoteMethod :: MethodSort - -> OMap Name DType -- method types - -> (Name, ULetDecRHS) - -> PrM (DDec, ALetDecRHS, DType) - -- returns (type instance, ALetDecRHS, promoted RHS) -promoteMethod meth_sort orig_sigs_map (meth_name, meth_rhs) = do - opts <- getOptions - (meth_arg_kis, meth_res_ki) <- promote_meth_ty - meth_arg_tvs <- replicateM (length meth_arg_kis) (qNewName "a") - let proName = promotedTopLevelValueName opts meth_name - helperNameBase = case nameBase proName of - first:_ | not (isHsLetter first) -> "TFHelper" - alpha -> alpha - - -- family_args are the type variables in a promoted class's - -- associated type family instance (or default implementation), e.g., - -- - -- class C k where - -- type T (a :: k) (b :: Bool) - -- type T a b = THelper1 a b -- family_args = [a, b] - -- - -- instance C Bool where - -- type T a b = THelper2 a b -- family_args = [a, b] - -- - -- We could annotate these variables with explicit kinds, but it's not - -- strictly necessary, as kind inference can figure them out just as well. - family_args = map DVarT meth_arg_tvs - helperName <- newUniqueName helperNameBase - let helperDefunName = defunctionalizedName0 opts helperName - (pro_decs, defun_decs, ann_rhs) - <- promoteLetDecRHS (ClassMethodRHS meth_arg_kis meth_res_ki) - OMap.empty OMap.empty - Nothing helperName meth_rhs - emitDecs (pro_decs ++ defun_decs) - return ( DTySynInstD - (DTySynEqn Nothing - (foldType (DConT proName) family_args) - (foldApply (DConT helperDefunName) (map DVarT meth_arg_tvs))) - , ann_rhs - , DConT helperDefunName ) - where - -- Promote the type of a class method. For a default method, "the type" is - -- simply the type of the original method. For an instance method, - -- "the type" is like the type of the original method, but substituted for - -- the types in the instance head. (e.g., if you have `class C a` and - -- `instance C T`, then the substitution [a |-> T] must be applied to the - -- original method's type.) - promote_meth_ty :: PrM ([DKind], DKind) - promote_meth_ty = - case meth_sort of - DefaultMethods -> - -- No substitution for class variables is required for default - -- method type signatures, as they share type variables with the - -- class they inhabit. - lookup_meth_ty - InstanceMethods inst_sigs_map cls_subst -> - case OMap.lookup meth_name inst_sigs_map of - Just ty -> do - -- We have an InstanceSig. These are easy: we can just use the - -- instance signature's type directly, and no substitution for - -- class variables is required. - (_tvbs, arg_kis, res_ki) <- promoteUnraveled ty - pure (arg_kis, res_ki) - Nothing -> do - -- We don't have an InstanceSig, so we must compute the kind to use - -- ourselves. - (arg_kis, res_ki) <- lookup_meth_ty - -- Substitute for the class variables in the method's type. - -- See Note [Promoted class method kinds] - let arg_kis' = map (substKind cls_subst) arg_kis - res_ki' = substKind cls_subst res_ki - pure (arg_kis', res_ki') - - -- Attempt to look up a class method's original type. - lookup_meth_ty :: PrM ([DKind], DKind) - lookup_meth_ty = do - opts <- getOptions - let proName = promotedTopLevelValueName opts meth_name - case OMap.lookup meth_name orig_sigs_map of - Just ty -> do - -- The type of the method is in scope, so promote that. - (_tvbs, arg_kis, res_ki) <- promoteUnraveled ty - pure (arg_kis, res_ki) - Nothing -> do - -- If the type of the method is not in scope, the only other option - -- is to try reifying the promoted method name. - mb_info <- dsReifyTypeNameInfo proName - -- See Note [Using dsReifyTypeNameInfo when promoting instances] - case mb_info of - Just (DTyConI (DOpenTypeFamilyD (DTypeFamilyHead _ tvbs mb_res_ki _)) _) - -> let arg_kis = map (defaultMaybeToTypeKind . extractTvbKind) tvbs - res_ki = defaultMaybeToTypeKind (resultSigToMaybeKind mb_res_ki) - in pure (arg_kis, res_ki) - _ -> fail $ "Cannot find type annotation for " ++ show proName - -{- -Note [Promoted class method kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this example of a type class (and instance): - - class C a where - m :: a -> Bool -> Bool - m _ x = x - - instance C [a] where - m l _ = null l - -The promoted version of these declarations would be: - - class PC a where - type M (x :: a) (y :: Bool) :: Bool - type M x y = MHelper1 x y - - instance PC [a] where - type M x y = MHelper2 x y - - type MHelper1 :: a -> Bool -> Bool - type family MHelper1 x y where ... - - type MHelper2 :: [a] -> Bool -> Bool - type family MHelper2 x y where ... - -Getting the kind signature for MHelper1 (the promoted default implementation of -M) is quite simple, as it corresponds exactly to the kind of M. We might even -choose to make that the kind of MHelper2, but then it would be overly general -(and more difficult to find in -ddump-splices output). For this reason, we -substitute in the kinds of the instance itself to determine the kinds of -promoted method implementations like MHelper2. --} - -promoteLetDecEnv :: Maybe Uniq -> ULetDecEnv -> PrM ([DDec], ALetDecEnv) -promoteLetDecEnv mb_let_uniq (LetDecEnv { lde_defns = value_env - , lde_types = type_env - , lde_infix = fix_env }) = do - infix_decls <- mapMaybeM (uncurry (promoteInfixDecl mb_let_uniq)) $ - OMap.assocs fix_env - - -- promote all the declarations, producing annotated declarations - let (names, rhss) = unzip $ OMap.assocs value_env - (pro_decs, defun_decss, ann_rhss) - <- fmap unzip3 $ - zipWithM (promoteLetDecRHS LetBindingRHS type_env fix_env mb_let_uniq) - names rhss - - emitDecs $ concat defun_decss - let decs = concat pro_decs ++ infix_decls - - -- build the ALetDecEnv - let let_dec_env' = LetDecEnv { lde_defns = OMap.fromList $ zip names ann_rhss - , lde_types = type_env - , lde_infix = fix_env - , lde_proms = OMap.empty -- filled in promoteLetDecs - } - - return (decs, let_dec_env') - --- Promote a fixity declaration. -promoteInfixDecl :: forall q. OptionsMonad q - => Maybe Uniq -> Name -> Fixity -> q (Maybe DDec) -promoteInfixDecl mb_let_uniq name fixity = do - opts <- getOptions - mb_ns <- reifyNameSpace name - case mb_ns of - -- If we can't find the Name for some odd reason, fall back to promote_val - Nothing -> promote_val - Just VarName -> promote_val - Just DataName -> never_mind - Just TcClsName -> do - mb_info <- dsReify name - case mb_info of - Just (DTyConI DClassD{} _) - -> finish $ promotedClassName opts name - _ -> never_mind - where - -- Produce the fixity declaration. - finish :: Name -> q (Maybe DDec) - finish = pure . Just . DLetDec . DInfixD fixity - - -- Don't produce a fixity declaration at all. This happens when promoting a - -- fixity declaration for a name whose promoted counterpart is the same as - -- the original name. - -- See Note [singletons-th and fixity declarations] in D.S.TH.Single.Fixity, wrinkle 1. - never_mind :: q (Maybe DDec) - never_mind = pure Nothing - - -- Certain value names do not change when promoted (e.g., infix names). - -- Therefore, don't bother promoting their fixity declarations if - -- 'genQuotedDecs' is set to 'True', since that will run the risk of - -- generating duplicate fixity declarations. - -- See Note [singletons-th and fixity declarations] in D.S.TH.Single.Fixity, wrinkle 1. - promote_val :: q (Maybe DDec) - promote_val = do - opts <- getOptions - let promoted_name :: Name - promoted_name = promotedValueName opts name mb_let_uniq - if nameBase name == nameBase promoted_name && genQuotedDecs opts - then never_mind - else finish promoted_name - --- Try producing promoted fixity declarations for Names by reifying them --- /without/ consulting quoted declarations. If reification fails, recover and --- return the empty list. --- See [singletons-th and fixity declarations] in D.S.TH.Single.Fixity, wrinkle 2. -promoteReifiedInfixDecls :: forall q. OptionsMonad q => [Name] -> q [DDec] -promoteReifiedInfixDecls = mapMaybeM tryPromoteFixityDeclaration - where - tryPromoteFixityDeclaration :: Name -> q (Maybe DDec) - tryPromoteFixityDeclaration name = - qRecover (return Nothing) $ do - mFixity <- qReifyFixity name - case mFixity of - Nothing -> pure Nothing - Just fixity -> promoteInfixDecl Nothing name fixity - --- Which sort of let-bound declaration's right-hand side is being promoted? -data LetDecRHSSort - -- An ordinary (i.e., non-class-related) let-bound declaration. - = LetBindingRHS - -- The right-hand side of a class method (either a default method or a - -- method in an instance declaration). - | ClassMethodRHS - [DKind] DKind - -- The RHS's promoted argument and result types. Needed to fix #136. - deriving Show - --- This function is used both to promote class method defaults and normal --- let bindings. Thus, it can't quite do all the work locally and returns --- an intermediate structure. Perhaps a better design is available. -promoteLetDecRHS :: LetDecRHSSort - -> OMap Name DType -- local type env't - -> OMap Name Fixity -- local fixity env't - -> Maybe Uniq -- let-binding unique (if locally bound) - -> Name -- name of the thing being promoted - -> ULetDecRHS -- body of the thing - -> PrM ( [DDec] -- promoted type family dec, plus the - -- SAK dec (if one exists) - , [DDec] -- defunctionalization - , ALetDecRHS ) -- annotated RHS -promoteLetDecRHS rhs_sort type_env fix_env mb_let_uniq name let_dec_rhs = do - opts <- getOptions - all_locals <- allLocals - case let_dec_rhs of - UValue exp -> do - (m_ldrki, ty_num_args) <- promote_let_dec_ty all_locals 0 - if ty_num_args == 0 - then - let proName = promotedValueName opts name mb_let_uniq - prom_fun_lhs = foldType (DConT proName) $ map DVarT all_locals in - promote_let_dec_rhs all_locals m_ldrki 0 (promoteExp exp) - (\exp' -> [DTySynEqn Nothing prom_fun_lhs exp']) - AValue - else - -- If we have a UValue with a function type, process it as though it - -- were a UFunction. promote_function_rhs will take care of - -- eta-expanding arguments as necessary. - promote_function_rhs all_locals [DClause [] exp] - UFunction clauses -> promote_function_rhs all_locals clauses - where - -- Promote the RHS of a UFunction (or a UValue with a function type). - promote_function_rhs :: [Name] - -> [DClause] -> PrM ([DDec], [DDec], ALetDecRHS) - promote_function_rhs all_locals clauses = do - opts <- getOptions - numArgs <- count_args clauses - let proName = promotedValueName opts name mb_let_uniq - prom_fun_lhs = foldType (DConT proName) $ map DVarT all_locals - (m_ldrki, ty_num_args) <- promote_let_dec_ty all_locals numArgs - expClauses <- mapM (etaContractOrExpand ty_num_args numArgs) clauses - promote_let_dec_rhs all_locals m_ldrki ty_num_args - (mapAndUnzipM (promoteClause prom_fun_lhs) expClauses) - id (AFunction ty_num_args) - - -- Promote a UValue or a UFunction. - -- Notes about type variables: - -- - -- * For UValues, `prom_a` is DType and `a` is Exp. - -- - -- * For UFunctions, `prom_a` is [DTySynEqn] and `a` is [DClause]. - promote_let_dec_rhs - :: [Name] -- Local variables bound in this scope - -> Maybe LetDecRHSKindInfo -- Information about the promoted kind (if present) - -> Int -- The number of promoted function arguments - -> PrM (prom_a, a) -- Promote the RHS - -> (prom_a -> [DTySynEqn]) -- Turn the promoted RHS into type family equations - -> (a -> ALetDecRHS) -- Build an ALetDecRHS - -> PrM ([DDec], [DDec], ALetDecRHS) - promote_let_dec_rhs all_locals m_ldrki ty_num_args - promote_thing mk_prom_eqns mk_alet_dec_rhs = do - opts <- getOptions - tyvarNames <- replicateM ty_num_args (qNewName "a") - let proName = promotedValueName opts name mb_let_uniq - local_tvbs = map (`DPlainTV` ()) all_locals - m_fixity = OMap.lookup name fix_env - - mk_tf_head :: [DTyVarBndrUnit] -> DFamilyResultSig -> DTypeFamilyHead - mk_tf_head tvbs res_sig = DTypeFamilyHead proName tvbs res_sig Nothing - - (m_sak_dec, defun_ki, tf_head) = - -- There are three possible cases: - case m_ldrki of - -- 1. We have no kind information whatsoever. - Nothing -> - let all_args = local_tvbs ++ map (`DPlainTV` ()) tyvarNames in - ( Nothing - , DefunNoSAK all_args Nothing - , mk_tf_head all_args DNoSig - ) - -- 2. We have some kind information in the form of a LetDecRHSKindInfo. - Just (LDRKI m_sak argKs resK) -> - let all_args = local_tvbs ++ zipWith (`DKindedTV` ()) tyvarNames argKs in - case m_sak of - -- 2(a). We do not have a standalone kind signature. - Nothing -> - ( Nothing - , DefunNoSAK all_args (Just resK) - , mk_tf_head all_args (DKindSig resK) - ) - -- 2(b). We have a standalone kind signature. - Just sak -> - ( Just $ DKiSigD proName sak - , DefunSAK sak - -- We opt to annotate the argument and result kinds in - -- the body of the type family declaration even if it is - -- given a standalone kind signature. - -- See Note [Keep redundant kind information for Haddocks]. - , mk_tf_head all_args (DKindSig resK) - ) - - defun_decs <- defunctionalize proName m_fixity defun_ki - (prom_thing, thing) <- promote_thing - return ( catMaybes [ m_sak_dec - , Just $ DClosedTypeFamilyD tf_head (mk_prom_eqns prom_thing) - ] - , defun_decs - , mk_alet_dec_rhs thing ) - - promote_let_dec_ty :: [Name] -- The local variables that the let-dec closes - -- over. If this is non-empty, we cannot - -- produce a standalone kind signature. - -- See Note [No SAKs for let-decs with local variables] - -> Int -- The number of arguments to default to if the - -- type cannot be inferred. This is 0 for UValues - -- and the number of arguments in a single clause - -- for UFunctions. - -> PrM (Maybe LetDecRHSKindInfo, Int) - -- Returns two things in a pair: - -- - -- 1. Information about the promoted kind, - -- if available. - -- - -- 2. The number of arguments the let-dec has. - -- If no kind information is available from - -- which to infer this number, then this - -- will default to the earlier Int argument. - promote_let_dec_ty all_locals default_num_args = - case rhs_sort of - ClassMethodRHS arg_kis res_ki - -> -- For class method RHS helper functions, don't bother quantifying - -- any type variables in their SAKS. We could certainly try, but - -- given that these functions are only used internally, there's no - -- point in trying to get the order of type variables correct, - -- since we don't apply these functions with visible kind - -- applications. - let sak = ravelVanillaDType [] [] arg_kis res_ki in - return (Just (LDRKI (Just sak) arg_kis res_ki), length arg_kis) - LetBindingRHS - | Just ty <- OMap.lookup name type_env - -> do - -- promoteType turns rank-1 uses of (->) into (~>). So, we unravel - -- first to avoid this behavior, and then ravel back. - (tvbs, argKs, resultK) <- promoteUnraveled ty - let m_sak | null all_locals = Just $ ravelVanillaDType tvbs [] argKs resultK - -- If this let-dec closes over local variables, then - -- don't give it a SAK. - -- See Note [No SAKs for let-decs with local variables] - | otherwise = Nothing - -- invariant: count_args ty == length argKs - return (Just (LDRKI m_sak argKs resultK), length argKs) - - | otherwise - -> return (Nothing, default_num_args) - - etaContractOrExpand :: Int -> Int -> DClause -> PrM DClause - etaContractOrExpand ty_num_args clause_num_args (DClause pats exp) - | n >= 0 = do -- Eta-expand - names <- replicateM n (newUniqueName "a") - let newPats = map DVarP names - newArgs = map DVarE names - return $ DClause (pats ++ newPats) (foldExp exp newArgs) - | otherwise = do -- Eta-contract - let (clausePats, lamPats) = splitAt ty_num_args pats - lamExp <- mkDLamEFromDPats lamPats exp - return $ DClause clausePats lamExp - where - n = ty_num_args - clause_num_args - - count_args :: [DClause] -> PrM Int - count_args (DClause pats _ : _) = return $ length pats - count_args _ = fail $ "Impossible! A function without clauses." - --- An auxiliary data type used in promoteLetDecRHS that describes information --- related to the promoted kind of a class method default or normal --- let binding. -data LetDecRHSKindInfo = - LDRKI (Maybe DKind) -- The standalone kind signature, if applicable. - -- This will be Nothing if the let-dec RHS has local - -- variables that it closes over. - -- See Note [No SAKs for let-decs with local variables] - [DKind] -- The argument kinds. - DKind -- The result kind. - -{- -Note [No SAKs for let-decs with local variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider promoting this: - - f :: Bool - f = let x = True - g :: () -> Bool - g _ = x - in g () - -Clearly, the promoted `F` type family will have the following SAK: - - type F :: () - -What about `G`? At a passing glance, it appears that you could get away with -this: - - type G :: Bool -> () - -But this isn't quite right, since `g` closes over `x = True`. The body of `G`, -therefore, has to lift `x` to be an explicit argument: - - type family G x (u :: ()) :: Bool where - G x _ = x - -At present, we don't keep track of the types of local variables like `x`, which -makes it difficult to create a SAK for things like `G`. Here are some possible -ideas, each followed by explanations for why they are infeasible: - -* Use wildcards: - - type G :: _ -> () -> Bool - - Alas, GHC currently does not allow wildcards in SAKs. See GHC#17432. - -* Use visible dependent quantification to avoid having to say what the kind - of `x` is: - - type G :: forall x -> () -> Bool - - A clever trick to be sure, but it doesn't quite do what we want, since - GHC will generalize that kind to become `forall (x :: k) -> () -> Bool`, - which is more general than we want. - -In any case, it's probably not worth bothering with SAKs for local definitions -like `g` in the first place, so we avoid generating SAKs for anything that -closes over at least one local variable for now. If someone yells about this, -we'll reconsider this design. - -Note [Keep redundant kind information for Haddocks] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -`singletons-th` generates explicit argument kinds and result kinds for -type-level declarations whenever possible, even if those kinds are technically -redundant. For example, `singletons-th` would promote this: - - id' :: a -> a - -To this: - - type Id' :: a -> a - type family Id' (x :: a) :: a where ... - -Strictly speaking, the argument and result kind of Id' are unnecessary, since -the same information is already present in the standalone kind signature. -However, due to a Haddock limitation -(https://github.com/haskell/haddock/issues/1178), Haddock will not render -standalone kind signatures at all, so if the argument and result kind of Id' -were omitted in the body, Haddock would render it like so: - - type family Id' x where ... - -This is unfortunate for Haddock viewers, as this does not convey any kind -information whatsoever. Until the aformentioned Haddock issue is resolved, we -work around this limitation by generating the redundant argument and kind -information anyway. Thankfully, this is simple to accomplish, as we already -compute this information to begin with. --} - -promoteClause :: DType -- What to use as the LHS of the promoted type family - -- equation. This should consist of the promoted name of - -- the function to which the clause belongs, applied to - -- any local arguments (e.g., `Go x y z`). - -> DClause -> PrM (DTySynEqn, ADClause) -promoteClause pro_clause_fun (DClause pats exp) = do - -- promoting the patterns creates variable bindings. These are passed - -- to the function promoted the RHS - ((types, pats'), new_vars) <- evalForPair $ mapAndUnzipM promotePat pats - (ty, ann_exp) <- lambdaBind new_vars $ promoteExp exp - return ( DTySynEqn Nothing (foldType pro_clause_fun types) ty - , ADClause new_vars pats' ann_exp ) - -promoteMatch :: DType -- What to use as the LHS of the promoted type family - -- equation. This should consist of the promoted name of - -- the case expression to which the match belongs, applied - -- to any local arguments (e.g., `Case x y z`). - -> DMatch -> PrM (DTySynEqn, ADMatch) -promoteMatch pro_case_fun (DMatch pat exp) = do - -- promoting the patterns creates variable bindings. These are passed - -- to the function promoted the RHS - ((ty, pat'), new_vars) <- evalForPair $ promotePat pat - (rhs, ann_exp) <- lambdaBind new_vars $ promoteExp exp - return $ ( DTySynEqn Nothing (pro_case_fun `DAppT` ty) rhs - , ADMatch new_vars pat' ann_exp) - --- promotes a term pattern into a type pattern, accumulating bound variable names -promotePat :: DPat -> QWithAux VarPromotions PrM (DType, ADPat) -promotePat (DLitP lit) = (, ADLitP lit) <$> promoteLitPat lit -promotePat (DVarP name) = do - -- term vars can be symbols... type vars can't! - tyName <- mkTyName name - tell $ [(name, tyName)] - return (DVarT tyName, ADVarP name) -promotePat (DConP name tys pats) = do - opts <- getOptions - kis <- traverse (promoteType_options conOptions) tys - (types, pats') <- mapAndUnzipM promotePat pats - let name' = promotedDataTypeOrConName opts name - return (foldType (foldl DAppKindT (DConT name') kis) types, ADConP name kis pats') - where - -- Currently, visible type patterns of data constructors are the one place - -- in `singletons-th` where it makes sense to promote wildcard types, as it - -- will produce code that GHC will accept. - conOptions :: PromoteTypeOptions - conOptions = defaultPromoteTypeOptions{ptoAllowWildcards = True} -promotePat (DTildeP pat) = do - qReportWarning "Lazy pattern converted into regular pattern in promotion" - second ADTildeP <$> promotePat pat -promotePat (DBangP pat) = do - qReportWarning "Strict pattern converted into regular pattern in promotion" - second ADBangP <$> promotePat pat -promotePat (DSigP pat ty) = do - -- We must maintain the invariant that any promoted pattern signature must - -- not have any wildcards in the underlying pattern. - -- See Note [Singling pattern signatures]. - wildless_pat <- removeWilds pat - (promoted, pat') <- promotePat wildless_pat - ki <- promoteType ty - return (DSigT promoted ki, ADSigP promoted pat' ki) -promotePat DWildP = return (DWildCardT, ADWildP) - -promoteExp :: DExp -> PrM (DType, ADExp) -promoteExp (DVarE name) = fmap (, ADVarE name) $ lookupVarE name -promoteExp (DConE name) = do - opts <- getOptions - return (DConT $ defunctionalizedName0 opts name, ADConE name) -promoteExp (DLitE lit) = fmap (, ADLitE lit) $ promoteLitExp lit -promoteExp (DAppE exp1 exp2) = do - (exp1', ann_exp1) <- promoteExp exp1 - (exp2', ann_exp2) <- promoteExp exp2 - return (apply exp1' exp2', ADAppE ann_exp1 ann_exp2) --- Until we get visible kind applications, this is the best we can do. -promoteExp (DAppTypeE exp _) = do - qReportWarning "Visible type applications are ignored by `singletons-th`." - promoteExp exp -promoteExp (DLamE names exp) = do - opts <- getOptions - lambdaName <- newUniqueName "Lambda" - tyNames <- mapM mkTyName names - let var_proms = zip names tyNames - (rhs, ann_exp) <- lambdaBind var_proms $ promoteExp exp - all_locals <- allLocals - let all_args = all_locals ++ tyNames - tvbs = map (`DPlainTV` ()) all_args - emitDecs [DClosedTypeFamilyD (DTypeFamilyHead - lambdaName - tvbs - DNoSig - Nothing) - [DTySynEqn Nothing - (foldType (DConT lambdaName) $ - map DVarT all_args) - rhs]] - emitDecsM $ defunctionalize lambdaName Nothing $ DefunNoSAK tvbs Nothing - let promLambda = foldApply (DConT (defunctionalizedName opts lambdaName 0)) - (map DVarT all_locals) - return (promLambda, ADLamE tyNames promLambda names ann_exp) -promoteExp (DCaseE exp matches) = do - caseTFName <- newUniqueName "Case" - all_locals <- allLocals - let prom_case = foldType (DConT caseTFName) (map DVarT all_locals) - (exp', ann_exp) <- promoteExp exp - (eqns, ann_matches) <- mapAndUnzipM (promoteMatch prom_case) matches - tyvarName <- qNewName "t" - let all_args = all_locals ++ [tyvarName] - tvbs = map (`DPlainTV` ()) all_args - emitDecs [DClosedTypeFamilyD (DTypeFamilyHead caseTFName tvbs DNoSig Nothing) eqns] - -- See Note [Annotate case return type] in Single - let applied_case = prom_case `DAppT` exp' - return ( applied_case - , ADCaseE ann_exp ann_matches applied_case ) -promoteExp (DLetE decs exp) = do - unique <- qNewUnique - (binds, ann_env) <- promoteLetDecs (Just unique) decs - (exp', ann_exp) <- letBind binds $ promoteExp exp - return (exp', ADLetE ann_env ann_exp) -promoteExp (DSigE exp ty) = do - (exp', ann_exp) <- promoteExp exp - ty' <- promoteType ty - return (DSigT exp' ty', ADSigE exp' ann_exp ty') -promoteExp e@(DStaticE _) = fail ("Static expressions cannot be promoted: " ++ show e) - -promoteLitExp :: OptionsMonad q => Lit -> q DType -promoteLitExp (IntegerL n) = do - opts <- getOptions - let tyFromIntegerName = promotedValueName opts fromIntegerName Nothing - tyNegateName = promotedValueName opts negateName Nothing - if n >= 0 - then return $ (DConT tyFromIntegerName `DAppT` DLitT (NumTyLit n)) - else return $ (DConT tyNegateName `DAppT` - (DConT tyFromIntegerName `DAppT` DLitT (NumTyLit (-n)))) -promoteLitExp (StringL str) = do - opts <- getOptions - let prom_str_lit = DLitT (StrTyLit str) - os_enabled <- qIsExtEnabled LangExt.OverloadedStrings - pure $ if os_enabled - then DConT (promotedValueName opts fromStringName Nothing) `DAppT` prom_str_lit - else prom_str_lit -promoteLitExp (CharL c) = return $ DLitT (CharTyLit c) -promoteLitExp lit = - fail ("Only string, natural number, and character literals can be promoted: " ++ show lit) - -promoteLitPat :: MonadFail m => Lit -> m DType -promoteLitPat (IntegerL n) - | n >= 0 = return $ (DLitT (NumTyLit n)) - | otherwise = - fail $ "Negative literal patterns are not allowed,\n" ++ - "because literal patterns are promoted to natural numbers." -promoteLitPat (StringL str) = return $ DLitT (StrTyLit str) -promoteLitPat (CharL c) = return $ DLitT (CharTyLit c) -promoteLitPat lit = - fail ("Only string, natural number, and character literals can be promoted: " ++ show lit) +{- Data/Singletons/TH/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-th package.+-}++module Data.Singletons.TH.Promote where++import Language.Haskell.TH hiding ( Q, cxt )+import Language.Haskell.TH.Syntax ( NameSpace(..), Quasi(..), Uniq )+import Language.Haskell.TH.Desugar+import qualified Language.Haskell.TH.Desugar.OMap.Strict as OMap+import Language.Haskell.TH.Desugar.OMap.Strict (OMap)+import qualified Language.Haskell.TH.Desugar.OSet as OSet+import Data.Singletons.TH.Deriving.Bounded+import Data.Singletons.TH.Deriving.Enum+import Data.Singletons.TH.Deriving.Eq+import Data.Singletons.TH.Deriving.Ord+import Data.Singletons.TH.Deriving.Show+import Data.Singletons.TH.Deriving.Util+import Data.Singletons.TH.Names+import Data.Singletons.TH.Options+import Data.Singletons.TH.Partition+import Data.Singletons.TH.Promote.Defun+import Data.Singletons.TH.Promote.Monad+import Data.Singletons.TH.Promote.Type+import Data.Singletons.TH.Syntax+import Data.Singletons.TH.Util+import Prelude hiding (exp)+import Control.Applicative (Alternative(..))+import Control.Arrow (second)+import Control.Monad+import Control.Monad.Trans.Maybe+import Control.Monad.Writer+import Data.List (nub)+import qualified Data.Map.Strict as Map+import Data.Map.Strict ( Map )+import Data.Maybe+import qualified GHC.LanguageExtensions.Type as LangExt++{-+Note [Disable genQuotedDecs in genPromotions and genSingletons]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Somewhat curiously, the genPromotions and genSingletons functions set the+genQuotedDecs option to False, despite neither function accepting quoted+declarations as arguments in the first place. There is a good reason for doing+this, however. Imagine this code:++ class C a where+ infixl 9 <%%>+ (<%%>) :: a -> a -> a+ $(genPromotions [''C])++If genQuotedDecs is set to True, then the (<%%>) type family will not receive+a fixity declaration (see+Note [singletons-th and fixity declarations] in D.S.TH.Single.Fixity, wrinkle 1 for+more details on this point). Therefore, we set genQuotedDecs to False to avoid+this problem.+-}++-- | Generate promoted definitions for each of the provided type-level+-- declaration 'Name's. This is generally only useful with classes.+genPromotions :: OptionsMonad q => [Name] -> q [Dec]+genPromotions names = do+ opts <- getOptions+ -- See Note [Disable genQuotedDecs in genPromotions and genSingletons]+ withOptions opts{genQuotedDecs = False} $ do+ checkForRep names+ infos <- mapM reifyWithLocals names+ dinfos <- mapM dsInfo infos+ ddecs <- promoteM_ [] $ mapM_ promoteInfo dinfos+ return $ decsToTH ddecs++-- | Promote every declaration given to the type level, retaining the originals.+-- See the+-- @<https://github.com/goldfirere/singletons/blob/master/README.md README>@+-- for further explanation.+promote :: OptionsMonad q => q [Dec] -> q [Dec]+promote qdecs = do+ opts <- getOptions+ withOptions opts{genQuotedDecs = True} $ promote' $ lift qdecs++-- | Promote each declaration, discarding the originals. Note that a promoted+-- datatype uses the same definition as an original datatype, so this will+-- not work with datatypes. Classes, instances, and functions are all fine.+promoteOnly :: OptionsMonad q => q [Dec] -> q [Dec]+promoteOnly qdecs = do+ opts <- getOptions+ withOptions opts{genQuotedDecs = False} $ promote' $ lift qdecs++-- The workhorse for 'promote' and 'promoteOnly'. The difference between the+-- two functions is whether 'genQuotedDecs' is set to 'True' or 'False'.+promote' :: OptionsMonad q => q [Dec] -> q [Dec]+promote' qdecs = do+ opts <- getOptions+ decs <- qdecs+ ddecs <- withLocalDeclarations decs $ dsDecs decs+ promDecs <- promoteM_ decs $ promoteDecs ddecs+ let origDecs | genQuotedDecs opts = decs+ | otherwise = []+ return $ origDecs ++ decsToTH promDecs++-- | Generate defunctionalization symbols for each of the provided type-level+-- declaration 'Name's. See the "Promotion and partial application" section of+-- the @singletons@+-- @<https://github.com/goldfirere/singletons/blob/master/README.md README>@+-- for further explanation.+genDefunSymbols :: OptionsMonad q => [Name] -> q [Dec]+genDefunSymbols names = do+ checkForRep names+ infos <- mapM (dsInfo <=< reifyWithLocals) names+ decs <- promoteMDecs [] $ concatMapM defunInfo infos+ return $ decsToTH decs++-- | Produce instances for @PEq@ from the given types+promoteEqInstances :: OptionsMonad q => [Name] -> q [Dec]+promoteEqInstances = concatMapM promoteEqInstance++-- | Produce an instance for @PEq@ from the given type+promoteEqInstance :: OptionsMonad q => Name -> q [Dec]+promoteEqInstance = promoteInstance mkEqInstance "Eq"++-- | Produce instances for 'POrd' from the given types+promoteOrdInstances :: OptionsMonad q => [Name] -> q [Dec]+promoteOrdInstances = concatMapM promoteOrdInstance++-- | Produce an instance for 'POrd' from the given type+promoteOrdInstance :: OptionsMonad q => Name -> q [Dec]+promoteOrdInstance = promoteInstance mkOrdInstance "Ord"++-- | Produce instances for 'PBounded' from the given types+promoteBoundedInstances :: OptionsMonad q => [Name] -> q [Dec]+promoteBoundedInstances = concatMapM promoteBoundedInstance++-- | Produce an instance for 'PBounded' from the given type+promoteBoundedInstance :: OptionsMonad q => Name -> q [Dec]+promoteBoundedInstance = promoteInstance mkBoundedInstance "Bounded"++-- | Produce instances for 'PEnum' from the given types+promoteEnumInstances :: OptionsMonad q => [Name] -> q [Dec]+promoteEnumInstances = concatMapM promoteEnumInstance++-- | Produce an instance for 'PEnum' from the given type+promoteEnumInstance :: OptionsMonad q => Name -> q [Dec]+promoteEnumInstance = promoteInstance mkEnumInstance "Enum"++-- | Produce instances for 'PShow' from the given types+promoteShowInstances :: OptionsMonad q => [Name] -> q [Dec]+promoteShowInstances = concatMapM promoteShowInstance++-- | Produce an instance for 'PShow' from the given type+promoteShowInstance :: OptionsMonad q => Name -> q [Dec]+promoteShowInstance = promoteInstance mkShowInstance "Show"++promoteInstance :: OptionsMonad q => DerivDesc q -> String -> Name -> q [Dec]+promoteInstance mk_inst class_name name = do+ (df, tvbs, cons) <- getDataD ("I cannot make an instance of " ++ class_name+ ++ " for it.") name+ tvbs' <- mapM dsTvbVis tvbs+ let data_ty = foldTypeTvbs (DConT name) tvbs'+ cons' <- concatMapM (dsCon tvbs' data_ty) cons+ let data_decl = DataDecl df name tvbs' cons'+ raw_inst <- mk_inst Nothing data_ty data_decl+ decs <- promoteM_ [] $ void $+ promoteInstanceDec OMap.empty Map.empty raw_inst+ return $ decsToTH decs++promoteInfo :: DInfo -> PrM ()+promoteInfo (DTyConI dec _instances) = promoteDecs [dec]+promoteInfo (DPrimTyConI _name _numArgs _unlifted) =+ fail "Promotion of primitive type constructors not supported"+promoteInfo (DVarI _name _ty _mdec) =+ fail "Promotion of individual values not supported"+promoteInfo (DTyVarI _name _ty) =+ fail "Promotion of individual type variables not supported"+promoteInfo (DPatSynI {}) =+ fail "Promotion of pattern synonyms not supported"++-- Promote a list of top-level declarations.+promoteDecs :: [DDec] -> PrM ()+promoteDecs raw_decls = do+ decls <- expand raw_decls -- expand type synonyms+ checkForRepInDecls decls+ PDecs { pd_let_decs = let_decs+ , pd_class_decs = classes+ , pd_instance_decs = insts+ , pd_data_decs = datas+ , pd_ty_syn_decs = ty_syns+ , pd_open_type_family_decs = o_tyfams+ , pd_closed_type_family_decs = c_tyfams } <- partitionDecs decls++ defunTopLevelTypeDecls ty_syns c_tyfams o_tyfams+ rec_sel_let_decs <- promoteDataDecs datas+ -- promoteLetDecs returns LetBinds, which we don't need at top level+ _ <- promoteLetDecs Nothing $ rec_sel_let_decs ++ let_decs+ mapM_ promoteClassDec classes+ let orig_meth_sigs = foldMap (lde_types . cd_lde) classes+ cls_tvbs_map = Map.fromList $ map (\cd -> (cd_name cd, cd_tvbs cd)) classes+ mapM_ (promoteInstanceDec orig_meth_sigs cls_tvbs_map) insts++-- curious about ALetDecEnv? See the LetDecEnv module for an explanation.+promoteLetDecs :: Maybe Uniq -- let-binding unique (if locally bound)+ -> [DLetDec] -> PrM ([LetBind], ALetDecEnv)+promoteLetDecs mb_let_uniq decls = do+ opts <- getOptions+ let_dec_env <- buildLetDecEnv decls+ all_locals <- allLocals+ let binds = [ (name, foldType (DConT sym) (map DVarT all_locals))+ | (name, _) <- OMap.assocs $ lde_defns let_dec_env+ , let proName = promotedValueName opts name mb_let_uniq+ sym = defunctionalizedName opts proName (length all_locals) ]+ (decs, let_dec_env') <- letBind binds $ promoteLetDecEnv mb_let_uniq let_dec_env+ emitDecs decs+ return (binds, let_dec_env' { lde_proms = OMap.fromList binds })++promoteDataDecs :: [DataDecl] -> PrM [DLetDec]+promoteDataDecs = concatMapM promoteDataDec++-- "Promotes" a data type, much like D.S.TH.Single.Data.singDataD singles a data+-- type. Promoting a data type is much easier than singling it, however, since+-- DataKinds automatically promotes data types and kinds and data constructors+-- to types. That means that promoteDataDec only has to do three things:+--+-- 1. Emit defunctionalization symbols for each data constructor,+--+-- 2. Emit promoted fixity declarations for each data constructor and promoted+-- record selector (assuming the originals have fixity declarations), and+--+-- 3. Assemble a top-level function that mimics the behavior of its record+-- selectors. Note that promoteDataDec does not actually promote this record+-- selector function—it merely returns its DLetDecs. Later, the promoteDecs+-- function takes these DLetDecs and promotes them (using promoteLetDecs).+-- This greatly simplifies the plumbing, since this allows all DLetDecs to+-- be promoted in a single location.+-- See Note [singletons-th and record selectors] in D.S.TH.Single.Data.+--+-- Note that if @NoFieldSelectors@ is active, then neither steps (2) nor (3)+-- will promote any records to top-level field selectors.+promoteDataDec :: DataDecl -> PrM [DLetDec]+promoteDataDec (DataDecl _ _ _ ctors) = do+ let rec_sel_names = nub $ concatMap extractRecSelNames ctors+ -- Note the use of nub: the same record selector name can+ -- be used in multiple constructors!+ fld_sels <- qIsExtEnabled LangExt.FieldSelectors+ rec_sel_let_decs <- if fld_sels then getRecordSelectors ctors else pure []+ ctorSyms <- buildDefunSymsDataD ctors+ -- NB: If NoFieldSelectors is active, then promoteReifiedInfixDecls will not+ -- promote any of `rec_sel_names` to field selectors, so there is no need to+ -- check for it here.+ infix_decs <- promoteReifiedInfixDecls rec_sel_names+ emitDecs $ ctorSyms ++ infix_decs+ pure rec_sel_let_decs++promoteClassDec :: UClassDecl -> PrM AClassDecl+promoteClassDec decl@(ClassDecl { cd_name = cls_name+ , cd_tvbs = tvbs+ , cd_fds = fundeps+ , cd_atfs = atfs+ , cd_lde = lde@LetDecEnv+ { lde_defns = defaults+ , lde_types = meth_sigs+ , lde_infix = infix_decls } }) = do+ opts <- getOptions+ let pClsName = promotedClassName opts cls_name+ meth_sigs_list = OMap.assocs meth_sigs+ meth_names = map fst meth_sigs_list+ defaults_list = OMap.assocs defaults+ defaults_names = map fst defaults_list+ mb_cls_sak <- dsReifyType cls_name+ sig_decs <- mapM (uncurry promote_sig) meth_sigs_list+ (default_decs, ann_rhss, prom_rhss)+ <- mapAndUnzip3M (promoteMethod DefaultMethods meth_sigs) defaults_list+ defunAssociatedTypeFamilies tvbs atfs++ infix_decls' <- mapMaybeM (uncurry (promoteInfixDecl Nothing)) $+ OMap.assocs infix_decls+ cls_infix_decls <- promoteReifiedInfixDecls $ cls_name:meth_names++ -- no need to do anything to the fundeps. They work as is!+ let pro_cls_dec = DClassD [] pClsName tvbs fundeps+ (sig_decs ++ default_decs ++ infix_decls')+ mb_pro_cls_sak = fmap (DKiSigD pClsName) mb_cls_sak+ emitDecs $ maybeToList mb_pro_cls_sak ++ pro_cls_dec:cls_infix_decls+ let defaults_list' = zip defaults_names ann_rhss+ proms = zip defaults_names prom_rhss+ return (decl { cd_lde = lde { lde_defns = OMap.fromList defaults_list'+ , lde_proms = OMap.fromList proms } })+ where+ promote_sig :: Name -> DType -> PrM DDec+ promote_sig name ty = do+ opts <- getOptions+ let proName = promotedTopLevelValueName opts name+ -- When computing the kind to use for the defunctionalization symbols,+ -- /don't/ use the type variable binders from the method's type...+ (_, argKs, resK) <- promoteUnraveled ty+ args <- mapM (const $ qNewName "arg") argKs+ let proTvbs = zipWith (`DKindedTV` BndrReq) args argKs+ -- ...instead, compute the type variable binders in a left-to-right order,+ -- since that is the same order that the promoted method's kind will use.+ -- See Note [Promoted class methods and kind variable ordering]+ meth_sak_tvbs = changeDTVFlags SpecifiedSpec $+ toposortTyVarsOf $ argKs ++ [resK]+ meth_sak = ravelVanillaDType meth_sak_tvbs [] argKs resK+ m_fixity <- reifyFixityWithLocals name+ emitDecsM $ defunctionalize proName m_fixity $ DefunSAK meth_sak++ return $ DOpenTypeFamilyD (DTypeFamilyHead proName+ proTvbs+ (DKindSig resK)+ Nothing)++{-+Note [Promoted class methods and kind variable ordering]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general, we make an effort to preserve the order of type variables when+promoting type signatures, but there is an annoying corner case where this is+difficult: class methods. When promoting class methods, the order of kind+variables in their kinds will often "just work" by happy coincidence, but+there are some situations where this does not happen. Consider the following+class:++ class C (b :: Type) where+ m :: forall a. a -> b -> a++The full type of `m` is `forall b. C b => forall a. a -> b -> a`, which binds+`b` before `a`. This order is preserved when singling `m`, but *not* when+promoting `m`. This is because the `C` class is promoted as follows:++ class PC (b :: Type) where+ type M (x :: a) (y :: b) :: a++Due to the way GHC kind-checks associated type families, the kind of `M` is+`forall a b. a -> b -> a`, which binds `b` *after* `a`. Moreover, the+`StandaloneKindSignatures` extension does not provide a way to explicitly+declare the full kind of an associated type family, so this limitation is+not easy to work around.++The defunctionalization symbols for `M` will also follow a similar+order of type variables:++ type MSym0 :: forall a b. a ~> b ~> a+ type MSym1 :: forall a b. a -> b ~> a++There is one potential hack we could use to rectify this:++ type FlipConst x y = y+ class PC (b :: Type) where+ type M (x :: FlipConst '(b, a) a) (y :: b) :: a++Using `FlipConst` would cause `b` to be mentioned before `a`, which would give+`M` the kind `forall b a. FlipConst '(b, a) a -> b -> a`. While the order of+type variables would be preserved, the downside is that the ugly `FlipConst`+type synonym leaks into the kind. I'm not particularly fond of this, so I have+decided not to use this hack unless someone specifically requests it.+-}++-- returns (unpromoted method name, ALetDecRHS) pairs+promoteInstanceDec :: OMap Name DType+ -- Class method type signatures+ -> Map Name [DTyVarBndrVis]+ -- Class header type variable (e.g., if `class C a b` is+ -- quoted, then this will have an entry for {C |-> [a, b]})+ -> UInstDecl -> PrM AInstDecl+promoteInstanceDec orig_meth_sigs cls_tvbs_map+ decl@(InstDecl { id_name = cls_name+ , id_arg_tys = inst_tys+ , id_sigs = inst_sigs+ , id_meths = meths }) = do+ opts <- getOptions+ cls_tvbs <- lookup_cls_tvbs+ inst_kis <- mapM promoteType inst_tys+ let pClsName = promotedClassName opts cls_name+ cls_tvb_names = map extractTvbName cls_tvbs+ subst = Map.fromList $ zip cls_tvb_names inst_kis+ meth_impl = InstanceMethods inst_sigs subst+ (meths', ann_rhss, _)+ <- mapAndUnzip3M (promoteMethod meth_impl orig_meth_sigs) meths+ emitDecs [DInstanceD Nothing Nothing [] (foldType (DConT pClsName)+ inst_kis) meths']+ return (decl { id_meths = zip (map fst meths) ann_rhss })+ where+ lookup_cls_tvbs :: PrM [DTyVarBndrVis]+ lookup_cls_tvbs =+ -- First, try consulting the map of class names to their type variables.+ -- It is important to do this first to ensure that we consider locally+ -- declared classes before imported ones. See #410 for what happens if+ -- you don't.+ case Map.lookup cls_name cls_tvbs_map of+ Just tvbs -> pure tvbs+ Nothing -> reify_cls_tvbs+ -- If the class isn't present in this map, we try reifying the class+ -- as a last resort.++ reify_cls_tvbs :: PrM [DTyVarBndrVis]+ reify_cls_tvbs = do+ opts <- getOptions+ let pClsName = promotedClassName opts cls_name+ mk_tvbs = extract_tvbs (dsReifyTypeNameInfo pClsName)+ <|> extract_tvbs (dsReifyTypeNameInfo cls_name)+ -- See Note [Using dsReifyTypeNameInfo when promoting instances]+ mb_tvbs <- runMaybeT mk_tvbs+ case mb_tvbs of+ Just tvbs -> pure tvbs+ Nothing -> fail $ "Cannot find class declaration annotation for " ++ show cls_name++ extract_tvbs :: PrM (Maybe DInfo) -> MaybeT PrM [DTyVarBndrVis]+ extract_tvbs reify_info = do+ mb_info <- lift reify_info+ case mb_info of+ Just (DTyConI (DClassD _ _ tvbs _ _) _) -> pure tvbs+ _ -> empty++{-+Note [Using dsReifyTypeNameInfo when promoting instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+During the promotion of a class instance, it becomes necessary to reify the+original promoted class's info to learn various things. It's tempting to think+that just calling dsReify on the class name will be sufficient, but it's not.+Consider this class and its promotion:++ class Eq a where+ (==) :: a -> a -> Bool++ class PEq a where+ type (==) (x :: a) (y :: a) :: Bool++Notice how both of these classes have an identifier named (==), one at the+value level, and one at the type level. Now imagine what happens when you+attempt to promote this Template Haskell declaration:++ [d| f :: Bool+ f = () == () |]++When promoting ==, singletons-th will come up with its promoted equivalent (which also+happens to be ==). However, this promoted name is a raw Name, since it is created+with mkName. This becomes an issue when we call dsReify the raw "==" Name, as+Template Haskell has to arbitrarily choose between reifying the info for the+value-level (==) and the type-level (==), and in this case, it happens to pick the+value-level (==) info. We want the type-level (==) info, however, because we care+about the promoted version of (==).++Fortunately, there's a serviceable workaround. Instead of dsReify, we can use+dsReifyTypeNameInfo, which first calls lookupTypeName (to ensure we can find a Name+that's in the type namespace) and _then_ reifies it.+-}++-- Which sort of class methods are being promoted?+data MethodSort+ -- The method defaults in class declarations.+ = DefaultMethods+ -- The methods in instance declarations.+ | InstanceMethods (OMap Name DType) -- ^ InstanceSigs+ (Map Name DKind) -- ^ Instantiations for class tyvars+ -- See Note [Promoted class method kinds]+ deriving Show++promoteMethod :: MethodSort+ -> OMap Name DType -- method types+ -> (Name, ULetDecRHS)+ -> PrM (DDec, ALetDecRHS, DType)+ -- returns (type instance, ALetDecRHS, promoted RHS)+promoteMethod meth_sort orig_sigs_map (meth_name, meth_rhs) = do+ opts <- getOptions+ (meth_arg_kis, meth_res_ki) <- promote_meth_ty+ meth_arg_tvs <- replicateM (length meth_arg_kis) (qNewName "a")+ let proName = promotedTopLevelValueName opts meth_name+ helperNameBase = case nameBase proName of+ first:_ | not (isHsLetter first) -> "TFHelper"+ alpha -> alpha++ -- family_args are the type variables in a promoted class's+ -- associated type family instance (or default implementation), e.g.,+ --+ -- class C k where+ -- type T (a :: k) (b :: Bool)+ -- type T a b = THelper1 a b -- family_args = [a, b]+ --+ -- instance C Bool where+ -- type T a b = THelper2 a b -- family_args = [a, b]+ --+ -- We could annotate these variables with explicit kinds, but it's not+ -- strictly necessary, as kind inference can figure them out just as well.+ family_args = map DVarT meth_arg_tvs+ helperName <- newUniqueName helperNameBase+ let helperDefunName = defunctionalizedName0 opts helperName+ (pro_decs, defun_decs, ann_rhs)+ <- promoteLetDecRHS (ClassMethodRHS meth_arg_kis meth_res_ki)+ OMap.empty OMap.empty+ Nothing helperName meth_rhs+ emitDecs (pro_decs ++ defun_decs)+ return ( DTySynInstD+ (DTySynEqn Nothing+ (foldType (DConT proName) family_args)+ (foldApply (DConT helperDefunName) (map DVarT meth_arg_tvs)))+ , ann_rhs+ , DConT helperDefunName )+ where+ -- Promote the type of a class method. For a default method, "the type" is+ -- simply the type of the original method. For an instance method,+ -- "the type" is like the type of the original method, but substituted for+ -- the types in the instance head. (e.g., if you have `class C a` and+ -- `instance C T`, then the substitution [a |-> T] must be applied to the+ -- original method's type.)+ promote_meth_ty :: PrM ([DKind], DKind)+ promote_meth_ty =+ case meth_sort of+ DefaultMethods ->+ -- No substitution for class variables is required for default+ -- method type signatures, as they share type variables with the+ -- class they inhabit.+ lookup_meth_ty+ InstanceMethods inst_sigs_map cls_subst ->+ case OMap.lookup meth_name inst_sigs_map of+ Just ty -> do+ -- We have an InstanceSig. These are easy: we can just use the+ -- instance signature's type directly, and no substitution for+ -- class variables is required.+ (_tvbs, arg_kis, res_ki) <- promoteUnraveled ty+ pure (arg_kis, res_ki)+ Nothing -> do+ -- We don't have an InstanceSig, so we must compute the kind to use+ -- ourselves.+ (arg_kis, res_ki) <- lookup_meth_ty+ -- Substitute for the class variables in the method's type.+ -- See Note [Promoted class method kinds]+ let arg_kis' = map (substKind cls_subst) arg_kis+ res_ki' = substKind cls_subst res_ki+ pure (arg_kis', res_ki')++ -- Attempt to look up a class method's original type.+ lookup_meth_ty :: PrM ([DKind], DKind)+ lookup_meth_ty = do+ opts <- getOptions+ let proName = promotedTopLevelValueName opts meth_name+ case OMap.lookup meth_name orig_sigs_map of+ Just ty -> do+ -- The type of the method is in scope, so promote that.+ (_tvbs, arg_kis, res_ki) <- promoteUnraveled ty+ pure (arg_kis, res_ki)+ Nothing -> do+ -- If the type of the method is not in scope, the only other option+ -- is to try reifying the promoted method name.+ mb_info <- dsReifyTypeNameInfo proName+ -- See Note [Using dsReifyTypeNameInfo when promoting instances]+ case mb_info of+ Just (DTyConI (DOpenTypeFamilyD (DTypeFamilyHead _ tvbs mb_res_ki _)) _)+ -> let arg_kis = map (defaultMaybeToTypeKind . extractTvbKind) tvbs+ res_ki = defaultMaybeToTypeKind (resultSigToMaybeKind mb_res_ki)+ in pure (arg_kis, res_ki)+ _ -> fail $ "Cannot find type annotation for " ++ show proName++{-+Note [Promoted class method kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this example of a type class (and instance):++ class C a where+ m :: a -> Bool -> Bool+ m _ x = x++ instance C [a] where+ m l _ = null l++The promoted version of these declarations would be:++ class PC a where+ type M (x :: a) (y :: Bool) :: Bool+ type M x y = MHelper1 x y++ instance PC [a] where+ type M x y = MHelper2 x y++ type MHelper1 :: a -> Bool -> Bool+ type family MHelper1 x y where ...++ type MHelper2 :: [a] -> Bool -> Bool+ type family MHelper2 x y where ...++Getting the kind signature for MHelper1 (the promoted default implementation of+M) is quite simple, as it corresponds exactly to the kind of M. We might even+choose to make that the kind of MHelper2, but then it would be overly general+(and more difficult to find in -ddump-splices output). For this reason, we+substitute in the kinds of the instance itself to determine the kinds of+promoted method implementations like MHelper2.+-}++promoteLetDecEnv :: Maybe Uniq -> ULetDecEnv -> PrM ([DDec], ALetDecEnv)+promoteLetDecEnv mb_let_uniq (LetDecEnv { lde_defns = value_env+ , lde_types = type_env+ , lde_infix = fix_env }) = do+ infix_decls <- mapMaybeM (uncurry (promoteInfixDecl mb_let_uniq)) $+ OMap.assocs fix_env++ -- promote all the declarations, producing annotated declarations+ let (names, rhss) = unzip $ OMap.assocs value_env+ (pro_decs, defun_decss, ann_rhss)+ <- fmap unzip3 $+ zipWithM (promoteLetDecRHS LetBindingRHS type_env fix_env mb_let_uniq)+ names rhss++ emitDecs $ concat defun_decss+ let decs = concat pro_decs ++ infix_decls++ -- build the ALetDecEnv+ let let_dec_env' = LetDecEnv { lde_defns = OMap.fromList $ zip names ann_rhss+ , lde_types = type_env+ , lde_infix = fix_env+ , lde_proms = OMap.empty -- filled in promoteLetDecs+ }++ return (decs, let_dec_env')++-- Promote a fixity declaration.+promoteInfixDecl :: forall q. OptionsMonad q+ => Maybe Uniq -> Name -> Fixity -> q (Maybe DDec)+promoteInfixDecl mb_let_uniq name fixity = do+ opts <- getOptions+ fld_sels <- qIsExtEnabled LangExt.FieldSelectors+ mb_ns <- reifyNameSpace name+ case mb_ns of+ -- If we can't find the Name for some odd reason, fall back to promote_val+ Nothing -> promote_val+ Just VarName -> promote_val+ Just (FldName _)+ | fld_sels -> promote_val+ | otherwise -> never_mind+ Just DataName -> never_mind+ Just TcClsName -> do+ mb_info <- dsReify name+ case mb_info of+ Just (DTyConI DClassD{} _)+ -> finish $ promotedClassName opts name+ _ -> never_mind+ where+ -- Produce the fixity declaration.+ finish :: Name -> q (Maybe DDec)+ finish = pure . Just . DLetDec . DInfixD fixity++ -- Don't produce a fixity declaration at all. This can happen in the+ -- following circumstances:+ --+ -- - When promoting a fixity declaration for a name whose promoted+ -- counterpart is the same as the original name.+ -- See Note [singletons-th and fixity declarations] in+ -- D.S.TH.Single.Fixity, wrinkle 1.+ --+ -- - A fixity declaration contains the name of a record selector when+ -- NoFieldSelectors is active.+ never_mind :: q (Maybe DDec)+ never_mind = pure Nothing++ -- Certain value names do not change when promoted (e.g., infix names).+ -- Therefore, don't bother promoting their fixity declarations if+ -- 'genQuotedDecs' is set to 'True', since that will run the risk of+ -- generating duplicate fixity declarations.+ -- See Note [singletons-th and fixity declarations] in D.S.TH.Single.Fixity, wrinkle 1.+ promote_val :: q (Maybe DDec)+ promote_val = do+ opts <- getOptions+ let promoted_name :: Name+ promoted_name = promotedValueName opts name mb_let_uniq+ if nameBase name == nameBase promoted_name && genQuotedDecs opts+ then never_mind+ else finish promoted_name++-- Try producing promoted fixity declarations for Names by reifying them+-- /without/ consulting quoted declarations. If reification fails, recover and+-- return the empty list.+-- See [singletons-th and fixity declarations] in D.S.TH.Single.Fixity, wrinkle 2.+promoteReifiedInfixDecls :: forall q. OptionsMonad q => [Name] -> q [DDec]+promoteReifiedInfixDecls = mapMaybeM tryPromoteFixityDeclaration+ where+ tryPromoteFixityDeclaration :: Name -> q (Maybe DDec)+ tryPromoteFixityDeclaration name =+ qRecover (return Nothing) $ do+ mFixity <- qReifyFixity name+ case mFixity of+ Nothing -> pure Nothing+ Just fixity -> promoteInfixDecl Nothing name fixity++-- Which sort of let-bound declaration's right-hand side is being promoted?+data LetDecRHSSort+ -- An ordinary (i.e., non-class-related) let-bound declaration.+ = LetBindingRHS+ -- The right-hand side of a class method (either a default method or a+ -- method in an instance declaration).+ | ClassMethodRHS+ [DKind] DKind+ -- The RHS's promoted argument and result types. Needed to fix #136.+ deriving Show++-- This function is used both to promote class method defaults and normal+-- let bindings. Thus, it can't quite do all the work locally and returns+-- an intermediate structure. Perhaps a better design is available.+promoteLetDecRHS :: LetDecRHSSort+ -> OMap Name DType -- local type env't+ -> OMap Name Fixity -- local fixity env't+ -> Maybe Uniq -- let-binding unique (if locally bound)+ -> Name -- name of the thing being promoted+ -> ULetDecRHS -- body of the thing+ -> PrM ( [DDec] -- promoted type family dec, plus the+ -- SAK dec (if one exists)+ , [DDec] -- defunctionalization+ , ALetDecRHS ) -- annotated RHS+promoteLetDecRHS rhs_sort type_env fix_env mb_let_uniq name let_dec_rhs = do+ all_locals <- allLocals+ case let_dec_rhs of+ UValue exp -> do+ (m_ldrki, ty_num_args) <- promote_let_dec_ty all_locals 0+ if ty_num_args == 0+ then do+ prom_fun_lhs <- promoteLetDecName mb_let_uniq name m_ldrki all_locals+ promote_let_dec_rhs all_locals m_ldrki 0 (promoteExp exp)+ (\exp' -> [DTySynEqn Nothing prom_fun_lhs exp'])+ AValue+ else+ -- If we have a UValue with a function type, process it as though it+ -- were a UFunction. promote_function_rhs will take care of+ -- eta-expanding arguments as necessary.+ promote_function_rhs all_locals [DClause [] exp]+ UFunction clauses -> promote_function_rhs all_locals clauses+ where+ -- Promote the RHS of a UFunction (or a UValue with a function type).+ promote_function_rhs :: [Name]+ -> [DClause] -> PrM ([DDec], [DDec], ALetDecRHS)+ promote_function_rhs all_locals clauses = do+ numArgs <- count_args clauses+ (m_ldrki, ty_num_args) <- promote_let_dec_ty all_locals numArgs+ expClauses <- mapM (etaContractOrExpand ty_num_args numArgs) clauses+ let promote_clause = promoteClause mb_let_uniq name m_ldrki all_locals+ promote_let_dec_rhs all_locals m_ldrki ty_num_args+ (mapAndUnzipM promote_clause expClauses)+ id (AFunction ty_num_args)++ -- Promote a UValue or a UFunction.+ -- Notes about type variables:+ --+ -- * For UValues, `prom_a` is DType and `a` is Exp.+ --+ -- * For UFunctions, `prom_a` is [DTySynEqn] and `a` is [DClause].+ promote_let_dec_rhs+ :: [Name] -- Local variables bound in this scope+ -> Maybe LetDecRHSKindInfo -- Information about the promoted kind (if present)+ -> Int -- The number of promoted function arguments+ -> PrM (prom_a, a) -- Promote the RHS+ -> (prom_a -> [DTySynEqn]) -- Turn the promoted RHS into type family equations+ -> (a -> ALetDecRHS) -- Build an ALetDecRHS+ -> PrM ([DDec], [DDec], ALetDecRHS)+ promote_let_dec_rhs all_locals m_ldrki ty_num_args+ promote_thing mk_prom_eqns mk_alet_dec_rhs = do+ opts <- getOptions+ tyvarNames <- replicateM ty_num_args (qNewName "a")+ let proName = promotedValueName opts name mb_let_uniq+ local_tvbs = map (`DPlainTV` BndrReq) all_locals+ m_fixity = OMap.lookup name fix_env++ mk_tf_head :: [DTyVarBndrVis] -> DFamilyResultSig -> DTypeFamilyHead+ mk_tf_head arg_tvbs res_sig =+ dTypeFamilyHead_with_locals proName all_locals arg_tvbs res_sig++ (lde_kvs_to_bind, m_sak_dec, defun_ki, tf_head) =+ -- There are three possible cases:+ case m_ldrki of+ -- 1. We have no kind information whatsoever.+ Nothing ->+ let arg_tvbs = map (`DPlainTV` BndrReq) tyvarNames in+ ( OSet.empty+ , Nothing+ , DefunNoSAK (local_tvbs ++ arg_tvbs) Nothing+ , mk_tf_head arg_tvbs DNoSig+ )+ -- 2. We have some kind information in the form of a LetDecRHSKindInfo.+ Just (LDRKI m_sak tvbs argKs resK) ->+ let arg_tvbs = zipWith (`DKindedTV` BndrReq) tyvarNames argKs+ lde_kvs_to_bind' = OSet.fromList (map extractTvbName tvbs) in+ case m_sak of+ -- 2(a). We do not have a standalone kind signature.+ Nothing ->+ ( lde_kvs_to_bind'+ , Nothing+ , DefunNoSAK (local_tvbs ++ arg_tvbs) (Just resK)+ , mk_tf_head arg_tvbs (DKindSig resK)+ )+ -- 2(b). We have a standalone kind signature.+ Just sak ->+ ( lde_kvs_to_bind'+ , Just $ DKiSigD proName sak+ , DefunSAK sak+ -- We opt to annotate the argument and result kinds in+ -- the body of the type family declaration even if it is+ -- given a standalone kind signature.+ -- See Note [Keep redundant kind information for Haddocks].+ , mk_tf_head arg_tvbs (DKindSig resK)+ )++ defun_decs <- defunctionalize proName m_fixity defun_ki+ (prom_thing, thing) <- scopedBind lde_kvs_to_bind promote_thing+ return ( catMaybes [ m_sak_dec+ , Just $ DClosedTypeFamilyD tf_head (mk_prom_eqns prom_thing)+ ]+ , defun_decs+ , mk_alet_dec_rhs thing )++ promote_let_dec_ty :: [Name] -- The local variables that the let-dec closes+ -- over. If this is non-empty, we cannot+ -- produce a standalone kind signature.+ -- See Note [No SAKs for let-decs with local variables]+ -> Int -- The number of arguments to default to if the+ -- type cannot be inferred. This is 0 for UValues+ -- and the number of arguments in a single clause+ -- for UFunctions.+ -> PrM (Maybe LetDecRHSKindInfo, Int)+ -- Returns two things in a pair:+ --+ -- 1. Information about the promoted kind,+ -- if available.+ --+ -- 2. The number of arguments the let-dec has.+ -- If no kind information is available from+ -- which to infer this number, then this+ -- will default to the earlier Int argument.+ promote_let_dec_ty all_locals default_num_args =+ case rhs_sort of+ ClassMethodRHS arg_kis res_ki+ -> -- For class method RHS helper functions, don't bother quantifying+ -- any type variables in their SAKS. We could certainly try, but+ -- given that these functions are only used internally, there's no+ -- point in trying to get the order of type variables correct,+ -- since we don't apply these functions with visible kind+ -- applications.+ let sak = ravelVanillaDType [] [] arg_kis res_ki in+ return (Just (LDRKI (Just sak) [] arg_kis res_ki), length arg_kis)+ LetBindingRHS+ | Just ty <- OMap.lookup name type_env+ -> do+ -- promoteType turns rank-1 uses of (->) into (~>). So, we unravel+ -- first to avoid this behavior, and then ravel back.+ (tvbs, argKs, resultK) <- promoteUnraveled ty+ let m_sak | null all_locals = Just $ ravelVanillaDType tvbs [] argKs resultK+ -- If this let-dec closes over local variables, then+ -- don't give it a SAK.+ -- See Note [No SAKs for let-decs with local variables]+ | otherwise = Nothing+ -- invariant: count_args ty == length argKs+ return (Just (LDRKI m_sak tvbs argKs resultK), length argKs)++ | otherwise+ -> return (Nothing, default_num_args)++ etaContractOrExpand :: Int -> Int -> DClause -> PrM DClause+ etaContractOrExpand ty_num_args clause_num_args (DClause pats exp)+ | n >= 0 = do -- Eta-expand+ names <- replicateM n (newUniqueName "a")+ let newPats = map DVarP names+ newArgs = map DVarE names+ return $ DClause (pats ++ newPats) (foldExp exp newArgs)+ | otherwise = do -- Eta-contract+ let (clausePats, lamPats) = splitAt ty_num_args pats+ lamExp <- mkDLamEFromDPats lamPats exp+ return $ DClause clausePats lamExp+ where+ n = ty_num_args - clause_num_args++ count_args :: [DClause] -> PrM Int+ count_args (DClause pats _ : _) = return $ length pats+ count_args _ = fail $ "Impossible! A function without clauses."++-- An auxiliary data type used in promoteLetDecRHS that describes information+-- related to the promoted kind of a class method default or normal+-- let binding.+data LetDecRHSKindInfo =+ LDRKI (Maybe DKind) -- The standalone kind signature, if applicable.+ -- This will be Nothing if the let-dec RHS has local+ -- variables that it closes over.+ -- See Note [No SAKs for let-decs with local variables]+ [DTyVarBndrSpec] -- The type variable binders of the kind.+ [DKind] -- The argument kinds.+ DKind -- The result kind.++{-+Note [No SAKs for let-decs with local variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider promoting this:++ f :: Bool+ f = let x = True+ g :: () -> Bool+ g _ = x+ in g ()++Clearly, the promoted `F` type family will have the following SAK:++ type F :: ()++What about `G`? At a passing glance, it appears that you could get away with+this:++ type G :: Bool -> ()++But this isn't quite right, since `g` closes over `x = True`. The body of `G`,+therefore, has to lift `x` to be an explicit argument:++ type family G x (u :: ()) :: Bool where+ G x _ = x++At present, we don't keep track of the types of local variables like `x`, which+makes it difficult to create a SAK for things like `G`. Here are some possible+ideas, each followed by explanations for why they are infeasible:++* Use wildcards:++ type G :: _ -> () -> Bool++ Alas, GHC currently does not allow wildcards in SAKs. See GHC#17432.++* Use visible dependent quantification to avoid having to say what the kind+ of `x` is:++ type G :: forall x -> () -> Bool++ A clever trick to be sure, but it doesn't quite do what we want, since+ GHC will generalize that kind to become `forall (x :: k) -> () -> Bool`,+ which is more general than we want.++In any case, it's probably not worth bothering with SAKs for local definitions+like `g` in the first place, so we avoid generating SAKs for anything that+closes over at least one local variable for now. If someone yells about this,+we'll reconsider this design.++Note [Keep redundant kind information for Haddocks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+`singletons-th` generates explicit argument kinds and result kinds for+type-level declarations whenever possible, even if those kinds are technically+redundant. For example, `singletons-th` would promote this:++ id' :: a -> a++To this:++ type Id' :: a -> a+ type family Id' (x :: a) :: a where ...++Strictly speaking, the argument and result kind of Id' are unnecessary, since+the same information is already present in the standalone kind signature.+However, due to a Haddock limitation+(https://github.com/haskell/haddock/issues/1178), Haddock will not render+standalone kind signatures at all, so if the argument and result kind of Id'+were omitted in the body, Haddock would render it like so:++ type family Id' x where ...++This is unfortunate for Haddock viewers, as this does not convey any kind+information whatsoever. Until the aformentioned Haddock issue is resolved, we+work around this limitation by generating the redundant argument and kind+information anyway. Thankfully, this is simple to accomplish, as we already+compute this information to begin with.+-}++promoteClause :: Maybe Uniq+ -- ^ Let-binding unique (if locally bound)+ -> Name+ -- ^ Name of the function being promoted+ -> Maybe LetDecRHSKindInfo+ -- ^ Information about the promoted kind (if present)+ -> [Name]+ -- ^ The local variables currently in scope+ -> DClause -> PrM (DTySynEqn, ADClause)+promoteClause mb_let_uniq name m_ldrki all_locals (DClause pats exp) = do+ -- promoting the patterns creates variable bindings. These are passed+ -- to the function promoted the RHS+ ((types, pats'), prom_pat_infos) <- evalForPair $ mapAndUnzipM promotePat pats+ -- If the function has scoped type variables, then we annotate each argument+ -- in the promoted type family equation with its kind.+ -- See Note [Scoped type variables] in Data.Singletons.TH.Promote.Monad for an+ -- explanation of why we do this.+ scoped_tvs <- qIsExtEnabled LangExt.ScopedTypeVariables+ let types_w_kinds =+ case m_ldrki of+ Just (LDRKI _ tvbs kinds _)+ | not (null tvbs) && scoped_tvs+ -> zipWith DSigT types kinds+ _ -> types+ let PromDPatInfos { prom_dpat_vars = new_vars+ , prom_dpat_sig_kvs = sig_kvs } = prom_pat_infos+ (ty, ann_exp) <- scopedBind sig_kvs $+ lambdaBind new_vars $+ promoteExp exp+ pro_clause_fun <- promoteLetDecName mb_let_uniq name m_ldrki all_locals+ return ( DTySynEqn Nothing (foldType pro_clause_fun types_w_kinds) ty+ , ADClause new_vars pats' ann_exp )++promoteMatch :: DType -- What to use as the LHS of the promoted type family+ -- equation. This should consist of the promoted name of+ -- the case expression to which the match belongs, applied+ -- to any local arguments (e.g., `Case x y z`).+ -> DMatch -> PrM (DTySynEqn, ADMatch)+promoteMatch pro_case_fun (DMatch pat exp) = do+ -- promoting the patterns creates variable bindings. These are passed+ -- to the function promoted the RHS+ ((ty, pat'), prom_pat_infos) <- evalForPair $ promotePat pat+ let PromDPatInfos { prom_dpat_vars = new_vars+ , prom_dpat_sig_kvs = sig_kvs } = prom_pat_infos+ (rhs, ann_exp) <- scopedBind sig_kvs $+ lambdaBind new_vars $+ promoteExp exp+ return $ ( DTySynEqn Nothing (pro_case_fun `DAppT` ty) rhs+ , ADMatch new_vars pat' ann_exp)++-- promotes a term pattern into a type pattern, accumulating bound variable names+promotePat :: DPat -> QWithAux PromDPatInfos PrM (DType, ADPat)+promotePat (DLitP lit) = (, ADLitP lit) <$> promoteLitPat lit+promotePat (DVarP name) = do+ -- term vars can be symbols... type vars can't!+ tyName <- mkTyName name+ tell $ PromDPatInfos [(name, tyName)] OSet.empty+ return (DVarT tyName, ADVarP name)+promotePat (DConP name tys pats) = do+ opts <- getOptions+ kis <- traverse (promoteType_options conOptions) tys+ (types, pats') <- mapAndUnzipM promotePat pats+ let name' = promotedDataTypeOrConName opts name+ return (foldType (foldl DAppKindT (DConT name') kis) types, ADConP name kis pats')+ where+ -- Currently, visible type patterns of data constructors are the one place+ -- in `singletons-th` where it makes sense to promote wildcard types, as it+ -- will produce code that GHC will accept.+ conOptions :: PromoteTypeOptions+ conOptions = defaultPromoteTypeOptions{ptoAllowWildcards = True}+promotePat (DTildeP pat) = do+ qReportWarning "Lazy pattern converted into regular pattern in promotion"+ second ADTildeP <$> promotePat pat+promotePat (DBangP pat) = do+ qReportWarning "Strict pattern converted into regular pattern in promotion"+ second ADBangP <$> promotePat pat+promotePat (DSigP pat ty) = do+ -- We must maintain the invariant that any promoted pattern signature must+ -- not have any wildcards in the underlying pattern.+ -- See Note [Singling pattern signatures].+ wildless_pat <- removeWilds pat+ (promoted, pat') <- promotePat wildless_pat+ ki <- promoteType ty+ tell $ PromDPatInfos [] (fvDType ki)+ return (DSigT promoted ki, ADSigP promoted pat' ki)+promotePat DWildP = return (DWildCardT, ADWildP)++promoteExp :: DExp -> PrM (DType, ADExp)+promoteExp (DVarE name) = fmap (, ADVarE name) $ lookupVarE name+promoteExp (DConE name) = do+ opts <- getOptions+ return (DConT $ defunctionalizedName0 opts name, ADConE name)+promoteExp (DLitE lit) = fmap (, ADLitE lit) $ promoteLitExp lit+promoteExp (DAppE exp1 exp2) = do+ (exp1', ann_exp1) <- promoteExp exp1+ (exp2', ann_exp2) <- promoteExp exp2+ return (apply exp1' exp2', ADAppE ann_exp1 ann_exp2)+-- Until we get visible kind applications, this is the best we can do.+promoteExp (DAppTypeE exp _) = do+ qReportWarning "Visible type applications are ignored by `singletons-th`."+ promoteExp exp+promoteExp (DLamE names exp) = do+ opts <- getOptions+ lambdaName <- newUniqueName "Lambda"+ tyNames <- mapM mkTyName names+ let var_proms = zip names tyNames+ (rhs, ann_exp) <- lambdaBind var_proms $ promoteExp exp+ all_locals <- allLocals+ let tvbs = map (`DPlainTV` BndrReq) tyNames+ all_args = all_locals ++ tyNames+ all_tvbs = map (`DPlainTV` BndrReq) all_args+ tfh = dTypeFamilyHead_with_locals lambdaName all_locals tvbs DNoSig+ emitDecs [DClosedTypeFamilyD+ tfh+ [DTySynEqn Nothing+ (foldType (DConT lambdaName) (map DVarT all_args))+ rhs]]+ emitDecsM $ defunctionalize lambdaName Nothing $ DefunNoSAK all_tvbs Nothing+ let promLambda = foldApply (DConT (defunctionalizedName opts lambdaName 0))+ (map DVarT all_locals)+ return (promLambda, ADLamE tyNames promLambda names ann_exp)+promoteExp (DCaseE exp matches) = do+ caseTFName <- newUniqueName "Case"+ all_locals <- allLocals+ let prom_case = foldType (DConT caseTFName) (map DVarT all_locals)+ (exp', ann_exp) <- promoteExp exp+ (eqns, ann_matches) <- mapAndUnzipM (promoteMatch prom_case) matches+ tyvarName <- qNewName "t"+ let tvbs = [DPlainTV tyvarName BndrReq]+ tfh = dTypeFamilyHead_with_locals caseTFName all_locals tvbs DNoSig+ emitDecs [DClosedTypeFamilyD tfh eqns]+ -- See Note [Annotate case return type] in Single+ let applied_case = prom_case `DAppT` exp'+ return ( applied_case+ , ADCaseE ann_exp ann_matches applied_case )+promoteExp (DLetE decs exp) = do+ unique <- qNewUnique+ (binds, ann_env) <- promoteLetDecs (Just unique) decs+ (exp', ann_exp) <- letBind binds $ promoteExp exp+ return (exp', ADLetE ann_env ann_exp)+promoteExp (DSigE exp ty) = do+ (exp', ann_exp) <- promoteExp exp+ ty' <- promoteType ty+ return (DSigT exp' ty', ADSigE exp' ann_exp ty')+promoteExp e@(DStaticE _) = fail ("Static expressions cannot be promoted: " ++ show e)+promoteExp e@(DTypedBracketE _) = fail ("Typed bracket expressions cannot be promoted: " ++ show e)+promoteExp e@(DTypedSpliceE _) = fail ("Typed splice expressions cannot be promoted: " ++ show e)++promoteLitExp :: OptionsMonad q => Lit -> q DType+promoteLitExp (IntegerL n) = do+ opts <- getOptions+ let tyFromIntegerName = promotedValueName opts fromIntegerName Nothing+ tyNegateName = promotedValueName opts negateName Nothing+ if n >= 0+ then return $ (DConT tyFromIntegerName `DAppT` DLitT (NumTyLit n))+ else return $ (DConT tyNegateName `DAppT`+ (DConT tyFromIntegerName `DAppT` DLitT (NumTyLit (-n))))+promoteLitExp (StringL str) = do+ opts <- getOptions+ let prom_str_lit = DLitT (StrTyLit str)+ os_enabled <- qIsExtEnabled LangExt.OverloadedStrings+ pure $ if os_enabled+ then DConT (promotedValueName opts fromStringName Nothing) `DAppT` prom_str_lit+ else prom_str_lit+promoteLitExp (CharL c) = return $ DLitT (CharTyLit c)+promoteLitExp lit =+ fail ("Only string, natural number, and character literals can be promoted: " ++ show lit)++promoteLitPat :: MonadFail m => Lit -> m DType+promoteLitPat (IntegerL n)+ | n >= 0 = return $ (DLitT (NumTyLit n))+ | otherwise =+ fail $ "Negative literal patterns are not allowed,\n" +++ "because literal patterns are promoted to natural numbers."+promoteLitPat (StringL str) = return $ DLitT (StrTyLit str)+promoteLitPat (CharL c) = return $ DLitT (CharTyLit c)+promoteLitPat lit =+ fail ("Only string, natural number, and character literals can be promoted: " ++ show lit)++-- Promote the name of a 'ULetDecRHS' to the type level. If the promoted+-- 'ULetDecRHS' has a standalone type signature and does not close over any+-- local variables, then this will include the scoped type variables from the+-- type signature as invisible arguments. (See Note [Scoped type variables] in+-- Data.Singletons.TH.Promote.Monad.) Otherwise, it will include any local+-- variables that it closes over as explicit arguments.+promoteLetDecName ::+ Maybe Uniq+ -- ^ Let-binding unique (if locally bound)+ -> Name+ -- ^ Name of the function being promoted+ -> Maybe LetDecRHSKindInfo+ -- ^ Information about the promoted kind (if present)+ -> [Name]+ -- ^ The local variables currently in scope+ -> PrM DType+promoteLetDecName mb_let_uniq name m_ldrki all_locals = do+ opts <- getOptions+ let proName = promotedValueName opts name mb_let_uniq+ type_args =+ case m_ldrki of+ Just (LDRKI m_sak tvbs _ _)+ | isJust m_sak+ -- Per the comments on LetDecRHSKindInfo, `isJust m_sak` is only True+ -- if there are no local variables. Return the scoped type variables+ -- `tvbs` as invisible arguments using `DTyArg`...+ -> map (DTyArg . DVarT . extractTvbName) tvbs+ _ -> -- ...otherwise, return the local variables as explicit arguments+ -- using DTANormal.+ map (DTANormal . DVarT) all_locals+ pure $ applyDType (DConT proName) type_args++-- Construct a 'DTypeFamilyHead' that closes over some local variables. We+-- apply `noExactName` to each local variable to avoid GHC#11812.+-- See also Note [Pitfalls of NameU/NameL] in Data.Singletons.TH.Util.+dTypeFamilyHead_with_locals ::+ Name+ -- ^ Name of type family+ -> [Name]+ -- ^ Local variables+ -> [DTyVarBndrVis]+ -- ^ Variables for type family arguments+ -> DFamilyResultSig+ -- ^ Type family result+ -> DTypeFamilyHead+dTypeFamilyHead_with_locals tf_nm local_nms arg_tvbs res_sig =+ DTypeFamilyHead+ tf_nm+ (map (`DPlainTV` BndrReq) local_nms' ++ arg_tvbs')+ res_sig'+ Nothing+ where+ -- We take care to only apply `noExactName` to the local variables and not+ -- to any of the argument/result types. The latter are much more likely to+ -- show up in the Haddocks, and `noExactName` produces incredibly long Names+ -- that are much harder to read in the rendered Haddocks.+ local_nms' = map noExactName local_nms++ -- Ensure that all references to local_nms are substituted away.+ subst1 = Map.fromList $+ zipWith (\local_nm local_nm' -> (local_nm, DVarT local_nm'))+ local_nms+ local_nms'+ (subst2, arg_tvbs') = substTvbs subst1 arg_tvbs+ (_subst3, res_sig') = substFamilyResultSig subst2 res_sig
src/Data/Singletons/TH/Promote/Defun.hs view
@@ -1,823 +1,826 @@-{-# LANGUAGE TemplateHaskellQuotes #-} - -{- Data/Singletons/TH/Promote/Defun.hs - -(c) Richard Eisenberg, Jan Stolarek 2014 -rae@cs.brynmawr.edu - -This file creates defunctionalization symbols for types during promotion. --} - -module Data.Singletons.TH.Promote.Defun where - -import Language.Haskell.TH.Desugar -import Language.Haskell.TH.Syntax -import Data.Singletons.TH.Names -import Data.Singletons.TH.Options -import Data.Singletons.TH.Promote.Monad -import Data.Singletons.TH.Promote.Type -import Data.Singletons.TH.Syntax -import Data.Singletons.TH.Util -import Control.Monad -import qualified Data.Map.Strict as Map -import Data.Map.Strict (Map) -import Data.Maybe - -defunInfo :: DInfo -> PrM [DDec] -defunInfo (DTyConI dec _instances) = buildDefunSyms dec -defunInfo (DPrimTyConI _name _numArgs _unlifted) = - fail $ "Building defunctionalization symbols of primitive " ++ - "type constructors not supported" -defunInfo (DVarI _name _ty _mdec) = - fail "Building defunctionalization symbols of values not supported" -defunInfo (DTyVarI _name _ty) = - fail "Building defunctionalization symbols of type variables not supported" -defunInfo (DPatSynI {}) = - fail "Building defunctionalization symbols of pattern synonyms not supported" - --- Defunctionalize type families defined at the top level (i.e., not associated --- with a type class). -defunTopLevelTypeDecls :: - [TySynDecl] - -> [ClosedTypeFamilyDecl] - -> [OpenTypeFamilyDecl] - -> PrM () -defunTopLevelTypeDecls ty_syns c_tyfams o_tyfams = do - defun_ty_syns <- - concatMapM (\(TySynDecl name tvbs rhs) -> buildDefunSymsTySynD name tvbs rhs) ty_syns - defun_c_tyfams <- - concatMapM (buildDefunSymsClosedTypeFamilyD . getTypeFamilyDecl) c_tyfams - defun_o_tyfams <- - concatMapM (buildDefunSymsOpenTypeFamilyD . getTypeFamilyDecl) o_tyfams - emitDecs $ defun_ty_syns ++ defun_c_tyfams ++ defun_o_tyfams - --- Defunctionalize all the type families associated with a type class. -defunAssociatedTypeFamilies :: - [DTyVarBndrUnit] -- The type variables bound by the parent class - -> [OpenTypeFamilyDecl] -- The type families associated with the parent class - -> PrM () -defunAssociatedTypeFamilies cls_tvbs atfs = do - defun_atfs <- concatMapM defun atfs - emitDecs defun_atfs - where - defun :: OpenTypeFamilyDecl -> PrM [DDec] - defun (TypeFamilyDecl tf_head) = - buildDefunSymsTypeFamilyHead ascribe_tf_tvb_kind id tf_head - - -- Maps class-bound type variables to their kind annotations (if supplied). - -- For example, `class C (a :: Bool) b (c :: Type)` will produce - -- {a |-> Bool, c |-> Type}. - cls_tvb_kind_map :: Map Name DKind - cls_tvb_kind_map = Map.fromList [ (extractTvbName tvb, tvb_kind) - | tvb <- cls_tvbs - , Just tvb_kind <- [extractTvbKind tvb] - ] - - -- If the parent class lacks a SAK, we cannot safely default kinds to - -- Type. All we can do is make use of whatever kind information that parent - -- class provides and let kind inference do the rest. - -- - -- We can sometimes learn more specific information about unannotated type - -- family binders from the parent class, as in the following example: - -- - -- class C (a :: Bool) where - -- type T a :: Type - -- - -- Here, we know that `T :: Bool -> Type` because we can infer that the `a` - -- in `type T a` should be of kind `Bool` from the class SAK. - ascribe_tf_tvb_kind :: DTyVarBndrUnit -> DTyVarBndrUnit - ascribe_tf_tvb_kind tvb = - case tvb of - DKindedTV{} -> tvb - DPlainTV n _ -> maybe tvb (DKindedTV n ()) $ Map.lookup n cls_tvb_kind_map - -buildDefunSyms :: DDec -> PrM [DDec] -buildDefunSyms dec = - case dec of - DDataD _new_or_data _cxt _tyName _tvbs _k ctors _derivings -> - buildDefunSymsDataD ctors - DClosedTypeFamilyD tf_head _ -> - buildDefunSymsClosedTypeFamilyD tf_head - DOpenTypeFamilyD tf_head -> - buildDefunSymsOpenTypeFamilyD tf_head - DTySynD name tvbs rhs -> - buildDefunSymsTySynD name tvbs rhs - DClassD _cxt name tvbs _fundeps _members -> - defunReify name tvbs (Just (DConT constraintName)) - _ -> fail $ "Defunctionalization symbols can only be built for " ++ - "type families and data declarations" - --- Unlike open type families, closed type families that lack SAKS do not --- default anything to Type, instead relying on kind inference to figure out --- unspecified kinds. -buildDefunSymsClosedTypeFamilyD :: DTypeFamilyHead -> PrM [DDec] -buildDefunSymsClosedTypeFamilyD = buildDefunSymsTypeFamilyHead id id - --- If an open type family lacks a SAK and has type variable binders or a result --- without explicit kinds, then they default to Type (hence the uses of --- default{Tvb,Maybe}ToTypeKind). -buildDefunSymsOpenTypeFamilyD :: DTypeFamilyHead -> PrM [DDec] -buildDefunSymsOpenTypeFamilyD = - buildDefunSymsTypeFamilyHead defaultTvbToTypeKind (Just . defaultMaybeToTypeKind) - -buildDefunSymsTypeFamilyHead - :: (DTyVarBndrUnit -> DTyVarBndrUnit) -- How to default each type variable binder - -> (Maybe DKind -> Maybe DKind) -- How to default the result kind - -> DTypeFamilyHead -> PrM [DDec] -buildDefunSymsTypeFamilyHead default_tvb default_kind - (DTypeFamilyHead name tvbs result_sig _) = do - let arg_tvbs = map default_tvb tvbs - res_kind = default_kind (resultSigToMaybeKind result_sig) - defunReify name arg_tvbs res_kind - -buildDefunSymsTySynD :: Name -> [DTyVarBndrUnit] -> DType -> PrM [DDec] -buildDefunSymsTySynD name tvbs rhs = defunReify name tvbs mb_res_kind - where - -- If a type synonym lacks a SAK, we can "infer" its result kind by - -- checking for an explicit kind annotation on the right-hand side. - mb_res_kind :: Maybe DKind - mb_res_kind = case rhs of - DSigT _ k -> Just k - _ -> Nothing - -buildDefunSymsDataD :: [DCon] -> PrM [DDec] -buildDefunSymsDataD ctors = - concatMapM promoteCtor ctors - where - promoteCtor :: DCon -> PrM [DDec] - promoteCtor (DCon tvbs _ name fields res_ty) = do - opts <- getOptions - let name' = promotedDataTypeOrConName opts name - arg_tys = tysOfConFields fields - arg_kis <- traverse promoteType_NC arg_tys - res_ki <- promoteType_NC res_ty - let con_ki = ravelVanillaDType tvbs [] arg_kis res_ki - m_fixity <- reifyFixityWithLocals name' - defunctionalize name' m_fixity $ DefunSAK con_ki - --- Generate defunctionalization symbols for a name, using reifyFixityWithLocals --- to determine what the fixity of each symbol should be --- (see Note [Fixity declarations for defunctionalization symbols]) --- and dsReifyType to determine whether defunctionalization should make use --- of SAKs or not (see Note [Defunctionalization game plan]). -defunReify :: Name -- Name of the declaration to be defunctionalized - -> [DTyVarBndrUnit] -- The declaration's type variable binders - -- (only used if the declaration lacks a SAK) - -> Maybe DKind -- The declaration's return kind, if it has one - -- (only used if the declaration lacks a SAK) - -> PrM [DDec] -defunReify name tvbs m_res_kind = do - m_fixity <- reifyFixityWithLocals name - m_sak <- dsReifyType name - let defun = defunctionalize name m_fixity - case m_sak of - Just sak -> defun $ DefunSAK sak - Nothing -> defun $ DefunNoSAK tvbs m_res_kind - --- Generate symbol data types, Apply instances, and other declarations required --- for defunctionalization. --- See Note [Defunctionalization game plan] for an overview of the design --- considerations involved. -defunctionalize :: Name - -> Maybe Fixity - -> DefunKindInfo - -> PrM [DDec] -defunctionalize name m_fixity defun_ki = do - case defun_ki of - DefunSAK sak -> - -- Even if a declaration has a SAK, its kind may not be vanilla. - case unravelVanillaDType_either sak of - -- If the kind isn't vanilla, use the fallback approach. - -- See Note [Defunctionalization game plan], - -- Wrinkle 2: Non-vanilla kinds. - Left _ -> defun_fallback [] (Just sak) - -- Otherwise, proceed with defun_vanilla_sak. - Right (sak_tvbs, _sak_cxt, sak_arg_kis, sak_res_ki) - -> defun_vanilla_sak sak_tvbs sak_arg_kis sak_res_ki - -- If a declaration lacks a SAK, it likely has a partial kind. - -- See Note [Defunctionalization game plan], Wrinkle 1: Partial kinds. - DefunNoSAK tvbs m_res -> defun_fallback tvbs m_res - where - -- Generate defunctionalization symbols for things with vanilla SAKs. - -- The symbols themselves will also be given SAKs. - defun_vanilla_sak :: [DTyVarBndrSpec] -> [DKind] -> DKind -> PrM [DDec] - defun_vanilla_sak sak_tvbs sak_arg_kis sak_res_ki = do - opts <- getOptions - extra_name <- qNewName "arg" - let sak_arg_n = length sak_arg_kis - -- Use noExactName below to avoid GHC#17537. - arg_names <- replicateM sak_arg_n (noExactName <$> qNewName "a") - - let -- The inner loop. @go n arg_nks res_nks@ returns @(res_k, decls)@. - -- Using one particular example: - -- - -- @ - -- type ExampleSym2 :: a -> b -> c ~> d ~> Type - -- data ExampleSym2 (x :: a) (y :: b) :: c ~> d ~> Type where ... - -- type instance Apply (ExampleSym2 x y) z = ExampleSym3 x y z - -- ... - -- @ - -- - -- We have: - -- - -- * @n@ is 2. This is incremented in each iteration of `go`. - -- - -- * @arg_nks@ is [(x, a), (y, b)]. Each element in this list is a - -- (type variable name, type variable kind) pair. The kinds appear in - -- the SAK, separated by matchable arrows (->). - -- - -- * @res_tvbs@ is [(z, c), (w, d)]. Each element in this list is a - -- (type variable name, type variable kind) pair. The kinds appear in - -- @res_k@, separated by unmatchable arrows (~>). - -- - -- * @res_k@ is `c ~> d ~> Type`. @res_k@ is returned so that earlier - -- defunctionalization symbols can build on the result kinds of - -- later symbols. For instance, ExampleSym1 would get the result - -- kind `b ~> c ~> d ~> Type` by prepending `b` to ExampleSym2's - -- result kind `c ~> d ~> Type`. - -- - -- * @decls@ are all of the declarations corresponding to ExampleSym2 - -- and later defunctionalization symbols. This is the main payload of - -- the function. - -- - -- Note that the body of ExampleSym2 redundantly includes the - -- argument kinds and result kind, which are already stated in the - -- standalone kind signature. This is a deliberate choice. - -- See Note [Keep redundant kind information for Haddocks] - -- in D.S.TH.Promote. - -- - -- This function is quadratic because it appends a variable at the end of - -- the @arg_nks@ list at each iteration. In practice, this is unlikely - -- to be a performance bottleneck since the number of arguments rarely - -- gets to be that large. - go :: Int -> [(Name, DKind)] -> [(Name, DKind)] -> (DKind, [DDec]) - go n arg_nks res_nkss = - let arg_tvbs :: [DTyVarBndrUnit] - arg_tvbs = map (\(na, ki) -> DKindedTV na () ki) arg_nks - - mk_sak_dec :: DKind -> DDec - mk_sak_dec res_ki = - DKiSigD (defunctionalizedName opts name n) $ - ravelVanillaDType sak_tvbs [] (map snd arg_nks) res_ki in - case res_nkss of - [] -> - let sat_sak_dec = mk_sak_dec sak_res_ki - sat_decs = mk_sat_decs opts n arg_tvbs (Just sak_res_ki) - in (sak_res_ki, sat_sak_dec:sat_decs) - res_nk:res_nks -> - let (res_ki, decs) = go (n+1) (arg_nks ++ [res_nk]) res_nks - tyfun = buildTyFunArrow (snd res_nk) res_ki - defun_sak_dec = mk_sak_dec tyfun - defun_other_decs = mk_defun_decs opts n sak_arg_n - arg_tvbs (fst res_nk) - extra_name (Just tyfun) - in (tyfun, defun_sak_dec:defun_other_decs ++ decs) - - pure $ snd $ go 0 [] $ zip arg_names sak_arg_kis - - -- If defun_sak can't be used to defunctionalize something, this fallback - -- approach is used. This is used when defunctionalizing something with a - -- partial kind - -- (see Note [Defunctionalization game plan], Wrinkle 1: Partial kinds) - -- or a non-vanilla kind - -- (see Note [Defunctionalization game plan], Wrinkle 2: Non-vanilla kinds). - defun_fallback :: [DTyVarBndrUnit] -> Maybe DKind -> PrM [DDec] - defun_fallback tvbs' m_res' = do - opts <- getOptions - extra_name <- qNewName "arg" - -- Use noExactTyVars below to avoid GHC#11812. - (tvbs, m_res) <- eta_expand (noExactTyVars tvbs') (noExactTyVars m_res') - - let tvbs_n = length tvbs - - -- The inner loop. @go n arg_tvbs res_tvbs@ returns @(m_res_k, decls)@. - -- Using one particular example: - -- - -- @ - -- data ExampleSym2 (x :: a) y :: c ~> d ~> Type where ... - -- type instance Apply (ExampleSym2 x y) z = ExampleSym3 x y z - -- ... - -- @ - -- - -- This works very similarly to the `go` function in - -- `defun_vanilla_sak`. The main differences are: - -- - -- * This function does not produce any SAKs for defunctionalization - -- symbols. - -- - -- * Instead of [(Name, DKind)], this function uses [DTyVarBndr] as - -- the types of @arg_tvbs@ and @res_tvbs@. This is because the - -- kinds are not always known. By a similar token, this function - -- uses Maybe DKind, not DKind, as the type of @m_res_k@, since - -- the result kind is not always fully known. - go :: Int -> [DTyVarBndrUnit] -> [DTyVarBndrUnit] -> (Maybe DKind, [DDec]) - go n arg_tvbs res_tvbss = - case res_tvbss of - [] -> - let sat_decs = mk_sat_decs opts n arg_tvbs m_res - in (m_res, sat_decs) - res_tvb:res_tvbs -> - let (m_res_ki, decs) = go (n+1) (arg_tvbs ++ [res_tvb]) res_tvbs - m_tyfun = buildTyFunArrow_maybe (extractTvbKind res_tvb) - m_res_ki - defun_decs' = mk_defun_decs opts n tvbs_n arg_tvbs - (extractTvbName res_tvb) - extra_name m_tyfun - in (m_tyfun, defun_decs' ++ decs) - - pure $ snd $ go 0 [] tvbs - - mk_defun_decs :: Options - -> Int - -> Int - -> [DTyVarBndrUnit] - -> Name - -> Name - -> Maybe DKind - -> [DDec] - mk_defun_decs opts n fully_sat_n arg_tvbs tyfun_name extra_name m_tyfun = - let data_name = defunctionalizedName opts name n - next_name = defunctionalizedName opts name (n+1) - con_name = prefixName "" ":" $ suffixName "KindInference" "###" data_name - arg_names = map extractTvbName arg_tvbs - params = arg_tvbs ++ [DPlainTV tyfun_name ()] - con_eq_ct = DConT sameKindName `DAppT` lhs `DAppT` rhs - where - lhs = foldType (DConT data_name) (map DVarT arg_names) `apply` (DVarT extra_name) - rhs = foldType (DConT next_name) (map DVarT (arg_names ++ [extra_name])) - con_decl = DCon [] [con_eq_ct] con_name (DNormalC False []) - (foldTypeTvbs (DConT data_name) params) - data_decl = DDataD Data [] data_name args m_tyfun [con_decl] [] - where - args | isJust m_tyfun = arg_tvbs - | otherwise = params - app_data_ty = foldTypeTvbs (DConT data_name) arg_tvbs - app_eqn = DTySynEqn Nothing - (DConT applyName `DAppT` app_data_ty - `DAppT` DVarT tyfun_name) - (foldTypeTvbs (DConT app_eqn_rhs_name) - (arg_tvbs ++ [DPlainTV tyfun_name ()])) - -- If the next defunctionalization symbol is fully saturated, then - -- use the original declaration name instead. - -- See Note [Fully saturated defunctionalization symbols] - -- (Wrinkle: avoiding reduction stack overflows). - app_eqn_rhs_name | n+1 == fully_sat_n = name - | otherwise = next_name - app_decl = DTySynInstD app_eqn - suppress = DInstanceD Nothing Nothing [] - (DConT suppressClassName `DAppT` app_data_ty) - [DLetDec $ DFunD suppressMethodName - [DClause [] - ((DVarE 'snd) `DAppE` - mkTupleDExp [DConE con_name, - mkTupleDExp []])]] - - -- See Note [Fixity declarations for defunctionalization symbols] - fixity_decl = maybeToList $ fmap (mk_fix_decl data_name) m_fixity - in data_decl : app_decl : suppress : fixity_decl - - -- Generate a "fully saturated" defunction symbol, along with a fixity - -- declaration (if needed). - -- See Note [Fully saturated defunctionalization symbols]. - mk_sat_decs :: Options -> Int -> [DTyVarBndrUnit] -> Maybe DKind -> [DDec] - mk_sat_decs opts n sat_tvbs m_sat_res = - let sat_name = defunctionalizedName opts name n - sat_dec = DClosedTypeFamilyD - (DTypeFamilyHead sat_name sat_tvbs - (maybeKindToResultSig m_sat_res) Nothing) - [DTySynEqn Nothing - (foldTypeTvbs (DConT sat_name) sat_tvbs) - (foldTypeTvbs (DConT name) sat_tvbs)] - sat_fixity_dec = maybeToList $ fmap (mk_fix_decl sat_name) m_fixity - in sat_dec : sat_fixity_dec - - -- Generate extra kind variable binders corresponding to the number of - -- arrows in the return kind (if provided). Examples: - -- - -- >>> eta_expand [(x :: a), (y :: b)] (Just (c -> Type)) - -- ([(x :: a), (y :: b), (e :: c)], Just Type) - -- - -- >>> eta_expand [(x :: a), (y :: b)] Nothing - -- ([(x :: a), (y :: b)], Nothing) - eta_expand :: [DTyVarBndrUnit] -> Maybe DKind -> PrM ([DTyVarBndrUnit], Maybe DKind) - eta_expand m_arg_tvbs Nothing = pure (m_arg_tvbs, Nothing) - eta_expand m_arg_tvbs (Just res_kind) = do - let (arg_ks, result_k) = unravelDType res_kind - vis_arg_ks = filterDVisFunArgs arg_ks - extra_arg_tvbs <- traverse mk_extra_tvb vis_arg_ks - pure (m_arg_tvbs ++ extra_arg_tvbs, Just result_k) - - -- Convert a DVisFunArg to a DTyVarBndr, generating a fresh type variable - -- name if the DVisFunArg is an anonymous argument. - mk_extra_tvb :: DVisFunArg -> PrM DTyVarBndrUnit - mk_extra_tvb vfa = - case vfa of - DVisFADep tvb -> pure tvb - DVisFAAnon k -> (\n -> DKindedTV n () k) <$> - -- Use noExactName below to avoid GHC#19743. - (noExactName <$> qNewName "e") - - mk_fix_decl :: Name -> Fixity -> DDec - mk_fix_decl n f = DLetDec $ DInfixD f n - --- Indicates whether the type being defunctionalized has a standalone kind --- signature. If it does, DefunSAK contains the kind. If not, DefunNoSAK --- contains whatever information is known about its type variable binders --- and result kind. --- See Note [Defunctionalization game plan] for details on how this --- information is used. -data DefunKindInfo - = DefunSAK DKind - | DefunNoSAK [DTyVarBndrUnit] (Maybe DKind) - --- Shorthand for building (k1 ~> k2) -buildTyFunArrow :: DKind -> DKind -> DKind -buildTyFunArrow k1 k2 = DConT tyFunArrowName `DAppT` k1 `DAppT` k2 - -buildTyFunArrow_maybe :: Maybe DKind -> Maybe DKind -> Maybe DKind -buildTyFunArrow_maybe m_k1 m_k2 = buildTyFunArrow <$> m_k1 <*> m_k2 - -{- -Note [Defunctionalization game plan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Generating defunctionalization symbols involves a surprising amount of -complexity. This Note gives a broad overview of what happens during -defunctionalization and highlights various design considerations. -As a working example, we will use the following type family: - - type Foo :: forall c a b. a -> b -> c -> c - type family Foo x y z where ... - -We must generate a defunctionalization symbol for every number of arguments -to which Foo can be partially applied. We do so by generating the following -declarations: - - type FooSym0 :: forall c a b. a ~> b ~> c ~> c - data FooSym0 f where - FooSym0KindInference :: SameKind (Apply FooSym0 arg) (FooSym1 arg) - => FooSym0 f - type instance Apply FooSym0 x = FooSym1 x - - type FooSym1 :: forall c a b. a -> b ~> c ~> c - data FooSym1 x f where - FooSym1KindInference :: SameKind (Apply (FooSym1 a) arg) (FooSym2 a arg) - => FooSym1 a f - type instance Apply (FooSym1 x) y = FooSym2 x y - - type FooSym2 :: forall c a b. a -> b -> c ~> c - data FooSym2 x y f where - FooSym2KindInference :: SameKind (Apply (FooSym2 x y) arg) (FooSym3 x y arg) - => FooSym2 x y f - type instance Apply (FooSym2 x y) z = Foo x y z - - type FooSym3 :: forall c a b. a -> b -> c -> c - type family FooSym3 x y z where - FooSym3 x y z = Foo x y z - -Some things to note: - -* Each defunctionalization symbol has its own standalone kind signature. The - number after `Sym` in each symbol indicates the number of leading -> arrows - in its kind—that is, the number of arguments to which it can be applied - directly to without the use of the Apply type family. - - See "Wrinkle 1: Partial kinds" below for what happens if the declaration - being defunctionalized does *not* have a standalone kind signature. - -* Each data declaration has a constructor with the suffix `-KindInference` - in its name. These are redundant in the particular case of Foo, where the - kind is already known. They play a more vital role when the kind of the - declaration being defunctionalized is only partially known. - See "Wrinkle 1: Partial kinds" below for more information. - -* FooSym3, the last defunctionalization symbol, is somewhat special in that - it is a type family, not a data type. These sorts of symbols are referred - to as "fully saturated" defunctionalization symbols. - See Note [Fully saturated defunctionalization symbols]. - -* If Foo had a fixity declaration (e.g., infixl 4 `Foo`), then we would also - generate fixity declarations for each defunctionalization symbol (e.g., - infixl 4 `FooSym0`). - See Note [Fixity declarations for defunctionalization symbols]. - -* Foo has a vanilla kind signature. (See - Note [Vanilla-type validity checking during promotion] in D.S.TH.Promote.Type - for what "vanilla" means in this context.) Having a vanilla type signature is - important, as it is a property that makes it much simpler to preserve the - order of type variables (`forall c a b.`) in each of the defunctionalization - symbols. - - That being said, it is not strictly required that the kind be vanilla. There - is another approach that can be used to defunctionalize things with - non-vanilla types, at the possible expense of having different type variable - orders between different defunctionalization symbols. - See "Wrinkle 2: Non-vanilla kinds" below for more information. - ------ --- Wrinkle 1: Partial kinds ------ - -The Foo example above has a standalone kind signature, but not everything has -this much kind information. For example, consider this: - - $(singletons [d| - type family Not x where - Not False = True - Not True = False - |]) - -The inferred kind for Not is `Bool -> Bool`, but since Not was declared in TH -quotes, `singletons-th` has no knowledge of this. Instead, we must rely on kind -inference to give Not's defunctionalization symbols the appropriate kinds. -Here is a naïve first attempt: - - data NotSym0 f - type instance Apply NotSym0 x = Not x - - type family NotSym1 x where - NotSym1 x = Not x - -NotSym1 will have the inferred kind `Bool -> Bool`, but poor NotSym0 will have -the inferred kind `forall k. k -> Type`, which is far more general than we -would like. We can do slightly better by supplying additional kind information -in a data constructor, like so: - - type SameKind :: k -> k -> Constraint - class SameKind x y = () - - data NotSym0 f where - NotSym0KindInference :: SameKind (Apply NotSym0 arg) (NotSym1 arg) - => NotSym0 f - -NotSym0KindInference is not intended to ever be seen by the user. Its only -reason for existing is its existential -`SameKind (Apply NotSym0 arg) (NotSym1 arg)` context, which allows GHC to -figure out that NotSym0 has kind `Bool ~> Bool`. This is a bit of a hack, but -it works quite nicely. The only problem is that GHC is likely to warn that -NotSym0KindInference is unused, which is annoying. To work around this, we -mention the data constructor in an instance of a dummy class: - - instance SuppressUnusedWarnings NotSym0 where - suppressUnusedWarnings = snd (NotSym0KindInference, ()) - -Similarly, this SuppressUnusedWarnings class is not intended to ever be seen -by the user. As its name suggests, it only exists to help suppress "unused -data constructor" warnings. - -Some declarations have a mixture of known kinds and unknown kinds, such as in -this example: - - $(singletons [d| - type family Bar x (y :: Nat) (z :: Nat) :: Nat where ... - |]) - -We can use the known kinds to guide kind inference. In this particular example -of Bar, here are the defunctionalization symbols that would be generated: - - data BarSym0 f where ... - data BarSym1 x :: Nat ~> Nat ~> Nat where ... - data BarSym2 x (y :: Nat) :: Nat ~> Nat where ... - type family BarSym3 x (y :: Nat) (z :: Nat) :: Nat where ... - ------ --- Wrinkle 2: Non-vanilla kinds ------ - -There is only limited support for defunctionalizing declarations with -non-vanilla kinds. One example of something with a non-vanilla kind is the -following, which uses a nested forall: - - $(singletons [d| - type Baz :: forall a. a -> forall b. b -> Type - data Baz x y - |]) - -One might envision generating the following defunctionalization symbols for -Baz: - - type BazSym0 :: forall a. a ~> forall b. b ~> Type - data BazSym0 f where ... - - type BazSym1 :: forall a. a -> forall b. b ~> Type - data BazSym1 x f where ... - - type BazSym2 :: forall a. a -> forall b. b -> Type - type family BazSym2 x y where - BazSym2 x y = Baz x y - -Unfortunately, doing so would require impredicativity, since we would have: - - forall a. a ~> forall b. b ~> Type - = forall a. (~>) a (forall b. b ~> Type) - = forall a. TyFun a (forall b. b ~> Type) -> Type - -Note that TyFun is an ordinary data type, so having its second argument be -(forall b. b ~> Type) is truly impredicative. As a result, trying to preserve -nested or higher-rank foralls is a non-starter. - -We need not reject Baz entirely, however. We can still generate perfectly -usable defunctionalization symbols if we are willing to sacrifice the exact -order of foralls. When we encounter a non-vanilla kind such as Baz's, we simply -fall back to the algorithm used when we encounter a partial kind (as described -in "Wrinkle 1: Partial kinds" above.) In other words, we generate the -following symbols: - - data BazSym0 :: a ~> b ~> Type where ... - data BazSym1 (x :: a) :: b ~> Type where ... - type family BazSym2 (x :: a) (y :: b) :: Type where ... - -The kinds of BazSym0 and BazSym1 both start with `forall a b.`, -whereas the `b` is quantified later in Baz itself. For most use cases, however, -this is not a huge concern. - -Another way kinds can be non-vanilla is if they contain visible dependent -quantification, like so: - - $(singletons [d| - type Quux :: forall (k :: Type) -> k -> Type - data Quux x y - |]) - -What should the kind of QuuxSym0 be? Intuitively, it should be this: - - type QuuxSym0 :: forall (k :: Type) ~> k ~> Type - -Alas, `forall (k :: Type) ~>` simply doesn't work. See #304. But there is an -acceptable compromise we can make that can give us defunctionalization symbols -for Quux. Once again, we fall back to the partial kind algorithm: - - data QuuxSym0 :: Type ~> k ~> Type where ... - data QuuxSym1 (k :: Type) :: k ~> Type where ... - type family QuuxSym2 (k :: Type) (x :: k) :: Type where ... - -The catch is that the kind of QuuxSym0, `forall k. Type ~> k ~> Type`, is -slightly more general than it ought to be. In practice, however, this is -unlikely to be a problem as long as you apply QuuxSym0 to arguments of the -right kinds. - -Note [Fully saturated defunctionalization symbols] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When generating defunctionalization symbols, most of the symbols are data -types. The last one, however, is a type family. For example, this code: - - $(singletons [d| - type Const :: a -> b -> a - type Const x y = x - |]) - -Will generate the following symbols: - - type ConstSym0 :: a ~> b ~> a - data ConstSym0 f where ... - - type ConstSym1 :: a -> b ~> a - data ConstSym1 x f where ... - - type ConstSym2 :: a -> b -> a - type family ConstSym2 x y where - ConstSym2 x y = Const x y - -ConstSym2, the sole type family of the bunch, is what is referred to as a -"fully saturated" defunctionaliztion symbol. - -At first glance, ConstSym2 may not seem terribly useful, since it is -effectively a thin wrapper around the original Const type. Indeed, fully -saturated symbols almost never appear directly in user-written code. Instead, -they are most valuable in TH-generated code, as singletons-th often generates code -that directly applies a defunctionalization symbol to some number of arguments -(see, for instance, D.S.TH.Names.promoteTySym). In theory, such code could carve -out a special case for fully saturated applications and apply the original -type instead of a defunctionalization symbol, but determining when an -application is fully saturated is often difficult in practice. As a result, it -is more convenient to just generate code that always applies FuncSymN to N -arguments, and to let fully saturated defunctionalization symbols handle the -case where N equals the number of arguments needed to fully saturate Func. - -One might wonder if, instead of using a closed type family with a single -equation, we could use a type synonym to define ConstSym2: - - type ConstSym2 :: a -> b -> a - type ConstSym2 x y = Const x y - -This approach has various downsides which make it impractical: - -* Type synonyms are often not expanded in the output of GHCi's :kind! command. - As issue #445 chronicles, this can significantly impact the readability of - even simple :kind! queries. It can be the difference between this: - - λ> :kind! Map IdSym0 '[1,2,3] - Map IdSym0 '[1,2,3] :: [Nat] - = 1 :@#@$$$ '[2, 3] - - And this: - - λ> :kind! Map IdSym0 '[1,2,3] - Map IdSym0 '[1,2,3] :: [Nat] - = '[1, 2, 3] - - Making fully saturated defunctionalization symbols like (:@#@$$$) type - families makes this issue moot, since :kind! always expands type families. -* There are a handful of corner cases where using type synonyms can actually - make fully saturated defunctionalization symbols fail to typecheck. - Here is one such corner case: - - $(promote [d| - class Applicative f where - pure :: a -> f a - ... - (*>) :: f a -> f b -> f b - |]) - - ==> - - class PApplicative f where - type Pure (x :: a) :: f a - type (*>) (x :: f a) (y :: f b) :: f b - - What would happen if we were to defunctionalize the promoted version of (*>)? - We'd end up with the following defunctionalization symbols: - - type (*>@#@$) :: f a ~> f b ~> f b - data (*>@#@$) f where ... - - type (*>@#@$$) :: f a -> f b ~> f b - data (*>@#@$$) x f where ... - - type (*>@#@$$$) :: f a -> f b -> f b - type (*>@#@$$$) x y = (*>) x y - - It turns out, however, that (*>@#@$$$) will not kind-check. Because (*>@#@$$$) - has a standalone kind signature, it is kind-generalized *before* kind-checking - the actual definition itself. Therefore, the full kind is: - - type (*>@#@$$$) :: forall {k} (f :: k -> Type) (a :: k) (b :: k). - f a -> f b -> f b - type (*>@#@$$$) x y = (*>) x y - - However, the kind of (*>) is - `forall (f :: Type -> Type) (a :: Type) (b :: Type). f a -> f b -> f b`. - This is not general enough for (*>@#@$$$), which expects kind-polymorphic `f`, - `a`, and `b`, leading to a kind error. You might think that we could somehow - infer this information, but note the quoted definition of Applicative (and - PApplicative, as a consequence) omits the kinds of `f`, `a`, and `b` entirely. - Unless we were to implement full-blown kind inference inside of Template - Haskell (which is a tall order), the kind `f a -> f b -> f b` is about as good - as we can get. - - Making (*>@#@$$$) a type family rather than a type synonym avoids this issue - since type family equations are allowed to match on kind arguments. In this - example, (*>@#@$$$) would have kind-polymorphic `f`, `a`, and `b` in its kind - signature, but its equation would implicitly equate `k` with `Type`. Note - that (*>@#@$) and (*>@#@$$), which are GADTs, also use a similar trick by - equating `k` with `Type` in their GADT constructors. - ------ --- Wrinkle: avoiding reduction stack overflows ------ - -A naïve attempt at declaring all fully saturated defunctionalization symbols -as type families can make certain programs overflow the reduction stack, such -as the T445 test case. This is because when evaluating -`FSym0 `Apply` x_1 `Apply` ... `Apply` x_N`, (where F is a promoted function -that requires N arguments), we will eventually bottom out by evaluating -`FSymN x_1 ... x_N`, where FSymN is a fully saturated defunctionalization -symbol. Since FSymN is a type family, this is yet another type family -reduction that contributes to the overall reduction limit. This might not -seem like a lot, but it can add up if F is invoked several times in a single -type-level computation! - -Fortunately, we can bypass evaluating FSymN entirely by just making a slight -tweak to the TH machinery. Instead of generating this Apply instance: - - type instance Apply (FSym{N-1} x_1 ... x_{N-1}) x_N = - FSymN x_1 ... x_{N-1} x_N - -Generate this instance, which jumps straight to F: - - type instance Apply (FSym{N-1} x_1 ... x_{N-1}) x_N = - F x_1 ... x_{N-1} x_N - -Now evaluating `FSym0 `Apply` x_1 `Apply` ... `Apply` x_N` will require one -less type family reduction. In practice, this is usually enough to keep the -reduction limit at bay in most situations. - -Note [Fixity declarations for defunctionalization symbols] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Just like we promote fixity declarations, we should also generate fixity -declarations for defunctionaliztion symbols. A primary use case is the -following scenario: - - (.) :: (b -> c) -> (a -> b) -> (a -> c) - (f . g) x = f (g x) - infixr 9 . - -One often writes (f . g . h) at the value level, but because (.) is promoted -to a type family with three arguments, this doesn't directly translate to the -type level. Instead, one must write this: - - f .@#@$$$ g .@#@$$$ h - -But in order to ensure that this associates to the right as expected, one must -generate an `infixr 9 .@#@#$$$` declaration. This is why defunctionalize accepts -a Maybe Fixity argument. --} +{-# LANGUAGE TemplateHaskellQuotes #-}++{- Data/Singletons/TH/Promote/Defun.hs++(c) Richard Eisenberg, Jan Stolarek 2014+rae@cs.brynmawr.edu++This file creates defunctionalization symbols for types during promotion.+-}++module Data.Singletons.TH.Promote.Defun where++import Language.Haskell.TH.Desugar+import Language.Haskell.TH.Syntax+import Data.Singletons.TH.Names+import Data.Singletons.TH.Options+import Data.Singletons.TH.Promote.Monad+import Data.Singletons.TH.Promote.Type+import Data.Singletons.TH.Syntax+import Data.Singletons.TH.Util+import Control.Monad+import qualified Data.Map.Strict as Map+import Data.Map.Strict (Map)+import Data.Maybe++defunInfo :: DInfo -> PrM [DDec]+defunInfo (DTyConI dec _instances) = buildDefunSyms dec+defunInfo (DPrimTyConI _name _numArgs _unlifted) =+ fail $ "Building defunctionalization symbols of primitive " +++ "type constructors not supported"+defunInfo (DVarI _name _ty _mdec) =+ fail "Building defunctionalization symbols of values not supported"+defunInfo (DTyVarI _name _ty) =+ fail "Building defunctionalization symbols of type variables not supported"+defunInfo (DPatSynI {}) =+ fail "Building defunctionalization symbols of pattern synonyms not supported"++-- Defunctionalize type families defined at the top level (i.e., not associated+-- with a type class).+defunTopLevelTypeDecls ::+ [TySynDecl]+ -> [ClosedTypeFamilyDecl]+ -> [OpenTypeFamilyDecl]+ -> PrM ()+defunTopLevelTypeDecls ty_syns c_tyfams o_tyfams = do+ defun_ty_syns <-+ concatMapM (\(TySynDecl name tvbs rhs) -> buildDefunSymsTySynD name tvbs rhs) ty_syns+ defun_c_tyfams <-+ concatMapM (buildDefunSymsClosedTypeFamilyD . getTypeFamilyDecl) c_tyfams+ defun_o_tyfams <-+ concatMapM (buildDefunSymsOpenTypeFamilyD . getTypeFamilyDecl) o_tyfams+ emitDecs $ defun_ty_syns ++ defun_c_tyfams ++ defun_o_tyfams++-- Defunctionalize all the type families associated with a type class.+defunAssociatedTypeFamilies ::+ [DTyVarBndrVis] -- The type variables bound by the parent class+ -> [OpenTypeFamilyDecl] -- The type families associated with the parent class+ -> PrM ()+defunAssociatedTypeFamilies cls_tvbs atfs = do+ defun_atfs <- concatMapM defun atfs+ emitDecs defun_atfs+ where+ defun :: OpenTypeFamilyDecl -> PrM [DDec]+ defun (TypeFamilyDecl tf_head) =+ buildDefunSymsTypeFamilyHead ascribe_tf_tvb_kind id tf_head++ -- Maps class-bound type variables to their kind annotations (if supplied).+ -- For example, `class C (a :: Bool) b (c :: Type)` will produce+ -- {a |-> Bool, c |-> Type}.+ cls_tvb_kind_map :: Map Name DKind+ cls_tvb_kind_map = Map.fromList [ (extractTvbName tvb, tvb_kind)+ | tvb <- cls_tvbs+ , Just tvb_kind <- [extractTvbKind tvb]+ ]++ -- If the parent class lacks a SAK, we cannot safely default kinds to+ -- Type. All we can do is make use of whatever kind information that parent+ -- class provides and let kind inference do the rest.+ --+ -- We can sometimes learn more specific information about unannotated type+ -- family binders from the parent class, as in the following example:+ --+ -- class C (a :: Bool) where+ -- type T a :: Type+ --+ -- Here, we know that `T :: Bool -> Type` because we can infer that the `a`+ -- in `type T a` should be of kind `Bool` from the class SAK.+ ascribe_tf_tvb_kind :: DTyVarBndrVis -> DTyVarBndrVis+ ascribe_tf_tvb_kind tvb =+ case tvb of+ DKindedTV{} -> tvb+ DPlainTV n _ -> maybe tvb (DKindedTV n BndrReq) $ Map.lookup n cls_tvb_kind_map++buildDefunSyms :: DDec -> PrM [DDec]+buildDefunSyms dec =+ case dec of+ DDataD _new_or_data _cxt _tyName _tvbs _k ctors _derivings ->+ buildDefunSymsDataD ctors+ DClosedTypeFamilyD tf_head _ ->+ buildDefunSymsClosedTypeFamilyD tf_head+ DOpenTypeFamilyD tf_head ->+ buildDefunSymsOpenTypeFamilyD tf_head+ DTySynD name tvbs rhs ->+ buildDefunSymsTySynD name tvbs rhs+ DClassD _cxt name tvbs _fundeps _members ->+ defunReify name tvbs (Just (DConT constraintName))+ _ -> fail $ "Defunctionalization symbols can only be built for " +++ "type families and data declarations"++-- Unlike open type families, closed type families that lack SAKS do not+-- default anything to Type, instead relying on kind inference to figure out+-- unspecified kinds.+buildDefunSymsClosedTypeFamilyD :: DTypeFamilyHead -> PrM [DDec]+buildDefunSymsClosedTypeFamilyD = buildDefunSymsTypeFamilyHead id id++-- If an open type family lacks a SAK and has type variable binders or a result+-- without explicit kinds, then they default to Type (hence the uses of+-- default{Tvb,Maybe}ToTypeKind).+buildDefunSymsOpenTypeFamilyD :: DTypeFamilyHead -> PrM [DDec]+buildDefunSymsOpenTypeFamilyD =+ buildDefunSymsTypeFamilyHead defaultTvbToTypeKind (Just . defaultMaybeToTypeKind)++buildDefunSymsTypeFamilyHead+ :: (DTyVarBndrVis -> DTyVarBndrVis) -- How to default each type variable binder+ -> (Maybe DKind -> Maybe DKind) -- How to default the result kind+ -> DTypeFamilyHead -> PrM [DDec]+buildDefunSymsTypeFamilyHead default_tvb default_kind+ (DTypeFamilyHead name tvbs result_sig _) = do+ let arg_tvbs = map default_tvb tvbs+ res_kind = default_kind (resultSigToMaybeKind result_sig)+ defunReify name arg_tvbs res_kind++buildDefunSymsTySynD :: Name -> [DTyVarBndrVis] -> DType -> PrM [DDec]+buildDefunSymsTySynD name tvbs rhs = defunReify name tvbs mb_res_kind+ where+ -- If a type synonym lacks a SAK, we can "infer" its result kind by+ -- checking for an explicit kind annotation on the right-hand side.+ mb_res_kind :: Maybe DKind+ mb_res_kind = case rhs of+ DSigT _ k -> Just k+ _ -> Nothing++buildDefunSymsDataD :: [DCon] -> PrM [DDec]+buildDefunSymsDataD ctors =+ concatMapM promoteCtor ctors+ where+ promoteCtor :: DCon -> PrM [DDec]+ promoteCtor (DCon tvbs _ name fields res_ty) = do+ opts <- getOptions+ let name' = promotedDataTypeOrConName opts name+ arg_tys = tysOfConFields fields+ arg_kis <- traverse promoteType_NC arg_tys+ res_ki <- promoteType_NC res_ty+ let con_ki = ravelVanillaDType tvbs [] arg_kis res_ki+ m_fixity <- reifyFixityWithLocals name'+ defunctionalize name' m_fixity $ DefunSAK con_ki++-- Generate defunctionalization symbols for a name, using reifyFixityWithLocals+-- to determine what the fixity of each symbol should be+-- (see Note [Fixity declarations for defunctionalization symbols])+-- and dsReifyType to determine whether defunctionalization should make use+-- of SAKs or not (see Note [Defunctionalization game plan]).+defunReify :: Name -- Name of the declaration to be defunctionalized+ -> [DTyVarBndrVis] -- The declaration's type variable binders+ -- (only used if the declaration lacks a SAK)+ -> Maybe DKind -- The declaration's return kind, if it has one+ -- (only used if the declaration lacks a SAK)+ -> PrM [DDec]+defunReify name tvbs m_res_kind = do+ m_fixity <- reifyFixityWithLocals name+ m_sak <- dsReifyType name+ let defun = defunctionalize name m_fixity+ case m_sak of+ Just sak -> defun $ DefunSAK sak+ Nothing -> defun $ DefunNoSAK tvbs m_res_kind++-- Generate symbol data types, Apply instances, and other declarations required+-- for defunctionalization.+-- See Note [Defunctionalization game plan] for an overview of the design+-- considerations involved.+defunctionalize :: Name+ -> Maybe Fixity+ -> DefunKindInfo+ -> PrM [DDec]+defunctionalize name m_fixity defun_ki = do+ case defun_ki of+ DefunSAK sak ->+ -- Even if a declaration has a SAK, its kind may not be vanilla.+ case unravelVanillaDType_either sak of+ -- If the kind isn't vanilla, use the fallback approach.+ -- See Note [Defunctionalization game plan],+ -- Wrinkle 2: Non-vanilla kinds.+ Left _ -> defun_fallback [] (Just sak)+ -- Otherwise, proceed with defun_vanilla_sak.+ Right (sak_tvbs, _sak_cxt, sak_arg_kis, sak_res_ki)+ -> defun_vanilla_sak sak_tvbs sak_arg_kis sak_res_ki+ -- If a declaration lacks a SAK, it likely has a partial kind.+ -- See Note [Defunctionalization game plan], Wrinkle 1: Partial kinds.+ DefunNoSAK tvbs m_res -> defun_fallback tvbs m_res+ where+ -- Generate defunctionalization symbols for things with vanilla SAKs.+ -- The symbols themselves will also be given SAKs.+ defun_vanilla_sak :: [DTyVarBndrSpec] -> [DKind] -> DKind -> PrM [DDec]+ defun_vanilla_sak sak_tvbs sak_arg_kis sak_res_ki = do+ opts <- getOptions+ extra_name <- qNewName "arg"+ let sak_arg_n = length sak_arg_kis+ -- Use noExactName below to avoid GHC#17537.+ -- See also Note [Pitfalls of NameU/NameL] in Data.Singletons.TH.Util.+ arg_names <- replicateM sak_arg_n (noExactName <$> qNewName "a")++ let -- The inner loop. @go n arg_nks res_nks@ returns @(res_k, decls)@.+ -- Using one particular example:+ --+ -- @+ -- type ExampleSym2 :: a -> b -> c ~> d ~> Type+ -- data ExampleSym2 (x :: a) (y :: b) :: c ~> d ~> Type where ...+ -- type instance Apply (ExampleSym2 x y) z = ExampleSym3 x y z+ -- ...+ -- @+ --+ -- We have:+ --+ -- * @n@ is 2. This is incremented in each iteration of `go`.+ --+ -- * @arg_nks@ is [(x, a), (y, b)]. Each element in this list is a+ -- (type variable name, type variable kind) pair. The kinds appear in+ -- the SAK, separated by matchable arrows (->).+ --+ -- * @res_tvbs@ is [(z, c), (w, d)]. Each element in this list is a+ -- (type variable name, type variable kind) pair. The kinds appear in+ -- @res_k@, separated by unmatchable arrows (~>).+ --+ -- * @res_k@ is `c ~> d ~> Type`. @res_k@ is returned so that earlier+ -- defunctionalization symbols can build on the result kinds of+ -- later symbols. For instance, ExampleSym1 would get the result+ -- kind `b ~> c ~> d ~> Type` by prepending `b` to ExampleSym2's+ -- result kind `c ~> d ~> Type`.+ --+ -- * @decls@ are all of the declarations corresponding to ExampleSym2+ -- and later defunctionalization symbols. This is the main payload of+ -- the function.+ --+ -- Note that the body of ExampleSym2 redundantly includes the+ -- argument kinds and result kind, which are already stated in the+ -- standalone kind signature. This is a deliberate choice.+ -- See Note [Keep redundant kind information for Haddocks]+ -- in D.S.TH.Promote.+ --+ -- This function is quadratic because it appends a variable at the end of+ -- the @arg_nks@ list at each iteration. In practice, this is unlikely+ -- to be a performance bottleneck since the number of arguments rarely+ -- gets to be that large.+ go :: Int -> [(Name, DKind)] -> [(Name, DKind)] -> (DKind, [DDec])+ go n arg_nks res_nkss =+ let arg_tvbs :: [DTyVarBndrVis]+ arg_tvbs = map (\(na, ki) -> DKindedTV na BndrReq ki) arg_nks++ mk_sak_dec :: DKind -> DDec+ mk_sak_dec res_ki =+ DKiSigD (defunctionalizedName opts name n) $+ ravelVanillaDType sak_tvbs [] (map snd arg_nks) res_ki in+ case res_nkss of+ [] ->+ let sat_sak_dec = mk_sak_dec sak_res_ki+ sat_decs = mk_sat_decs opts n arg_tvbs (Just sak_res_ki)+ in (sak_res_ki, sat_sak_dec:sat_decs)+ res_nk:res_nks ->+ let (res_ki, decs) = go (n+1) (arg_nks ++ [res_nk]) res_nks+ tyfun = buildTyFunArrow (snd res_nk) res_ki+ defun_sak_dec = mk_sak_dec tyfun+ defun_other_decs = mk_defun_decs opts n sak_arg_n+ arg_tvbs (fst res_nk)+ extra_name (Just tyfun)+ in (tyfun, defun_sak_dec:defun_other_decs ++ decs)++ pure $ snd $ go 0 [] $ zip arg_names sak_arg_kis++ -- If defun_sak can't be used to defunctionalize something, this fallback+ -- approach is used. This is used when defunctionalizing something with a+ -- partial kind+ -- (see Note [Defunctionalization game plan], Wrinkle 1: Partial kinds)+ -- or a non-vanilla kind+ -- (see Note [Defunctionalization game plan], Wrinkle 2: Non-vanilla kinds).+ defun_fallback :: [DTyVarBndrVis] -> Maybe DKind -> PrM [DDec]+ defun_fallback tvbs' m_res' = do+ opts <- getOptions+ extra_name <- qNewName "arg"+ -- Use noExactTyVars below to avoid GHC#11812.+ -- See also Note [Pitfalls of NameU/NameL] in Data.Singletons.TH.Util.+ (tvbs, m_res) <- eta_expand (noExactTyVars tvbs') (noExactTyVars m_res')++ let tvbs_n = length tvbs++ -- The inner loop. @go n arg_tvbs res_tvbs@ returns @(m_res_k, decls)@.+ -- Using one particular example:+ --+ -- @+ -- data ExampleSym2 (x :: a) y :: c ~> d ~> Type where ...+ -- type instance Apply (ExampleSym2 x y) z = ExampleSym3 x y z+ -- ...+ -- @+ --+ -- This works very similarly to the `go` function in+ -- `defun_vanilla_sak`. The main differences are:+ --+ -- * This function does not produce any SAKs for defunctionalization+ -- symbols.+ --+ -- * Instead of [(Name, DKind)], this function uses [DTyVarBndr] as+ -- the types of @arg_tvbs@ and @res_tvbs@. This is because the+ -- kinds are not always known. By a similar token, this function+ -- uses Maybe DKind, not DKind, as the type of @m_res_k@, since+ -- the result kind is not always fully known.+ go :: Int -> [DTyVarBndrVis] -> [DTyVarBndrVis] -> (Maybe DKind, [DDec])+ go n arg_tvbs res_tvbss =+ case res_tvbss of+ [] ->+ let sat_decs = mk_sat_decs opts n arg_tvbs m_res+ in (m_res, sat_decs)+ res_tvb:res_tvbs ->+ let (m_res_ki, decs) = go (n+1) (arg_tvbs ++ [res_tvb]) res_tvbs+ m_tyfun = buildTyFunArrow_maybe (extractTvbKind res_tvb)+ m_res_ki+ defun_decs' = mk_defun_decs opts n tvbs_n arg_tvbs+ (extractTvbName res_tvb)+ extra_name m_tyfun+ in (m_tyfun, defun_decs' ++ decs)++ pure $ snd $ go 0 [] tvbs++ mk_defun_decs :: Options+ -> Int+ -> Int+ -> [DTyVarBndrVis]+ -> Name+ -> Name+ -> Maybe DKind+ -> [DDec]+ mk_defun_decs opts n fully_sat_n arg_tvbs tyfun_name extra_name m_tyfun =+ let data_name = defunctionalizedName opts name n+ next_name = defunctionalizedName opts name (n+1)+ con_name = prefixName "" ":" $ suffixName "KindInference" "###" data_name+ params = arg_tvbs ++ [DPlainTV tyfun_name BndrReq]+ con_eq_ct = DConT sameKindName `DAppT` lhs `DAppT` rhs+ where+ lhs = app_data_ty `apply` DVarT extra_name+ rhs = foldTypeTvbs (DConT next_name)+ (arg_tvbs ++ [DPlainTV extra_name BndrReq])+ con_decl = DCon [] [con_eq_ct] con_name (DNormalC False [])+ (foldTypeTvbs (DConT data_name) params)+ data_decl = DDataD Data [] data_name args m_tyfun [con_decl] []+ where+ args | isJust m_tyfun = arg_tvbs+ | otherwise = params+ app_data_ty = foldTypeTvbs (DConT data_name) arg_tvbs+ app_eqn = DTySynEqn Nothing+ (DConT applyName `DAppT` app_data_ty+ `DAppT` DVarT tyfun_name)+ (foldTypeTvbs (DConT app_eqn_rhs_name) params)+ -- If the next defunctionalization symbol is fully saturated, then+ -- use the original declaration name instead.+ -- See Note [Fully saturated defunctionalization symbols]+ -- (Wrinkle: avoiding reduction stack overflows).+ app_eqn_rhs_name | n+1 == fully_sat_n = name+ | otherwise = next_name+ app_decl = DTySynInstD app_eqn+ suppress = DInstanceD Nothing Nothing []+ (DConT suppressClassName `DAppT` app_data_ty)+ [DLetDec $ DFunD suppressMethodName+ [DClause []+ ((DVarE 'snd) `DAppE`+ mkTupleDExp [DConE con_name,+ mkTupleDExp []])]]++ -- See Note [Fixity declarations for defunctionalization symbols]+ fixity_decl = maybeToList $ fmap (mk_fix_decl data_name) m_fixity+ in data_decl : app_decl : suppress : fixity_decl++ -- Generate a "fully saturated" defunction symbol, along with a fixity+ -- declaration (if needed).+ -- See Note [Fully saturated defunctionalization symbols].+ mk_sat_decs :: Options -> Int -> [DTyVarBndrVis] -> Maybe DKind -> [DDec]+ mk_sat_decs opts n sat_tvbs m_sat_res =+ let sat_name = defunctionalizedName opts name n+ sat_dec = DClosedTypeFamilyD+ (DTypeFamilyHead sat_name sat_tvbs+ (maybeKindToResultSig m_sat_res) Nothing)+ [DTySynEqn Nothing+ (foldTypeTvbs (DConT sat_name) sat_tvbs)+ (foldTypeTvbs (DConT name) sat_tvbs)]+ sat_fixity_dec = maybeToList $ fmap (mk_fix_decl sat_name) m_fixity+ in sat_dec : sat_fixity_dec++ -- Generate extra kind variable binders corresponding to the number of+ -- arrows in the return kind (if provided). Examples:+ --+ -- >>> eta_expand [(x :: a), (y :: b)] (Just (c -> Type))+ -- ([(x :: a), (y :: b), (e :: c)], Just Type)+ --+ -- >>> eta_expand [(x :: a), (y :: b)] Nothing+ -- ([(x :: a), (y :: b)], Nothing)+ eta_expand :: [DTyVarBndrVis] -> Maybe DKind -> PrM ([DTyVarBndrVis], Maybe DKind)+ eta_expand m_arg_tvbs Nothing = pure (m_arg_tvbs, Nothing)+ eta_expand m_arg_tvbs (Just res_kind) = do+ let (arg_ks, result_k) = unravelDType res_kind+ vis_arg_ks = filterDVisFunArgs arg_ks+ extra_arg_tvbs <- traverse mk_extra_tvb vis_arg_ks+ pure (m_arg_tvbs ++ extra_arg_tvbs, Just result_k)++ -- Convert a DVisFunArg to a DTyVarBndr, generating a fresh type variable+ -- name if the DVisFunArg is an anonymous argument.+ mk_extra_tvb :: DVisFunArg -> PrM DTyVarBndrVis+ mk_extra_tvb vfa =+ case vfa of+ DVisFADep tvb -> pure (BndrReq <$ tvb)+ DVisFAAnon k -> (\n -> DKindedTV n BndrReq k) <$>+ -- Use noExactName below to avoid GHC#19743.+ -- See also Note [Pitfalls of NameU/NameL]+ -- in Data.Singletons.TH.Util.+ (noExactName <$> qNewName "e")++ mk_fix_decl :: Name -> Fixity -> DDec+ mk_fix_decl n f = DLetDec $ DInfixD f n++-- Indicates whether the type being defunctionalized has a standalone kind+-- signature. If it does, DefunSAK contains the kind. If not, DefunNoSAK+-- contains whatever information is known about its type variable binders+-- and result kind.+-- See Note [Defunctionalization game plan] for details on how this+-- information is used.+data DefunKindInfo+ = DefunSAK DKind+ | DefunNoSAK [DTyVarBndrVis] (Maybe DKind)++-- Shorthand for building (k1 ~> k2)+buildTyFunArrow :: DKind -> DKind -> DKind+buildTyFunArrow k1 k2 = DConT tyFunArrowName `DAppT` k1 `DAppT` k2++buildTyFunArrow_maybe :: Maybe DKind -> Maybe DKind -> Maybe DKind+buildTyFunArrow_maybe m_k1 m_k2 = buildTyFunArrow <$> m_k1 <*> m_k2++{-+Note [Defunctionalization game plan]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Generating defunctionalization symbols involves a surprising amount of+complexity. This Note gives a broad overview of what happens during+defunctionalization and highlights various design considerations.+As a working example, we will use the following type family:++ type Foo :: forall c a b. a -> b -> c -> c+ type family Foo x y z where ...++We must generate a defunctionalization symbol for every number of arguments+to which Foo can be partially applied. We do so by generating the following+declarations:++ type FooSym0 :: forall c a b. a ~> b ~> c ~> c+ data FooSym0 f where+ FooSym0KindInference :: SameKind (Apply FooSym0 arg) (FooSym1 arg)+ => FooSym0 f+ type instance Apply FooSym0 x = FooSym1 x++ type FooSym1 :: forall c a b. a -> b ~> c ~> c+ data FooSym1 x f where+ FooSym1KindInference :: SameKind (Apply (FooSym1 a) arg) (FooSym2 a arg)+ => FooSym1 a f+ type instance Apply (FooSym1 x) y = FooSym2 x y++ type FooSym2 :: forall c a b. a -> b -> c ~> c+ data FooSym2 x y f where+ FooSym2KindInference :: SameKind (Apply (FooSym2 x y) arg) (FooSym3 x y arg)+ => FooSym2 x y f+ type instance Apply (FooSym2 x y) z = Foo x y z++ type FooSym3 :: forall c a b. a -> b -> c -> c+ type family FooSym3 x y z where+ FooSym3 x y z = Foo x y z++Some things to note:++* Each defunctionalization symbol has its own standalone kind signature. The+ number after `Sym` in each symbol indicates the number of leading -> arrows+ in its kind—that is, the number of arguments to which it can be applied+ directly to without the use of the Apply type family.++ See "Wrinkle 1: Partial kinds" below for what happens if the declaration+ being defunctionalized does *not* have a standalone kind signature.++* Each data declaration has a constructor with the suffix `-KindInference`+ in its name. These are redundant in the particular case of Foo, where the+ kind is already known. They play a more vital role when the kind of the+ declaration being defunctionalized is only partially known.+ See "Wrinkle 1: Partial kinds" below for more information.++* FooSym3, the last defunctionalization symbol, is somewhat special in that+ it is a type family, not a data type. These sorts of symbols are referred+ to as "fully saturated" defunctionalization symbols.+ See Note [Fully saturated defunctionalization symbols].++* If Foo had a fixity declaration (e.g., infixl 4 `Foo`), then we would also+ generate fixity declarations for each defunctionalization symbol (e.g.,+ infixl 4 `FooSym0`).+ See Note [Fixity declarations for defunctionalization symbols].++* Foo has a vanilla kind signature. (See+ Note [Vanilla-type validity checking during promotion] in D.S.TH.Promote.Type+ for what "vanilla" means in this context.) Having a vanilla type signature is+ important, as it is a property that makes it much simpler to preserve the+ order of type variables (`forall c a b.`) in each of the defunctionalization+ symbols.++ That being said, it is not strictly required that the kind be vanilla. There+ is another approach that can be used to defunctionalize things with+ non-vanilla types, at the possible expense of having different type variable+ orders between different defunctionalization symbols.+ See "Wrinkle 2: Non-vanilla kinds" below for more information.++-----+-- Wrinkle 1: Partial kinds+-----++The Foo example above has a standalone kind signature, but not everything has+this much kind information. For example, consider this:++ $(singletons [d|+ type family Not x where+ Not False = True+ Not True = False+ |])++The inferred kind for Not is `Bool -> Bool`, but since Not was declared in TH+quotes, `singletons-th` has no knowledge of this. Instead, we must rely on kind+inference to give Not's defunctionalization symbols the appropriate kinds.+Here is a naïve first attempt:++ data NotSym0 f+ type instance Apply NotSym0 x = Not x++ type family NotSym1 x where+ NotSym1 x = Not x++NotSym1 will have the inferred kind `Bool -> Bool`, but poor NotSym0 will have+the inferred kind `forall k. k -> Type`, which is far more general than we+would like. We can do slightly better by supplying additional kind information+in a data constructor, like so:++ type SameKind :: k -> k -> Constraint+ class SameKind x y = ()++ data NotSym0 f where+ NotSym0KindInference :: SameKind (Apply NotSym0 arg) (NotSym1 arg)+ => NotSym0 f++NotSym0KindInference is not intended to ever be seen by the user. Its only+reason for existing is its existential+`SameKind (Apply NotSym0 arg) (NotSym1 arg)` context, which allows GHC to+figure out that NotSym0 has kind `Bool ~> Bool`. This is a bit of a hack, but+it works quite nicely. The only problem is that GHC is likely to warn that+NotSym0KindInference is unused, which is annoying. To work around this, we+mention the data constructor in an instance of a dummy class:++ instance SuppressUnusedWarnings NotSym0 where+ suppressUnusedWarnings = snd (NotSym0KindInference, ())++Similarly, this SuppressUnusedWarnings class is not intended to ever be seen+by the user. As its name suggests, it only exists to help suppress "unused+data constructor" warnings.++Some declarations have a mixture of known kinds and unknown kinds, such as in+this example:++ $(singletons [d|+ type family Bar x (y :: Nat) (z :: Nat) :: Nat where ...+ |])++We can use the known kinds to guide kind inference. In this particular example+of Bar, here are the defunctionalization symbols that would be generated:++ data BarSym0 f where ...+ data BarSym1 x :: Nat ~> Nat ~> Nat where ...+ data BarSym2 x (y :: Nat) :: Nat ~> Nat where ...+ type family BarSym3 x (y :: Nat) (z :: Nat) :: Nat where ...++-----+-- Wrinkle 2: Non-vanilla kinds+-----++There is only limited support for defunctionalizing declarations with+non-vanilla kinds. One example of something with a non-vanilla kind is the+following, which uses a nested forall:++ $(singletons [d|+ type Baz :: forall a. a -> forall b. b -> Type+ data Baz x y+ |])++One might envision generating the following defunctionalization symbols for+Baz:++ type BazSym0 :: forall a. a ~> forall b. b ~> Type+ data BazSym0 f where ...++ type BazSym1 :: forall a. a -> forall b. b ~> Type+ data BazSym1 x f where ...++ type BazSym2 :: forall a. a -> forall b. b -> Type+ type family BazSym2 x y where+ BazSym2 x y = Baz x y++Unfortunately, doing so would require impredicativity, since we would have:++ forall a. a ~> forall b. b ~> Type+ = forall a. (~>) a (forall b. b ~> Type)+ = forall a. TyFun a (forall b. b ~> Type) -> Type++Note that TyFun is an ordinary data type, so having its second argument be+(forall b. b ~> Type) is truly impredicative. As a result, trying to preserve+nested or higher-rank foralls is a non-starter.++We need not reject Baz entirely, however. We can still generate perfectly+usable defunctionalization symbols if we are willing to sacrifice the exact+order of foralls. When we encounter a non-vanilla kind such as Baz's, we simply+fall back to the algorithm used when we encounter a partial kind (as described+in "Wrinkle 1: Partial kinds" above.) In other words, we generate the+following symbols:++ data BazSym0 :: a ~> b ~> Type where ...+ data BazSym1 (x :: a) :: b ~> Type where ...+ type family BazSym2 (x :: a) (y :: b) :: Type where ...++The kinds of BazSym0 and BazSym1 both start with `forall a b.`,+whereas the `b` is quantified later in Baz itself. For most use cases, however,+this is not a huge concern.++Another way kinds can be non-vanilla is if they contain visible dependent+quantification, like so:++ $(singletons [d|+ type Quux :: forall (k :: Type) -> k -> Type+ data Quux x y+ |])++What should the kind of QuuxSym0 be? Intuitively, it should be this:++ type QuuxSym0 :: forall (k :: Type) ~> k ~> Type++Alas, `forall (k :: Type) ~>` simply doesn't work. See #304. But there is an+acceptable compromise we can make that can give us defunctionalization symbols+for Quux. Once again, we fall back to the partial kind algorithm:++ data QuuxSym0 :: Type ~> k ~> Type where ...+ data QuuxSym1 (k :: Type) :: k ~> Type where ...+ type family QuuxSym2 (k :: Type) (x :: k) :: Type where ...++The catch is that the kind of QuuxSym0, `forall k. Type ~> k ~> Type`, is+slightly more general than it ought to be. In practice, however, this is+unlikely to be a problem as long as you apply QuuxSym0 to arguments of the+right kinds.++Note [Fully saturated defunctionalization symbols]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When generating defunctionalization symbols, most of the symbols are data+types. The last one, however, is a type family. For example, this code:++ $(singletons [d|+ type Const :: a -> b -> a+ type Const x y = x+ |])++Will generate the following symbols:++ type ConstSym0 :: a ~> b ~> a+ data ConstSym0 f where ...++ type ConstSym1 :: a -> b ~> a+ data ConstSym1 x f where ...++ type ConstSym2 :: a -> b -> a+ type family ConstSym2 x y where+ ConstSym2 x y = Const x y++ConstSym2, the sole type family of the bunch, is what is referred to as a+"fully saturated" defunctionaliztion symbol.++At first glance, ConstSym2 may not seem terribly useful, since it is+effectively a thin wrapper around the original Const type. Indeed, fully+saturated symbols almost never appear directly in user-written code. Instead,+they are most valuable in TH-generated code, as singletons-th often generates code+that directly applies a defunctionalization symbol to some number of arguments+(see, for instance, D.S.TH.Names.promoteTySym). In theory, such code could carve+out a special case for fully saturated applications and apply the original+type instead of a defunctionalization symbol, but determining when an+application is fully saturated is often difficult in practice. As a result, it+is more convenient to just generate code that always applies FuncSymN to N+arguments, and to let fully saturated defunctionalization symbols handle the+case where N equals the number of arguments needed to fully saturate Func.++One might wonder if, instead of using a closed type family with a single+equation, we could use a type synonym to define ConstSym2:++ type ConstSym2 :: a -> b -> a+ type ConstSym2 x y = Const x y++This approach has various downsides which make it impractical:++* Type synonyms are often not expanded in the output of GHCi's :kind! command.+ As issue #445 chronicles, this can significantly impact the readability of+ even simple :kind! queries. It can be the difference between this:++ λ> :kind! Map IdSym0 '[1,2,3]+ Map IdSym0 '[1,2,3] :: [Nat]+ = 1 :@#@$$$ '[2, 3]++ And this:++ λ> :kind! Map IdSym0 '[1,2,3]+ Map IdSym0 '[1,2,3] :: [Nat]+ = '[1, 2, 3]++ Making fully saturated defunctionalization symbols like (:@#@$$$) type+ families makes this issue moot, since :kind! always expands type families.+* There are a handful of corner cases where using type synonyms can actually+ make fully saturated defunctionalization symbols fail to typecheck.+ Here is one such corner case:++ $(promote [d|+ class Applicative f where+ pure :: a -> f a+ ...+ (*>) :: f a -> f b -> f b+ |])++ ==>++ class PApplicative f where+ type Pure (x :: a) :: f a+ type (*>) (x :: f a) (y :: f b) :: f b++ What would happen if we were to defunctionalize the promoted version of (*>)?+ We'd end up with the following defunctionalization symbols:++ type (*>@#@$) :: f a ~> f b ~> f b+ data (*>@#@$) f where ...++ type (*>@#@$$) :: f a -> f b ~> f b+ data (*>@#@$$) x f where ...++ type (*>@#@$$$) :: f a -> f b -> f b+ type (*>@#@$$$) x y = (*>) x y++ It turns out, however, that (*>@#@$$$) will not kind-check. Because (*>@#@$$$)+ has a standalone kind signature, it is kind-generalized *before* kind-checking+ the actual definition itself. Therefore, the full kind is:++ type (*>@#@$$$) :: forall {k} (f :: k -> Type) (a :: k) (b :: k).+ f a -> f b -> f b+ type (*>@#@$$$) x y = (*>) x y++ However, the kind of (*>) is+ `forall (f :: Type -> Type) (a :: Type) (b :: Type). f a -> f b -> f b`.+ This is not general enough for (*>@#@$$$), which expects kind-polymorphic `f`,+ `a`, and `b`, leading to a kind error. You might think that we could somehow+ infer this information, but note the quoted definition of Applicative (and+ PApplicative, as a consequence) omits the kinds of `f`, `a`, and `b` entirely.+ Unless we were to implement full-blown kind inference inside of Template+ Haskell (which is a tall order), the kind `f a -> f b -> f b` is about as good+ as we can get.++ Making (*>@#@$$$) a type family rather than a type synonym avoids this issue+ since type family equations are allowed to match on kind arguments. In this+ example, (*>@#@$$$) would have kind-polymorphic `f`, `a`, and `b` in its kind+ signature, but its equation would implicitly equate `k` with `Type`. Note+ that (*>@#@$) and (*>@#@$$), which are GADTs, also use a similar trick by+ equating `k` with `Type` in their GADT constructors.++-----+-- Wrinkle: avoiding reduction stack overflows+-----++A naïve attempt at declaring all fully saturated defunctionalization symbols+as type families can make certain programs overflow the reduction stack, such+as the T445 test case. This is because when evaluating+`FSym0 `Apply` x_1 `Apply` ... `Apply` x_N`, (where F is a promoted function+that requires N arguments), we will eventually bottom out by evaluating+`FSymN x_1 ... x_N`, where FSymN is a fully saturated defunctionalization+symbol. Since FSymN is a type family, this is yet another type family+reduction that contributes to the overall reduction limit. This might not+seem like a lot, but it can add up if F is invoked several times in a single+type-level computation!++Fortunately, we can bypass evaluating FSymN entirely by just making a slight+tweak to the TH machinery. Instead of generating this Apply instance:++ type instance Apply (FSym{N-1} x_1 ... x_{N-1}) x_N =+ FSymN x_1 ... x_{N-1} x_N++Generate this instance, which jumps straight to F:++ type instance Apply (FSym{N-1} x_1 ... x_{N-1}) x_N =+ F x_1 ... x_{N-1} x_N++Now evaluating `FSym0 `Apply` x_1 `Apply` ... `Apply` x_N` will require one+less type family reduction. In practice, this is usually enough to keep the+reduction limit at bay in most situations.++Note [Fixity declarations for defunctionalization symbols]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Just like we promote fixity declarations, we should also generate fixity+declarations for defunctionaliztion symbols. A primary use case is the+following scenario:++ (.) :: (b -> c) -> (a -> b) -> (a -> c)+ (f . g) x = f (g x)+ infixr 9 .++One often writes (f . g . h) at the value level, but because (.) is promoted+to a type family with three arguments, this doesn't directly translate to the+type level. Instead, one must write this:++ f .@#@$$$ g .@#@$$$ h++But in order to ensure that this associates to the right as expected, one must+generate an `infixr 9 .@#@#$$$` declaration. This is why defunctionalize accepts+a Maybe Fixity argument.+-}
src/Data/Singletons/TH/Promote/Monad.hs view
@@ -1,117 +1,435 @@-{- Data/Singletons/TH/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. --} - -module Data.Singletons.TH.Promote.Monad ( - PrM, promoteM, promoteM_, promoteMDecs, VarPromotions, - allLocals, emitDecs, emitDecsM, - lambdaBind, LetBind, letBind, lookupVarE - ) where - -import Control.Monad.Reader -import Control.Monad.Writer -import Language.Haskell.TH.Syntax hiding ( lift ) -import Language.Haskell.TH.Desugar -import qualified Language.Haskell.TH.Desugar.OMap.Strict as OMap -import Language.Haskell.TH.Desugar.OMap.Strict (OMap) -import Data.Singletons.TH.Options -import Data.Singletons.TH.Syntax - -type LetExpansions = OMap Name DType -- from **term-level** name - --- environment during promotion -data PrEnv = - PrEnv { pr_options :: Options - , pr_lambda_bound :: OMap Name Name - , pr_let_bound :: LetExpansions - , pr_local_decls :: [Dec] - } - -emptyPrEnv :: PrEnv -emptyPrEnv = PrEnv { pr_options = defaultOptions - , pr_lambda_bound = OMap.empty - , pr_let_bound = OMap.empty - , pr_local_decls = [] } - --- the promotion monad -newtype PrM a = PrM (ReaderT PrEnv (WriterT [DDec] Q) a) - deriving ( Functor, Applicative, Monad, Quasi - , MonadReader PrEnv, MonadWriter [DDec] - , MonadFail, MonadIO ) - -instance DsMonad PrM where - localDeclarations = asks pr_local_decls - -instance OptionsMonad PrM where - getOptions = asks pr_options - --- return *type-level* names -allLocals :: MonadReader PrEnv m => m [Name] -allLocals = do - lambdas <- asks (OMap.assocs . pr_lambda_bound) - lets <- asks pr_let_bound - -- filter out shadowed variables! - return [ typeName - | (termName, typeName) <- lambdas - , case OMap.lookup termName lets of - Just (DVarT typeName') | typeName' == typeName -> True - _ -> False ] - -emitDecs :: MonadWriter [DDec] m => [DDec] -> m () -emitDecs = tell - -emitDecsM :: MonadWriter [DDec] m => m [DDec] -> m () -emitDecsM action = do - decs <- action - emitDecs decs - --- when lambda-binding variables, we still need to add the variables --- to the let-expansion, because of shadowing. ugh. -lambdaBind :: VarPromotions -> PrM a -> PrM a -lambdaBind binds = local add_binds - where add_binds env@(PrEnv { pr_lambda_bound = lambdas - , pr_let_bound = lets }) = - let new_lets = OMap.fromList [ (tmN, DVarT tyN) | (tmN, tyN) <- binds ] in - env { pr_lambda_bound = OMap.fromList binds `OMap.union` lambdas - , pr_let_bound = new_lets `OMap.union` lets } - -type LetBind = (Name, DType) -letBind :: [LetBind] -> PrM a -> PrM a -letBind binds = local add_binds - where add_binds env@(PrEnv { pr_let_bound = lets }) = - env { pr_let_bound = OMap.fromList binds `OMap.union` lets } - -lookupVarE :: Name -> PrM DType -lookupVarE n = do - opts <- getOptions - lets <- asks pr_let_bound - case OMap.lookup n lets of - Just ty -> return ty - Nothing -> return $ DConT $ defunctionalizedName0 opts n - -promoteM :: OptionsMonad q => [Dec] -> PrM a -> q (a, [DDec]) -promoteM locals (PrM rdr) = do - opts <- getOptions - other_locals <- localDeclarations - let wr = runReaderT rdr (emptyPrEnv { pr_options = opts - , pr_local_decls = other_locals ++ locals }) - q = runWriterT wr - runQ q - -promoteM_ :: OptionsMonad q => [Dec] -> PrM () -> q [DDec] -promoteM_ locals thing = do - ((), decs) <- promoteM locals thing - return decs - --- promoteM specialized to [DDec] -promoteMDecs :: OptionsMonad q => [Dec] -> PrM [DDec] -> q [DDec] -promoteMDecs locals thing = do - (decs1, decs2) <- promoteM locals thing - return $ decs1 ++ decs2 +{- Data/Singletons/TH/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.+-}++module Data.Singletons.TH.Promote.Monad (+ PrM, promoteM, promoteM_, promoteMDecs, VarPromotions,+ allLocals, emitDecs, emitDecsM,+ scopedBind, lambdaBind, LetBind, letBind, lookupVarE+ ) where++import Control.Monad.Reader+import Control.Monad.Writer+import qualified Data.Foldable as F+import Language.Haskell.TH.Syntax hiding ( lift )+import Language.Haskell.TH.Desugar+import qualified Language.Haskell.TH.Desugar.OMap.Strict as OMap+import Language.Haskell.TH.Desugar.OMap.Strict (OMap)+import qualified Language.Haskell.TH.Desugar.OSet as OSet+import Language.Haskell.TH.Desugar.OSet (OSet)+import Data.Singletons.TH.Options+import Data.Singletons.TH.Syntax++-- environment during promotion+data PrEnv =+ PrEnv { pr_options :: Options+ , pr_scoped_vars :: OSet Name+ -- ^ The set of scoped type variables currently in scope.+ -- See @Note [Scoped type variables]@.+ , pr_lambda_vars :: OMap Name Name+ -- ^ Map from term-level 'Name's of variables bound in lambdas and+ -- function clauses to their type-level counterparts.+ -- See @Note [Tracking local variables]@.+ , pr_local_vars :: OMap Name DType+ -- ^ Map from term-level 'Name's of local variables to their+ -- type-level counterparts. Note that scoped type variables are stored+ -- separately in 'pr_scoped_tvs'.+ -- See @Note [Tracking local variables]@.+ , pr_local_decls :: [Dec]+ }++emptyPrEnv :: PrEnv+emptyPrEnv = PrEnv { pr_options = defaultOptions+ , pr_scoped_vars = OSet.empty+ , pr_lambda_vars = OMap.empty+ , pr_local_vars = OMap.empty+ , pr_local_decls = [] }++-- the promotion monad+newtype PrM a = PrM (ReaderT PrEnv (WriterT [DDec] Q) a)+ deriving ( Functor, Applicative, Monad, Quasi+ , MonadReader PrEnv, MonadWriter [DDec]+ , MonadFail, MonadIO )++instance DsMonad PrM where+ localDeclarations = asks pr_local_decls++instance OptionsMonad PrM where+ getOptions = asks pr_options++-- return *type-level* names+allLocals :: MonadReader PrEnv m => m [Name]+allLocals = do+ scoped <- asks (F.toList . pr_scoped_vars)+ lambdas <- asks (OMap.assocs . pr_lambda_vars)+ return $ scoped ++ map snd lambdas++emitDecs :: MonadWriter [DDec] m => [DDec] -> m ()+emitDecs = tell++emitDecsM :: MonadWriter [DDec] m => m [DDec] -> m ()+emitDecsM action = do+ decs <- action+ emitDecs decs++-- ^ Bring a list of type variables into scope for the duration the supplied+-- computation. See @Note [Tracking local variables]@ and+-- @Note [Scoped type variables]@.+scopedBind :: OSet Name -> PrM a -> PrM a+scopedBind binds =+ local (\env@(PrEnv { pr_scoped_vars = scoped }) ->+ env { pr_scoped_vars = binds `OSet.union` scoped })++-- ^ Bring a list of 'VarPromotions' into scope for the duration the supplied+-- computation. See @Note [Tracking local variables]@.+lambdaBind :: VarPromotions -> PrM a -> PrM a+lambdaBind binds = local add_binds+ where add_binds env@(PrEnv { pr_lambda_vars = lambdas+ , pr_local_vars = locals }) =+ -- Per Note [Tracking local variables], these will be added to both+ -- `pr_lambda_vars` and `pr_local_vars`.+ let new_locals = OMap.fromList [ (tmN, DVarT tyN) | (tmN, tyN) <- binds ] in+ env { pr_lambda_vars = OMap.fromList binds `OMap.union` lambdas+ , pr_local_vars = new_locals `OMap.union` locals }++-- ^ A pair consisting of a term-level 'Name' of a variable, bound in a @let@+-- binding or @where@ clause, and its type-level counterpart.+-- See @Note [Tracking local variables]@.+type LetBind = (Name, DType)++-- ^ Bring a list of 'LetBind's into scope for the duration the supplied+-- computation. See @Note [Tracking local variables]@.+letBind :: [LetBind] -> PrM a -> PrM a+letBind binds = local add_binds+ where add_binds env@(PrEnv { pr_local_vars = locals }) =+ env { pr_local_vars = OMap.fromList binds `OMap.union` locals }++-- | Map a term-level 'Name' to its type-level counterpart. This function is+-- aware of any local variables that are currently in scope.+-- See @Note [Tracking local variables]@.+lookupVarE :: Name -> PrM DType+lookupVarE n = do+ opts <- getOptions+ locals <- asks pr_local_vars+ case OMap.lookup n locals of+ Just ty -> return ty+ Nothing -> return $ DConT $ defunctionalizedName0 opts n++promoteM :: OptionsMonad q => [Dec] -> PrM a -> q (a, [DDec])+promoteM locals (PrM rdr) = do+ opts <- getOptions+ other_locals <- localDeclarations+ let wr = runReaderT rdr (emptyPrEnv { pr_options = opts+ , pr_local_decls = other_locals ++ locals })+ q = runWriterT wr+ runQ q++promoteM_ :: OptionsMonad q => [Dec] -> PrM () -> q [DDec]+promoteM_ locals thing = do+ ((), decs) <- promoteM locals thing+ return decs++-- promoteM specialized to [DDec]+promoteMDecs :: OptionsMonad q => [Dec] -> PrM [DDec] -> q [DDec]+promoteMDecs locals thing = do+ (decs1, decs2) <- promoteM locals thing+ return $ decs1 ++ decs2++{-+Note [Tracking local variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Handling local variables in singletons-th requires some care. There are three+sorts of local variables that singletons-th tracks:++1. Scoped type variables, e.g.,++ d :: forall a. Maybe a+ d = Nothing :: Maybe a++ e (x :: a) = Nothing :: Maybe a++ In both `d` and `e`, the variable `a` in `:: Maybe a` is scoped.++2. Lambda-bound variables, e.g.,++ f = \x -> x+ g x = x++ In both `f` and `g`, the variable `x` is considered lambda-bound.++3. Let-bound variables, e.g.,++ h =+ let x = 42 in+ x + x++ i = x + x+ where+ x = 42++ In both `h` and `i`, the variable `x` is considered let-bound.++Why does singletons-th need to track local variables? It's because they must+be promoted differently depending on whether they are local or not. Consider:++ j = ... x ...++When promoting the `j` function to a type family `J`, there are four possible+ways of promoting `x`:++* If `x` is a scoped type variable, then `x` must be promoted to the same+ name. This is because promoting a type variable to a kind variable is a+ no-op. For instance, we would promote this:++ j (z :: x) = (z :: x)++ Here, `(%%)`, `x`, and `y` are lambda-bound variables. But we cannot promote+ `j` to this type family:++ type family J arg where+ J (z :: x) = (z :: x)++* If `x` is a lambda-bound variable, then `x` must be promoted to a type+ variable. In general, we cannot promote `x` to the same name. Consider this+ example:++ j (%%) x y = x %% y++ Here, `(%%)`, `x`, and `y` are lambda-bound variables. But we cannot promote+ `j` to this type family:++ type family J (%%) x y where+ J (%%) x y = x %% y++ This is because type variable names cannot be symbolic like `(%%)` is. As a+ result, we create a fresh name `ty` and promote each occurrence of `(%%)` to+ `ty`:++ type family J ty x y where+ J ty x y = x `ty` y++ See `mkTyName` in Data.Singletons.TH.Names. In fact, `mkTyName` will also+ freshen alphanumeric names, so it would be more accurate to say that `j` will+ be promoted to this:++ type family J ty x_123 y_456 where+ J ty x_123 y_456 = x_123 `ty` y_456++ Where `x_123` and `y_456` are fresh names that are distinct from `x` and `y`.+ Freshening alphanumeric names like `x` and `y` is probably not strictly+ necessary, but `mkTyName` does it anyway (1) for consistency with symbolic+ names and (2) to make the type-level names easier to tell apart from the+ original term-level names.++* If `x` is a let-bound variable, then `x` must be promoted to something like+ `LetX`, where `LetX` is the lambda-lifted version of `x`. For instance, we+ would promote this:++ j = x+ where+ x = True++ To this:++ type family J where+ J = LetX+ type family LetX where+ LetX = True++* If `x` is not a local variable at all, then `x` must be promoted to something+ like `X`, which is assumed to be a top-level function. For instance, we would+ promote this:++ x = 42+ j = x++ To this:++ type family X where+ X = 42+ type family J where+ J = X++Being able to distinguish between all these sorts of variables requires+recording whether they are scoped, lambda-bound, or let-bound at their binding+sites during promotion and singling. This is primarily done in two places:++* During promotion, the `pr_local_vars` field of `PrEnv` tracks lambda- and+ let-bound variables.++* During singling, the `sg_local_vars` field of `SgEnv` tracks lambda- and+ let-bound variables.++Each of these fields are Maps from the original, term-level Names to the+promoted or singled versions of the Names. The `lookupVarE` functions (which+can be found in both Data.Singletons.TH.Promote.Monad and+Data.Singletons.TH.Single.Monad) are responsible for determining what a+term-level Name should be mapped to.++In addition to `pr_local_vars` and `sg_local_vars`, which include both lambda-+and let-bound variables, `PrEnv` also includes two additional fields for+tracking other sorts of local variables:++* The `pr_scoped_vars` field tracks which scoped type variables are currently+ in scope. As discussed above, promoting an occurrence of a scoped type+ variable is a no-op, and as such, we never need to use `lookupVarE` to figure+ out what a scoped type variable promotes to. As such, there is no need to put+ the scoped type variables in `pr_local_vars`.++ On the other hand, we /do/ need to track the scoped type variables for+ lambda-lifting purposes (see Note [Scoped type variables]), and this is the+ only reason why we bother maintaining the `pr_scoped_vars` field in the first+ place. See the `scopedBind` function, which is responsible for adding new+ scoped type variables to `pr_scoped_vars`.++* The `pr_lambda_vars` field only tracks lambda-bound variables, unlike+ `pr_local_vars`, which also includes let-bound variables. We must do this+ because lambda-bound variables are treated differently during lambda lifting.+ Lambda-lifted functions must close over any lambda-bound variables in scope,+ but /not/ any let-bound variables in scope, since the latter are+ lambda-lifted separately.++ A consequence of this is that when we lambda-bind a variable during promotion+ (see `lambdaBind`), we add the variable to both `pr_lambda_vars` and+ `pr_local_vars`. When we let-bind a variable during promotion (see+ `letBind`), we only add the variable to `pr_local_vars`. This means that+ `pr_lambda_vars` will always be a subset of `pr_local_vars`.++Because singling does not do anything akin to lambda lifting, `SgEnv` does not+have anything like `sg_scoped_vars` or `sg_lambda_vars`.++Note [Scoped type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Scoped type variables are a particular form of local variable (see Note+[Tracking local variables]). They are arguably the trickiest form of local+variable to handle, and as noted in the singletons README, there are still some+forms of scoped type variables that singletons-th cannot handle during+promotion.++First, let's discuss how singletons-th promotes scoped type variables in+general:++* When promoting a function with a top-level type signature, we annotate each+ argument on the left-hand sides of type family equations with its kind. This+ is usually redundant, but it can sometimes be useful for bringing type+ variables into scope. For example, this:++ f :: forall a. a -> Maybe a+ f x = (Just x :: Maybe a)++ Will be promoted to something like this:++ type F :: forall a. a -> Maybe a+ type family F x where+ F (x :: a) = (Just x :: Maybe a)++ Note that we gave the `x` on the left-hand side of `F`'s equation an explicit+ `:: a` kind signature to ensure that the `a` on the right-hand side of the+ type family equation is in scope.++ The `promoteClause` function in Data.Singletons.TH.Promote is responsible for+ implementing this.++* Sometimes, there are no arguments available to bring type variables into+ scope. In these situations, we can sometimes use `@` in type family equations+ as an alternative. For example, this:++ g :: forall a. Maybe a+ g = (Nothing :: Maybe a)++ Will be promoted to this:++ type G :: forall a. Maybe a+ type family G where+ G @a = (Nothing :: Maybe a)++ Note the `@a` on `G`'s left-hand side. This relies on `G` having a standalone+ kind signature to work.++ The `promoteLetDecName` function in Data.Singletons.TH.Promote is responsible+ for implementing this.++* When lambda-lifting, singletons-th tracks the current set of scoped type+ variables and includes them as explicit arguments when promoting local+ definitions. For example, this:++ h :: forall a. a -> a+ h x = i+ where+ i = (x :: a)++ Will be promoted to this:++ type H :: forall a. a -> a+ type family H x where+ H @a (x :: a) = LetI a x++ type I a x where+ I a x = (x :: a)++ The `I` type family includes both `a` (a scoped type variable) and `x` (a+ lambda-bound variable) as explicit arguments to ensure that they are in scope+ on the right-hand side, which mentions both of them.++ singletons-th uses the `pr_scoped_vars` field of `PrM` to track scoped type+ variables. Whenever new scoped type variables are bound during promotion, the+ `scopedBind` function is used to add the variables to `pr_scoped_vars`.++These three tricks suffice to handle a substantial number of ways that scoped+type variables can be used. The approach is not perfect, however. Here are two+scenarios where singletons-th fails to promote scoped type variables:++* Funky pattern signatures like this one will not work:++ j :: forall a. a -> a+ j (x :: b) = b++ This is because singletons-th will attempt to promote `j` like so:++ type J :: forall a. a -> a+ type J x where+ J @a ((x :: b) :: a) = b++ But unlike in terms, GHC has no way to know that `a` and `b` are meant to+ refer to the same type variable. In order to make this work, we would need to+ substitute all occurrences of `a` with `b` in the type family equation (or+ vice versa), which seems challenging in the general case.++* Scoped type variables that are only mentioned in the return types of local+ definitions may not always work, such as in this example:++ k x = y+ where+ y :: forall b. Maybe b+ y = Nothing :: Maybe b++ singletons-th would promote `k` and `y` to the following type families:++ type K x where+ K x = LetY x++ type LetY x :: Maybe b where+ LetY x = Nothing :: Maybe b++ Note that because `LetY` closes over the `x` argument, it cannot easily be+ given a standalone kind signature, and this prevents us from writing+ `LetY @b x = ...`. Moreover, `LetY` does not have an argument that we can+ attach an explicit `:: b` signature to. (Attaching it to `x` would be+ incorrect, as that would give `LetY` a less general kind.)++ One possible way forward here would be to give type families the ability to+ write result signatures on their left-hand sides, similar to what GHC+ proposal #228+ (https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0228-function-result-sigs.rst)+ offers:++ type LetY x :: Maybe b where+ LetY x :: Maybe b = Nothing :: Maybe b+-}
src/Data/Singletons/TH/Promote/Type.hs view
@@ -1,175 +1,175 @@-{- Data/Singletons/TH/Promote/Type.hs - -(c) Richard Eisenberg 2013 -rae@cs.brynmawr.edu - -This file implements promotion of types into kinds. --} - -module Data.Singletons.TH.Promote.Type - ( promoteType, promoteType_NC, promoteType_options - , PromoteTypeOptions(..), defaultPromoteTypeOptions - , promoteTypeArg_NC, promoteUnraveled - ) where - -import Control.Monad (when) -import Language.Haskell.TH (pprint) -import Language.Haskell.TH.Desugar -import Data.Singletons.TH.Names -import Data.Singletons.TH.Options -import Data.Singletons.TH.Util - --- | Promote a 'DType' to the kind level and invoke 'checkVanillaDType'. --- See @Note [Vanilla-type validity checking during promotion]@. -promoteType :: OptionsMonad m => DType -> m DKind -promoteType = promoteType_options defaultPromoteTypeOptions{ptoCheckVanilla = True} - --- | Promote a 'DType' to the kind level. This is suffixed with \"_NC\" because --- we do not invoke 'checkVanillaDType' here. --- See @Note [Vanilla-type validity checking during promotion]@. -promoteType_NC :: forall m. OptionsMonad m => DType -> m DKind -promoteType_NC = promoteType_options defaultPromoteTypeOptions - --- | Options for controlling how types are promoted at a fine granularity. -data PromoteTypeOptions = PromoteTypeOptions - { ptoCheckVanilla :: Bool - -- ^ If 'True', invoke 'checkVanillaDType' on the argument type being - -- promoted. See @Note [Vanilla-type validity checking during promotion]@. - , ptoAllowWildcards :: Bool - -- ^ If 'True', allow promoting wildcard types. Otherwise, throw an error. - -- In most places, GHC disallows kind-level wildcard types, so rather - -- than promoting such wildcards and getting an error message from GHC - -- /post facto/, we can catch such wildcards early and give a more - -- descriptive error message instead. - } deriving Show - --- | The default 'PromoteTypeOptions': --- --- * 'checkVanillaDType' is not invoked. --- --- * Throw an error when attempting to promote a wildcard type. -defaultPromoteTypeOptions :: PromoteTypeOptions -defaultPromoteTypeOptions = PromoteTypeOptions - { ptoCheckVanilla = False - , ptoAllowWildcards = False - } - --- | Promote a 'DType' to the kind level. This is the workhorse for --- 'promoteType' and 'promoteType_NC'. -promoteType_options :: forall m. OptionsMonad m => PromoteTypeOptions -> DType -> m DKind -promoteType_options pto typ = do - -- See Note [Vanilla-type validity checking during promotion] - when (ptoCheckVanilla pto) $ - checkVanillaDType typ - go [] typ - where - go :: [DTypeArg] -> DType -> m DKind - go [] (DForallT tele ty) = do - ty' <- go [] ty - pure $ DForallT tele ty' - go args ty@DForallT{} = illegal args ty - -- We don't need to worry about constraints: they are used to express - -- static guarantees at runtime. But, because we don't need to do - -- anything special to keep static guarantees at compile time, we don't - -- need to promote them. - go [] (DConstrainedT _cxt ty) = go [] ty - go args ty@DConstrainedT{} = illegal args ty - go args (DAppT t1 t2) = do - k2 <- go [] t2 - go (DTANormal k2 : args) t1 - -- NB: This next case means that promoting something like - -- (((->) a) :: Type -> Type) b - -- will fail because the pattern below won't recognize the - -- arrow to turn it into a TyFun. But I'm not terribly - -- bothered by this, and it would be annoying to fix. Wait - -- for someone to report. - go args (DAppKindT ty ki) = do - ki' <- go [] ki - go (DTyArg ki' : args) ty - go args (DSigT ty ki) = do - ty' <- go [] ty - -- No need to promote 'ki' - it is already a kind. - return $ applyDType (DSigT ty' ki) args - go args (DVarT name) = return $ applyDType (DVarT name) args - go args (DConT name) = do - opts <- getOptions - return $ applyDType (DConT (promotedDataTypeOrConName opts name)) args - go args ty@DArrowT = - case filterDTANormals args of - [] -> noPartialArrows - [_] -> noPartialArrows - [k1, k2] -> return $ DConT tyFunArrowName `DAppT` k1 `DAppT` k2 - (_:_:_:_) -> illegal args ty - go [] ty@DLitT{} = pure ty - go args ty@DLitT{} = illegal args ty - go args ty@DWildCardT{} - | ptoAllowWildcards pto - = pure $ applyDType ty args - | otherwise - = fail $ unlines - [ "`singletons-th` does not support wildcard types" - , "\tunless they appear in visible type patterns of data constructors" - , "\t" ++ herald - ] - - noPartialArrows :: m a - noPartialArrows = fail $ unlines - [ "`singletons-th` does not support partial applications of (->)" - , "\t" ++ herald - ] - - herald :: String - herald = "In the type: " ++ pprint (sweeten typ) - - illegal :: [DTypeArg] -> DType -> m a - illegal args hd = fail $ unlines - [ "Illegal Haskell construct encountered:" - , "\theaded by: " ++ show hd - , "\tapplied to: " ++ show args - ] - --- | Promote a DTypeArg to the kind level. This is suffixed with "_NC" because --- we do not invoke checkVanillaDType here. --- See @Note [Vanilla-type validity checking during promotion]@. -promoteTypeArg_NC :: OptionsMonad m => DTypeArg -> m DTypeArg -promoteTypeArg_NC (DTANormal t) = DTANormal <$> promoteType_NC t -promoteTypeArg_NC ta@(DTyArg _) = pure ta -- Kinds are already promoted - --- | Promote a DType to the kind level, splitting it into its type variable --- binders, argument types, and result type in the process. -promoteUnraveled :: OptionsMonad m - => DType -> m ([DTyVarBndrSpec], [DKind], DKind) -promoteUnraveled ty = do - (tvbs, _, arg_tys, res_ty) <- unravelVanillaDType ty - arg_kis <- mapM promoteType_NC arg_tys - res_ki <- promoteType_NC res_ty - return (tvbs, arg_kis, res_ki) - -{- -Note [Vanilla-type validity checking during promotion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We only support promoting (and singling) vanilla types, where a vanilla -function type is a type that: - -1. Only uses a @forall@ at the top level, if used at all. That is to say, it - does not contain any nested or higher-rank @forall@s. - -2. Only uses a context (e.g., @c => ...@) at the top level, if used at all, - and only after the top-level @forall@ if one is present. That is to say, - it does not contain any nested or higher-rank contexts. - -3. Contains no visible dependent quantification. - -The checkVanillaDType function checks if a type is vanilla. Note that it is -crucial to call checkVanillaDType on the /entire/ type. For instance, it would -be incorrect to call unravelVanillaDType and then check each argument type -individually, since that loses information about which @forall@s/constraints -are higher-rank. - -We make an effort to avoiding calling checkVanillaDType on the same type twice, -since checkVanillaDType must traverse the entire type. (It would not be -incorrect to do so, just wasteful.) For this certain, certain functions are -suffixed with "_NC" (short for "no checking") to indicate that they do not -invoke checkVanillaDType. These functions are used on types that have already -been validity-checked. --} +{- Data/Singletons/TH/Promote/Type.hs++(c) Richard Eisenberg 2013+rae@cs.brynmawr.edu++This file implements promotion of types into kinds.+-}++module Data.Singletons.TH.Promote.Type+ ( promoteType, promoteType_NC, promoteType_options+ , PromoteTypeOptions(..), defaultPromoteTypeOptions+ , promoteTypeArg_NC, promoteUnraveled+ ) where++import Control.Monad (when)+import Language.Haskell.TH (pprint)+import Language.Haskell.TH.Desugar+import Data.Singletons.TH.Names+import Data.Singletons.TH.Options+import Data.Singletons.TH.Util++-- | Promote a 'DType' to the kind level and invoke 'checkVanillaDType'.+-- See @Note [Vanilla-type validity checking during promotion]@.+promoteType :: OptionsMonad m => DType -> m DKind+promoteType = promoteType_options defaultPromoteTypeOptions{ptoCheckVanilla = True}++-- | Promote a 'DType' to the kind level. This is suffixed with \"_NC\" because+-- we do not invoke 'checkVanillaDType' here.+-- See @Note [Vanilla-type validity checking during promotion]@.+promoteType_NC :: forall m. OptionsMonad m => DType -> m DKind+promoteType_NC = promoteType_options defaultPromoteTypeOptions++-- | Options for controlling how types are promoted at a fine granularity.+data PromoteTypeOptions = PromoteTypeOptions+ { ptoCheckVanilla :: Bool+ -- ^ If 'True', invoke 'checkVanillaDType' on the argument type being+ -- promoted. See @Note [Vanilla-type validity checking during promotion]@.+ , ptoAllowWildcards :: Bool+ -- ^ If 'True', allow promoting wildcard types. Otherwise, throw an error.+ -- In most places, GHC disallows kind-level wildcard types, so rather+ -- than promoting such wildcards and getting an error message from GHC+ -- /post facto/, we can catch such wildcards early and give a more+ -- descriptive error message instead.+ } deriving Show++-- | The default 'PromoteTypeOptions':+--+-- * 'checkVanillaDType' is not invoked.+--+-- * Throw an error when attempting to promote a wildcard type.+defaultPromoteTypeOptions :: PromoteTypeOptions+defaultPromoteTypeOptions = PromoteTypeOptions+ { ptoCheckVanilla = False+ , ptoAllowWildcards = False+ }++-- | Promote a 'DType' to the kind level. This is the workhorse for+-- 'promoteType' and 'promoteType_NC'.+promoteType_options :: forall m. OptionsMonad m => PromoteTypeOptions -> DType -> m DKind+promoteType_options pto typ = do+ -- See Note [Vanilla-type validity checking during promotion]+ when (ptoCheckVanilla pto) $+ checkVanillaDType typ+ go [] typ+ where+ go :: [DTypeArg] -> DType -> m DKind+ go [] (DForallT tele ty) = do+ ty' <- go [] ty+ pure $ DForallT tele ty'+ go args ty@DForallT{} = illegal args ty+ -- We don't need to worry about constraints: they are used to express+ -- static guarantees at runtime. But, because we don't need to do+ -- anything special to keep static guarantees at compile time, we don't+ -- need to promote them.+ go [] (DConstrainedT _cxt ty) = go [] ty+ go args ty@DConstrainedT{} = illegal args ty+ go args (DAppT t1 t2) = do+ k2 <- go [] t2+ go (DTANormal k2 : args) t1+ -- NB: This next case means that promoting something like+ -- (((->) a) :: Type -> Type) b+ -- will fail because the pattern below won't recognize the+ -- arrow to turn it into a TyFun. But I'm not terribly+ -- bothered by this, and it would be annoying to fix. Wait+ -- for someone to report.+ go args (DAppKindT ty ki) = do+ ki' <- go [] ki+ go (DTyArg ki' : args) ty+ go args (DSigT ty ki) = do+ ty' <- go [] ty+ -- No need to promote 'ki' - it is already a kind.+ return $ applyDType (DSigT ty' ki) args+ go args (DVarT name) = return $ applyDType (DVarT name) args+ go args (DConT name) = do+ opts <- getOptions+ return $ applyDType (DConT (promotedDataTypeOrConName opts name)) args+ go args ty@DArrowT =+ case filterDTANormals args of+ [] -> noPartialArrows+ [_] -> noPartialArrows+ [k1, k2] -> return $ DConT tyFunArrowName `DAppT` k1 `DAppT` k2+ (_:_:_:_) -> illegal args ty+ go [] ty@DLitT{} = pure ty+ go args ty@DLitT{} = illegal args ty+ go args ty@DWildCardT{}+ | ptoAllowWildcards pto+ = pure $ applyDType ty args+ | otherwise+ = fail $ unlines+ [ "`singletons-th` does not support wildcard types"+ , "\tunless they appear in visible type patterns of data constructors"+ , "\t" ++ herald+ ]++ noPartialArrows :: m a+ noPartialArrows = fail $ unlines+ [ "`singletons-th` does not support partial applications of (->)"+ , "\t" ++ herald+ ]++ herald :: String+ herald = "In the type: " ++ pprint (sweeten typ)++ illegal :: [DTypeArg] -> DType -> m a+ illegal args hd = fail $ unlines+ [ "Illegal Haskell construct encountered:"+ , "\theaded by: " ++ show hd+ , "\tapplied to: " ++ show args+ ]++-- | Promote a DTypeArg to the kind level. This is suffixed with "_NC" because+-- we do not invoke checkVanillaDType here.+-- See @Note [Vanilla-type validity checking during promotion]@.+promoteTypeArg_NC :: OptionsMonad m => DTypeArg -> m DTypeArg+promoteTypeArg_NC (DTANormal t) = DTANormal <$> promoteType_NC t+promoteTypeArg_NC ta@(DTyArg _) = pure ta -- Kinds are already promoted++-- | Promote a DType to the kind level, splitting it into its type variable+-- binders, argument types, and result type in the process.+promoteUnraveled :: OptionsMonad m+ => DType -> m ([DTyVarBndrSpec], [DKind], DKind)+promoteUnraveled ty = do+ (tvbs, _, arg_tys, res_ty) <- unravelVanillaDType ty+ arg_kis <- mapM promoteType_NC arg_tys+ res_ki <- promoteType_NC res_ty+ return (tvbs, arg_kis, res_ki)++{-+Note [Vanilla-type validity checking during promotion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We only support promoting (and singling) vanilla types, where a vanilla+function type is a type that:++1. Only uses a @forall@ at the top level, if used at all. That is to say, it+ does not contain any nested or higher-rank @forall@s.++2. Only uses a context (e.g., @c => ...@) at the top level, if used at all,+ and only after the top-level @forall@ if one is present. That is to say,+ it does not contain any nested or higher-rank contexts.++3. Contains no visible dependent quantification.++The checkVanillaDType function checks if a type is vanilla. Note that it is+crucial to call checkVanillaDType on the /entire/ type. For instance, it would+be incorrect to call unravelVanillaDType and then check each argument type+individually, since that loses information about which @forall@s/constraints+are higher-rank.++We make an effort to avoiding calling checkVanillaDType on the same type twice,+since checkVanillaDType must traverse the entire type. (It would not be+incorrect to do so, just wasteful.) For this certain, certain functions are+suffixed with "_NC" (short for "no checking") to indicate that they do not+invoke checkVanillaDType. These functions are used on types that have already+been validity-checked.+-}
src/Data/Singletons/TH/Single.hs view
@@ -1,1093 +1,1118 @@-{-# LANGUAGE TemplateHaskellQuotes #-} - -{- Data/Singletons/TH/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-th package. --} - -module Data.Singletons.TH.Single where - -import Prelude hiding ( exp ) -import Language.Haskell.TH hiding ( cxt ) -import Language.Haskell.TH.Syntax (NameSpace(..), Quasi(..)) -import Data.Singletons.TH.Deriving.Bounded -import Data.Singletons.TH.Deriving.Enum -import Data.Singletons.TH.Deriving.Eq -import Data.Singletons.TH.Deriving.Infer -import Data.Singletons.TH.Deriving.Ord -import Data.Singletons.TH.Deriving.Show -import Data.Singletons.TH.Deriving.Util -import Data.Singletons.TH.Names -import Data.Singletons.TH.Options -import Data.Singletons.TH.Partition -import Data.Singletons.TH.Promote -import Data.Singletons.TH.Promote.Defun -import Data.Singletons.TH.Promote.Monad ( promoteM ) -import Data.Singletons.TH.Promote.Type -import Data.Singletons.TH.Single.Data -import Data.Singletons.TH.Single.Decide -import Data.Singletons.TH.Single.Defun -import Data.Singletons.TH.Single.Fixity -import Data.Singletons.TH.Single.Monad -import Data.Singletons.TH.Single.Type -import Data.Singletons.TH.Syntax -import Data.Singletons.TH.Util -import Language.Haskell.TH.Desugar -import qualified Language.Haskell.TH.Desugar.OMap.Strict as OMap -import Language.Haskell.TH.Desugar.OMap.Strict (OMap) -import qualified Data.Map.Strict as Map -import Data.Map.Strict ( Map ) -import Data.Maybe -import qualified Data.Set as Set -import Control.Monad -import Control.Monad.Trans.Class -import Data.List (unzip6, zipWith4) -import qualified GHC.LanguageExtensions.Type as LangExt - -{- -How singletons-th works -~~~~~~~~~~~~~~~~~~~~~~~ - -Singling, on the surface, doesn't seem all that complicated. Promote the type, -and singletonize all the terms. That's essentially what was done singletons < 1.0. -But, now we want to deal with higher-order singletons. So, things are a little -more complicated. - -The way to understand all of this is that *every* variable maps to something -of type (Sing t), for an appropriately-kinded t. This includes functions, which -use the "SLambda" instance of Sing. To apply singleton functions, we use the -applySing function. - -That, in and of itself, wouldn't be too hard, but it's really annoying from -the user standpoint. After dutifully singling `map`, a user doesn't want to -have to use two `applySing`s to actually use it. So, any let-bound identifier -is eta-expanded so that the singled type has the same number of arrows as -the original type. (If there is no original type signature, then it has as -many arrows as the original had patterns.) Then, we store a use of one of the -singFunX functions in the SgM environment so that every use of a let-bound -identifier has a proper type (Sing t). - -It would be consistent to avoid this eta-expansion for local lets (as opposed -to top-level lets), but that seemed like more bother than it was worth. It -may also be possible to be cleverer about nested eta-expansions and contractions, -but that also seemed not to be worth it. Though I haven't tested it, my hope -is that the eta-expansions and contractions have no runtime effect, especially -because SLambda is a *newtype* instance, not a *data* instance. - -Note that to maintain the desired invariant, we must also be careful to eta- -contract constructors. This is the point of buildDataLets. --} - --- | Generate singled definitions for each of the provided type-level --- declaration 'Name's. For example, the singletons-th package itself uses --- --- > $(genSingletons [''Bool, ''Maybe, ''Either, ''[]]) --- --- to generate singletons for Prelude types. -genSingletons :: OptionsMonad q => [Name] -> q [Dec] -genSingletons names = do - opts <- getOptions - -- See Note [Disable genQuotedDecs in genPromotions and genSingletons] - -- in D.S.TH.Promote - withOptions opts{genQuotedDecs = False} $ do - checkForRep names - ddecs <- concatMapM (singInfo <=< dsInfo <=< reifyWithLocals) names - return $ decsToTH ddecs - --- | Make promoted and singled versions of all declarations given, retaining --- the original declarations. See the --- @<https://github.com/goldfirere/singletons/blob/master/README.md README>@ --- for further explanation. -singletons :: OptionsMonad q => q [Dec] -> q [Dec] -singletons qdecs = do - opts <- getOptions - withOptions opts{genQuotedDecs = True} $ singletons' $ lift qdecs - --- | Make promoted and singled versions of all declarations given, discarding --- the original declarations. Note that a singleton based on a datatype needs --- the original datatype, so this will fail if it sees any datatype declarations. --- Classes, instances, and functions are all fine. -singletonsOnly :: OptionsMonad q => q [Dec] -> q [Dec] -singletonsOnly qdecs = do - opts <- getOptions - withOptions opts{genQuotedDecs = False} $ singletons' $ lift qdecs - --- The workhorse for 'singletons' and 'singletonsOnly'. The difference between --- the two functions is whether 'genQuotedDecs' is set to 'True' or 'False'. -singletons' :: OptionsMonad q => q [Dec] -> q [Dec] -singletons' qdecs = do - opts <- getOptions - decs <- qdecs - ddecs <- withLocalDeclarations decs $ dsDecs decs - singDecs <- singTopLevelDecs decs ddecs - let origDecs | genQuotedDecs opts = decs - | otherwise = [] - return $ origDecs ++ decsToTH singDecs - --- | Create instances of 'SEq' for the given types -singEqInstances :: OptionsMonad q => [Name] -> q [Dec] -singEqInstances = concatMapM singEqInstance - --- | Create instance of 'SEq' for the given type -singEqInstance :: OptionsMonad q => Name -> q [Dec] -singEqInstance = singInstance mkEqInstance "Eq" - --- | Create instances of 'SDecide', 'TestEquality', and 'TestCoercion' for each --- type in the list. -singDecideInstances :: OptionsMonad q => [Name] -> q [Dec] -singDecideInstances = concatMapM singDecideInstance - --- | Create instances of 'SDecide', 'TestEquality', and 'TestCoercion' for the --- given type. -singDecideInstance :: OptionsMonad q => Name -> q [Dec] -singDecideInstance name = do - (_df, tvbs, cons) <- getDataD ("I cannot make an instance of SDecide for it.") name - dtvbs <- mapM dsTvbUnit tvbs - let data_ty = foldTypeTvbs (DConT name) dtvbs - dcons <- concatMapM (dsCon dtvbs data_ty) cons - (scons, _) <- singM [] $ mapM (singCtor name) dcons - sDecideInstance <- mkDecideInstance Nothing data_ty dcons scons - testInstances <- traverse (mkTestInstance Nothing data_ty name dcons) - [TestEquality, TestCoercion] - return $ decsToTH (sDecideInstance:testInstances) - --- | Create instances of 'SOrd' for the given types -singOrdInstances :: OptionsMonad q => [Name] -> q [Dec] -singOrdInstances = concatMapM singOrdInstance - --- | Create instance of 'SOrd' for the given type -singOrdInstance :: OptionsMonad q => Name -> q [Dec] -singOrdInstance = singInstance mkOrdInstance "Ord" - --- | Create instances of 'SBounded' for the given types -singBoundedInstances :: OptionsMonad q => [Name] -> q [Dec] -singBoundedInstances = concatMapM singBoundedInstance - --- | Create instance of 'SBounded' for the given type -singBoundedInstance :: OptionsMonad q => Name -> q [Dec] -singBoundedInstance = singInstance mkBoundedInstance "Bounded" - --- | Create instances of 'SEnum' for the given types -singEnumInstances :: OptionsMonad q => [Name] -> q [Dec] -singEnumInstances = concatMapM singEnumInstance - --- | Create instance of 'SEnum' for the given type -singEnumInstance :: OptionsMonad q => Name -> q [Dec] -singEnumInstance = singInstance mkEnumInstance "Enum" - --- | Create instance of 'SShow' for the given type --- --- (Not to be confused with 'showShowInstance'.) -singShowInstance :: OptionsMonad q => Name -> q [Dec] -singShowInstance = singInstance mkShowInstance "Show" - --- | Create instances of 'SShow' for the given types --- --- (Not to be confused with 'showSingInstances'.) -singShowInstances :: OptionsMonad q => [Name] -> q [Dec] -singShowInstances = concatMapM singShowInstance - --- | Create instance of 'Show' for the given singleton type --- --- (Not to be confused with 'singShowInstance'.) -showSingInstance :: OptionsMonad q => Name -> q [Dec] -showSingInstance name = do - (df, tvbs, cons) <- getDataD ("I cannot make an instance of Show for it.") name - dtvbs <- mapM dsTvbUnit tvbs - let data_ty = foldTypeTvbs (DConT name) dtvbs - dcons <- concatMapM (dsCon dtvbs data_ty) cons - let tyvars = map (DVarT . extractTvbName) dtvbs - kind = foldType (DConT name) tyvars - data_decl = DataDecl df name dtvbs dcons - deriv_show_decl = DerivedDecl { ded_mb_cxt = Nothing - , ded_type = kind - , ded_type_tycon = name - , ded_decl = data_decl } - (show_insts, _) <- singM [] $ singDerivedShowDecs deriv_show_decl - pure $ decsToTH show_insts - --- | Create instances of 'Show' for the given singleton types --- --- (Not to be confused with 'singShowInstances'.) -showSingInstances :: OptionsMonad q => [Name] -> q [Dec] -showSingInstances = concatMapM showSingInstance - --- | Create an instance for @'SingI' TyCon{N}@, where @N@ is the positive --- number provided as an argument. --- --- Note that the generated code requires the use of the @QuantifiedConstraints@ --- language extension. -singITyConInstances :: DsMonad q => [Int] -> q [Dec] -singITyConInstances = mapM singITyConInstance - --- | Create an instance for @'SingI' TyCon{N}@, where @N@ is the positive --- number provided as an argument. --- --- Note that the generated code requires the use of the @QuantifiedConstraints@ --- language extension. -singITyConInstance :: DsMonad q => Int -> q Dec -singITyConInstance n - | n <= 0 - = fail $ "Argument must be a positive number (given " ++ show n ++ ")" - | otherwise - = do as <- replicateM n (qNewName "a") - ks <- replicateM n (qNewName "k") - k_last <- qNewName "k_last" - f <- qNewName "f" - x <- qNewName "x" - let k_penult = last ks - k_fun = ravelVanillaDType [] [] (map DVarT ks) (DVarT k_last) - f_ty = DVarT f - a_tys = map DVarT as - mk_fun arrow t1 t2 = arrow `DAppT` t1 `DAppT` t2 - matchable_apply_fun = mk_fun DArrowT (DVarT k_penult) (DVarT k_last) - unmatchable_apply_fun = mk_fun (DConT tyFunArrowName) (DVarT k_penult) (DVarT k_last) - ctxt = [ DForallT (DForallInvis (map (`DPlainTV` SpecifiedSpec) as)) $ - DConstrainedT (map (DAppT (DConT singIName)) a_tys) - (DConT singIName `DAppT` foldType f_ty a_tys) - , DConT equalityName - `DAppT` (DConT applyTyConName `DSigT` - mk_fun DArrowT matchable_apply_fun unmatchable_apply_fun) - `DAppT` DConT applyTyConAux1Name - ] - pure $ decToTH - $ DInstanceD - Nothing Nothing ctxt - (DConT singIName `DAppT` (DConT (mkTyConName n) `DAppT` (f_ty `DSigT` k_fun))) - [DLetDec $ DFunD singMethName - [DClause [] $ - wrapSingFun 1 DWildCardT $ - DLamE [x] $ - DVarE withSingIName `DAppE` DVarE x - `DAppE` DVarE singMethName]] - -singInstance :: OptionsMonad q => DerivDesc q -> String -> Name -> q [Dec] -singInstance mk_inst inst_name name = do - (df, tvbs, cons) <- getDataD ("I cannot make an instance of " ++ inst_name - ++ " for it.") name - dtvbs <- mapM dsTvbUnit tvbs - let data_ty = foldTypeTvbs (DConT name) dtvbs - dcons <- concatMapM (dsCon dtvbs data_ty) cons - let data_decl = DataDecl df name dtvbs dcons - raw_inst <- mk_inst Nothing data_ty data_decl - (a_inst, decs) <- promoteM [] $ - promoteInstanceDec OMap.empty Map.empty raw_inst - decs' <- singDecsM [] $ (:[]) <$> singInstD a_inst - return $ decsToTH (decs ++ decs') - -singInfo :: OptionsMonad q => DInfo -> q [DDec] -singInfo (DTyConI dec _) = - singTopLevelDecs [] [dec] -singInfo (DPrimTyConI _name _numArgs _unlifted) = - fail "Singling of primitive type constructors not supported" -singInfo (DVarI _name _ty _mdec) = - fail "Singling of value info not supported" -singInfo (DTyVarI _name _ty) = - fail "Singling of type variable info not supported" -singInfo (DPatSynI {}) = - fail "Singling of pattern synonym info not supported" - -singTopLevelDecs :: OptionsMonad q => [Dec] -> [DDec] -> q [DDec] -singTopLevelDecs locals raw_decls = withLocalDeclarations locals $ do - decls <- expand raw_decls -- expand type synonyms - PDecs { pd_let_decs = letDecls - , pd_class_decs = classes - , pd_instance_decs = insts - , pd_data_decs = datas - , pd_ty_syn_decs = ty_syns - , pd_open_type_family_decs = o_tyfams - , pd_closed_type_family_decs = c_tyfams - , pd_derived_eq_decs = derivedEqDecs - , pd_derived_show_decs = derivedShowDecs } <- partitionDecs decls - - ((letDecEnv, classes', insts'), promDecls) <- promoteM locals $ do - defunTopLevelTypeDecls ty_syns c_tyfams o_tyfams - recSelLetDecls <- promoteDataDecs datas - (_, letDecEnv) <- promoteLetDecs Nothing $ recSelLetDecls ++ letDecls - classes' <- mapM promoteClassDec classes - let meth_sigs = foldMap (lde_types . cd_lde) classes - cls_tvbs_map = Map.fromList $ map (\cd -> (cd_name cd, cd_tvbs cd)) classes - insts' <- mapM (promoteInstanceDec meth_sigs cls_tvbs_map) insts - return (letDecEnv, classes', insts') - - singDecsM locals $ do - dataLetBinds <- concatMapM buildDataLets datas - methLetBinds <- concatMapM buildMethLets classes - let letBinds = dataLetBinds ++ methLetBinds - (newLetDecls, singIDefunDecls, newDecls) - <- bindLets letBinds $ - singLetDecEnv letDecEnv $ do - newDataDecls <- concatMapM singDataD datas - newClassDecls <- mapM singClassD classes' - newInstDecls <- mapM singInstD insts' - newDerivedEqDecs <- concatMapM singDerivedEqDecs derivedEqDecs - newDerivedShowDecs <- concatMapM singDerivedShowDecs derivedShowDecs - return $ newDataDecls ++ newClassDecls - ++ newInstDecls - ++ newDerivedEqDecs - ++ newDerivedShowDecs - return $ promDecls ++ (map DLetDec newLetDecls) ++ singIDefunDecls ++ newDecls - --- see comment at top of file -buildDataLets :: OptionsMonad q => DataDecl -> q [(Name, DExp)] -buildDataLets (DataDecl _df _name _tvbs cons) = do - opts <- getOptions - pure $ concatMap (con_num_args opts) cons - where - con_num_args :: Options -> DCon -> [(Name, DExp)] - con_num_args opts (DCon _tvbs _cxt name fields _rty) = - (name, wrapSingFun (length (tysOfConFields fields)) - (DConT $ defunctionalizedName0 opts name) - (DConE $ singledDataConName opts name)) - : rec_selectors opts fields - - rec_selectors :: Options -> DConFields -> [(Name, DExp)] - rec_selectors _ (DNormalC {}) = [] - rec_selectors opts (DRecC fields) = - let names = map fstOf3 fields in - [ (name, wrapSingFun 1 (DConT $ defunctionalizedName0 opts name) - (DVarE $ singledValueName opts name)) - | name <- names ] - --- see comment at top of file -buildMethLets :: OptionsMonad q => UClassDecl -> q [(Name, DExp)] -buildMethLets (ClassDecl { cd_lde = LetDecEnv { lde_types = meth_sigs } }) = do - opts <- getOptions - pure $ map (mk_bind opts) (OMap.assocs meth_sigs) - where - mk_bind opts (meth_name, meth_ty) = - ( meth_name - , wrapSingFun (countArgs meth_ty) (DConT $ defunctionalizedName0 opts meth_name) - (DVarE $ singledValueName opts meth_name) ) - -singClassD :: AClassDecl -> SgM DDec -singClassD (ClassDecl { cd_cxt = cls_cxt - , cd_name = cls_name - , cd_tvbs = cls_tvbs - , cd_fds = cls_fundeps - , cd_lde = LetDecEnv { lde_defns = default_defns - , lde_types = meth_sigs - , lde_infix = fixities - , lde_proms = promoted_defaults } }) = - bindContext [foldTypeTvbs (DConT cls_name) cls_tvbs] $ do - opts <- getOptions - mb_cls_sak <- dsReifyType cls_name - let sing_cls_name = singledClassName opts cls_name - mb_sing_cls_sak = fmap (DKiSigD sing_cls_name) mb_cls_sak - cls_infix_decls <- singReifiedInfixDecls $ cls_name:meth_names - (sing_sigs, _, tyvar_names, cxts, res_kis, singIDefunss) - <- unzip6 <$> zipWithM (singTySig no_meth_defns meth_sigs) - meth_names - (map (DConT . defunctionalizedName0 opts) meth_names) - emitDecs $ maybeToList mb_sing_cls_sak ++ cls_infix_decls ++ concat singIDefunss - let default_sigs = catMaybes $ - zipWith4 (mk_default_sig opts) meth_names sing_sigs - tyvar_names res_kis - sing_meths <- mapM (uncurry (singLetDecRHS (Map.fromList cxts))) - (OMap.assocs default_defns) - fixities' <- mapMaybeM (uncurry singInfixDecl) $ OMap.assocs fixities - cls_cxt' <- mapM singPred cls_cxt - return $ DClassD cls_cxt' - sing_cls_name - cls_tvbs - cls_fundeps -- they are fine without modification - (map DLetDec (sing_sigs ++ sing_meths ++ fixities') ++ default_sigs) - where - no_meth_defns = error "Internal error: can't find declared method type" - meth_names = map fst $ OMap.assocs meth_sigs - - mk_default_sig :: Options -> Name -> DLetDec -> [Name] -> Maybe DType -> Maybe DDec - mk_default_sig opts meth_name (DSigD s_name sty) bound_kvs (Just res_ki) = - DDefaultSigD s_name <$> add_constraints opts meth_name sty bound_kvs res_ki - mk_default_sig _ _ _ _ _ = error "Internal error: a singled signature isn't a signature." - - add_constraints :: Options -> Name -> DType -> [Name] -> DType -> Maybe DType - -- We must look through `... :: Type` kind annotations, which can be added - -- when singling type signatures lacking explicit `forall`s. - -- See Note [Preserve the order of type variables during singling] - -- (wrinkle 1) in D.S.TH.Single.Type. - add_constraints opts meth_name (DSigT sty ski) bound_kvs res_ki = do - sty' <- add_constraints opts meth_name sty bound_kvs res_ki - pure $ DSigT sty' ski - add_constraints opts meth_name sty bound_kvs res_ki = do - (tvbs, cxt, args, res) <- unravelVanillaDType sty - prom_dflt <- OMap.lookup meth_name promoted_defaults - - -- Filter out explicitly bound kind variables. Otherwise, if you had - -- the following class (#312): - -- - -- class Foo a where - -- bar :: a -> b -> b - -- bar _ x = x - -- - -- Then it would be singled to: - -- - -- class SFoo a where - -- sBar :: forall b (x :: a) (y :: b). Sing x -> Sing y -> Sing (sBar x y) - -- default :: forall b (x :: a) (y :: b). - -- (Bar b x y) ~ (BarDefault b x y) => ... - -- - -- Which applies Bar/BarDefault to b, which shouldn't happen. - let tvs = map tvbToType $ - filter (\tvb -> extractTvbName tvb `Set.member` bound_kv_set) tvbs - prom_meth = DConT $ defunctionalizedName0 opts meth_name - default_pred = foldType (DConT equalityName) - -- NB: Need the res_ki here to prevent ambiguous - -- kinds in result-inferred default methods. - -- See #175 - [ foldApply prom_meth tvs `DSigT` res_ki - , foldApply prom_dflt tvs ] - return $ ravelVanillaDType tvbs (default_pred : cxt) args res - where - bound_kv_set = Set.fromList bound_kvs - -singInstD :: AInstDecl -> SgM DDec -singInstD (InstDecl { id_cxt = cxt, id_name = inst_name, id_arg_tys = inst_tys - , id_sigs = inst_sigs, id_meths = ann_meths }) = do - opts <- getOptions - let s_inst_name = singledClassName opts inst_name - bindContext cxt $ do - cxt' <- mapM singPred cxt - inst_kis <- mapM promoteType inst_tys - meths <- concatMapM (uncurry sing_meth) ann_meths - return (DInstanceD Nothing - Nothing - cxt' - (foldl DAppT (DConT s_inst_name) inst_kis) - meths) - - where - sing_meth :: Name -> ALetDecRHS -> SgM [DDec] - sing_meth name rhs = do - opts <- getOptions - mb_s_info <- dsReify (singledValueName opts name) - inst_kis <- mapM promoteType inst_tys - let mk_subst cls_tvbs = Map.fromList $ zip (map extractTvbName vis_cls_tvbs) inst_kis - where - -- This is a half-hearted attempt to address the underlying problem - -- in #358, where we can sometimes have more class type variables - -- (due to implicit kind arguments) than class arguments. This just - -- ensures that the explicit type variables are properly mapped - -- to the class arguments, leaving the implicit kind variables - -- unmapped. That could potentially cause *other* problems, but - -- those are perhaps best avoided by using InstanceSigs. At the - -- very least, this workaround will make error messages slightly - -- less confusing. - vis_cls_tvbs = drop (length cls_tvbs - length inst_kis) cls_tvbs - - sing_meth_ty :: DType -> SgM DType - sing_meth_ty inner_ty = do - -- Make sure to expand through type synonyms here! Not doing so - -- resulted in #167. - raw_ty <- expand inner_ty - (s_ty, _num_args, _tyvar_names, _ctxt, _arg_kis, _res_ki) - <- singType (DConT $ defunctionalizedName0 opts name) raw_ty - pure s_ty - - s_ty <- case OMap.lookup name inst_sigs of - Just inst_sig -> - -- We have an InstanceSig, so just single that type. - sing_meth_ty inst_sig - Nothing -> case mb_s_info of - -- We don't have an InstanceSig, so we must compute the type to use - -- in the singled instance ourselves through reification. - Just (DVarI _ (DForallT (DForallInvis cls_tvbs) (DConstrainedT _cls_pred s_ty)) _) -> - pure $ substType (mk_subst cls_tvbs) s_ty - _ -> do - mb_info <- dsReify name - case mb_info of - Just (DVarI _ (DForallT (DForallInvis cls_tvbs) - (DConstrainedT _cls_pred inner_ty)) _) -> do - s_ty <- sing_meth_ty inner_ty - pure $ substType (mk_subst cls_tvbs) s_ty - _ -> fail $ "Cannot find type of method " ++ show name - - meth' <- singLetDecRHS - Map.empty -- Because we are singling an instance declaration, - -- we aren't generating defunctionalization symbols - -- for the class methods, and hence we aren't - -- generating any SingI instances. Therefore, we - -- don't need to include anything in this Map. - name rhs - return $ map DLetDec [DSigD (singledValueName opts name) s_ty, meth'] - -singLetDecEnv :: ALetDecEnv - -> SgM a - -> SgM ([DLetDec], [DDec], a) - -- Return: - -- - -- 1. The singled let-decs - -- 2. SingI instances for any defunctionalization symbols - -- (see Data.Singletons.TH.Single.Defun) - -- 3. The result of running the `SgM a` action -singLetDecEnv (LetDecEnv { lde_defns = defns - , lde_types = types - , lde_infix = infix_decls - , lde_proms = proms }) - thing_inside = do - let prom_list = OMap.assocs proms - (typeSigs, letBinds, _tyvarNames, cxts, _res_kis, singIDefunss) - <- unzip6 <$> mapM (uncurry (singTySig defns types)) prom_list - infix_decls' <- mapMaybeM (uncurry singInfixDecl) $ OMap.assocs infix_decls - bindLets letBinds $ do - let_decs <- mapM (uncurry (singLetDecRHS (Map.fromList cxts))) - (OMap.assocs defns) - thing <- thing_inside - return (infix_decls' ++ typeSigs ++ let_decs, concat singIDefunss, thing) - -singTySig :: OMap Name ALetDecRHS -- definitions - -> OMap Name DType -- type signatures - -> 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] -- the scoped tyvar names in the tysig - , (Name, DCxt) -- the context of the type signature - , Maybe DKind -- the result kind in the tysig - , [DDec] -- SingI instances for defun symbols - ) -singTySig defns types name prom_ty = do - opts <- getOptions - let sName = singledValueName opts name - case OMap.lookup name types of - Nothing -> do - num_args <- guess_num_args - (sty, tyvar_names) <- mk_sing_ty num_args - singIDefuns <- singDefuns name VarName [] - (map (const Nothing) tyvar_names) Nothing - return ( DSigD sName sty - , (name, wrapSingFun num_args prom_ty (DVarE sName)) - , tyvar_names - , (name, []) - , Nothing - , singIDefuns ) - Just ty -> do - (sty, num_args, tyvar_names, ctxt, arg_kis, res_ki) - <- singType prom_ty ty - bound_cxt <- askContext - singIDefuns <- singDefuns name VarName (bound_cxt ++ ctxt) - (map Just arg_kis) (Just res_ki) - return ( DSigD sName sty - , (name, wrapSingFun num_args prom_ty (DVarE sName)) - , tyvar_names - , (name, ctxt) - , Just res_ki - , singIDefuns ) - where - guess_num_args :: SgM Int - guess_num_args = - case OMap.lookup name defns of - Nothing -> fail "Internal error: promotion known for something not let-bound." - Just (AValue _) -> return 0 - 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") - -- If there are no arguments, use `Sing @_` instead of `Sing`. - -- See Note [Disable kind generalization for local functions if possible] - let sing_w_wildcard | n == 0 = singFamily `DAppKindT` DWildCardT - | otherwise = singFamily - return ( ravelVanillaDType - (map (`DPlainTV` SpecifiedSpec) arg_names) - [] - (map (\nm -> singFamily `DAppT` DVarT nm) arg_names) - (sing_w_wildcard `DAppT` - (foldApply prom_ty (map DVarT arg_names))) - , arg_names ) - -{- -Note [Disable kind generalization for local functions if possible] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this example (from #296): - - f :: forall a. MyProxy a -> MyProxy a - f MyProxy = - let x = let z :: MyProxy a - z = MyProxy in z - in x - -A naïve attempt at singling `f` is as follows: - - type LetZ :: MyProxy a - type family LetZ where - LetZ = 'MyProxy - - type family LetX where - LetX = LetZ - - type F :: forall a. MyProxy a -> MyProxy a - type family F x where - F 'MyProxy = LetX - - sF :: forall a (t :: MyProxy a). Sing t -> Sing (F t :: MyProxy a) - sF SMyProxy = - let sX :: Sing LetX - sX = let sZ :: Sing (LetZ :: MyProxy a) - sZ = SMyProxy in sZ - in sX - -This will not typecheck, however. The is because the return kind of -`LetX` (in `let sX :: Sing LetX`) will get generalized by virtue of `sX` -having a type signature. It's as if one had written this: - - sF :: forall a (t :: MyProxy a). Sing t -> Sing (F t :: MyProxy a) - sF SMyProxy = - let sX :: forall a1. Sing (LetX :: MyProxy a1) - sX = ... - -This is too general, since `sX` will only typecheck if the return kind of -`LetX` is `MyProxy a`, not `MyProxy a1`. In order to avoid this problem, -we need to avoid kind generalization when kind-checking the type of `sX`. -To accomplish this, we borrow a trick from -Note [The id hack; or, how singletons-th learned to stop worrying and avoid kind generalization] -and use TypeApplications plus a wildcard type. That is, we generate this code -for `sF`: - - sF :: forall a (t :: MyProxy a). Sing t -> Sing (F t :: MyProxy a) - sF SMyProxy = - let sX :: Sing @_ LetX - sX = ... - -The presence of the wildcard type disables kind generalization, which allows -GHC's kind inference to deduce that the return kind of `LetX` should be `a`. -Now `sF` typechecks, and since we only use wildcards within visible kind -applications, we don't even have to force users to enable -PartialTypeSignatures. Hooray! - -Question: where should we put wildcard types when singling? One possible answer -is: put a wildcard in any type signature that gets generated when singling a -function that lacks a type signature. Unfortunately, this is a step too far. -This will break singling the `foldr` function: - - foldr :: (a -> b -> b) -> b -> [a] -> b - foldr k z = go - where - go [] = z - go (y:ys) = y `k` go ys - -If the type of `sGo` is given a wildcard, then it will fail to typecheck. This -is because `sGo` is polymorphically recursive, so disabling kind generalization -forces GHC to infer `sGo`'s type. Attempting to infer a polymorphically -recursive type, unsurprisingly, leads to failure. - -To avoid this sort of situation, where adopt a simple metric: if a function -lacks a type signature, only put @_ in its singled type signature if it has -zero arguments. This allows `sX` to typecheck without breaking things like -`sGo`. This metric is a bit conservative, however, since it means that this -small tweak to `x` still would not typecheck: - - f :: forall a. MyProxy a -> MyProxy a - f MyProxy = - let x () = let z :: MyProxy a - z = MyProxy in z - in x () - -We need not let perfect be the enemy of good, however. It is extremely -common for local definitions to have zero arguments, so it makes good sense -to optimize for that special case. In fact, this special treatment is the only -reason that `foo8` from the `T183` test case singles successfully, since -the as-patterns in `foo8` desugar to code very similar to the `f` example -above. --} - -singLetDecRHS :: Map Name DCxt -- the context of the type signature - -- (might not be known) - -> Name -> ALetDecRHS -> SgM DLetDec -singLetDecRHS cxts name ld_rhs = do - opts <- getOptions - bindContext (Map.findWithDefault [] name cxts) $ - case ld_rhs of - AValue exp -> - DValD (DVarP (singledValueName opts name)) <$> - singExp exp - AFunction _num_arrows clauses -> - DFunD (singledValueName opts name) <$> - mapM singClause clauses - -singClause :: ADClause -> SgM DClause -singClause (ADClause var_proms pats exp) = do - (sPats, sigPaExpsSigs) <- evalForPair $ mapM (singPat (Map.fromList var_proms)) pats - sBody <- singExp exp - return $ DClause sPats $ mkSigPaCaseE sigPaExpsSigs sBody - -singPat :: Map Name Name -- from term-level names to type-level names - -> ADPat - -> QWithAux SingDSigPaInfos SgM DPat -singPat var_proms = go - where - go :: ADPat -> QWithAux SingDSigPaInfos SgM DPat - go (ADLitP _lit) = - fail "Singling of literal patterns not yet supported" - go (ADVarP name) = do - opts <- getOptions - tyname <- case Map.lookup name var_proms of - Nothing -> - fail "Internal error: unknown variable when singling pattern" - Just tyname -> return tyname - pure $ DVarP (singledValueName opts name) - `DSigP` (singFamily `DAppT` DVarT tyname) - go (ADConP name tys pats) = do - opts <- getOptions - DConP (singledDataConName opts name) tys <$> mapM go pats - go (ADTildeP pat) = do - qReportWarning - "Lazy pattern converted into regular pattern during singleton generation." - go pat - go (ADBangP pat) = DBangP <$> go pat - go (ADSigP prom_pat pat ty) = do - pat' <- go pat - -- Normally, calling dPatToDExp would be dangerous, since it fails if the - -- supplied pattern contains any wildcard patterns. However, promotePat - -- (which produced the pattern we're passing into dPatToDExp) maintains - -- an invariant that any promoted pattern signatures will be free of - -- wildcard patterns in the underlying pattern. - -- See Note [Singling pattern signatures]. - addElement (dPatToDExp pat', DSigT prom_pat ty) - pure pat' - go ADWildP = pure DWildP - --- | If given a non-empty list of 'SingDSigPaInfos', construct a case expression --- that brings singleton equality constraints into scope via pattern-matching. --- See @Note [Singling pattern signatures]@. -mkSigPaCaseE :: SingDSigPaInfos -> DExp -> DExp -mkSigPaCaseE exps_with_sigs exp - | null exps_with_sigs = exp - | otherwise = - let (exps, sigs) = unzip exps_with_sigs - scrutinee = mkTupleDExp exps - pats = map (DSigP DWildP . DAppT (DConT singFamilyName)) sigs - in DCaseE scrutinee [DMatch (mkTupleDPat pats) exp] - --- Note [Annotate case return type] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- We're straining GHC's type inference here. One particular trouble area --- is determining the return type of a GADT pattern match. In general, GHC --- cannot infer return types of GADT pattern matches because the return type --- becomes "untouchable" in the case matches. See the OutsideIn paper. But, --- during singletonization, we *know* the return type. So, just add a type --- annotation. See #54. --- --- In particular, we add a type annotation in a somewhat unorthodox fashion. --- Instead of the usual `(x :: t)`, we use `id @t x`. See --- Note [The id hack; or, how singletons-th learned to stop worrying and avoid --- kind generalization] for an explanation of why we do this. - --- Note [Why error is so special] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Some of the transformations that happen before this point produce impossible --- case matches. We must be careful when processing these so as not to make --- an error GHC will complain about. When binding the case-match variables, we --- normally include an equality constraint saying that the scrutinee is equal --- to the matched pattern. But, we can't do this in inaccessible matches, because --- equality is bogus, and GHC (rightly) complains. However, we then have another --- problem, because GHC doesn't have enough information when type-checking the --- RHS of the inaccessible match to deem it type-safe. The solution: treat error --- as super-special, so that GHC doesn't look too hard at singletonized error --- calls. Specifically, DON'T do the applySing stuff. Just use sError, which --- has a custom type (Sing x -> a) anyway. - --- Note [Singling pattern signatures] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- We want to single a pattern signature, like so: --- --- f :: Maybe a -> a --- f (Just x :: Maybe a) = x --- --- Naïvely, one might expect this to single straightfowardly as: --- --- sF :: forall (z :: Maybe a). Sing z -> Sing (F z) --- sF (SJust sX :: Sing (Just x :: Maybe a)) = sX --- --- But the way GHC typechecks patterns prevents this from working, as GHC won't --- know that the type `z` is actually `Just x` until /after/ the entirety of --- the `SJust sX` pattern has been typechecked. (See Trac #12018 for an --- extended discussion on this topic.) --- --- To work around this design, we resort to a somewhat unsightly trick: --- immediately after matching on all the patterns, we perform a case on every --- pattern with a pattern signature, like so: --- --- sF :: forall (z :: Maybe a). Sing z -> Sing (F z) --- sF (SJust sX :: Sing z) --- = case (SJust sX :: Sing z) of --- (_ :: Sing (Just x :: Maybe a)) -> sX --- --- Now GHC accepts the fact that `z` is `Just x`, and all is well. In order --- to support this construction, the type of singPat is augmented with some --- extra information in the form of SingDSigPaInfos: --- --- type SingDSigPaInfos = [(DExp, DType)] --- --- Where the DExps corresponds to the expressions we case on just after the --- patterns (`SJust sX :: Sing x`, in the example above), and the DTypes --- correspond to the singled pattern signatures to use in the case alternative --- (`Sing (Just x :: Maybe a)` in the example above). singPat appends to the --- list of SingDSigPaInfos whenever it processes a DSigPa (pattern signature), --- and call sites can pass these SingDSigPaInfos to mkSigPaCaseE to construct a --- case expression like the one featured above. --- --- Some interesting consequences of this design: --- --- 1. We must promote DPats to ADPats, a variation of DPat where the annotated --- DSigPa counterpart, ADSigPa, stores the type that the original DPat was --- promoted to. This is necessary since promoting the type might have --- generated fresh variable names, so we need to be able to use the same --- names when singling. --- --- 2. Also when promoting a DSigPa to an ADSigPa, we remove any wildcards from --- the underlying pattern. To see why this is necessary, consider singling --- this example: --- --- g (Just _ :: Maybe a) = "hi" --- --- This must single to something like this: --- --- sG (SJust _ :: Sing z) --- = case (SJust _ :: Sing z) of --- (_ :: Sing (Just _ :: Maybe a)) -> "hi" --- --- But `SJust _` is not a valid expression, and since the minimal th-desugar --- AST lacks as-patterns, we can't replace it with something like --- `sG x@(SJust _ :: Sing z) = case x of ...`. But even if the th-desugar --- AST /did/ have as-patterns, we'd still be in trouble, as `Just _` isn't --- a valid type without the use of -XPartialTypeSignatures, which isn't a --- design we want to force upon others. --- --- We work around both issues by simply converting all wildcard patterns --- from the pattern that has a signature. That means our example becomes: --- --- sG (SJust sWild :: Sing z) --- = case (SJust sWild :: Sing z) of --- (_ :: Sing (Just wild :: Maybe a)) -> "hi" --- --- And now everything is hunky-dory. - -singExp :: ADExp -> SgM DExp - -- See Note [Why error is so special] -singExp (ADVarE err `ADAppE` arg) - | err == errorName = do opts <- getOptions - DAppE (DVarE (singledValueName opts err)) <$> - singExp arg -singExp (ADVarE name) = lookupVarE name -singExp (ADConE name) = lookupConE name -singExp (ADLitE lit) = singLit lit -singExp (ADAppE e1 e2) = do - e1' <- singExp e1 - e2' <- singExp e2 - -- `applySing undefined x` kills type inference, because GHC can't figure - -- out the type of `undefined`. So we don't emit `applySing` there. - if isException e1' - then return $ e1' `DAppE` e2' - else return $ (DVarE applySingName) `DAppE` e1' `DAppE` e2' -singExp (ADLamE ty_names prom_lam names exp) = do - opts <- getOptions - let sNames = map (singledValueName opts) names - exp' <- singExp exp - -- we need to bind the type variables... but DLamE doesn't allow SigT patterns. - -- So: build a case - let caseExp = DCaseE (mkTupleDExp (map DVarE sNames)) - [DMatch (mkTupleDPat - (map ((DWildP `DSigP`) . - (singFamily `DAppT`) . - DVarT) ty_names)) exp'] - return $ wrapSingFun (length names) prom_lam $ DLamE sNames caseExp -singExp (ADCaseE exp matches ret_ty) = - -- See Note [Annotate case return type] and - -- Note [The id hack; or, how singletons-th learned to stop worrying and - -- avoid kind generalization] - DAppE (DAppTypeE (DVarE 'id) - (singFamily `DAppT` ret_ty)) - <$> (DCaseE <$> singExp exp <*> mapM singMatch matches) -singExp (ADLetE env exp) = do - -- We intentionally discard the SingI instances for exp's defunctionalization - -- symbols, as we also do not generate the declarations for the - -- defunctionalization symbols in the first place during promotion. - (let_decs, _, exp') <- singLetDecEnv env $ singExp exp - pure $ DLetE let_decs exp' -singExp (ADSigE prom_exp exp ty) = do - exp' <- singExp exp - pure $ DSigE exp' $ DConT singFamilyName `DAppT` DSigT prom_exp ty - --- See Note [DerivedDecl] in Data.Singletons.TH.Syntax -singDerivedEqDecs :: DerivedEqDecl -> SgM [DDec] -singDerivedEqDecs (DerivedDecl { ded_mb_cxt = mb_ctxt - , ded_type = ty - , ded_type_tycon = ty_tycon - , ded_decl = DataDecl _ _ _ cons }) = do - (scons, _) <- singM [] $ mapM (singCtor ty_tycon) cons - mb_sctxt <- mapM (mapM singPred) mb_ctxt - kind <- promoteType ty - -- Beware! The user might have specified an instance context like this: - -- - -- deriving instance Eq a => Eq (T a Int) - -- - -- When we single the context, it will become (SEq a). But we do *not* want - -- this for the SDecide instance! The simplest solution is to simply replace - -- all occurrences of SEq with SDecide in the context. - mb_sctxtDecide <- traverse (traverse sEqToSDecide) mb_sctxt - sDecideInst <- mkDecideInstance mb_sctxtDecide kind cons scons - testInsts <- traverse (mkTestInstance mb_sctxtDecide kind ty_tycon cons) - [TestEquality, TestCoercion] - return (sDecideInst:testInsts) - --- Walk a DPred, replacing all occurrences of SEq with SDecide. -sEqToSDecide :: OptionsMonad q => DPred -> q DPred -sEqToSDecide p = do - opts <- getOptions - pure $ modifyConNameDType (\n -> - if n == singledClassName opts eqName - then sDecideClassName - else n) p - --- See Note [DerivedDecl] in Data.Singletons.TH.Syntax -singDerivedShowDecs :: DerivedShowDecl -> SgM [DDec] -singDerivedShowDecs (DerivedDecl { ded_mb_cxt = mb_cxt - , ded_type = ty - , ded_type_tycon = ty_tycon - , ded_decl = DataDecl _ _ _ cons }) = do - opts <- getOptions - z <- qNewName "z" - -- Generate a Show instance for a singleton type, like this: - -- - -- deriving instance (ShowSing a, ShowSing b) => Sing (SEither (z :: Either a b)) - -- - -- Be careful: we want to generate an instance context that uses ShowSing, - -- not SShow. - show_cxt <- inferConstraintsDef (fmap mkShowSingContext mb_cxt) - (DConT showSingName) - ty cons - ki <- promoteType ty - let sty_tycon = singledDataTypeName opts ty_tycon - show_inst = DStandaloneDerivD Nothing Nothing show_cxt - (DConT showName `DAppT` (DConT sty_tycon `DAppT` DSigT (DVarT z) ki)) - pure [show_inst] - -isException :: DExp -> Bool -isException (DVarE n) = nameBase n == "sUndefined" -isException (DConE {}) = False -isException (DLitE {}) = False -isException (DAppE (DVarE fun) _) | nameBase fun == "sError" = True -isException (DAppE fun _) = isException fun -isException (DAppTypeE e _) = isException e -isException (DLamE _ _) = False -isException (DCaseE e _) = isException e -isException (DLetE _ e) = isException e -isException (DSigE e _) = isException e -isException (DStaticE e) = isException e - -singMatch :: ADMatch -> SgM DMatch -singMatch (ADMatch var_proms pat exp) = do - (sPat, sigPaExpsSigs) <- evalForPair $ singPat (Map.fromList var_proms) pat - sExp <- singExp exp - return $ DMatch sPat $ mkSigPaCaseE sigPaExpsSigs sExp - -singLit :: Lit -> SgM DExp -singLit (IntegerL n) = do - opts <- getOptions - if n >= 0 - then return $ - DVarE (singledValueName opts fromIntegerName) `DAppE` - (DVarE singMethName `DSigE` - (singFamily `DAppT` DLitT (NumTyLit n))) - else do sLit <- singLit (IntegerL (-n)) - return $ DVarE (singledValueName opts negateName) `DAppE` sLit -singLit (StringL str) = do - opts <- getOptions - let sing_str_lit = DVarE singMethName `DSigE` - (singFamily `DAppT` DLitT (StrTyLit str)) - os_enabled <- qIsExtEnabled LangExt.OverloadedStrings - pure $ if os_enabled - then DVarE (singledValueName opts fromStringName) `DAppE` sing_str_lit - else sing_str_lit -singLit (CharL c) = - return $ DVarE singMethName `DSigE` (singFamily `DAppT` DLitT (CharTyLit c)) -singLit lit = - fail ("Only string, natural number, and character literals can be singled: " ++ show lit) - -{- -Note [The id hack; or, how singletons-th learned to stop worrying and avoid kind generalization] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC 8.8 was a time of great change. In particular, 8.8 debuted a fix for -Trac #15141 (decideKindGeneralisationPlan is too complicated). To fix this, a -wily GHC developer—who shall remain unnamed, but whose username rhymes with -schmoldfire—decided to make decideKindGeneralisationPlan less complicated by, -well, removing the whole thing. One consequence of this is that local -definitions are now kind-generalized (whereas they would not have been -previously). - -While schmoldfire had the noblest of intentions when authoring his fix, he -unintentionally made life much harder for singletons-th. Why? Consider the -following program: - - class Foo a where - bar :: a -> (a -> b) -> b - baz :: a - - quux :: Foo a => a -> a - quux x = x `bar` \_ -> baz - -When singled, this program will turn into something like this: - - type family Quux (x :: a) :: a where - Quux x = Bar x (LambdaSym1 x) - - sQuux :: forall a (x :: a). SFoo a => Sing x -> Sing (Quux x :: a) - sQuux (sX :: Sing x) - = sBar sX - ((singFun1 @(LambdaSym1 x)) - (\ sArg - -> case sArg of { - (_ :: Sing arg) - -> (case sArg of { _ -> sBaz }) :: - Sing (Case x arg arg) })) - - type family Case x arg t where - Case x arg _ = Baz - type family Lambda x t where - Lambda x arg = Case x arg arg - data LambdaSym1 x t - type instance Apply (LambdaSym1 x) t = Lambda x t - -The high-level bit is the explicit `Sing (Case x arg arg)` signature. Question: -what is the kind of `Case x arg arg`? The answer depends on whether local -definitions are kind-generalized or not! - -1. If local definitions are *not* kind-generalized (i.e., the status quo before - GHC 8.8), then `Case x arg arg :: a`. -2. If local definitions *are* kind-generalized (i.e., the status quo in GHC 8.8 - and later), then `Case x arg arg :: k` for some fresh kind variable `k`. - -Unfortunately, the kind of `Case x arg arg` *must* be `a` in order for `sQuux` -to type-check. This means that the code above suddenly stopped working in GHC -8.8. What's more, we can't just remove these explicit signatures, as there is -code elsewhere in `singletons-th` that crucially relies on them to guide type -inference along (e.g., `sShowParen` in `Text.Show.Singletons`). - -Luckily, there is an ingenious hack that lets us the benefits of explicit -signatures without the pain of kind generalization: our old friend, the `id` -function. The plan is as follows: instead of generating this code: - - (case sArg of ...) :: Sing (Case x arg arg) - -We instead generate this code: - - id @(Sing (Case x arg arg)) (case sArg of ...) - -That's it! This works because visible type arguments in terms do not get kind- -generalized, unlike top-level or local signatures. Now `Case x arg arg`'s kind -is not generalized, and all is well. We dub this: the `id` hack. - -One might wonder: will we need the `id` hack around forever? Perhaps not. While -GHC 8.8 removed the decideKindGeneralisationPlan function, there have been -rumblings that a future version of GHC may bring it back (in a limited form). -If this happens, it is possibly that GHC's attitude towards kind-generalizing -local definitions may change *again*, which could conceivably render the `id` -hack unnecessary. This is all speculation, of course, so all we can do now is -wait and revisit this design at a later date. --} +{-# LANGUAGE TemplateHaskellQuotes #-}++{- Data/Singletons/TH/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-th package.+-}++module Data.Singletons.TH.Single where++import Prelude hiding ( exp )+import Language.Haskell.TH hiding ( cxt )+import Language.Haskell.TH.Syntax (NameSpace(..), Quasi(..))+import Data.Singletons.TH.Deriving.Bounded+import Data.Singletons.TH.Deriving.Enum+import Data.Singletons.TH.Deriving.Eq+import Data.Singletons.TH.Deriving.Infer+import Data.Singletons.TH.Deriving.Ord+import Data.Singletons.TH.Deriving.Show+import Data.Singletons.TH.Deriving.Util+import Data.Singletons.TH.Names+import Data.Singletons.TH.Options+import Data.Singletons.TH.Partition+import Data.Singletons.TH.Promote+import Data.Singletons.TH.Promote.Defun+import Data.Singletons.TH.Promote.Monad ( promoteM )+import Data.Singletons.TH.Promote.Type+import Data.Singletons.TH.Single.Data+import Data.Singletons.TH.Single.Decide+import Data.Singletons.TH.Single.Defun+import Data.Singletons.TH.Single.Fixity+import Data.Singletons.TH.Single.Monad+import Data.Singletons.TH.Single.Ord+import Data.Singletons.TH.Single.Type+import Data.Singletons.TH.Syntax+import Data.Singletons.TH.Util+import Language.Haskell.TH.Desugar+import qualified Language.Haskell.TH.Desugar.OMap.Strict as OMap+import Language.Haskell.TH.Desugar.OMap.Strict (OMap)+import qualified Data.Map.Strict as Map+import Data.Map.Strict ( Map )+import Data.Maybe+import qualified Data.Set as Set+import Control.Monad+import Control.Monad.Trans.Class+import Data.List (unzip6, zipWith4)+import qualified GHC.LanguageExtensions.Type as LangExt++{-+How singletons-th works+~~~~~~~~~~~~~~~~~~~~~~~++Singling, on the surface, doesn't seem all that complicated. Promote the type,+and singletonize all the terms. That's essentially what was done singletons < 1.0.+But, now we want to deal with higher-order singletons. So, things are a little+more complicated.++The way to understand all of this is that *every* variable maps to something+of type (Sing t), for an appropriately-kinded t. This includes functions, which+use the "SLambda" instance of Sing. To apply singleton functions, we use the+applySing function.++That, in and of itself, wouldn't be too hard, but it's really annoying from+the user standpoint. After dutifully singling `map`, a user doesn't want to+have to use two `applySing`s to actually use it. So, any let-bound identifier+is eta-expanded so that the singled type has the same number of arrows as+the original type. (If there is no original type signature, then it has as+many arrows as the original had patterns.) Then, we store a use of one of the+singFunX functions in the SgM environment so that every use of a let-bound+identifier has a proper type (Sing t).++It would be consistent to avoid this eta-expansion for local lets (as opposed+to top-level lets), but that seemed like more bother than it was worth. It+may also be possible to be cleverer about nested eta-expansions and contractions,+but that also seemed not to be worth it. Though I haven't tested it, my hope+is that the eta-expansions and contractions have no runtime effect, especially+because SLambda is a *newtype* instance, not a *data* instance.++Note that to maintain the desired invariant, we must also be careful to eta-+contract constructors. This is the point of buildDataLets.+-}++-- | Generate singled definitions for each of the provided type-level+-- declaration 'Name's. For example, the singletons-th package itself uses+--+-- > $(genSingletons [''Bool, ''Maybe, ''Either, ''[]])+--+-- to generate singletons for Prelude types.+genSingletons :: OptionsMonad q => [Name] -> q [Dec]+genSingletons names = do+ opts <- getOptions+ -- See Note [Disable genQuotedDecs in genPromotions and genSingletons]+ -- in D.S.TH.Promote+ withOptions opts{genQuotedDecs = False} $ do+ checkForRep names+ ddecs <- concatMapM (singInfo <=< dsInfo <=< reifyWithLocals) names+ return $ decsToTH ddecs++-- | Make promoted and singled versions of all declarations given, retaining+-- the original declarations. See the+-- @<https://github.com/goldfirere/singletons/blob/master/README.md README>@+-- for further explanation.+singletons :: OptionsMonad q => q [Dec] -> q [Dec]+singletons qdecs = do+ opts <- getOptions+ withOptions opts{genQuotedDecs = True} $ singletons' $ lift qdecs++-- | Make promoted and singled versions of all declarations given, discarding+-- the original declarations. Note that a singleton based on a datatype needs+-- the original datatype, so this will fail if it sees any datatype declarations.+-- Classes, instances, and functions are all fine.+singletonsOnly :: OptionsMonad q => q [Dec] -> q [Dec]+singletonsOnly qdecs = do+ opts <- getOptions+ withOptions opts{genQuotedDecs = False} $ singletons' $ lift qdecs++-- The workhorse for 'singletons' and 'singletonsOnly'. The difference between+-- the two functions is whether 'genQuotedDecs' is set to 'True' or 'False'.+singletons' :: OptionsMonad q => q [Dec] -> q [Dec]+singletons' qdecs = do+ opts <- getOptions+ decs <- qdecs+ ddecs <- withLocalDeclarations decs $ dsDecs decs+ singDecs <- singTopLevelDecs decs ddecs+ let origDecs | genQuotedDecs opts = decs+ | otherwise = []+ return $ origDecs ++ decsToTH singDecs++-- | Create instances of 'SEq' for the given types+singEqInstances :: OptionsMonad q => [Name] -> q [Dec]+singEqInstances = concatMapM singEqInstance++-- | Create instance of 'SEq' for the given type+singEqInstance :: OptionsMonad q => Name -> q [Dec]+singEqInstance = singInstance mkEqInstance "Eq"++-- | Create instances of 'SDecide', 'Eq', 'TestEquality', and 'TestCoercion' for+-- each type in the list.+singDecideInstances :: OptionsMonad q => [Name] -> q [Dec]+singDecideInstances = concatMapM singDecideInstance++-- | Create instances of 'SDecide', 'Eq', 'TestEquality', and 'TestCoercion' for+-- the given type.+singDecideInstance :: OptionsMonad q => Name -> q [Dec]+singDecideInstance name = do+ (_df, tvbs, cons) <- getDataD ("I cannot make an instance of SDecide for it.") name+ dtvbs <- mapM dsTvbVis tvbs+ let data_ty = foldTypeTvbs (DConT name) dtvbs+ dcons <- concatMapM (dsCon dtvbs data_ty) cons+ (scons, _) <- singM [] $ mapM (singCtor name) dcons+ sDecideInstance <- mkDecideInstance Nothing data_ty dcons scons+ eqInstance <- mkEqInstanceForSingleton data_ty name+ testInstances <- traverse (mkTestInstance Nothing data_ty name dcons)+ [TestEquality, TestCoercion]+ return $ decsToTH (sDecideInstance:eqInstance:testInstances)++-- | Create instances of 'SOrd' for the given types+singOrdInstances :: OptionsMonad q => [Name] -> q [Dec]+singOrdInstances = concatMapM singOrdInstance++-- | Create instance of 'SOrd' for the given type+singOrdInstance :: OptionsMonad q => Name -> q [Dec]+singOrdInstance = singInstance mkOrdInstance "Ord"++-- | Create instances of 'SBounded' for the given types+singBoundedInstances :: OptionsMonad q => [Name] -> q [Dec]+singBoundedInstances = concatMapM singBoundedInstance++-- | Create instance of 'SBounded' for the given type+singBoundedInstance :: OptionsMonad q => Name -> q [Dec]+singBoundedInstance = singInstance mkBoundedInstance "Bounded"++-- | Create instances of 'SEnum' for the given types+singEnumInstances :: OptionsMonad q => [Name] -> q [Dec]+singEnumInstances = concatMapM singEnumInstance++-- | Create instance of 'SEnum' for the given type+singEnumInstance :: OptionsMonad q => Name -> q [Dec]+singEnumInstance = singInstance mkEnumInstance "Enum"++-- | Create instance of 'SShow' for the given type+--+-- (Not to be confused with 'showShowInstance'.)+singShowInstance :: OptionsMonad q => Name -> q [Dec]+singShowInstance = singInstance mkShowInstance "Show"++-- | Create instances of 'SShow' for the given types+--+-- (Not to be confused with 'showSingInstances'.)+singShowInstances :: OptionsMonad q => [Name] -> q [Dec]+singShowInstances = concatMapM singShowInstance++-- | Create instance of 'Show' for the given singleton type+--+-- (Not to be confused with 'singShowInstance'.)+showSingInstance :: OptionsMonad q => Name -> q [Dec]+showSingInstance name = do+ (df, tvbs, cons) <- getDataD ("I cannot make an instance of Show for it.") name+ dtvbs <- mapM dsTvbVis tvbs+ let data_ty = foldTypeTvbs (DConT name) dtvbs+ dcons <- concatMapM (dsCon dtvbs data_ty) cons+ let tyvars = map (DVarT . extractTvbName) dtvbs+ kind = foldType (DConT name) tyvars+ data_decl = DataDecl df name dtvbs dcons+ deriv_show_decl = DerivedDecl { ded_mb_cxt = Nothing+ , ded_type = kind+ , ded_type_tycon = name+ , ded_decl = data_decl }+ (show_insts, _) <- singM [] $ singDerivedShowDecs deriv_show_decl+ pure $ decsToTH show_insts++-- | Create instances of 'Show' for the given singleton types+--+-- (Not to be confused with 'singShowInstances'.)+showSingInstances :: OptionsMonad q => [Name] -> q [Dec]+showSingInstances = concatMapM showSingInstance++-- | Create an instance for @'SingI' TyCon{N}@, where @N@ is the positive+-- number provided as an argument.+--+-- Note that the generated code requires the use of the @QuantifiedConstraints@+-- language extension.+singITyConInstances :: DsMonad q => [Int] -> q [Dec]+singITyConInstances = mapM singITyConInstance++-- | Create an instance for @'SingI' TyCon{N}@, where @N@ is the positive+-- number provided as an argument.+--+-- Note that the generated code requires the use of the @QuantifiedConstraints@+-- language extension.+singITyConInstance :: DsMonad q => Int -> q Dec+singITyConInstance n+ | n <= 0+ = fail $ "Argument must be a positive number (given " ++ show n ++ ")"+ | otherwise+ = do as <- replicateM n (qNewName "a")+ ks <- replicateM n (qNewName "k")+ k_last <- qNewName "k_last"+ f <- qNewName "f"+ x <- qNewName "x"+ let k_penult = last ks+ k_fun = ravelVanillaDType [] [] (map DVarT ks) (DVarT k_last)+ f_ty = DVarT f+ a_tys = map DVarT as+ mk_fun arrow t1 t2 = arrow `DAppT` t1 `DAppT` t2+ matchable_apply_fun = mk_fun DArrowT (DVarT k_penult) (DVarT k_last)+ unmatchable_apply_fun = mk_fun (DConT tyFunArrowName) (DVarT k_penult) (DVarT k_last)+ ctxt = [ DForallT (DForallInvis (map (`DPlainTV` SpecifiedSpec) as)) $+ DConstrainedT (map (DAppT (DConT singIName)) a_tys)+ (DConT singIName `DAppT` foldType f_ty a_tys)+ , DConT equalityName+ `DAppT` (DConT applyTyConName `DSigT`+ mk_fun DArrowT matchable_apply_fun unmatchable_apply_fun)+ `DAppT` DConT applyTyConAux1Name+ ]+ pure $ decToTH+ $ DInstanceD+ Nothing Nothing ctxt+ (DConT singIName `DAppT` (DConT (mkTyConName n) `DAppT` (f_ty `DSigT` k_fun)))+ [DLetDec $ DFunD singMethName+ [DClause [] $+ wrapSingFun 1 DWildCardT $+ DLamE [x] $+ DVarE withSingIName `DAppE` DVarE x+ `DAppE` DVarE singMethName]]++singInstance :: OptionsMonad q => DerivDesc q -> String -> Name -> q [Dec]+singInstance mk_inst inst_name name = do+ (df, tvbs, cons) <- getDataD ("I cannot make an instance of " ++ inst_name+ ++ " for it.") name+ dtvbs <- mapM dsTvbVis tvbs+ let data_ty = foldTypeTvbs (DConT name) dtvbs+ dcons <- concatMapM (dsCon dtvbs data_ty) cons+ let data_decl = DataDecl df name dtvbs dcons+ raw_inst <- mk_inst Nothing data_ty data_decl+ (a_inst, decs) <- promoteM [] $+ promoteInstanceDec OMap.empty Map.empty raw_inst+ decs' <- singDecsM [] $ (:[]) <$> singInstD a_inst+ return $ decsToTH (decs ++ decs')++singInfo :: OptionsMonad q => DInfo -> q [DDec]+singInfo (DTyConI dec _) =+ singTopLevelDecs [] [dec]+singInfo (DPrimTyConI _name _numArgs _unlifted) =+ fail "Singling of primitive type constructors not supported"+singInfo (DVarI _name _ty _mdec) =+ fail "Singling of value info not supported"+singInfo (DTyVarI _name _ty) =+ fail "Singling of type variable info not supported"+singInfo (DPatSynI {}) =+ fail "Singling of pattern synonym info not supported"++singTopLevelDecs :: OptionsMonad q => [Dec] -> [DDec] -> q [DDec]+singTopLevelDecs locals raw_decls = withLocalDeclarations locals $ do+ decls <- expand raw_decls -- expand type synonyms+ PDecs { pd_let_decs = letDecls+ , pd_class_decs = classes+ , pd_instance_decs = insts+ , pd_data_decs = datas+ , pd_ty_syn_decs = ty_syns+ , pd_open_type_family_decs = o_tyfams+ , pd_closed_type_family_decs = c_tyfams+ , pd_derived_eq_decs = derivedEqDecs+ , pd_derived_ord_decs = derivedOrdDecs+ , pd_derived_show_decs = derivedShowDecs } <- partitionDecs decls++ ((letDecEnv, classes', insts'), promDecls) <- promoteM locals $ do+ defunTopLevelTypeDecls ty_syns c_tyfams o_tyfams+ recSelLetDecls <- promoteDataDecs datas+ (_, letDecEnv) <- promoteLetDecs Nothing $ recSelLetDecls ++ letDecls+ classes' <- mapM promoteClassDec classes+ let meth_sigs = foldMap (lde_types . cd_lde) classes+ cls_tvbs_map = Map.fromList $ map (\cd -> (cd_name cd, cd_tvbs cd)) classes+ insts' <- mapM (promoteInstanceDec meth_sigs cls_tvbs_map) insts+ return (letDecEnv, classes', insts')++ singDecsM locals $ do+ dataLetBinds <- concatMapM buildDataLets datas+ methLetBinds <- concatMapM buildMethLets classes+ let letBinds = dataLetBinds ++ methLetBinds+ (newLetDecls, singIDefunDecls, newDecls)+ <- bindLets letBinds $+ singLetDecEnv letDecEnv $ do+ newDataDecls <- concatMapM singDataD datas+ newClassDecls <- mapM singClassD classes'+ newInstDecls <- mapM singInstD insts'+ newDerivedEqDecs <- concatMapM singDerivedEqDecs derivedEqDecs+ newDerivedOrdDecs <- concatMapM singDerivedOrdDecs derivedOrdDecs+ newDerivedShowDecs <- concatMapM singDerivedShowDecs derivedShowDecs+ return $ newDataDecls ++ newClassDecls+ ++ newInstDecls+ ++ newDerivedEqDecs+ ++ newDerivedOrdDecs+ ++ newDerivedShowDecs+ return $ promDecls ++ (map DLetDec newLetDecls) ++ singIDefunDecls ++ newDecls++-- see comment at top of file+buildDataLets :: OptionsMonad q => DataDecl -> q [(Name, DExp)]+buildDataLets (DataDecl _df _name _tvbs cons) = do+ opts <- getOptions+ fld_sels <- qIsExtEnabled LangExt.FieldSelectors+ pure $ concatMap (con_num_args opts fld_sels) cons+ where+ con_num_args :: Options -> Bool -> DCon -> [(Name, DExp)]+ con_num_args opts fld_sels (DCon _tvbs _cxt name fields _rty) =+ (name, wrapSingFun (length (tysOfConFields fields))+ (DConT $ defunctionalizedName0 opts name)+ (DConE $ singledDataConName opts name))+ : rec_selectors opts fld_sels fields++ rec_selectors :: Options -> Bool -> DConFields -> [(Name, DExp)]+ rec_selectors opts fld_sels con+ | fld_sels+ = case con of+ DNormalC {} -> []+ DRecC fields ->+ let names = map fstOf3 fields in+ [ (name, wrapSingFun 1 (DConT $ defunctionalizedName0 opts name)+ (DVarE $ singledValueName opts name))+ | name <- names ]++ | otherwise+ = []++-- see comment at top of file+buildMethLets :: OptionsMonad q => UClassDecl -> q [(Name, DExp)]+buildMethLets (ClassDecl { cd_lde = LetDecEnv { lde_types = meth_sigs } }) = do+ opts <- getOptions+ pure $ map (mk_bind opts) (OMap.assocs meth_sigs)+ where+ mk_bind opts (meth_name, meth_ty) =+ ( meth_name+ , wrapSingFun (countArgs meth_ty) (DConT $ defunctionalizedName0 opts meth_name)+ (DVarE $ singledValueName opts meth_name) )++singClassD :: AClassDecl -> SgM DDec+singClassD (ClassDecl { cd_cxt = cls_cxt+ , cd_name = cls_name+ , cd_tvbs = cls_tvbs+ , cd_fds = cls_fundeps+ , cd_lde = LetDecEnv { lde_defns = default_defns+ , lde_types = meth_sigs+ , lde_infix = fixities+ , lde_proms = promoted_defaults } }) =+ bindContext [foldTypeTvbs (DConT cls_name) cls_tvbs] $ do+ opts <- getOptions+ mb_cls_sak <- dsReifyType cls_name+ let sing_cls_name = singledClassName opts cls_name+ mb_sing_cls_sak = fmap (DKiSigD sing_cls_name) mb_cls_sak+ cls_infix_decls <- singReifiedInfixDecls $ cls_name:meth_names+ (sing_sigs, _, tyvar_names, cxts, res_kis, singIDefunss)+ <- unzip6 <$> zipWithM (singTySig no_meth_defns meth_sigs)+ meth_names+ (map (DConT . defunctionalizedName0 opts) meth_names)+ emitDecs $ maybeToList mb_sing_cls_sak ++ cls_infix_decls ++ concat singIDefunss+ let default_sigs = catMaybes $+ zipWith4 (mk_default_sig opts) meth_names sing_sigs+ tyvar_names res_kis+ sing_meths <- mapM (uncurry (singLetDecRHS (Map.fromList cxts)))+ (OMap.assocs default_defns)+ fixities' <- mapMaybeM (uncurry singInfixDecl) $ OMap.assocs fixities+ cls_cxt' <- mapM singPred cls_cxt+ return $ DClassD cls_cxt'+ sing_cls_name+ cls_tvbs+ cls_fundeps -- they are fine without modification+ (map DLetDec (sing_sigs ++ sing_meths ++ fixities') ++ default_sigs)+ where+ no_meth_defns = error "Internal error: can't find declared method type"+ meth_names = map fst $ OMap.assocs meth_sigs++ mk_default_sig :: Options -> Name -> DLetDec -> [Name] -> Maybe DType -> Maybe DDec+ mk_default_sig opts meth_name (DSigD s_name sty) bound_kvs (Just res_ki) =+ DDefaultSigD s_name <$> add_constraints opts meth_name sty bound_kvs res_ki+ mk_default_sig _ _ _ _ _ = error "Internal error: a singled signature isn't a signature."++ add_constraints :: Options -> Name -> DType -> [Name] -> DType -> Maybe DType+ -- We must look through `... :: Type` kind annotations, which can be added+ -- when singling type signatures lacking explicit `forall`s.+ -- See Note [Preserve the order of type variables during singling]+ -- (wrinkle 1) in D.S.TH.Single.Type.+ add_constraints opts meth_name (DSigT sty ski) bound_kvs res_ki = do+ sty' <- add_constraints opts meth_name sty bound_kvs res_ki+ pure $ DSigT sty' ski+ add_constraints opts meth_name sty bound_kvs res_ki = do+ (tvbs, cxt, args, res) <- unravelVanillaDType sty+ prom_dflt <- OMap.lookup meth_name promoted_defaults++ -- Filter out explicitly bound kind variables. Otherwise, if you had+ -- the following class (#312):+ --+ -- class Foo a where+ -- bar :: a -> b -> b+ -- bar _ x = x+ --+ -- Then it would be singled to:+ --+ -- class SFoo a where+ -- sBar :: forall b (x :: a) (y :: b). Sing x -> Sing y -> Sing (sBar x y)+ -- default :: forall b (x :: a) (y :: b).+ -- (Bar b x y) ~ (BarDefault b x y) => ...+ --+ -- Which applies Bar/BarDefault to b, which shouldn't happen.+ let tvs = map tvbToType $+ filter (\tvb -> extractTvbName tvb `Set.member` bound_kv_set) tvbs+ prom_meth = DConT $ defunctionalizedName0 opts meth_name+ default_pred = foldType (DConT equalityName)+ -- NB: Need the res_ki here to prevent ambiguous+ -- kinds in result-inferred default methods.+ -- See #175+ [ foldApply prom_meth tvs `DSigT` res_ki+ , foldApply prom_dflt tvs ]+ return $ ravelVanillaDType tvbs (default_pred : cxt) args res+ where+ bound_kv_set = Set.fromList bound_kvs++singInstD :: AInstDecl -> SgM DDec+singInstD (InstDecl { id_cxt = cxt, id_name = inst_name, id_arg_tys = inst_tys+ , id_sigs = inst_sigs, id_meths = ann_meths }) = do+ opts <- getOptions+ let s_inst_name = singledClassName opts inst_name+ bindContext cxt $ do+ cxt' <- mapM singPred cxt+ inst_kis <- mapM promoteType inst_tys+ meths <- concatMapM (uncurry sing_meth) ann_meths+ return (DInstanceD Nothing+ Nothing+ cxt'+ (foldl DAppT (DConT s_inst_name) inst_kis)+ meths)++ where+ sing_meth :: Name -> ALetDecRHS -> SgM [DDec]+ sing_meth name rhs = do+ opts <- getOptions+ mb_s_info <- dsReify (singledValueName opts name)+ inst_kis <- mapM promoteType inst_tys+ let mk_subst cls_tvbs = Map.fromList $ zip (map extractTvbName vis_cls_tvbs) inst_kis+ where+ -- This is a half-hearted attempt to address the underlying problem+ -- in #358, where we can sometimes have more class type variables+ -- (due to implicit kind arguments) than class arguments. This just+ -- ensures that the explicit type variables are properly mapped+ -- to the class arguments, leaving the implicit kind variables+ -- unmapped. That could potentially cause *other* problems, but+ -- those are perhaps best avoided by using InstanceSigs. At the+ -- very least, this workaround will make error messages slightly+ -- less confusing.+ vis_cls_tvbs = drop (length cls_tvbs - length inst_kis) cls_tvbs++ sing_meth_ty :: DType -> SgM DType+ sing_meth_ty inner_ty = do+ -- Make sure to expand through type synonyms here! Not doing so+ -- resulted in #167.+ raw_ty <- expand inner_ty+ (s_ty, _num_args, _tyvar_names, _ctxt, _arg_kis, _res_ki)+ <- singType (DConT $ defunctionalizedName0 opts name) raw_ty+ pure s_ty++ s_ty <- case OMap.lookup name inst_sigs of+ Just inst_sig ->+ -- We have an InstanceSig, so just single that type.+ sing_meth_ty inst_sig+ Nothing -> case mb_s_info of+ -- We don't have an InstanceSig, so we must compute the type to use+ -- in the singled instance ourselves through reification.+ Just (DVarI _ (DForallT (DForallInvis cls_tvbs) (DConstrainedT _cls_pred s_ty)) _) ->+ pure $ substType (mk_subst cls_tvbs) s_ty+ _ -> do+ mb_info <- dsReify name+ case mb_info of+ Just (DVarI _ (DForallT (DForallInvis cls_tvbs)+ (DConstrainedT _cls_pred inner_ty)) _) -> do+ s_ty <- sing_meth_ty inner_ty+ pure $ substType (mk_subst cls_tvbs) s_ty+ _ -> fail $ "Cannot find type of method " ++ show name++ meth' <- singLetDecRHS+ Map.empty -- Because we are singling an instance declaration,+ -- we aren't generating defunctionalization symbols+ -- for the class methods, and hence we aren't+ -- generating any SingI instances. Therefore, we+ -- don't need to include anything in this Map.+ name rhs+ return $ map DLetDec [DSigD (singledValueName opts name) s_ty, meth']++singLetDecEnv :: ALetDecEnv+ -> SgM a+ -> SgM ([DLetDec], [DDec], a)+ -- Return:+ --+ -- 1. The singled let-decs+ -- 2. SingI instances for any defunctionalization symbols+ -- (see Data.Singletons.TH.Single.Defun)+ -- 3. The result of running the `SgM a` action+singLetDecEnv (LetDecEnv { lde_defns = defns+ , lde_types = types+ , lde_infix = infix_decls+ , lde_proms = proms })+ thing_inside = do+ let prom_list = OMap.assocs proms+ (typeSigs, letBinds, _tyvarNames, cxts, _res_kis, singIDefunss)+ <- unzip6 <$> mapM (uncurry (singTySig defns types)) prom_list+ infix_decls' <- mapMaybeM (uncurry singInfixDecl) $ OMap.assocs infix_decls+ bindLets letBinds $ do+ let_decs <- mapM (uncurry (singLetDecRHS (Map.fromList cxts)))+ (OMap.assocs defns)+ thing <- thing_inside+ return (infix_decls' ++ typeSigs ++ let_decs, concat singIDefunss, thing)++singTySig :: OMap Name ALetDecRHS -- definitions+ -> OMap Name DType -- type signatures+ -> 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] -- the scoped tyvar names in the tysig+ , (Name, DCxt) -- the context of the type signature+ , Maybe DKind -- the result kind in the tysig+ , [DDec] -- SingI instances for defun symbols+ )+singTySig defns types name prom_ty = do+ opts <- getOptions+ let sName = singledValueName opts name+ case OMap.lookup name types of+ Nothing -> do+ num_args <- guess_num_args+ (sty, tyvar_names) <- mk_sing_ty num_args+ singIDefuns <- singDefuns name VarName []+ (map (const Nothing) tyvar_names) Nothing+ return ( DSigD sName sty+ , (name, wrapSingFun num_args prom_ty (DVarE sName))+ , tyvar_names+ , (name, [])+ , Nothing+ , singIDefuns )+ Just ty -> do+ (sty, num_args, tyvar_names, ctxt, arg_kis, res_ki)+ <- singType prom_ty ty+ bound_cxt <- askContext+ singIDefuns <- singDefuns name VarName (bound_cxt ++ ctxt)+ (map Just arg_kis) (Just res_ki)+ return ( DSigD sName sty+ , (name, wrapSingFun num_args prom_ty (DVarE sName))+ , tyvar_names+ , (name, ctxt)+ , Just res_ki+ , singIDefuns )+ where+ guess_num_args :: SgM Int+ guess_num_args =+ case OMap.lookup name defns of+ Nothing -> fail "Internal error: promotion known for something not let-bound."+ Just (AValue _) -> return 0+ 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")+ -- If there are no arguments, use `Sing @_` instead of `Sing`.+ -- See Note [Disable kind generalization for local functions if possible]+ let sing_w_wildcard | n == 0 = singFamily `DAppKindT` DWildCardT+ | otherwise = singFamily+ return ( ravelVanillaDType+ (map (`DPlainTV` SpecifiedSpec) arg_names)+ []+ (map (\nm -> singFamily `DAppT` DVarT nm) arg_names)+ (sing_w_wildcard `DAppT`+ (foldApply prom_ty (map DVarT arg_names)))+ , arg_names )++{-+Note [Disable kind generalization for local functions if possible]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this example (from #296):++ f :: forall a. MyProxy a -> MyProxy a+ f MyProxy =+ let x = let z :: MyProxy a+ z = MyProxy in z+ in x++A naïve attempt at singling `f` is as follows:++ type LetZ :: MyProxy a+ type family LetZ where+ LetZ = 'MyProxy++ type family LetX where+ LetX = LetZ++ type F :: forall a. MyProxy a -> MyProxy a+ type family F x where+ F 'MyProxy = LetX++ sF :: forall a (t :: MyProxy a). Sing t -> Sing (F t :: MyProxy a)+ sF SMyProxy =+ let sX :: Sing LetX+ sX = let sZ :: Sing (LetZ :: MyProxy a)+ sZ = SMyProxy in sZ+ in sX++This will not typecheck, however. The is because the return kind of+`LetX` (in `let sX :: Sing LetX`) will get generalized by virtue of `sX`+having a type signature. It's as if one had written this:++ sF :: forall a (t :: MyProxy a). Sing t -> Sing (F t :: MyProxy a)+ sF SMyProxy =+ let sX :: forall a1. Sing (LetX :: MyProxy a1)+ sX = ...++This is too general, since `sX` will only typecheck if the return kind of+`LetX` is `MyProxy a`, not `MyProxy a1`. In order to avoid this problem,+we need to avoid kind generalization when kind-checking the type of `sX`.+To accomplish this, we borrow a trick from+Note [The id hack; or, how singletons-th learned to stop worrying and avoid kind generalization]+and use TypeApplications plus a wildcard type. That is, we generate this code+for `sF`:++ sF :: forall a (t :: MyProxy a). Sing t -> Sing (F t :: MyProxy a)+ sF SMyProxy =+ let sX :: Sing @_ LetX+ sX = ...++The presence of the wildcard type disables kind generalization, which allows+GHC's kind inference to deduce that the return kind of `LetX` should be `a`.+Now `sF` typechecks, and since we only use wildcards within visible kind+applications, we don't even have to force users to enable+PartialTypeSignatures. Hooray!++Question: where should we put wildcard types when singling? One possible answer+is: put a wildcard in any type signature that gets generated when singling a+function that lacks a type signature. Unfortunately, this is a step too far.+This will break singling the `foldr` function:++ foldr :: (a -> b -> b) -> b -> [a] -> b+ foldr k z = go+ where+ go [] = z+ go (y:ys) = y `k` go ys++If the type of `sGo` is given a wildcard, then it will fail to typecheck. This+is because `sGo` is polymorphically recursive, so disabling kind generalization+forces GHC to infer `sGo`'s type. Attempting to infer a polymorphically+recursive type, unsurprisingly, leads to failure.++To avoid this sort of situation, where adopt a simple metric: if a function+lacks a type signature, only put @_ in its singled type signature if it has+zero arguments. This allows `sX` to typecheck without breaking things like+`sGo`. This metric is a bit conservative, however, since it means that this+small tweak to `x` still would not typecheck:++ f :: forall a. MyProxy a -> MyProxy a+ f MyProxy =+ let x () = let z :: MyProxy a+ z = MyProxy in z+ in x ()++We need not let perfect be the enemy of good, however. It is extremely+common for local definitions to have zero arguments, so it makes good sense+to optimize for that special case. In fact, this special treatment is the only+reason that `foo8` from the `T183` test case singles successfully, since+the as-patterns in `foo8` desugar to code very similar to the `f` example+above.+-}++singLetDecRHS :: Map Name DCxt -- the context of the type signature+ -- (might not be known)+ -> Name -> ALetDecRHS -> SgM DLetDec+singLetDecRHS cxts name ld_rhs = do+ opts <- getOptions+ bindContext (Map.findWithDefault [] name cxts) $+ case ld_rhs of+ AValue exp ->+ DValD (DVarP (singledValueName opts name)) <$>+ singExp exp+ AFunction _num_arrows clauses ->+ DFunD (singledValueName opts name) <$>+ mapM singClause clauses++singClause :: ADClause -> SgM DClause+singClause (ADClause var_proms pats exp) = do+ opts <- getOptions+ (sPats, sigPaExpsSigs) <- evalForPair $ mapM (singPat (Map.fromList var_proms)) pats+ let lambda_binds = map (\(n,_) -> (n, singledValueName opts n)) var_proms+ sBody <- bindLambdas lambda_binds $ singExp exp+ return $ DClause sPats $ mkSigPaCaseE sigPaExpsSigs sBody++singPat :: Map Name Name -- from term-level names to type-level names+ -> ADPat+ -> QWithAux SingDSigPaInfos SgM DPat+singPat var_proms = go+ where+ go :: ADPat -> QWithAux SingDSigPaInfos SgM DPat+ go (ADLitP _lit) =+ fail "Singling of literal patterns not yet supported"+ go (ADVarP name) = do+ opts <- getOptions+ tyname <- case Map.lookup name var_proms of+ Nothing ->+ fail "Internal error: unknown variable when singling pattern"+ Just tyname -> return tyname+ pure $ DVarP (singledValueName opts name)+ `DSigP` (singFamily `DAppT` DVarT tyname)+ go (ADConP name tys pats) = do+ opts <- getOptions+ DConP (singledDataConName opts name) tys <$> mapM go pats+ go (ADTildeP pat) = do+ qReportWarning+ "Lazy pattern converted into regular pattern during singleton generation."+ go pat+ go (ADBangP pat) = DBangP <$> go pat+ go (ADSigP prom_pat pat ty) = do+ pat' <- go pat+ -- Normally, calling dPatToDExp would be dangerous, since it fails if the+ -- supplied pattern contains any wildcard patterns. However, promotePat+ -- (which produced the pattern we're passing into dPatToDExp) maintains+ -- an invariant that any promoted pattern signatures will be free of+ -- wildcard patterns in the underlying pattern.+ -- See Note [Singling pattern signatures].+ addElement (dPatToDExp pat', DSigT prom_pat ty)+ pure pat'+ go ADWildP = pure DWildP++-- | If given a non-empty list of 'SingDSigPaInfos', construct a case expression+-- that brings singleton equality constraints into scope via pattern-matching.+-- See @Note [Singling pattern signatures]@.+mkSigPaCaseE :: SingDSigPaInfos -> DExp -> DExp+mkSigPaCaseE exps_with_sigs exp+ | null exps_with_sigs = exp+ | otherwise =+ let (exps, sigs) = unzip exps_with_sigs+ scrutinee = mkTupleDExp exps+ pats = map (DSigP DWildP . DAppT (DConT singFamilyName)) sigs+ in DCaseE scrutinee [DMatch (mkTupleDPat pats) exp]++-- Note [Annotate case return type]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- We're straining GHC's type inference here. One particular trouble area+-- is determining the return type of a GADT pattern match. In general, GHC+-- cannot infer return types of GADT pattern matches because the return type+-- becomes "untouchable" in the case matches. See the OutsideIn paper. But,+-- during singletonization, we *know* the return type. So, just add a type+-- annotation. See #54.+--+-- In particular, we add a type annotation in a somewhat unorthodox fashion.+-- Instead of the usual `(x :: t)`, we use `id @t x`. See+-- Note [The id hack; or, how singletons-th learned to stop worrying and avoid+-- kind generalization] for an explanation of why we do this.++-- Note [Why error is so special]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Some of the transformations that happen before this point produce impossible+-- case matches. We must be careful when processing these so as not to make+-- an error GHC will complain about. When binding the case-match variables, we+-- normally include an equality constraint saying that the scrutinee is equal+-- to the matched pattern. But, we can't do this in inaccessible matches, because+-- equality is bogus, and GHC (rightly) complains. However, we then have another+-- problem, because GHC doesn't have enough information when type-checking the+-- RHS of the inaccessible match to deem it type-safe. The solution: treat error+-- as super-special, so that GHC doesn't look too hard at singletonized error+-- calls. Specifically, DON'T do the applySing stuff. Just use sError, which+-- has a custom type (Sing x -> a) anyway.++-- Note [Singling pattern signatures]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- We want to single a pattern signature, like so:+--+-- f :: Maybe a -> a+-- f (Just x :: Maybe a) = x+--+-- Naïvely, one might expect this to single straightfowardly as:+--+-- sF :: forall (z :: Maybe a). Sing z -> Sing (F z)+-- sF (SJust sX :: Sing (Just x :: Maybe a)) = sX+--+-- But the way GHC typechecks patterns prevents this from working, as GHC won't+-- know that the type `z` is actually `Just x` until /after/ the entirety of+-- the `SJust sX` pattern has been typechecked. (See Trac #12018 for an+-- extended discussion on this topic.)+--+-- To work around this design, we resort to a somewhat unsightly trick:+-- immediately after matching on all the patterns, we perform a case on every+-- pattern with a pattern signature, like so:+--+-- sF :: forall (z :: Maybe a). Sing z -> Sing (F z)+-- sF (SJust sX :: Sing z)+-- = case (SJust sX :: Sing z) of+-- (_ :: Sing (Just x :: Maybe a)) -> sX+--+-- Now GHC accepts the fact that `z` is `Just x`, and all is well. In order+-- to support this construction, the type of singPat is augmented with some+-- extra information in the form of SingDSigPaInfos:+--+-- type SingDSigPaInfos = [(DExp, DType)]+--+-- Where the DExps corresponds to the expressions we case on just after the+-- patterns (`SJust sX :: Sing x`, in the example above), and the DTypes+-- correspond to the singled pattern signatures to use in the case alternative+-- (`Sing (Just x :: Maybe a)` in the example above). singPat appends to the+-- list of SingDSigPaInfos whenever it processes a DSigPa (pattern signature),+-- and call sites can pass these SingDSigPaInfos to mkSigPaCaseE to construct a+-- case expression like the one featured above.+--+-- Some interesting consequences of this design:+--+-- 1. We must promote DPats to ADPats, a variation of DPat where the annotated+-- DSigPa counterpart, ADSigPa, stores the type that the original DPat was+-- promoted to. This is necessary since promoting the type might have+-- generated fresh variable names, so we need to be able to use the same+-- names when singling.+--+-- 2. Also when promoting a DSigPa to an ADSigPa, we remove any wildcards from+-- the underlying pattern. To see why this is necessary, consider singling+-- this example:+--+-- g (Just _ :: Maybe a) = "hi"+--+-- This must single to something like this:+--+-- sG (SJust _ :: Sing z)+-- = case (SJust _ :: Sing z) of+-- (_ :: Sing (Just _ :: Maybe a)) -> "hi"+--+-- But `SJust _` is not a valid expression, and since the minimal th-desugar+-- AST lacks as-patterns, we can't replace it with something like+-- `sG x@(SJust _ :: Sing z) = case x of ...`. But even if the th-desugar+-- AST /did/ have as-patterns, we'd still be in trouble, as `Just _` isn't+-- a valid type without the use of -XPartialTypeSignatures, which isn't a+-- design we want to force upon others.+--+-- We work around both issues by simply converting all wildcard patterns+-- from the pattern that has a signature. That means our example becomes:+--+-- sG (SJust sWild :: Sing z)+-- = case (SJust sWild :: Sing z) of+-- (_ :: Sing (Just wild :: Maybe a)) -> "hi"+--+-- And now everything is hunky-dory.++singExp :: ADExp -> SgM DExp+ -- See Note [Why error is so special]+singExp (ADVarE err `ADAppE` arg)+ | err == errorName = do opts <- getOptions+ DAppE (DVarE (singledValueName opts err)) <$>+ singExp arg+singExp (ADVarE name) = lookupVarE name+singExp (ADConE name) = lookupConE name+singExp (ADLitE lit) = singLit lit+singExp (ADAppE e1 e2) = do+ e1' <- singExp e1+ e2' <- singExp e2+ -- `applySing undefined x` kills type inference, because GHC can't figure+ -- out the type of `undefined`. So we don't emit `applySing` there.+ if isException e1'+ then return $ e1' `DAppE` e2'+ else return $ (DVarE applySingName) `DAppE` e1' `DAppE` e2'+singExp (ADLamE ty_names prom_lam names exp) = do+ opts <- getOptions+ let sNames = map (singledValueName opts) names+ exp' <- bindLambdas (zip names sNames) $ singExp exp+ -- we need to bind the type variables... but DLamE doesn't allow SigT patterns.+ -- So: build a case+ let caseExp = DCaseE (mkTupleDExp (map DVarE sNames))+ [DMatch (mkTupleDPat+ (map ((DWildP `DSigP`) .+ (singFamily `DAppT`) .+ DVarT) ty_names)) exp']+ return $ wrapSingFun (length names) prom_lam $ DLamE sNames caseExp+singExp (ADCaseE exp matches ret_ty) =+ -- See Note [Annotate case return type] and+ -- Note [The id hack; or, how singletons-th learned to stop worrying and+ -- avoid kind generalization]+ DAppE (DAppTypeE (DVarE 'id)+ (singFamily `DAppT` ret_ty))+ <$> (DCaseE <$> singExp exp <*> mapM singMatch matches)+singExp (ADLetE env exp) = do+ -- We intentionally discard the SingI instances for exp's defunctionalization+ -- symbols, as we also do not generate the declarations for the+ -- defunctionalization symbols in the first place during promotion.+ (let_decs, _, exp') <- singLetDecEnv env $ singExp exp+ pure $ DLetE let_decs exp'+singExp (ADSigE prom_exp exp ty) = do+ exp' <- singExp exp+ pure $ DSigE exp' $ DConT singFamilyName `DAppT` DSigT prom_exp ty++-- See Note [DerivedDecl] in Data.Singletons.TH.Syntax+singDerivedEqDecs :: DerivedEqDecl -> SgM [DDec]+singDerivedEqDecs (DerivedDecl { ded_mb_cxt = mb_ctxt+ , ded_type = ty+ , ded_type_tycon = ty_tycon+ , ded_decl = DataDecl _ _ _ cons }) = do+ (scons, _) <- singM [] $ mapM (singCtor ty_tycon) cons+ mb_sctxt <- mapM (mapM singPred) mb_ctxt+ -- Beware! The user might have specified an instance context like this:+ --+ -- deriving instance Eq a => Eq (T a Int)+ --+ -- When we single the context, it will become (SEq a). But we do *not* want+ -- this for the SDecide instance! The simplest solution is to simply replace+ -- all occurrences of SEq with SDecide in the context.+ mb_sctxtDecide <- traverse (traverse sEqToSDecide) mb_sctxt+ sDecideInst <- mkDecideInstance mb_sctxtDecide ty cons scons+ eqInst <- mkEqInstanceForSingleton ty ty_tycon+ testInsts <- traverse (mkTestInstance mb_sctxtDecide ty ty_tycon cons)+ [TestEquality, TestCoercion]+ return (sDecideInst:eqInst:testInsts)++-- Walk a DPred, replacing all occurrences of SEq with SDecide.+sEqToSDecide :: OptionsMonad q => DPred -> q DPred+sEqToSDecide p = do+ opts <- getOptions+ pure $ modifyConNameDType (\n ->+ if n == singledClassName opts eqName+ then sDecideClassName+ else n) p++-- See Note [DerivedDecl] in Data.Singletons.TH.Syntax+singDerivedOrdDecs :: DerivedOrdDecl -> SgM [DDec]+singDerivedOrdDecs (DerivedDecl { ded_type = ty+ , ded_type_tycon = ty_tycon }) = do+ ord_inst <- mkOrdInstanceForSingleton ty ty_tycon+ pure [ord_inst]++-- See Note [DerivedDecl] in Data.Singletons.TH.Syntax+singDerivedShowDecs :: DerivedShowDecl -> SgM [DDec]+singDerivedShowDecs (DerivedDecl { ded_mb_cxt = mb_cxt+ , ded_type = ty+ , ded_type_tycon = ty_tycon+ , ded_decl = DataDecl _ _ _ cons }) = do+ opts <- getOptions+ z <- qNewName "z"+ -- Generate a Show instance for a singleton type, like this:+ --+ -- deriving instance (ShowSing a, ShowSing b) => Sing (SEither (z :: Either a b))+ --+ -- Be careful: we want to generate an instance context that uses ShowSing,+ -- not SShow.+ show_cxt <- inferConstraintsDef (fmap mkShowSingContext mb_cxt)+ (DConT showSingName)+ ty cons+ ki <- promoteType ty+ let sty_tycon = singledDataTypeName opts ty_tycon+ show_inst = DStandaloneDerivD Nothing Nothing show_cxt+ (DConT showName `DAppT` (DConT sty_tycon `DAppT` DSigT (DVarT z) ki))+ pure [show_inst]++isException :: DExp -> Bool+isException (DVarE n) = nameBase n == "sUndefined"+isException (DConE {}) = False+isException (DLitE {}) = False+isException (DAppE (DVarE fun) _) | nameBase fun == "sError" = True+isException (DAppE fun _) = isException fun+isException (DAppTypeE e _) = isException e+isException (DLamE _ _) = False+isException (DCaseE e _) = isException e+isException (DLetE _ e) = isException e+isException (DSigE e _) = isException e+isException (DStaticE e) = isException e+isException (DTypedBracketE e) = isException e+isException (DTypedSpliceE e) = isException e++singMatch :: ADMatch -> SgM DMatch+singMatch (ADMatch var_proms pat exp) = do+ opts <- getOptions+ (sPat, sigPaExpsSigs) <- evalForPair $ singPat (Map.fromList var_proms) pat+ let lambda_binds = map (\(n,_) -> (n, singledValueName opts n)) var_proms+ sExp <- bindLambdas lambda_binds $ singExp exp+ return $ DMatch sPat $ mkSigPaCaseE sigPaExpsSigs sExp++singLit :: Lit -> SgM DExp+singLit (IntegerL n) = do+ opts <- getOptions+ if n >= 0+ then return $+ DVarE (singledValueName opts fromIntegerName) `DAppE`+ (DVarE singMethName `DSigE`+ (singFamily `DAppT` DLitT (NumTyLit n)))+ else do sLit <- singLit (IntegerL (-n))+ return $ DVarE (singledValueName opts negateName) `DAppE` sLit+singLit (StringL str) = do+ opts <- getOptions+ let sing_str_lit = DVarE singMethName `DSigE`+ (singFamily `DAppT` DLitT (StrTyLit str))+ os_enabled <- qIsExtEnabled LangExt.OverloadedStrings+ pure $ if os_enabled+ then DVarE (singledValueName opts fromStringName) `DAppE` sing_str_lit+ else sing_str_lit+singLit (CharL c) =+ return $ DVarE singMethName `DSigE` (singFamily `DAppT` DLitT (CharTyLit c))+singLit lit =+ fail ("Only string, natural number, and character literals can be singled: " ++ show lit)++{-+Note [The id hack; or, how singletons-th learned to stop worrying and avoid kind generalization]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC 8.8 was a time of great change. In particular, 8.8 debuted a fix for+Trac #15141 (decideKindGeneralisationPlan is too complicated). To fix this, a+wily GHC developer—who shall remain unnamed, but whose username rhymes with+schmoldfire—decided to make decideKindGeneralisationPlan less complicated by,+well, removing the whole thing. One consequence of this is that local+definitions are now kind-generalized (whereas they would not have been+previously).++While schmoldfire had the noblest of intentions when authoring his fix, he+unintentionally made life much harder for singletons-th. Why? Consider the+following program:++ class Foo a where+ bar :: a -> (a -> b) -> b+ baz :: a++ quux :: Foo a => a -> a+ quux x = x `bar` \_ -> baz++When singled, this program will turn into something like this:++ type family Quux (x :: a) :: a where+ Quux x = Bar x (LambdaSym1 x)++ sQuux :: forall a (x :: a). SFoo a => Sing x -> Sing (Quux x :: a)+ sQuux (sX :: Sing x)+ = sBar sX+ ((singFun1 @(LambdaSym1 x))+ (\ sArg+ -> case sArg of {+ (_ :: Sing arg)+ -> (case sArg of { _ -> sBaz }) ::+ Sing (Case x arg arg) }))++ type family Case x arg t where+ Case x arg _ = Baz+ type family Lambda x t where+ Lambda x arg = Case x arg arg+ data LambdaSym1 x t+ type instance Apply (LambdaSym1 x) t = Lambda x t++The high-level bit is the explicit `Sing (Case x arg arg)` signature. Question:+what is the kind of `Case x arg arg`? The answer depends on whether local+definitions are kind-generalized or not!++1. If local definitions are *not* kind-generalized (i.e., the status quo before+ GHC 8.8), then `Case x arg arg :: a`.+2. If local definitions *are* kind-generalized (i.e., the status quo in GHC 8.8+ and later), then `Case x arg arg :: k` for some fresh kind variable `k`.++Unfortunately, the kind of `Case x arg arg` *must* be `a` in order for `sQuux`+to type-check. This means that the code above suddenly stopped working in GHC+8.8. What's more, we can't just remove these explicit signatures, as there is+code elsewhere in `singletons-th` that crucially relies on them to guide type+inference along (e.g., `sShowParen` in `Text.Show.Singletons`).++Luckily, there is an ingenious hack that lets us the benefits of explicit+signatures without the pain of kind generalization: our old friend, the `id`+function. The plan is as follows: instead of generating this code:++ (case sArg of ...) :: Sing (Case x arg arg)++We instead generate this code:++ id @(Sing (Case x arg arg)) (case sArg of ...)++That's it! This works because visible type arguments in terms do not get kind-+generalized, unlike top-level or local signatures. Now `Case x arg arg`'s kind+is not generalized, and all is well. We dub this: the `id` hack.++One might wonder: will we need the `id` hack around forever? Perhaps not. While+GHC 8.8 removed the decideKindGeneralisationPlan function, there have been+rumblings that a future version of GHC may bring it back (in a limited form).+If this happens, it is possibly that GHC's attitude towards kind-generalizing+local definitions may change *again*, which could conceivably render the `id`+hack unnecessary. This is all speculation, of course, so all we can do now is+wait and revisit this design at a later date.+-}
src/Data/Singletons/TH/Single/Data.hs view
@@ -1,405 +1,644 @@-{- Data/Singletons/TH/Single/Data.hs - -(c) Richard Eisenberg 2013 -rae@cs.brynmawr.edu - -Singletonizes constructors. --} - -module Data.Singletons.TH.Single.Data where - -import Language.Haskell.TH.Desugar as Desugar -import Language.Haskell.TH.Syntax -import Data.Maybe -import Data.Singletons.TH.Names -import Data.Singletons.TH.Options -import Data.Singletons.TH.Promote.Type -import Data.Singletons.TH.Single.Defun -import Data.Singletons.TH.Single.Fixity -import Data.Singletons.TH.Single.Monad -import Data.Singletons.TH.Syntax -import Data.Singletons.TH.Util -import Control.Monad - --- We wish to consider the promotion of "Rep" to be * --- not a promoted data constructor. -singDataD :: DataDecl -> SgM [DDec] -singDataD (DataDecl df name tvbs ctors) = do - opts <- getOptions - let tvbNames = map extractTvbName tvbs - ctor_names = map extractName ctors - rec_sel_names = concatMap extractRecSelNames ctors - k <- promoteType (foldType (DConT name) (map DVarT tvbNames)) - mb_data_sak <- dsReifyType name - ctors' <- mapM (singCtor name) ctors - fixityDecs <- singReifiedInfixDecls $ ctor_names ++ rec_sel_names - -- instance for SingKind - fromSingClauses <- mapM mkFromSingClause ctors - emptyFromSingClause <- mkEmptyFromSingClause - toSingClauses <- mapM mkToSingClause ctors - emptyToSingClause <- mkEmptyToSingClause - let singKindInst = - DInstanceD Nothing Nothing - (map (singKindConstraint . DVarT) tvbNames) - (DAppT (DConT singKindClassName) k) - [ DTySynInstD $ DTySynEqn Nothing - (DConT demoteName `DAppT` k) - (foldType (DConT name) - (map (DAppT demote . DVarT) tvbNames)) - , DLetDec $ DFunD fromSingName - (fromSingClauses `orIfEmpty` [emptyFromSingClause]) - , DLetDec $ DFunD toSingName - (toSingClauses `orIfEmpty` [emptyToSingClause]) ] - - let singDataName = singledDataTypeName opts name - -- e.g. type instance Sing @Nat = SNat - singSynInst = - DTySynInstD $ DTySynEqn Nothing - (DConT singFamilyName `DAppKindT` k) - (DConT singDataName) - - -- Note that we always include an explicit result kind in the body of the - -- singleton data type declaration, even if it has a standalone kind - -- signature that would make this explicit result kind redudant. - -- See Note [Keep redundant kind information for Haddocks] - -- in D.S.TH.Promote. - mk_data_dec kind = - DDataD Data [] singDataName [] (Just kind) ctors' [] - - data_decs = case mb_data_sak of - -- No standalone kind signature. Try to figure out the order of kind - -- variables on a best-effort basis. - Nothing -> - let sing_tvbs = changeDTVFlags SpecifiedSpec $ - toposortTyVarsOf $ map dTyVarBndrToDType tvbs - kinded_sing_ty = DForallT (DForallInvis sing_tvbs) $ - DArrowT `DAppT` k `DAppT` DConT typeKindName in - [mk_data_dec kinded_sing_ty] - - -- A standalone kind signature is provided, so use that to determine the - -- order of kind variables. - Just data_sak -> - let (args, _) = unravelDType data_sak - vis_args = filterDVisFunArgs args - vis_tvbs = changeDTVFlags SpecifiedSpec $ - zipWith replaceTvbKind vis_args tvbs - invis_args = filterInvisTvbArgs args - -- If the standalone kind signature did not explicitly quantify its - -- kind variables, do so ourselves. This is very similar to what - -- D.S.TH.Single.Type.singTypeKVBs does. - invis_tvbs | null invis_args - = changeDTVFlags SpecifiedSpec $ - toposortTyVarsOf [data_sak] - | otherwise - = invis_args - sing_data_sak = DForallT (DForallInvis (invis_tvbs ++ vis_tvbs)) $ - DArrowT `DAppT` k `DAppT` DConT typeKindName in - [ DKiSigD singDataName sing_data_sak - , mk_data_dec sing_data_sak - ] - - return $ data_decs ++ - singSynInst : - [ singKindInst | genSingKindInsts opts - , -- `type data` data constructors only exist at the - -- type level. As such, we cannot define SingKind - -- instances for them, as they require term-level - -- data constructors to implement. - df /= Desugar.TypeData - ] ++ - fixityDecs - where -- in the Rep case, the names of the constructors are in the wrong scope - -- (they're types, not datacons), so we have to reinterpret them. - mkConName :: Name -> SgM Name - mkConName - | nameBase name == nameBase repName = mkDataName . nameBase - | otherwise = return - - mkFromSingClause :: DCon -> SgM DClause - mkFromSingClause c = do - opts <- getOptions - let (cname, numArgs) = extractNameArgs c - cname' <- mkConName cname - varNames <- replicateM numArgs (qNewName "b") - return $ DClause [DConP (singledDataConName opts cname) [] (map DVarP varNames)] - (foldExp - (DConE cname') - (map (DAppE (DVarE fromSingName) . DVarE) varNames)) - - mkToSingClause :: DCon -> SgM DClause - mkToSingClause (DCon _tvbs _cxt cname fields _rty) = do - opts <- getOptions - let types = tysOfConFields fields - varNames <- mapM (const $ qNewName "b") types - svarNames <- mapM (const $ qNewName "c") types - promoted <- mapM promoteType types - cname' <- mkConName cname - let varPats = zipWith mkToSingVarPat varNames promoted - recursiveCalls = zipWith mkRecursiveCall varNames promoted - return $ - DClause [DConP cname' [] varPats] - (multiCase recursiveCalls - (map (DConP someSingDataName [] . listify . DVarP) - svarNames) - (DAppE (DConE someSingDataName) - (foldExp (DConE (singledDataConName opts cname)) - (map DVarE svarNames)))) - - mkToSingVarPat :: Name -> DKind -> DPat - mkToSingVarPat varName ki = - DSigP (DVarP varName) (DAppT (DConT demoteName) ki) - - mkRecursiveCall :: Name -> DKind -> DExp - mkRecursiveCall var_name ki = - DSigE (DAppE (DVarE toSingName) (DVarE var_name)) - (DAppT (DConT someSingTypeName) ki) - - mkEmptyFromSingClause :: SgM DClause - mkEmptyFromSingClause = do - x <- qNewName "x" - pure $ DClause [DVarP x] - $ DCaseE (DVarE x) [] - - mkEmptyToSingClause :: SgM DClause - mkEmptyToSingClause = do - x <- qNewName "x" - pure $ DClause [DVarP x] - $ DConE someSingDataName `DAppE` DCaseE (DVarE x) [] - --- Single a constructor. -singCtor :: Name -> DCon -> SgM DCon - -- polymorphic constructors are handled just - -- like monomorphic ones -- the polymorphism in - -- the kind is automatic -singCtor dataName (DCon con_tvbs cxt name fields rty) - | not (null cxt) - = fail "Singling of constrained constructors not yet supported" - | otherwise - = do - opts <- getOptions - let types = tysOfConFields fields - numTypes = length types - sName = singledDataConName opts name - sCon = DConE sName - pCon = DConT $ promotedDataTypeOrConName opts name - checkVanillaDType $ ravelVanillaDType con_tvbs [] types rty - indexNames <- mapM (const $ qNewName "n") types - kinds <- mapM promoteType_NC types - rty' <- promoteType_NC rty - let indices = map DVarT indexNames - kindedIndices = zipWith DSigT indices kinds - -- The approach we use for singling data constructor types differs - -- slightly from the approach taken in D.S.TH.Single.Type.singType in that - -- we always explicitly quantify all type variables in a singled data - -- constructor, regardless of whether the original data constructor - -- explicitly quantified them or not. This explains the use of - -- toposortTyVarsOf below. - -- See Note [Preserve the order of type variables during singling] - -- (wrinkle 1) in D.S.TH.Single.Type. - kvbs | null con_tvbs - = changeDTVFlags SpecifiedSpec (toposortTyVarsOf (kinds ++ [rty'])) ++ - con_tvbs - | otherwise - = con_tvbs - all_tvbs = kvbs ++ zipWith (`DKindedTV` SpecifiedSpec) indexNames kinds - - -- @mb_SingI_dec k@ returns 'Just' an instance of @SingI<k>@ if @k@ is - -- less than or equal to the number of fields in the data constructor. - -- Otherwise, it returns 'Nothing'. - let mb_SingI_dec :: Int -> Maybe DDec - mb_SingI_dec k - | k <= numTypes - = let take_until_k = take (numTypes - k) in - Just $ DInstanceD Nothing Nothing - (map (DAppT (DConT singIName)) (take_until_k indices)) - (DAppT (DConT (mkSingIName k)) - (foldType pCon (take_until_k kindedIndices))) - [DLetDec $ DValD (DVarP (mkSingMethName k)) - (foldExp sCon (replicate (numTypes - k) (DVarE singMethName)))] - | otherwise - = Nothing - - -- SingI instance for data constructor - emitDecs $ mapMaybe mb_SingI_dec [0, 1, 2] - -- SingI instances for defunctionalization symbols. Note that we don't - -- support contexts in constructors at the moment, so it's fine for now to - -- just assume that the context is always (). - emitDecs =<< singDefuns name DataName [] (map Just kinds) (Just rty') - - conFields <- case fields of - DNormalC dInfix bts -> DNormalC dInfix <$> - zipWithM (\(b, _) index -> mk_bang_type b index) - bts indices - DRecC vbts -> DNormalC False <$> - zipWithM (\(_, b, _) index -> mk_bang_type b index) - vbts indices - -- Don't bother looking at record selectors, as they are - -- handled separately in singTopLevelDecs. - -- See Note [singletons-th and record selectors] - return $ DCon all_tvbs [] sName conFields - (DConT (singledDataTypeName opts dataName) `DAppT` - (foldType pCon indices `DSigT` rty')) - -- Make sure to include an explicit `rty'` kind annotation. - -- See Note [Preserve the order of type variables during singling], - -- wrinkle 3, in D.S.TH.Single.Type. - where - mk_source_unpackedness :: SourceUnpackedness -> SgM SourceUnpackedness - mk_source_unpackedness su = case su of - NoSourceUnpackedness -> pure su - SourceNoUnpack -> pure su - SourceUnpack -> do - -- {-# UNPACK #-} is essentially useless in a singletons setting, since - -- all singled data types are GADTs. See GHC#10016. - qReportWarning "{-# UNPACK #-} pragmas are ignored by `singletons-th`." - pure NoSourceUnpackedness - - mk_bang :: Bang -> SgM Bang - mk_bang (Bang su ss) = do su' <- mk_source_unpackedness su - pure $ Bang su' ss - - mk_bang_type :: Bang -> DType -> SgM DBangType - mk_bang_type b index = do b' <- mk_bang b - pure (b', DAppT singFamily index) - -{- -Note [singletons-th and record selectors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Record selectors are annoying to deal with in singletons-th for various reasons: - -1. There is no record syntax at the type level, so promoting code that involves - records in some way is not straightforward. -2. One can define record selectors for singled data types, but they're rife - with peril. Some pitfalls include: - - * Singling record updates often produces code that does not typecheck. For - example, this works: - - let i = Identity True in i { runIdentity = False } - - But this does /not/ work: - - let si = SIdentity STrue in si { sRunIdentity = SFalse } - - error: - • Record update for insufficiently polymorphic field: - sRunIdentity :: Sing n - • In the expression: si {sRunIdentity = SFalse} - In the expression: - let si = SIdentity STrue in si {sRunIdentity = SFalse} - - Ugh. See GHC#16501. - - * Singling a data type with multiple constructors that share a record - selector name will /also/ not typecheck. While this works: - - data X = X1 {y :: Bool} | X2 {y :: Bool} - - This does not: - - data SX :: X -> Type where - SX1 :: { sY :: Sing n } -> SX ('X1 n) - SY1 :: { sY :: Sing n } -> SX ('X2 n) - - error: - • Constructors SX1 and SX2 have a common field ‘sY’, - but have different result types - • In the data type declaration for ‘SX’ - - Double ugh. See GHC#8673/GHC#12159. - - * Even if a data type only has a single constructor with record selectors, - singling it can induce headaches. One might be tempted to single this type: - - newtype Unit = MkUnit { runUnit :: () } - - With this code: - - data SUnit :: Unit -> Type where - SMkUnit :: { sRunUnit :: Sing u } -> SUnit (MkUnit u) - - Somewhat surprisingly, the type of sRunUnit: - - sRunUnit :: Sing (MkUnit u) -> Sing u - - Is not general enough to handle common uses of record selectors. For - example, if you try to single this function: - - f :: Unit -> () - f = runUnit - - Then the resulting code: - - sF :: Sing (x :: Unit) -> Sing (F x :: ()) - sF = sRunUnit - - Will not typecheck. Note that sRunUnit expects an argument of type - `Sing (MkUnit u)`, but there is no way to know a priori that the `x` in - `Sing (x :: Unit)` is `MkUnit u` without pattern-matching on SMkUnit. - -Hopefully I have convinced you that handling records in singletons-th is a bit of -a nightmare. Thankfully, there is a simple trick to avoid most of the pitfalls -above: just desugar code (using th-desugar) to avoid records! -In more concrete terms, we do the following: - -* A record constructions desugars to a normal constructor application. For example: - - MkT{a = x, b = y} - - ==> - - MkT x y - - Something similar occurs for record syntax in patterns. - -* A record update desugars to a case expression. For example: - - t{a = x} - - ==> - - case t of MkT _ y => MkT x y - -We can't easily desugar away all uses of records, however. After all, records -can be used as ordinary functions as well. We leave such uses of records alone -when desugaring and accommodate them during promotion and singling by generating -"manual" record selectors. As a running example, consider the earlier Unit example: - - newtype Unit = MkUnit { runUnit :: () } - -When singling Unit, we do not give SMkUnit a record selector: - - data SUnit :: Unit -> Type where - SMkUnit :: Sing u -> SUnit (MkUnit u) - -Instead, we generate a top-level function that behaves equivalently to runUnit. -This function then gets promoted and singled (in D.S.TH.Promote.promoteDecs and -D.S.TH.Single.singTopLevelDecs): - - type family RunUnit (x :: Unit) :: () where - RunUnit (MkUnit x) = x - - sRunUnit :: Sing (x :: Unit) -> Sing (RunUnit x :: ()) - sRunUnit (SMkUnit sx) = sx - -Now promoting/singling uses of runUnit as an ordinary function work as expected -since the types of RunUnit/sRunUnit are sufficiently general. This technique also -scales up to data types with multiple constructors sharing a record selector name. -For instance, in the earlier X example: - - data X = X1 {y :: Bool} | X2 {y :: Bool} - -We would promote/single `y` like so: - - type family Y (x :: X) :: Bool where - Y (X1 y) = y - Y (X2 y) = y - - sY :: Sing (x :: X) -> Sing (Y x :: Bool) - sY (SX1 sy) = sy - sY (SX2 sy) = sy - -Manual record selectors cannot be used in record constructions or updates, but -for most use cases this won't be an issue, since singletons-th makes an effort to -desugar away fancy uses of records anyway. The only time this would bite is if -you wanted to use record syntax in hand-written singletons code. --} +{- Data/Singletons/TH/Single/Data.hs++(c) Richard Eisenberg 2013+rae@cs.brynmawr.edu++Singletonizes constructors.+-}++module Data.Singletons.TH.Single.Data+ ( singDataD+ , singCtor+ ) where++import Language.Haskell.TH.Desugar as Desugar+import Language.Haskell.TH.Syntax+import qualified Data.Map.Strict as Map+import Data.Map.Strict (Map)+import Data.Maybe+import Data.Traversable (mapAccumL)+import Data.Singletons.TH.Names+import Data.Singletons.TH.Options+import Data.Singletons.TH.Promote.Type+import Data.Singletons.TH.Single.Defun+import Data.Singletons.TH.Single.Fixity+import Data.Singletons.TH.Single.Monad+import Data.Singletons.TH.Syntax+import Data.Singletons.TH.Util+import Control.Monad++-- We wish to consider the promotion of "Rep" to be *+-- not a promoted data constructor.+singDataD :: DataDecl -> SgM [DDec]+singDataD (DataDecl df name tvbs ctors) = do+ opts <- getOptions+ let reqTvbNames = map extractTvbName $+ filter (\tvb -> extractTvbFlag tvb == BndrReq) tvbs+ ctor_names = map extractName ctors+ rec_sel_names = concatMap extractRecSelNames ctors+ k <- promoteType (foldTypeTvbs (DConT name) tvbs)+ mb_data_sak <- dsReifyType name+ ctors' <- mapM (singCtor name) ctors+ fixityDecs <- singReifiedInfixDecls $ ctor_names ++ rec_sel_names+ -- instance for SingKind+ fromSingClauses <- mapM mkFromSingClause ctors+ emptyFromSingClause <- mkEmptyFromSingClause+ toSingClauses <- mapM mkToSingClause ctors+ emptyToSingClause <- mkEmptyToSingClause+ let singKindInst =+ DInstanceD Nothing Nothing+ (map (singKindConstraint . DVarT) reqTvbNames)+ (DAppT (DConT singKindClassName) k)+ [ DTySynInstD $ DTySynEqn Nothing+ (DConT demoteName `DAppT` k)+ (foldType (DConT name)+ (map (DAppT demote . DVarT) reqTvbNames))+ , DLetDec $ DFunD fromSingName+ (fromSingClauses `orIfEmpty` [emptyFromSingClause])+ , DLetDec $ DFunD toSingName+ (toSingClauses `orIfEmpty` [emptyToSingClause]) ]++ let singDataName = singledDataTypeName opts name+ -- e.g. type instance Sing @Nat = SNat+ singSynInst =+ DTySynInstD $ DTySynEqn Nothing+ (DConT singFamilyName `DAppKindT` k)+ (DConT singDataName)++ -- Note that we always include an explicit result kind in the body of the+ -- singleton data type declaration, even if it has a standalone kind+ -- signature that would make this explicit result kind redudant.+ -- See Note [Keep redundant kind information for Haddocks]+ -- in D.S.TH.Promote.+ mk_data_dec kind =+ DDataD Data [] singDataName [] (Just kind) ctors' []++ data_decs <- case mb_data_sak of+ -- No standalone kind signature. Try to figure out the order of kind+ -- variables on a best-effort basis.+ Nothing -> do+ let sing_tvbs = changeDTVFlags SpecifiedSpec $+ toposortTyVarsOf $ map dTyVarBndrToDType tvbs+ kinded_sing_ty = DForallT (DForallInvis sing_tvbs) $+ DArrowT `DAppT` k `DAppT` DConT typeKindName+ pure [mk_data_dec kinded_sing_ty]++ -- A standalone kind signature is provided, so use that to determine the+ -- order of kind variables.+ Just data_sak -> do+ sing_data_sak <- singDataSAK data_sak tvbs k+ pure [ DKiSigD singDataName sing_data_sak+ , mk_data_dec sing_data_sak+ ]++ return $ data_decs +++ singSynInst :+ [ singKindInst | genSingKindInsts opts+ , -- `type data` data constructors only exist at the+ -- type level. As such, we cannot define SingKind+ -- instances for them, as they require term-level+ -- data constructors to implement.+ df /= Desugar.TypeData+ ] +++ fixityDecs+ where -- in the Rep case, the names of the constructors are in the wrong scope+ -- (they're types, not datacons), so we have to reinterpret them.+ mkConName :: Name -> SgM Name+ mkConName+ | nameBase name == nameBase repName = mkDataName . nameBase+ | otherwise = return++ mkFromSingClause :: DCon -> SgM DClause+ mkFromSingClause c = do+ opts <- getOptions+ let (cname, numArgs) = extractNameArgs c+ cname' <- mkConName cname+ varNames <- replicateM numArgs (qNewName "b")+ return $ DClause [DConP (singledDataConName opts cname) [] (map DVarP varNames)]+ (foldExp+ (DConE cname')+ (map (DAppE (DVarE fromSingName) . DVarE) varNames))++ mkToSingClause :: DCon -> SgM DClause+ mkToSingClause (DCon _tvbs _cxt cname fields _rty) = do+ opts <- getOptions+ let types = tysOfConFields fields+ varNames <- mapM (const $ qNewName "b") types+ svarNames <- mapM (const $ qNewName "c") types+ promoted <- mapM promoteType types+ cname' <- mkConName cname+ let varPats = zipWith mkToSingVarPat varNames promoted+ recursiveCalls = zipWith mkRecursiveCall varNames promoted+ return $+ DClause [DConP cname' [] varPats]+ (multiCase recursiveCalls+ (map (DConP someSingDataName [] . listify . DVarP)+ svarNames)+ (DAppE (DConE someSingDataName)+ (foldExp (DConE (singledDataConName opts cname))+ (map DVarE svarNames))))++ mkToSingVarPat :: Name -> DKind -> DPat+ mkToSingVarPat varName ki =+ DSigP (DVarP varName) (DAppT (DConT demoteName) ki)++ mkRecursiveCall :: Name -> DKind -> DExp+ mkRecursiveCall var_name ki =+ DSigE (DAppE (DVarE toSingName) (DVarE var_name))+ (DAppT (DConT someSingTypeName) ki)++ mkEmptyFromSingClause :: SgM DClause+ mkEmptyFromSingClause = do+ x <- qNewName "x"+ pure $ DClause [DVarP x]+ $ DCaseE (DVarE x) []++ mkEmptyToSingClause :: SgM DClause+ mkEmptyToSingClause = do+ x <- qNewName "x"+ pure $ DClause [DVarP x]+ $ DConE someSingDataName `DAppE` DCaseE (DVarE x) []++-- Single a constructor.+singCtor :: Name -> DCon -> SgM DCon+ -- polymorphic constructors are handled just+ -- like monomorphic ones -- the polymorphism in+ -- the kind is automatic+singCtor dataName (DCon con_tvbs cxt name fields rty)+ | not (null cxt)+ = fail "Singling of constrained constructors not yet supported"+ | otherwise+ = do+ opts <- getOptions+ let types = tysOfConFields fields+ numTypes = length types+ sName = singledDataConName opts name+ sCon = DConE sName+ pCon = DConT $ promotedDataTypeOrConName opts name+ checkVanillaDType $ ravelVanillaDType con_tvbs [] types rty+ indexNames <- mapM (const $ qNewName "n") types+ kinds <- mapM promoteType_NC types+ rty' <- promoteType_NC rty+ let indices = map DVarT indexNames+ kindedIndices = zipWith DSigT indices kinds+ -- The approach we use for singling data constructor types differs+ -- slightly from the approach taken in D.S.TH.Single.Type.singType in that+ -- we always explicitly quantify all type variables in a singled data+ -- constructor, regardless of whether the original data constructor+ -- explicitly quantified them or not. This explains the use of+ -- toposortTyVarsOf below.+ -- See Note [Preserve the order of type variables during singling]+ -- (wrinkle 1) in D.S.TH.Single.Type.+ kvbs | null con_tvbs+ = changeDTVFlags SpecifiedSpec (toposortTyVarsOf (kinds ++ [rty'])) +++ con_tvbs+ | otherwise+ = con_tvbs+ all_tvbs = kvbs ++ zipWith (`DKindedTV` SpecifiedSpec) indexNames kinds++ -- @mb_SingI_dec k@ returns 'Just' an instance of @SingI<k>@ if @k@ is+ -- less than or equal to the number of fields in the data constructor.+ -- Otherwise, it returns 'Nothing'.+ let mb_SingI_dec :: Int -> Maybe DDec+ mb_SingI_dec k+ | k <= numTypes+ = let take_until_k = take (numTypes - k) in+ Just $ DInstanceD Nothing Nothing+ (map (DAppT (DConT singIName)) (take_until_k indices))+ (DAppT (DConT (mkSingIName k))+ (foldType pCon (take_until_k kindedIndices)))+ [DLetDec $ DValD (DVarP (mkSingMethName k))+ (foldExp sCon (replicate (numTypes - k) (DVarE singMethName)))]+ | otherwise+ = Nothing++ -- SingI instance for data constructor+ emitDecs $ mapMaybe mb_SingI_dec [0, 1, 2]+ -- SingI instances for defunctionalization symbols. Note that we don't+ -- support contexts in constructors at the moment, so it's fine for now to+ -- just assume that the context is always ().+ emitDecs =<< singDefuns name DataName [] (map Just kinds) (Just rty')++ conFields <- case fields of+ DNormalC dInfix bts -> DNormalC dInfix <$>+ zipWithM (\(b, _) index -> mk_bang_type b index)+ bts indices+ DRecC vbts -> DNormalC False <$>+ zipWithM (\(_, b, _) index -> mk_bang_type b index)+ vbts indices+ -- Don't bother looking at record selectors, as they are+ -- handled separately in singTopLevelDecs.+ -- See Note [singletons-th and record selectors]+ return $ DCon all_tvbs [] sName conFields+ (DConT (singledDataTypeName opts dataName) `DAppT`+ (foldType pCon indices `DSigT` rty'))+ -- Make sure to include an explicit `rty'` kind annotation.+ -- See Note [Preserve the order of type variables during singling],+ -- wrinkle 3, in D.S.TH.Single.Type.+ where+ mk_source_unpackedness :: SourceUnpackedness -> SgM SourceUnpackedness+ mk_source_unpackedness su = case su of+ NoSourceUnpackedness -> pure su+ SourceNoUnpack -> pure su+ SourceUnpack -> do+ -- {-# UNPACK #-} is essentially useless in a singletons setting, since+ -- all singled data types are GADTs. See GHC#10016.+ qReportWarning "{-# UNPACK #-} pragmas are ignored by `singletons-th`."+ pure NoSourceUnpackedness++ mk_bang :: Bang -> SgM Bang+ mk_bang (Bang su ss) = do su' <- mk_source_unpackedness su+ pure $ Bang su' ss++ mk_bang_type :: Bang -> DType -> SgM DBangType+ mk_bang_type b index = do b' <- mk_bang b+ pure (b', DAppT singFamily index)++-- @'singDataSAK' sak data_bndrs@ produces a standalone kind signature for a+-- singled data declaration, using the original data type's standalone kind+-- signature (@sak@) and its user-written binders (@data_bndrs@) as a template.+-- For this example:+--+-- @+-- type D :: forall j k. k -> j -> Type+-- data D @j @l (a :: l) b = ...+-- @+--+-- We would produce the following standalone kind signature:+--+-- @+-- type SD :: forall j l (a :: l) (b :: j). D @j @l (a :: l) b -> Type+-- @+--+-- Note that:+--+-- * This function has a precondition that the length of @data_bndrs@ must+-- always be equal to the number of visible quantifiers (i.e., the number of+-- function arrows plus the number of visible @forall@–bound variables) in+-- @sak@. @singletons-th@ maintains this invariant when constructing a+-- 'DataDecl' (see the 'buildDataDTvbs' function).+--+-- * The order of the invisible quantifiers is preserved, so both+-- @D \@Bool \@Ordering@ and @SD \@Bool \@Ordering@ will work the way you would+-- expect it to.+--+-- * Whenever possible, this function reuses type variable names from the data+-- type's user-written binders. This is why the standalone kind signature uses+-- @forall j l@ instead of @forall j k@, since the @(a :: l)@ binder uses @l@+-- instead of @k@. We could have just as well chose the other way around, but+-- we chose to pick variable names from the data type binders since they scope+-- over other parts of the data type declaration (e.g., in @deriving@+-- clauses), so keeping these names avoids having to perform some+-- alpha-renaming.+singDataSAK ::+ MonadFail q+ => DKind+ -- ^ The standalone kind signature for the original data type+ -> [DTyVarBndrVis]+ -- ^ The user-written binders for the original data type+ -> DKind+ -- ^ The original data type, promoted to a kind+ -> q DKind+ -- ^ The standalone kind signature for the singled data type+singDataSAK data_sak data_bndrs data_k = do+ -- (1) First, explicitly quantify any free kind variables in `data_sak` using+ -- an invisible @forall@. This is done to ensure that precondition (2) in+ -- `matchUpSigWithDecl` is upheld. (See the Haddocks for that function).+ let data_sak_free_tvbs =+ changeDTVFlags SpecifiedSpec $ toposortTyVarsOf [data_sak]+ data_sak' = DForallT (DForallInvis data_sak_free_tvbs) data_sak++ -- (2) Next, compute type variable binders for the singled data type's+ -- standalone kind signature using `matchUpSigWithDecl`. Note that these can+ -- be biased towards type variable names mention in `data_sak` over names+ -- mentioned in `data_bndrs`, but we will fix that up in the next step.+ let (data_sak_args, _) = unravelDType data_sak'+ sing_sak_tvbs <- matchUpSigWithDecl data_sak_args data_bndrs++ -- (3) Swizzle the type variable names so that names in `data_bndrs` are+ -- preferred over names in `data_sak`.+ --+ -- This is heavily inspired by similar code in GHC:+ -- https://gitlab.haskell.org/ghc/ghc/-/blob/cec903899234bf9e25ea404477ba846ac1e963bb/compiler/GHC/Tc/Gen/HsType.hs#L2607-2616+ let invis_data_sak_args = filterInvisTvbArgs data_sak_args+ invis_data_sak_arg_nms = map extractTvbName invis_data_sak_args++ invis_data_bndrs = toposortKindVarsOfTvbs data_bndrs+ invis_data_bndr_nms = map extractTvbName invis_data_bndrs++ swizzle_env =+ Map.fromList $ zip invis_data_sak_arg_nms invis_data_bndr_nms+ (_, swizzled_sing_sak_tvbs) =+ mapAccumL (swizzleTvb swizzle_env) Map.empty sing_sak_tvbs++ -- (4) Finally, construct the kind of the singled data type.+ pure $ DForallT (DForallInvis swizzled_sing_sak_tvbs)+ $ DArrowT `DAppT` data_k `DAppT` DConT typeKindName++-- Match the quantifiers in a data type's standalone kind signature with the+-- binders in the data type declaration. This function assumes the following+-- preconditions:+--+-- 1. The number of required binders in the data type declaration is equal to+-- the number of visible quantifiers (i.e., the number of function arrows+-- plus the number of visible @forall@–bound variables) in the standalone+-- kind signature.+--+-- 2. The number of invisible \@-binders in the data type declaration is less+-- than or equal to the number of invisible quantifiers (i.e., the number of+-- invisible @forall@–bound variables) in the standalone kind signature.+--+-- The implementation of this function is heavily based on a GHC function of+-- the same name:+-- https://gitlab.haskell.org/ghc/ghc/-/blob/1464a2a8de082f66ae250d63ab9d94dbe2ef8620/compiler/GHC/Tc/Gen/HsType.hs#L2645-2715+matchUpSigWithDecl ::+ forall q.+ MonadFail q+ => DFunArgs+ -- ^ The quantifiers in the data type's standalone kind signature+ -> [DTyVarBndrVis]+ -- ^ The user-written binders in the data type declaration+ -> q [DTyVarBndrSpec]+matchUpSigWithDecl = go_fun_args Map.empty+ where+ go_fun_args ::+ DSubst+ -- ^ A substitution from the names of @forall@-bound variables in the+ -- standalone kind signature to corresponding binder names in the+ -- user-written binders. (See the Haddocks for `singDataSAK` for an+ -- explanation of why we perform this substitution.) For example:+ --+ -- @+ -- type T :: forall a. forall b -> Maybe (a, b) -> Type+ -- data T @x y z+ -- @+ --+ -- After matching up the @a@ in @forall a.@ with @x@ and+ -- the @b@ in @forall b ->@ with @y@, this substitution will be+ -- extended with @[a :-> x, b :-> y]@. This ensures that we will+ -- produce @Maybe (x, y)@ instead of @Maybe (a, b)@ in+ -- the kind for @z@.+ -> DFunArgs -> [DTyVarBndrVis] -> q [DTyVarBndrSpec]+ go_fun_args _ DFANil [] =+ pure []+ -- This should not happen, per the function's precondition+ go_fun_args _ DFANil data_bndrs =+ fail $ "matchUpSigWithDecl.go_fun_args: Too many binders: " ++ show data_bndrs+ -- GHC now disallows kind-level constraints, per this GHC proposal:+ -- https://github.com/ghc-proposals/ghc-proposals/blob/b0687d96ce8007294173b7f628042ac4260cc738/proposals/0547-no-kind-equalities.rst+ go_fun_args _ (DFACxt{}) _ =+ fail "matchUpSigWithDecl.go_fun_args: Unexpected kind-level constraint"+ go_fun_args subst (DFAForalls (DForallInvis tvbs) sig_args) data_bndrs =+ go_invis_tvbs subst tvbs sig_args data_bndrs+ go_fun_args subst (DFAForalls (DForallVis tvbs) sig_args) data_bndrs =+ go_vis_tvbs subst tvbs sig_args data_bndrs+ go_fun_args subst (DFAAnon anon sig_args) (data_bndr:data_bndrs) = do+ let data_bndr_name = extractTvbName data_bndr+ mb_data_bndr_kind = extractTvbKind data_bndr+ anon' = substType subst anon++ anon'' =+ case mb_data_bndr_kind of+ Nothing -> anon'+ Just data_bndr_kind ->+ let mb_match_subst = matchTy NoIgnore data_bndr_kind anon' in+ maybe data_bndr_kind (`substType` data_bndr_kind) mb_match_subst+ sig_args' <- go_fun_args subst sig_args data_bndrs+ pure $ DKindedTV data_bndr_name SpecifiedSpec anon'' : sig_args'+ -- This should not happen, per precondition (1).+ go_fun_args _ _ [] =+ fail "matchUpSigWithDecl.go_fun_args: Too few binders"++ go_invis_tvbs :: DSubst -> [DTyVarBndrSpec] -> DFunArgs -> [DTyVarBndrVis] -> q [DTyVarBndrSpec]+ go_invis_tvbs subst [] sig_args data_bndrs =+ go_fun_args subst sig_args data_bndrs+ -- This should not happen, per precondition (2).+ go_invis_tvbs _ (_:_) _ [] =+ fail $ "matchUpSigWithDecl.go_invis_tvbs: Too few binders"+ go_invis_tvbs subst (invis_tvb:invis_tvbs) sig_args data_bndrss@(data_bndr:data_bndrs) =+ case extractTvbFlag data_bndr of+ -- If the next data_bndr is required, then we have a invisible forall in+ -- the kind without a corresponding invisible @-binder, which is+ -- allowed. In this case, we simply apply the substitution and recurse.+ BndrReq -> do+ let (subst', invis_tvb') = substTvb subst invis_tvb+ sig_args' <- go_invis_tvbs subst' invis_tvbs sig_args data_bndrss+ pure $ invis_tvb' : sig_args'+ -- If the next data_bndr is an invisible @-binder, then we must match it+ -- against the invisible forall–bound variable in the kind.+ BndrInvis -> do+ let (subst', sig_tvb) = match_tvbs subst invis_tvb data_bndr+ sig_args' <- go_invis_tvbs subst' invis_tvbs sig_args data_bndrs+ pure (sig_tvb : sig_args')++ go_vis_tvbs :: DSubst -> [DTyVarBndrUnit] -> DFunArgs -> [DTyVarBndrVis] -> q [DTyVarBndrSpec]+ go_vis_tvbs subst [] sig_args data_bndrs =+ go_fun_args subst sig_args data_bndrs+ -- This should not happen, per precondition (1).+ go_vis_tvbs _ (_:_) _ [] =+ fail $ "matchUpSigWithDecl.go_vis_tvbs: Too few binders"+ go_vis_tvbs subst (vis_tvb:vis_tvbs) sig_args (data_bndr:data_bndrs) = do+ case extractTvbFlag data_bndr of+ -- If the next data_bndr is required, then we must match it against the+ -- visible forall–bound variable in the kind.+ BndrReq -> do+ let (subst', sig_tvb) = match_tvbs subst vis_tvb data_bndr+ sig_args' <- go_vis_tvbs subst' vis_tvbs sig_args data_bndrs+ pure (sig_tvb : sig_args')+ -- We have a visible forall in the kind, but an invisible @-binder as+ -- the next data_bndr. This is ill kinded, so throw an error.+ BndrInvis ->+ fail $ "matchUpSigWithDecl.go_vis_tvbs: Expected visible binder, encountered invisible binder: "+ ++ show data_bndr++ -- @match_tvbs subst sig_tvb data_bndr@ will match the kind of @data_bndr@+ -- against the kind of @sig_tvb@ to produce a new kind. This function+ -- produces two values as output:+ --+ -- 1. A new @subst@ that has been extended such that the name of @sig_tvb@+ -- maps to the name of @data_bndr@. (See the Haddocks for the 'DSubst'+ -- argument to @go_fun_args@ for an explanation of why we do this.)+ --+ -- 2. A 'DTyVarBndrSpec' that has the name of @data_bndr@, but with the new+ -- kind resulting from matching.+ match_tvbs :: DSubst -> DTyVarBndr flag -> DTyVarBndrVis -> (DSubst, DTyVarBndrSpec)+ match_tvbs subst sig_tvb data_bndr =+ let data_bndr_name = extractTvbName data_bndr+ mb_data_bndr_kind = extractTvbKind data_bndr++ sig_tvb_name = extractTvbName sig_tvb+ mb_sig_tvb_kind = substType subst <$> extractTvbKind sig_tvb++ mb_kind :: Maybe DKind+ mb_kind =+ case (mb_data_bndr_kind, mb_sig_tvb_kind) of+ (Nothing, Nothing) -> Nothing+ (Just data_bndr_kind, Nothing) -> Just data_bndr_kind+ (Nothing, Just sig_tvb_kind) -> Just sig_tvb_kind+ (Just data_bndr_kind, Just sig_tvb_kind) -> do+ match_subst <- matchTy NoIgnore data_bndr_kind sig_tvb_kind+ Just $ substType match_subst data_bndr_kind++ subst' = Map.insert sig_tvb_name (DVarT data_bndr_name) subst+ sig_tvb' = case mb_kind of+ Nothing -> DPlainTV data_bndr_name SpecifiedSpec+ Just kind -> DKindedTV data_bndr_name SpecifiedSpec kind in++ (subst', sig_tvb')++-- This is heavily inspired by the `swizzleTcb` function in GHC:+-- https://gitlab.haskell.org/ghc/ghc/-/blob/cec903899234bf9e25ea404477ba846ac1e963bb/compiler/GHC/Tc/Gen/HsType.hs#L2741-2755+swizzleTvb :: Map Name Name -> DSubst -> DTyVarBndrSpec -> (DSubst, DTyVarBndrSpec)+swizzleTvb swizzle_env subst tvb =+ (subst', tvb2)+ where+ subst' = Map.insert tvb_name (DVarT (extractTvbName tvb2)) subst+ tvb_name = extractTvbName tvb+ tvb1 = mapDTVKind (substType subst) tvb+ tvb2 =+ case Map.lookup tvb_name swizzle_env of+ Just user_name -> mapDTVName (const user_name) tvb1+ Nothing -> tvb1++{-+Note [singletons-th and record selectors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Record selectors are annoying to deal with in singletons-th for various reasons:++1. There is no record syntax at the type level, so promoting code that involves+ records in some way is not straightforward.+2. One can define record selectors for singled data types, but they're rife+ with peril. Some pitfalls include:++ * Singling record updates often produces code that does not typecheck. For+ example, this works:++ let i = Identity True in i { runIdentity = False }++ But this does /not/ work:++ let si = SIdentity STrue in si { sRunIdentity = SFalse }++ error:+ • Record update for insufficiently polymorphic field:+ sRunIdentity :: Sing n+ • In the expression: si {sRunIdentity = SFalse}+ In the expression:+ let si = SIdentity STrue in si {sRunIdentity = SFalse}++ Ugh. See GHC#16501.++ * Singling a data type with multiple constructors that share a record+ selector name will /also/ not typecheck. While this works:++ data X = X1 {y :: Bool} | X2 {y :: Bool}++ This does not:++ data SX :: X -> Type where+ SX1 :: { sY :: Sing n } -> SX ('X1 n)+ SY1 :: { sY :: Sing n } -> SX ('X2 n)++ error:+ • Constructors SX1 and SX2 have a common field ‘sY’,+ but have different result types+ • In the data type declaration for ‘SX’++ Double ugh. See GHC#8673/GHC#12159.++ * Even if a data type only has a single constructor with record selectors,+ singling it can induce headaches. One might be tempted to single this type:++ newtype Unit = MkUnit { runUnit :: () }++ With this code:++ data SUnit :: Unit -> Type where+ SMkUnit :: { sRunUnit :: Sing u } -> SUnit (MkUnit u)++ Somewhat surprisingly, the type of sRunUnit:++ sRunUnit :: Sing (MkUnit u) -> Sing u++ Is not general enough to handle common uses of record selectors. For+ example, if you try to single this function:++ f :: Unit -> ()+ f = runUnit++ Then the resulting code:++ sF :: Sing (x :: Unit) -> Sing (F x :: ())+ sF = sRunUnit++ Will not typecheck. Note that sRunUnit expects an argument of type+ `Sing (MkUnit u)`, but there is no way to know a priori that the `x` in+ `Sing (x :: Unit)` is `MkUnit u` without pattern-matching on SMkUnit.++Hopefully I have convinced you that handling records in singletons-th is a bit of+a nightmare. Thankfully, there is a simple trick to avoid most of the pitfalls+above: just desugar code (using th-desugar) to avoid records!+In more concrete terms, we do the following:++* A record constructions desugars to a normal constructor application. For example:++ MkT{a = x, b = y}++ ==>++ MkT x y++ Something similar occurs for record syntax in patterns.++* A record update desugars to a case expression. For example:++ t{a = x}++ ==>++ case t of MkT _ y => MkT x y++We can't easily desugar away all uses of records, however. After all, records+can be used as ordinary functions as well. We leave such uses of records alone+when desugaring and accommodate them during promotion and singling by generating+"manual" record selectors. As a running example, consider the earlier Unit example:++ newtype Unit = MkUnit { runUnit :: () }++When singling Unit, we do not give SMkUnit a record selector:++ data SUnit :: Unit -> Type where+ SMkUnit :: Sing u -> SUnit (MkUnit u)++Instead, we generate a top-level function that behaves equivalently to runUnit.+This function then gets promoted and singled (in D.S.TH.Promote.promoteDecs and+D.S.TH.Single.singTopLevelDecs):++ type family RunUnit (x :: Unit) :: () where+ RunUnit (MkUnit x) = x++ sRunUnit :: Sing (x :: Unit) -> Sing (RunUnit x :: ())+ sRunUnit (SMkUnit sx) = sx++Now promoting/singling uses of runUnit as an ordinary function work as expected+since the types of RunUnit/sRunUnit are sufficiently general. This technique also+scales up to data types with multiple constructors sharing a record selector name.+For instance, in the earlier X example:++ data X = X1 {y :: Bool} | X2 {y :: Bool}++We would promote/single `y` like so:++ type family Y (x :: X) :: Bool where+ Y (X1 y) = y+ Y (X2 y) = y++ sY :: Sing (x :: X) -> Sing (Y x :: Bool)+ sY (SX1 sy) = sy+ sY (SX2 sy) = sy++Manual record selectors cannot be used in record constructions or updates, but+for most use cases this won't be an issue, since singletons-th makes an effort to+desugar away fancy uses of records anyway. The only time this would bite is if+you wanted to use record syntax in hand-written singletons code.+-}
src/Data/Singletons/TH/Single/Decide.hs view
@@ -1,112 +1,134 @@-{- Data/Singletons/TH/Single/Decide.hs - -(c) Richard Eisenberg 2014 -rae@cs.brynmawr.edu - -Defines functions to generate SDecide instances, as well as TestEquality and -TestCoercion instances that leverage SDecide. --} - -module Data.Singletons.TH.Single.Decide where - -import Language.Haskell.TH.Syntax -import Language.Haskell.TH.Desugar -import Data.Singletons.TH.Deriving.Infer -import Data.Singletons.TH.Names -import Data.Singletons.TH.Options -import Data.Singletons.TH.Promote.Type -import Data.Singletons.TH.Util -import Control.Monad - --- Make an instance of SDecide. -mkDecideInstance :: OptionsMonad q => Maybe DCxt -> DType - -> [DCon] -- ^ The /original/ constructors (for inferring the instance context) - -> [DCon] -- ^ The /singletons/ constructors - -> q DDec -mkDecideInstance mb_ctxt data_ty ctors sctors = do - let sctorPairs = [ (sc1, sc2) | sc1 <- sctors, sc2 <- sctors ] - methClauses <- if null sctors - then (:[]) <$> mkEmptyDecideMethClause - else mapM mkDecideMethClause sctorPairs - constraints <- inferConstraintsDef mb_ctxt (DConT sDecideClassName) data_ty ctors - data_ki <- promoteType data_ty - return $ DInstanceD Nothing Nothing - constraints - (DAppT (DConT sDecideClassName) data_ki) - [DLetDec $ DFunD sDecideMethName methClauses] - -data TestInstance = TestEquality - | TestCoercion - --- Make an instance of TestEquality or TestCoercion by leveraging SDecide. -mkTestInstance :: OptionsMonad q => Maybe DCxt -> DType - -> Name -- ^ The name of the data type - -> [DCon] -- ^ The /original/ constructors (for inferring the instance context) - -> TestInstance -> q DDec -mkTestInstance mb_ctxt data_ty data_name ctors ti = do - opts <- getOptions - constraints <- inferConstraintsDef mb_ctxt (DConT sDecideClassName) data_ty ctors - data_ki <- promoteType data_ty - pure $ DInstanceD Nothing Nothing - constraints - (DAppT (DConT tiClassName) - (DConT (singledDataTypeName opts data_name) - `DSigT` (DArrowT `DAppT` data_ki `DAppT` DConT typeKindName))) - [DLetDec $ DFunD tiMethName - [DClause [] (DVarE tiDefaultName)]] - where - (tiClassName, tiMethName, tiDefaultName) = - case ti of - TestEquality -> (testEqualityClassName, testEqualityMethName, decideEqualityName) - TestCoercion -> (testCoercionClassName, testCoercionMethName, decideCoercionName) - -mkDecideMethClause :: Quasi q => (DCon, DCon) -> q DClause -mkDecideMethClause (c1, c2) - | lname == rname = - if lNumArgs == 0 - then return $ DClause [DConP lname [] [], DConP rname [] []] - (DAppE (DConE provedName) (DConE reflName)) - else do - lnames <- replicateM lNumArgs (qNewName "a") - rnames <- replicateM lNumArgs (qNewName "b") - contra <- qNewName "contra" - let lpats = map DVarP lnames - rpats = map DVarP rnames - lvars = map DVarE lnames - rvars = map DVarE rnames - refl <- qNewName "refl" - return $ DClause - [DConP lname [] lpats, DConP rname [] rpats] - (DCaseE (mkTupleDExp $ - zipWith (\l r -> foldExp (DVarE sDecideMethName) [l, r]) - lvars rvars) - ((DMatch (mkTupleDPat (replicate lNumArgs - (DConP provedName [] [DConP reflName [] []]))) - (DAppE (DConE provedName) (DConE reflName))) : - [DMatch (mkTupleDPat (replicate i DWildP ++ - DConP disprovedName [] [DVarP contra] : - replicate (lNumArgs - i - 1) DWildP)) - (DAppE (DConE disprovedName) - (DLamE [refl] $ - DCaseE (DVarE refl) - [DMatch (DConP reflName [] []) $ - (DAppE (DVarE contra) - (DConE reflName))])) - | i <- [0..lNumArgs-1] ])) - - | otherwise = do - x <- qNewName "x" - return $ DClause - [DConP lname [] (replicate lNumArgs DWildP), - DConP rname [] (replicate rNumArgs DWildP)] - (DAppE (DConE disprovedName) (DLamE [x] (DCaseE (DVarE x) []))) - - where - (lname, lNumArgs) = extractNameArgs c1 - (rname, rNumArgs) = extractNameArgs c2 - -mkEmptyDecideMethClause :: Quasi q => q DClause -mkEmptyDecideMethClause = do - x <- qNewName "x" - pure $ DClause [DVarP x, DWildP] - $ DConE provedName `DAppE` DCaseE (DVarE x) [] +{- Data/Singletons/TH/Single/Decide.hs++(c) Richard Eisenberg 2014+rae@cs.brynmawr.edu++Defines functions to generate SDecide instances, as well as TestEquality and+TestCoercion instances that leverage SDecide.+-}++module Data.Singletons.TH.Single.Decide where++import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Desugar+import Data.Singletons.TH.Deriving.Infer+import Data.Singletons.TH.Names+import Data.Singletons.TH.Options+import Data.Singletons.TH.Promote.Type+import Data.Singletons.TH.Util+import Control.Monad++-- Make an instance of SDecide.+mkDecideInstance :: OptionsMonad q => Maybe DCxt -> DType+ -> [DCon] -- ^ The /original/ constructors (for inferring the instance context)+ -> [DCon] -- ^ The /singletons/ constructors+ -> q DDec+mkDecideInstance mb_ctxt data_ty ctors sctors = do+ let sctorPairs = [ (sc1, sc2) | sc1 <- sctors, sc2 <- sctors ]+ methClauses <- if null sctors+ then (:[]) <$> mkEmptyDecideMethClause+ else mapM mkDecideMethClause sctorPairs+ constraints <- inferConstraintsDef mb_ctxt (DConT sDecideClassName) data_ty ctors+ data_ki <- promoteType data_ty+ return $ DInstanceD Nothing Nothing+ constraints+ (DAppT (DConT sDecideClassName) data_ki)+ [DLetDec $ DFunD sDecideMethName methClauses]++-- Make a boilerplate Eq instance for a singleton type, e.g.,+--+-- @+-- instance Eq (SExample (z :: Example a)) where+-- _ == _ = True+-- @+mkEqInstanceForSingleton :: OptionsMonad q+ => DType+ -> Name+ -- ^ The name of the data type+ -> q DDec+mkEqInstanceForSingleton data_ty data_name = do+ opts <- getOptions+ z <- qNewName "z"+ data_ki <- promoteType data_ty+ let sdata_name = singledDataTypeName opts data_name+ pure $ DInstanceD Nothing Nothing []+ (DAppT (DConT eqName) (DConT sdata_name `DAppT` DSigT (DVarT z) data_ki))+ [DLetDec $+ DFunD equalsName+ [DClause [DWildP, DWildP] (DConE trueName)]]++data TestInstance = TestEquality+ | TestCoercion++-- Make an instance of TestEquality or TestCoercion by leveraging SDecide.+mkTestInstance :: OptionsMonad q => Maybe DCxt -> DType+ -> Name -- ^ The name of the data type+ -> [DCon] -- ^ The /original/ constructors (for inferring the instance context)+ -> TestInstance -> q DDec+mkTestInstance mb_ctxt data_ty data_name ctors ti = do+ opts <- getOptions+ constraints <- inferConstraintsDef mb_ctxt (DConT sDecideClassName) data_ty ctors+ data_ki <- promoteType data_ty+ pure $ DInstanceD Nothing Nothing+ constraints+ (DAppT (DConT tiClassName)+ (DConT (singledDataTypeName opts data_name)+ `DSigT` (DArrowT `DAppT` data_ki `DAppT` DConT typeKindName)))+ [DLetDec $ DFunD tiMethName+ [DClause [] (DVarE tiDefaultName)]]+ where+ (tiClassName, tiMethName, tiDefaultName) =+ case ti of+ TestEquality -> (testEqualityClassName, testEqualityMethName, decideEqualityName)+ TestCoercion -> (testCoercionClassName, testCoercionMethName, decideCoercionName)++mkDecideMethClause :: Quasi q => (DCon, DCon) -> q DClause+mkDecideMethClause (c1, c2)+ | lname == rname =+ if lNumArgs == 0+ then return $ DClause [DConP lname [] [], DConP rname [] []]+ (DAppE (DConE provedName) (DConE reflName))+ else do+ lnames <- replicateM lNumArgs (qNewName "a")+ rnames <- replicateM lNumArgs (qNewName "b")+ contra <- qNewName "contra"+ let lpats = map DVarP lnames+ rpats = map DVarP rnames+ lvars = map DVarE lnames+ rvars = map DVarE rnames+ refl <- qNewName "refl"+ return $ DClause+ [DConP lname [] lpats, DConP rname [] rpats]+ (DCaseE (mkTupleDExp $+ zipWith (\l r -> foldExp (DVarE sDecideMethName) [l, r])+ lvars rvars)+ ((DMatch (mkTupleDPat (replicate lNumArgs+ (DConP provedName [] [DConP reflName [] []])))+ (DAppE (DConE provedName) (DConE reflName))) :+ [DMatch (mkTupleDPat (replicate i DWildP +++ DConP disprovedName [] [DVarP contra] :+ replicate (lNumArgs - i - 1) DWildP))+ (DAppE (DConE disprovedName)+ (DLamE [refl] $+ DCaseE (DVarE refl)+ [DMatch (DConP reflName [] []) $+ (DAppE (DVarE contra)+ (DConE reflName))]))+ | i <- [0..lNumArgs-1] ]))++ | otherwise = do+ x <- qNewName "x"+ return $ DClause+ [DConP lname [] (replicate lNumArgs DWildP),+ DConP rname [] (replicate rNumArgs DWildP)]+ (DAppE (DConE disprovedName) (DLamE [x] (DCaseE (DVarE x) [])))++ where+ (lname, lNumArgs) = extractNameArgs c1+ (rname, rNumArgs) = extractNameArgs c2++mkEmptyDecideMethClause :: Quasi q => q DClause+mkEmptyDecideMethClause = do+ x <- qNewName "x"+ pure $ DClause [DVarP x, DWildP]+ $ DConE provedName `DAppE` DCaseE (DVarE x) []
src/Data/Singletons/TH/Single/Defun.hs view
@@ -1,238 +1,238 @@------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TH.Single.Defun --- Copyright : (C) 2018 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Creates 'SingI' instances for promoted types' defunctionalization symbols. --- ------------------------------------------------------------------------------ - -module Data.Singletons.TH.Single.Defun (singDefuns) where - -import Control.Monad -import Data.Foldable -import Data.Singletons.TH.Names -import Data.Singletons.TH.Options -import Data.Singletons.TH.Promote.Defun -import Data.Singletons.TH.Single.Monad -import Data.Singletons.TH.Single.Type -import Data.Singletons.TH.Util -import Language.Haskell.TH.Desugar -import Language.Haskell.TH.Syntax - --- Given the Name of something, take the defunctionalization symbols for its --- promoted counterpart and create SingI{,1,2} instances for them. As a concrete --- example, if you have: --- --- foo :: Eq a => a -> a -> Bool --- --- Then foo's promoted counterpart, Foo, will have two defunctionalization --- symbols: --- --- FooSym0 :: a ~> a ~> Bool --- FooSym1 :: a -> a ~> Bool --- --- We can declare SingI and SingI1 instances for these two symbols like so: --- --- instance SEq a => SingI (FooSym0 :: a ~> a ~> Bool) where --- sing = singFun2 sFoo --- --- instance (SEq a, SingI x) => SingI (FooSym1 x :: a ~> Bool) where --- sing = singFun1 (sFoo (sing @_ @x)) --- --- instance SEq a => SingI1 (FooSym1 :: a -> a ~> Bool) where --- liftSing s = singFun1 (sFoo s) --- --- Only FooSym1 will have a SingI1 instance, as unlike FooSym0, it is able to --- be partially applied (using normal function application) to a single --- argument. Neither FooSym0 nor FooSym1 can be partially applied to two --- arguments, so neither will receive a SingI2 instance. --- --- Note that singDefuns takes Maybe DKinds for the promoted argument and result --- types, in case we have an entity whose type needs to be inferred. --- See Note [singDefuns and type inference]. -singDefuns :: Name -- The Name of the thing to promote. - -> NameSpace -- Whether the above Name is a value, data constructor, - -- or a type constructor. - -> DCxt -- The type's context. - -> [Maybe DKind] -- The promoted argument types (if known). - -> Maybe DKind -- The promoted result type (if known). - -> SgM [DDec] -singDefuns n ns ty_ctxt mb_ty_args mb_ty_res = - case mb_ty_args of - [] -> pure [] -- If a function has no arguments, then it has no - -- defunctionalization symbols, so there's nothing to be done. - _ -> do opts <- getOptions - sty_ctxt <- mapM singPred ty_ctxt - names <- replicateM (length mb_ty_args) $ qNewName "d" - let tvbs = zipWith inferMaybeKindTV names mb_ty_args - (_, insts) <- go opts 0 sty_ctxt [] tvbs - pure insts - where - num_ty_args :: Int - num_ty_args = length mb_ty_args - - -- The inner loop. @go n ctxt arg_tvbs res_tvbs@ returns @(m_result, insts)@. - -- Using one particular example: - -- - -- @ - -- instance (SingI a, SingI b, SEq c, SEq d) => - -- SingI (ExampleSym2 (x :: a) (y :: b) :: c ~> d ~> Type) where ... - -- @ - -- - -- We have: - -- - -- * @n@ is 2. This is incremented in each iteration of `go`. - -- - -- * @ctxt@ is (SEq c, SEq d). The (SingI a, SingI b) part of the instance - -- context is added separately. - -- - -- * @arg_tvbs@ is [(x :: a), (y :: b)]. - -- - -- * @res_tvbs@ is [(z :: c), (w :: d)]. The kinds of these type variable - -- binders appear in the result kind. - -- - -- * @m_result@ is `Just (c ~> d ~> Type)`. @m_result@ is returned so - -- that earlier defunctionalization symbols can build on the result - -- kinds of later symbols. For instance, ExampleSym1 would get the - -- result kind `b ~> c ~> d ~> Type` by prepending `b` to ExampleSym2's - -- result kind `c ~> d ~> Type`. - -- - -- * @insts@ are all of the instance declarations corresponding to - -- ExampleSym2 and later defunctionalization symbols. This is the main - -- payload of the function. - -- - -- This function is quadratic because it appends a variable at the end of - -- the @arg_tvbs@ list at each iteration. In practice, this is unlikely - -- to be a performance bottleneck since the number of arguments rarely - -- gets to be that large. - go :: Options -> Int -> DCxt -> [DTyVarBndrUnit] -> [DTyVarBndrUnit] - -> SgM (Maybe DKind, [DDec]) - go _ _ _ _ [] = pure (mb_ty_res, []) - go opts sym_num sty_ctxt arg_tvbs (res_tvb:res_tvbs) = do - (mb_res, insts) <- go opts (sym_num + 1) sty_ctxt (arg_tvbs ++ [res_tvb]) res_tvbs - new_insts <- mapMaybeM (mb_new_inst mb_res) [0, 1, 2] - pure (mk_inst_kind [] res_tvb mb_res, new_insts ++ insts) - where - sing_fun_num :: Int - sing_fun_num = num_ty_args - sym_num - - -- Construct the arrow kind used to annotate the defunctionalization - -- symbol. For example, this constructs the `a -> b -> c ~> Bool` in - -- `SingI1 (FooSym1 :: a -> b -> c ~> Bool)`, where: - -- - -- * The first argument to `mk_inst_kind` gives the kinds [a, b], which - -- are used with normal function arrows. - -- * The second argumen to `mk_inst_kind` gives the kind `c`, which is - -- used with a defunctionalized function arrow. - -- - -- If any of the argument kinds or result kind isn't known (i.e., is - -- Nothing), then we opt not to construct this arrow kind altogether. - -- See Note [singDefuns and type inference] - mk_inst_kind :: [DTyVarBndrUnit] -> DTyVarBndrUnit -> Maybe DKind -> Maybe DKind - mk_inst_kind funTvbs defunTvb mbKind = - foldr buildFunArrow_maybe - (buildTyFunArrow_maybe (extractTvbKind defunTvb) mbKind) - (map extractTvbKind funTvbs) - - -- @mb_new_inst mb_res k@ returns 'Just' an instance of @SingI<k>@ if - -- @k@ is less than or equal to the number of arguments to which the - -- defunctionalization symbol can be partially applied using normal - -- function application. Otherwise, it returns 'Nothing'. - mb_new_inst :: Maybe DKind -> Int -> SgM (Maybe DDec) - mb_new_inst mb_res k - | k <= sym_num - = do vs <- replicateM k $ qNewName "s" - let sing_vs = zipWith (\v arg_tvb -> - DSigP (DVarP v) - (singFamily `DAppT` dTyVarBndrToDType arg_tvb)) - vs last_arg_tvbs - pure $ Just $ - DInstanceD Nothing Nothing - (sty_ctxt ++ singI_ctxt) - (DConT (mkSingIName k) `DAppT` mk_inst_ty (mk_defun_inst_ty init_arg_tvbs)) - [ DLetDec $ DFunD (mkSingMethName k) - [ DClause sing_vs - $ wrapSingFun sing_fun_num (mk_defun_inst_ty arg_tvbs) - $ mk_sing_fun_expr sing_exp vs - ] - ] - | otherwise - = pure Nothing - where - init_arg_tvbs, last_arg_tvbs :: [DTyVarBndrUnit] - (init_arg_tvbs, last_arg_tvbs) = splitAt (sym_num - k) arg_tvbs - - mk_defun_inst_ty :: [DTyVarBndrUnit] -> DType - mk_defun_inst_ty tvbs = - foldType (DConT (defunctionalizedName opts n sym_num)) - (map dTyVarBndrToDType tvbs) - - sing_exp :: DExp - sing_exp = case ns of - DataName -> DConE $ singledDataConName opts n - _ -> DVarE $ singledValueName opts n - - mk_sing_fun_expr :: DExp -> [Name] -> DExp - mk_sing_fun_expr sing_expr vs = - foldl' DAppE sing_expr - (map (\arg_tvb -> DVarE singMethName `DAppTypeE` - DVarT (extractTvbName arg_tvb)) - init_arg_tvbs ++ - map DVarE vs) - - singI_ctxt :: DCxt - singI_ctxt = map (DAppT (DConT singIName) . tvbToType) init_arg_tvbs - - mk_inst_ty :: DType -> DType - mk_inst_ty inst_head - = case mk_inst_kind last_arg_tvbs res_tvb mb_res of - Just inst_kind -> inst_head `DSigT` inst_kind - Nothing -> inst_head - --- Shorthand for building (k1 -> k2) -buildFunArrow :: DKind -> DKind -> DKind -buildFunArrow k1 k2 = DArrowT `DAppT` k1 `DAppT` k2 - -buildFunArrow_maybe :: Maybe DKind -> Maybe DKind -> Maybe DKind -buildFunArrow_maybe m_k1 m_k2 = buildFunArrow <$> m_k1 <*> m_k2 - -{- -Note [singDefuns and type inference] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following function: - - foo :: a -> Bool - foo _ = True - -singDefuns would give the following SingI instance for FooSym0, with an -explicit kind signature: - - instance SingI (FooSym0 :: a ~> Bool) where ... - -What happens if we leave off the type signature for foo? - - foo _ = True - -Can singDefuns still do its job? Yes! It will simply generate: - - instance SingI FooSym0 where ... - -In general, if any of the promoted argument or result types given to singDefun -are Nothing, then we avoid crafting an explicit kind signature. You might worry -that this could lead to SingI instances being generated that GHC cannot infer -the type for, such as: - - bar x = x == x - ==> - instance SingI BarSym0 -- Missing an SEq constraint? - -This is true, but also not unprecedented, as the singled version of bar, sBar, -will /also/ fail to typecheck due to a missing SEq constraint. Therefore, this -design choice fits within the existing tradition of type inference in -singletons-th. --} +-----------------------------------------------------------------------------+-- |+-- Module : Data.Singletons.TH.Single.Defun+-- Copyright : (C) 2018 Ryan Scott+-- License : BSD-style (see LICENSE)+-- Maintainer : Ryan Scott+-- Stability : experimental+-- Portability : non-portable+--+-- Creates 'SingI' instances for promoted types' defunctionalization symbols.+--+-----------------------------------------------------------------------------++module Data.Singletons.TH.Single.Defun (singDefuns) where++import Control.Monad+import Data.Foldable+import Data.Singletons.TH.Names+import Data.Singletons.TH.Options+import Data.Singletons.TH.Promote.Defun+import Data.Singletons.TH.Single.Monad+import Data.Singletons.TH.Single.Type+import Data.Singletons.TH.Util+import Language.Haskell.TH.Desugar+import Language.Haskell.TH.Syntax++-- Given the Name of something, take the defunctionalization symbols for its+-- promoted counterpart and create SingI{,1,2} instances for them. As a concrete+-- example, if you have:+--+-- foo :: Eq a => a -> a -> Bool+--+-- Then foo's promoted counterpart, Foo, will have two defunctionalization+-- symbols:+--+-- FooSym0 :: a ~> a ~> Bool+-- FooSym1 :: a -> a ~> Bool+--+-- We can declare SingI and SingI1 instances for these two symbols like so:+--+-- instance SEq a => SingI (FooSym0 :: a ~> a ~> Bool) where+-- sing = singFun2 sFoo+--+-- instance (SEq a, SingI x) => SingI (FooSym1 x :: a ~> Bool) where+-- sing = singFun1 (sFoo (sing @_ @x))+--+-- instance SEq a => SingI1 (FooSym1 :: a -> a ~> Bool) where+-- liftSing s = singFun1 (sFoo s)+--+-- Only FooSym1 will have a SingI1 instance, as unlike FooSym0, it is able to+-- be partially applied (using normal function application) to a single+-- argument. Neither FooSym0 nor FooSym1 can be partially applied to two+-- arguments, so neither will receive a SingI2 instance.+--+-- Note that singDefuns takes Maybe DKinds for the promoted argument and result+-- types, in case we have an entity whose type needs to be inferred.+-- See Note [singDefuns and type inference].+singDefuns :: Name -- The Name of the thing to promote.+ -> NameSpace -- Whether the above Name is a value, data constructor,+ -- or a type constructor.+ -> DCxt -- The type's context.+ -> [Maybe DKind] -- The promoted argument types (if known).+ -> Maybe DKind -- The promoted result type (if known).+ -> SgM [DDec]+singDefuns n ns ty_ctxt mb_ty_args mb_ty_res =+ case mb_ty_args of+ [] -> pure [] -- If a function has no arguments, then it has no+ -- defunctionalization symbols, so there's nothing to be done.+ _ -> do opts <- getOptions+ sty_ctxt <- mapM singPred ty_ctxt+ names <- replicateM (length mb_ty_args) $ qNewName "d"+ let tvbs = zipWith inferMaybeKindTV names mb_ty_args+ (_, insts) <- go opts 0 sty_ctxt [] tvbs+ pure insts+ where+ num_ty_args :: Int+ num_ty_args = length mb_ty_args++ -- The inner loop. @go n ctxt arg_tvbs res_tvbs@ returns @(m_result, insts)@.+ -- Using one particular example:+ --+ -- @+ -- instance (SingI a, SingI b, SEq c, SEq d) =>+ -- SingI (ExampleSym2 (x :: a) (y :: b) :: c ~> d ~> Type) where ...+ -- @+ --+ -- We have:+ --+ -- * @n@ is 2. This is incremented in each iteration of `go`.+ --+ -- * @ctxt@ is (SEq c, SEq d). The (SingI a, SingI b) part of the instance+ -- context is added separately.+ --+ -- * @arg_tvbs@ is [(x :: a), (y :: b)].+ --+ -- * @res_tvbs@ is [(z :: c), (w :: d)]. The kinds of these type variable+ -- binders appear in the result kind.+ --+ -- * @m_result@ is `Just (c ~> d ~> Type)`. @m_result@ is returned so+ -- that earlier defunctionalization symbols can build on the result+ -- kinds of later symbols. For instance, ExampleSym1 would get the+ -- result kind `b ~> c ~> d ~> Type` by prepending `b` to ExampleSym2's+ -- result kind `c ~> d ~> Type`.+ --+ -- * @insts@ are all of the instance declarations corresponding to+ -- ExampleSym2 and later defunctionalization symbols. This is the main+ -- payload of the function.+ --+ -- This function is quadratic because it appends a variable at the end of+ -- the @arg_tvbs@ list at each iteration. In practice, this is unlikely+ -- to be a performance bottleneck since the number of arguments rarely+ -- gets to be that large.+ go :: Options -> Int -> DCxt -> [DTyVarBndrUnit] -> [DTyVarBndrUnit]+ -> SgM (Maybe DKind, [DDec])+ go _ _ _ _ [] = pure (mb_ty_res, [])+ go opts sym_num sty_ctxt arg_tvbs (res_tvb:res_tvbs) = do+ (mb_res, insts) <- go opts (sym_num + 1) sty_ctxt (arg_tvbs ++ [res_tvb]) res_tvbs+ new_insts <- mapMaybeM (mb_new_inst mb_res) [0, 1, 2]+ pure (mk_inst_kind [] res_tvb mb_res, new_insts ++ insts)+ where+ sing_fun_num :: Int+ sing_fun_num = num_ty_args - sym_num++ -- Construct the arrow kind used to annotate the defunctionalization+ -- symbol. For example, this constructs the `a -> b -> c ~> Bool` in+ -- `SingI1 (FooSym1 :: a -> b -> c ~> Bool)`, where:+ --+ -- * The first argument to `mk_inst_kind` gives the kinds [a, b], which+ -- are used with normal function arrows.+ -- * The second argumen to `mk_inst_kind` gives the kind `c`, which is+ -- used with a defunctionalized function arrow.+ --+ -- If any of the argument kinds or result kind isn't known (i.e., is+ -- Nothing), then we opt not to construct this arrow kind altogether.+ -- See Note [singDefuns and type inference]+ mk_inst_kind :: [DTyVarBndrUnit] -> DTyVarBndrUnit -> Maybe DKind -> Maybe DKind+ mk_inst_kind funTvbs defunTvb mbKind =+ foldr buildFunArrow_maybe+ (buildTyFunArrow_maybe (extractTvbKind defunTvb) mbKind)+ (map extractTvbKind funTvbs)++ -- @mb_new_inst mb_res k@ returns 'Just' an instance of @SingI<k>@ if+ -- @k@ is less than or equal to the number of arguments to which the+ -- defunctionalization symbol can be partially applied using normal+ -- function application. Otherwise, it returns 'Nothing'.+ mb_new_inst :: Maybe DKind -> Int -> SgM (Maybe DDec)+ mb_new_inst mb_res k+ | k <= sym_num+ = do vs <- replicateM k $ qNewName "s"+ let sing_vs = zipWith (\v arg_tvb ->+ DSigP (DVarP v)+ (singFamily `DAppT` dTyVarBndrToDType arg_tvb))+ vs last_arg_tvbs+ pure $ Just $+ DInstanceD Nothing Nothing+ (sty_ctxt ++ singI_ctxt)+ (DConT (mkSingIName k) `DAppT` mk_inst_ty (mk_defun_inst_ty init_arg_tvbs))+ [ DLetDec $ DFunD (mkSingMethName k)+ [ DClause sing_vs+ $ wrapSingFun sing_fun_num (mk_defun_inst_ty arg_tvbs)+ $ mk_sing_fun_expr sing_exp vs+ ]+ ]+ | otherwise+ = pure Nothing+ where+ init_arg_tvbs, last_arg_tvbs :: [DTyVarBndrUnit]+ (init_arg_tvbs, last_arg_tvbs) = splitAt (sym_num - k) arg_tvbs++ mk_defun_inst_ty :: [DTyVarBndrUnit] -> DType+ mk_defun_inst_ty tvbs =+ foldType (DConT (defunctionalizedName opts n sym_num))+ (map dTyVarBndrToDType tvbs)++ sing_exp :: DExp+ sing_exp = case ns of+ DataName -> DConE $ singledDataConName opts n+ _ -> DVarE $ singledValueName opts n++ mk_sing_fun_expr :: DExp -> [Name] -> DExp+ mk_sing_fun_expr sing_expr vs =+ foldl' DAppE sing_expr+ (map (\arg_tvb -> DVarE singMethName `DAppTypeE`+ DVarT (extractTvbName arg_tvb))+ init_arg_tvbs +++ map DVarE vs)++ singI_ctxt :: DCxt+ singI_ctxt = map (DAppT (DConT singIName) . tvbToType) init_arg_tvbs++ mk_inst_ty :: DType -> DType+ mk_inst_ty inst_head+ = case mk_inst_kind last_arg_tvbs res_tvb mb_res of+ Just inst_kind -> inst_head `DSigT` inst_kind+ Nothing -> inst_head++-- Shorthand for building (k1 -> k2)+buildFunArrow :: DKind -> DKind -> DKind+buildFunArrow k1 k2 = DArrowT `DAppT` k1 `DAppT` k2++buildFunArrow_maybe :: Maybe DKind -> Maybe DKind -> Maybe DKind+buildFunArrow_maybe m_k1 m_k2 = buildFunArrow <$> m_k1 <*> m_k2++{-+Note [singDefuns and type inference]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following function:++ foo :: a -> Bool+ foo _ = True++singDefuns would give the following SingI instance for FooSym0, with an+explicit kind signature:++ instance SingI (FooSym0 :: a ~> Bool) where ...++What happens if we leave off the type signature for foo?++ foo _ = True++Can singDefuns still do its job? Yes! It will simply generate:++ instance SingI FooSym0 where ...++In general, if any of the promoted argument or result types given to singDefun+are Nothing, then we avoid crafting an explicit kind signature. You might worry+that this could lead to SingI instances being generated that GHC cannot infer+the type for, such as:++ bar x = x == x+ ==>+ instance SingI BarSym0 -- Missing an SEq constraint?++This is true, but also not unprecedented, as the singled version of bar, sBar,+will /also/ fail to typecheck due to a missing SEq constraint. Therefore, this+design choice fits within the existing tradition of type inference in+singletons-th.+-}
src/Data/Singletons/TH/Single/Fixity.hs view
@@ -1,170 +1,178 @@-module Data.Singletons.TH.Single.Fixity where - -import Prelude hiding ( exp ) -import Language.Haskell.TH hiding ( cxt ) -import Language.Haskell.TH.Syntax (NameSpace(..), Quasi(..)) -import Data.Singletons.TH.Options -import Data.Singletons.TH.Util -import Language.Haskell.TH.Desugar - --- Single a fixity declaration. -singInfixDecl :: forall q. OptionsMonad q => Name -> Fixity -> q (Maybe DLetDec) -singInfixDecl name fixity = do - opts <- getOptions - mb_ns <- reifyNameSpace name - case mb_ns of - -- If we can't find the Name for some odd reason, - -- fall back to singValName - Nothing -> finish $ singledValueName opts name - Just VarName -> finish $ singledValueName opts name - Just DataName -> finish $ singledDataConName opts name - Just TcClsName -> do - mb_info <- dsReify name - case mb_info of - Just (DTyConI DClassD{} _) - -> finish $ singledClassName opts name - _ -> pure Nothing - -- Don't produce anything for other type constructors (type synonyms, - -- type families, data types, etc.). - -- See [singletons-th and fixity declarations], wrinkle 1. - where - finish :: Name -> q (Maybe DLetDec) - finish = pure . Just . DInfixD fixity - --- Try producing singled fixity declarations for Names by reifying them --- /without/ consulting quoted declarations. If reification fails, recover and --- return the empty list. --- See [singletons-th and fixity declarations], wrinkle 2. -singReifiedInfixDecls :: forall q. OptionsMonad q => [Name] -> q [DDec] -singReifiedInfixDecls = mapMaybeM trySingFixityDeclaration - where - trySingFixityDeclaration :: Name -> q (Maybe DDec) - trySingFixityDeclaration name = - qRecover (return Nothing) $ do - mFixity <- qReifyFixity name - case mFixity of - Nothing -> pure Nothing - Just fixity -> fmap (fmap DLetDec) $ singInfixDecl name fixity - -{- -Note [singletons-th and fixity declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Promoting and singling fixity declarations is surprisingly tricky to get right. -This Note serves as a place to document the insights learned after getting this -wrong at various points. - -As a general rule, when promoting something with a fixity declaration like this -one: - - infixl 5 `foo` - -singletons-th will produce promoted and singled versions of them: - - infixl 5 `Foo` - infixl 5 `sFoo` - -singletons-th will also produce fixity declarations for its defunctionalization -symbols (see Note [Fixity declarations for defunctionalization symbols] in -D.S.TH.Promote.Defun): - - infixl 5 `FooSym0` - infixl 5 `FooSym1` - ... - ------ --- Wrinkle 1: When not to promote/single fixity declarations ------ - -Rules are meant to be broken, and the general rule above is no exception. There -are certain cases where singletons-th does *not* produce promoted or singled -versions of fixity declarations: - -* During promotion, fixity declarations for the following sorts of names will - not receive promoted counterparts: - - - Data types - - Type synonyms - - Type families - - Data constructors - - Infix values - - We exclude the first four because the promoted versions of these names are - the same as the originals, so generating an extra fixity declaration for them - would run the risk of having duplicates, which GHC would reject with an error. - - We exclude infix value because while their promoted versions are different, - they share the same name base. In concrete terms, this: - - $(promote [d| - infixl 4 ### - (###) :: a -> a -> a - |]) - - Is promoted to the following: - - type family (###) (x :: a) (y :: a) :: a where ... - - So giving the type-level (###) a fixity declaration would clash with the - existing one for the value-level (###). - - There *is* a scenario where we should generate a fixity declaration for the - type-level (###), however. Imagine the above example used the `promoteOnly` - function instead of `promote`. Then the type-level (###) would lack a fixity - declaration altogether because the original fixity declaration was discarded - by `promoteOnly`! The same problem would arise if one had to choose between - the `singletons` and `singletonsOnly` functions. - - The difference between `promote` and `promoteOnly` (as well as `singletons` - and `singletonsOnly`) is whether the `genQuotedDecs` option is set to `True` - or `False`, respectively. Therefore, if `genQuotedDecs` is set to `False` - when promoting the fixity declaration for an infix value, we opt to generate - a fixity declaration (with the same name base) so that the type-level version - of that value gets one. - -* During singling, the following things will not have their fixity declarations - singled: - - - Type synonyms or type families. This is because singletons-th does not - generate singled versions of them in the first place (they only receive - defunctionalization symbols). - - - Data types. This is because the singled version of a data type T is - always of the form: - - data ST :: forall a_1 ... a_n. T a_1 ... a_n -> Type where ... - - Regardless of how many arguments T has, ST will have exactly one argument. - This makes is rather pointless to generate a fixity declaration for it. - ------ --- Wrinkle 2: Making sure fixity declarations are promoted/singled properly ------ - -There are two situations where singletons-th must promote/single fixity -declarations: - -1. When quoting code, i.e., with `promote` or `singletons`. -2. When reifying code, i.e., with `genPromotions` or `genSingletons`. - -In the case of (1), singletons-th stores the quoted fixity declarations in the -lde_infix field of LetDecEnv. Therefore, it suffices to call -promoteInfixDecl/singleInfixDecl when processing LetDecEnvs. - -In the case of (2), there is no LetDecEnv to use, so we must instead reify -the fixity declarations and promote/single those. See D.S.TH.Single.Data.singDataD -(which singles data constructors) for a place that does this—we will use -singDataD as a running example for the rest of this section. - -One complication is that code paths like singDataD are invoked in both (1) and -(2). This runs the risk that singletons-th will generate duplicate infix -declarations for data constructors in situation (1), as it will try to single -their fixity declarations once when processing them in LetDecEnvs and again -when reifying them in singDataD. - -To avoid this pitfall, when reifying declarations in singDataD we take care -*not* to consult any quoted declarations when reifying (i.e., we do not use -reifyWithLocals for functions like it). Therefore, it we are in situation (1), -then the reification in singDataD will fail (and recover gracefully), so it -will not produce any singled fixity declarations. Therefore, the only singled -fixity declarations will be produced by processing LetDecEnvs. --} +module Data.Singletons.TH.Single.Fixity where++import Prelude hiding ( exp )+import Language.Haskell.TH hiding ( cxt )+import Language.Haskell.TH.Syntax (NameSpace(..), Quasi(..))+import Data.Singletons.TH.Options+import Data.Singletons.TH.Util+import Language.Haskell.TH.Desugar+import qualified GHC.LanguageExtensions.Type as LangExt++-- Single a fixity declaration.+singInfixDecl :: forall q. OptionsMonad q => Name -> Fixity -> q (Maybe DLetDec)+singInfixDecl name fixity = do+ opts <- getOptions+ fld_sels <- qIsExtEnabled LangExt.FieldSelectors+ mb_ns <- reifyNameSpace name+ case mb_ns of+ -- If we can't find the Name for some odd reason,+ -- fall back to singValName+ Nothing -> finish $ singledValueName opts name+ Just VarName -> finish $ singledValueName opts name+ Just (FldName _)+ | fld_sels -> finish $ singledValueName opts name+ | otherwise -> never_mind+ Just DataName -> finish $ singledDataConName opts name+ Just TcClsName -> do+ mb_info <- dsReify name+ case mb_info of+ Just (DTyConI DClassD{} _)+ -> finish $ singledClassName opts name+ _ -> never_mind+ -- Don't produce anything for other type constructors (type synonyms,+ -- type families, data types, etc.).+ -- See [singletons-th and fixity declarations], wrinkle 1.+ where+ finish :: Name -> q (Maybe DLetDec)+ finish = pure . Just . DInfixD fixity++ never_mind :: q (Maybe DLetDec)+ never_mind = pure Nothing++-- Try producing singled fixity declarations for Names by reifying them+-- /without/ consulting quoted declarations. If reification fails, recover and+-- return the empty list.+-- See [singletons-th and fixity declarations], wrinkle 2.+singReifiedInfixDecls :: forall q. OptionsMonad q => [Name] -> q [DDec]+singReifiedInfixDecls = mapMaybeM trySingFixityDeclaration+ where+ trySingFixityDeclaration :: Name -> q (Maybe DDec)+ trySingFixityDeclaration name =+ qRecover (return Nothing) $ do+ mFixity <- qReifyFixity name+ case mFixity of+ Nothing -> pure Nothing+ Just fixity -> fmap (fmap DLetDec) $ singInfixDecl name fixity++{-+Note [singletons-th and fixity declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Promoting and singling fixity declarations is surprisingly tricky to get right.+This Note serves as a place to document the insights learned after getting this+wrong at various points.++As a general rule, when promoting something with a fixity declaration like this+one:++ infixl 5 `foo`++singletons-th will produce promoted and singled versions of them:++ infixl 5 `Foo`+ infixl 5 `sFoo`++singletons-th will also produce fixity declarations for its defunctionalization+symbols (see Note [Fixity declarations for defunctionalization symbols] in+D.S.TH.Promote.Defun):++ infixl 5 `FooSym0`+ infixl 5 `FooSym1`+ ...++-----+-- Wrinkle 1: When not to promote/single fixity declarations+-----++Rules are meant to be broken, and the general rule above is no exception. There+are certain cases where singletons-th does *not* produce promoted or singled+versions of fixity declarations:++* During promotion, fixity declarations for the following sorts of names will+ not receive promoted counterparts:++ - Data types+ - Type synonyms+ - Type families+ - Data constructors+ - Infix values++ We exclude the first four because the promoted versions of these names are+ the same as the originals, so generating an extra fixity declaration for them+ would run the risk of having duplicates, which GHC would reject with an error.++ We exclude infix value because while their promoted versions are different,+ they share the same name base. In concrete terms, this:++ $(promote [d|+ infixl 4 ###+ (###) :: a -> a -> a+ |])++ Is promoted to the following:++ type family (###) (x :: a) (y :: a) :: a where ...++ So giving the type-level (###) a fixity declaration would clash with the+ existing one for the value-level (###).++ There *is* a scenario where we should generate a fixity declaration for the+ type-level (###), however. Imagine the above example used the `promoteOnly`+ function instead of `promote`. Then the type-level (###) would lack a fixity+ declaration altogether because the original fixity declaration was discarded+ by `promoteOnly`! The same problem would arise if one had to choose between+ the `singletons` and `singletonsOnly` functions.++ The difference between `promote` and `promoteOnly` (as well as `singletons`+ and `singletonsOnly`) is whether the `genQuotedDecs` option is set to `True`+ or `False`, respectively. Therefore, if `genQuotedDecs` is set to `False`+ when promoting the fixity declaration for an infix value, we opt to generate+ a fixity declaration (with the same name base) so that the type-level version+ of that value gets one.++* During singling, the following things will not have their fixity declarations+ singled:++ - Type synonyms or type families. This is because singletons-th does not+ generate singled versions of them in the first place (they only receive+ defunctionalization symbols).++ - Data types. This is because the singled version of a data type T is+ always of the form:++ data ST :: forall a_1 ... a_n. T a_1 ... a_n -> Type where ...++ Regardless of how many arguments T has, ST will have exactly one argument.+ This makes is rather pointless to generate a fixity declaration for it.++-----+-- Wrinkle 2: Making sure fixity declarations are promoted/singled properly+-----++There are two situations where singletons-th must promote/single fixity+declarations:++1. When quoting code, i.e., with `promote` or `singletons`.+2. When reifying code, i.e., with `genPromotions` or `genSingletons`.++In the case of (1), singletons-th stores the quoted fixity declarations in the+lde_infix field of LetDecEnv. Therefore, it suffices to call+promoteInfixDecl/singleInfixDecl when processing LetDecEnvs.++In the case of (2), there is no LetDecEnv to use, so we must instead reify+the fixity declarations and promote/single those. See D.S.TH.Single.Data.singDataD+(which singles data constructors) for a place that does this—we will use+singDataD as a running example for the rest of this section.++One complication is that code paths like singDataD are invoked in both (1) and+(2). This runs the risk that singletons-th will generate duplicate infix+declarations for data constructors in situation (1), as it will try to single+their fixity declarations once when processing them in LetDecEnvs and again+when reifying them in singDataD.++To avoid this pitfall, when reifying declarations in singDataD we take care+*not* to consult any quoted declarations when reifying (i.e., we do not use+reifyWithLocals for functions like it). Therefore, it we are in situation (1),+then the reification in singDataD will fail (and recover gracefully), so it+will not produce any singled fixity declarations. Therefore, the only singled+fixity declarations will be produced by processing LetDecEnvs.+-}
src/Data/Singletons/TH/Single/Monad.hs view
@@ -1,182 +1,205 @@-{-# LANGUAGE TemplateHaskellQuotes #-} - -{- Data/Singletons/TH/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. --} - -module Data.Singletons.TH.Single.Monad ( - SgM, bindLets, bindContext, askContext, lookupVarE, lookupConE, - wrapSingFun, - singM, singDecsM, - emitDecs, emitDecsM - ) where - -import Prelude hiding ( exp ) -import Data.Map ( Map ) -import qualified Data.Map as Map -import Data.Singletons -import Data.Singletons.TH.Options -import Data.Singletons.TH.Promote.Monad ( emitDecs, emitDecsM ) -import Data.Singletons.TH.Util -import Language.Haskell.TH.Syntax hiding ( lift ) -import Language.Haskell.TH.Desugar -import Control.Monad ( liftM2 ) -import Control.Monad.IO.Class ( MonadIO ) -import Control.Monad.Reader ( MonadReader(..), ReaderT(..), asks ) -import Control.Monad.Writer ( MonadWriter, WriterT(..) ) -import Control.Applicative - --- environment during singling -data SgEnv = - SgEnv { sg_options :: Options - , sg_let_binds :: Map Name DExp -- from the *original* name - , sg_context :: DCxt -- See Note [Tracking the current type signature context] - , sg_local_decls :: [Dec] - } - -emptySgEnv :: SgEnv -emptySgEnv = SgEnv { sg_options = defaultOptions - , sg_let_binds = Map.empty - , sg_context = [] - , sg_local_decls = [] - } - --- the singling monad -newtype SgM a = SgM (ReaderT SgEnv (WriterT [DDec] Q) a) - deriving ( Functor, Applicative, Monad - , MonadReader SgEnv, MonadWriter [DDec] - , MonadFail, MonadIO, Quasi ) - -instance DsMonad SgM where - localDeclarations = asks sg_local_decls - -instance OptionsMonad SgM where - getOptions = asks sg_options - -bindLets :: [(Name, DExp)] -> SgM a -> SgM a -bindLets lets1 = - local (\env@(SgEnv { sg_let_binds = lets2 }) -> - env { sg_let_binds = (Map.fromList lets1) `Map.union` lets2 }) - --- Add some constraints to the current type signature context. --- See Note [Tracking the current type signature context] -bindContext :: DCxt -> SgM a -> SgM a -bindContext ctxt1 - = local (\env@(SgEnv { sg_context = ctxt2 }) -> - env { sg_context = ctxt1 ++ ctxt2 }) - --- Retrieve the current type signature context. --- See Note [Tracking the current type signature context] -askContext :: SgM DCxt -askContext = asks sg_context - -lookupVarE :: Name -> SgM DExp -lookupVarE name = do - opts <- getOptions - lookup_var_con (singledValueName opts) - (DVarE . singledValueName opts) name - -lookupConE :: Name -> SgM DExp -lookupConE name = do - opts <- getOptions - lookup_var_con (singledDataConName opts) - (DConE . singledDataConName opts) name - -lookup_var_con :: (Name -> Name) -> (Name -> DExp) -> Name -> SgM DExp -lookup_var_con mk_sing_name mk_exp name = do - opts <- getOptions - letExpansions <- asks sg_let_binds - sName <- mkDataName (nameBase (mk_sing_name name)) -- we want *term* names! - case Map.lookup name letExpansions of - Nothing -> do - -- try to get it from the global context - m_dinfo <- liftM2 (<|>) (dsReify sName) (dsReify name) - -- try the unrefined name too -- it's needed to bootstrap Enum - case m_dinfo of - Just (DVarI _ ty _) -> - let num_args = countArgs ty in - return $ wrapSingFun num_args (DConT $ defunctionalizedName0 opts name) - (mk_exp name) - _ -> return $ mk_exp name -- lambda-bound - Just exp -> return exp - -wrapSingFun :: Int -> DType -> DExp -> DExp -wrapSingFun 0 _ = id -wrapSingFun n ty = - let wrap_fun = DVarE $ case n of - 1 -> 'singFun1 - 2 -> 'singFun2 - 3 -> 'singFun3 - 4 -> 'singFun4 - 5 -> 'singFun5 - 6 -> 'singFun6 - 7 -> 'singFun7 - _ -> error "No support for functions of arity > 7." - in - (wrap_fun `DAppTypeE` ty `DAppE`) - -singM :: OptionsMonad q => [Dec] -> SgM a -> q (a, [DDec]) -singM locals (SgM rdr) = do - opts <- getOptions - other_locals <- localDeclarations - let wr = runReaderT rdr (emptySgEnv { sg_options = opts - , sg_local_decls = other_locals ++ locals }) - q = runWriterT wr - runQ q - -singDecsM :: OptionsMonad q => [Dec] -> SgM [DDec] -> q [DDec] -singDecsM locals thing = do - (decs1, decs2) <- singM locals thing - return $ decs1 ++ decs2 - -{- -Note [Tracking the current type signature context] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Much like we track the let-bound names in scope, we also track the current -context. For instance, in the following program: - - -- (1) - f :: forall a. Show a => a -> String -> Bool - f x y = g (show x) y - where - -- (2) - g :: forall b. Eq b => b -> b -> Bool - g = h - where - -- (3) - h :: b -> b -> Bool - h = (==) - -Here is the context at various points: - -(1) () -(2) (Show a) -(3) (Show a, Eq b) - -We track this informating during singling instead of during promotion, as the -promoted versions of things are often type families, which do not have -contexts. - -Why do we bother tracking this at all? Ultimately, because singDefuns (from -Data.Singletons.TH.Single.Defun) needs to know the current context in order to -generate a correctly typed SingI instance. For instance, if you called -singDefuns on the class method bar: - - class Foo a where - bar :: Eq a => a -> Bool - -Then if you only grabbed the context of `bar` itself, then you'd end up -generating the following SingI instance for BarSym0: - - instance SEq a => SingI (FooSym0 :: a ~> Bool) where ... - -Which is incorrect—there needs to be an (SFoo a) constraint as well! If we -track the current context when singling Foo, then we will correctly propagate -this information to singDefuns. --} +{-# LANGUAGE TemplateHaskellQuotes #-}++{- Data/Singletons/TH/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.+-}++module Data.Singletons.TH.Single.Monad (+ SgM, bindLambdas, bindLets, bindContext,+ askContext, lookupVarE, lookupConE,+ wrapSingFun,+ singM, singDecsM,+ emitDecs, emitDecsM+ ) where++import Prelude hiding ( exp )+import Data.Map ( Map )+import qualified Data.Map as Map+import Data.Singletons+import Data.Singletons.TH.Options+import Data.Singletons.TH.Promote.Monad ( emitDecs, emitDecsM )+import Data.Singletons.TH.Util+import Language.Haskell.TH.Syntax hiding ( lift )+import Language.Haskell.TH.Desugar+import Control.Monad ( liftM2 )+import Control.Monad.IO.Class ( MonadIO )+import Control.Monad.Reader ( MonadReader(..), ReaderT(..), asks )+import Control.Monad.Writer ( MonadWriter, WriterT(..) )+import Control.Applicative++-- environment during singling+data SgEnv =+ SgEnv { sg_options :: Options+ , sg_local_vars :: Map Name DExp+ -- ^ Map from term-level 'Name's of local variables to their+ -- singled counterparts. See @Note [Tracking local variables]@ in+ -- "Data.Singletons.TH.Promote.Monad".+ , sg_context :: DCxt -- See Note [Tracking the current type signature context]+ , sg_local_decls :: [Dec]+ }++emptySgEnv :: SgEnv+emptySgEnv = SgEnv { sg_options = defaultOptions+ , sg_local_vars = Map.empty+ , sg_context = []+ , sg_local_decls = []+ }++-- the singling monad+newtype SgM a = SgM (ReaderT SgEnv (WriterT [DDec] Q) a)+ deriving ( Functor, Applicative, Monad+ , MonadReader SgEnv, MonadWriter [DDec]+ , MonadFail, MonadIO, Quasi )++instance DsMonad SgM where+ localDeclarations = asks sg_local_decls++instance OptionsMonad SgM where+ getOptions = asks sg_options++-- ^ Bring a list of lambda-bound names into scope for the duration the supplied+-- computation, where the first element of each pair is the original, term-level+-- name, and the second element of each pair is the singled counterpart.+-- See @Note [Tracking local variables]@ in "Data.Singletons.TH.Promote.Monad".+bindLambdas :: [(Name, Name)] -> SgM a -> SgM a+bindLambdas lambdas = local add_binds+ where add_binds env@(SgEnv { sg_local_vars = locals }) =+ let new_locals = Map.fromList [ (tmN, DVarE tyN) | (tmN, tyN) <- lambdas ] in+ env { sg_local_vars = new_locals `Map.union` locals }++-- ^ Bring a list of let-bound names into scope for the duration the supplied+-- computation, where the first element of each pair is the original, term-level+-- name, and the second element of each pair is the singled counterpart.+-- See @Note [Tracking local variables]@ in "Data.Singletons.TH.Promote.Monad".+bindLets :: [(Name, DExp)] -> SgM a -> SgM a+bindLets lets =+ local (\env@(SgEnv { sg_local_vars = locals }) ->+ env { sg_local_vars = Map.fromList lets `Map.union` locals })++-- Add some constraints to the current type signature context.+-- See Note [Tracking the current type signature context]+bindContext :: DCxt -> SgM a -> SgM a+bindContext ctxt1+ = local (\env@(SgEnv { sg_context = ctxt2 }) ->+ env { sg_context = ctxt1 ++ ctxt2 })++-- Retrieve the current type signature context.+-- See Note [Tracking the current type signature context]+askContext :: SgM DCxt+askContext = asks sg_context++-- | Map a term-level 'Name' to its singled counterpart. This function is aware+-- of any local variables that are currently in scope.+-- See @Note [Tracking local variables]@ in "Data.Singletons.TH.Promote.Monad".+lookupVarE :: Name -> SgM DExp+lookupVarE name = do+ opts <- getOptions+ lookup_var_con (singledValueName opts)+ (DVarE . singledValueName opts) name++-- | Map a data constructor name to its singled counterpart.+lookupConE :: Name -> SgM DExp+lookupConE name = do+ opts <- getOptions+ lookup_var_con (singledDataConName opts)+ (DConE . singledDataConName opts) name++lookup_var_con :: (Name -> Name) -> (Name -> DExp) -> Name -> SgM DExp+lookup_var_con mk_sing_name mk_exp name = do+ opts <- getOptions+ localExpansions <- asks sg_local_vars+ sName <- mkDataName (nameBase (mk_sing_name name)) -- we want *term* names!+ case Map.lookup name localExpansions of+ Nothing -> do+ -- try to get it from the global context+ m_dinfo <- liftM2 (<|>) (dsReify sName) (dsReify name)+ -- try the unrefined name too -- it's needed to bootstrap Enum+ case m_dinfo of+ Just (DVarI _ ty _) ->+ let num_args = countArgs ty in+ return $ wrapSingFun num_args (DConT $ defunctionalizedName0 opts name)+ (mk_exp name)+ _ -> return $ mk_exp name -- lambda-bound+ Just exp -> return exp++wrapSingFun :: Int -> DType -> DExp -> DExp+wrapSingFun 0 _ = id+wrapSingFun n ty =+ let wrap_fun = DVarE $ case n of+ 1 -> 'singFun1+ 2 -> 'singFun2+ 3 -> 'singFun3+ 4 -> 'singFun4+ 5 -> 'singFun5+ 6 -> 'singFun6+ 7 -> 'singFun7+ _ -> error "No support for functions of arity > 7."+ in+ (wrap_fun `DAppTypeE` ty `DAppE`)++singM :: OptionsMonad q => [Dec] -> SgM a -> q (a, [DDec])+singM locals (SgM rdr) = do+ opts <- getOptions+ other_locals <- localDeclarations+ let wr = runReaderT rdr (emptySgEnv { sg_options = opts+ , sg_local_decls = other_locals ++ locals })+ q = runWriterT wr+ runQ q++singDecsM :: OptionsMonad q => [Dec] -> SgM [DDec] -> q [DDec]+singDecsM locals thing = do+ (decs1, decs2) <- singM locals thing+ return $ decs1 ++ decs2++{-+Note [Tracking the current type signature context]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Much like we track the locally-bound names in scope (see Note [Tracking local+variables] in Data.Singletons.TH.Promote.Monad), we also track the current+context. For instance, in the following program:++ -- (1)+ f :: forall a. Show a => a -> String -> Bool+ f x y = g (show x) y+ where+ -- (2)+ g :: forall b. Eq b => b -> b -> Bool+ g = h+ where+ -- (3)+ h :: b -> b -> Bool+ h = (==)++Here is the context at various points:++(1) ()+(2) (Show a)+(3) (Show a, Eq b)++We track this informating during singling instead of during promotion, as the+promoted versions of things are often type families, which do not have+contexts.++Why do we bother tracking this at all? Ultimately, because singDefuns (from+Data.Singletons.TH.Single.Defun) needs to know the current context in order to+generate a correctly typed SingI instance. For instance, if you called+singDefuns on the class method bar:++ class Foo a where+ bar :: Eq a => a -> Bool++Then if you only grabbed the context of `bar` itself, then you'd end up+generating the following SingI instance for BarSym0:++ instance SEq a => SingI (FooSym0 :: a ~> Bool) where ...++Which is incorrect—there needs to be an (SFoo a) constraint as well! If we+track the current context when singling Foo, then we will correctly propagate+this information to singDefuns.+-}
+ src/Data/Singletons/TH/Single/Ord.hs view
@@ -0,0 +1,43 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.Singletons.TH.Single.Ord+-- Copyright : (C) 2023 Ryan Scott+-- License : BSD-style (see LICENSE)+-- Maintainer : Ryan Scott+-- Stability : experimental+-- Portability : non-portable+--+-- Defines a function to generate boilerplate Ord instances for singleton+-- types.+--+-----------------------------------------------------------------------------++module Data.Singletons.TH.Single.Ord (mkOrdInstanceForSingleton) where++import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Desugar+import Data.Singletons.TH.Names+import Data.Singletons.TH.Options+import Data.Singletons.TH.Promote.Type++-- Make a boilerplate Ord instance for a singleton type, e.g.,+--+-- @+-- instance Ord (SExample (z :: Example a)) where+-- compare _ _ = EQ+-- @+mkOrdInstanceForSingleton :: OptionsMonad q+ => DType+ -> Name+ -- ^ The name of the data type+ -> q DDec+mkOrdInstanceForSingleton data_ty data_name = do+ opts <- getOptions+ z <- qNewName "z"+ data_ki <- promoteType data_ty+ let sdata_name = singledDataTypeName opts data_name+ pure $ DInstanceD Nothing Nothing []+ (DAppT (DConT ordName) (DConT sdata_name `DAppT` DSigT (DVarT z) data_ki))+ [DLetDec $+ DFunD compareName+ [DClause [DWildP, DWildP] (DConE cmpEQName)]]
src/Data/Singletons/TH/Single/Type.hs view
@@ -1,336 +1,336 @@-{- Data/Singletons/TH/Single/Type.hs - -(c) Richard Eisenberg 2013 -rae@cs.brynmawr.edu - -Singletonizes types. --} - -module Data.Singletons.TH.Single.Type where - -import Language.Haskell.TH.Desugar -import Language.Haskell.TH.Syntax -import Data.Singletons.TH.Names -import Data.Singletons.TH.Options -import Data.Singletons.TH.Promote.Type -import Data.Singletons.TH.Single.Monad -import Data.Singletons.TH.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 - , DCxt -- the context of the singletonized type - , [DKind] -- the kinds of the argument types - , DKind ) -- the kind of the result type -singType prom ty = do - (orig_tvbs, cxt, args, res) <- unravelVanillaDType ty - let num_args = length args - cxt' <- mapM singPred_NC cxt - arg_names <- replicateM num_args (qNewName "t") - prom_args <- mapM promoteType_NC args - prom_res <- promoteType_NC res - let args' = map (\n -> singFamily `DAppT` (DVarT n)) arg_names - res' = singFamily `DAppT` (foldApply prom (map DVarT arg_names) `DSigT` prom_res) - -- Make sure to include an explicit `prom_res` kind annotation. - -- See Note [Preserve the order of type variables during singling], - -- wrinkle 3. - arg_tvbs = zipWith (`DKindedTV` SpecifiedSpec) arg_names prom_args - -- If the original type signature lacks an explicit `forall`, then do not - -- give the singled type signature an outermost `forall`. Instead, give it - -- a `<singled-ty> :: Type` kind annotation and let GHC implicitly - -- quantify any type variables that are free in `<singled-ty>`. - -- See Note [Preserve the order of type variables during singling], - -- wrinkle 1. - ty' | null orig_tvbs - = ravelVanillaDType arg_tvbs cxt' args' res' `DSigT` DConT typeKindName - | otherwise - = ravelVanillaDType (orig_tvbs ++ arg_tvbs) cxt' args' res' - return (ty', num_args, arg_names, cxt, prom_args, prom_res) - --- Single a DPred, checking that it is a vanilla type in the process. --- See [Vanilla-type validity checking during promotion] --- in Data.Singletons.TH.Promote.Type. -singPred :: DPred -> SgM DPred -singPred p = do - checkVanillaDType p - singPred_NC p - --- Single a DPred. Does not check if the argument is a vanilla type. --- See [Vanilla-type validity checking during promotion] --- in Data.Singletons.TH.Promote.Type. -singPred_NC :: DPred -> SgM DPred -singPred_NC = singPredRec [] - --- The workhorse for singPred_NC. -singPredRec :: [DTypeArg] -> DPred -> SgM DPred -singPredRec _cxt (DForallT {}) = - fail "Singling of quantified constraints not yet supported" -singPredRec _cxt (DConstrainedT {}) = - fail "Singling of quantified constraints not yet supported" -singPredRec ctx (DAppT pr ty) = singPredRec (DTANormal ty : ctx) pr -singPredRec ctx (DAppKindT pr ki) = singPredRec (DTyArg ki : ctx) pr -singPredRec _ctx (DSigT _pr _ki) = - fail "Singling of constraints with explicit kinds not yet supported" -singPredRec _ctx (DVarT _n) = - fail "Singling of contraint variables not yet supported" -singPredRec ctx (DConT n) - | n == equalityName - = fail "Singling of type equality constraints not yet supported" - | otherwise = do - opts <- getOptions - kis <- mapM promoteTypeArg_NC ctx - let sName = singledClassName opts n - return $ applyDType (DConT sName) kis -singPredRec _ctx DWildCardT = return DWildCardT -- it just might work -singPredRec _ctx DArrowT = - fail "(->) spotted at head of a constraint" -singPredRec _ctx (DLitT {}) = - fail "Type-level literal spotted at head of a constraint" - -{- -Note [Preserve the order of type variables during singling] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -singletons-th does its best to preseve the order in which users write type -variables in type signatures for functions and data constructors. They are -"preserved" in the sense that if one writes `foo @T1 @T2`, one should be -able to write out `sFoo @T1 @T2` by hand and have the same order of visible -type applications still work. Accomplishing this is surprisingly nontrivial, -so this Note documents the various wrinkles one must iron out to get this -working. - ------ --- Wrinkle 1: Dealing with the presence (and absence) of `forall` ------ - -If we single a function that has an explicit `forall`, such as this example: - - const2 :: forall b a. a -> b -> a - const2 x _ = x - -Then our job is easy, as the exact order of type variables has already been -spelled out in advance. We single this to: - - sConst2 :: forall b a (x :: a) (y :: b). Sing x -> Sing y -> Sing (Const2 x y :: a) - sConst2 = ... - -What happens if there is no explicit `forall`, as in this example? - - data V a - - absurd :: V a -> b - absurd v = case v of {} - -This time, the order of type variables vis-à-vis TypeApplications is determined -by their left-to-right order of appearance in the type signature. This order -dictates that `a` is quantified before `b`, so we must mirror this order in the -singled type signature. - -One way to accomplish this would be to compute the order in which the type -variables appear and then explicitly quantify them. In the `absurd` example -above, this would be tantamount to writing: - - sAbsurd :: forall a b (v :: V a). Sing v -> Sing (Absurd v :: b) - ^^^ - ||| - Explicitly quantified by singletons-th, - not in the original type signature - -This is possible to do, and indeed, singletons-th used to do this. However, it -is a bit tiresome to implement. In order to know which type variables to -quantify, you must keep track of which type variables have been brought into -scope at all times. For the historical details on how this worked, see this -now-removed Note describing the old implementation: -https://github.com/goldfirere/singletons/blob/10ef27880d7ecc16241824c504ca83e2bb6ca787/singletons-th/src/Data/Singletons/TH/Promote/Monad.hs#L135-L192 - -A much more straightforward approach, which singletons-th currently uses, is to -let GHC do the hard work of implicitly quantifying the type variables. That is, -we will single `absurd` to something like this: - - sAbsurd :: () => forall (v :: V a). Sing v -> Sing (Absurd v :: b) - -This works because just like in the original type signature, `a` and `b` are -implicitly quantified, and more importantly, they are quantified in exactly the -same order as in the original type signature. - -Why do we need the `() => ...` part? If we had instead written the type -signature like this: - - sAbsurd :: forall (v :: V a). Sing v -> Sing (Absurd v :: b) - -Then GHC would reject `a` and `b` for being out of scope. This is because of -GHC's "forall-or-nothing" rule: if a type signature has an outermost forall, -then all type variable occurrences in the type signature must have explicit -binding sites. Using `() => forall (v :: V a). ...` prevents the `forall` from -being an outermost `forall`, which bypasses the forall-or-nothing rule. - -Some further complications: - -* Template Haskell doesn't actually allow you to splice in types of the form - `() => ...` in practice. - See https://gitlab.haskell.org/ghc/ghc/-/issues/16396. Luckily, this isn't a - deal-breaker, as we can also avoid the forall-or-nothing rule by annotating - the type signature with an explicit `... :: Type` annotation: - - sAbsurd :: ((forall (v :: V a). Sing v -> Sing (Absurd v :: b)) :: Type) - - This is the approach that singletons-th actually uses. Note that there is one - spot in the code (in D.S.TH.Single.singInstD) that must be taught to look - through these `... :: Type` annotations, but this approach is otherwise fairly - non-invasive. - -* We cannot use this trick when singling the types of data constructors. That - is, we cannot single this: - - data T a where - MkT :: a -> T a - - To this: - - data ST z where - SMkT :: ((forall (x :: a). Sing x -> ST (MkT x)) :: Type) - - This is because GADT syntax does not currently permit nested `forall`s of this - sort. (It might permit them in the future if - https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0402-gadt-syntax.rst - is implemented, but not currently.) As a result, we /always/ explicitly - quantify all type variables in a data constructor's type, regardless of - whether the original type implicitly quantified them or not. In the example - above, that means that the singled version would be: - - data ST z where - SMkT :: forall a (x :: a). Sing x -> ST (MkT x) - ------ --- Wrinkle 2: The TH reification swamp ------ - -There is another issue with type signatures that lack explicit `forall`s, one -which the current design of Template Haskell does not make simple to fix. -If we single code that is wrapped in TH quotes, such as in the following example: - - {-# LANGUAGE PolyKinds, ... #-} - $(singletons [d| - data Proxy a = MkProxy - |]) - -Then our job is made much easier when singling MkProxy, since we know that the -only type variable that must be quantified is `a`, as that is the only one -specified by the user. This results in the following type signature for -MkProxy: - - MkProxy :: forall a. Proxy a - -However, this is not the only possible way to single MkProxy. One can -alternatively use $(genSingletons [''Proxy]), which uses TH reification to -infer the type of MkProxy. There is perilous, however, because this is how -TH reifies Proxy: - - DataD - [] ''Proxy [KindedTV a () (VarT k)] Nothing - [NormalC 'MkProxy []] - [] - -We must then construct a type signature for MkProxy using nothing but the type -variables from the data type header. But notice that `KindedTV a () (VarT k)` -gives no indication of whether `k` is specified or inferred! As a result, we -conservatively assume that `k` is specified, resulting the following type -signature for MkProxy: - - MkProxy :: forall k (a :: k). Proxy a - -Contrast this with `MkProxy :: Proxy a`, where `k` is inferred. In other words, -if you single MkProxy using genSingletons, then `Proxy @True` will typecheck -but `SMkProxy @True` will /not/ typecheck—you'd have to use -`SMkProxy @_ @True` instead. Urk! - -At present, Template Haskell does not have a way to distinguish among the -specificities bound by a data type header. Without this knowledge, it is -unclear how one could work around this issue. Thankfully, this issue is -only likely to surface in very limited circumstances, so the damage is somewhat -minimal. - ------ --- Wrinkle 3: Where to put explicit kind annotations ------ - -Type variable binders are only part of the story—we must also determine what -the body of the type signature will be singled to. As a general rule, if the -original type signature is of the form: - - f :: forall a_1 ... a_m. (C_1, ..., C_n) - => T_1 -> ... -> T_p -> R - -Then the singled type signature will be: - - sF :: forall a_1 ... a_m (x_1 :: PT_1) ... (x_p :: PT_p). (SC_1, ..., SC_n) - => Sing x1 -> ... -> Sing x_p -> SRes (F x1 ... x_p :: PR) - -Where: - -* x_i is a fresh type variable of kind PT_i. -* PT_i is the promoted version of the type T_i, and PR is the promoted version - of the type R. -* SC_i is the singled version of the constraint SC_i. -* SRes is either `Sing` if dealing with a function, or a singled data type if - dealing with a data constructor. For instance, SRes is `SBool` in - `STrue :: SBool (True :: Bool)`. - -One aspect of this worth pointing out is the explicit `:: PR` kind annotation -in the result type `Sing (F x1 ... x_p :: PR)`. As it turns out, this kind -annotation is mandatory, as omitting can result in singled type signatures -with the wrong semantics. For instance, consider the `Nothing` data -constructor: - - Nothing :: forall a. Maybe a - -Consider what would happen if it were singled to this type: - - SNothing :: forall a. SMaybe Nothing - -This is not what we want at all, since the `a` has no connection to the -`Nothing` in the result type. It's as if we had written this: - - SNothing :: forall {t} a. SMaybe (Nothing :: Maybe t) - -If we instead generate `forall a. SMaybe (Nothing :: Maybe a)`, then this issue -is handily avoided. - -You might wonder if it would be cleaner to use visible kind applications -instead: - - SNothing :: forall a. SMaybe (Nothing @a) - -This does work for many cases, but there are also some corner cases where this -approach fails. Recall the `MkProxy` example from Wrinkle 2 above: - - {-# LANGUAGE PolyKinds, ... #-} - data Proxy a = MkProxy - $(genSingletons [''Proxy]) - -Due to the design of Template Haskell (discussed in Wrinkle 2), `MkProxy` will -be reified with the type of `forall k (a :: k). Proxy a`. This means that -if we used visible kind applications in the result type, we would end up with -this: - - SMkProxy :: forall k (a :: k). SProxy (MkProxy @k @a) - -This will not kind-check because MkProxy only accepts /one/ visible kind argument, -whereas this supplies it with two. To avoid this issue, we instead use the type -`forall k (a :: k). SProxy (MkProxy :: Proxy a)`. Granted, this type is /still/ -technically wrong due to the fact that it explicitly quantifies `k`, but at the -very least it typechecks. If Template Haskell gained the ability to distinguish -among the specificities of type variables bound by a data type header -(perhaps by way of a language feature akin to -https://github.com/ghc-proposals/ghc-proposals/pull/326), then we could revisit -this design choice. - -Finally, note that we need only write `Sing x_1 -> ... -> Sing x_p`, and not -`Sing (x_1 :: PT_1) -> ... Sing (x_p :: PT_p)`. This is simply because we -always use explicit `forall`s in singled type signatures, and therefore always -explicitly bind `(x_1 :: PT_1) ... (x_p :: PT_p)`, which fully determine the -kinds of `x_1 ... x_p`. It wouldn't be wrong to add extra kind annotations to -`Sing x_1 -> ... -> Sing x_p`, just redundant. --} +{- Data/Singletons/TH/Single/Type.hs++(c) Richard Eisenberg 2013+rae@cs.brynmawr.edu++Singletonizes types.+-}++module Data.Singletons.TH.Single.Type where++import Language.Haskell.TH.Desugar+import Language.Haskell.TH.Syntax+import Data.Singletons.TH.Names+import Data.Singletons.TH.Options+import Data.Singletons.TH.Promote.Type+import Data.Singletons.TH.Single.Monad+import Data.Singletons.TH.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+ , DCxt -- the context of the singletonized type+ , [DKind] -- the kinds of the argument types+ , DKind ) -- the kind of the result type+singType prom ty = do+ (orig_tvbs, cxt, args, res) <- unravelVanillaDType ty+ let num_args = length args+ cxt' <- mapM singPred_NC cxt+ arg_names <- replicateM num_args (qNewName "t")+ prom_args <- mapM promoteType_NC args+ prom_res <- promoteType_NC res+ let args' = map (\n -> singFamily `DAppT` (DVarT n)) arg_names+ res' = singFamily `DAppT` (foldApply prom (map DVarT arg_names) `DSigT` prom_res)+ -- Make sure to include an explicit `prom_res` kind annotation.+ -- See Note [Preserve the order of type variables during singling],+ -- wrinkle 3.+ arg_tvbs = zipWith (`DKindedTV` SpecifiedSpec) arg_names prom_args+ -- If the original type signature lacks an explicit `forall`, then do not+ -- give the singled type signature an outermost `forall`. Instead, give it+ -- a `<singled-ty> :: Type` kind annotation and let GHC implicitly+ -- quantify any type variables that are free in `<singled-ty>`.+ -- See Note [Preserve the order of type variables during singling],+ -- wrinkle 1.+ ty' | null orig_tvbs+ = ravelVanillaDType arg_tvbs cxt' args' res' `DSigT` DConT typeKindName+ | otherwise+ = ravelVanillaDType (orig_tvbs ++ arg_tvbs) cxt' args' res'+ return (ty', num_args, arg_names, cxt, prom_args, prom_res)++-- Single a DPred, checking that it is a vanilla type in the process.+-- See [Vanilla-type validity checking during promotion]+-- in Data.Singletons.TH.Promote.Type.+singPred :: DPred -> SgM DPred+singPred p = do+ checkVanillaDType p+ singPred_NC p++-- Single a DPred. Does not check if the argument is a vanilla type.+-- See [Vanilla-type validity checking during promotion]+-- in Data.Singletons.TH.Promote.Type.+singPred_NC :: DPred -> SgM DPred+singPred_NC = singPredRec []++-- The workhorse for singPred_NC.+singPredRec :: [DTypeArg] -> DPred -> SgM DPred+singPredRec _cxt (DForallT {}) =+ fail "Singling of quantified constraints not yet supported"+singPredRec _cxt (DConstrainedT {}) =+ fail "Singling of quantified constraints not yet supported"+singPredRec ctx (DAppT pr ty) = singPredRec (DTANormal ty : ctx) pr+singPredRec ctx (DAppKindT pr ki) = singPredRec (DTyArg ki : ctx) pr+singPredRec _ctx (DSigT _pr _ki) =+ fail "Singling of constraints with explicit kinds not yet supported"+singPredRec _ctx (DVarT _n) =+ fail "Singling of contraint variables not yet supported"+singPredRec ctx (DConT n)+ | n == equalityName+ = fail "Singling of type equality constraints not yet supported"+ | otherwise = do+ opts <- getOptions+ kis <- mapM promoteTypeArg_NC ctx+ let sName = singledClassName opts n+ return $ applyDType (DConT sName) kis+singPredRec _ctx DWildCardT = return DWildCardT -- it just might work+singPredRec _ctx DArrowT =+ fail "(->) spotted at head of a constraint"+singPredRec _ctx (DLitT {}) =+ fail "Type-level literal spotted at head of a constraint"++{-+Note [Preserve the order of type variables during singling]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+singletons-th does its best to preseve the order in which users write type+variables in type signatures for functions and data constructors. They are+"preserved" in the sense that if one writes `foo @T1 @T2`, one should be+able to write out `sFoo @T1 @T2` by hand and have the same order of visible+type applications still work. Accomplishing this is surprisingly nontrivial,+so this Note documents the various wrinkles one must iron out to get this+working.++-----+-- Wrinkle 1: Dealing with the presence (and absence) of `forall`+-----++If we single a function that has an explicit `forall`, such as this example:++ const2 :: forall b a. a -> b -> a+ const2 x _ = x++Then our job is easy, as the exact order of type variables has already been+spelled out in advance. We single this to:++ sConst2 :: forall b a (x :: a) (y :: b). Sing x -> Sing y -> Sing (Const2 x y :: a)+ sConst2 = ...++What happens if there is no explicit `forall`, as in this example?++ data V a++ absurd :: V a -> b+ absurd v = case v of {}++This time, the order of type variables vis-à-vis TypeApplications is determined+by their left-to-right order of appearance in the type signature. This order+dictates that `a` is quantified before `b`, so we must mirror this order in the+singled type signature.++One way to accomplish this would be to compute the order in which the type+variables appear and then explicitly quantify them. In the `absurd` example+above, this would be tantamount to writing:++ sAbsurd :: forall a b (v :: V a). Sing v -> Sing (Absurd v :: b)+ ^^^+ |||+ Explicitly quantified by singletons-th,+ not in the original type signature++This is possible to do, and indeed, singletons-th used to do this. However, it+is a bit tiresome to implement. In order to know which type variables to+quantify, you must keep track of which type variables have been brought into+scope at all times. For the historical details on how this worked, see this+now-removed Note describing the old implementation:+https://github.com/goldfirere/singletons/blob/10ef27880d7ecc16241824c504ca83e2bb6ca787/singletons-th/src/Data/Singletons/TH/Promote/Monad.hs#L135-L192++A much more straightforward approach, which singletons-th currently uses, is to+let GHC do the hard work of implicitly quantifying the type variables. That is,+we will single `absurd` to something like this:++ sAbsurd :: () => forall (v :: V a). Sing v -> Sing (Absurd v :: b)++This works because just like in the original type signature, `a` and `b` are+implicitly quantified, and more importantly, they are quantified in exactly the+same order as in the original type signature.++Why do we need the `() => ...` part? If we had instead written the type+signature like this:++ sAbsurd :: forall (v :: V a). Sing v -> Sing (Absurd v :: b)++Then GHC would reject `a` and `b` for being out of scope. This is because of+GHC's "forall-or-nothing" rule: if a type signature has an outermost forall,+then all type variable occurrences in the type signature must have explicit+binding sites. Using `() => forall (v :: V a). ...` prevents the `forall` from+being an outermost `forall`, which bypasses the forall-or-nothing rule.++Some further complications:++* Template Haskell doesn't actually allow you to splice in types of the form+ `() => ...` in practice.+ See https://gitlab.haskell.org/ghc/ghc/-/issues/16396. Luckily, this isn't a+ deal-breaker, as we can also avoid the forall-or-nothing rule by annotating+ the type signature with an explicit `... :: Type` annotation:++ sAbsurd :: ((forall (v :: V a). Sing v -> Sing (Absurd v :: b)) :: Type)++ This is the approach that singletons-th actually uses. Note that there is one+ spot in the code (in D.S.TH.Single.singInstD) that must be taught to look+ through these `... :: Type` annotations, but this approach is otherwise fairly+ non-invasive.++* We cannot use this trick when singling the types of data constructors. That+ is, we cannot single this:++ data T a where+ MkT :: a -> T a++ To this:++ data ST z where+ SMkT :: ((forall (x :: a). Sing x -> ST (MkT x)) :: Type)++ This is because GADT syntax does not currently permit nested `forall`s of this+ sort. (It might permit them in the future if+ https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0402-gadt-syntax.rst+ is implemented, but not currently.) As a result, we /always/ explicitly+ quantify all type variables in a data constructor's type, regardless of+ whether the original type implicitly quantified them or not. In the example+ above, that means that the singled version would be:++ data ST z where+ SMkT :: forall a (x :: a). Sing x -> ST (MkT x)++-----+-- Wrinkle 2: The TH reification swamp+-----++There is another issue with type signatures that lack explicit `forall`s, one+which the current design of Template Haskell does not make simple to fix.+If we single code that is wrapped in TH quotes, such as in the following example:++ {-# LANGUAGE PolyKinds, ... #-}+ $(singletons [d|+ data Proxy a = MkProxy+ |])++Then our job is made much easier when singling MkProxy, since we know that the+only type variable that must be quantified is `a`, as that is the only one+specified by the user. This results in the following type signature for+MkProxy:++ MkProxy :: forall a. Proxy a++However, this is not the only possible way to single MkProxy. One can+alternatively use $(genSingletons [''Proxy]), which uses TH reification to+infer the type of MkProxy. There is perilous, however, because this is how+TH reifies Proxy:++ DataD+ [] ''Proxy [KindedTV a () (VarT k)] Nothing+ [NormalC 'MkProxy []]+ []++We must then construct a type signature for MkProxy using nothing but the type+variables from the data type header. But notice that `KindedTV a () (VarT k)`+gives no indication of whether `k` is specified or inferred! As a result, we+conservatively assume that `k` is specified, resulting the following type+signature for MkProxy:++ MkProxy :: forall k (a :: k). Proxy a++Contrast this with `MkProxy :: Proxy a`, where `k` is inferred. In other words,+if you single MkProxy using genSingletons, then `Proxy @True` will typecheck+but `SMkProxy @True` will /not/ typecheck—you'd have to use+`SMkProxy @_ @True` instead. Urk!++At present, Template Haskell does not have a way to distinguish among the+specificities bound by a data type header. Without this knowledge, it is+unclear how one could work around this issue. Thankfully, this issue is+only likely to surface in very limited circumstances, so the damage is somewhat+minimal.++-----+-- Wrinkle 3: Where to put explicit kind annotations+-----++Type variable binders are only part of the story—we must also determine what+the body of the type signature will be singled to. As a general rule, if the+original type signature is of the form:++ f :: forall a_1 ... a_m. (C_1, ..., C_n)+ => T_1 -> ... -> T_p -> R++Then the singled type signature will be:++ sF :: forall a_1 ... a_m (x_1 :: PT_1) ... (x_p :: PT_p). (SC_1, ..., SC_n)+ => Sing x1 -> ... -> Sing x_p -> SRes (F x1 ... x_p :: PR)++Where:++* x_i is a fresh type variable of kind PT_i.+* PT_i is the promoted version of the type T_i, and PR is the promoted version+ of the type R.+* SC_i is the singled version of the constraint SC_i.+* SRes is either `Sing` if dealing with a function, or a singled data type if+ dealing with a data constructor. For instance, SRes is `SBool` in+ `STrue :: SBool (True :: Bool)`.++One aspect of this worth pointing out is the explicit `:: PR` kind annotation+in the result type `Sing (F x1 ... x_p :: PR)`. As it turns out, this kind+annotation is mandatory, as omitting can result in singled type signatures+with the wrong semantics. For instance, consider the `Nothing` data+constructor:++ Nothing :: forall a. Maybe a++Consider what would happen if it were singled to this type:++ SNothing :: forall a. SMaybe Nothing++This is not what we want at all, since the `a` has no connection to the+`Nothing` in the result type. It's as if we had written this:++ SNothing :: forall {t} a. SMaybe (Nothing :: Maybe t)++If we instead generate `forall a. SMaybe (Nothing :: Maybe a)`, then this issue+is handily avoided.++You might wonder if it would be cleaner to use visible kind applications+instead:++ SNothing :: forall a. SMaybe (Nothing @a)++This does work for many cases, but there are also some corner cases where this+approach fails. Recall the `MkProxy` example from Wrinkle 2 above:++ {-# LANGUAGE PolyKinds, ... #-}+ data Proxy a = MkProxy+ $(genSingletons [''Proxy])++Due to the design of Template Haskell (discussed in Wrinkle 2), `MkProxy` will+be reified with the type of `forall k (a :: k). Proxy a`. This means that+if we used visible kind applications in the result type, we would end up with+this:++ SMkProxy :: forall k (a :: k). SProxy (MkProxy @k @a)++This will not kind-check because MkProxy only accepts /one/ visible kind argument,+whereas this supplies it with two. To avoid this issue, we instead use the type+`forall k (a :: k). SProxy (MkProxy :: Proxy a)`. Granted, this type is /still/+technically wrong due to the fact that it explicitly quantifies `k`, but at the+very least it typechecks. If Template Haskell gained the ability to distinguish+among the specificities of type variables bound by a data type header+(perhaps by way of a language feature akin to+https://github.com/ghc-proposals/ghc-proposals/pull/326), then we could revisit+this design choice.++Finally, note that we need only write `Sing x_1 -> ... -> Sing x_p`, and not+`Sing (x_1 :: PT_1) -> ... Sing (x_p :: PT_p)`. This is simply because we+always use explicit `forall`s in singled type signatures, and therefore always+explicitly bind `(x_1 :: PT_1) ... (x_p :: PT_p)`, which fully determine the+kinds of `x_1 ... x_p`. It wouldn't be wrong to add extra kind annotations to+`Sing x_1 -> ... -> Sing x_p`, just redundant.+-}
src/Data/Singletons/TH/SuppressUnusedWarnings.hs view
@@ -1,21 +1,21 @@-{-# LANGUAGE AllowAmbiguousTypes #-} - --- Data/Singletons/TH/SuppressUnusedWarnings.hs --- --- (c) Richard Eisenberg 2014 --- rae@cs.brynmawr.edu --- --- This declares user-oriented exports that are actually meant to be hidden --- from the user. Why would anyone ever want this? Because what is below --- is dirty, and no one wants to see it. - -module Data.Singletons.TH.SuppressUnusedWarnings where - -import Data.Kind - --- | This class (which users should never see) is to be instantiated in order --- to use an otherwise-unused data constructor, such as the "kind-inference" --- data constructor for defunctionalization symbols. -type SuppressUnusedWarnings :: k -> Constraint -class SuppressUnusedWarnings (t :: k) where - suppressUnusedWarnings :: () +{-# LANGUAGE AllowAmbiguousTypes #-}++-- Data/Singletons/TH/SuppressUnusedWarnings.hs+--+-- (c) Richard Eisenberg 2014+-- rae@cs.brynmawr.edu+--+-- This declares user-oriented exports that are actually meant to be hidden+-- from the user. Why would anyone ever want this? Because what is below+-- is dirty, and no one wants to see it.++module Data.Singletons.TH.SuppressUnusedWarnings where++import Data.Kind++-- | This class (which users should never see) is to be instantiated in order+-- to use an otherwise-unused data constructor, such as the "kind-inference"+-- data constructor for defunctionalization symbols.+type SuppressUnusedWarnings :: k -> Constraint+class SuppressUnusedWarnings (t :: k) where+ suppressUnusedWarnings :: ()
src/Data/Singletons/TH/Syntax.hs view
@@ -1,224 +1,243 @@-{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} - -{- Data/Singletons/TH/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. --} - -module Data.Singletons.TH.Syntax where - -import Prelude hiding ( exp ) -import Data.Kind (Constraint, Type) -import Language.Haskell.TH.Syntax hiding (Type) -import Language.Haskell.TH.Desugar -import qualified Language.Haskell.TH.Desugar.OMap.Strict as OMap -import Language.Haskell.TH.Desugar.OMap.Strict (OMap) - -type VarPromotions = [(Name, Name)] -- from term-level name to type-level name - --- A list of 'SingDSigPaInfos' is produced when singling pattern signatures, as we --- must case on the 'DExp's and match on them using the supplied 'DType's to --- bring the necessary singleton equality constraints into scope. --- See @Note [Singling pattern signatures]@. -type SingDSigPaInfos = [(DExp, DType)] - --- The parts of data declarations that are relevant to singletons-th. -data DataDecl = DataDecl DataFlavor Name [DTyVarBndrUnit] [DCon] - --- The parts of type synonyms that are relevant to singletons-th. -data TySynDecl = TySynDecl Name [DTyVarBndrUnit] DType - --- The parts of open type families that are relevant to singletons-th. -type OpenTypeFamilyDecl = TypeFamilyDecl 'Open - --- The parts of closed type families that are relevant to singletons-th. -type ClosedTypeFamilyDecl = TypeFamilyDecl 'Closed - --- The parts of type families that are relevant to singletons-th. -newtype TypeFamilyDecl (info :: FamilyInfo) - = TypeFamilyDecl { getTypeFamilyDecl :: DTypeFamilyHead } --- Whether a type family is open or closed. -data FamilyInfo = Open | Closed - -data ClassDecl ann - = ClassDecl { cd_cxt :: DCxt - , cd_name :: Name - , cd_tvbs :: [DTyVarBndrUnit] - , cd_fds :: [FunDep] - , cd_lde :: LetDecEnv ann - , cd_atfs :: [OpenTypeFamilyDecl] - -- Associated type families. Only recorded for - -- defunctionalization purposes. - -- See Note [Partitioning, type synonyms, and type families] - -- in D.S.TH.Partition. - } - -data InstDecl ann = InstDecl { id_cxt :: DCxt - , id_name :: Name - , id_arg_tys :: [DType] - , id_sigs :: OMap Name DType - , id_meths :: [(Name, LetDecRHS ann)] } - -type UClassDecl = ClassDecl Unannotated -type UInstDecl = InstDecl Unannotated - -type AClassDecl = ClassDecl Annotated -type AInstDecl = InstDecl Annotated - -{- -We see below several datatypes beginning with "A". These are annotated structures, -necessary for Promote to communicate key things to Single. In particular, promotion -of expressions is *not* deterministic, due to the necessity to create unique names -for lets, cases, and lambdas. So, we put these promotions into an annotated AST -so that Single can use the right promotions. --} - --- A DExp with let, lambda, and type-signature nodes annotated with their --- type-level equivalents -data ADExp = ADVarE Name - | ADConE Name - | ADLitE Lit - | ADAppE ADExp ADExp - | ADLamE [Name] -- type-level names corresponding to term-level ones - DType -- the promoted lambda - [Name] ADExp - | ADCaseE ADExp [ADMatch] DType - -- the type is the return type - | ADLetE ALetDecEnv ADExp - | ADSigE DType -- the promoted expression - ADExp DType - --- A DPat with a pattern-signature node annotated with its type-level equivalent -data ADPat = ADLitP Lit - | ADVarP Name - | ADConP Name [DType] [ADPat] - | ADTildeP ADPat - | ADBangP ADPat - | ADSigP DType -- The promoted pattern. Will not contain any wildcards, - -- as per Note [Singling pattern signatures] - ADPat DType - | ADWildP - -data ADMatch = ADMatch VarPromotions ADPat ADExp -data ADClause = ADClause VarPromotions - [ADPat] ADExp - -data AnnotationFlag = Annotated | Unannotated - --- These are used at the type-level exclusively -type Annotated = 'Annotated -type Unannotated = 'Unannotated - -type family IfAnn (ann :: AnnotationFlag) (yes :: k) (no :: k) :: k where - IfAnn Annotated yes no = yes - IfAnn Unannotated yes no = no - -data family LetDecRHS :: AnnotationFlag -> Type -data instance LetDecRHS Annotated - = -- A function definition. Invariant: each ADClause contains at least one - -- pattern. - AFunction - Int -- The number of arrows in the type. As a consequence of the invariant - -- above, this is always a positive number. - [ADClause] - - | -- A value whose definition is given by the DExp. Invariant: the value is - -- not a function (i.e., there are no occurrences of (->) in the value's - -- type). - AValue - ADExp -data instance LetDecRHS Unannotated = UFunction [DClause] - | UValue DExp - -type ALetDecRHS = LetDecRHS Annotated -type ULetDecRHS = LetDecRHS Unannotated - -data LetDecEnv ann = LetDecEnv - { lde_defns :: OMap Name (LetDecRHS ann) - , lde_types :: OMap Name DType -- type signatures - , lde_infix :: OMap Name Fixity -- infix declarations - , lde_proms :: IfAnn ann (OMap Name DType) () -- possibly, promotions - } -type ALetDecEnv = LetDecEnv Annotated -type ULetDecEnv = LetDecEnv Unannotated - -instance Semigroup ULetDecEnv where - LetDecEnv defns1 types1 infx1 _ <> LetDecEnv defns2 types2 infx2 _ = - LetDecEnv (defns1 <> defns2) (types1 <> types2) (infx1 <> infx2) () - -instance Monoid ULetDecEnv where - mempty = LetDecEnv OMap.empty OMap.empty OMap.empty () - -valueBinding :: Name -> ULetDecRHS -> ULetDecEnv -valueBinding n v = emptyLetDecEnv { lde_defns = OMap.singleton n v } - -typeBinding :: Name -> DType -> ULetDecEnv -typeBinding n t = emptyLetDecEnv { lde_types = OMap.singleton n t } - -infixDecl :: Fixity -> Name -> ULetDecEnv -infixDecl f n = emptyLetDecEnv { lde_infix = OMap.singleton n f } - -emptyLetDecEnv :: ULetDecEnv -emptyLetDecEnv = mempty - -buildLetDecEnv :: Quasi q => [DLetDec] -> q ULetDecEnv -buildLetDecEnv = go emptyLetDecEnv - where - go acc [] = return acc - go acc (DFunD name clauses : rest) = - go (valueBinding name (UFunction clauses) <> acc) rest - go acc (DValD (DVarP name) exp : rest) = - go (valueBinding name (UValue exp) <> acc) rest - go acc (dec@(DValD {}) : rest) = do - flattened <- flattenDValD dec - go acc (flattened ++ rest) - go acc (DSigD name ty : rest) = - go (typeBinding name ty <> acc) rest - go acc (DInfixD f n : rest) = - go (infixDecl f n <> acc) rest - go acc (DPragmaD{} : rest) = go acc rest - --- See Note [DerivedDecl] -data DerivedDecl (cls :: Type -> Constraint) = DerivedDecl - { ded_mb_cxt :: Maybe DCxt - , ded_type :: DType - , ded_type_tycon :: Name - , ded_decl :: DataDecl - } - -type DerivedEqDecl = DerivedDecl Eq -type DerivedShowDecl = DerivedDecl Show - -{- Note [DerivedDecl] -~~~~~~~~~~~~~~~~~~~~~ -Most derived instances are wholly handled in -Data.Singletons.TH.Partition.partitionDecs. There are two notable exceptions to -this rule, however, that are partially handled outside of partitionDecs: -Eq and Show instances. For these instances, we use a DerivedDecl data type to -encode just enough information to recreate the derived instance: - -1. Just the instance context, if it's standalone-derived, or Nothing if it's in - a deriving clause (ded_mb_cxt) -2. The datatype, applied to some number of type arguments, as in the - instance declaration (ded_type) -3. The datatype name (ded_type_tycon), cached for convenience -4. The datatype's constructors (ded_cons) - -Why are these instances handled outside of partitionDecs? - -* Deriving Eq in singletons-th not only derives PEq/SEq instances, but it also - derives SDecide, TestEquality, and TestCoercion instances. - Data.Singletons.TH.Single (depending on the task at hand). -* Deriving Show in singletons-th not only derives PShow/SShow instances, but it - also derives Show instances for singletons-th types. - -To make this work, we let partitionDecs handle the P{Eq,Show} and S{Eq,Show} -instances, but we also stick the relevant info into a DerivedDecl value for -later use in Data.Singletons.TH.Single, where we additionally generate -SDecide, TestEquality, TestCoercion and Show instances for singleton types. --} +{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}++{- Data/Singletons/TH/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.+-}++module Data.Singletons.TH.Syntax where++import Prelude hiding ( exp )+import Data.Kind (Constraint, Type)+import Language.Haskell.TH.Syntax hiding (Type)+import Language.Haskell.TH.Desugar+import qualified Language.Haskell.TH.Desugar.OMap.Strict as OMap+import Language.Haskell.TH.Desugar.OMap.Strict (OMap)+import Language.Haskell.TH.Desugar.OSet (OSet)++type VarPromotions = [(Name, Name)] -- from term-level name to type-level name++-- Information that is accumulated when promoting patterns.+data PromDPatInfos = PromDPatInfos+ { prom_dpat_vars :: VarPromotions+ -- Maps term-level pattern variables to their promoted, type-level counterparts.+ , prom_dpat_sig_kvs :: OSet Name+ -- Kind variables bound by DSigPas.+ -- See Note [Scoped type variables] in Data.Singletons.TH.Promote.Monad.+ }++instance Semigroup PromDPatInfos where+ PromDPatInfos vars1 sig_kvs1 <> PromDPatInfos vars2 sig_kvs2+ = PromDPatInfos (vars1 <> vars2) (sig_kvs1 <> sig_kvs2)++instance Monoid PromDPatInfos where+ mempty = PromDPatInfos mempty mempty++-- A list of 'SingDSigPaInfos' is produced when singling pattern signatures, as we+-- must case on the 'DExp's and match on them using the supplied 'DType's to+-- bring the necessary singleton equality constraints into scope.+-- See @Note [Singling pattern signatures]@.+type SingDSigPaInfos = [(DExp, DType)]++-- The parts of data declarations that are relevant to singletons-th.+data DataDecl = DataDecl DataFlavor Name [DTyVarBndrVis] [DCon]++-- The parts of type synonyms that are relevant to singletons-th.+data TySynDecl = TySynDecl Name [DTyVarBndrVis] DType++-- The parts of open type families that are relevant to singletons-th.+type OpenTypeFamilyDecl = TypeFamilyDecl 'Open++-- The parts of closed type families that are relevant to singletons-th.+type ClosedTypeFamilyDecl = TypeFamilyDecl 'Closed++-- The parts of type families that are relevant to singletons-th.+newtype TypeFamilyDecl (info :: FamilyInfo)+ = TypeFamilyDecl { getTypeFamilyDecl :: DTypeFamilyHead }+-- Whether a type family is open or closed.+data FamilyInfo = Open | Closed++data ClassDecl ann+ = ClassDecl { cd_cxt :: DCxt+ , cd_name :: Name+ , cd_tvbs :: [DTyVarBndrVis]+ , cd_fds :: [FunDep]+ , cd_lde :: LetDecEnv ann+ , cd_atfs :: [OpenTypeFamilyDecl]+ -- Associated type families. Only recorded for+ -- defunctionalization purposes.+ -- See Note [Partitioning, type synonyms, and type families]+ -- in D.S.TH.Partition.+ }++data InstDecl ann = InstDecl { id_cxt :: DCxt+ , id_name :: Name+ , id_arg_tys :: [DType]+ , id_sigs :: OMap Name DType+ , id_meths :: [(Name, LetDecRHS ann)] }++type UClassDecl = ClassDecl Unannotated+type UInstDecl = InstDecl Unannotated++type AClassDecl = ClassDecl Annotated+type AInstDecl = InstDecl Annotated++{-+We see below several datatypes beginning with "A". These are annotated structures,+necessary for Promote to communicate key things to Single. In particular, promotion+of expressions is *not* deterministic, due to the necessity to create unique names+for lets, cases, and lambdas. So, we put these promotions into an annotated AST+so that Single can use the right promotions.+-}++-- A DExp with let, lambda, and type-signature nodes annotated with their+-- type-level equivalents+data ADExp = ADVarE Name+ | ADConE Name+ | ADLitE Lit+ | ADAppE ADExp ADExp+ | ADLamE [Name] -- type-level names corresponding to term-level ones+ DType -- the promoted lambda+ [Name] ADExp+ | ADCaseE ADExp [ADMatch] DType+ -- the type is the return type+ | ADLetE ALetDecEnv ADExp+ | ADSigE DType -- the promoted expression+ ADExp DType++-- A DPat with a pattern-signature node annotated with its type-level equivalent+data ADPat = ADLitP Lit+ | ADVarP Name+ | ADConP Name [DType] [ADPat]+ | ADTildeP ADPat+ | ADBangP ADPat+ | ADSigP DType -- The promoted pattern. Will not contain any wildcards,+ -- as per Note [Singling pattern signatures]+ ADPat DType+ | ADWildP++data ADMatch = ADMatch VarPromotions ADPat ADExp+data ADClause = ADClause VarPromotions+ [ADPat] ADExp++data AnnotationFlag = Annotated | Unannotated++-- These are used at the type-level exclusively+type Annotated = 'Annotated+type Unannotated = 'Unannotated++type family IfAnn (ann :: AnnotationFlag) (yes :: k) (no :: k) :: k where+ IfAnn Annotated yes no = yes+ IfAnn Unannotated yes no = no++data family LetDecRHS :: AnnotationFlag -> Type+data instance LetDecRHS Annotated+ = -- A function definition. Invariant: each ADClause contains at least one+ -- pattern.+ AFunction+ Int -- The number of arrows in the type. As a consequence of the invariant+ -- above, this is always a positive number.+ [ADClause]++ | -- A value whose definition is given by the DExp. Invariant: the value is+ -- not a function (i.e., there are no occurrences of (->) in the value's+ -- type).+ AValue+ ADExp+data instance LetDecRHS Unannotated = UFunction [DClause]+ | UValue DExp++type ALetDecRHS = LetDecRHS Annotated+type ULetDecRHS = LetDecRHS Unannotated++data LetDecEnv ann = LetDecEnv+ { lde_defns :: OMap Name (LetDecRHS ann)+ , lde_types :: OMap Name DType -- type signatures+ , lde_infix :: OMap Name Fixity -- infix declarations+ , lde_proms :: IfAnn ann (OMap Name DType) () -- possibly, promotions+ }+type ALetDecEnv = LetDecEnv Annotated+type ULetDecEnv = LetDecEnv Unannotated++instance Semigroup ULetDecEnv where+ LetDecEnv defns1 types1 infx1 _ <> LetDecEnv defns2 types2 infx2 _ =+ LetDecEnv (defns1 <> defns2) (types1 <> types2) (infx1 <> infx2) ()++instance Monoid ULetDecEnv where+ mempty = LetDecEnv OMap.empty OMap.empty OMap.empty ()++valueBinding :: Name -> ULetDecRHS -> ULetDecEnv+valueBinding n v = emptyLetDecEnv { lde_defns = OMap.singleton n v }++typeBinding :: Name -> DType -> ULetDecEnv+typeBinding n t = emptyLetDecEnv { lde_types = OMap.singleton n t }++infixDecl :: Fixity -> Name -> ULetDecEnv+infixDecl f n = emptyLetDecEnv { lde_infix = OMap.singleton n f }++emptyLetDecEnv :: ULetDecEnv+emptyLetDecEnv = mempty++buildLetDecEnv :: Quasi q => [DLetDec] -> q ULetDecEnv+buildLetDecEnv = go emptyLetDecEnv+ where+ go acc [] = return acc+ go acc (DFunD name clauses : rest) =+ go (valueBinding name (UFunction clauses) <> acc) rest+ go acc (DValD (DVarP name) exp : rest) =+ go (valueBinding name (UValue exp) <> acc) rest+ go acc (dec@(DValD {}) : rest) = do+ flattened <- flattenDValD dec+ go acc (flattened ++ rest)+ go acc (DSigD name ty : rest) =+ go (typeBinding name ty <> acc) rest+ go acc (DInfixD f n : rest) =+ go (infixDecl f n <> acc) rest+ go acc (DPragmaD{} : rest) = go acc rest++-- See Note [DerivedDecl]+data DerivedDecl (cls :: Type -> Constraint) = DerivedDecl+ { ded_mb_cxt :: Maybe DCxt+ , ded_type :: DType+ , ded_type_tycon :: Name+ , ded_decl :: DataDecl+ }++type DerivedEqDecl = DerivedDecl Eq+type DerivedOrdDecl = DerivedDecl Ord+type DerivedShowDecl = DerivedDecl Show++{- Note [DerivedDecl]+~~~~~~~~~~~~~~~~~~~~~+Most derived instances are wholly handled in+Data.Singletons.TH.Partition.partitionDecs. There are two notable exceptions to+this rule, however, that are partially handled outside of partitionDecs:+Eq and Show instances. For these instances, we use a DerivedDecl data type to+encode just enough information to recreate the derived instance:++1. Just the instance context, if it's standalone-derived, or Nothing if it's in+ a deriving clause (ded_mb_cxt)+2. The datatype, applied to some number of type arguments, as in the+ instance declaration (ded_type)+3. The datatype name (ded_type_tycon), cached for convenience+4. The datatype's constructors (ded_cons)++Why are these instances handled outside of partitionDecs?++* Deriving Eq in singletons-th not only derives PEq/SEq instances, but it also+ derives SDecide, Eq, TestEquality, and TestCoercion instances.+* Deriving Ord in singletons-th not only derives POrd/SOrd instances, but it also+ derives Ord instances for the singleton types themselves.+* Deriving Show in singletons-th not only derives PShow/SShow instances, but it+ also derives Show instances for the singleton types themselves.++To make this work, we let partitionDecs handle the P{Eq,Show} and S{Eq,Show}+instances, but we also stick the relevant info into a DerivedDecl value for+later use in Data.Singletons.TH.Single, where we additionally generate+SDecide, Eq, TestEquality, TestCoercion and Show instances for singleton types.+-}
src/Data/Singletons/TH/Util.hs view
@@ -1,577 +1,697 @@-{-# LANGUAGE LambdaCase #-} - -{- Data/Singletons/TH/Util.hs - -(c) Richard Eisenberg 2013 -rae@cs.brynmawr.edu - -This file contains helper functions internal to the singletons-th package. -Users of the package should not need to consult this file. --} - -module Data.Singletons.TH.Util where - -import Prelude hiding ( exp, foldl, concat, mapM, any, pred ) -import Language.Haskell.TH ( pprint ) -import Language.Haskell.TH.Syntax hiding ( lift ) -import Language.Haskell.TH.Desugar -import Data.Char -import Control.Monad ( liftM, unless, when ) -import Control.Monad.Except ( ExceptT, runExceptT, MonadError(..) ) -import Control.Monad.IO.Class ( MonadIO ) -import Control.Monad.Reader ( MonadReader(..), Reader, ReaderT(..) ) -import Control.Monad.Trans ( MonadTrans ) -import Control.Monad.Writer ( MonadWriter(..), WriterT(..), execWriterT ) -import qualified Data.Map as Map -import Data.Map ( Map ) -import Data.Bifunctor (second) -import Data.Foldable -import Data.Functor.Identity -import Data.Traversable -import Data.Generics -import Data.Maybe - --- like reportWarning, but generalized to any Quasi -qReportWarning :: Quasi q => String -> q () -qReportWarning = qReport False - --- like reportError, but generalized to any Quasi -qReportError :: Quasi q => String -> q () -qReportError = qReport True - --- | Generate a new Unique -qNewUnique :: DsMonad q => q Uniq -qNewUnique = do - Name _ flav <- qNewName "x" - case flav of - NameU n -> return n - _ -> error "Internal error: `qNewName` didn't return a NameU" - -checkForRep :: Quasi q => [Name] -> q () -checkForRep names = - when (any ((== "Rep") . nameBase) names) - (fail $ "A data type named <<Rep>> is a special case.\n" ++ - "Promoting it will not work as expected.\n" ++ - "Please choose another name for your data type.") - -checkForRepInDecls :: Quasi q => [DDec] -> q () -checkForRepInDecls decls = - checkForRep (allNamesIn decls) - -tysOfConFields :: DConFields -> [DType] -tysOfConFields (DNormalC _ stys) = map snd stys -tysOfConFields (DRecC vstys) = map (\(_,_,ty) -> ty) vstys - -recSelsOfConFields :: DConFields -> [Name] -recSelsOfConFields DNormalC{} = [] -recSelsOfConFields (DRecC vstys) = map (\(n,_,_) -> n) vstys - --- Extract a data constructor's name and the number of arguments it accepts. -extractNameArgs :: DCon -> (Name, Int) -extractNameArgs (DCon _ _ n fields _) = (n, length (tysOfConFields fields)) - --- Extract a data constructor's name. -extractName :: DCon -> Name -extractName (DCon _ _ n _ _) = n - --- Extract the names of a data constructor's record selectors. -extractRecSelNames :: DCon -> [Name] -extractRecSelNames (DCon _ _ _ fields _) = recSelsOfConFields fields - --- | is a valid Haskell infix data constructor (i.e., does it begin with a colon?) -isInfixDataCon :: String -> Bool -isInfixDataCon (':':_) = True -isInfixDataCon _ = False - --- | Is an identifier a legal data constructor name in Haskell? That is, is its --- first character an uppercase letter (prefix) or a colon (infix)? -isDataConName :: Name -> Bool -isDataConName n = let first = head (nameBase n) in isUpper first || first == ':' - --- | Is an identifier uppercase? --- --- Note that this will always return 'False' for infix names, since the concept --- of upper- and lower-case doesn't make sense for non-alphabetic characters. --- If you want to check if a name is legal as a data constructor, use the --- 'isDataConName' function. -isUpcase :: Name -> Bool -isUpcase n = let first = head (nameBase n) in isUpper first - --- Make an identifier uppercase. If the identifier is infix, this acts as the --- identity function. -upcase :: Name -> Name -upcase = mkName . toUpcaseStr noPrefix - --- make an identifier uppercase and return it as a String -toUpcaseStr :: (String, String) -- (alpha, symb) prefixes to prepend - -> Name -> String -toUpcaseStr (alpha, symb) n - | isHsLetter first - = upcase_alpha - - | otherwise - = upcase_symb - - where - str = nameBase n - first = head str - - upcase_alpha = alpha ++ (toUpper first) : tail str - upcase_symb = symb ++ str - -noPrefix :: (String, String) -noPrefix = ("", "") - --- Put an uppercase prefix on a constructor name. Takes two prefixes: --- one for identifiers and one for symbols. --- --- This is different from 'prefixName' in that infix constructor names always --- start with a colon, so we must insert the prefix after the colon in order --- for the new name to be syntactically valid. -prefixConName :: String -> String -> Name -> Name -prefixConName pre tyPre n = case (nameBase n) of - (':' : rest) -> mkName (':' : tyPre ++ rest) - alpha -> mkName (pre ++ alpha) - --- Put a prefix on a name. Takes two prefixes: one for identifiers --- and one for symbols. -prefixName :: String -> String -> Name -> Name -prefixName pre tyPre n = - let str = nameBase n - first = head str in - if isHsLetter first - then mkName (pre ++ str) - else mkName (tyPre ++ str) - --- Put a suffix on a name. Takes two suffixes: one for identifiers --- and one for symbols. -suffixName :: String -> String -> Name -> Name -suffixName ident symb n = - let str = nameBase n - first = head str in - if isHsLetter first - then mkName (str ++ ident) - else mkName (str ++ symb) - --- convert a number into both alphanumeric and symoblic forms -uniquePrefixes :: String -- alphanumeric prefix - -> String -- symbolic prefix - -> Uniq - -> (String, String) -- (alphanum, symbolic) -uniquePrefixes alpha symb n = (alpha ++ n_str, symb ++ convert n_str) - where - n_str = show n - - convert [] = [] - convert (d : ds) = - let d' = case d of - '0' -> '!' - '1' -> '#' - '2' -> '$' - '3' -> '%' - '4' -> '&' - '5' -> '*' - '6' -> '+' - '7' -> '.' - '8' -> '/' - '9' -> '>' - _ -> error "non-digit in show #" - in d' : convert ds - --- extract the kind from a TyVarBndr -extractTvbKind :: DTyVarBndr flag -> Maybe DKind -extractTvbKind (DPlainTV _ _) = Nothing -extractTvbKind (DKindedTV _ _ k) = Just k - --- extract the name from a TyVarBndr. -extractTvbName :: DTyVarBndr flag -> Name -extractTvbName (DPlainTV n _) = n -extractTvbName (DKindedTV n _ _) = n - -tvbToType :: DTyVarBndr flag -> DType -tvbToType = DVarT . extractTvbName - --- If a type variable binder lacks an explicit kind, pick a default kind of --- Type. Otherwise, leave the binder alone. -defaultTvbToTypeKind :: DTyVarBndr flag -> DTyVarBndr flag -defaultTvbToTypeKind (DPlainTV tvname f) = DKindedTV tvname f $ DConT typeKindName -defaultTvbToTypeKind tvb = tvb - --- If @Nothing@, return @Type@. If @Just k@, return @k@. -defaultMaybeToTypeKind :: Maybe DKind -> DKind -defaultMaybeToTypeKind (Just k) = k -defaultMaybeToTypeKind Nothing = DConT typeKindName - -inferMaybeKindTV :: Name -> Maybe DKind -> DTyVarBndrUnit -inferMaybeKindTV n Nothing = DPlainTV n () -inferMaybeKindTV n (Just k) = DKindedTV n () k - -resultSigToMaybeKind :: DFamilyResultSig -> Maybe DKind -resultSigToMaybeKind DNoSig = Nothing -resultSigToMaybeKind (DKindSig k) = Just k -resultSigToMaybeKind (DTyVarSig DPlainTV{}) = Nothing -resultSigToMaybeKind (DTyVarSig (DKindedTV _ _ k)) = Just k - -maybeKindToResultSig :: Maybe DKind -> DFamilyResultSig -maybeKindToResultSig = maybe DNoSig DKindSig - -maybeSigT :: DType -> Maybe DKind -> DType -maybeSigT ty Nothing = ty -maybeSigT ty (Just ki) = ty `DSigT` ki - --- Reconstruct a vanilla function type from its individual type variable --- binders, constraints, argument types, and result type. (See --- Note [Vanilla-type validity checking during promotion] in --- Data.Singletons.TH.Promote.Type for what "vanilla" means.) -ravelVanillaDType :: [DTyVarBndrSpec] -> DCxt -> [DType] -> DType -> DType -ravelVanillaDType tvbs ctxt args res = - ifNonEmpty tvbs (DForallT . DForallInvis) $ - ifNonEmpty ctxt DConstrainedT $ - go args - where - ifNonEmpty :: [a] -> ([a] -> b -> b) -> b -> b - ifNonEmpty [] _ z = z - ifNonEmpty l f z = f l z - - go :: [DType] -> DType - go [] = res - go (h:t) = DAppT (DAppT DArrowT h) (go t) - --- Decompose a vanilla function type into its type variables, its context, its --- argument types, and its result type. (See --- Note [Vanilla-type validity checking during promotion] in --- Data.Singletons.TH.Promote.Type for what "vanilla" means.) --- If a non-vanilla construct is encountered while decomposing the function --- type, an error is thrown monadically. --- --- This should be contrasted with the 'unravelDType' function from --- @th-desugar@, which supports the full gamut of function types. @singletons-th@ --- only supports a subset of these types, which is why this function is used --- to decompose them instead. -unravelVanillaDType :: forall m. MonadFail m - => DType -> m ([DTyVarBndrSpec], DCxt, [DType], DType) -unravelVanillaDType ty = - case unravelVanillaDType_either ty of - Left err -> fail err - Right payload -> pure payload - --- Ensures that a 'DType' is a vanilla type. (See --- Note [Vanilla-type validity checking during promotion] in --- Data.Singletons.TH.Promote.Type for what "vanilla" means.) --- --- The only monadic thing that this function can do is 'fail', which it does --- if a non-vanilla construct is encountered. -checkVanillaDType :: forall m. MonadFail m => DType -> m () -checkVanillaDType ty = - case unravelVanillaDType_either ty of - Left err -> fail err - Right _ -> pure () - --- The workhorse that powers unravelVanillaDType and checkVanillaDType. --- Returns @Right payload@ upon success, and @Left error_msg@ upon failure. -unravelVanillaDType_either :: - DType -> Either String ([DTyVarBndrSpec], DCxt, [DType], DType) -unravelVanillaDType_either ty = - runIdentity $ flip runReaderT True $ runExceptT $ runUnravelM $ go_ty ty - where - go_ty :: DType -> UnravelM ([DTyVarBndrSpec], DCxt, [DType], DType) - go_ty typ = do - let (args1, res) = unravelDType typ - (args2, tvbs) <- take_tvbs args1 - (args3, ctxt) <- take_ctxt args2 - anons <- take_anons args3 - pure (tvbs, ctxt, anons, res) - - -- Process a type in a higher-order position (e.g., the @forall a. a -> a@ in - -- @(forall a. a -> a) -> b -> b@). This is only done to check for the - -- presence of higher-rank foralls or constraints, which are not permitted - -- in vanilla types. - go_higher_order_ty :: DType -> UnravelM () - go_higher_order_ty typ = () <$ local (const False) (go_ty typ) - - take_tvbs :: DFunArgs -> UnravelM (DFunArgs, [DTyVarBndrSpec]) - take_tvbs (DFAForalls (DForallInvis tvbs) args) = do - rank_1 <- ask - unless rank_1 $ fail_forall "higher-rank" - _ <- traverse_ (traverse_ go_higher_order_ty . extractTvbKind) tvbs - (args', tvbs') <- take_tvbs args - pure (args', tvbs ++ tvbs') - take_tvbs (DFAForalls DForallVis{} _) = fail_vdq - take_tvbs args = pure (args, []) - - take_ctxt :: DFunArgs -> UnravelM (DFunArgs, DCxt) - take_ctxt (DFACxt ctxt args) = do - rank_1 <- ask - unless rank_1 $ fail_ctxt "higher-rank" - traverse_ go_higher_order_ty ctxt - (args', ctxt') <- take_ctxt args - pure (args', ctxt ++ ctxt') - take_ctxt (DFAForalls tele _) = - case tele of - DForallInvis{} -> fail_forall "nested" - DForallVis{} -> fail_vdq - take_ctxt args = pure (args, []) - - take_anons :: DFunArgs -> UnravelM [DType] - take_anons (DFAAnon anon args) = do - go_higher_order_ty anon - anons <- take_anons args - pure (anon:anons) - take_anons (DFAForalls tele _) = - case tele of - DForallInvis{} -> fail_forall "nested" - DForallVis{} -> fail_vdq - take_anons (DFACxt _ _) = fail_ctxt "nested" - take_anons DFANil = pure [] - - failWith :: MonadError String m => String -> m a - failWith thing = throwError $ unlines - [ "`singletons-th` does not support " ++ thing - , "In the type: " ++ pprint (sweeten ty) - ] - - fail_forall :: MonadError String m => String -> m a - fail_forall sort = failWith $ sort ++ " `forall`s" - - fail_vdq :: MonadError String m => m a - fail_vdq = failWith "visible dependent quantification" - - fail_ctxt :: MonadError String m => String -> m a - fail_ctxt sort = failWith $ sort ++ " contexts" - --- The monad that powers the internals of unravelVanillaDType_either. --- --- * ExceptT String: records the error message upon failure. --- --- * Reader Bool: True if we are in a rank-1 position in a type, False otherwise -newtype UnravelM a = UnravelM { runUnravelM :: ExceptT String (Reader Bool) a } - deriving (Functor, Applicative, Monad, MonadError String, MonadReader Bool) - --- count the number of arguments in a type -countArgs :: DType -> Int -countArgs ty = length $ filterDVisFunArgs args - where (args, _) = unravelDType ty - --- Collect the invisible type variable binders from a sequence of DFunArgs. -filterInvisTvbArgs :: DFunArgs -> [DTyVarBndrSpec] -filterInvisTvbArgs DFANil = [] -filterInvisTvbArgs (DFACxt _ args) = filterInvisTvbArgs args -filterInvisTvbArgs (DFAAnon _ args) = filterInvisTvbArgs args -filterInvisTvbArgs (DFAForalls tele args) = - let res = filterInvisTvbArgs args in - case tele of - DForallVis _ -> res - DForallInvis tvbs' -> tvbs' ++ res - --- Infer the kind of a DTyVarBndr by using information from a DVisFunArg. -replaceTvbKind :: DVisFunArg -> DTyVarBndrUnit -> DTyVarBndrUnit -replaceTvbKind (DVisFADep tvb) _ = tvb -replaceTvbKind (DVisFAAnon k) tvb = DKindedTV (extractTvbName tvb) () k - --- changes all TyVars not to be NameU's. Workaround for GHC#11812/#17537/#19743 -noExactTyVars :: Data a => a -> a -noExactTyVars = everywhere go - where - go :: Data a => a -> a - go = mkT (fix_tvb @Specificity) - `extT` fix_tvb @() - `extT` fix_ty - `extT` fix_inj_ann - - fix_tvb :: Typeable flag => DTyVarBndr flag -> DTyVarBndr flag - fix_tvb (DPlainTV n f) = DPlainTV (noExactName n) f - fix_tvb (DKindedTV n f k) = DKindedTV (noExactName n) f k - - fix_ty (DVarT n) = DVarT (noExactName n) - fix_ty ty = ty - - fix_inj_ann (InjectivityAnn lhs rhs) - = InjectivityAnn (noExactName lhs) (map noExactName rhs) - --- changes a Name not to be a NameU. Workaround for GHC#11812/#17537/#19743 -noExactName :: Name -> Name -noExactName (Name (OccName occ) (NameU unique)) = mkName (occ ++ show unique) -noExactName n = n - -substKind :: Map Name DKind -> DKind -> DKind -substKind = substType - --- | Non–capture-avoiding substitution. (If you want capture-avoiding --- substitution, use @substTy@ from "Language.Haskell.TH.Desugar.Subst". -substType :: Map Name DType -> DType -> DType -substType subst ty | Map.null subst = ty -substType subst (DForallT tele inner_ty) - = DForallT tele' inner_ty' - where - (subst', tele') = subst_tele subst tele - inner_ty' = substType subst' inner_ty -substType subst (DConstrainedT cxt inner_ty) = - DConstrainedT (map (substType subst) cxt) (substType subst inner_ty) -substType subst (DAppT ty1 ty2) = substType subst ty1 `DAppT` substType subst ty2 -substType subst (DAppKindT ty ki) = substType subst ty `DAppKindT` substType subst ki -substType subst (DSigT ty ki) = substType subst ty `DSigT` substType subst ki -substType subst (DVarT n) = - case Map.lookup n subst of - Just ki -> ki - Nothing -> DVarT n -substType _ ty@(DConT {}) = ty -substType _ ty@(DArrowT) = ty -substType _ ty@(DLitT {}) = ty -substType _ ty@DWildCardT = ty - -subst_tele :: Map Name DKind -> DForallTelescope -> (Map Name DKind, DForallTelescope) -subst_tele s (DForallInvis tvbs) = second DForallInvis $ subst_tvbs s tvbs -subst_tele s (DForallVis tvbs) = second DForallVis $ subst_tvbs s tvbs - -subst_tvbs :: Map Name DKind -> [DTyVarBndr flag] -> (Map Name DKind, [DTyVarBndr flag]) -subst_tvbs = mapAccumL subst_tvb - -subst_tvb :: Map Name DKind -> DTyVarBndr flag -> (Map Name DKind, DTyVarBndr flag) -subst_tvb s tvb@(DPlainTV n _) = (Map.delete n s, tvb) -subst_tvb s (DKindedTV n f k) = (Map.delete n s, DKindedTV n f (substKind s k)) - -dropTvbKind :: DTyVarBndr flag -> DTyVarBndr flag -dropTvbKind tvb@(DPlainTV {}) = tvb -dropTvbKind (DKindedTV n f _) = DPlainTV n f - --- apply a type to a list of types -foldType :: DType -> [DType] -> DType -foldType = foldl DAppT - --- apply a type to a list of type variable binders -foldTypeTvbs :: DType -> [DTyVarBndr flag] -> DType -foldTypeTvbs ty = foldType ty . map tvbToType - --- Construct a data type's variable binders, possibly using fresh variables --- from the data type's kind signature. -buildDataDTvbs :: DsMonad q => [DTyVarBndrUnit] -> Maybe DKind -> q [DTyVarBndrUnit] -buildDataDTvbs tvbs mk = do - extra_tvbs <- mkExtraDKindBinders $ fromMaybe (DConT typeKindName) mk - pure $ tvbs ++ extra_tvbs - --- apply an expression to a list of expressions -foldExp :: DExp -> [DExp] -> DExp -foldExp = foldl DAppE - --- choose the first non-empty list -orIfEmpty :: [a] -> [a] -> [a] -orIfEmpty [] x = x -orIfEmpty x _ = x - --- build a pattern match over several expressions, each with only one pattern -multiCase :: [DExp] -> [DPat] -> DExp -> DExp -multiCase [] [] body = body -multiCase scruts pats body = - DCaseE (mkTupleDExp scruts) [DMatch (mkTupleDPat pats) body] - --- a monad transformer for writing a monoid alongside returning a Q -newtype QWithAux m q a = QWA { runQWA :: WriterT m q a } - deriving ( Functor, Applicative, Monad, MonadTrans - , MonadWriter m, MonadReader r - , MonadFail, MonadIO, Quasi, DsMonad ) - --- run a computation with an auxiliary monoid, discarding the monoid result -evalWithoutAux :: Quasi q => QWithAux m q a -> q a -evalWithoutAux = liftM fst . runWriterT . runQWA - --- run a computation with an auxiliary monoid, returning only the monoid result -evalForAux :: Quasi q => QWithAux m q a -> q m -evalForAux = execWriterT . runQWA - --- run a computation with an auxiliary monoid, return both the result --- of the computation and the monoid result -evalForPair :: QWithAux m q a -> q (a, m) -evalForPair = runWriterT . runQWA - --- in a computation with an auxiliary map, add a binding to the map -addBinding :: (Quasi q, Ord k) => k -> v -> QWithAux (Map.Map k v) q () -addBinding k v = tell (Map.singleton k v) - --- in a computation with an auxiliar list, add an element to the list -addElement :: Quasi q => elt -> QWithAux [elt] q () -addElement elt = tell [elt] - --- | Call 'lookupTypeNameWithLocals' first to ensure we have a 'Name' in the --- type namespace, then call 'dsReify'. - --- See also Note [Using dsReifyTypeNameInfo when promoting instances] --- in Data.Singletons.TH.Promote. -dsReifyTypeNameInfo :: DsMonad q => Name -> q (Maybe DInfo) -dsReifyTypeNameInfo ty_name = do - mb_name <- lookupTypeNameWithLocals (nameBase ty_name) - case mb_name of - Just n -> dsReify n - Nothing -> pure Nothing - --- lift concatMap into a monad --- could this be more efficient? -concatMapM :: (Monad monad, Monoid monoid, Traversable t) - => (a -> monad monoid) -> t a -> monad monoid -concatMapM fn list = do - bss <- mapM fn list - return $ fold bss - --- like GHC's -mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b] -mapMaybeM _ [] = return [] -mapMaybeM f (x:xs) = do - y <- f x - ys <- mapMaybeM f xs - return $ case y of - Nothing -> ys - Just z -> z : ys - --- make a one-element list -listify :: a -> [a] -listify = (:[]) - -fstOf3 :: (a,b,c) -> a -fstOf3 (a,_,_) = a - -liftFst :: (a -> b) -> (a, c) -> (b, c) -liftFst f (a, c) = (f a, c) - -liftSnd :: (a -> b) -> (c, a) -> (c, b) -liftSnd f (c, a) = (c, f a) - -snocView :: [a] -> ([a], a) -snocView [] = error "snocView nil" -snocView [x] = ([], x) -snocView (x : xs) = liftFst (x:) (snocView xs) - -partitionWith :: (a -> Either b c) -> [a] -> ([b], [c]) -partitionWith f = go [] [] - where go bs cs [] = (reverse bs, reverse cs) - go bs cs (a:as) = - case f a of - Left b -> go (b:bs) cs as - Right c -> go bs (c:cs) as - -partitionWithM :: Monad m => (a -> m (Either b c)) -> [a] -> m ([b], [c]) -partitionWithM f = go [] [] - where go bs cs [] = return (reverse bs, reverse cs) - go bs cs (a:as) = do - fa <- f a - case fa of - Left b -> go (b:bs) cs as - Right c -> go bs (c:cs) as - -partitionLetDecs :: [DDec] -> ([DLetDec], [DDec]) -partitionLetDecs = partitionWith (\case DLetDec ld -> Left ld - dec -> Right dec) - -{-# INLINEABLE zipWith3M #-} -zipWith3M :: Monad m => (a -> b -> m c) -> [a] -> [b] -> m [c] -zipWith3M f (a:as) (b:bs) = (:) <$> f a b <*> zipWith3M f as bs -zipWith3M _ _ _ = return [] - -mapAndUnzip3M :: Monad m => (a -> m (b,c,d)) -> [a] -> m ([b],[c],[d]) -mapAndUnzip3M _ [] = return ([],[],[]) -mapAndUnzip3M f (x:xs) = do - (r1, r2, r3) <- f x - (rs1, rs2, rs3) <- mapAndUnzip3M f xs - return (r1:rs1, r2:rs2, r3:rs3) - --- is it a letter or underscore? -isHsLetter :: Char -> Bool -isHsLetter c = isLetter c || c == '_' +{-# LANGUAGE LambdaCase #-}++{- Data/Singletons/TH/Util.hs++(c) Richard Eisenberg 2013+rae@cs.brynmawr.edu++This file contains helper functions internal to the singletons-th package.+Users of the package should not need to consult this file.+-}++module Data.Singletons.TH.Util where++import Prelude hiding ( exp, foldl, concat, mapM, any, pred )+import Language.Haskell.TH ( pprint )+import Language.Haskell.TH.Syntax hiding ( lift )+import Language.Haskell.TH.Desugar+import Data.Char+import Control.Monad ( liftM, unless, when )+import Control.Monad.Except ( ExceptT, runExceptT, MonadError(..) )+import Control.Monad.IO.Class ( MonadIO )+import Control.Monad.Reader ( MonadReader(..), Reader, ReaderT(..) )+import Control.Monad.Trans ( MonadTrans )+import Control.Monad.Writer ( MonadWriter(..), WriterT(..), execWriterT )+import qualified Data.Map as Map+import Data.Map ( Map )+import Data.Bifunctor (second)+import Data.Foldable+import Data.Functor.Identity+import Data.Traversable+import Data.Generics+import Data.Maybe++-- like reportWarning, but generalized to any Quasi+qReportWarning :: Quasi q => String -> q ()+qReportWarning = qReport False++-- like reportError, but generalized to any Quasi+qReportError :: Quasi q => String -> q ()+qReportError = qReport True++-- | Generate a new Unique+qNewUnique :: DsMonad q => q Uniq+qNewUnique = do+ Name _ flav <- qNewName "x"+ case flav of+ NameU n -> return n+ _ -> error "Internal error: `qNewName` didn't return a NameU"++checkForRep :: Quasi q => [Name] -> q ()+checkForRep names =+ when (any ((== "Rep") . nameBase) names)+ (fail $ "A data type named <<Rep>> is a special case.\n" +++ "Promoting it will not work as expected.\n" +++ "Please choose another name for your data type.")++checkForRepInDecls :: Quasi q => [DDec] -> q ()+checkForRepInDecls decls =+ checkForRep (allNamesIn decls)++tysOfConFields :: DConFields -> [DType]+tysOfConFields (DNormalC _ stys) = map snd stys+tysOfConFields (DRecC vstys) = map (\(_,_,ty) -> ty) vstys++recSelsOfConFields :: DConFields -> [Name]+recSelsOfConFields DNormalC{} = []+recSelsOfConFields (DRecC vstys) = map (\(n,_,_) -> n) vstys++-- Extract a data constructor's name and the number of arguments it accepts.+extractNameArgs :: DCon -> (Name, Int)+extractNameArgs (DCon _ _ n fields _) = (n, length (tysOfConFields fields))++-- Extract a data constructor's name.+extractName :: DCon -> Name+extractName (DCon _ _ n _ _) = n++-- Extract the names of a data constructor's record selectors.+extractRecSelNames :: DCon -> [Name]+extractRecSelNames (DCon _ _ _ fields _) = recSelsOfConFields fields++-- | is a valid Haskell infix data constructor (i.e., does it begin with a colon?)+isInfixDataCon :: String -> Bool+isInfixDataCon (':':_) = True+isInfixDataCon _ = False++-- | Is an identifier a legal data constructor name in Haskell? That is, is its+-- first character an uppercase letter (prefix) or a colon (infix)?+isDataConName :: Name -> Bool+isDataConName n = let first = headNameStr (nameBase n) in isUpper first || first == ':'++-- | Is an identifier uppercase?+--+-- Note that this will always return 'False' for infix names, since the concept+-- of upper- and lower-case doesn't make sense for non-alphabetic characters.+-- If you want to check if a name is legal as a data constructor, use the+-- 'isDataConName' function.+isUpcase :: Name -> Bool+isUpcase n = let first = headNameStr (nameBase n) in isUpper first++-- Make an identifier uppercase. If the identifier is infix, this acts as the+-- identity function.+upcase :: Name -> Name+upcase = mkName . toUpcaseStr noPrefix++-- make an identifier uppercase and return it as a String+toUpcaseStr :: (String, String) -- (alpha, symb) prefixes to prepend+ -> Name -> String+toUpcaseStr (alpha, symb) n+ | isHsLetter first+ = upcase_alpha++ | otherwise+ = upcase_symb++ where+ str = nameBase n+ first = headNameStr str++ upcase_alpha = alpha ++ (toUpper first) : tailNameStr str+ upcase_symb = symb ++ str++noPrefix :: (String, String)+noPrefix = ("", "")++-- Put an uppercase prefix on a constructor name. Takes two prefixes:+-- one for identifiers and one for symbols.+--+-- This is different from 'prefixName' in that infix constructor names always+-- start with a colon, so we must insert the prefix after the colon in order+-- for the new name to be syntactically valid.+prefixConName :: String -> String -> Name -> Name+prefixConName pre tyPre n = case (nameBase n) of+ (':' : rest) -> mkName (':' : tyPre ++ rest)+ alpha -> mkName (pre ++ alpha)++-- Put a prefix on a name. Takes two prefixes: one for identifiers+-- and one for symbols.+prefixName :: String -> String -> Name -> Name+prefixName pre tyPre n =+ let str = nameBase n+ first = headNameStr str in+ if isHsLetter first+ then mkName (pre ++ str)+ else mkName (tyPre ++ str)++-- Put a suffix on a name. Takes two suffixes: one for identifiers+-- and one for symbols.+suffixName :: String -> String -> Name -> Name+suffixName ident symb n =+ let str = nameBase n+ first = headNameStr str in+ if isHsLetter first+ then mkName (str ++ ident)+ else mkName (str ++ symb)++-- Return the first character in a Name's string (i.e., nameBase).+-- Precondition: the string is non-empty.+headNameStr :: String -> Char+headNameStr str =+ case str of+ (c:_) -> c+ [] -> error "headNameStr: Expected non-empty string"++-- Drop the first character in a Name's string (i.e., nameBase).+-- Precondition: the string is non-empty.+tailNameStr :: String -> String+tailNameStr str =+ case str of+ (_:cs) -> cs+ [] -> error "tailNameStr: Expected non-empty string"++-- convert a number into both alphanumeric and symoblic forms+uniquePrefixes :: String -- alphanumeric prefix+ -> String -- symbolic prefix+ -> Uniq+ -> (String, String) -- (alphanum, symbolic)+uniquePrefixes alpha symb n = (alpha ++ n_str, symb ++ convert n_str)+ where+ n_str = show n++ convert [] = []+ convert (d : ds) =+ let d' = case d of+ '0' -> '!'+ '1' -> '#'+ '2' -> '$'+ '3' -> '%'+ '4' -> '&'+ '5' -> '*'+ '6' -> '+'+ '7' -> '.'+ '8' -> '/'+ '9' -> '>'+ _ -> error "non-digit in show #"+ in d' : convert ds++-- extract the kind from a TyVarBndr+extractTvbKind :: DTyVarBndr flag -> Maybe DKind+extractTvbKind (DPlainTV _ _) = Nothing+extractTvbKind (DKindedTV _ _ k) = Just k++-- extract the name from a TyVarBndr.+extractTvbName :: DTyVarBndr flag -> Name+extractTvbName (DPlainTV n _) = n+extractTvbName (DKindedTV n _ _) = n++-- extract the flag from a TyVarBndr.+extractTvbFlag :: DTyVarBndr flag -> flag+extractTvbFlag (DPlainTV _ f) = f+extractTvbFlag (DKindedTV _ f _) = f++-- Map over the 'Name' of a 'DTyVarBndr'.+mapDTVName :: (Name -> Name) -> DTyVarBndr flag -> DTyVarBndr flag+mapDTVName f (DPlainTV name flag) = DPlainTV (f name) flag+mapDTVName f (DKindedTV name flag kind) = DKindedTV (f name) flag kind++-- Map over the 'DKind' of a 'DTyVarBndr'.+mapDTVKind :: (DKind -> DKind) -> DTyVarBndr flag -> DTyVarBndr flag+mapDTVKind _ tvb@(DPlainTV{}) = tvb+mapDTVKind f (DKindedTV name flag kind) = DKindedTV name flag (f kind)++tvbToType :: DTyVarBndr flag -> DType+tvbToType = DVarT . extractTvbName++-- If a type variable binder lacks an explicit kind, pick a default kind of+-- Type. Otherwise, leave the binder alone.+defaultTvbToTypeKind :: DTyVarBndr flag -> DTyVarBndr flag+defaultTvbToTypeKind (DPlainTV tvname f) = DKindedTV tvname f $ DConT typeKindName+defaultTvbToTypeKind tvb = tvb++-- If @Nothing@, return @Type@. If @Just k@, return @k@.+defaultMaybeToTypeKind :: Maybe DKind -> DKind+defaultMaybeToTypeKind (Just k) = k+defaultMaybeToTypeKind Nothing = DConT typeKindName++inferMaybeKindTV :: Name -> Maybe DKind -> DTyVarBndrUnit+inferMaybeKindTV n Nothing = DPlainTV n ()+inferMaybeKindTV n (Just k) = DKindedTV n () k++resultSigToMaybeKind :: DFamilyResultSig -> Maybe DKind+resultSigToMaybeKind DNoSig = Nothing+resultSigToMaybeKind (DKindSig k) = Just k+resultSigToMaybeKind (DTyVarSig DPlainTV{}) = Nothing+resultSigToMaybeKind (DTyVarSig (DKindedTV _ _ k)) = Just k++maybeKindToResultSig :: Maybe DKind -> DFamilyResultSig+maybeKindToResultSig = maybe DNoSig DKindSig++maybeSigT :: DType -> Maybe DKind -> DType+maybeSigT ty Nothing = ty+maybeSigT ty (Just ki) = ty `DSigT` ki++-- Reconstruct a vanilla function type from its individual type variable+-- binders, constraints, argument types, and result type. (See+-- Note [Vanilla-type validity checking during promotion] in+-- Data.Singletons.TH.Promote.Type for what "vanilla" means.)+ravelVanillaDType :: [DTyVarBndrSpec] -> DCxt -> [DType] -> DType -> DType+ravelVanillaDType tvbs ctxt args res =+ ifNonEmpty tvbs (DForallT . DForallInvis) $+ ifNonEmpty ctxt DConstrainedT $+ go args+ where+ ifNonEmpty :: [a] -> ([a] -> b -> b) -> b -> b+ ifNonEmpty [] _ z = z+ ifNonEmpty l f z = f l z++ go :: [DType] -> DType+ go [] = res+ go (h:t) = DAppT (DAppT DArrowT h) (go t)++-- Decompose a vanilla function type into its type variables, its context, its+-- argument types, and its result type. (See+-- Note [Vanilla-type validity checking during promotion] in+-- Data.Singletons.TH.Promote.Type for what "vanilla" means.)+-- If a non-vanilla construct is encountered while decomposing the function+-- type, an error is thrown monadically.+--+-- This should be contrasted with the 'unravelDType' function from+-- @th-desugar@, which supports the full gamut of function types. @singletons-th@+-- only supports a subset of these types, which is why this function is used+-- to decompose them instead.+unravelVanillaDType :: forall m. MonadFail m+ => DType -> m ([DTyVarBndrSpec], DCxt, [DType], DType)+unravelVanillaDType ty =+ case unravelVanillaDType_either ty of+ Left err -> fail err+ Right payload -> pure payload++-- Ensures that a 'DType' is a vanilla type. (See+-- Note [Vanilla-type validity checking during promotion] in+-- Data.Singletons.TH.Promote.Type for what "vanilla" means.)+--+-- The only monadic thing that this function can do is 'fail', which it does+-- if a non-vanilla construct is encountered.+checkVanillaDType :: forall m. MonadFail m => DType -> m ()+checkVanillaDType ty =+ case unravelVanillaDType_either ty of+ Left err -> fail err+ Right _ -> pure ()++-- The workhorse that powers unravelVanillaDType and checkVanillaDType.+-- Returns @Right payload@ upon success, and @Left error_msg@ upon failure.+unravelVanillaDType_either ::+ DType -> Either String ([DTyVarBndrSpec], DCxt, [DType], DType)+unravelVanillaDType_either ty =+ runIdentity $ flip runReaderT True $ runExceptT $ runUnravelM $ go_ty ty+ where+ go_ty :: DType -> UnravelM ([DTyVarBndrSpec], DCxt, [DType], DType)+ go_ty typ = do+ let (args1, res) = unravelDType typ+ (args2, tvbs) <- take_tvbs args1+ (args3, ctxt) <- take_ctxt args2+ anons <- take_anons args3+ pure (tvbs, ctxt, anons, res)++ -- Process a type in a higher-order position (e.g., the @forall a. a -> a@ in+ -- @(forall a. a -> a) -> b -> b@). This is only done to check for the+ -- presence of higher-rank foralls or constraints, which are not permitted+ -- in vanilla types.+ go_higher_order_ty :: DType -> UnravelM ()+ go_higher_order_ty typ = () <$ local (const False) (go_ty typ)++ take_tvbs :: DFunArgs -> UnravelM (DFunArgs, [DTyVarBndrSpec])+ take_tvbs (DFAForalls (DForallInvis tvbs) args) = do+ rank_1 <- ask+ unless rank_1 $ fail_forall "higher-rank"+ _ <- traverse_ (traverse_ go_higher_order_ty . extractTvbKind) tvbs+ (args', tvbs') <- take_tvbs args+ pure (args', tvbs ++ tvbs')+ take_tvbs (DFAForalls DForallVis{} _) = fail_vdq+ take_tvbs args = pure (args, [])++ take_ctxt :: DFunArgs -> UnravelM (DFunArgs, DCxt)+ take_ctxt (DFACxt ctxt args) = do+ rank_1 <- ask+ unless rank_1 $ fail_ctxt "higher-rank"+ traverse_ go_higher_order_ty ctxt+ (args', ctxt') <- take_ctxt args+ pure (args', ctxt ++ ctxt')+ take_ctxt (DFAForalls tele _) =+ case tele of+ DForallInvis{} -> fail_forall "nested"+ DForallVis{} -> fail_vdq+ take_ctxt args = pure (args, [])++ take_anons :: DFunArgs -> UnravelM [DType]+ take_anons (DFAAnon anon args) = do+ go_higher_order_ty anon+ anons <- take_anons args+ pure (anon:anons)+ take_anons (DFAForalls tele _) =+ case tele of+ DForallInvis{} -> fail_forall "nested"+ DForallVis{} -> fail_vdq+ take_anons (DFACxt _ _) = fail_ctxt "nested"+ take_anons DFANil = pure []++ failWith :: MonadError String m => String -> m a+ failWith thing = throwError $ unlines+ [ "`singletons-th` does not support " ++ thing+ , "In the type: " ++ pprint (sweeten ty)+ ]++ fail_forall :: MonadError String m => String -> m a+ fail_forall sort = failWith $ sort ++ " `forall`s"++ fail_vdq :: MonadError String m => m a+ fail_vdq = failWith "visible dependent quantification"++ fail_ctxt :: MonadError String m => String -> m a+ fail_ctxt sort = failWith $ sort ++ " contexts"++-- The monad that powers the internals of unravelVanillaDType_either.+--+-- * ExceptT String: records the error message upon failure.+--+-- * Reader Bool: True if we are in a rank-1 position in a type, False otherwise+newtype UnravelM a = UnravelM { runUnravelM :: ExceptT String (Reader Bool) a }+ deriving (Functor, Applicative, Monad, MonadError String, MonadReader Bool)++-- count the number of arguments in a type+countArgs :: DType -> Int+countArgs ty = length $ filterDVisFunArgs args+ where (args, _) = unravelDType ty++-- Collect the invisible type variable binders from a sequence of DFunArgs.+filterInvisTvbArgs :: DFunArgs -> [DTyVarBndrSpec]+filterInvisTvbArgs DFANil = []+filterInvisTvbArgs (DFACxt _ args) = filterInvisTvbArgs args+filterInvisTvbArgs (DFAAnon _ args) = filterInvisTvbArgs args+filterInvisTvbArgs (DFAForalls tele args) =+ let res = filterInvisTvbArgs args in+ case tele of+ DForallVis _ -> res+ DForallInvis tvbs' -> tvbs' ++ res++-- Change all unique Names with a NameU or NameL namespace to non-unique Names+-- by performing a syb-based traversal. See Note [Pitfalls of NameU/NameL] for+-- why this is useful.+noExactTyVars :: Data a => a -> a+noExactTyVars = everywhere go+ where+ go :: Data a => a -> a+ go = mkT (fix_tvb @Specificity)+ `extT` fix_tvb @()+ `extT` fix_tvb @BndrVis+ `extT` fix_ty+ `extT` fix_inj_ann++ fix_tvb :: Typeable flag => DTyVarBndr flag -> DTyVarBndr flag+ fix_tvb (DPlainTV n f) = DPlainTV (noExactName n) f+ fix_tvb (DKindedTV n f k) = DKindedTV (noExactName n) f k++ fix_ty (DVarT n) = DVarT (noExactName n)+ fix_ty ty = ty++ fix_inj_ann (InjectivityAnn lhs rhs)+ = InjectivityAnn (noExactName lhs) (map noExactName rhs)++-- Changes a unique Name with a NameU or NameL namespace to a non-unique Name.+-- See Note [Pitfalls of NameU/NameL] for why this is useful.+noExactName :: Name -> Name+noExactName n@(Name (OccName occ) ns) =+ case ns of+ NameU unique -> mk_name unique+ NameL unique -> mk_name unique+ _ -> n+ where+ mk_name unique = mkName (occ ++ show unique)++{-+Note [Pitfalls of NameU/NameL]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Most of the Names used in singletons-th come from reified or quoted Template+Haskell definitions. Because these definitions have passed through GHC's+renamer, they have unique Names with unique a NameU/NameL namespace. For the+sake of convenience, we often reuse these Names in the definitions that we+generate. For example, if singletons-th is given a declaration+`f :: forall a_123. a_123 -> a_123`, it will produce a standalone kind signature+`type F :: forall a_123. a_123 -> a_123`, reusing the unique Name `a_123`.++While reusing unique Names is convenient, it does have a downside. In+particular, GHC can sometimes get confused when the same unique Name is reused+in distinct type variable scopes. In the best case, this can lead to confusing+type errors, but in the worst case, it can cause GHC to panic, as seen in the+following issues (all of which were first observed in singletons-th):++* https://gitlab.haskell.org/ghc/ghc/-/issues/11812+* https://gitlab.haskell.org/ghc/ghc/-/issues/17537+* https://gitlab.haskell.org/ghc/ghc/-/issues/19743++This is pretty terrible. Arguably, we are abusing Template Haskell here, since+GHC likely assumes the invariant that each unique Name only has a single+binding site. On the other hand, rearchitecting singletons-th to uphold this+invariant would require a substantial amount of work.++A far easier solution is to identify any problematic areas where unique Names+are reused and work around the issue by changing unique Names to non-unique+Names. The issues above all have a common theme: they arise when unique Names+are reused in the type variable binders of a data type or type family+declaration. For instance, when promoting a function like this:++ f :: forall a_123. a_123 -> a_123+ f x_456 = g+ where+ g = x_456++We must promote `f` and `g` to something like this:++ type F :: forall a_123. a_123 -> a_123+ type family F (arg :: a_123) :: a_123 where+ F x_456 = G x_456++ type family LetG x_456 where+ LetG x_456 = x_456++This looks sensible enough. But note that we are reusing the same unique Name+`x_456` in three different scopes: once in the equation for `F`, once in the+the equation for `G`, and once more in the type variable binder in+`type family LetG x_456`. The last of these scopes in particular is enough to+confuse GHC in some situations and trigger GHC#11812.++Our workaround is to apply the `noExactName` function to such names, which+converts any Names with NameU/NameL namespaces into non-unique Names with+longer OccNames. For instance, `noExactName x_456` will return a non-unique+Name with the OccName `x456`. We use `noExactName` when generating `LetG` so+that it will instead be:++ type family LetG x456 where+ LetG x_456 = x_456++Here, `x456` is a non-unique Name, and `x_456` is a Unique name. Thankfully,+this is sufficient to work around GHC#11812. There is still some amount of+risk, since we are reusing `x_456` in two different type family equations (one+for `LetG` and one for `F`), but GHC accepts this for now. We prefer to use the+`noExactName` in as few places as possible, as using longer OccNames makes the+Haddocks harder to read, so we will continue to reuse unique Names unless GHC+forces us to behave differently.++In addition to the type family example above, we also make use of `noExactName`+(as well as its cousin, `noExactTyVars`) when generating defunctionalization+symbols, as these also require reusing Unique names in several type family and+data type declarations. See references to this Note in the code for particular+locations where we must apply this workaround.+-}++substKind :: Map Name DKind -> DKind -> DKind+substKind = substType++-- | Non–capture-avoiding substitution. (If you want capture-avoiding+-- substitution, use @substTy@ from "Language.Haskell.TH.Desugar.Subst".+substType :: Map Name DType -> DType -> DType+substType subst ty | Map.null subst = ty+substType subst (DForallT tele inner_ty)+ = DForallT tele' inner_ty'+ where+ (subst', tele') = subst_tele subst tele+ inner_ty' = substType subst' inner_ty+substType subst (DConstrainedT cxt inner_ty) =+ DConstrainedT (map (substType subst) cxt) (substType subst inner_ty)+substType subst (DAppT ty1 ty2) = substType subst ty1 `DAppT` substType subst ty2+substType subst (DAppKindT ty ki) = substType subst ty `DAppKindT` substType subst ki+substType subst (DSigT ty ki) = substType subst ty `DSigT` substType subst ki+substType subst (DVarT n) =+ case Map.lookup n subst of+ Just ki -> ki+ Nothing -> DVarT n+substType _ ty@(DConT {}) = ty+substType _ ty@(DArrowT) = ty+substType _ ty@(DLitT {}) = ty+substType _ ty@DWildCardT = ty++subst_tele :: Map Name DKind -> DForallTelescope -> (Map Name DKind, DForallTelescope)+subst_tele s (DForallInvis tvbs) = second DForallInvis $ substTvbs s tvbs+subst_tele s (DForallVis tvbs) = second DForallVis $ substTvbs s tvbs++substTvbs :: Map Name DKind -> [DTyVarBndr flag] -> (Map Name DKind, [DTyVarBndr flag])+substTvbs = mapAccumL substTvb++substTvb :: Map Name DKind -> DTyVarBndr flag -> (Map Name DKind, DTyVarBndr flag)+substTvb s tvb@(DPlainTV n _) = (Map.delete n s, tvb)+substTvb s (DKindedTV n f k) = (Map.delete n s, DKindedTV n f (substKind s k))++substFamilyResultSig :: Map Name DKind -> DFamilyResultSig -> (Map Name DKind, DFamilyResultSig)+substFamilyResultSig s frs@DNoSig = (s, frs)+substFamilyResultSig s (DKindSig k) = (s, DKindSig (substKind s k))+substFamilyResultSig s (DTyVarSig tvb) = let (s', tvb') = substTvb s tvb in+ (s', DTyVarSig tvb')++dropTvbKind :: DTyVarBndr flag -> DTyVarBndr flag+dropTvbKind tvb@(DPlainTV {}) = tvb+dropTvbKind (DKindedTV n f _) = DPlainTV n f++-- apply a type to a list of types+foldType :: DType -> [DType] -> DType+foldType = foldl DAppT++-- apply a type to a list of type variable binders+foldTypeTvbs :: DType -> [DTyVarBndrVis] -> DType+foldTypeTvbs ty = applyDType ty . map dTyVarBndrVisToDTypeArg++-- Construct a data type's variable binders, possibly using fresh variables+-- from the data type's kind signature. This function is used when constructing+-- a @DataDecl@ to ensure that it has a number of binders equal in length to the+-- number of visible quantifiers (i.e., the number of function arrows plus the+-- number of visible @forall@–bound variables) in the data type's kind.+buildDataDTvbs :: DsMonad q => [DTyVarBndrVis] -> Maybe DKind -> q [DTyVarBndrVis]+buildDataDTvbs tvbs mk = do+ extra_tvbs <- mkExtraDKindBinders $ fromMaybe (DConT typeKindName) mk+ pure $ tvbs ++ extra_tvbs++-- apply an expression to a list of expressions+foldExp :: DExp -> [DExp] -> DExp+foldExp = foldl DAppE++-- choose the first non-empty list+orIfEmpty :: [a] -> [a] -> [a]+orIfEmpty [] x = x+orIfEmpty x _ = x++-- build a pattern match over several expressions, each with only one pattern+multiCase :: [DExp] -> [DPat] -> DExp -> DExp+multiCase [] [] body = body+multiCase scruts pats body =+ DCaseE (mkTupleDExp scruts) [DMatch (mkTupleDPat pats) body]++-- a monad transformer for writing a monoid alongside returning a Q+newtype QWithAux m q a = QWA { runQWA :: WriterT m q a }+ deriving ( Functor, Applicative, Monad, MonadTrans+ , MonadWriter m, MonadReader r+ , MonadFail, MonadIO, Quasi, DsMonad )++-- run a computation with an auxiliary monoid, discarding the monoid result+evalWithoutAux :: Quasi q => QWithAux m q a -> q a+evalWithoutAux = liftM fst . runWriterT . runQWA++-- run a computation with an auxiliary monoid, returning only the monoid result+evalForAux :: Quasi q => QWithAux m q a -> q m+evalForAux = execWriterT . runQWA++-- run a computation with an auxiliary monoid, return both the result+-- of the computation and the monoid result+evalForPair :: QWithAux m q a -> q (a, m)+evalForPair = runWriterT . runQWA++-- in a computation with an auxiliary map, add a binding to the map+addBinding :: (Quasi q, Ord k) => k -> v -> QWithAux (Map.Map k v) q ()+addBinding k v = tell (Map.singleton k v)++-- in a computation with an auxiliar list, add an element to the list+addElement :: Quasi q => elt -> QWithAux [elt] q ()+addElement elt = tell [elt]++-- | Call 'lookupTypeNameWithLocals' first to ensure we have a 'Name' in the+-- type namespace, then call 'dsReify'.++-- See also Note [Using dsReifyTypeNameInfo when promoting instances]+-- in Data.Singletons.TH.Promote.+dsReifyTypeNameInfo :: DsMonad q => Name -> q (Maybe DInfo)+dsReifyTypeNameInfo ty_name = do+ mb_name <- lookupTypeNameWithLocals (nameBase ty_name)+ case mb_name of+ Just n -> dsReify n+ Nothing -> pure Nothing++-- lift concatMap into a monad+-- could this be more efficient?+concatMapM :: (Monad monad, Monoid monoid, Traversable t)+ => (a -> monad monoid) -> t a -> monad monoid+concatMapM fn list = do+ bss <- mapM fn list+ return $ fold bss++-- like GHC's+mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]+mapMaybeM _ [] = return []+mapMaybeM f (x:xs) = do+ y <- f x+ ys <- mapMaybeM f xs+ return $ case y of+ Nothing -> ys+ Just z -> z : ys++-- make a one-element list+listify :: a -> [a]+listify = (:[])++fstOf3 :: (a,b,c) -> a+fstOf3 (a,_,_) = a++liftFst :: (a -> b) -> (a, c) -> (b, c)+liftFst f (a, c) = (f a, c)++liftSnd :: (a -> b) -> (c, a) -> (c, b)+liftSnd f (c, a) = (c, f a)++snocView :: [a] -> ([a], a)+snocView [] = error "snocView nil"+snocView [x] = ([], x)+snocView (x : xs) = liftFst (x:) (snocView xs)++partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])+partitionWith f = go [] []+ where go bs cs [] = (reverse bs, reverse cs)+ go bs cs (a:as) =+ case f a of+ Left b -> go (b:bs) cs as+ Right c -> go bs (c:cs) as++partitionWithM :: Monad m => (a -> m (Either b c)) -> [a] -> m ([b], [c])+partitionWithM f = go [] []+ where go bs cs [] = return (reverse bs, reverse cs)+ go bs cs (a:as) = do+ fa <- f a+ case fa of+ Left b -> go (b:bs) cs as+ Right c -> go bs (c:cs) as++partitionLetDecs :: [DDec] -> ([DLetDec], [DDec])+partitionLetDecs = partitionWith (\case DLetDec ld -> Left ld+ dec -> Right dec)++{-# INLINEABLE zipWith3M #-}+zipWith3M :: Monad m => (a -> b -> m c) -> [a] -> [b] -> m [c]+zipWith3M f (a:as) (b:bs) = (:) <$> f a b <*> zipWith3M f as bs+zipWith3M _ _ _ = return []++mapAndUnzip3M :: Monad m => (a -> m (b,c,d)) -> [a] -> m ([b],[c],[d])+mapAndUnzip3M _ [] = return ([],[],[])+mapAndUnzip3M f (x:xs) = do+ (r1, r2, r3) <- f x+ (rs1, rs2, rs3) <- mapAndUnzip3M f xs+ return (r1:rs1, r2:rs2, r3:rs3)++-- is it a letter or underscore?+isHsLetter :: Char -> Bool+isHsLetter c = isLetter c || c == '_'