singletons-th 3.1.1 → 3.2
raw patch · 34 files changed
+8284/−8417 lines, 34 filesdep ~basedep ~mtldep ~template-haskellsetup-changed
Dependency ranges changed: base, mtl, template-haskell, th-desugar
Files
- CHANGES.md +159/−145
- LICENSE +27/−27
- README.md +26/−26
- Setup.hs +2/−2
- singletons-th.cabal +104/−104
- src/Data/Singletons/TH.hs +173/−124
- src/Data/Singletons/TH/CustomStar.hs +158/−158
- src/Data/Singletons/TH/Deriving/Bounded.hs +59/−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 +269/−270
- src/Data/Singletons/TH/Options.hs +341/−341
- src/Data/Singletons/TH/Partition.hs +326/−326
- src/Data/Singletons/TH/Promote.hs +1094/−1170
- src/Data/Singletons/TH/Promote/Defun.hs +823/−823
- src/Data/Singletons/TH/Promote/Monad.hs +117/−192
- src/Data/Singletons/TH/Promote/Type.hs +175/−175
- src/Data/Singletons/TH/Single.hs +1093/−1154
- src/Data/Singletons/TH/Single/Data.hs +405/−388
- src/Data/Singletons/TH/Single/Decide.hs +112/−109
- src/Data/Singletons/TH/Single/Defun.hs +238/−238
- src/Data/Singletons/TH/Single/Fixity.hs +170/−170
- src/Data/Singletons/TH/Single/Monad.hs +182/−195
- src/Data/Singletons/TH/Single/Type.hs +336/−312
- src/Data/Singletons/TH/SuppressUnusedWarnings.hs +21/−21
- src/Data/Singletons/TH/Syntax.hs +224/−240
- src/Data/Singletons/TH/Util.hs +577/−575
CHANGES.md view
@@ -1,145 +1,159 @@-Changelog for the `singletons-th` project-=========================================--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.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.4). 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.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`.
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple-main = defaultMain+import Distribution.Simple +main = defaultMain
singletons-th.cabal view
@@ -1,104 +1,104 @@-name: singletons-th-version: 3.1.1-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.4.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.4). 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.1--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.17 && < 4.18,- containers >= 0.5,- mtl >= 2.2.1,- ghc-boot-th,- singletons == 3.0.*,- syb >= 0.4,- template-haskell >= 2.19 && < 2.20,- th-desugar >= 1.14 && < 1.15,- 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.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
src/Data/Singletons/TH.hs view
@@ -1,124 +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.-cases :: DsMonad q- => Name -- ^ The head of the type of the scrutinee. (Like @''Maybe@ or @''Bool@.)- -> q Exp -- ^ The scrutinee, in a Template Haskell quote- -> q Exp -- ^ The body, in a Template Haskell quote- -> q Exp-cases tyName expq bodyq = do- dinfo <- dsReify tyName- case dinfo of- Just (DTyConI (DDataD _ _ _ _ _ ctors _) _) ->- expToTH <$> buildCases (map extractNameArgs ctors) expq bodyq- Just _ ->- fail $ "Using <<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@.-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 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,59 @@--------------------------------------------------------------------------------- |--- 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. + 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) ] }
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 thenCmpName `DAppE`- DConE cmpEQName `DAppE`- mkListE (zipWith- (\a b -> DVarE compareName `DAppE` DVarE a- `DAppE` DVarE b)- a_names b_names))--mk_nonequal_clause :: (DCon, Int) -> (DCon, Int) -> DClause-mk_nonequal_clause (DCon _tvbs1 _cxt1 name1 fields1 _rty1, n1)- (DCon _tvbs2 _cxt2 name2 fields2 _rty2, n2) =- DClause [pat1, pat2] (case n1 `compare` n2 of- LT -> DConE cmpLTName- EQ -> DConE cmpEQName- GT -> DConE cmpGTName)- where- pat1 = DConP name1 [] (map (const DWildP) (tysOfConFields fields1))- pat2 = DConP name2 [] (map (const DWildP) (tysOfConFields fields2))---- A variant of mk_equal_clause tailored to empty datatypes-mk_empty_clause :: DClause-mk_empty_clause = DClause [DWildP, DWildP] (DConE cmpEQName)+----------------------------------------------------------------------------- +-- | +-- 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 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,270 +1,269 @@-{-# 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(..) )-import Control.Applicative--{--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,- thenCmpName, 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, 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-thenCmpName = 'thenCmp-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-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 + +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. +-}
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 (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. +-}
src/Data/Singletons/TH/Partition.hs view
@@ -1,326 +1,326 @@--------------------------------------------------------------------------------- |--- 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 _nd _cxt name tvbs mk cons derivings) = do- all_tvbs <- buildDataDTvbs tvbs mk- let data_decl = DataDecl name all_tvbs cons- derived_dec = mempty { pd_data_decs = [data_decl] }- derived_decs- <- mapM (\(strat, deriv_pred) ->- let etad_tvbs- | (DConT pred_name, _) <- unfoldDType deriv_pred- , isFunctorLikeClassName pred_name- -- If deriving Functor, Foldable, or Traversable,- -- we need to use one less type variable than we normally do.- = take (length all_tvbs - 1) all_tvbs- | otherwise- = all_tvbs- ty = foldTypeTvbs (DConT name) etad_tvbs- in partitionDeriving strat deriv_pred Nothing ty data_decl)- $ concatMap flatten_clause derivings- return $ mconcat $ derived_dec : derived_decs- where- flatten_clause :: DDerivClause -> [(Maybe DDerivStrategy, DPred)]- flatten_clause (DDerivClause strat preds) =- map (\p -> (strat, p)) preds--partitionDec (DClassD cxt name tvbs fds decs) = do- (lde, otfs) <- concatMapM partitionClassDec decs- return $ mempty { pd_class_decs = [ClassDecl { cd_cxt = cxt- , cd_name = name- , cd_tvbs = tvbs- , cd_fds = fds- , cd_lde = lde- , cd_atfs = otfs}] }-partitionDec (DInstanceD _ _ cxt ty decs) = do- (defns, sigs) <- liftM (bimap catMaybes mconcat) $- mapAndUnzipM partitionInstanceDec decs- (name, tys) <- split_app_tys [] ty- return $ mempty { pd_instance_decs = [InstDecl { id_cxt = cxt- , id_name = name- , id_arg_tys = tys- , id_sigs = sigs- , id_meths = defns }] }- where- split_app_tys acc (DAppT t1 t2) = split_app_tys (t2:acc) t1- split_app_tys acc (DConT name) = return (name, acc)- split_app_tys acc (DSigT t _) = split_app_tys acc t- split_app_tys _ _ = fail $ "Illegal instance head: " ++ show ty-partitionDec (DRoleAnnotD {}) = return mempty -- ignore these-partitionDec (DTySynD name tvbs rhs) =- -- See Note [Partitioning, type synonyms, and type families]- pure $ mempty { pd_ty_syn_decs = [TySynDecl name tvbs rhs] }-partitionDec (DClosedTypeFamilyD tf_head _) =- -- See Note [Partitioning, type synonyms, and type families]- pure $ mempty { pd_closed_type_family_decs = [TypeFamilyDecl tf_head] }-partitionDec (DOpenTypeFamilyD tf_head) =- -- See Note [Partitioning, type synonyms, and type families]- pure $ mempty { pd_open_type_family_decs = [TypeFamilyDecl tf_head] }-partitionDec (DTySynInstD {}) = pure mempty- -- There's no need to track type family instances, since- -- we already record the type family itself separately.-partitionDec (DKiSigD {}) = pure mempty- -- There's no need to track standalone kind signatures, since we use- -- dsReifyType to look them up.-partitionDec (DStandaloneDerivD mb_strat _ ctxt ty) =- case unfoldDType ty of- (cls_pred_ty, cls_tys)- | let cls_normal_tys = filterDTANormals cls_tys- , not (null cls_normal_tys) -- We can't handle zero-parameter type classes- , let cls_arg_tys = init cls_normal_tys- data_ty = last cls_normal_tys- data_ty_head = case unfoldDType data_ty of (ty_head, _) -> ty_head- , DConT data_tycon <- data_ty_head -- We can't handle deriving an instance for something- -- other than a type constructor application- -> do let cls_pred = foldType cls_pred_ty cls_arg_tys- dinfo <- dsReify data_tycon- case dinfo of- Just (DTyConI (DDataD _ _ dn dtvbs dk dcons _) _) -> do- all_tvbs <- buildDataDTvbs dtvbs dk- let data_decl = DataDecl dn all_tvbs dcons- partitionDeriving mb_strat cls_pred (Just ctxt) data_ty data_decl- Just _ ->- fail $ "Standalone derived instance for something other than a datatype: "- ++ show data_ty- _ -> fail $ "Cannot find " ++ show data_ty- _ -> return mempty-partitionDec dec =- fail $ "Declaration cannot be promoted: " ++ pprint (decToTH dec)--partitionClassDec :: MonadFail m => DDec -> m (ULetDecEnv, [OpenTypeFamilyDecl])-partitionClassDec (DLetDec (DSigD name ty)) =- pure (typeBinding name ty, mempty)-partitionClassDec (DLetDec (DValD (DVarP name) exp)) =- pure (valueBinding name (UValue exp), mempty)-partitionClassDec (DLetDec (DFunD name clauses)) =- pure (valueBinding name (UFunction clauses), mempty)-partitionClassDec (DLetDec (DInfixD fixity name)) =- pure (infixDecl fixity name, mempty)-partitionClassDec (DLetDec (DPragmaD {})) =- pure (mempty, mempty)-partitionClassDec (DOpenTypeFamilyD tf_head) =- -- See Note [Partitioning, type synonyms, and type families]- pure (mempty, [TypeFamilyDecl tf_head])-partitionClassDec (DTySynInstD {}) =- -- There's no need to track associated type family default equations, since- -- we already record the type family itself separately.- pure (mempty, mempty)-partitionClassDec _ =- fail "Only method declarations can be promoted within a class."--partitionInstanceDec :: MonadFail m => DDec- -> m ( Maybe (Name, ULetDecRHS) -- right-hand sides of methods- , OMap Name DType -- method type signatures- )-partitionInstanceDec (DLetDec (DValD (DVarP name) exp)) =- pure (Just (name, UValue exp), mempty)-partitionInstanceDec (DLetDec (DFunD name clauses)) =- pure (Just (name, UFunction clauses), mempty)-partitionInstanceDec (DLetDec (DSigD name ty)) =- pure (Nothing, OMap.singleton name ty)-partitionInstanceDec (DLetDec (DPragmaD {})) =- pure (Nothing, mempty)-partitionInstanceDec (DTySynInstD {}) =- pure (Nothing, mempty)- -- There's no need to track associated type family instances, since- -- we already record the type family itself separately.-partitionInstanceDec _ =- fail "Only method bodies can be promoted within an instance."--partitionDeriving- :: forall m. OptionsMonad m- => Maybe DDerivStrategy- -- ^ The deriving strategy, if present.- -> DPred -- ^ The class being derived (e.g., 'Eq'), possibly applied to- -- some number of arguments (e.g., @C Int Bool@).- -> Maybe DCxt -- ^ @'Just' ctx@ if @ctx@ was provided via @StandaloneDeriving@.- -- 'Nothing' if using a @deriving@ clause.- -> DType -- ^ The data type argument to the class.- -> DataDecl -- ^ The original data type information (e.g., its constructors).- -> m PartitionedDecs-partitionDeriving mb_strat deriv_pred mb_ctxt ty data_decl =- case unfoldDType deriv_pred of- (DConT deriv_name, arg_tys)- -- Here, we are more conservative than GHC: DeriveAnyClass only kicks- -- in if the user explicitly chooses to do so with the anyclass- -- deriving strategy- | Just DAnyclassStrategy <- mb_strat- -> return $ mk_derived_inst- InstDecl { id_cxt = fromMaybe [] mb_ctxt- -- For now at least, there's no point in attempting to- -- infer an instance context for DeriveAnyClass, since- -- the other language feature that requires it,- -- DefaultSignatures, can't be singled. Thus, inferring an- -- empty context will Just Work for all currently supported- -- default implementations.- --- -- (Of course, if a user specifies a context with- -- StandaloneDeriving, use that.)-- , id_name = deriv_name- , id_arg_tys = filterDTANormals arg_tys ++ [ty]- , id_sigs = mempty- , id_meths = [] }-- | Just DNewtypeStrategy <- mb_strat- -> do qReportWarning "GeneralizedNewtypeDeriving is ignored by `singletons-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_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. +-}
src/Data/Singletons/TH/Promote.hs view
@@ -1,1170 +1,1094 @@-{- 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 Language.Haskell.TH.Desugar.OSet (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- (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 name tvbs' cons'- raw_inst <- mk_inst Nothing data_ty data_decl- decs <- promoteM_ [] $ void $- promoteInstanceDec OMap.empty Map.empty raw_inst- return $ decsToTH decs--promoteInfo :: DInfo -> PrM ()-promoteInfo (DTyConI dec _instances) = promoteDecs [dec]-promoteInfo (DPrimTyConI _name _numArgs _unlifted) =- fail "Promotion of primitive type constructors not supported"-promoteInfo (DVarI _name _ty _mdec) =- fail "Promotion of individual values not supported"-promoteInfo (DTyVarI _name _ty) =- fail "Promotion of individual type variables not supported"-promoteInfo (DPatSynI {}) =- fail "Promotion of pattern synonyms not supported"---- Note [Promoting declarations in two stages]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ It is necessary to know the types of things when promoting. So,--- we promote in two stages: first, we build a LetDecEnv, which allows--- for easy lookup. Then, we go through the actual elements of the LetDecEnv,--- performing the promotion.------ Why do we need the types? For kind annotations on the type family. We also--- need to have both the types and the actual function definition at the same--- time, because the function definition tells us how many patterns are--- matched. Note that an eta-contracted function needs to return a TyFun,--- not a proper type-level function.------ Consider this example:------ foo :: Nat -> Bool -> Bool--- foo Zero = id--- foo _ = not------ Here the first parameter to foo is non-uniform, because it is--- inspected in a pattern and can be different in each defining--- equation of foo. The second parameter to foo, specified in the type--- signature as Bool, is a uniform parameter - it is not inspected and--- each defining equation of foo uses it the same way. The foo--- function will be promoted to a type familty Foo like this:------ type family Foo (n :: Nat) :: Bool ~> Bool where--- Foo Zero = Id--- Foo a = Not------ To generate type signature for Foo type family we must first learn--- what is the actual number of patterns used in defining cequations--- of foo. In this case there is only one so we declare Foo to take--- one argument and have return type of Bool -> Bool.---- Promote a list of top-level declarations.-promoteDecs :: [DDec] -> PrM ()-promoteDecs raw_decls = do- decls <- expand raw_decls -- expand type synonyms- checkForRepInDecls decls- PDecs { pd_let_decs = let_decs- , pd_class_decs = classes- , pd_instance_decs = insts- , pd_data_decs = datas- , pd_ty_syn_decs = ty_syns- , pd_open_type_family_decs = o_tyfams- , pd_closed_type_family_decs = c_tyfams } <- 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)- -- See Note [Promoting declarations in two stages]-promoteLetDecs mb_let_uniq decls = do- opts <- getOptions- let_dec_env <- buildLetDecEnv decls- all_locals <- allLocals- let binds = [ (name, foldType (DConT sym) (map DVarT all_locals))- | (name, _) <- OMap.assocs $ lde_defns let_dec_env- , let proName = promotedValueName opts name mb_let_uniq- sym = defunctionalizedName opts proName (length all_locals) ]- (decs, let_dec_env') <- letBind binds $ promoteLetDecEnv mb_let_uniq let_dec_env- emitDecs decs- return (binds, let_dec_env' { lde_proms = OMap.fromList binds })--promoteDataDecs :: [DataDecl] -> PrM [DLetDec]-promoteDataDecs = concatMapM promoteDataDec---- "Promotes" a data type, much like D.S.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- forallBind cls_kvs_to_bind $ do- let meth_sigs_list = OMap.assocs meth_sigs- meth_names = map fst meth_sigs_list- defaults_list = OMap.assocs defaults- defaults_names = map fst defaults_list- mb_cls_sak <- dsReifyType cls_name- sig_decs <- mapM (uncurry promote_sig) meth_sigs_list- (default_decs, ann_rhss, prom_rhss)- <- mapAndUnzip3M (promoteMethod DefaultMethods meth_sigs) defaults_list- defunAssociatedTypeFamilies tvbs atfs-- infix_decls' <- mapMaybeM (uncurry (promoteInfixDecl Nothing)) $- OMap.assocs infix_decls- cls_infix_decls <- promoteReifiedInfixDecls $ cls_name:meth_names-- -- no need to do anything to the fundeps. They work as is!- let pro_cls_dec = DClassD [] pClsName tvbs fundeps- (sig_decs ++ default_decs ++ infix_decls')- mb_pro_cls_sak = fmap (DKiSigD pClsName) mb_cls_sak- emitDecs $ maybeToList mb_pro_cls_sak ++ pro_cls_dec:cls_infix_decls- let defaults_list' = zip defaults_names ann_rhss- proms = zip defaults_names prom_rhss- cls_kvs_to_bind' = cls_kvs_to_bind <$ meth_sigs- return (decl { cd_lde = lde { lde_defns = OMap.fromList defaults_list'- , lde_proms = OMap.fromList proms- , lde_bound_kvs = cls_kvs_to_bind' } })- where- cls_kvb_names, cls_tvb_names, cls_kvs_to_bind :: OSet Name- cls_kvb_names = foldMap (foldMap fvDType . extractTvbKind) tvbs- cls_tvb_names = OSet.fromList $ map extractTvbName tvbs- cls_kvs_to_bind = cls_kvb_names `OSet.union` cls_tvb_names-- promote_sig :: Name -> DType -> PrM DDec- promote_sig name ty = do- opts <- getOptions- let proName = promotedTopLevelValueName opts name- -- When computing the kind to use for the defunctionalization symbols,- -- /don't/ use the type variable binders from the method's type...- (_, argKs, resK) <- promoteUnraveled ty- args <- mapM (const $ qNewName "arg") argKs- let proTvbs = zipWith (`DKindedTV` ()) args argKs- -- ...instead, compute the type variable binders in a left-to-right order,- -- since that is the same order that the promoted method's kind will use.- -- See Note [Promoted class methods and kind variable ordering]- meth_sak_tvbs = 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- kvs_to_bind = foldMap fvDType inst_kis- forallBind kvs_to_bind $ do- let subst = Map.fromList $ zip cls_tvb_names inst_kis- meth_impl = InstanceMethods inst_sigs subst- (meths', ann_rhss, _)- <- mapAndUnzip3M (promoteMethod meth_impl orig_meth_sigs) meths- emitDecs [DInstanceD Nothing Nothing [] (foldType (DConT pClsName)- inst_kis) meths']- return (decl { id_meths = zip (map fst meths) ann_rhss })- where- lookup_cls_tvbs :: PrM [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_tvbs, meth_arg_kis, meth_res_ki) <- promote_meth_ty- meth_arg_tvs <- replicateM (length meth_arg_kis) (qNewName "a")- let proName = promotedTopLevelValueName opts meth_name- helperNameBase = case nameBase proName of- first:_ | not (isHsLetter first) -> "TFHelper"- alpha -> alpha-- -- family_args are the type variables in a promoted class's- -- associated type family instance (or default implementation), e.g.,- --- -- class C k where- -- type T (a :: k) (b :: Bool)- -- type T a b = THelper1 a b -- family_args = [a, b]- --- -- instance C Bool where- -- type T a b = THelper2 a b -- family_args = [a, b]- --- -- We could annotate these variables with explicit kinds, but it's not- -- strictly necessary, as kind inference can figure them out just as well.- family_args = map DVarT meth_arg_tvs- helperName <- newUniqueName helperNameBase- let helperDefunName = defunctionalizedName0 opts helperName- (pro_decs, defun_decs, ann_rhs)- <- promoteLetDecRHS (ClassMethodRHS meth_tvbs meth_arg_kis meth_res_ki)- OMap.empty OMap.empty- Nothing helperName meth_rhs- emitDecs (pro_decs ++ defun_decs)- return ( DTySynInstD- (DTySynEqn Nothing- (foldType (DConT proName) family_args)- (foldApply (DConT helperDefunName) (map DVarT meth_arg_tvs)))- , ann_rhs- , DConT helperDefunName )- where- -- Promote the type of a class method. For a default method, "the type" is- -- simply the type of the original method. For an instance method,- -- "the type" is like the type of the original method, but substituted for- -- the types in the instance head. (e.g., if you have `class C a` and- -- `instance C T`, then the substitution [a |-> T] must be applied to the- -- original method's type.)- promote_meth_ty :: PrM ([DTyVarBndrSpec], [DKind], DKind)- promote_meth_ty =- case meth_sort of- DefaultMethods ->- -- No substitution for class variables is required for default- -- method type signatures, as they share type variables with the- -- class they inhabit.- lookup_meth_ty- InstanceMethods inst_sigs_map cls_subst ->- case OMap.lookup meth_name inst_sigs_map of- Just ty -> do- -- We have an InstanceSig. These are easy: we can just use the- -- instance signature's type directly, and no substitution for- -- class variables is required.- promoteUnraveled ty- Nothing -> do- -- We don't have an InstanceSig, so we must compute the kind to use- -- ourselves.- (_, arg_kis, res_ki) <- lookup_meth_ty- -- Substitute for the class variables in the method's type.- -- See Note [Promoted class method kinds]- let arg_kis' = map (substKind cls_subst) arg_kis- res_ki' = substKind cls_subst res_ki- -- Compute the type variable binders in a left-to-right- -- order, since that is the same order that the promoted- -- method's kind will use.- -- See Note [Promoted class methods and kind variable ordering]- tvbs' = changeDTVFlags SpecifiedSpec $- toposortTyVarsOf (arg_kis' ++ [res_ki'])- pure (tvbs', arg_kis', res_ki')-- -- Attempt to look up a class method's original type.- lookup_meth_ty :: PrM ([DTyVarBndrSpec], [DKind], DKind)- lookup_meth_ty = do- opts <- getOptions- let proName = promotedTopLevelValueName opts meth_name- case OMap.lookup meth_name orig_sigs_map of- Just ty -> do- -- The type of the method is in scope, so promote that.- promoteUnraveled ty- Nothing -> do- -- If the type of the method is not in scope, the only other option- -- is to try reifying the promoted method name.- mb_info <- dsReifyTypeNameInfo proName- -- See Note [Using dsReifyTypeNameInfo when promoting instances]- case mb_info of- Just (DTyConI (DOpenTypeFamilyD (DTypeFamilyHead _ tvbs mb_res_ki _)) _)- -> let arg_kis = map (defaultMaybeToTypeKind . extractTvbKind) tvbs- res_ki = defaultMaybeToTypeKind (resultSigToMaybeKind mb_res_ki)- -- Compute the type variable binders in a left-to-right- -- order, since that is the same order that the promoted- -- method's kind will use.- -- See Note [Promoted class methods and kind variable ordering]- tvbs' = changeDTVFlags SpecifiedSpec $- toposortTyVarsOf (arg_kis ++ [res_ki])- in pure (tvbs', arg_kis, res_ki)- _ -> fail $ "Cannot find type annotation for " ++ show proName--{--Note [Promoted class method kinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this example of a type class (and instance):-- class C a where- m :: a -> Bool -> Bool- m _ x = x-- instance C [a] where- m l _ = null l--The promoted version of these declarations would be:-- class PC a where- type M (x :: a) (y :: Bool) :: Bool- type M x y = MHelper1 x y-- instance PC [a] where- type M x y = MHelper2 x y-- type MHelper1 :: a -> Bool -> Bool- type family MHelper1 x y where ...-- type MHelper2 :: [a] -> Bool -> Bool- type family MHelper2 x y where ...--Getting the kind signature for MHelper1 (the promoted default implementation of-M) is quite simple, as it corresponds exactly to the kind of M. We might even-choose to make that the kind of MHelper2, but then it would be overly general-(and more difficult to find in -ddump-splices output). For this reason, we-substitute in the kinds of the instance itself to determine the kinds of-promoted method implementations like MHelper2.--}--promoteLetDecEnv :: Maybe Uniq -> ULetDecEnv -> PrM ([DDec], ALetDecEnv)-promoteLetDecEnv mb_let_uniq (LetDecEnv { lde_defns = value_env- , lde_types = type_env- , lde_infix = fix_env }) = do- infix_decls <- mapMaybeM (uncurry (promoteInfixDecl mb_let_uniq)) $- OMap.assocs fix_env-- -- promote all the declarations, producing annotated declarations- let (names, rhss) = unzip $ OMap.assocs value_env- (pro_decs, defun_decss, ann_rhss)- <- fmap unzip3 $- zipWithM (promoteLetDecRHS LetBindingRHS type_env fix_env mb_let_uniq)- names rhss-- emitDecs $ concat defun_decss- bound_kvs <- allBoundKindVars- let decs = concat pro_decs ++ infix_decls-- -- build the ALetDecEnv- let let_dec_env' = LetDecEnv { lde_defns = OMap.fromList $ zip names ann_rhss- , lde_types = type_env- , lde_infix = fix_env- , lde_proms = OMap.empty -- filled in promoteLetDecs- , lde_bound_kvs = OMap.fromList $ map (, bound_kvs) names }-- return (decs, let_dec_env')---- Promote a fixity declaration.-promoteInfixDecl :: forall q. OptionsMonad q- => Maybe Uniq -> Name -> Fixity -> q (Maybe DDec)-promoteInfixDecl mb_let_uniq name fixity = do- opts <- getOptions- mb_ns <- reifyNameSpace name- case mb_ns of- -- If we can't find the Name for some odd reason, fall back to promote_val- Nothing -> promote_val- Just VarName -> promote_val- Just DataName -> never_mind- Just TcClsName -> do- mb_info <- dsReify name- case mb_info of- Just (DTyConI DClassD{} _)- -> finish $ promotedClassName opts name- _ -> never_mind- where- -- Produce the fixity declaration.- finish :: Name -> q (Maybe DDec)- finish = pure . Just . DLetDec . DInfixD fixity-- -- Don't produce a fixity declaration at all. This happens when promoting a- -- fixity declaration for a name whose promoted counterpart is the same as- -- the original name.- -- See Note [singletons-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- [DTyVarBndrSpec] [DKind] DKind- -- The RHS's promoted type variable binders, argument types, and- -- result type. Needed to fix #136.- deriving Show---- This function is used both to promote class method defaults and normal--- let bindings. Thus, it can't quite do all the work locally and returns--- an intermediate structure. Perhaps a better design is available.-promoteLetDecRHS :: LetDecRHSSort- -> OMap Name DType -- local type env't- -> OMap Name Fixity -- local fixity env't- -> Maybe Uniq -- let-binding unique (if locally bound)- -> Name -- name of the thing being promoted- -> ULetDecRHS -- body of the thing- -> PrM ( [DDec] -- promoted type family dec, plus the- -- SAK dec (if one exists)- , [DDec] -- defunctionalization- , ALetDecRHS ) -- annotated RHS-promoteLetDecRHS rhs_sort type_env fix_env mb_let_uniq name let_dec_rhs = do- opts <- getOptions- all_locals <- allLocals- case let_dec_rhs of- UValue exp -> do- (m_ldrki, ty_num_args) <- promote_let_dec_ty all_locals 0- if ty_num_args == 0- then- let proName = promotedValueName opts name mb_let_uniq- prom_fun_lhs = foldType (DConT proName) $ map DVarT all_locals in- promote_let_dec_rhs all_locals m_ldrki 0 (promoteExp exp)- (\exp' -> [DTySynEqn Nothing prom_fun_lhs exp'])- AValue- else- -- If we have a UValue with a function type, process it as though it- -- were a UFunction. promote_function_rhs will take care of- -- eta-expanding arguments as necessary.- promote_function_rhs all_locals [DClause [] exp]- UFunction clauses -> promote_function_rhs all_locals clauses- where- -- Promote the RHS of a UFunction (or a UValue with a function type).- promote_function_rhs :: [Name]- -> [DClause] -> PrM ([DDec], [DDec], ALetDecRHS)- promote_function_rhs all_locals clauses = do- opts <- getOptions- numArgs <- count_args clauses- let proName = promotedValueName opts name mb_let_uniq- prom_fun_lhs = foldType (DConT proName) $ map DVarT all_locals- (m_ldrki, ty_num_args) <- promote_let_dec_ty all_locals numArgs- expClauses <- mapM (etaContractOrExpand ty_num_args numArgs) clauses- promote_let_dec_rhs all_locals m_ldrki ty_num_args- (mapAndUnzipM (promoteClause prom_fun_lhs) expClauses)- id AFunction-- -- Promote a UValue or a UFunction.- -- Notes about type variables:- --- -- * For UValues, `prom_a` is DType and `a` is Exp.- --- -- * For UFunctions, `prom_a` is [DTySynEqn] and `a` is [DClause].- promote_let_dec_rhs- :: [Name] -- Local variables bound in this scope- -> Maybe LetDecRHSKindInfo -- Information about the promoted kind (if present)- -> Int -- The number of promoted function arguments- -> PrM (prom_a, a) -- Promote the RHS- -> (prom_a -> [DTySynEqn]) -- Turn the promoted RHS into type family equations- -> (DType -> Int -> a -> ALetDecRHS) -- Build an ALetDecRHS- -> PrM ([DDec], [DDec], ALetDecRHS)- promote_let_dec_rhs all_locals m_ldrki ty_num_args- promote_thing mk_prom_eqns mk_alet_dec_rhs = do- opts <- getOptions- tyvarNames <- replicateM ty_num_args (qNewName "a")- let proName = promotedValueName opts name mb_let_uniq- local_tvbs = map (`DPlainTV` ()) all_locals- m_fixity = OMap.lookup name fix_env-- mk_tf_head :: [DTyVarBndrUnit] -> DFamilyResultSig -> DTypeFamilyHead- mk_tf_head tvbs res_sig = DTypeFamilyHead proName tvbs res_sig Nothing-- (lde_kvs_to_bind, m_sak_dec, defun_ki, tf_head) =- -- There are three possible cases:- case m_ldrki of- -- 1. We have no kind information whatsoever.- Nothing ->- let all_args = local_tvbs ++ map (`DPlainTV` ()) tyvarNames in- ( OSet.empty- , Nothing- , DefunNoSAK all_args Nothing- , mk_tf_head all_args DNoSig- )- -- 2. We have some kind information in the form of a LetDecRHSKindInfo.- Just (LDRKI m_sak tvbs argKs resK) ->- let all_args = local_tvbs ++ zipWith (`DKindedTV` ()) tyvarNames argKs- lde_kvs_to_bind' = OSet.fromList (map extractTvbName tvbs) in- case m_sak of- -- 2(a). We do not have a standalone kind signature.- Nothing ->- ( lde_kvs_to_bind'- , Nothing- , DefunNoSAK all_args (Just resK)- , mk_tf_head all_args (DKindSig resK)- )- -- 2(b). We have a standalone kind signature.- Just sak ->- ( lde_kvs_to_bind'- , Just $ DKiSigD proName sak- , DefunSAK sak- -- 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) <- forallBind lde_kvs_to_bind promote_thing- prom_fun_rhs <- lookupVarE name- return ( catMaybes [ m_sak_dec- , Just $ DClosedTypeFamilyD tf_head (mk_prom_eqns prom_thing)- ]- , defun_decs- , mk_alet_dec_rhs prom_fun_rhs ty_num_args thing )-- promote_let_dec_ty :: [Name] -- The local variables that the let-dec closes- -- over. If this is non-empty, we cannot- -- produce a standalone kind signature.- -- See Note [No SAKs for let-decs with local variables]- -> Int -- The number of arguments to default to if the- -- type cannot be inferred. This is 0 for UValues- -- and the number of arguments in a single clause- -- for UFunctions.- -> PrM (Maybe LetDecRHSKindInfo, Int)- -- Returns two things in a pair:- --- -- 1. Information about the promoted kind,- -- if available.- --- -- 2. The number of arguments the let-dec has.- -- If no kind information is available from- -- which to infer this number, then this- -- will default to the earlier Int argument.- promote_let_dec_ty all_locals default_num_args =- case rhs_sort of- ClassMethodRHS tvbs arg_kis res_ki- -> -- For class method RHS helper functions, don't bother quantifying- -- any type variables in their SAKS. We could certainly try, but- -- given that these functions are only used internally, there's no- -- point in trying to get the order of type variables correct,- -- since we don't apply these functions with visible kind- -- applications.- let sak = ravelVanillaDType [] [] arg_kis res_ki in- return (Just (LDRKI (Just sak) tvbs arg_kis res_ki), length arg_kis)- LetBindingRHS- | Just ty <- OMap.lookup name type_env- -> do- -- promoteType turns rank-1 uses of (->) into (~>). So, we unravel- -- first to avoid this behavior, and then ravel back.- (tvbs, argKs, resultK) <- promoteUnraveled ty- let m_sak | null all_locals = Just $ ravelVanillaDType tvbs [] argKs resultK- -- If this let-dec closes over local variables, then- -- don't give it a SAK.- -- See Note [No SAKs for let-decs with local variables]- | otherwise = Nothing- -- invariant: count_args ty == length argKs- return (Just (LDRKI m_sak tvbs argKs resultK), length argKs)-- | otherwise- -> return (Nothing, default_num_args)-- etaContractOrExpand :: Int -> Int -> DClause -> PrM DClause- etaContractOrExpand ty_num_args clause_num_args (DClause pats exp)- | n >= 0 = do -- Eta-expand- names <- replicateM n (newUniqueName "a")- let newPats = map DVarP names- newArgs = map DVarE names- return $ DClause (pats ++ newPats) (foldExp exp newArgs)- | otherwise = do -- Eta-contract- let (clausePats, lamPats) = splitAt ty_num_args pats- lamExp <- mkDLamEFromDPats lamPats exp- return $ DClause clausePats lamExp- where- n = ty_num_args - clause_num_args-- count_args :: [DClause] -> PrM Int- count_args (DClause pats _ : _) = return $ length pats- count_args _ = fail $ "Impossible! A function without clauses."---- An auxiliary data type used in promoteLetDecRHS that describes information--- related to the promoted kind of a class method default or normal--- let binding.-data LetDecRHSKindInfo =- LDRKI (Maybe DKind) -- The standalone kind signature, if applicable.- -- This will be Nothing if the let-dec RHS has local- -- variables that it closes over.- -- See Note [No SAKs for let-decs with local variables]- [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 :: DType -- What to use as the LHS of the promoted type family- -- equation. This should consist of the promoted name of- -- the function to which the clause belongs, applied to- -- any local arguments (e.g., `Go x y z`).- -> DClause -> PrM (DTySynEqn, ADClause)-promoteClause pro_clause_fun (DClause pats exp) = do- -- promoting the patterns creates variable bindings. These are passed- -- to the function promoted the RHS- ((types, pats'), prom_pat_infos) <- evalForPair $ mapAndUnzipM promotePat pats- let PromDPatInfos { prom_dpat_vars = new_vars- , prom_dpat_sig_kvs = sig_kvs } = prom_pat_infos- (ty, ann_exp) <- forallBind sig_kvs $- lambdaBind new_vars $- promoteExp exp- return ( DTySynEqn Nothing (foldType pro_clause_fun types) ty- , ADClause new_vars pats' ann_exp )--promoteMatch :: DType -- What to use as the LHS of the promoted type family- -- equation. This should consist of the promoted name of- -- the case expression to which the match belongs, applied- -- to any local arguments (e.g., `Case x y z`).- -> DMatch -> PrM (DTySynEqn, ADMatch)-promoteMatch pro_case_fun (DMatch pat exp) = do- -- promoting the patterns creates variable bindings. These are passed- -- to the function promoted the RHS- ((ty, pat'), prom_pat_infos) <- evalForPair $ promotePat pat- let PromDPatInfos { prom_dpat_vars = new_vars- , prom_dpat_sig_kvs = sig_kvs } = prom_pat_infos- (rhs, ann_exp) <- forallBind sig_kvs $- lambdaBind new_vars $- promoteExp exp- return $ ( DTySynEqn Nothing (pro_case_fun `DAppT` ty) rhs- , ADMatch new_vars pat' ann_exp)---- promotes a term pattern into a type pattern, accumulating bound variable names-promotePat :: DPat -> QWithAux PromDPatInfos PrM (DType, ADPat)-promotePat (DLitP lit) = (, ADLitP lit) <$> promoteLitPat lit-promotePat (DVarP name) = do- -- term vars can be symbols... type vars can't!- tyName <- mkTyName name- tell $ PromDPatInfos [(name, tyName)] OSet.empty- return (DVarT tyName, ADVarP name)-promotePat (DConP name 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 all_args = all_locals ++ tyNames- tvbs = map (`DPlainTV` ()) all_args- emitDecs [DClosedTypeFamilyD (DTypeFamilyHead- lambdaName- tvbs- DNoSig- Nothing)- [DTySynEqn Nothing- (foldType (DConT lambdaName) $- map DVarT all_args)- rhs]]- emitDecsM $ defunctionalize lambdaName Nothing $ DefunNoSAK tvbs Nothing- let promLambda = foldl apply (DConT (defunctionalizedName opts lambdaName 0))- (map DVarT all_locals)- return (promLambda, ADLamE tyNames promLambda names ann_exp)-promoteExp (DCaseE exp matches) = do- caseTFName <- newUniqueName "Case"- all_locals <- allLocals- let prom_case = foldType (DConT caseTFName) (map DVarT all_locals)- (exp', ann_exp) <- promoteExp exp- (eqns, ann_matches) <- mapAndUnzipM (promoteMatch prom_case) matches- tyvarName <- qNewName "t"- let all_args = all_locals ++ [tyvarName]- tvbs = map (`DPlainTV` ()) all_args- emitDecs [DClosedTypeFamilyD (DTypeFamilyHead caseTFName tvbs DNoSig Nothing) eqns]- -- See Note [Annotate case return type] in Single- let applied_case = prom_case `DAppT` exp'- return ( applied_case- , ADCaseE ann_exp ann_matches applied_case )-promoteExp (DLetE decs exp) = do- unique <- qNewUnique- (binds, ann_env) <- promoteLetDecs (Just unique) decs- (exp', ann_exp) <- letBind binds $ promoteExp exp- return (exp', ADLetE ann_env ann_exp)-promoteExp (DSigE exp ty) = do- (exp', ann_exp) <- promoteExp exp- ty' <- promoteType ty- return (DSigT exp' ty', ADSigE exp' ann_exp ty')-promoteExp e@(DStaticE _) = fail ("Static expressions cannot be promoted: " ++ show e)--promoteLitExp :: 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 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)
src/Data/Singletons/TH/Promote/Defun.hs view
@@ -1,823 +1,823 @@-{-# 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 :: + [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. +-}
src/Data/Singletons/TH/Promote/Monad.hs view
@@ -1,192 +1,117 @@-{- 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, forallBind, allBoundKindVars- ) where--import Control.Monad.Reader-import Control.Monad.Writer-import Language.Haskell.TH.Syntax hiding ( lift )-import Language.Haskell.TH.Desugar-import qualified Language.Haskell.TH.Desugar.OMap.Strict as OMap-import Language.Haskell.TH.Desugar.OMap.Strict (OMap)-import qualified Language.Haskell.TH.Desugar.OSet as OSet-import Language.Haskell.TH.Desugar.OSet (OSet)-import Data.Singletons.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_forall_bound :: OSet Name -- See Note [Explicitly binding kind variables]- , pr_local_decls :: [Dec]- }--emptyPrEnv :: PrEnv-emptyPrEnv = PrEnv { pr_options = defaultOptions- , pr_lambda_bound = OMap.empty- , pr_let_bound = OMap.empty- , pr_forall_bound = OSet.empty- , pr_local_decls = [] }---- the promotion monad-newtype PrM a = PrM (ReaderT PrEnv (WriterT [DDec] Q) a)- deriving ( Functor, Applicative, Monad, Quasi- , MonadReader PrEnv, MonadWriter [DDec]- , MonadFail, MonadIO )--instance DsMonad PrM where- localDeclarations = asks pr_local_decls--instance OptionsMonad PrM where- getOptions = asks pr_options---- return *type-level* names-allLocals :: MonadReader PrEnv m => m [Name]-allLocals = do- lambdas <- asks (OMap.assocs . pr_lambda_bound)- lets <- asks pr_let_bound- -- filter out shadowed variables!- return [ typeName- | (termName, typeName) <- lambdas- , case OMap.lookup termName lets of- Just (DVarT typeName') | typeName' == typeName -> True- _ -> False ]--emitDecs :: MonadWriter [DDec] m => [DDec] -> m ()-emitDecs = tell--emitDecsM :: MonadWriter [DDec] m => m [DDec] -> m ()-emitDecsM action = do- decs <- action- emitDecs decs---- when lambda-binding variables, we still need to add the variables--- to the let-expansion, because of shadowing. ugh.-lambdaBind :: VarPromotions -> PrM a -> PrM a-lambdaBind binds = local add_binds- where add_binds env@(PrEnv { pr_lambda_bound = lambdas- , pr_let_bound = lets }) =- let new_lets = OMap.fromList [ (tmN, DVarT tyN) | (tmN, tyN) <- binds ] in- env { pr_lambda_bound = OMap.fromList binds `OMap.union` lambdas- , pr_let_bound = new_lets `OMap.union` lets }--type LetBind = (Name, DType)-letBind :: [LetBind] -> PrM a -> PrM a-letBind binds = local add_binds- where add_binds env@(PrEnv { pr_let_bound = lets }) =- env { pr_let_bound = OMap.fromList binds `OMap.union` lets }--lookupVarE :: Name -> PrM DType-lookupVarE n = do- opts <- getOptions- lets <- asks pr_let_bound- case OMap.lookup n lets of- Just ty -> return ty- Nothing -> return $ DConT $ defunctionalizedName0 opts n---- Add to the set of bound kind variables currently in scope.--- See Note [Explicitly binding kind variables]-forallBind :: OSet Name -> PrM a -> PrM a-forallBind kvs1 =- local (\env@(PrEnv { pr_forall_bound = kvs2 }) ->- env { pr_forall_bound = kvs1 `OSet.union` kvs2 })---- Look up the set of bound kind variables currently in scope.--- See Note [Explicitly binding kind variables]-allBoundKindVars :: PrM (OSet Name)-allBoundKindVars = asks pr_forall_bound--promoteM :: OptionsMonad q => [Dec] -> PrM a -> q (a, [DDec])-promoteM locals (PrM rdr) = do- opts <- getOptions- other_locals <- localDeclarations- let wr = runReaderT rdr (emptyPrEnv { pr_options = opts- , pr_local_decls = other_locals ++ locals })- q = runWriterT wr- runQ q--promoteM_ :: OptionsMonad q => [Dec] -> PrM () -> q [DDec]-promoteM_ locals thing = do- ((), decs) <- promoteM locals thing- return decs---- promoteM specialized to [DDec]-promoteMDecs :: OptionsMonad q => [Dec] -> PrM [DDec] -> q [DDec]-promoteMDecs locals thing = do- (decs1, decs2) <- promoteM locals thing- return $ decs1 ++ decs2--{--Note [Explicitly binding kind variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We want to ensure that when we single type signatures for functions and data-constructors, we should explicitly quantify every kind variable bound by a-forall. For example, if we were to single the identity function:-- identity :: forall a. a -> a- identity x = x--We want the final result to be:-- sIdentity :: forall a (x :: a). Sing x -> Sing (Identity x :: a)- sIdentity sX = sX--Accomplishing this takes a bit of care during promotion. When promoting a-function, we determine what set of kind variables are currently bound at that-point and store them in an ALetDecEnv (as lde_bound_kvs), which in turn is-singled. Then, during singling, we extract every kind variable in a singled-type signature, subtract the lde_bound_kvs, and explicitly bind the variables-that remain.--For a top-level function like identity, lde_bound_kvs is the empty set. But-consider this more complicated example:-- f :: forall a. a -> a- f = g- where- g :: a -> a- g x = x--When singling, we would eventually end up in this spot:-- sF :: forall a (x :: a). Sing a -> Sing (F a :: a)- sF = sG- where- sG :: _- sG x = x--We must make sure /not/ to fill in the following type for _:-- sF :: forall a (x :: a). Sing a -> Sing (F a :: a)- sF = sG- where- sG :: forall a (y :: a). Sing a -> Sing (G a :: a)- sG x = x--This would be incorrect, as the `a` bound by sF /must/ be the same one used in-sG, as per the scoping of the original `f` function. Thus, we ensure that the-bound variables from `f` are put into lde_bound_kvs when promoting `g` so-that we subtract out `a` and are left with the correct result:-- sF :: forall a (x :: a). Sing a -> Sing (F a :: a)- sF = sG- where- sG :: forall (y :: a). Sing a -> Sing (G a :: a)- sG x = x--}+{- 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
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,1154 +1,1093 @@-{-# 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 Language.Haskell.TH.Desugar.OSet as OSet-import Language.Haskell.TH.Desugar.OSet (OSet)-import qualified Data.Map.Strict as Map-import Data.Map.Strict ( Map )-import Data.Maybe-import qualified Data.Set as Set-import Control.Monad-import Control.Monad.Trans.Class-import Data.List (unzip6, zipWith4)-import qualified GHC.LanguageExtensions.Type as LangExt--{--How singletons-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- (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- let tyvars = map (DVarT . extractTvbName) dtvbs- kind = foldType (DConT name) tyvars- (scons, _) <- singM [] $ mapM (singCtor name) dcons- sDecideInstance <- mkDecideInstance Nothing kind dcons scons- testInstances <- traverse (mkTestInstance Nothing kind 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- (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 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- (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 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 _name _tvbs cons) = do- opts <- getOptions- pure $ concatMap (con_num_args opts) cons- where- con_num_args :: Options -> DCon -> [(Name, DExp)]- con_num_args opts (DCon _tvbs _cxt name fields _rty) =- (name, wrapSingFun (length (tysOfConFields fields))- (DConT $ defunctionalizedName0 opts name)- (DConE $ singledDataConName opts name))- : rec_selectors opts fields-- rec_selectors :: Options -> DConFields -> [(Name, DExp)]- rec_selectors _ (DNormalC {}) = []- rec_selectors opts (DRecC fields) =- let names = map fstOf3 fields in- [ (name, wrapSingFun 1 (DConT $ defunctionalizedName0 opts name)- (DVarE $ singledValueName opts name))- | name <- names ]---- see comment at top of file-buildMethLets :: OptionsMonad q => UClassDecl -> q [(Name, DExp)]-buildMethLets (ClassDecl { cd_lde = LetDecEnv { lde_types = meth_sigs } }) = do- opts <- getOptions- pure $ map (mk_bind opts) (OMap.assocs meth_sigs)- where- mk_bind opts (meth_name, meth_ty) =- ( meth_name- , wrapSingFun (countArgs meth_ty) (DConT $ defunctionalizedName0 opts meth_name)- (DVarE $ singledValueName opts meth_name) )--singClassD :: AClassDecl -> SgM DDec-singClassD (ClassDecl { cd_cxt = cls_cxt- , cd_name = cls_name- , cd_tvbs = cls_tvbs- , cd_fds = cls_fundeps- , cd_lde = LetDecEnv { lde_defns = default_defns- , lde_types = meth_sigs- , lde_infix = fixities- , lde_proms = promoted_defaults- , lde_bound_kvs = meth_bound_kvs } }) =- bindContext [foldTypeTvbs (DConT cls_name) cls_tvbs] $ do- opts <- getOptions- mb_cls_sak <- dsReifyType cls_name- let sing_cls_name = singledClassName opts cls_name- mb_sing_cls_sak = fmap (DKiSigD sing_cls_name) mb_cls_sak- cls_infix_decls <- singReifiedInfixDecls $ cls_name:meth_names- (sing_sigs, _, tyvar_names, cxts, res_kis, singIDefunss)- <- unzip6 <$> zipWithM (singTySig no_meth_defns meth_sigs meth_bound_kvs)- meth_names- (map (DConT . defunctionalizedName0 opts) meth_names)- emitDecs $ maybeToList mb_sing_cls_sak ++ cls_infix_decls ++ concat singIDefunss- let default_sigs = catMaybes $- zipWith4 (mk_default_sig opts) meth_names sing_sigs- tyvar_names res_kis- res_ki_map = Map.fromList (zip meth_names- (map (fromMaybe always_sig) res_kis))- sing_meths <- mapM (uncurry (singLetDecRHS (Map.fromList tyvar_names)- (Map.fromList cxts)- res_ki_map))- (OMap.assocs default_defns)- fixities' <- mapMaybeM (uncurry singInfixDecl) $ OMap.assocs fixities- cls_cxt' <- mapM singPred cls_cxt- return $ DClassD cls_cxt'- sing_cls_name- cls_tvbs- cls_fundeps -- they are fine without modification- (map DLetDec (sing_sigs ++ sing_meths ++ fixities') ++ default_sigs)- where- no_meth_defns = error "Internal error: can't find declared method type"- always_sig = error "Internal error: no signature for default method"- meth_names = map fst $ OMap.assocs meth_sigs-- mk_default_sig opts meth_name (DSigD s_name sty) bound_kvs (Just res_ki) =- DDefaultSigD s_name <$> add_constraints opts meth_name sty bound_kvs res_ki- mk_default_sig _ _ _ _ _ = error "Internal error: a singled signature isn't a signature."-- add_constraints opts meth_name sty (_, bound_kvs) res_ki = do -- Maybe monad- (tvbs, cxt, args, res) <- unravelVanillaDType sty- prom_dflt <- OMap.lookup meth_name promoted_defaults-- -- Filter out explicitly bound kind variables. Otherwise, if you had- -- the following class (#312):- --- -- class Foo a where- -- bar :: a -> b -> b- -- bar _ x = x- --- -- Then it would be singled to:- --- -- class SFoo a where- -- sBar :: forall b (x :: a) (y :: b). Sing x -> Sing y -> Sing (sBar x y)- -- default :: forall b (x :: a) (y :: b).- -- (Bar b x y) ~ (BarDefault b x y) => ...- --- -- Which applies Bar/BarDefault to b, which shouldn't happen.- let tvs = map tvbToType $- filter (\tvb -> extractTvbName tvb `Set.member` bound_kv_set) tvbs- prom_meth = DConT $ defunctionalizedName0 opts meth_name- default_pred = foldType (DConT equalityName)- -- NB: Need the res_ki here to prevent ambiguous- -- kinds in result-inferred default methods.- -- See #175- [ foldApply prom_meth tvs `DSigT` res_ki- , foldApply prom_dflt tvs ]- return $ ravelVanillaDType tvbs (default_pred : cxt) args res- where- bound_kv_set = Set.fromList bound_kvs--singInstD :: AInstDecl -> SgM DDec-singInstD (InstDecl { id_cxt = cxt, id_name = inst_name, id_arg_tys = inst_tys- , id_sigs = inst_sigs, id_meths = ann_meths }) = do- opts <- getOptions- let s_inst_name = singledClassName opts inst_name- bindContext cxt $ do- cxt' <- mapM singPred cxt- inst_kis <- mapM promoteType inst_tys- meths <- concatMapM (uncurry sing_meth) ann_meths- return (DInstanceD Nothing- Nothing- cxt'- (foldl DAppT (DConT s_inst_name) inst_kis)- meths)-- where- sing_meth :: Name -> ALetDecRHS -> SgM [DDec]- sing_meth name rhs = do- opts <- getOptions- mb_s_info <- dsReify (singledValueName opts name)- inst_kis <- mapM promoteType inst_tys- let mk_subst cls_tvbs = Map.fromList $ zip (map extractTvbName vis_cls_tvbs) inst_kis- where- -- This is a half-hearted attempt to address the underlying problem- -- in #358, where we can sometimes have more class type variables- -- (due to implicit kind arguments) than class arguments. This just- -- ensures that the explicit type variables are properly mapped- -- to the class arguments, leaving the implicit kind variables- -- unmapped. That could potentially cause *other* problems, but- -- those are perhaps best avoided by using InstanceSigs. At the- -- very least, this workaround will make error messages slightly- -- less confusing.- vis_cls_tvbs = drop (length cls_tvbs - length inst_kis) cls_tvbs-- sing_meth_ty :: OSet Name -> DType- -> SgM (DType, [Name], DCxt, DKind)- sing_meth_ty bound_kvs inner_ty = do- -- Make sure to expand through type synonyms here! Not doing so- -- resulted in #167.- raw_ty <- expand inner_ty- (s_ty, _num_args, tyvar_names, ctxt, _arg_kis, res_ki)- <- singType bound_kvs (DConT $ defunctionalizedName0 opts name) raw_ty- pure (s_ty, tyvar_names, ctxt, res_ki)-- (s_ty, tyvar_names, ctxt, m_res_ki) <- case OMap.lookup name inst_sigs of- Just inst_sig -> do- -- We have an InstanceSig, so just single that type. Take care to- -- avoid binding the variables bound by the instance head as well.- let inst_bound = foldMap fvDType (cxt ++ inst_kis)- (s_ty, tyvar_names, ctxt, res_ki) <- sing_meth_ty inst_bound inst_sig- pure (s_ty, tyvar_names, ctxt, Just res_ki)- Nothing -> case mb_s_info of- -- We don't have an InstanceSig, so we must compute the type to use- -- in the singled instance ourselves through reification.- Just (DVarI _ (DForallT (DForallInvis cls_tvbs) (DConstrainedT _cls_pred s_ty)) _) -> do- (sing_tvbs, ctxt, _args, res_ty) <- unravelVanillaDType s_ty- let subst = mk_subst cls_tvbs- m_res_ki = case res_ty of- _sing `DAppT` (_prom_func `DSigT` res_ki) -> Just (substKind subst res_ki)- _ -> Nothing-- pure ( substType subst s_ty- , map extractTvbName sing_tvbs- , map (substType subst) ctxt- , m_res_ki )- _ -> do- mb_info <- dsReify name- case mb_info of- Just (DVarI _ (DForallT (DForallInvis cls_tvbs)- (DConstrainedT _cls_pred inner_ty)) _) -> do- let subst = mk_subst cls_tvbs- cls_kvb_names = foldMap (foldMap fvDType . extractTvbKind) cls_tvbs- cls_tvb_names = OSet.fromList $ map extractTvbName cls_tvbs- cls_bound = cls_kvb_names `OSet.union` cls_tvb_names- (s_ty, tyvar_names, ctxt, res_ki) <- sing_meth_ty cls_bound inner_ty- pure ( substType subst s_ty- , tyvar_names- , ctxt- , Just (substKind subst res_ki) )- _ -> fail $ "Cannot find type of method " ++ show name-- let kind_map = maybe Map.empty (Map.singleton name) m_res_ki- meth' <- singLetDecRHS (Map.singleton name tyvar_names)- (Map.singleton name ctxt)- kind_map name rhs- return $ map DLetDec [DSigD (singledValueName opts name) s_ty, meth']--singLetDecEnv :: ALetDecEnv- -> SgM a- -> SgM ([DLetDec], [DDec], a)- -- Return:- --- -- 1. The singled let-decs- -- 2. SingI instances for any defunctionalization symbols- -- (see Data.Singletons.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- , lde_bound_kvs = bound_kvs })- thing_inside = do- let prom_list = OMap.assocs proms- (typeSigs, letBinds, tyvarNames, cxts, res_kis, singIDefunss)- <- unzip6 <$> mapM (uncurry (singTySig defns types bound_kvs)) prom_list- infix_decls' <- mapMaybeM (uncurry singInfixDecl) $ OMap.assocs infix_decls- let res_ki_map = Map.fromList [ (name, res_ki) | ((name, _), Just res_ki)- <- zip prom_list res_kis ]- bindLets letBinds $ do- let_decs <- mapM (uncurry (singLetDecRHS (Map.fromList tyvarNames)- (Map.fromList cxts)- res_ki_map))- (OMap.assocs defns)- thing <- thing_inside- return (infix_decls' ++ typeSigs ++ let_decs, concat singIDefunss, thing)--singTySig :: OMap Name ALetDecRHS -- definitions- -> OMap Name DType -- type signatures- -> OMap Name (OSet Name) -- bound kind variables- -> Name -> DType -- the type is the promoted type, not the type sig!- -> SgM ( DLetDec -- the new type signature- , (Name, DExp) -- the let-bind entry- , (Name, [Name]) -- the scoped tyvar names in the tysig- , (Name, DCxt) -- the context of the type signature- , Maybe DKind -- the result kind in the tysig- , [DDec] -- SingI instances for defun symbols- )-singTySig defns types bound_kvs name prom_ty = do- opts <- getOptions- let sName = singledValueName opts name- case OMap.lookup name types of- Nothing -> do- num_args <- guess_num_args- (sty, tyvar_names) <- mk_sing_ty num_args- singIDefuns <- singDefuns name VarName []- (map (const Nothing) tyvar_names) Nothing- return ( DSigD sName sty- , (name, wrapSingFun num_args prom_ty (DVarE sName))- , (name, tyvar_names)- , (name, [])- , Nothing- , singIDefuns )- Just ty -> do- all_bound_kvs <- lookup_bound_kvs- (sty, num_args, tyvar_names, ctxt, arg_kis, res_ki)- <- singType all_bound_kvs prom_ty ty- bound_cxt <- askContext- singIDefuns <- singDefuns name VarName (bound_cxt ++ ctxt)- (map Just arg_kis) (Just res_ki)- return ( DSigD sName sty- , (name, wrapSingFun num_args prom_ty (DVarE sName))- , (name, tyvar_names)- , (name, ctxt)- , Just res_ki- , singIDefuns )- where- guess_num_args :: SgM Int- guess_num_args =- case OMap.lookup name defns of- Nothing -> fail "Internal error: promotion known for something not let-bound."- Just (AValue _ n _) -> return n- Just (AFunction _ n _) -> return n-- lookup_bound_kvs :: SgM (OSet Name)- lookup_bound_kvs =- case OMap.lookup name bound_kvs of- Nothing -> fail $ "Internal error: " ++ nameBase name ++ " has no type variable "- ++ "bindings, despite having a type signature"- Just kvs -> pure kvs-- -- create a Sing t1 -> Sing t2 -> ... type of a given arity and result type- mk_sing_ty :: Int -> SgM (DType, [Name])- mk_sing_ty n = do- arg_names <- replicateM n (qNewName "arg")- -- If there are no arguments, use `Sing @_` instead of `Sing`.- -- See Note [Disable kind generalization for local functions if possible]- let sing_w_wildcard | n == 0 = singFamily `DAppKindT` DWildCardT- | otherwise = singFamily- return ( ravelVanillaDType- (map (`DPlainTV` SpecifiedSpec) arg_names)- []- (map (\nm -> singFamily `DAppT` DVarT nm) arg_names)- (sing_w_wildcard `DAppT`- (foldl apply prom_ty (map DVarT arg_names)))- , arg_names )--{--Note [Disable kind generalization for local functions if possible]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this example (from #296):-- f :: forall a. MyProxy a -> MyProxy a- f MyProxy =- let x = let z :: MyProxy a- z = MyProxy in z- in x--A naïve attempt at singling `f` is as follows:-- type LetZ :: MyProxy a- type family LetZ where- LetZ = 'MyProxy-- type family LetX where- LetX = LetZ-- type F :: forall a. MyProxy a -> MyProxy a- type family F x where- F 'MyProxy = LetX-- sF :: forall a (t :: MyProxy a). Sing t -> Sing (F t :: MyProxy a)- sF SMyProxy =- let sX :: Sing LetX- sX = let sZ :: Sing (LetZ :: MyProxy a)- sZ = SMyProxy in sZ- in sX--This will not typecheck, however. The is because the return kind of-`LetX` (in `let sX :: Sing LetX`) will get generalized by virtue of `sX`-having a type signature. It's as if one had written this:-- sF :: forall a (t :: MyProxy a). Sing t -> Sing (F t :: MyProxy a)- sF SMyProxy =- let sX :: forall a1. Sing (LetX :: MyProxy a1)- sX = ...--This is too general, since `sX` will only typecheck if the return kind of-`LetX` is `MyProxy a`, not `MyProxy a1`. In order to avoid this problem,-we need to avoid kind generalization when kind-checking the type of `sX`.-To accomplish this, we borrow a trick from-Note [The id hack; or, how singletons-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 [Name]- -> Map Name DCxt -- the context of the type signature- -- (might not be known)- -> Map Name DKind -- result kind (might not be known)- -> Name -> ALetDecRHS -> SgM DLetDec-singLetDecRHS bound_names cxts res_kis name ld_rhs = do- opts <- getOptions- bindContext (Map.findWithDefault [] name cxts) $- case ld_rhs of- AValue prom num_arrows exp ->- DValD (DVarP (singledValueName opts name)) <$>- (wrapUnSingFun num_arrows prom <$> singExp exp (Map.lookup name res_kis))- AFunction prom_fun num_arrows clauses ->- let tyvar_names = case Map.lookup name bound_names of- Nothing -> []- Just ns -> ns- res_ki = Map.lookup name res_kis- in- DFunD (singledValueName opts name) <$>- mapM (singClause prom_fun num_arrows tyvar_names res_ki) clauses--singClause :: DType -- the promoted function- -> Int -- the number of arrows in the type. If this is more- -- than the number of patterns, we need to eta-expand- -- with unSingFun.- -> [Name] -- the names of the forall'd vars in the type sig of this- -- function. This list should have at least the length as the- -- number of patterns in the clause- -> Maybe DKind -- result kind, if known- -> ADClause -> SgM DClause-singClause prom_fun num_arrows bound_names res_ki- (ADClause var_proms pats exp) = do-- -- Fix #166:- when (num_arrows - length pats < 0) $- fail $ "Function being promoted to " ++ (pprint (typeToTH prom_fun)) ++- " has too many arguments."-- (sPats, sigPaExpsSigs) <- evalForPair $ mapM (singPat (Map.fromList var_proms)) pats- sBody <- singExp exp res_ki- -- when calling unSingFun, the promoted pats aren't in scope, so we use the- -- bound_names instead- let pattern_bound_names = zipWith const bound_names pats- -- this does eta-expansion. See comment at top of file.- sBody' = wrapUnSingFun (num_arrows - length pats)- (foldl apply prom_fun (map DVarT pattern_bound_names)) sBody- return $ DClause sPats $ mkSigPaCaseE sigPaExpsSigs sBody'--singPat :: Map Name Name -- from term-level names to type-level names- -> ADPat- -> QWithAux SingDSigPaInfos SgM DPat-singPat var_proms = go- where- go :: ADPat -> QWithAux SingDSigPaInfos SgM DPat- go (ADLitP _lit) =- fail "Singling of literal patterns not yet supported"- go (ADVarP name) = do- opts <- getOptions- tyname <- case Map.lookup name var_proms of- Nothing ->- fail "Internal error: unknown variable when singling pattern"- Just tyname -> return tyname- pure $ DVarP (singledValueName opts name)- `DSigP` (singFamily `DAppT` DVarT tyname)- go (ADConP name 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 -> Maybe DKind -- the kind of the expression, if known- -> SgM DExp- -- See Note [Why error is so special]-singExp (ADVarE err `ADAppE` arg) _res_ki- | err == errorName = do opts <- getOptions- DAppE (DVarE (singledValueName opts err)) <$>- singExp arg (Just (DConT symbolName))-singExp (ADVarE name) _res_ki = lookupVarE name-singExp (ADConE name) _res_ki = lookupConE name-singExp (ADLitE lit) _res_ki = singLit lit-singExp (ADAppE e1 e2) _res_ki = do- e1' <- singExp e1 Nothing- e2' <- singExp e2 Nothing- -- `applySing undefined x` kills type inference, because GHC can't figure- -- out the type of `undefined`. So we don't emit `applySing` there.- if isException e1'- then return $ e1' `DAppE` e2'- else return $ (DVarE applySingName) `DAppE` e1' `DAppE` e2'-singExp (ADLamE ty_names prom_lam names exp) _res_ki = do- opts <- getOptions- let sNames = map (singledValueName opts) names- exp' <- singExp exp Nothing- -- we need to bind the type variables... but DLamE doesn't allow SigT patterns.- -- So: build a case- let caseExp = DCaseE (mkTupleDExp (map DVarE sNames))- [DMatch (mkTupleDPat- (map ((DWildP `DSigP`) .- (singFamily `DAppT`) .- DVarT) ty_names)) exp']- return $ wrapSingFun (length names) prom_lam $ DLamE sNames caseExp-singExp (ADCaseE exp matches ret_ty) res_ki =- -- See Note [Annotate case return type] and- -- Note [The id hack; or, how singletons-th learned to stop worrying and- -- avoid kind generalization]- DAppE (DAppTypeE (DVarE 'id)- (singFamily `DAppT` (ret_ty `maybeSigT` res_ki)))- <$> (DCaseE <$> singExp exp Nothing <*> mapM (singMatch res_ki) matches)-singExp (ADLetE env exp) res_ki = do- -- We intentionally discard the SingI instances for exp's defunctionalization- -- symbols, as we also do not generate the declarations for the- -- defunctionalization symbols in the first place during promotion.- (let_decs, _, exp') <- singLetDecEnv env $ singExp exp res_ki- pure $ DLetE let_decs exp'-singExp (ADSigE prom_exp exp ty) _ = do- exp' <- singExp exp (Just ty)- pure $ DSigE exp' $ DConT singFamilyName `DAppT` DSigT prom_exp ty---- See Note [DerivedDecl] in Data.Singletons.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- let sty_tycon = singledDataTypeName opts ty_tycon- show_inst = DStandaloneDerivD Nothing Nothing show_cxt- (DConT showName `DAppT` (DConT sty_tycon `DAppT` DSigT (DVarT z) ty))- 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 :: Maybe DKind -- ^ the result kind, if known- -> ADMatch -> SgM DMatch-singMatch res_ki (ADMatch var_proms pat exp) = do- (sPat, sigPaExpsSigs) <- evalForPair $ singPat (Map.fromList var_proms) pat- sExp <- singExp exp res_ki- return $ DMatch sPat $ mkSigPaCaseE sigPaExpsSigs sExp--singLit :: Lit -> SgM DExp-singLit (IntegerL n) = 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.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. +-}
src/Data/Singletons/TH/Single/Data.hs view
@@ -1,388 +1,405 @@-{- 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-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.Single.Type-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 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] ++- 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- kvbs = singTypeKVBs con_tvbs kinds [] rty' mempty- 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 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. +-}
src/Data/Singletons/TH/Single/Decide.hs view
@@ -1,109 +1,112 @@-{- 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.Util-import Control.Monad---- Make an instance of SDecide.-mkDecideInstance :: DsMonad q => Maybe DCxt -> DKind- -> [DCon] -- ^ The /original/ constructors (for inferring the instance context)- -> [DCon] -- ^ The /singletons/ constructors- -> q DDec-mkDecideInstance mb_ctxt k 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) k ctors- return $ DInstanceD Nothing Nothing- constraints- (DAppT (DConT sDecideClassName) k)- [DLetDec $ DFunD sDecideMethName methClauses]--data TestInstance = TestEquality- | TestCoercion---- Make an instance of TestEquality or TestCoercion by leveraging SDecide.-mkTestInstance :: OptionsMonad q => Maybe DCxt -> DKind- -> Name -- ^ The name of the data type- -> [DCon] -- ^ The /original/ constructors (for inferring the instance context)- -> TestInstance -> q DDec-mkTestInstance mb_ctxt k data_name ctors ti = do- opts <- getOptions- constraints <- inferConstraintsDef mb_ctxt (DConT sDecideClassName) k ctors- pure $ DInstanceD Nothing Nothing- constraints- (DAppT (DConT tiClassName)- (DConT (singledDataTypeName opts data_name)- `DSigT` (DArrowT `DAppT` k `DAppT` DConT typeKindName)))- [DLetDec $ DFunD tiMethName- [DClause [] (DVarE tiDefaultName)]]- where- (tiClassName, tiMethName, tiDefaultName) =- case ti of- TestEquality -> (testEqualityClassName, testEqualityMethName, decideEqualityName)- TestCoercion -> (testCoercionClassName, testCoercionMethName, decideCoercionName)--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] + +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,170 @@-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 + +-- 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. +-}
src/Data/Singletons/TH/Single/Monad.hs view
@@ -1,195 +1,182 @@-{-# 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, wrapUnSingFun,- 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.Reader-import Control.Monad.Writer-import Control.Applicative---- environment during singling-data SgEnv =- SgEnv { sg_options :: Options- , sg_let_binds :: Map Name DExp -- from the *original* name- , sg_context :: DCxt -- See Note [Tracking the current type signature context]- , sg_local_decls :: [Dec]- }--emptySgEnv :: SgEnv-emptySgEnv = SgEnv { sg_options = defaultOptions- , sg_let_binds = Map.empty- , sg_context = []- , sg_local_decls = []- }---- the singling monad-newtype SgM a = SgM (ReaderT SgEnv (WriterT [DDec] Q) a)- deriving ( Functor, Applicative, Monad- , MonadReader SgEnv, MonadWriter [DDec]- , MonadFail, MonadIO, Quasi )--instance DsMonad SgM where- localDeclarations = asks sg_local_decls--instance OptionsMonad SgM where- getOptions = asks sg_options--bindLets :: [(Name, DExp)] -> SgM a -> SgM a-bindLets lets1 =- local (\env@(SgEnv { sg_let_binds = lets2 }) ->- env { sg_let_binds = (Map.fromList lets1) `Map.union` lets2 })---- Add some constraints to the current type signature context.--- See Note [Tracking the current type signature context]-bindContext :: DCxt -> SgM a -> SgM a-bindContext ctxt1- = local (\env@(SgEnv { sg_context = ctxt2 }) ->- env { sg_context = ctxt1 ++ ctxt2 })---- Retrieve the current type signature context.--- See Note [Tracking the current type signature context]-askContext :: SgM DCxt-askContext = asks sg_context--lookupVarE :: Name -> SgM DExp-lookupVarE name = do- opts <- getOptions- lookup_var_con (singledValueName opts)- (DVarE . singledValueName opts) name--lookupConE :: Name -> SgM DExp-lookupConE name = do- opts <- getOptions- lookup_var_con (singledDataConName opts)- (DConE . singledDataConName opts) name--lookup_var_con :: (Name -> Name) -> (Name -> DExp) -> Name -> SgM DExp-lookup_var_con mk_sing_name mk_exp name = do- opts <- getOptions- letExpansions <- asks sg_let_binds- sName <- mkDataName (nameBase (mk_sing_name name)) -- we want *term* names!- case Map.lookup name letExpansions of- Nothing -> do- -- try to get it from the global context- m_dinfo <- liftM2 (<|>) (dsReify sName) (dsReify name)- -- try the unrefined name too -- it's needed to bootstrap Enum- case m_dinfo of- Just (DVarI _ ty _) ->- let num_args = countArgs ty in- return $ wrapSingFun num_args (DConT $ defunctionalizedName0 opts name)- (mk_exp name)- _ -> return $ mk_exp name -- lambda-bound- Just exp -> return exp--wrapSingFun :: Int -> DType -> DExp -> DExp-wrapSingFun 0 _ = id-wrapSingFun n ty =- let wrap_fun = DVarE $ case n of- 1 -> 'singFun1- 2 -> 'singFun2- 3 -> 'singFun3- 4 -> 'singFun4- 5 -> 'singFun5- 6 -> 'singFun6- 7 -> 'singFun7- _ -> error "No support for functions of arity > 7."- in- (wrap_fun `DAppTypeE` ty `DAppE`)--wrapUnSingFun :: Int -> DType -> DExp -> DExp-wrapUnSingFun 0 _ = id-wrapUnSingFun n ty =- let unwrap_fun = DVarE $ case n of- 1 -> 'unSingFun1- 2 -> 'unSingFun2- 3 -> 'unSingFun3- 4 -> 'unSingFun4- 5 -> 'unSingFun5- 6 -> 'unSingFun6- 7 -> 'unSingFun7- _ -> error "No support for functions of arity > 7."- in- (unwrap_fun `DAppTypeE` ty `DAppE`)--singM :: OptionsMonad q => [Dec] -> SgM a -> q (a, [DDec])-singM locals (SgM rdr) = do- opts <- getOptions- other_locals <- localDeclarations- let wr = runReaderT rdr (emptySgEnv { sg_options = opts- , sg_local_decls = other_locals ++ locals })- q = runWriterT wr- runQ q--singDecsM :: OptionsMonad q => [Dec] -> SgM [DDec] -> q [DDec]-singDecsM locals thing = do- (decs1, decs2) <- singM locals thing- return $ decs1 ++ decs2--{--Note [Tracking the current type signature context]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Much like we track the let-bound names in scope, we also track the current-context. For instance, in the following program:-- -- (1)- f :: forall a. Show a => a -> String -> Bool- f x y = g (show x) y- where- -- (2)- g :: forall b. Eq b => b -> b -> Bool- g = h- where- -- (3)- h :: b -> b -> Bool- h = (==)--Here is the context at various points:--(1) ()-(2) (Show a)-(3) (Show a, Eq b)--We track this informating during singling instead of during promotion, as the-promoted versions of things are often type families, which do not have-contexts.--Why do we bother tracking this at all? Ultimately, because singDefuns (from-Data.Singletons.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, 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. +-}
src/Data/Singletons/TH/Single/Type.hs view
@@ -1,312 +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.Desugar.OSet (OSet)-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-import Data.Foldable-import Data.Function-import Data.List (deleteFirstsBy)--singType :: OSet Name -- the set of bound kind variables in this scope- -- see Note [Explicitly binding kind variables]- -- in Data.Singletons.TH.Promote.Monad- -> DType -- the promoted version of the thing classified by...- -> DType -- ... this type- -> SgM ( DType -- the singletonized type- , Int -- the number of arguments- , [Name] -- the names of the tyvars used in the sing'd type- , DCxt -- the context of the singletonized type- , [DKind] -- the kinds of the argument types- , DKind ) -- the kind of the result type-singType bound_kvs prom ty = do- (orig_tvbs, cxt, args, res) <- unravelVanillaDType ty- let num_args = length args- cxt' <- mapM singPred_NC cxt- arg_names <- replicateM num_args (qNewName "t")- prom_args <- mapM promoteType_NC args- prom_res <- promoteType_NC res- let args' = map (\n -> singFamily `DAppT` (DVarT n)) arg_names- res' = singFamily `DAppT` (foldl apply prom (map DVarT arg_names) `DSigT` prom_res)- -- Make sure to include an explicit `prom_res` kind annotation.- -- See Note [Preserve the order of type variables during singling],- -- wrinkle 3.- kvbs = singTypeKVBs orig_tvbs prom_args cxt' prom_res bound_kvs- all_tvbs = kvbs ++ zipWith (`DKindedTV` SpecifiedSpec) arg_names prom_args- ty' = ravelVanillaDType all_tvbs cxt' args' res'- return (ty', num_args, arg_names, cxt, prom_args, prom_res)---- Compute the kind variable binders to use in the singled version of a type--- signature. This has two main call sites: singType and D.S.TH.Single.Data.singCtor.------ This implements the advice documented in--- Note [Preserve the order of type variables during singling], wrinkle 1.-singTypeKVBs ::- [DTyVarBndrSpec] -- ^ The bound type variables from the original type signature.- -> [DType] -- ^ The argument types of the signature (promoted).- -> DCxt -- ^ The context of the signature (singled).- -> DType -- ^ The result type of the signature (promoted).- -> OSet Name -- ^ The type variables previously bound in the current scope.- -> [DTyVarBndrSpec] -- ^ The kind variables for the singled type signature.-singTypeKVBs orig_tvbs prom_args sing_ctxt prom_res bound_tvbs- | null orig_tvbs- -- There are no explicitly `forall`ed type variable binders, so we must- -- infer them ourselves.- = changeDTVFlags SpecifiedSpec $- deleteFirstsBy- ((==) `on` extractTvbName)- (toposortTyVarsOf $ prom_args ++ sing_ctxt ++ [prom_res])- (map (`DPlainTV` ()) $ toList bound_tvbs)- -- Make sure to subtract out the bound variables currently in scope,- -- lest we accidentally shadow them in this type signature.- -- See Note [Explicitly binding kind variables] in D.S.TH.Promote.Monad.- | otherwise- -- There is an explicit `forall`, so this case is easy.- = orig_tvbs---- Single a DPred, checking that it is a vanilla type in the process.--- See [Vanilla-type validity checking during promotion]--- in Data.Singletons.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. It's tempting-to think that since there is no explicit `forall` in the original type-signature, we could get away without an explicit `forall` in the singled type-signature. That is, one could write:-- sAbsurd :: Sing (v :: V a) -> Sing (Absurd :: b)--This would have the right type variable order, but unfortunately, this approach-does not play well with singletons-th's style of code generation. Consider the code-that would be generated for the body of sAbsurd:-- sAbsurd :: Sing (v :: V a) -> Sing (Absurd :: b)- sAbsurd (sV :: Sing v) = id @(Case v v :: b) (case sV of {})--Note the use of the type `Case v v :: b` in the right-hand side of sAbsurd.-However, because `b` was not bound by a top-level `forall`, it won't be in-scope here, resulting in an error!--(Why do we generate the code `id @(Case v v :: b)` in the first place? See-Note [The id hack; or, how singletons-th learned to stop worrying and avoid kind generalization]-in D.S.TH.Single.)--The simplest approach is to just always generate singled type signatures with-explicit `forall`s. In the event that the original type signature lacks an-explicit `forall`, we infer the correct type variable ordering ourselves and-synthesize a `forall` with that order. The `singTypeKVBs` function implements-this logic.---------- Wrinkle 2: The TH reification swamp--------There is another issue with type signatures that lack explicit `forall`s, one-which the current design of Template Haskell does not make simple to fix.-If we single code that is wrapped in TH quotes, such as in the following example:-- {-# 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,240 +1,224 @@-{-# 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 [Explicitly binding kind 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 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- = AFunction DType -- promote function (unapplied)- Int -- number of arrows in type- [ADClause]- | AValue DType -- promoted exp- Int -- number of arrows in type- ADExp-data instance LetDecRHS Unannotated = UFunction [DClause]- | UValue DExp--type ALetDecRHS = LetDecRHS Annotated-type ULetDecRHS = LetDecRHS Unannotated--data LetDecEnv ann = LetDecEnv- { lde_defns :: OMap Name (LetDecRHS ann)- , lde_types :: OMap Name DType -- type signatures- , lde_infix :: OMap Name Fixity -- infix declarations- , lde_proms :: IfAnn ann (OMap Name DType) () -- possibly, promotions- , lde_bound_kvs :: IfAnn ann (OMap Name (OSet Name)) ()- -- The set of bound variables in scope.- -- See Note [Explicitly binding kind variables]- -- in Data.Singletons.TH.Promote.Monad.- }-type ALetDecEnv = LetDecEnv Annotated-type ULetDecEnv = LetDecEnv Unannotated--instance Semigroup ULetDecEnv where- LetDecEnv defns1 types1 infx1 _ _ <> LetDecEnv defns2 types2 infx2 _ _ =- LetDecEnv (defns1 <> defns2) (types1 <> types2) (infx1 <> infx2) () ()--instance Monoid ULetDecEnv where- mempty = LetDecEnv OMap.empty OMap.empty OMap.empty () ()--valueBinding :: Name -> ULetDecRHS -> ULetDecEnv-valueBinding n v = emptyLetDecEnv { lde_defns = OMap.singleton n v }--typeBinding :: Name -> DType -> ULetDecEnv-typeBinding n t = emptyLetDecEnv { lde_types = OMap.singleton n t }--infixDecl :: Fixity -> Name -> ULetDecEnv-infixDecl f n = emptyLetDecEnv { lde_infix = OMap.singleton n f }--emptyLetDecEnv :: ULetDecEnv-emptyLetDecEnv = mempty--buildLetDecEnv :: Quasi q => [DLetDec] -> q ULetDecEnv-buildLetDecEnv = go emptyLetDecEnv- where- go acc [] = return acc- go acc (DFunD name clauses : rest) =- go (valueBinding name (UFunction clauses) <> acc) rest- go acc (DValD (DVarP name) exp : rest) =- go (valueBinding name (UValue exp) <> acc) rest- go acc (dec@(DValD {}) : rest) = do- flattened <- flattenDValD dec- go acc (flattened ++ rest)- go acc (DSigD name ty : rest) =- go (typeBinding name ty <> acc) rest- go acc (DInfixD f n : rest) =- go (infixDecl f n <> acc) rest- go acc (DPragmaD{} : rest) = go acc rest---- See Note [DerivedDecl]-data DerivedDecl (cls :: Type -> Constraint) = DerivedDecl- { ded_mb_cxt :: Maybe DCxt- , ded_type :: DType- , ded_type_tycon :: Name- , ded_decl :: DataDecl- }--type DerivedEqDecl = DerivedDecl Eq-type DerivedShowDecl = DerivedDecl Show--{- Note [DerivedDecl]-~~~~~~~~~~~~~~~~~~~~~-Most derived instances are wholly handled in-Data.Singletons.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) + +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. +-}
src/Data/Singletons/TH/Util.hs view
@@ -1,575 +1,577 @@-{-# 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 hiding ( mapM )-import Control.Monad.Except hiding ( mapM )-import Control.Monad.Reader hiding ( mapM )-import Control.Monad.Writer hiding ( mapM )-import qualified Data.Map as Map-import Data.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 = 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 == '_'