diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,159 +1,184 @@ -Changelog for the `singletons-th` project -========================================= - -3.2 [2023.03.12] ----------------- -* Require building with GHC 9.6. -* Derived `POrd` and `SOrd` instances (arising from a use of `deriving Ord`) - now use `(<>) @Ordering` in their implementations instead of the custom - `thenCmp :: Ordering -> Ordering -> Ordering` function. While most code will - likely continue to work after this change, this may break code that attempts - to prove properties about the implementation of a derived `POrd`/`SOrd` - instance. -* Fix a bug in which the `singDecideInstances` and `showSingInstances`, as well - as `deriving Show` declarations, would not respect custom - `promotedDataTypeOrConName` options. -* Allow building with `mtl-2.3.*`. - -3.1.1 [2022.08.23] ------------------- -* Require building with GHC 9.4. -* Improve error messages when attempting to promote a partial application of - a function arrow `(->)`, which is not currently supported. - -3.1 [2021.10.30] ----------------- -* Require building with GHC 9.2. -* Allow promoting and singling type applications in data constructor patterns. -* Make the Template Haskell machinery generate `SingI1` and `SingI2` instances - when possible. -* Make `genDefunSymbols` and related functions less likely to trigger - [GHC#19743](https://gitlab.haskell.org/ghc/ghc/-/issues/19743). - -3.0 [2021.03.12] ----------------- -* The `singletons` library has been split into three libraries: - - * The new `singletons` library is now a minimal library that only provides - `Data.Singletons`, `Data.Singletons.Decide`, `Data.Singletons.Sigma`, and - `Data.Singletons.ShowSing` (if compiled with GHC 8.6 or later). - `singletons` now supports building GHCs back to GHC 8.0, as well as GHCJS. - * The `singletons-th` library defines Template Haskell functionality for - promoting and singling term-level definitions, but but nothing else. This - library continues to require the latest stable release of GHC. - * The `singletons-base` library defines promoted and singled versions of - definitions from the `base` library, including the `Prelude`. This library - continues to require the latest stable release of GHC. - - Consult the changelogs for `singletons` and `singletons-base` for changes - specific to those libraries. For more information on this split, see the - [relevant GitHub discussion](https://github.com/goldfirere/singletons/issues/420). -* Require building with GHC 9.0. -* `Data.Singletons.CustomStar` and `Data.Singletons.SuppressUnusedWarnings` - have been renamed to `Data.Singletons.TH.CustomStar` and - `Data.Singletons.SuppressUnusedWarnings`, respectively, to give every module - in `singletons-th` a consistent module prefix. -* Due to the `singletons` package split, the `singletons-th` modules - `Data.Singletons.TH` and `Data.Singletons.TH.CustomStar` (formerly known as - `Data.Singletons.CustomStar`) no longer re-export any definitions from the - `singletons-base` module `Prelude.Singletons` (formerly known as - `Data.Singletons.Prelude`). The `singletons-base` library now provides - versions of these modules—`Data.Singletons.Base.CustomStar` and - `Data.Singletons.Base.TH`, respectively—that do re-export definitions - from `Prelude.Singletons`. -* "Fully saturated" defunctionalization symbols (e.g., `IdSym1`) are now - defined as type families instead of type synonyms. This has two notable - benefits: - - * Fully saturated defunctionalization symbols can now be given standalone - kind signatures, which ensures that the order of kind variables is the - same as the user originally declared them. - * This fixes a minor regression in `singletons-2.7` in which the quality - of `:kind!` output in GHCi would become worse when using promoted type - families generated by Template Haskell. - - Under certain circumstances, this can be a breaking change: - - * Since more TH-generated promoted functions now have type families on - their right-hand sides, some programs will now require - `UndecidableInstances` where they didn't before. - * Certain definitions that made use of overlapping patterns, such as - `natMinus` below, will no longer typecheck: - - ```hs - $(singletons [d| - data Nat = Z | S Nat - - natMinus :: Nat -> Nat -> Nat - natMinus Z _ = Z - natMinus (S a) (S b) = natMinus a b - natMinus a Z = a - |]) - ``` - - This can be worked around by avoiding the use of overlapping patterns. - In the case of `natMinus`, this amounts to changing the third equation - to match on its first argument: - - ```hs - $(singletons [d| - natMinus :: Nat -> Nat -> Nat - natMinus Z _ = Z - natMinus (S a) (S b) = natMinus a b - natMinus a@(S _) Z = a - |]) - ``` -* The specification for how `singletons` deals with record selectors has been - simplified. Previously, `singletons` would try to avoid promoting so-called - "naughty" selectors (those whose types mention existential type variables - that do not appear in the constructor's return type) to top-level functions. - Determing if a selector is naughty is quite challenging in practice, as - determining if a type variable is existential or not in the context of - Template Haskell is difficult in the general case. As a result, `singletons` - now adopts the dumb-but-predictable approach of always promoting record - selectors to top-level functions, naughty or not. - - This means that attempting to promote code with a naughty record selector, - like in the example below, will no longer work: - - ```hs - $(promote [d| - data Some :: (Type -> Type) -> Type where - MkSome :: { getSome :: f a } -> Some f - -- getSome is naughty due to mentioning the type variable `a` - |]) - ``` - - Please open an issue if you find this restriction burdensome in practice. -* The `singEqInstanceOnly` and `singEqInstancesOnly` functions, which generate - `SEq` (but not `PEq`) instances, have been removed. There is not much point - in keeping these functions around now that `PEq` now longer has a special - default implementation. Use `singEqInstance{s}` instead. -* The Template Haskell machinery will no longer promote `TypeRep` to `Type`, - as this special case never worked properly in the first place. -* The Template Haskell machinery will now preserve strict fields in data types - when generating their singled counterparts. -* Introduce a new `promotedDataTypeOrConName` option to - `Data.Singletons.TH.Options`. Overriding this option can be useful in - situations where one wishes to promote types such as `Nat`, `Symbol`, or - data types built on top of them. See the - "Arrows, `Nat`, `Symbol`, and literals" section of the `README` for more - information. -* Define a `Quote` instance for `OptionsM`. A notable benefit of this instance - is that it avoids the need to explicitly `lift` TH quotes into `OptionsM`. - Before, you would have to do this: - - ```hs - import Control.Monad.Trans.Class (lift) - - withOptions defaultOptions - $ singletons - $ lift [d| data T = MkT |] - ``` - - But now, it suffices to simply do this: - - ```hs - withOptions defaultOptions - $ singletons [d| data T = MkT |] - ``` +Changelog for the `singletons-th` project +========================================= + +3.3 [2023.10.13] +---------------- +* Require building with GHC 9.8. +* Singled data types with derived `Eq` or `Ord` instances now generate `Eq` or + `Ord` instances for the singleton type itself, e.g., + + ```hs + instance Eq (SExample a) where + _ == _ = True + + instance Ord (SExample a) where + compare _ _ = EQ + ``` +* `singletons-th` now makes an effort to promote definitions that use scoped + type variables. See the "Scoped type variables" section of the `README` for + more information about what `singletons-th` can (and can't) do. +* `singletons-th` now supports singling type-level definitions that use + `TypeAbstractions`. +* Fix a bug in which data types using visible dependent quantification would + generate ill-scoped code when singled. +* Fix a bug in which singling a local variable that shadows a top-level + definition would fail to typecheck in some circumstances. +* Fix a bug in which `singletons-th` would incorrectly promote/single records + to top-level field selectors when `NoFieldSelectors` was active. + +3.2 [2023.03.12] +---------------- +* Require building with GHC 9.6. +* Derived `POrd` and `SOrd` instances (arising from a use of `deriving Ord`) + now use `(<>) @Ordering` in their implementations instead of the custom + `thenCmp :: Ordering -> Ordering -> Ordering` function. While most code will + likely continue to work after this change, this may break code that attempts + to prove properties about the implementation of a derived `POrd`/`SOrd` + instance. +* Fix a bug in which the `singDecideInstances` and `showSingInstances`, as well + as `deriving Show` declarations, would not respect custom + `promotedDataTypeOrConName` options. +* Allow building with `mtl-2.3.*`. + +3.1.1 [2022.08.23] +------------------ +* Require building with GHC 9.4. +* Improve error messages when attempting to promote a partial application of + a function arrow `(->)`, which is not currently supported. + +3.1 [2021.10.30] +---------------- +* Require building with GHC 9.2. +* Allow promoting and singling type applications in data constructor patterns. +* Make the Template Haskell machinery generate `SingI1` and `SingI2` instances + when possible. +* Make `genDefunSymbols` and related functions less likely to trigger + [GHC#19743](https://gitlab.haskell.org/ghc/ghc/-/issues/19743). + +3.0 [2021.03.12] +---------------- +* The `singletons` library has been split into three libraries: + + * The new `singletons` library is now a minimal library that only provides + `Data.Singletons`, `Data.Singletons.Decide`, `Data.Singletons.Sigma`, and + `Data.Singletons.ShowSing` (if compiled with GHC 8.6 or later). + `singletons` now supports building GHCs back to GHC 8.0, as well as GHCJS. + * The `singletons-th` library defines Template Haskell functionality for + promoting and singling term-level definitions, but but nothing else. This + library continues to require the latest stable release of GHC. + * The `singletons-base` library defines promoted and singled versions of + definitions from the `base` library, including the `Prelude`. This library + continues to require the latest stable release of GHC. + + Consult the changelogs for `singletons` and `singletons-base` for changes + specific to those libraries. For more information on this split, see the + [relevant GitHub discussion](https://github.com/goldfirere/singletons/issues/420). +* Require building with GHC 9.0. +* `Data.Singletons.CustomStar` and `Data.Singletons.SuppressUnusedWarnings` + have been renamed to `Data.Singletons.TH.CustomStar` and + `Data.Singletons.SuppressUnusedWarnings`, respectively, to give every module + in `singletons-th` a consistent module prefix. +* Due to the `singletons` package split, the `singletons-th` modules + `Data.Singletons.TH` and `Data.Singletons.TH.CustomStar` (formerly known as + `Data.Singletons.CustomStar`) no longer re-export any definitions from the + `singletons-base` module `Prelude.Singletons` (formerly known as + `Data.Singletons.Prelude`). The `singletons-base` library now provides + versions of these modules—`Data.Singletons.Base.CustomStar` and + `Data.Singletons.Base.TH`, respectively—that do re-export definitions + from `Prelude.Singletons`. +* "Fully saturated" defunctionalization symbols (e.g., `IdSym1`) are now + defined as type families instead of type synonyms. This has two notable + benefits: + + * Fully saturated defunctionalization symbols can now be given standalone + kind signatures, which ensures that the order of kind variables is the + same as the user originally declared them. + * This fixes a minor regression in `singletons-2.7` in which the quality + of `:kind!` output in GHCi would become worse when using promoted type + families generated by Template Haskell. + + Under certain circumstances, this can be a breaking change: + + * Since more TH-generated promoted functions now have type families on + their right-hand sides, some programs will now require + `UndecidableInstances` where they didn't before. + * Certain definitions that made use of overlapping patterns, such as + `natMinus` below, will no longer typecheck: + + ```hs + $(singletons [d| + data Nat = Z | S Nat + + natMinus :: Nat -> Nat -> Nat + natMinus Z _ = Z + natMinus (S a) (S b) = natMinus a b + natMinus a Z = a + |]) + ``` + + This can be worked around by avoiding the use of overlapping patterns. + In the case of `natMinus`, this amounts to changing the third equation + to match on its first argument: + + ```hs + $(singletons [d| + natMinus :: Nat -> Nat -> Nat + natMinus Z _ = Z + natMinus (S a) (S b) = natMinus a b + natMinus a@(S _) Z = a + |]) + ``` +* The specification for how `singletons` deals with record selectors has been + simplified. Previously, `singletons` would try to avoid promoting so-called + "naughty" selectors (those whose types mention existential type variables + that do not appear in the constructor's return type) to top-level functions. + Determing if a selector is naughty is quite challenging in practice, as + determining if a type variable is existential or not in the context of + Template Haskell is difficult in the general case. As a result, `singletons` + now adopts the dumb-but-predictable approach of always promoting record + selectors to top-level functions, naughty or not. + + This means that attempting to promote code with a naughty record selector, + like in the example below, will no longer work: + + ```hs + $(promote [d| + data Some :: (Type -> Type) -> Type where + MkSome :: { getSome :: f a } -> Some f + -- getSome is naughty due to mentioning the type variable `a` + |]) + ``` + + Please open an issue if you find this restriction burdensome in practice. +* The `singEqInstanceOnly` and `singEqInstancesOnly` functions, which generate + `SEq` (but not `PEq`) instances, have been removed. There is not much point + in keeping these functions around now that `PEq` now longer has a special + default implementation. Use `singEqInstance{s}` instead. +* The Template Haskell machinery will no longer promote `TypeRep` to `Type`, + as this special case never worked properly in the first place. +* The Template Haskell machinery will now preserve strict fields in data types + when generating their singled counterparts. +* Introduce a new `promotedDataTypeOrConName` option to + `Data.Singletons.TH.Options`. Overriding this option can be useful in + situations where one wishes to promote types such as `Nat`, `Symbol`, or + data types built on top of them. See the + "Arrows, `Nat`, `Symbol`, and literals" section of the `README` for more + information. +* Define a `Quote` instance for `OptionsM`. A notable benefit of this instance + is that it avoids the need to explicitly `lift` TH quotes into `OptionsM`. + Before, you would have to do this: + + ```hs + import Control.Monad.Trans.Class (lift) + + withOptions defaultOptions + $ singletons + $ lift [d| data T = MkT |] + ``` + + But now, it suffices to simply do this: + + ```hs + withOptions defaultOptions + $ singletons [d| data T = MkT |] + ``` diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,26 +1,26 @@ -`singletons-th` -=============== - -[![Hackage](https://img.shields.io/hackage/v/singletons-th.svg)](http://hackage.haskell.org/package/singletons-th) - -`singletons-th` defines Template Haskell functionality that allows -_promotion_ of term-level functions to type-level equivalents and -_singling_ functions to dependently typed equivalents. This library was -originally presented in -[_Dependently Typed Programming with Singletons_](https://richarde.dev/papers/2012/singletons/paper.pdf), -published at the Haskell Symposium, 2012. See also -[the paper published at Haskell Symposium, 2014](https://richarde.dev/papers/2014/promotion/promotion.pdf), -which describes how promotion works in greater detail. - -`singletons-th` generates code that relies on bleeding-edge GHC language -extensions. As such, `singletons-th` only supports the latest major version -of GHC (currently GHC 9.6). For more information, -consult the `singletons` -[`README`](https://github.com/goldfirere/singletons/blob/master/README.md). - -You may also be interested in the following related libraries: - -* The `singletons` library is a small, foundational library that defines - basic singleton-related types and definitions. -* The `singletons-base` library uses `singletons-th` to define promoted and - singled functions from the `base` library, including the `Prelude`. +`singletons-th` +=============== + +[![Hackage](https://img.shields.io/hackage/v/singletons-th.svg)](http://hackage.haskell.org/package/singletons-th) + +`singletons-th` defines Template Haskell functionality that allows +_promotion_ of term-level functions to type-level equivalents and +_singling_ functions to dependently typed equivalents. This library was +originally presented in +[_Dependently Typed Programming with Singletons_](https://richarde.dev/papers/2012/singletons/paper.pdf), +published at the Haskell Symposium, 2012. See also +[the paper published at Haskell Symposium, 2014](https://richarde.dev/papers/2014/promotion/promotion.pdf), +which describes how promotion works in greater detail. + +`singletons-th` generates code that relies on bleeding-edge GHC language +extensions. As such, `singletons-th` only supports the latest major version +of GHC (currently GHC 9.8). For more information, +consult the `singletons` +[`README`](https://github.com/goldfirere/singletons/blob/master/README.md). + +You may also be interested in the following related libraries: + +* The `singletons` library is a small, foundational library that defines + basic singleton-related types and definitions. +* The `singletons-base` library uses `singletons-th` to define promoted and + singled functions from the `base` library, including the `Prelude`. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain diff --git a/singletons-th.cabal b/singletons-th.cabal --- a/singletons-th.cabal +++ b/singletons-th.cabal @@ -1,104 +1,105 @@ -name: singletons-th -version: 3.2 -cabal-version: 1.24 -synopsis: A framework for generating singleton types -homepage: http://www.github.com/goldfirere/singletons -category: Dependent Types -author: Richard Eisenberg , Jan Stolarek -maintainer: Ryan Scott -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. - () - See also the paper published at Haskell Symposium, 2014, 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@ - @@. - . - You may also be interested in the following related libraries: - . - * The @singletons@ library is a small, foundational library that defines - basic singleton-related types and definitions. - . - * The @singletons-base@ library uses @singletons-th@ to define promoted and - singled functions from the @base@ library, including the "Prelude". - -source-repository this - type: git - location: https://github.com/goldfirere/singletons.git - subdir: singletons-th - tag: v3.1.2 - -source-repository head - type: git - location: https://github.com/goldfirere/singletons.git - subdir: singletons-th - branch: master - -library - hs-source-dirs: src - build-depends: base >= 4.18 && < 4.19, - containers >= 0.5, - mtl >= 2.2.1 && < 2.4, - ghc-boot-th, - singletons == 3.0.*, - syb >= 0.4, - template-haskell >= 2.20 && < 2.21, - th-desugar >= 1.15 && < 1.16, - th-orphans >= 0.13.11 && < 0.14, - transformers >= 0.5.2 - default-language: GHC2021 - other-extensions: TemplateHaskellQuotes - exposed-modules: Data.Singletons.TH - Data.Singletons.TH.CustomStar - Data.Singletons.TH.Options - Data.Singletons.TH.SuppressUnusedWarnings - - other-modules: Data.Singletons.TH.Deriving.Bounded - Data.Singletons.TH.Deriving.Enum - Data.Singletons.TH.Deriving.Eq - Data.Singletons.TH.Deriving.Foldable - Data.Singletons.TH.Deriving.Functor - Data.Singletons.TH.Deriving.Infer - Data.Singletons.TH.Deriving.Ord - Data.Singletons.TH.Deriving.Show - Data.Singletons.TH.Deriving.Traversable - Data.Singletons.TH.Deriving.Util - Data.Singletons.TH.Names - Data.Singletons.TH.Partition - Data.Singletons.TH.Promote - Data.Singletons.TH.Promote.Defun - Data.Singletons.TH.Promote.Monad - Data.Singletons.TH.Promote.Type - Data.Singletons.TH.Single - Data.Singletons.TH.Single.Data - Data.Singletons.TH.Single.Decide - Data.Singletons.TH.Single.Defun - Data.Singletons.TH.Single.Fixity - Data.Singletons.TH.Single.Monad - Data.Singletons.TH.Single.Type - Data.Singletons.TH.Syntax - Data.Singletons.TH.Util - - -- singletons re-exports - reexported-modules: Data.Singletons - , Data.Singletons.Decide - , Data.Singletons.ShowSing - , Data.Singletons.Sigma - - ghc-options: -Wall -Wcompat +name: singletons-th +version: 3.3 +cabal-version: 1.24 +synopsis: A framework for generating singleton types +homepage: http://www.github.com/goldfirere/singletons +category: Dependent Types +author: Richard Eisenberg , Jan Stolarek +maintainer: Ryan Scott +bug-reports: https://github.com/goldfirere/singletons/issues +stability: experimental +tested-with: GHC == 9.8.1 +extra-source-files: README.md, CHANGES.md +license: BSD3 +license-file: LICENSE +build-type: Simple +description: + @singletons-th@ defines Template Haskell functionality that allows + /promotion/ of term-level functions to type-level equivalents and + /singling/ functions to dependently typed equivalents. This library was + originally presented in /Dependently Typed Programming with Singletons/, + published at the Haskell Symposium, 2012. + () + See also the paper published at Haskell Symposium, 2014, which describes + how promotion works in greater detail: + . + . + @singletons-th@ generates code that relies on bleeding-edge GHC language + extensions. As such, @singletons-th@ only supports the latest major version + of GHC (currently GHC 9.8). For more information, + consult the @singletons@ + @@. + . + You may also be interested in the following related libraries: + . + * The @singletons@ library is a small, foundational library that defines + basic singleton-related types and definitions. + . + * The @singletons-base@ library uses @singletons-th@ to define promoted and + singled functions from the @base@ library, including the "Prelude". + +source-repository this + type: git + location: https://github.com/goldfirere/singletons.git + subdir: singletons-th + tag: v3.1.2 + +source-repository head + type: git + location: https://github.com/goldfirere/singletons.git + subdir: singletons-th + branch: master + +library + hs-source-dirs: src + build-depends: base >= 4.19 && < 4.20, + containers >= 0.5, + mtl >= 2.2.1 && < 2.4, + ghc-boot-th, + singletons == 3.0.*, + syb >= 0.4, + template-haskell >= 2.21 && < 2.22, + th-desugar >= 1.16 && < 1.17, + th-orphans >= 0.13.11 && < 0.14, + transformers >= 0.5.2 + default-language: GHC2021 + other-extensions: TemplateHaskellQuotes + exposed-modules: Data.Singletons.TH + Data.Singletons.TH.CustomStar + Data.Singletons.TH.Options + Data.Singletons.TH.SuppressUnusedWarnings + + other-modules: Data.Singletons.TH.Deriving.Bounded + Data.Singletons.TH.Deriving.Enum + Data.Singletons.TH.Deriving.Eq + Data.Singletons.TH.Deriving.Foldable + Data.Singletons.TH.Deriving.Functor + Data.Singletons.TH.Deriving.Infer + Data.Singletons.TH.Deriving.Ord + Data.Singletons.TH.Deriving.Show + Data.Singletons.TH.Deriving.Traversable + Data.Singletons.TH.Deriving.Util + Data.Singletons.TH.Names + Data.Singletons.TH.Partition + Data.Singletons.TH.Promote + Data.Singletons.TH.Promote.Defun + Data.Singletons.TH.Promote.Monad + Data.Singletons.TH.Promote.Type + Data.Singletons.TH.Single + Data.Singletons.TH.Single.Data + Data.Singletons.TH.Single.Decide + Data.Singletons.TH.Single.Defun + Data.Singletons.TH.Single.Fixity + Data.Singletons.TH.Single.Monad + Data.Singletons.TH.Single.Ord + Data.Singletons.TH.Single.Type + Data.Singletons.TH.Syntax + Data.Singletons.TH.Util + + -- singletons re-exports + reexported-modules: Data.Singletons + , Data.Singletons.Decide + , Data.Singletons.ShowSing + , Data.Singletons.Sigma + + ghc-options: -Wall -Wcompat diff --git a/src/Data/Singletons/TH.hs b/src/Data/Singletons/TH.hs --- a/src/Data/Singletons/TH.hs +++ b/src/Data/Singletons/TH.hs @@ -1,173 +1,173 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TH --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- This module contains basic functionality for deriving your own singletons --- via Template Haskell. Note that this module does not define any singled --- definitions on its own. For a version of this module that comes pre-equipped --- with several singled definitions based on the "Prelude", see --- @Data.Singletons.Base.TH@ from the @singletons-base@ library. --- ----------------------------------------------------------------------------- - -module Data.Singletons.TH ( - -- * Primary Template Haskell generation functions - singletons, singletonsOnly, genSingletons, - promote, promoteOnly, genDefunSymbols, genPromotions, - - -- ** Functions to generate equality instances - promoteEqInstances, promoteEqInstance, - singEqInstances, singEqInstance, - singDecideInstances, singDecideInstance, - - -- ** Functions to generate 'Ord' instances - promoteOrdInstances, promoteOrdInstance, - singOrdInstances, singOrdInstance, - - -- ** Functions to generate 'Bounded' instances - promoteBoundedInstances, promoteBoundedInstance, - singBoundedInstances, singBoundedInstance, - - -- ** Functions to generate 'Enum' instances - promoteEnumInstances, promoteEnumInstance, - singEnumInstances, singEnumInstance, - - -- ** Functions to generate 'Show' instances - promoteShowInstances, promoteShowInstance, - singShowInstances, singShowInstance, - showSingInstances, showSingInstance, - - -- ** Utility functions - singITyConInstances, singITyConInstance, - cases, sCases, - - -- * Basic singleton definitions - module Data.Singletons, - - -- * Auxiliary definitions - SDecide(..), (:~:)(..), Void, Refuted, Decision(..), - - SuppressUnusedWarnings(..) - - ) where - -import Control.Arrow ( first ) -import Data.Singletons -import Data.Singletons.Decide -import Data.Singletons.TH.Options -import Data.Singletons.TH.Promote -import Data.Singletons.TH.Single -import Data.Singletons.TH.SuppressUnusedWarnings -import Data.Singletons.TH.Util -import Language.Haskell.TH -import Language.Haskell.TH.Desugar - --- | The function 'cases' generates a case expression where each right-hand side --- is identical. This may be useful if the type-checker requires knowledge of which --- constructor is used to satisfy equality or type-class constraints, but where --- each constructor is treated the same. --- --- Here is a simple example to illustrate where 'cases' can be useful. Suppose --- you use @singletons-th@ to single this code: --- --- @ --- $('singletons' [d| --- foo :: Bool -> () --- foo True = () --- foo False = () --- |]) --- @ --- --- And that you want to write a function of this type: --- --- @ --- bar :: SBool b -> STuple0 (Foo b) --- @ --- --- How would you do this? You might be tempted to write the following: --- --- @ --- bar _ = STuple0 --- @ --- --- However, this won't typecheck, as Foo b won't reduce to @'()@ unless GHC --- knows @b@ is either 'True' or 'False'. In order to convince GHC of this, you --- must explicitly match on each of the data constructors of @SBool@: --- --- @ --- bar :: SBool b -> STuple0 (Foo b) --- bar b = case b of --- STrue -> STuple0 --- SFalse -> STuple0 --- @ --- --- This is doable, but it is somewhat tedious. After all, the right-hand side --- of each case alternative is exactly the same! This only becomes more tedious --- when you deal with data types with lots of lots of data constructors. For --- this reason, @singletons-th@ offers the 'cases' function to generate this --- boilerplate code for you. The following is equivalent to the implementation --- of @bar@ above: --- --- @ --- bar :: SBool b -> STuple0 (Foo b) --- bar b = $(cases ''SBool [| b |] [| STuple0 |]) --- @ -cases :: DsMonad q - => Name -- ^ The head of the type of the scrutinee. (e.g., @''SBool@) - -> q Exp -- ^ The scrutinee, in a Template Haskell quote - -> q Exp -- ^ The body, in a Template Haskell quote - -> q Exp -cases tyName expq bodyq = do - dinfo <- dsReify tyName - case dinfo of - Just (DTyConI (DDataD _ _ _ _ _ ctors _) _) -> - expToTH <$> buildCases (map extractNameArgs ctors) expq bodyq - Just _ -> - fail $ "Using <> 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 <> 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 <> 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 <> with something other than a type constructor: " + ++ (show tyName) + _ -> fail $ "Cannot find " ++ show tyName + +buildCases :: DsMonad m + => [(Name, Int)] + -> m Exp -- scrutinee + -> m Exp -- body + -> m DExp +buildCases ctor_infos expq bodyq = + DCaseE <$> (dsExp =<< expq) <*> + mapM (\con -> DMatch (conToPat con) <$> (dsExp =<< bodyq)) ctor_infos + where + conToPat :: (Name, Int) -> DPat + conToPat (name, num_fields) = + DConP name [] (replicate num_fields DWildP) diff --git a/src/Data/Singletons/TH/CustomStar.hs b/src/Data/Singletons/TH/CustomStar.hs --- a/src/Data/Singletons/TH/CustomStar.hs +++ b/src/Data/Singletons/TH/CustomStar.hs @@ -1,158 +1,158 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TH.CustomStar --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- This file implements 'singletonStar', which generates a datatype @Rep@ and associated --- singleton from a list of types. The promoted version of @Rep@ is kind @*@ and the --- Haskell types themselves. This is still very experimental, so expect unusual --- results! --- --- See also @Data.Singletons.Base.CustomStar@ from @singletons-base@, a --- variant of this module that also re-exports related definitions from --- @Prelude.Singletons@. --- ----------------------------------------------------------------------------- - -module Data.Singletons.TH.CustomStar ( - singletonStar, - - module Data.Singletons.TH - ) where - -import Language.Haskell.TH -import Data.Singletons.TH -import Data.Singletons.TH.Deriving.Eq -import Data.Singletons.TH.Deriving.Infer -import Data.Singletons.TH.Deriving.Ord -import Data.Singletons.TH.Deriving.Show -import Data.Singletons.TH.Promote -import Data.Singletons.TH.Promote.Monad -import Data.Singletons.TH.Names -import Data.Singletons.TH.Options -import Data.Singletons.TH.Single -import Data.Singletons.TH.Single.Data -import Data.Singletons.TH.Single.Monad -import Data.Singletons.TH.Syntax -import Data.Singletons.TH.Util -import Control.Monad -import Data.Maybe -import Language.Haskell.TH.Desugar - --- | Produce a representation and singleton for the collection of types given. --- --- A datatype @Rep@ is created, with one constructor per type in the declared --- universe. When this type is promoted by the @singletons-th@ library, the --- constructors become full types in @*@, not just promoted data constructors. --- --- For example, --- --- > $(singletonStar [''Nat, ''Bool, ''Maybe]) --- --- generates the following: --- --- > data Rep = Nat | Bool | Maybe Rep deriving (Eq, Ord, Read, Show) --- --- and its singleton. However, because @Rep@ is promoted to @*@, the singleton --- is perhaps slightly unexpected: --- --- > data SRep (a :: *) where --- > SNat :: Sing Nat --- > SBool :: Sing Bool --- > SMaybe :: Sing a -> Sing (Maybe a) --- > type instance Sing = SRep --- --- The unexpected part is that @Nat@, @Bool@, and @Maybe@ above are the real @Nat@, --- @Bool@, and @Maybe@, not just promoted data constructors. --- --- Please note that this function is /very/ experimental. Use at your own risk. -singletonStar :: OptionsMonad q - => [Name] -- ^ A list of Template Haskell @Name@s for types - -> q [Dec] -singletonStar names = do - kinds <- mapM getKind names - ctors <- zipWithM (mkCtor True) names kinds - let repDecl = DDataD Data [] repName [] (Just (DConT typeKindName)) ctors - [DDerivClause Nothing (map DConT [''Eq, ''Ord, ''Read, ''Show])] - fakeCtors <- zipWithM (mkCtor False) names kinds - let dataDecl = DataDecl Data repName [] fakeCtors - -- Why do we need withLocalDeclarations here? It's because we end up - -- expanding type synonyms when deriving instances for Rep, which requires - -- reifying Rep itself. Since Rep hasn't been spliced in yet, we must put it - -- into the local declarations. - withLocalDeclarations [decToTH repDecl] $ do - -- We opt to infer the constraints for the Eq instance here so that when it's - -- promoted, Rep will be promoted to Type. - dataDeclEqCxt <- inferConstraints (DConT ''Eq) (DConT repName) fakeCtors - let dataDeclEqInst = DerivedDecl (Just dataDeclEqCxt) (DConT repName) repName dataDecl - eqInst <- mkEqInstance Nothing (DConT repName) dataDecl - ordInst <- mkOrdInstance Nothing (DConT repName) dataDecl - showInst <- mkShowInstance Nothing (DConT repName) dataDecl - (pInsts, promDecls) <- promoteM [] $ do _ <- promoteDataDec dataDecl - traverse (promoteInstanceDec mempty mempty) - [eqInst, ordInst, showInst] - singletonDecls <- singDecsM [] $ do decs1 <- singDataD dataDecl - decs2 <- singDerivedEqDecs dataDeclEqInst - decs3 <- traverse singInstD pInsts - return (decs1 ++ decs2 ++ decs3) - return $ decsToTH $ repDecl : - promDecls ++ - singletonDecls - where -- get the kinds of the arguments to the tycon with the given name - getKind :: DsMonad q => Name -> q [DKind] - getKind name = do - info <- reifyWithLocals name - dinfo <- dsInfo info - case dinfo of - DTyConI (DDataD _ (_:_) _ _ _ _ _) _ -> - fail "Cannot make a representation of a constrained data type" - DTyConI (DDataD _ [] _ tvbs mk _ _) _ -> do - all_tvbs <- buildDataDTvbs tvbs mk - return $ map (fromMaybe (DConT typeKindName) . extractTvbKind) all_tvbs - DTyConI (DTySynD _ tvbs _) _ -> - return $ map (fromMaybe (DConT typeKindName) . extractTvbKind) tvbs - DPrimTyConI _ n _ -> - return $ replicate n $ DConT typeKindName - _ -> fail $ "Invalid thing for representation: " ++ (show name) - - -- first parameter is whether this is a real ctor (with a fresh name) - -- or a fake ctor (when the name is actually a Haskell type) - mkCtor :: DsMonad q => Bool -> Name -> [DKind] -> q DCon - mkCtor real name args = do - (types, vars) <- evalForPair $ mapM (kindToType []) args - dataName <- if real then mkDataName (nameBase name) else return name - return $ DCon (map (`DPlainTV` SpecifiedSpec) vars) [] dataName - (DNormalC False (map (\ty -> (noBang, ty)) types)) - (DConT repName) - where - noBang = Bang NoSourceUnpackedness NoSourceStrictness - - -- demote a kind back to a type, accumulating any unbound parameters - kindToType :: DsMonad q => [DTypeArg] -> DKind -> QWithAux [Name] q DType - kindToType _ (DForallT _ _) = fail "Explicit forall encountered in kind" - kindToType _ (DConstrainedT _ _) = fail "Explicit constraint encountered in kind" - kindToType args (DAppT f a) = do - a' <- kindToType [] a - kindToType (DTANormal a' : args) f - kindToType args (DAppKindT f a) = do - a' <- kindToType [] a - kindToType (DTyArg a' : args) f - kindToType args (DSigT t k) = do - t' <- kindToType [] t - k' <- kindToType [] k - return $ DSigT t' k' `applyDType` args - kindToType args (DVarT n) = do - addElement n - return $ DVarT n `applyDType` args - kindToType args (DConT n) = return $ DConT name `applyDType` args - where name | isTypeKindName n = repName - | otherwise = n - kindToType args DArrowT = return $ DArrowT `applyDType` args - kindToType args k@(DLitT {}) = return $ k `applyDType` args - kindToType args DWildCardT = return $ DWildCardT `applyDType` args +{-# LANGUAGE TemplateHaskellQuotes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Singletons.TH.CustomStar +-- Copyright : (C) 2013 Richard Eisenberg +-- License : BSD-style (see LICENSE) +-- Maintainer : Ryan Scott +-- Stability : experimental +-- Portability : non-portable +-- +-- This file implements 'singletonStar', which generates a datatype @Rep@ and associated +-- singleton from a list of types. The promoted version of @Rep@ is kind @*@ and the +-- Haskell types themselves. This is still very experimental, so expect unusual +-- results! +-- +-- See also @Data.Singletons.Base.CustomStar@ from @singletons-base@, a +-- variant of this module that also re-exports related definitions from +-- @Prelude.Singletons@. +-- +---------------------------------------------------------------------------- + +module Data.Singletons.TH.CustomStar ( + singletonStar, + + module Data.Singletons.TH + ) where + +import Language.Haskell.TH +import Data.Singletons.TH +import Data.Singletons.TH.Deriving.Eq +import Data.Singletons.TH.Deriving.Infer +import Data.Singletons.TH.Deriving.Ord +import Data.Singletons.TH.Deriving.Show +import Data.Singletons.TH.Promote +import Data.Singletons.TH.Promote.Monad +import Data.Singletons.TH.Names +import Data.Singletons.TH.Options +import Data.Singletons.TH.Single +import Data.Singletons.TH.Single.Data +import Data.Singletons.TH.Single.Monad +import Data.Singletons.TH.Syntax +import Data.Singletons.TH.Util +import Control.Monad +import Data.Maybe +import Language.Haskell.TH.Desugar + +-- | Produce a representation and singleton for the collection of types given. +-- +-- A datatype @Rep@ is created, with one constructor per type in the declared +-- universe. When this type is promoted by the @singletons-th@ library, the +-- constructors become full types in @*@, not just promoted data constructors. +-- +-- For example, +-- +-- > $(singletonStar [''Nat, ''Bool, ''Maybe]) +-- +-- generates the following: +-- +-- > data Rep = Nat | Bool | Maybe Rep deriving (Eq, Ord, Read, Show) +-- +-- and its singleton. However, because @Rep@ is promoted to @*@, the singleton +-- is perhaps slightly unexpected: +-- +-- > data SRep (a :: *) where +-- > SNat :: Sing Nat +-- > SBool :: Sing Bool +-- > SMaybe :: Sing a -> Sing (Maybe a) +-- > type instance Sing = SRep +-- +-- The unexpected part is that @Nat@, @Bool@, and @Maybe@ above are the real @Nat@, +-- @Bool@, and @Maybe@, not just promoted data constructors. +-- +-- Please note that this function is /very/ experimental. Use at your own risk. +singletonStar :: OptionsMonad q + => [Name] -- ^ A list of Template Haskell @Name@s for types + -> q [Dec] +singletonStar names = do + kinds <- mapM getKind names + ctors <- zipWithM (mkCtor True) names kinds + let repDecl = DDataD Data [] repName [] (Just (DConT typeKindName)) ctors + [DDerivClause Nothing (map DConT [''Eq, ''Ord, ''Read, ''Show])] + fakeCtors <- zipWithM (mkCtor False) names kinds + let dataDecl = DataDecl Data repName [] fakeCtors + -- Why do we need withLocalDeclarations here? It's because we end up + -- expanding type synonyms when deriving instances for Rep, which requires + -- reifying Rep itself. Since Rep hasn't been spliced in yet, we must put it + -- into the local declarations. + withLocalDeclarations [decToTH repDecl] $ do + -- We opt to infer the constraints for the Eq instance here so that when it's + -- promoted, Rep will be promoted to Type. + dataDeclEqCxt <- inferConstraints (DConT ''Eq) (DConT repName) fakeCtors + let dataDeclEqInst = DerivedDecl (Just dataDeclEqCxt) (DConT repName) repName dataDecl + eqInst <- mkEqInstance Nothing (DConT repName) dataDecl + ordInst <- mkOrdInstance Nothing (DConT repName) dataDecl + showInst <- mkShowInstance Nothing (DConT repName) dataDecl + (pInsts, promDecls) <- promoteM [] $ do _ <- promoteDataDec dataDecl + traverse (promoteInstanceDec mempty mempty) + [eqInst, ordInst, showInst] + singletonDecls <- singDecsM [] $ do decs1 <- singDataD dataDecl + decs2 <- singDerivedEqDecs dataDeclEqInst + decs3 <- traverse singInstD pInsts + return (decs1 ++ decs2 ++ decs3) + return $ decsToTH $ repDecl : + promDecls ++ + singletonDecls + where -- get the kinds of the arguments to the tycon with the given name + getKind :: DsMonad q => Name -> q [DKind] + getKind name = do + info <- reifyWithLocals name + dinfo <- dsInfo info + case dinfo of + DTyConI (DDataD _ (_:_) _ _ _ _ _) _ -> + fail "Cannot make a representation of a constrained data type" + DTyConI (DDataD _ [] _ tvbs mk _ _) _ -> do + all_tvbs <- buildDataDTvbs tvbs mk + return $ map (fromMaybe (DConT typeKindName) . extractTvbKind) all_tvbs + DTyConI (DTySynD _ tvbs _) _ -> + return $ map (fromMaybe (DConT typeKindName) . extractTvbKind) tvbs + DPrimTyConI _ n _ -> + return $ replicate n $ DConT typeKindName + _ -> fail $ "Invalid thing for representation: " ++ (show name) + + -- first parameter is whether this is a real ctor (with a fresh name) + -- or a fake ctor (when the name is actually a Haskell type) + mkCtor :: DsMonad q => Bool -> Name -> [DKind] -> q DCon + mkCtor real name args = do + (types, vars) <- evalForPair $ mapM (kindToType []) args + dataName <- if real then mkDataName (nameBase name) else return name + return $ DCon (map (`DPlainTV` SpecifiedSpec) vars) [] dataName + (DNormalC False (map (\ty -> (noBang, ty)) types)) + (DConT repName) + where + noBang = Bang NoSourceUnpackedness NoSourceStrictness + + -- demote a kind back to a type, accumulating any unbound parameters + kindToType :: DsMonad q => [DTypeArg] -> DKind -> QWithAux [Name] q DType + kindToType _ (DForallT _ _) = fail "Explicit forall encountered in kind" + kindToType _ (DConstrainedT _ _) = fail "Explicit constraint encountered in kind" + kindToType args (DAppT f a) = do + a' <- kindToType [] a + kindToType (DTANormal a' : args) f + kindToType args (DAppKindT f a) = do + a' <- kindToType [] a + kindToType (DTyArg a' : args) f + kindToType args (DSigT t k) = do + t' <- kindToType [] t + k' <- kindToType [] k + return $ DSigT t' k' `applyDType` args + kindToType args (DVarT n) = do + addElement n + return $ DVarT n `applyDType` args + kindToType args (DConT n) = return $ DConT name `applyDType` args + where name | isTypeKindName n = repName + | otherwise = n + kindToType args DArrowT = return $ DArrowT `applyDType` args + kindToType args k@(DLitT {}) = return $ k `applyDType` args + kindToType args DWildCardT = return $ DWildCardT `applyDType` args diff --git a/src/Data/Singletons/TH/Deriving/Bounded.hs b/src/Data/Singletons/TH/Deriving/Bounded.hs --- a/src/Data/Singletons/TH/Deriving/Bounded.hs +++ b/src/Data/Singletons/TH/Deriving/Bounded.hs @@ -1,59 +1,67 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TH.Deriving.Bounded --- Copyright : (C) 2015 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Implements deriving of Bounded instances --- ----------------------------------------------------------------------------- - -module Data.Singletons.TH.Deriving.Bounded where - -import Language.Haskell.TH.Ppr -import Language.Haskell.TH.Desugar -import Data.Singletons.TH.Deriving.Infer -import Data.Singletons.TH.Deriving.Util -import Data.Singletons.TH.Names -import Data.Singletons.TH.Syntax -import Data.Singletons.TH.Util -import Control.Monad - --- monadic only for failure and parallelism with other functions --- that make instances -mkBoundedInstance :: DsMonad q => DerivDesc q -mkBoundedInstance mb_ctxt ty (DataDecl _ _ _ cons) = do - -- We can derive instance of Bounded if datatype is an enumeration (all - -- constructors must be nullary) or has only one constructor. See Section 11 - -- of Haskell 2010 Language Report. - -- Note that order of conditions below is important. - when (null cons - || (any (\(DCon _ _ _ f _) -> not . null . tysOfConFields $ f) cons - && (not . null . tail $ cons))) $ - fail ("Can't derive Bounded instance for " - ++ pprint (typeToTH ty) ++ ".") - -- at this point we know that either we have a datatype that has only one - -- constructor or a datatype where each constructor is nullary - let (DCon _ _ minName fields _) = head cons - (DCon _ _ maxName _ _) = last cons - fieldsCount = length $ tysOfConFields fields - (minRHS, maxRHS) = case fieldsCount of - 0 -> (DConE minName, DConE maxName) - _ -> - let minEqnRHS = foldExp (DConE minName) - (replicate fieldsCount (DVarE minBoundName)) - maxEqnRHS = foldExp (DConE maxName) - (replicate fieldsCount (DVarE maxBoundName)) - in (minEqnRHS, maxEqnRHS) - - mk_rhs rhs = UFunction [DClause [] rhs] - constraints <- inferConstraintsDef mb_ctxt (DConT boundedName) ty cons - return $ InstDecl { id_cxt = constraints - , id_name = boundedName - , id_arg_tys = [ty] - , id_sigs = mempty - , id_meths = [ (minBoundName, mk_rhs minRHS) - , (maxBoundName, mk_rhs maxRHS) ] } +----------------------------------------------------------------------------- +-- | +-- Module : Data.Singletons.TH.Deriving.Bounded +-- Copyright : (C) 2015 Richard Eisenberg +-- License : BSD-style (see LICENSE) +-- Maintainer : Ryan Scott +-- Stability : experimental +-- Portability : non-portable +-- +-- Implements deriving of Bounded instances +-- +---------------------------------------------------------------------------- + +module Data.Singletons.TH.Deriving.Bounded where + +import Language.Haskell.TH.Ppr +import Language.Haskell.TH.Desugar +import Data.Singletons.TH.Deriving.Infer +import Data.Singletons.TH.Deriving.Util +import Data.Singletons.TH.Names +import Data.Singletons.TH.Syntax +import Data.Singletons.TH.Util +import Control.Monad + +-- monadic only for failure and parallelism with other functions +-- that make instances +mkBoundedInstance :: DsMonad q => DerivDesc q +mkBoundedInstance mb_ctxt ty (DataDecl _ _ _ cons) = do + -- We can derive instance of Bounded if datatype is an enumeration (all + -- constructors must be nullary) or has only one constructor. See Section 11 + -- of Haskell 2010 Language Report. + -- Note that order of conditions below is important. + let illegal_bounded_inst = + case cons of + [] -> True + _:cons' -> + any (\(DCon _ _ _ f _) -> not . null . tysOfConFields $ f) cons + && not (null cons') + when illegal_bounded_inst $ + fail ("Can't derive Bounded instance for " + ++ pprint (typeToTH ty) ++ ".") + -- at this point we know that either we have a datatype that has only one + -- constructor or a datatype where each constructor is nullary + let internal_err = fail "Internal error (mkBoundedInstance): non-empty list of constructors" + DCon _ _ minName fields _ <- + case cons of + (c:_) -> pure c + [] -> internal_err + let (_, DCon _ _ maxName _ _) = snocView cons + fieldsCount = length $ tysOfConFields fields + (minRHS, maxRHS) = case fieldsCount of + 0 -> (DConE minName, DConE maxName) + _ -> + let minEqnRHS = foldExp (DConE minName) + (replicate fieldsCount (DVarE minBoundName)) + maxEqnRHS = foldExp (DConE maxName) + (replicate fieldsCount (DVarE maxBoundName)) + in (minEqnRHS, maxEqnRHS) + + mk_rhs rhs = UFunction [DClause [] rhs] + constraints <- inferConstraintsDef mb_ctxt (DConT boundedName) ty cons + return $ InstDecl { id_cxt = constraints + , id_name = boundedName + , id_arg_tys = [ty] + , id_sigs = mempty + , id_meths = [ (minBoundName, mk_rhs minRHS) + , (maxBoundName, mk_rhs maxRHS) ] } diff --git a/src/Data/Singletons/TH/Deriving/Enum.hs b/src/Data/Singletons/TH/Deriving/Enum.hs --- a/src/Data/Singletons/TH/Deriving/Enum.hs +++ b/src/Data/Singletons/TH/Deriving/Enum.hs @@ -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) ] }) diff --git a/src/Data/Singletons/TH/Deriving/Eq.hs b/src/Data/Singletons/TH/Deriving/Eq.hs --- a/src/Data/Singletons/TH/Deriving/Eq.hs +++ b/src/Data/Singletons/TH/Deriving/Eq.hs @@ -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 diff --git a/src/Data/Singletons/TH/Deriving/Foldable.hs b/src/Data/Singletons/TH/Deriving/Foldable.hs --- a/src/Data/Singletons/TH/Deriving/Foldable.hs +++ b/src/Data/Singletons/TH/Deriving/Foldable.hs @@ -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 } diff --git a/src/Data/Singletons/TH/Deriving/Functor.hs b/src/Data/Singletons/TH/Deriving/Functor.hs --- a/src/Data/Singletons/TH/Deriving/Functor.hs +++ b/src/Data/Singletons/TH/Deriving/Functor.hs @@ -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 } diff --git a/src/Data/Singletons/TH/Deriving/Infer.hs b/src/Data/Singletons/TH/Deriving/Infer.hs --- a/src/Data/Singletons/TH/Deriving/Infer.hs +++ b/src/Data/Singletons/TH/Deriving/Infer.hs @@ -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 diff --git a/src/Data/Singletons/TH/Deriving/Ord.hs b/src/Data/Singletons/TH/Deriving/Ord.hs --- a/src/Data/Singletons/TH/Deriving/Ord.hs +++ b/src/Data/Singletons/TH/Deriving/Ord.hs @@ -1,71 +1,71 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TH.Deriving.Ord --- Copyright : (C) 2015 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Implements deriving of Ord instances --- ----------------------------------------------------------------------------- - -module Data.Singletons.TH.Deriving.Ord ( mkOrdInstance ) where - -import Language.Haskell.TH.Desugar -import Language.Haskell.TH.Syntax -import Data.Singletons.TH.Deriving.Infer -import Data.Singletons.TH.Deriving.Util -import Data.Singletons.TH.Names -import Data.Singletons.TH.Syntax -import Data.Singletons.TH.Util - --- | Make a *non-singleton* Ord instance -mkOrdInstance :: DsMonad q => DerivDesc q -mkOrdInstance mb_ctxt ty (DataDecl _ _ _ cons) = do - constraints <- inferConstraintsDef mb_ctxt (DConT ordName) ty cons - compare_eq_clauses <- mapM mk_equal_clause cons - let compare_noneq_clauses = map (uncurry mk_nonequal_clause) - [ (con1, con2) - | con1 <- zip cons [1..] - , con2 <- zip cons [1..] - , extractName (fst con1) /= - extractName (fst con2) ] - clauses | null cons = [mk_empty_clause] - | otherwise = compare_eq_clauses ++ compare_noneq_clauses - return (InstDecl { id_cxt = constraints - , id_name = ordName - , id_arg_tys = [ty] - , id_sigs = mempty - , id_meths = [(compareName, UFunction clauses)] }) - -mk_equal_clause :: Quasi q => DCon -> q DClause -mk_equal_clause (DCon _tvbs _cxt name fields _rty) = do - let tys = tysOfConFields fields - a_names <- mapM (const $ newUniqueName "a") tys - b_names <- mapM (const $ newUniqueName "b") tys - let pat1 = DConP name [] (map DVarP a_names) - pat2 = DConP name [] (map DVarP b_names) - return $ DClause [pat1, pat2] (DVarE foldlName `DAppE` - DVarE sappendName `DAppE` - DConE cmpEQName `DAppE` - mkListE (zipWith - (\a b -> DVarE compareName `DAppE` DVarE a - `DAppE` DVarE b) - a_names b_names)) - -mk_nonequal_clause :: (DCon, Int) -> (DCon, Int) -> DClause -mk_nonequal_clause (DCon _tvbs1 _cxt1 name1 fields1 _rty1, n1) - (DCon _tvbs2 _cxt2 name2 fields2 _rty2, n2) = - DClause [pat1, pat2] (case n1 `compare` n2 of - LT -> DConE cmpLTName - EQ -> DConE cmpEQName - GT -> DConE cmpGTName) - where - pat1 = DConP name1 [] (map (const DWildP) (tysOfConFields fields1)) - pat2 = DConP name2 [] (map (const DWildP) (tysOfConFields fields2)) - --- A variant of mk_equal_clause tailored to empty datatypes -mk_empty_clause :: DClause -mk_empty_clause = DClause [DWildP, DWildP] (DConE cmpEQName) +----------------------------------------------------------------------------- +-- | +-- Module : Data.Singletons.TH.Deriving.Ord +-- Copyright : (C) 2015 Richard Eisenberg +-- License : BSD-style (see LICENSE) +-- Maintainer : Ryan Scott +-- Stability : experimental +-- Portability : non-portable +-- +-- Implements deriving of Ord instances +-- +---------------------------------------------------------------------------- + +module Data.Singletons.TH.Deriving.Ord ( mkOrdInstance ) where + +import Language.Haskell.TH.Desugar +import Language.Haskell.TH.Syntax +import Data.Singletons.TH.Deriving.Infer +import Data.Singletons.TH.Deriving.Util +import Data.Singletons.TH.Names +import Data.Singletons.TH.Syntax +import Data.Singletons.TH.Util + +-- | Make a *non-singleton* Ord instance +mkOrdInstance :: DsMonad q => DerivDesc q +mkOrdInstance mb_ctxt ty (DataDecl _ _ _ cons) = do + constraints <- inferConstraintsDef mb_ctxt (DConT ordName) ty cons + compare_eq_clauses <- mapM mk_equal_clause cons + let compare_noneq_clauses = map (uncurry mk_nonequal_clause) + [ (con1, con2) + | con1 <- zip cons [1..] + , con2 <- zip cons [1..] + , extractName (fst con1) /= + extractName (fst con2) ] + clauses | null cons = [mk_empty_clause] + | otherwise = compare_eq_clauses ++ compare_noneq_clauses + return (InstDecl { id_cxt = constraints + , id_name = ordName + , id_arg_tys = [ty] + , id_sigs = mempty + , id_meths = [(compareName, UFunction clauses)] }) + +mk_equal_clause :: Quasi q => DCon -> q DClause +mk_equal_clause (DCon _tvbs _cxt name fields _rty) = do + let tys = tysOfConFields fields + a_names <- mapM (const $ newUniqueName "a") tys + b_names <- mapM (const $ newUniqueName "b") tys + let pat1 = DConP name [] (map DVarP a_names) + pat2 = DConP name [] (map DVarP b_names) + return $ DClause [pat1, pat2] (DVarE foldlName `DAppE` + DVarE sappendName `DAppE` + DConE cmpEQName `DAppE` + mkListE (zipWith + (\a b -> DVarE compareName `DAppE` DVarE a + `DAppE` DVarE b) + a_names b_names)) + +mk_nonequal_clause :: (DCon, Int) -> (DCon, Int) -> DClause +mk_nonequal_clause (DCon _tvbs1 _cxt1 name1 fields1 _rty1, n1) + (DCon _tvbs2 _cxt2 name2 fields2 _rty2, n2) = + DClause [pat1, pat2] (case n1 `compare` n2 of + LT -> DConE cmpLTName + EQ -> DConE cmpEQName + GT -> DConE cmpGTName) + where + pat1 = DConP name1 [] (map (const DWildP) (tysOfConFields fields1)) + pat2 = DConP name2 [] (map (const DWildP) (tysOfConFields fields2)) + +-- A variant of mk_equal_clause tailored to empty datatypes +mk_empty_clause :: DClause +mk_empty_clause = DClause [DWildP, DWildP] (DConE cmpEQName) diff --git a/src/Data/Singletons/TH/Deriving/Show.hs b/src/Data/Singletons/TH/Deriving/Show.hs --- a/src/Data/Singletons/TH/Deriving/Show.hs +++ b/src/Data/Singletons/TH/Deriving/Show.hs @@ -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 diff --git a/src/Data/Singletons/TH/Deriving/Traversable.hs b/src/Data/Singletons/TH/Deriving/Traversable.hs --- a/src/Data/Singletons/TH/Deriving/Traversable.hs +++ b/src/Data/Singletons/TH/Deriving/Traversable.hs @@ -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) ] } diff --git a/src/Data/Singletons/TH/Deriving/Util.hs b/src/Data/Singletons/TH/Deriving/Util.hs --- a/src/Data/Singletons/TH/Deriving/Util.hs +++ b/src/Data/Singletons/TH/Deriving/Util.hs @@ -1,299 +1,299 @@ -{-# LANGUAGE MultiWayIf #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TH.Deriving.Util --- Copyright : (C) 2018 Ryan Scott --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Utilities used by the `deriving` machinery in singletons-th. --- ----------------------------------------------------------------------------- -module Data.Singletons.TH.Deriving.Util where - -import Control.Monad -import Data.Singletons.TH.Names -import Data.Singletons.TH.Syntax -import Data.Singletons.TH.Util -import Language.Haskell.TH.Desugar -import qualified Language.Haskell.TH.Desugar.OSet as OSet -import Language.Haskell.TH.Syntax - --- A generic type signature for describing how to produce a derived instance. -type DerivDesc q - = Maybe DCxt -- (Just ctx) if ctx was provided via StandaloneDeriving. - -- Nothing if using a deriving clause. - -> DType -- The data type argument to the class. - -> DataDecl -- The original data type information. - -> q UInstDecl -- The derived instance. - ------ --- Utilities for deriving Functor-like classes. --- Much of this was cargo-culted from the GHC source code. ------ - -data FFoldType a -- Describes how to fold over a DType in a functor like way - = FT { ft_triv :: a - -- ^ Does not contain variable - , ft_var :: a - -- ^ The variable itself - , ft_ty_app :: DType -> a -> a - -- ^ Type app, variable only in last argument - , ft_bad_app :: a - -- ^ Type app, variable other than in last argument - , ft_forall :: [DTyVarBndrSpec] -> a -> a - -- ^ Forall type - } - --- Note that in GHC, this function is pure. It must be monadic here since we: --- --- (1) Expand type synonyms --- (2) Detect type family applications --- --- Which require reification in Template Haskell, but are pure in Core. -functorLikeTraverse :: forall q a. - DsMonad q - => Name -- ^ Variable to look for - -> FFoldType a -- ^ How to fold - -> DType -- ^ Type to process - -> q a -functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar - , ft_ty_app = caseTyApp, ft_bad_app = caseWrongArg - , ft_forall = caseForAll }) - ty - = do ty' <- expandType ty - (res, _) <- go ty' - pure res - where - go :: DType - -> q (a, Bool) -- (result of type a, does type contain var) - go t@DAppT{} = do - let (f, args) = unfoldDType t - vis_args = filterDTANormals args - (_, fc) <- go f - (xrs, xcs) <- mapAndUnzipM go vis_args - let wrongArg :: q (a, Bool) - wrongArg = pure (caseWrongArg, True) - if | not (or xcs) - -> trivial -- Variable does not occur - -- At this point we know that xrs, xcs is not empty, - -- and at least one xr is True - | fc || or (init xcs) - -> wrongArg -- T (..var..) ty - | otherwise -- T (..no var..) ty - -> do itf <- isInTypeFamilyApp var f vis_args - if itf -- We can't decompose type families, so - -- error if we encounter one here. - then wrongArg - else pure (caseTyApp (last vis_args) (last xrs), True) - go (DAppKindT t k) = do - (_, kc) <- go k - if kc - then pure (caseWrongArg, True) - else go t - go (DSigT t k) = do - (_, kc) <- go k - if kc - then pure (caseWrongArg, True) - else go t - go (DVarT v) - | v == var = pure (caseVar, True) - | otherwise = trivial - go (DForallT tele t) = case tele of - DForallVis{} -> - fail "Unexpected visible forall in the type of a data constructor" - DForallInvis tvbs -> do - (tr, tc) <- go t - if var `notElem` map extractTvbName tvbs && tc - then pure (caseForAll tvbs tr, True) - else trivial - go (DConstrainedT _ t) = go t - go (DConT {}) = trivial - go DArrowT = trivial - go (DLitT {}) = trivial - go DWildCardT = trivial - - trivial :: q (a, Bool) - trivial = pure (caseTrivial, False) - --- | Detect if a Name occurs as an argument to some type family. This makes an --- effort to exclude /oversaturated/ arguments to type families. For instance, --- if one declared the following type family: --- --- @ --- type family F a :: Type -> Type --- @ --- --- Then in the type @F a b@, we would consider @a@ to be an argument to @F@, --- but not @b@. -isInTypeFamilyApp :: forall q. DsMonad q => Name -> DType -> [DType] -> q Bool -isInTypeFamilyApp name tyFun tyArgs = - case tyFun of - DConT tcName -> go tcName - _ -> pure False - where - go :: Name -> q Bool - go tcName = do - info <- dsReify tcName - case info of - Just (DTyConI dec _) - | DOpenTypeFamilyD (DTypeFamilyHead _ bndrs _ _) <- dec - -> withinFirstArgs bndrs - | DClosedTypeFamilyD (DTypeFamilyHead _ bndrs _ _) _ <- dec - -> withinFirstArgs bndrs - _ -> pure False - - withinFirstArgs :: [a] -> q Bool - withinFirstArgs bndrs = - let firstArgs = take (length bndrs) tyArgs - argFVs = foldMap fvDType firstArgs - in pure $ name `elem` argFVs - --- A crude approximation of cond_functorOK from GHC. This checks that: --- --- (1) There's at least one type variable in the data type. --- (2) It doesn't constrain the last type variable, e.g., data T a = Eq a => MkT a --- (3) It doesn't use the last type variable in the wrong place, e.g. data T a = MkT (X a a) --- --- This skips some things that cond_functorOK checks for but are tricky to --- implement in Template Haskell, such as if the last type variable in the --- constructor's return type is universally quantified. For example, --- functorLikeValidityChecks would accept the following example that --- cond_functorOK would reject: --- --- @ --- data T a b where --- MkT :: z -> T z z -- Last type variable is existential --- deriving instance Functor (T a) --- @ --- --- This isn't the end of the world, as it just means that the user will have to --- deal with a more complex error message when the generate code fails to --- typecheck. -functorLikeValidityChecks :: forall q. DsMonad q => Bool -> DataDecl -> q () -functorLikeValidityChecks allowConstrainedLastTyVar (DataDecl _df n data_tvbs cons) - | null data_tvbs -- (1) - = fail $ "Data type " ++ nameBase n ++ " must have some type parameters" - | otherwise - = mapM_ check_con cons - where - check_con :: DCon -> q () - check_con con = do - check_universal con - checks <- foldDataConArgs (ft_check (extractName con)) con - sequence_ checks - - -- (2) - check_universal :: DCon -> q () - check_universal (DCon _ con_theta con_name _ res_ty) - | allowConstrainedLastTyVar - = pure () - | (_, res_ty_args) <- unfoldDType res_ty - , (_, last_res_ty_arg) <- snocView $ filterDTANormals res_ty_args - , Just last_tv <- getDVarTName_maybe last_res_ty_arg - = do if last_tv `OSet.notMember` foldMap fvDType con_theta - then pure () - else fail $ badCon con_name existential - | otherwise - = fail $ badCon con_name existential - - -- (3) - ft_check :: Name -> FFoldType (q ()) - ft_check con_name = - FT { ft_triv = pure () - , ft_var = pure () - , ft_ty_app = \_ x -> x - , ft_bad_app = fail $ badCon con_name wrong_arg - , ft_forall = \_ x -> x - } - - badCon :: Name -> String -> String - badCon con_name msg = "Constructor " ++ nameBase con_name ++ " " ++ msg - - existential, wrong_arg :: String - existential = "must be truly polymorphic in the last argument of the data type" - wrong_arg = "must use the type variable only as the last argument of a data type" - --- Return all syntactic subterms of a type that contain the given variable somewhere. --- These are the things that should appear in Functor-like instance constraints. -deepSubtypesContaining :: DsMonad q => Name -> DType -> q [DType] -deepSubtypesContaining tv - = functorLikeTraverse tv - (FT { ft_triv = [] - , ft_var = [] - , ft_ty_app = (:) - , ft_bad_app = error "in other argument in deepSubtypesContaining" - , ft_forall = \tvbs xs -> filter (\x -> all (not_in_ty x) tvbs) xs }) - where - not_in_ty :: DType -> DTyVarBndrSpec -> Bool - not_in_ty ty tvb = extractTvbName tvb `OSet.notMember` fvDType ty - --- Fold over the arguments of a data constructor in a Functor-like way. -foldDataConArgs :: forall q a. DsMonad q => FFoldType a -> DCon -> q [a] -foldDataConArgs ft (DCon _ _ _ fields res_ty) = do - field_tys <- traverse expandType $ tysOfConFields fields - traverse foldArg field_tys - where - foldArg :: DType -> q a - foldArg - | (_, res_ty_args) <- unfoldDType res_ty - , (_, last_res_ty_arg) <- snocView $ filterDTANormals res_ty_args - , Just last_tv <- getDVarTName_maybe last_res_ty_arg - = functorLikeTraverse last_tv ft - | otherwise - = const (return (ft_triv ft)) - --- If a type is a type variable (or a variable with a kind signature), return --- 'Just' that. Otherwise, return 'Nothing'. -getDVarTName_maybe :: DType -> Maybe Name -getDVarTName_maybe (DSigT t _) = getDVarTName_maybe t -getDVarTName_maybe (DVarT n) = Just n -getDVarTName_maybe _ = Nothing - --- Make a 'DLamE' using a fresh variable. -mkSimpleLam :: Quasi q => (DExp -> q DExp) -> q DExp -mkSimpleLam lam = do - n <- newUniqueName "n" - body <- lam (DVarE n) - return $ DLamE [n] body - --- Make a 'DLamE' using two fresh variables. -mkSimpleLam2 :: Quasi q => (DExp -> DExp -> q DExp) -> q DExp -mkSimpleLam2 lam = do - n1 <- newUniqueName "n1" - n2 <- newUniqueName "n2" - body <- lam (DVarE n1) (DVarE n2) - return $ DLamE [n1, n2] body - --- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]" --- --- @mkSimpleConClause fold extra_pats con insides@ produces a match clause in --- which the LHS pattern-matches on @extra_pats@, followed by a match on the --- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@ --- and its arguments, applying an expression (from @insides@) to each of the --- respective arguments of @con@. -mkSimpleConClause :: Quasi q - => (Name -> [DExp] -> DExp) - -> [DPat] - -> DCon - -> [DExp] - -> q DClause -mkSimpleConClause fold extra_pats (DCon _ _ con_name _ _) insides = do - vars_needed <- replicateM (length insides) $ newUniqueName "a" - let pat = DConP con_name [] (map DVarP vars_needed) - rhs = fold con_name (zipWith (\i v -> i `DAppE` DVarE v) insides vars_needed) - pure $ DClause (extra_pats ++ [pat]) rhs - --- 'True' if the derived class's last argument is of kind (Type -> Type), --- and thus needs a different constraint inference approach. --- --- Really, we should be determining this information by inspecting the kind --- of the class being used. But that comes dangerously close to kind --- inference territory, so for now we simply hardcode which stock derivable --- classes are Functor-like. -isFunctorLikeClassName :: Name -> Bool -isFunctorLikeClassName class_name - = class_name `elem` [functorName, foldableName, traversableName] +{-# LANGUAGE MultiWayIf #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Singletons.TH.Deriving.Util +-- Copyright : (C) 2018 Ryan Scott +-- License : BSD-style (see LICENSE) +-- Maintainer : Ryan Scott +-- Stability : experimental +-- Portability : non-portable +-- +-- Utilities used by the `deriving` machinery in singletons-th. +-- +---------------------------------------------------------------------------- +module Data.Singletons.TH.Deriving.Util where + +import Control.Monad +import Data.Singletons.TH.Names +import Data.Singletons.TH.Syntax +import Data.Singletons.TH.Util +import Language.Haskell.TH.Desugar +import qualified Language.Haskell.TH.Desugar.OSet as OSet +import Language.Haskell.TH.Syntax + +-- A generic type signature for describing how to produce a derived instance. +type DerivDesc q + = Maybe DCxt -- (Just ctx) if ctx was provided via StandaloneDeriving. + -- Nothing if using a deriving clause. + -> DType -- The data type argument to the class. + -> DataDecl -- The original data type information. + -> q UInstDecl -- The derived instance. + +----- +-- Utilities for deriving Functor-like classes. +-- Much of this was cargo-culted from the GHC source code. +----- + +data FFoldType a -- Describes how to fold over a DType in a functor like way + = FT { ft_triv :: a + -- ^ Does not contain variable + , ft_var :: a + -- ^ The variable itself + , ft_ty_app :: DType -> a -> a + -- ^ Type app, variable only in last argument + , ft_bad_app :: a + -- ^ Type app, variable other than in last argument + , ft_forall :: [DTyVarBndrSpec] -> a -> a + -- ^ Forall type + } + +-- Note that in GHC, this function is pure. It must be monadic here since we: +-- +-- (1) Expand type synonyms +-- (2) Detect type family applications +-- +-- Which require reification in Template Haskell, but are pure in Core. +functorLikeTraverse :: forall q a. + DsMonad q + => Name -- ^ Variable to look for + -> FFoldType a -- ^ How to fold + -> DType -- ^ Type to process + -> q a +functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar + , ft_ty_app = caseTyApp, ft_bad_app = caseWrongArg + , ft_forall = caseForAll }) + ty + = do ty' <- expandType ty + (res, _) <- go ty' + pure res + where + go :: DType + -> q (a, Bool) -- (result of type a, does type contain var) + go t@DAppT{} = do + let (f, args) = unfoldDType t + vis_args = filterDTANormals args + (_, fc) <- go f + (xrs, xcs) <- mapAndUnzipM go vis_args + let wrongArg :: q (a, Bool) + wrongArg = pure (caseWrongArg, True) + if | not (or xcs) + -> trivial -- Variable does not occur + -- At this point we know that xrs, xcs is not empty, + -- and at least one xr is True + | fc || or (init xcs) + -> wrongArg -- T (..var..) ty + | otherwise -- T (..no var..) ty + -> do itf <- isInTypeFamilyApp var f vis_args + if itf -- We can't decompose type families, so + -- error if we encounter one here. + then wrongArg + else pure (caseTyApp (last vis_args) (last xrs), True) + go (DAppKindT t k) = do + (_, kc) <- go k + if kc + then pure (caseWrongArg, True) + else go t + go (DSigT t k) = do + (_, kc) <- go k + if kc + then pure (caseWrongArg, True) + else go t + go (DVarT v) + | v == var = pure (caseVar, True) + | otherwise = trivial + go (DForallT tele t) = case tele of + DForallVis{} -> + fail "Unexpected visible forall in the type of a data constructor" + DForallInvis tvbs -> do + (tr, tc) <- go t + if var `notElem` map extractTvbName tvbs && tc + then pure (caseForAll tvbs tr, True) + else trivial + go (DConstrainedT _ t) = go t + go (DConT {}) = trivial + go DArrowT = trivial + go (DLitT {}) = trivial + go DWildCardT = trivial + + trivial :: q (a, Bool) + trivial = pure (caseTrivial, False) + +-- | Detect if a Name occurs as an argument to some type family. This makes an +-- effort to exclude /oversaturated/ arguments to type families. For instance, +-- if one declared the following type family: +-- +-- @ +-- type family F a :: Type -> Type +-- @ +-- +-- Then in the type @F a b@, we would consider @a@ to be an argument to @F@, +-- but not @b@. +isInTypeFamilyApp :: forall q. DsMonad q => Name -> DType -> [DType] -> q Bool +isInTypeFamilyApp name tyFun tyArgs = + case tyFun of + DConT tcName -> go tcName + _ -> pure False + where + go :: Name -> q Bool + go tcName = do + info <- dsReify tcName + case info of + Just (DTyConI dec _) + | DOpenTypeFamilyD (DTypeFamilyHead _ bndrs _ _) <- dec + -> withinFirstArgs bndrs + | DClosedTypeFamilyD (DTypeFamilyHead _ bndrs _ _) _ <- dec + -> withinFirstArgs bndrs + _ -> pure False + + withinFirstArgs :: [a] -> q Bool + withinFirstArgs bndrs = + let firstArgs = take (length bndrs) tyArgs + argFVs = foldMap fvDType firstArgs + in pure $ name `elem` argFVs + +-- A crude approximation of cond_functorOK from GHC. This checks that: +-- +-- (1) There's at least one type variable in the data type. +-- (2) It doesn't constrain the last type variable, e.g., data T a = Eq a => MkT a +-- (3) It doesn't use the last type variable in the wrong place, e.g. data T a = MkT (X a a) +-- +-- This skips some things that cond_functorOK checks for but are tricky to +-- implement in Template Haskell, such as if the last type variable in the +-- constructor's return type is universally quantified. For example, +-- functorLikeValidityChecks would accept the following example that +-- cond_functorOK would reject: +-- +-- @ +-- data T a b where +-- MkT :: z -> T z z -- Last type variable is existential +-- deriving instance Functor (T a) +-- @ +-- +-- This isn't the end of the world, as it just means that the user will have to +-- deal with a more complex error message when the generate code fails to +-- typecheck. +functorLikeValidityChecks :: forall q. DsMonad q => Bool -> DataDecl -> q () +functorLikeValidityChecks allowConstrainedLastTyVar (DataDecl _df n data_tvbs cons) + | null data_tvbs -- (1) + = fail $ "Data type " ++ nameBase n ++ " must have some type parameters" + | otherwise + = mapM_ check_con cons + where + check_con :: DCon -> q () + check_con con = do + check_universal con + checks <- foldDataConArgs (ft_check (extractName con)) con + sequence_ checks + + -- (2) + check_universal :: DCon -> q () + check_universal (DCon _ con_theta con_name _ res_ty) + | allowConstrainedLastTyVar + = pure () + | (_, res_ty_args) <- unfoldDType res_ty + , (_, last_res_ty_arg) <- snocView $ filterDTANormals res_ty_args + , Just last_tv <- getDVarTName_maybe last_res_ty_arg + = do if last_tv `OSet.notMember` foldMap fvDType con_theta + then pure () + else fail $ badCon con_name existential + | otherwise + = fail $ badCon con_name existential + + -- (3) + ft_check :: Name -> FFoldType (q ()) + ft_check con_name = + FT { ft_triv = pure () + , ft_var = pure () + , ft_ty_app = \_ x -> x + , ft_bad_app = fail $ badCon con_name wrong_arg + , ft_forall = \_ x -> x + } + + badCon :: Name -> String -> String + badCon con_name msg = "Constructor " ++ nameBase con_name ++ " " ++ msg + + existential, wrong_arg :: String + existential = "must be truly polymorphic in the last argument of the data type" + wrong_arg = "must use the type variable only as the last argument of a data type" + +-- Return all syntactic subterms of a type that contain the given variable somewhere. +-- These are the things that should appear in Functor-like instance constraints. +deepSubtypesContaining :: DsMonad q => Name -> DType -> q [DType] +deepSubtypesContaining tv + = functorLikeTraverse tv + (FT { ft_triv = [] + , ft_var = [] + , ft_ty_app = (:) + , ft_bad_app = error "in other argument in deepSubtypesContaining" + , ft_forall = \tvbs xs -> filter (\x -> all (not_in_ty x) tvbs) xs }) + where + not_in_ty :: DType -> DTyVarBndrSpec -> Bool + not_in_ty ty tvb = extractTvbName tvb `OSet.notMember` fvDType ty + +-- Fold over the arguments of a data constructor in a Functor-like way. +foldDataConArgs :: forall q a. DsMonad q => FFoldType a -> DCon -> q [a] +foldDataConArgs ft (DCon _ _ _ fields res_ty) = do + field_tys <- traverse expandType $ tysOfConFields fields + traverse foldArg field_tys + where + foldArg :: DType -> q a + foldArg + | (_, res_ty_args) <- unfoldDType res_ty + , (_, last_res_ty_arg) <- snocView $ filterDTANormals res_ty_args + , Just last_tv <- getDVarTName_maybe last_res_ty_arg + = functorLikeTraverse last_tv ft + | otherwise + = const (return (ft_triv ft)) + +-- If a type is a type variable (or a variable with a kind signature), return +-- 'Just' that. Otherwise, return 'Nothing'. +getDVarTName_maybe :: DType -> Maybe Name +getDVarTName_maybe (DSigT t _) = getDVarTName_maybe t +getDVarTName_maybe (DVarT n) = Just n +getDVarTName_maybe _ = Nothing + +-- Make a 'DLamE' using a fresh variable. +mkSimpleLam :: Quasi q => (DExp -> q DExp) -> q DExp +mkSimpleLam lam = do + n <- newUniqueName "n" + body <- lam (DVarE n) + return $ DLamE [n] body + +-- Make a 'DLamE' using two fresh variables. +mkSimpleLam2 :: Quasi q => (DExp -> DExp -> q DExp) -> q DExp +mkSimpleLam2 lam = do + n1 <- newUniqueName "n1" + n2 <- newUniqueName "n2" + body <- lam (DVarE n1) (DVarE n2) + return $ DLamE [n1, n2] body + +-- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]" +-- +-- @mkSimpleConClause fold extra_pats con insides@ produces a match clause in +-- which the LHS pattern-matches on @extra_pats@, followed by a match on the +-- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@ +-- and its arguments, applying an expression (from @insides@) to each of the +-- respective arguments of @con@. +mkSimpleConClause :: Quasi q + => (Name -> [DExp] -> DExp) + -> [DPat] + -> DCon + -> [DExp] + -> q DClause +mkSimpleConClause fold extra_pats (DCon _ _ con_name _ _) insides = do + vars_needed <- replicateM (length insides) $ newUniqueName "a" + let pat = DConP con_name [] (map DVarP vars_needed) + rhs = fold con_name (zipWith (\i v -> i `DAppE` DVarE v) insides vars_needed) + pure $ DClause (extra_pats ++ [pat]) rhs + +-- 'True' if the derived class's last argument is of kind (Type -> Type), +-- and thus needs a different constraint inference approach. +-- +-- Really, we should be determining this information by inspecting the kind +-- of the class being used. But that comes dangerously close to kind +-- inference territory, so for now we simply hardcode which stock derivable +-- classes are Functor-like. +isFunctorLikeClassName :: Name -> Bool +isFunctorLikeClassName class_name + = class_name `elem` [functorName, foldableName, traversableName] diff --git a/src/Data/Singletons/TH/Names.hs b/src/Data/Singletons/TH/Names.hs --- a/src/Data/Singletons/TH/Names.hs +++ b/src/Data/Singletons/TH/Names.hs @@ -1,269 +1,274 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} - -{- Data/Singletons/TH/Names.hs - -(c) Richard Eisenberg 2014 -rae@cs.brynmawr.edu - -Defining names and manipulations on names for use in promotion and singling. --} - -module Data.Singletons.TH.Names where - -import Data.Singletons -import Data.Singletons.Decide -import Data.Singletons.ShowSing -import Data.Singletons.TH.SuppressUnusedWarnings -import Data.Singletons.TH.Util -import Language.Haskell.TH.Syntax -import Language.Haskell.TH.Desugar -import GHC.TypeLits ( Symbol ) -import GHC.Exts ( Constraint ) -import GHC.Show ( showCommaSpace, showSpace ) -import Data.String (fromString) -import Data.Type.Equality ( TestEquality(..) ) -import Data.Type.Coercion ( TestCoercion(..) ) - -{- -Note [Wired-in Names] -~~~~~~~~~~~~~~~~~~~~~ -The list of Names below contains everything that the Template Haskell machinery -needs to have special knowledge of. These names can be broadly categorized into -two groups: - -1. Names of basic singleton definitions (Sing, SingKind, etc.). These are - spliced directly into TH-generated code. -2. Names of definitions from the Prelude. These are not spliced into - TH-generated code, but are instead used as the namesakes for promoted and - singled definitions. For example, the TH machinery must be aware of the Name - `fromInteger` so that it can promote and single the expression `42` to - `FromInteger 42` and `sFromInteger (sing @42)`, respectively. - -Note that we deliberately do not wire in promoted or singled Names, such as -FromInteger or sFromInteger, for two reasons: - -a. We want all promoted and singled names to go through the naming options in - D.S.TH.Options. Splicing the name FromInteger directly into TH-generated - code, for instance, would prevent users from overriding the default options - in order to promote `fromInteger` to something else (e.g., - MyCustomFromInteger). -b. Wired in names live in particular modules, so if we were to wire in the name - FromInteger, it would come from GHC.Num.Singletons. This would effectively - prevent anyone from defining their own version of FromInteger and - piggybacking on top of the TH machinery to generate it, however. As a - result, we generate the name FromInteger completely unqualified so that - it picks up whichever version of FromInteger is in scope. --} - -boolName, andName, compareName, minBoundName, - maxBoundName, repName, - nilName, consName, listName, tyFunArrowName, - applyName, applyTyConName, applyTyConAux1Name, - symbolName, stringName, - eqName, ordName, boundedName, orderingName, - singFamilyName, singIName, singI1Name, singI2Name, - singMethName, liftSingName, liftSing2Name, demoteName, withSingIName, - singKindClassName, someSingTypeName, someSingDataName, - sDecideClassName, sDecideMethName, - testEqualityClassName, testEqualityMethName, decideEqualityName, - testCoercionClassName, testCoercionMethName, decideCoercionName, - provedName, disprovedName, reflName, toSingName, fromSingName, - equalityName, applySingName, suppressClassName, suppressMethodName, - sameKindName, fromIntegerName, negateName, - errorName, foldlName, cmpEQName, cmpLTName, cmpGTName, - toEnumName, fromEnumName, enumName, - equalsName, constraintName, - showName, showSName, showCharName, showCommaSpaceName, showParenName, showsPrecName, - showSpaceName, showStringName, showSingName, - composeName, gtName, fromStringName, - foldableName, foldMapName, memptyName, mappendName, sappendName, foldrName, - functorName, fmapName, replaceName, - traversableName, traverseName, pureName, apName, liftA2Name :: Name -boolName = ''Bool -andName = '(&&) -compareName = 'compare -minBoundName = 'minBound -maxBoundName = 'maxBound -repName = mkName "Rep" -- this is actually defined in client code! -nilName = '[] -consName = '(:) -listName = ''[] -tyFunArrowName = ''(~>) -applyName = ''Apply -applyTyConName = ''ApplyTyCon -applyTyConAux1Name = ''ApplyTyConAux1 -symbolName = ''Symbol -stringName = ''String -eqName = ''Eq -ordName = ''Ord -boundedName = ''Bounded -orderingName = ''Ordering -singFamilyName = ''Sing -singIName = ''SingI -singI1Name = ''SingI1 -singI2Name = ''SingI2 -singMethName = 'sing -liftSingName = 'liftSing -liftSing2Name = 'liftSing2 -toSingName = 'toSing -fromSingName = 'fromSing -demoteName = ''Demote -withSingIName = 'withSingI -singKindClassName = ''SingKind -someSingTypeName = ''SomeSing -someSingDataName = 'SomeSing -sDecideClassName = ''SDecide -sDecideMethName = '(%~) -testEqualityClassName = ''TestEquality -testEqualityMethName = 'testEquality -decideEqualityName = 'decideEquality -testCoercionClassName = ''TestCoercion -testCoercionMethName = 'testCoercion -decideCoercionName = 'decideCoercion -provedName = 'Proved -disprovedName = 'Disproved -reflName = 'Refl -equalityName = ''(~) -applySingName = 'applySing -suppressClassName = ''SuppressUnusedWarnings -suppressMethodName = 'suppressUnusedWarnings -sameKindName = ''SameKind -fromIntegerName = 'fromInteger -negateName = 'negate -errorName = 'error -foldlName = 'foldl -cmpEQName = 'EQ -cmpLTName = 'LT -cmpGTName = 'GT -toEnumName = 'toEnum -fromEnumName = 'fromEnum -enumName = ''Enum -equalsName = '(==) -constraintName = ''Constraint -showName = ''Show -showSName = ''ShowS -showCharName = 'showChar -showParenName = 'showParen -showSpaceName = 'showSpace -showsPrecName = 'showsPrec -showStringName = 'showString -showSingName = ''ShowSing -composeName = '(.) -gtName = '(>) -showCommaSpaceName = 'showCommaSpace -fromStringName = 'fromString -foldableName = ''Foldable -foldMapName = 'foldMap -memptyName = 'mempty -mappendName = 'mappend -sappendName = '(<>) -foldrName = 'foldr -functorName = ''Functor -fmapName = 'fmap -replaceName = '(<$) -traversableName = ''Traversable -traverseName = 'traverse -pureName = 'pure -apName = '(<*>) -liftA2Name = 'liftA2 - -mkTyName :: Quasi q => Name -> q Name -mkTyName tmName = do - let nameStr = nameBase tmName - symbolic = not (isHsLetter (head nameStr)) - qNewName (if symbolic then "ty" else nameStr) - -mkTyConName :: Int -> Name -mkTyConName i = mkName $ "TyCon" ++ show i - -mkSingIName :: Int -> Name -mkSingIName 0 = singIName -mkSingIName 1 = singI1Name -mkSingIName 2 = singI2Name -mkSingIName n = error $ "SingI" ++ show n ++ " does not exist" - -mkSingMethName :: Int -> Name -mkSingMethName 0 = singMethName -mkSingMethName 1 = liftSingName -mkSingMethName 2 = liftSing2Name -mkSingMethName n = error $ "SingI" ++ show n ++ " does not exist" - -boolKi :: DKind -boolKi = DConT boolName - -singFamily :: DType -singFamily = DConT singFamilyName - -singKindConstraint :: DKind -> DPred -singKindConstraint = DAppT (DConT singKindClassName) - -demote :: DType -demote = DConT demoteName - -apply :: DType -> DType -> DType -apply t1 t2 = DAppT (DAppT (DConT applyName) t1) t2 - -mkListE :: [DExp] -> DExp -mkListE = - foldr (\h t -> DConE consName `DAppE` h `DAppE` t) (DConE nilName) - --- apply a type to a list of types using Apply type family --- This is defined here, not in Utils, to avoid cyclic dependencies -foldApply :: DType -> [DType] -> DType -foldApply = foldl apply - --- make an equality predicate -mkEqPred :: DType -> DType -> DPred -mkEqPred ty1 ty2 = foldType (DConT equalityName) [ty1, ty2] - --- | If a 'String' begins with one or more underscores, return --- @'Just' (us, rest)@, where @us@ contain all of the underscores at the --- beginning of the 'String' and @rest@ contains the remainder of the 'String'. --- Otherwise, return 'Nothing'. -splitUnderscores :: String -> Maybe (String, String) -splitUnderscores s = case span (== '_') s of - ([], _) -> Nothing - res -> Just res - --- Walk a DType, applying a function to all occurrences of constructor names. -modifyConNameDType :: (Name -> Name) -> DType -> DType -modifyConNameDType mod_con_name = go - where - go :: DType -> DType - go (DForallT tele p) = DForallT tele (go p) - go (DConstrainedT cxt p) = DConstrainedT (map go cxt) (go p) - go (DAppT p t) = DAppT (go p) t - go (DAppKindT p k) = DAppKindT (go p) k - go (DSigT p k) = DSigT (go p) k - go p@(DVarT _) = p - go (DConT n) = DConT (mod_con_name n) - go p@DWildCardT = p - go p@(DLitT {}) = p - go p@DArrowT = p - -{- -Note [Defunctionalization symbol suffixes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Before, we used to denote defunctionalization symbols by simply appending dollar -signs at the end (e.g., (+$) and (+$$)). But this can lead to ambiguity when you -have function names that consist of solely $ characters. For instance, if you -tried to promote ($) and ($$) simultaneously, you'd get these promoted types: - -$ -$$ - -And these defunctionalization symbols: - -$$ -$$$ - -But now there's a name clash between the promoted type for ($) and the -defunctionalization symbol for ($$)! The solution is to use a precede these -defunctionalization dollar signs with another string (we choose @#@). -So now the new defunctionalization symbols would be: - -$@#@$ -$@#@$$ - -And there is no conflict. --} +{-# LANGUAGE TemplateHaskellQuotes #-} + +{- Data/Singletons/TH/Names.hs + +(c) Richard Eisenberg 2014 +rae@cs.brynmawr.edu + +Defining names and manipulations on names for use in promotion and singling. +-} + +module Data.Singletons.TH.Names where + +import Data.Singletons +import Data.Singletons.Decide +import Data.Singletons.ShowSing +import Data.Singletons.TH.SuppressUnusedWarnings +import Data.Singletons.TH.Util +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Desugar +import GHC.TypeLits ( Symbol ) +import GHC.Exts ( Constraint ) +import GHC.Show ( showCommaSpace, showSpace ) +import Data.String (fromString) +import Data.Type.Equality ( TestEquality(..) ) +import Data.Type.Coercion ( TestCoercion(..) ) + +{- +Note [Wired-in Names] +~~~~~~~~~~~~~~~~~~~~~ +The list of Names below contains everything that the Template Haskell machinery +needs to have special knowledge of. These names can be broadly categorized into +two groups: + +1. Names of basic singleton definitions (Sing, SingKind, etc.). These are + spliced directly into TH-generated code. +2. Names of definitions from the Prelude. These are not spliced into + TH-generated code, but are instead used as the namesakes for promoted and + singled definitions. For example, the TH machinery must be aware of the Name + `fromInteger` so that it can promote and single the expression `42` to + `FromInteger 42` and `sFromInteger (sing @42)`, respectively. + +Note that we deliberately do not wire in promoted or singled Names, such as +FromInteger or sFromInteger, for two reasons: + +a. We want all promoted and singled names to go through the naming options in + D.S.TH.Options. Splicing the name FromInteger directly into TH-generated + code, for instance, would prevent users from overriding the default options + in order to promote `fromInteger` to something else (e.g., + MyCustomFromInteger). +b. Wired in names live in particular modules, so if we were to wire in the name + FromInteger, it would come from GHC.Num.Singletons. This would effectively + prevent anyone from defining their own version of FromInteger and + piggybacking on top of the TH machinery to generate it, however. As a + result, we generate the name FromInteger completely unqualified so that + it picks up whichever version of FromInteger is in scope. +-} + +boolName, andName, compareName, minBoundName, + maxBoundName, repName, + nilName, consName, listName, tyFunArrowName, + applyName, applyTyConName, applyTyConAux1Name, + symbolName, stringName, + eqName, ordName, boundedName, orderingName, + singFamilyName, singIName, singI1Name, singI2Name, + singMethName, liftSingName, liftSing2Name, demoteName, withSingIName, + singKindClassName, someSingTypeName, someSingDataName, + sDecideClassName, sDecideMethName, + testEqualityClassName, testEqualityMethName, decideEqualityName, + testCoercionClassName, testCoercionMethName, decideCoercionName, + provedName, disprovedName, reflName, toSingName, fromSingName, + equalityName, applySingName, suppressClassName, suppressMethodName, + sameKindName, fromIntegerName, negateName, + errorName, foldlName, cmpEQName, cmpLTName, cmpGTName, + toEnumName, fromEnumName, enumName, + equalsName, constraintName, + showName, showSName, showCharName, showCommaSpaceName, showParenName, showsPrecName, + showSpaceName, showStringName, showSingName, + composeName, gtName, fromStringName, + foldableName, foldMapName, memptyName, mappendName, sappendName, foldrName, + functorName, fmapName, replaceName, + traversableName, traverseName, pureName, apName, liftA2Name :: Name +boolName = ''Bool +andName = '(&&) +compareName = 'compare +minBoundName = 'minBound +maxBoundName = 'maxBound +repName = mkName "Rep" -- this is actually defined in client code! +nilName = '[] +consName = '(:) +listName = ''[] +tyFunArrowName = ''(~>) +applyName = ''Apply +applyTyConName = ''ApplyTyCon +applyTyConAux1Name = ''ApplyTyConAux1 +symbolName = ''Symbol +stringName = ''String +eqName = ''Eq +ordName = ''Ord +boundedName = ''Bounded +orderingName = ''Ordering +singFamilyName = ''Sing +singIName = ''SingI +singI1Name = ''SingI1 +singI2Name = ''SingI2 +singMethName = 'sing +liftSingName = 'liftSing +liftSing2Name = 'liftSing2 +toSingName = 'toSing +fromSingName = 'fromSing +demoteName = ''Demote +withSingIName = 'withSingI +singKindClassName = ''SingKind +someSingTypeName = ''SomeSing +someSingDataName = 'SomeSing +sDecideClassName = ''SDecide +sDecideMethName = '(%~) +testEqualityClassName = ''TestEquality +testEqualityMethName = 'testEquality +decideEqualityName = 'decideEquality +testCoercionClassName = ''TestCoercion +testCoercionMethName = 'testCoercion +decideCoercionName = 'decideCoercion +provedName = 'Proved +disprovedName = 'Disproved +reflName = 'Refl +equalityName = ''(~) +applySingName = 'applySing +suppressClassName = ''SuppressUnusedWarnings +suppressMethodName = 'suppressUnusedWarnings +sameKindName = ''SameKind +fromIntegerName = 'fromInteger +negateName = 'negate +errorName = 'error +foldlName = 'foldl +cmpEQName = 'EQ +cmpLTName = 'LT +cmpGTName = 'GT +toEnumName = 'toEnum +fromEnumName = 'fromEnum +enumName = ''Enum +equalsName = '(==) +constraintName = ''Constraint +showName = ''Show +showSName = ''ShowS +showCharName = 'showChar +showParenName = 'showParen +showSpaceName = 'showSpace +showsPrecName = 'showsPrec +showStringName = 'showString +showSingName = ''ShowSing +composeName = '(.) +gtName = '(>) +showCommaSpaceName = 'showCommaSpace +fromStringName = 'fromString +foldableName = ''Foldable +foldMapName = 'foldMap +memptyName = 'mempty +mappendName = 'mappend +sappendName = '(<>) +foldrName = 'foldr +functorName = ''Functor +fmapName = 'fmap +replaceName = '(<$) +traversableName = ''Traversable +traverseName = 'traverse +pureName = 'pure +apName = '(<*>) +liftA2Name = 'liftA2 + +-- | Return a fresh alphanumeric 'Name'. In particular, if the supplied 'Name' +-- is symbolic (e.g., (%%)), then return a fresh 'Name' with the 'OccName' @ty@. +-- Otherwise, return a fresh 'Name' with the same 'OccName' as the supplied +-- 'Name'. See @Note [Tracking local variables]@ in +-- "Data.Singletons.TH.Promote.Monad" for why we do this. +mkTyName :: Quasi q => Name -> q Name +mkTyName tmName = do + let nameStr = nameBase tmName + symbolic = not (isHsLetter (headNameStr nameStr)) + qNewName (if symbolic then "ty" else nameStr) + +mkTyConName :: Int -> Name +mkTyConName i = mkName $ "TyCon" ++ show i + +mkSingIName :: Int -> Name +mkSingIName 0 = singIName +mkSingIName 1 = singI1Name +mkSingIName 2 = singI2Name +mkSingIName n = error $ "SingI" ++ show n ++ " does not exist" + +mkSingMethName :: Int -> Name +mkSingMethName 0 = singMethName +mkSingMethName 1 = liftSingName +mkSingMethName 2 = liftSing2Name +mkSingMethName n = error $ "SingI" ++ show n ++ " does not exist" + +boolKi :: DKind +boolKi = DConT boolName + +singFamily :: DType +singFamily = DConT singFamilyName + +singKindConstraint :: DKind -> DPred +singKindConstraint = DAppT (DConT singKindClassName) + +demote :: DType +demote = DConT demoteName + +apply :: DType -> DType -> DType +apply t1 t2 = DAppT (DAppT (DConT applyName) t1) t2 + +mkListE :: [DExp] -> DExp +mkListE = + foldr (\h t -> DConE consName `DAppE` h `DAppE` t) (DConE nilName) + +-- apply a type to a list of types using Apply type family +-- This is defined here, not in Utils, to avoid cyclic dependencies +foldApply :: DType -> [DType] -> DType +foldApply = foldl apply + +-- make an equality predicate +mkEqPred :: DType -> DType -> DPred +mkEqPred ty1 ty2 = foldType (DConT equalityName) [ty1, ty2] + +-- | If a 'String' begins with one or more underscores, return +-- @'Just' (us, rest)@, where @us@ contain all of the underscores at the +-- beginning of the 'String' and @rest@ contains the remainder of the 'String'. +-- Otherwise, return 'Nothing'. +splitUnderscores :: String -> Maybe (String, String) +splitUnderscores s = case span (== '_') s of + ([], _) -> Nothing + res -> Just res + +-- Walk a DType, applying a function to all occurrences of constructor names. +modifyConNameDType :: (Name -> Name) -> DType -> DType +modifyConNameDType mod_con_name = go + where + go :: DType -> DType + go (DForallT tele p) = DForallT tele (go p) + go (DConstrainedT cxt p) = DConstrainedT (map go cxt) (go p) + go (DAppT p t) = DAppT (go p) t + go (DAppKindT p k) = DAppKindT (go p) k + go (DSigT p k) = DSigT (go p) k + go p@(DVarT _) = p + go (DConT n) = DConT (mod_con_name n) + go p@DWildCardT = p + go p@(DLitT {}) = p + go p@DArrowT = p + +{- +Note [Defunctionalization symbol suffixes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before, we used to denote defunctionalization symbols by simply appending dollar +signs at the end (e.g., (+$) and (+$$)). But this can lead to ambiguity when you +have function names that consist of solely $ characters. For instance, if you +tried to promote ($) and ($$) simultaneously, you'd get these promoted types: + +$ +$$ + +And these defunctionalization symbols: + +$$ +$$$ + +But now there's a name clash between the promoted type for ($) and the +defunctionalization symbol for ($$)! The solution is to use a precede these +defunctionalization dollar signs with another string (we choose @#@). +So now the new defunctionalization symbols would be: + +$@#@$ +$@#@$$ + +And there is no conflict. +-} diff --git a/src/Data/Singletons/TH/Options.hs b/src/Data/Singletons/TH/Options.hs --- a/src/Data/Singletons/TH/Options.hs +++ b/src/Data/Singletons/TH/Options.hs @@ -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@ - -- @@ - -- 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@ --- @@. -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@ + -- @@ + -- 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@ +-- @@. +defaultOptions :: Options +defaultOptions = Options + { genQuotedDecs = True + , genSingKindInsts = True + , promotedDataTypeOrConName = promoteDataTypeOrConName + , promotedClassName = promoteClassName + , promotedValueName = promoteValNameLhs + , singledDataTypeName = singTyConName + , singledClassName = singClassName + , singledDataConName = singDataConName + , singledValueName = singValName + , defunctionalizedName = promoteTySym + } + +-- | Given the name of the original, unrefined, top-level value, produces the +-- name of the promoted equivalent of the value. +promotedTopLevelValueName :: Options -> Name -> Name +promotedTopLevelValueName opts name = promotedValueName opts name Nothing + +-- | Given the name of the original, unrefined, @let@-bound value and its +-- globally unique number, produces the name of the promoted equivalent of the +-- value. +promotedLetBoundValueName :: Options -> Name -> Uniq -> Name +promotedLetBoundValueName opts name = promotedValueName opts name . Just + +-- | Given the original name of a function (term- or type-level), produces a +-- type-level function name that can be partially applied even without being +-- given any arguments (i.e., @0@ arguments). +defunctionalizedName0 :: Options -> Name -> Name +defunctionalizedName0 opts name = defunctionalizedName opts name 0 + +-- | Class that describes monads that contain 'Options'. +class DsMonad m => OptionsMonad m where + getOptions :: m Options + +instance OptionsMonad Q where + getOptions = pure defaultOptions + +instance OptionsMonad m => OptionsMonad (DsM m) where + getOptions = lift getOptions + +instance (OptionsMonad q, Monoid m) => OptionsMonad (QWithAux m q) where + getOptions = lift getOptions + +instance OptionsMonad m => OptionsMonad (ReaderT r m) where + getOptions = lift getOptions + +instance OptionsMonad m => OptionsMonad (StateT s m) where + getOptions = lift getOptions + +instance (OptionsMonad m, Monoid w) => OptionsMonad (WriterT w m) where + getOptions = lift getOptions + +instance (OptionsMonad m, Monoid w) => OptionsMonad (RWST r w s m) where + getOptions = lift getOptions + +-- | A convenient implementation of the 'OptionsMonad' class. Use by calling +-- 'withOptions'. +newtype OptionsM m a = OptionsM (ReaderT Options m a) + deriving ( Functor, Applicative, Monad, MonadTrans + , Quote, Quasi, MonadFail, MonadIO, DsMonad ) + +-- | Turn any 'DsMonad' into an 'OptionsMonad'. +instance DsMonad m => OptionsMonad (OptionsM m) where + getOptions = OptionsM ask + +-- | Declare the 'Options' that a TH computation should use. +withOptions :: Options -> OptionsM m a -> m a +withOptions opts (OptionsM x) = runReaderT x opts + +-- Used when a value name appears in a pattern context. +-- Works only for proper variables (lower-case names). +-- +-- If the Maybe Uniq argument is Nothing, then the name is top-level (and +-- thus globally unique on its own). +-- If the Maybe Uniq argument is `Just uniq`, then the name is let-bound and +-- should use `uniq` to make the promoted name globally unique. +promoteValNameLhs :: Name -> Maybe Uniq -> Name +promoteValNameLhs n mb_let_uniq + -- We can't promote promote idenitifers beginning with underscores to + -- type names, so we work around the issue by prepending "US" at the + -- front of the name (#229). + | Just (us, rest) <- splitUnderscores (nameBase n) + = mkName $ alpha ++ "US" ++ us ++ rest + + | otherwise + = mkName $ toUpcaseStr pres n + where + pres = maybe noPrefix (uniquePrefixes "Let" "<<<") mb_let_uniq + (alpha, _) = pres + +-- generates type-level symbol for a given name. Int parameter represents +-- saturation: 0 - no parameters passed to the symbol, 1 - one parameter +-- passed to the symbol, and so on. Works on both promoted and unpromoted +-- names. +promoteTySym :: Name -> Int -> Name +promoteTySym name sat + -- We can't promote promote idenitifers beginning with underscores to + -- type names, so we work around the issue by prepending "US" at the + -- front of the name (#229). + | Just (us, rest) <- splitUnderscores (nameBase name) + = default_case (mkName $ "US" ++ us ++ rest) + + | name == nilName + = mkName $ "NilSym" ++ (show sat) + + -- Treat unboxed tuples like tuples. + -- See Note [Promoting and singling unboxed tuples]. + | Just degree <- tupleNameDegree_maybe name <|> + unboxedTupleNameDegree_maybe name + = mkName $ "Tuple" ++ show degree ++ "Sym" ++ show sat + + | otherwise + = default_case name + where + default_case :: Name -> Name + default_case name' = + let capped = toUpcaseStr noPrefix name' in + if isHsLetter (headNameStr capped) + then mkName (capped ++ "Sym" ++ (show sat)) + else mkName (capped ++ "@#@" -- See Note [Defunctionalization symbol suffixes] + ++ (replicate (sat + 1) '$')) + +promoteClassName :: Name -> Name +promoteClassName = prefixName "P" "#" + +promoteDataTypeOrConName :: Name -> Name +promoteDataTypeOrConName nm + | nameBase nm == nameBase repName = typeKindName + -- See Note [Promoting and singling unboxed tuples] + | Just degree <- unboxedTupleNameDegree_maybe nm + = if isDataName nm then tupleDataName degree else tupleTypeName degree + | otherwise = nm + where + -- Is this name a data constructor name? A 'False' answer means "unsure". + isDataName :: Name -> Bool + isDataName (Name _ (NameG DataName _ _)) = True + isDataName _ = False + +-- Singletons + +singDataConName :: Name -> Name +singDataConName nm + | nm == nilName = mkName "SNil" + | nm == consName = mkName "SCons" + | Just degree <- tupleNameDegree_maybe nm = mkTupleName degree + -- See Note [Promoting and singling unboxed tuples] + | Just degree <- unboxedTupleNameDegree_maybe nm = mkTupleName degree + | otherwise = prefixConName "S" "%" nm + +singTyConName :: Name -> Name +singTyConName name + | name == listName = mkName "SList" + | Just degree <- tupleNameDegree_maybe name = mkTupleName degree + -- See Note [Promoting and singling unboxed tuples] + | Just degree <- unboxedTupleNameDegree_maybe name = mkTupleName degree + | otherwise = prefixName "S" "%" name + +mkTupleName :: Int -> Name +mkTupleName n = mkName $ "STuple" ++ show n + +singClassName :: Name -> Name +singClassName = singTyConName + +singValName :: Name -> Name +singValName n + -- Push the 's' past the underscores, as this lets us avoid some unused + -- variable warnings (#229). + | Just (us, rest) <- splitUnderscores (nameBase n) + = prefixName (us ++ "s") "%" $ mkName rest + | otherwise + = prefixName "s" "%" $ upcase n + +{- +Note [Promoting and singling unboxed tuples] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Unfortunately, today's GHC is not quite up to the task of promoting types +involving unboxed tuples. Consider this example: + + swapperino :: (# a, b #) -> (# b, a #) + +What would this look like when promoted? Presumably, it would have a kind +signature like this: + + type Swapperino :: (# a, b #) -> (# b, a #) + +Surprisingly, this won't kindcheck: + + error: + • Expecting a lifted type, but ‘(# a, b #)’ is unlifted + • In a standalone kind signature for ‘Swapperino’: + (# a, b #) -> (# b, a #) + +Even though (->) is levity polymorphic, this levity polymorphism only kicks in +for types, not kinds. In other words, the (->) in the kind of Swapperino is +completely levity monomorphic and only accepts Type-kinded arguments. This +oddity is tracked upstream as GHC#14180. Until that is fixed, there is no hope +of using promoted unboxed tuples freely in kinds. + +However, we don't have to give up quite yet. As a crude-but-effective +workaround, we can simply promote value-level unboxed tuples to type-level boxed +tuples. In other words, we would promote swapperino to this: + + type Swapperino :: (a, b) -> (b, a) + +This trick is enough to make many (but not all) uses of unboxed tuples +Just Work™ when promoted. We use a similar trick when singling unboxed tuples +as well. +-} diff --git a/src/Data/Singletons/TH/Partition.hs b/src/Data/Singletons/TH/Partition.hs --- a/src/Data/Singletons/TH/Partition.hs +++ b/src/Data/Singletons/TH/Partition.hs @@ -1,326 +1,333 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TH.Partition --- Copyright : (C) 2015 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Ryan Scott --- Stability : experimental --- Portability : non-portable --- --- Partitions a list of declarations into its bits --- ----------------------------------------------------------------------------- - -module Data.Singletons.TH.Partition where - -import Prelude hiding ( exp ) -import Data.Singletons.TH.Deriving.Bounded -import Data.Singletons.TH.Deriving.Enum -import Data.Singletons.TH.Deriving.Eq -import Data.Singletons.TH.Deriving.Foldable -import Data.Singletons.TH.Deriving.Functor -import Data.Singletons.TH.Deriving.Ord -import Data.Singletons.TH.Deriving.Show -import Data.Singletons.TH.Deriving.Traversable -import Data.Singletons.TH.Deriving.Util -import Data.Singletons.TH.Names -import Data.Singletons.TH.Options -import Data.Singletons.TH.Syntax -import Data.Singletons.TH.Util -import Language.Haskell.TH.Syntax hiding (showName) -import Language.Haskell.TH.Ppr -import Language.Haskell.TH.Desugar -import qualified Language.Haskell.TH.Desugar.OMap.Strict as OMap -import Language.Haskell.TH.Desugar.OMap.Strict (OMap) - -import Control.Monad -import Data.Bifunctor (bimap) -import qualified Data.Map as Map -import Data.Map (Map) -import Data.Maybe - -data PartitionedDecs = - PDecs { pd_let_decs :: [DLetDec] - , pd_class_decs :: [UClassDecl] - , pd_instance_decs :: [UInstDecl] - , pd_data_decs :: [DataDecl] - , pd_ty_syn_decs :: [TySynDecl] - , pd_open_type_family_decs :: [OpenTypeFamilyDecl] - , pd_closed_type_family_decs :: [ClosedTypeFamilyDecl] - , pd_derived_eq_decs :: [DerivedEqDecl] - , pd_derived_show_decs :: [DerivedShowDecl] - } - -instance Semigroup PartitionedDecs where - PDecs a1 b1 c1 d1 e1 f1 g1 h1 i1 <> PDecs a2 b2 c2 d2 e2 f2 g2 h2 i2 = - PDecs (a1 <> a2) (b1 <> b2) (c1 <> c2) (d1 <> d2) (e1 <> e2) - (f1 <> f2) (g1 <> g2) (h1 <> h2) (i1 <> i2) - -instance Monoid PartitionedDecs where - mempty = PDecs mempty mempty mempty mempty mempty - mempty mempty mempty mempty - --- | Split up a @[DDec]@ into its pieces, extracting 'Ord' instances --- from deriving clauses -partitionDecs :: OptionsMonad m => [DDec] -> m PartitionedDecs -partitionDecs = concatMapM partitionDec - -partitionDec :: OptionsMonad m => DDec -> m PartitionedDecs -partitionDec (DLetDec (DPragmaD {})) = return mempty -partitionDec (DLetDec letdec) = return $ mempty { pd_let_decs = [letdec] } - -partitionDec (DDataD df _cxt name tvbs mk cons derivings) = do - all_tvbs <- buildDataDTvbs tvbs mk - let data_decl = DataDecl df name all_tvbs cons - derived_dec = mempty { pd_data_decs = [data_decl] } - derived_decs - <- mapM (\(strat, deriv_pred) -> - let etad_tvbs - | (DConT pred_name, _) <- unfoldDType deriv_pred - , isFunctorLikeClassName pred_name - -- If deriving Functor, Foldable, or Traversable, - -- we need to use one less type variable than we normally do. - = take (length all_tvbs - 1) all_tvbs - | otherwise - = all_tvbs - ty = foldTypeTvbs (DConT name) etad_tvbs - in partitionDeriving strat deriv_pred Nothing ty data_decl) - $ concatMap flatten_clause derivings - return $ mconcat $ derived_dec : derived_decs - where - flatten_clause :: DDerivClause -> [(Maybe DDerivStrategy, DPred)] - flatten_clause (DDerivClause strat preds) = - map (\p -> (strat, p)) preds - -partitionDec (DClassD cxt name tvbs fds decs) = do - (lde, otfs) <- concatMapM partitionClassDec decs - return $ mempty { pd_class_decs = [ClassDecl { cd_cxt = cxt - , cd_name = name - , cd_tvbs = tvbs - , cd_fds = fds - , cd_lde = lde - , cd_atfs = otfs}] } -partitionDec (DInstanceD _ _ cxt ty decs) = do - (defns, sigs) <- liftM (bimap catMaybes mconcat) $ - mapAndUnzipM partitionInstanceDec decs - (name, tys) <- split_app_tys [] ty - return $ mempty { pd_instance_decs = [InstDecl { id_cxt = cxt - , id_name = name - , id_arg_tys = tys - , id_sigs = sigs - , id_meths = defns }] } - where - split_app_tys acc (DAppT t1 t2) = split_app_tys (t2:acc) t1 - split_app_tys acc (DConT name) = return (name, acc) - split_app_tys acc (DSigT t _) = split_app_tys acc t - split_app_tys _ _ = fail $ "Illegal instance head: " ++ show ty -partitionDec (DRoleAnnotD {}) = return mempty -- ignore these -partitionDec (DTySynD name tvbs rhs) = - -- See Note [Partitioning, type synonyms, and type families] - pure $ mempty { pd_ty_syn_decs = [TySynDecl name tvbs rhs] } -partitionDec (DClosedTypeFamilyD tf_head _) = - -- See Note [Partitioning, type synonyms, and type families] - pure $ mempty { pd_closed_type_family_decs = [TypeFamilyDecl tf_head] } -partitionDec (DOpenTypeFamilyD tf_head) = - -- See Note [Partitioning, type synonyms, and type families] - pure $ mempty { pd_open_type_family_decs = [TypeFamilyDecl tf_head] } -partitionDec (DTySynInstD {}) = pure mempty - -- There's no need to track type family instances, since - -- we already record the type family itself separately. -partitionDec (DKiSigD {}) = pure mempty - -- There's no need to track standalone kind signatures, since we use - -- dsReifyType to look them up. -partitionDec (DStandaloneDerivD mb_strat _ ctxt ty) = - case unfoldDType ty of - (cls_pred_ty, cls_tys) - | let cls_normal_tys = filterDTANormals cls_tys - , not (null cls_normal_tys) -- We can't handle zero-parameter type classes - , let cls_arg_tys = init cls_normal_tys - data_ty = last cls_normal_tys - data_ty_head = case unfoldDType data_ty of (ty_head, _) -> ty_head - , DConT data_tycon <- data_ty_head -- We can't handle deriving an instance for something - -- other than a type constructor application - -> do let cls_pred = foldType cls_pred_ty cls_arg_tys - dinfo <- dsReify data_tycon - case dinfo of - Just (DTyConI (DDataD df _ dn dtvbs dk dcons _) _) -> do - all_tvbs <- buildDataDTvbs dtvbs dk - let data_decl = DataDecl df dn all_tvbs dcons - partitionDeriving mb_strat cls_pred (Just ctxt) data_ty data_decl - Just _ -> - fail $ "Standalone derived instance for something other than a datatype: " - ++ show data_ty - _ -> fail $ "Cannot find " ++ show data_ty - _ -> return mempty -partitionDec dec = - fail $ "Declaration cannot be promoted: " ++ pprint (decToTH dec) - -partitionClassDec :: MonadFail m => DDec -> m (ULetDecEnv, [OpenTypeFamilyDecl]) -partitionClassDec (DLetDec (DSigD name ty)) = - pure (typeBinding name ty, mempty) -partitionClassDec (DLetDec (DValD (DVarP name) exp)) = - pure (valueBinding name (UValue exp), mempty) -partitionClassDec (DLetDec (DFunD name clauses)) = - pure (valueBinding name (UFunction clauses), mempty) -partitionClassDec (DLetDec (DInfixD fixity name)) = - pure (infixDecl fixity name, mempty) -partitionClassDec (DLetDec (DPragmaD {})) = - pure (mempty, mempty) -partitionClassDec (DOpenTypeFamilyD tf_head) = - -- See Note [Partitioning, type synonyms, and type families] - pure (mempty, [TypeFamilyDecl tf_head]) -partitionClassDec (DTySynInstD {}) = - -- There's no need to track associated type family default equations, since - -- we already record the type family itself separately. - pure (mempty, mempty) -partitionClassDec _ = - fail "Only method declarations can be promoted within a class." - -partitionInstanceDec :: MonadFail m => DDec - -> m ( Maybe (Name, ULetDecRHS) -- right-hand sides of methods - , OMap Name DType -- method type signatures - ) -partitionInstanceDec (DLetDec (DValD (DVarP name) exp)) = - pure (Just (name, UValue exp), mempty) -partitionInstanceDec (DLetDec (DFunD name clauses)) = - pure (Just (name, UFunction clauses), mempty) -partitionInstanceDec (DLetDec (DSigD name ty)) = - pure (Nothing, OMap.singleton name ty) -partitionInstanceDec (DLetDec (DPragmaD {})) = - pure (Nothing, mempty) -partitionInstanceDec (DTySynInstD {}) = - pure (Nothing, mempty) - -- There's no need to track associated type family instances, since - -- we already record the type family itself separately. -partitionInstanceDec _ = - fail "Only method bodies can be promoted within an instance." - -partitionDeriving - :: forall m. OptionsMonad m - => Maybe DDerivStrategy - -- ^ The deriving strategy, if present. - -> DPred -- ^ The class being derived (e.g., 'Eq'), possibly applied to - -- some number of arguments (e.g., @C Int Bool@). - -> Maybe DCxt -- ^ @'Just' ctx@ if @ctx@ was provided via @StandaloneDeriving@. - -- 'Nothing' if using a @deriving@ clause. - -> DType -- ^ The data type argument to the class. - -> DataDecl -- ^ The original data type information (e.g., its constructors). - -> m PartitionedDecs -partitionDeriving mb_strat deriv_pred mb_ctxt ty data_decl = - case unfoldDType deriv_pred of - (DConT deriv_name, arg_tys) - -- Here, we are more conservative than GHC: DeriveAnyClass only kicks - -- in if the user explicitly chooses to do so with the anyclass - -- deriving strategy - | Just DAnyclassStrategy <- mb_strat - -> return $ mk_derived_inst - InstDecl { id_cxt = fromMaybe [] mb_ctxt - -- For now at least, there's no point in attempting to - -- infer an instance context for DeriveAnyClass, since - -- the other language feature that requires it, - -- DefaultSignatures, can't be singled. Thus, inferring an - -- empty context will Just Work for all currently supported - -- default implementations. - -- - -- (Of course, if a user specifies a context with - -- StandaloneDeriving, use that.) - - , id_name = deriv_name - , id_arg_tys = filterDTANormals arg_tys ++ [ty] - , id_sigs = mempty - , id_meths = [] } - - | Just DNewtypeStrategy <- mb_strat - -> do qReportWarning "GeneralizedNewtypeDeriving is ignored by `singletons-th`." - return mempty - - | Just (DViaStrategy {}) <- mb_strat - -> do qReportWarning "DerivingVia is ignored by `singletons-th`." - return mempty - - -- Stock classes. These are derived only if `singletons-th` supports them - -- (and, optionally, if an explicit stock deriving strategy is used) - (DConT deriv_name, []) -- For now, all stock derivable class supported in - -- singletons-th take just one argument (the data - -- type itself) - | stock_or_default - , Just decs <- Map.lookup deriv_name stock_map - -> decs - - -- If we can't find a stock class, but the user bothered to use an - -- explicit stock keyword, we can at least warn them about it. - | Just DStockStrategy <- mb_strat - -> do qReportWarning $ "`singletons-th` doesn't recognize the stock class " - ++ nameBase deriv_name - return mempty - - _ -> return mempty -- singletons-th doesn't support deriving this instance - where - mk_instance :: DerivDesc m -> m UInstDecl - mk_instance maker = maker mb_ctxt ty data_decl - - mk_derived_inst dec = mempty { pd_instance_decs = [dec] } - - derived_decl :: DerivedDecl cls - derived_decl = DerivedDecl { ded_mb_cxt = mb_ctxt - , ded_type = ty - , ded_type_tycon = ty_tycon - , ded_decl = data_decl } - where - ty_tycon :: Name - ty_tycon = case unfoldDType ty of - (DConT tc, _) -> tc - (t, _) -> error $ "Not a data type: " ++ show t - stock_or_default = isStockOrDefault mb_strat - - -- A mapping from all stock derivable classes (that singletons-th supports) - -- to to derived code that they produce. - stock_map :: Map Name (m PartitionedDecs) - stock_map = Map.fromList - [ ( ordName, mk_derived_inst <$> mk_instance mkOrdInstance ) - , ( boundedName, mk_derived_inst <$> mk_instance mkBoundedInstance ) - , ( enumName, mk_derived_inst <$> mk_instance mkEnumInstance ) - , ( functorName, mk_derived_inst <$> mk_instance mkFunctorInstance ) - , ( foldableName, mk_derived_inst <$> mk_instance mkFoldableInstance ) - , ( traversableName, mk_derived_inst <$> mk_instance mkTraversableInstance ) - - -- See Note [DerivedDecl] in Data.Singletons.TH.Syntax - , ( eqName, do -- These will become PEq/SEq instances... - inst_for_promotion <- mk_instance mkEqInstance - -- ...and these will become SDecide/TestEquality/TestCoercion instances. - let inst_for_decide = derived_decl - return $ mempty { pd_instance_decs = [inst_for_promotion] - , pd_derived_eq_decs = [inst_for_decide] } ) - , ( showName, do -- These will become PShow/SShow instances... - inst_for_promotion <- mk_instance mkShowInstance - -- ...and this will become a Show instance. - let inst_for_show = derived_decl - pure $ mempty { pd_instance_decs = [inst_for_promotion] - , pd_derived_show_decs = [inst_for_show] } ) - ] - --- Is this being used with an explicit stock strategy, or no strategy at all? -isStockOrDefault :: Maybe DDerivStrategy -> Bool -isStockOrDefault Nothing = True -isStockOrDefault (Just DStockStrategy) = True -isStockOrDefault (Just _) = False - -{- -Note [Partitioning, type synonyms, and type families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The process of singling does not produce any new declarations corresponding to -type synonyms or type families, so they are "ignored" in a sense. Nevertheless, -we explicitly track them during partitioning, since we want to create -defunctionalization symbols for them. - -Also note that: - -1. Other uses of type synonyms in singled code will be expanded away. -2. Other uses of type families in singled code are unlikely to work at present - due to Trac #12564. -3. We track open type families, closed type families, and associated type - families separately, as each form of type family has different kind - inference behavior. See defunTopLevelTypeDecls and - defunAssociatedTypeFamilies in D.S.TH.Promote.Defun for how these differences - manifest. --} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Singletons.TH.Partition +-- Copyright : (C) 2015 Richard Eisenberg +-- License : BSD-style (see LICENSE) +-- Maintainer : Ryan Scott +-- Stability : experimental +-- Portability : non-portable +-- +-- Partitions a list of declarations into its bits +-- +---------------------------------------------------------------------------- + +module Data.Singletons.TH.Partition where + +import Prelude hiding ( exp ) +import Data.Singletons.TH.Deriving.Bounded +import Data.Singletons.TH.Deriving.Enum +import Data.Singletons.TH.Deriving.Eq +import Data.Singletons.TH.Deriving.Foldable +import Data.Singletons.TH.Deriving.Functor +import Data.Singletons.TH.Deriving.Ord +import Data.Singletons.TH.Deriving.Show +import Data.Singletons.TH.Deriving.Traversable +import Data.Singletons.TH.Deriving.Util +import Data.Singletons.TH.Names +import Data.Singletons.TH.Options +import Data.Singletons.TH.Syntax +import Data.Singletons.TH.Util +import Language.Haskell.TH.Syntax hiding (showName) +import Language.Haskell.TH.Ppr +import Language.Haskell.TH.Desugar +import qualified Language.Haskell.TH.Desugar.OMap.Strict as OMap +import Language.Haskell.TH.Desugar.OMap.Strict (OMap) + +import Control.Monad +import Data.Bifunctor (bimap) +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Maybe + +data PartitionedDecs = + PDecs { pd_let_decs :: [DLetDec] + , pd_class_decs :: [UClassDecl] + , pd_instance_decs :: [UInstDecl] + , pd_data_decs :: [DataDecl] + , pd_ty_syn_decs :: [TySynDecl] + , pd_open_type_family_decs :: [OpenTypeFamilyDecl] + , pd_closed_type_family_decs :: [ClosedTypeFamilyDecl] + , pd_derived_eq_decs :: [DerivedEqDecl] + , pd_derived_ord_decs :: [DerivedOrdDecl] + , pd_derived_show_decs :: [DerivedShowDecl] + } + +instance Semigroup PartitionedDecs where + PDecs a1 b1 c1 d1 e1 f1 g1 h1 i1 j1 <> PDecs a2 b2 c2 d2 e2 f2 g2 h2 i2 j2 = + PDecs (a1 <> a2) (b1 <> b2) (c1 <> c2) (d1 <> d2) (e1 <> e2) + (f1 <> f2) (g1 <> g2) (h1 <> h2) (i1 <> i2) (j1 <> j2) + +instance Monoid PartitionedDecs where + mempty = PDecs mempty mempty mempty mempty mempty + mempty mempty mempty mempty mempty + +-- | Split up a @[DDec]@ into its pieces, extracting 'Ord' instances +-- from deriving clauses +partitionDecs :: OptionsMonad m => [DDec] -> m PartitionedDecs +partitionDecs = concatMapM partitionDec + +partitionDec :: OptionsMonad m => DDec -> m PartitionedDecs +partitionDec (DLetDec (DPragmaD {})) = return mempty +partitionDec (DLetDec letdec) = return $ mempty { pd_let_decs = [letdec] } + +partitionDec (DDataD df _cxt name tvbs mk cons derivings) = do + all_tvbs <- buildDataDTvbs tvbs mk + let data_decl = DataDecl df name all_tvbs cons + derived_dec = mempty { pd_data_decs = [data_decl] } + derived_decs + <- mapM (\(strat, deriv_pred) -> + let etad_tvbs + | (DConT pred_name, _) <- unfoldDType deriv_pred + , isFunctorLikeClassName pred_name + -- If deriving Functor, Foldable, or Traversable, + -- we need to use one less type variable than we normally do. + = take (length all_tvbs - 1) all_tvbs + | otherwise + = all_tvbs + ty = foldTypeTvbs (DConT name) etad_tvbs + in partitionDeriving strat deriv_pred Nothing ty data_decl) + $ concatMap flatten_clause derivings + return $ mconcat $ derived_dec : derived_decs + where + flatten_clause :: DDerivClause -> [(Maybe DDerivStrategy, DPred)] + flatten_clause (DDerivClause strat preds) = + map (\p -> (strat, p)) preds + +partitionDec (DClassD cxt name tvbs fds decs) = do + (lde, otfs) <- concatMapM partitionClassDec decs + return $ mempty { pd_class_decs = [ClassDecl { cd_cxt = cxt + , cd_name = name + , cd_tvbs = tvbs + , cd_fds = fds + , cd_lde = lde + , cd_atfs = otfs}] } +partitionDec (DInstanceD _ _ cxt ty decs) = do + (defns, sigs) <- liftM (bimap catMaybes mconcat) $ + mapAndUnzipM partitionInstanceDec decs + (name, tys) <- split_app_tys [] ty + return $ mempty { pd_instance_decs = [InstDecl { id_cxt = cxt + , id_name = name + , id_arg_tys = tys + , id_sigs = sigs + , id_meths = defns }] } + where + split_app_tys acc (DAppT t1 t2) = split_app_tys (t2:acc) t1 + split_app_tys acc (DConT name) = return (name, acc) + split_app_tys acc (DSigT t _) = split_app_tys acc t + split_app_tys _ _ = fail $ "Illegal instance head: " ++ show ty +partitionDec (DRoleAnnotD {}) = return mempty -- ignore these +partitionDec (DTySynD name tvbs rhs) = + -- See Note [Partitioning, type synonyms, and type families] + pure $ mempty { pd_ty_syn_decs = [TySynDecl name tvbs rhs] } +partitionDec (DClosedTypeFamilyD tf_head _) = + -- See Note [Partitioning, type synonyms, and type families] + pure $ mempty { pd_closed_type_family_decs = [TypeFamilyDecl tf_head] } +partitionDec (DOpenTypeFamilyD tf_head) = + -- See Note [Partitioning, type synonyms, and type families] + pure $ mempty { pd_open_type_family_decs = [TypeFamilyDecl tf_head] } +partitionDec (DTySynInstD {}) = pure mempty + -- There's no need to track type family instances, since + -- we already record the type family itself separately. +partitionDec (DKiSigD {}) = pure mempty + -- There's no need to track standalone kind signatures, since we use + -- dsReifyType to look them up. +partitionDec (DStandaloneDerivD mb_strat _ ctxt ty) = + case unfoldDType ty of + (cls_pred_ty, cls_tys) + | let cls_normal_tys = filterDTANormals cls_tys + , not (null cls_normal_tys) -- We can't handle zero-parameter type classes + , let cls_arg_tys = init cls_normal_tys + data_ty = last cls_normal_tys + data_ty_head = case unfoldDType data_ty of (ty_head, _) -> ty_head + , DConT data_tycon <- data_ty_head -- We can't handle deriving an instance for something + -- other than a type constructor application + -> do let cls_pred = foldType cls_pred_ty cls_arg_tys + dinfo <- dsReify data_tycon + case dinfo of + Just (DTyConI (DDataD df _ dn dtvbs dk dcons _) _) -> do + all_tvbs <- buildDataDTvbs dtvbs dk + let data_decl = DataDecl df dn all_tvbs dcons + partitionDeriving mb_strat cls_pred (Just ctxt) data_ty data_decl + Just _ -> + fail $ "Standalone derived instance for something other than a datatype: " + ++ show data_ty + _ -> fail $ "Cannot find " ++ show data_ty + _ -> return mempty +partitionDec dec = + fail $ "Declaration cannot be promoted: " ++ pprint (decToTH dec) + +partitionClassDec :: MonadFail m => DDec -> m (ULetDecEnv, [OpenTypeFamilyDecl]) +partitionClassDec (DLetDec (DSigD name ty)) = + pure (typeBinding name ty, mempty) +partitionClassDec (DLetDec (DValD (DVarP name) exp)) = + pure (valueBinding name (UValue exp), mempty) +partitionClassDec (DLetDec (DFunD name clauses)) = + pure (valueBinding name (UFunction clauses), mempty) +partitionClassDec (DLetDec (DInfixD fixity name)) = + pure (infixDecl fixity name, mempty) +partitionClassDec (DLetDec (DPragmaD {})) = + pure (mempty, mempty) +partitionClassDec (DOpenTypeFamilyD tf_head) = + -- See Note [Partitioning, type synonyms, and type families] + pure (mempty, [TypeFamilyDecl tf_head]) +partitionClassDec (DTySynInstD {}) = + -- There's no need to track associated type family default equations, since + -- we already record the type family itself separately. + pure (mempty, mempty) +partitionClassDec _ = + fail "Only method declarations can be promoted within a class." + +partitionInstanceDec :: MonadFail m => DDec + -> m ( Maybe (Name, ULetDecRHS) -- right-hand sides of methods + , OMap Name DType -- method type signatures + ) +partitionInstanceDec (DLetDec (DValD (DVarP name) exp)) = + pure (Just (name, UValue exp), mempty) +partitionInstanceDec (DLetDec (DFunD name clauses)) = + pure (Just (name, UFunction clauses), mempty) +partitionInstanceDec (DLetDec (DSigD name ty)) = + pure (Nothing, OMap.singleton name ty) +partitionInstanceDec (DLetDec (DPragmaD {})) = + pure (Nothing, mempty) +partitionInstanceDec (DTySynInstD {}) = + pure (Nothing, mempty) + -- There's no need to track associated type family instances, since + -- we already record the type family itself separately. +partitionInstanceDec _ = + fail "Only method bodies can be promoted within an instance." + +partitionDeriving + :: forall m. OptionsMonad m + => Maybe DDerivStrategy + -- ^ The deriving strategy, if present. + -> DPred -- ^ The class being derived (e.g., 'Eq'), possibly applied to + -- some number of arguments (e.g., @C Int Bool@). + -> Maybe DCxt -- ^ @'Just' ctx@ if @ctx@ was provided via @StandaloneDeriving@. + -- 'Nothing' if using a @deriving@ clause. + -> DType -- ^ The data type argument to the class. + -> DataDecl -- ^ The original data type information (e.g., its constructors). + -> m PartitionedDecs +partitionDeriving mb_strat deriv_pred mb_ctxt ty data_decl = + case unfoldDType deriv_pred of + (DConT deriv_name, arg_tys) + -- Here, we are more conservative than GHC: DeriveAnyClass only kicks + -- in if the user explicitly chooses to do so with the anyclass + -- deriving strategy + | Just DAnyclassStrategy <- mb_strat + -> return $ mk_derived_inst + InstDecl { id_cxt = fromMaybe [] mb_ctxt + -- For now at least, there's no point in attempting to + -- infer an instance context for DeriveAnyClass, since + -- the other language feature that requires it, + -- DefaultSignatures, can't be singled. Thus, inferring an + -- empty context will Just Work for all currently supported + -- default implementations. + -- + -- (Of course, if a user specifies a context with + -- StandaloneDeriving, use that.) + + , id_name = deriv_name + , id_arg_tys = filterDTANormals arg_tys ++ [ty] + , id_sigs = mempty + , id_meths = [] } + + | Just DNewtypeStrategy <- mb_strat + -> do qReportWarning "GeneralizedNewtypeDeriving is ignored by `singletons-th`." + return mempty + + | Just (DViaStrategy {}) <- mb_strat + -> do qReportWarning "DerivingVia is ignored by `singletons-th`." + return mempty + + -- Stock classes. These are derived only if `singletons-th` supports them + -- (and, optionally, if an explicit stock deriving strategy is used) + (DConT deriv_name, []) -- For now, all stock derivable class supported in + -- singletons-th take just one argument (the data + -- type itself) + | stock_or_default + , Just decs <- Map.lookup deriv_name stock_map + -> decs + + -- If we can't find a stock class, but the user bothered to use an + -- explicit stock keyword, we can at least warn them about it. + | Just DStockStrategy <- mb_strat + -> do qReportWarning $ "`singletons-th` doesn't recognize the stock class " + ++ nameBase deriv_name + return mempty + + _ -> return mempty -- singletons-th doesn't support deriving this instance + where + mk_instance :: DerivDesc m -> m UInstDecl + mk_instance maker = maker mb_ctxt ty data_decl + + mk_derived_inst dec = mempty { pd_instance_decs = [dec] } + + derived_decl :: DerivedDecl cls + derived_decl = DerivedDecl { ded_mb_cxt = mb_ctxt + , ded_type = ty + , ded_type_tycon = ty_tycon + , ded_decl = data_decl } + where + ty_tycon :: Name + ty_tycon = case unfoldDType ty of + (DConT tc, _) -> tc + (t, _) -> error $ "Not a data type: " ++ show t + stock_or_default = isStockOrDefault mb_strat + + -- A mapping from all stock derivable classes (that singletons-th supports) + -- to to derived code that they produce. + stock_map :: Map Name (m PartitionedDecs) + stock_map = Map.fromList + [ ( ordName, mk_derived_inst <$> mk_instance mkOrdInstance ) + , ( boundedName, mk_derived_inst <$> mk_instance mkBoundedInstance ) + , ( enumName, mk_derived_inst <$> mk_instance mkEnumInstance ) + , ( functorName, mk_derived_inst <$> mk_instance mkFunctorInstance ) + , ( foldableName, mk_derived_inst <$> mk_instance mkFoldableInstance ) + , ( traversableName, mk_derived_inst <$> mk_instance mkTraversableInstance ) + + -- See Note [DerivedDecl] in Data.Singletons.TH.Syntax + , ( eqName, do -- These will become PEq/SEq instances... + inst_for_promotion <- mk_instance mkEqInstance + -- ...and these will become SDecide/Eq/TestEquality/TestCoercion instances. + let inst_for_decide = derived_decl + return $ mempty { pd_instance_decs = [inst_for_promotion] + , pd_derived_eq_decs = [inst_for_decide] } ) + , ( ordName, do -- These will become POrd/SOrd instances... + inst_for_promotion <- mk_instance mkOrdInstance + -- ...and this will become an Ord instance. + let inst_for_ord = derived_decl + pure $ mempty { pd_instance_decs = [inst_for_promotion] + , pd_derived_ord_decs = [inst_for_ord] } ) + , ( showName, do -- These will become PShow/SShow instances... + inst_for_promotion <- mk_instance mkShowInstance + -- ...and this will become a Show instance. + let inst_for_show = derived_decl + pure $ mempty { pd_instance_decs = [inst_for_promotion] + , pd_derived_show_decs = [inst_for_show] } ) + ] + +-- Is this being used with an explicit stock strategy, or no strategy at all? +isStockOrDefault :: Maybe DDerivStrategy -> Bool +isStockOrDefault Nothing = True +isStockOrDefault (Just DStockStrategy) = True +isStockOrDefault (Just _) = False + +{- +Note [Partitioning, type synonyms, and type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The process of singling does not produce any new declarations corresponding to +type synonyms or type families, so they are "ignored" in a sense. Nevertheless, +we explicitly track them during partitioning, since we want to create +defunctionalization symbols for them. + +Also note that: + +1. Other uses of type synonyms in singled code will be expanded away. +2. Other uses of type families in singled code are unlikely to work at present + due to Trac #12564. +3. We track open type families, closed type families, and associated type + families separately, as each form of type family has different kind + inference behavior. See defunTopLevelTypeDecls and + defunAssociatedTypeFamilies in D.S.TH.Promote.Defun for how these differences + manifest. +-} diff --git a/src/Data/Singletons/TH/Promote.hs b/src/Data/Singletons/TH/Promote.hs --- a/src/Data/Singletons/TH/Promote.hs +++ b/src/Data/Singletons/TH/Promote.hs @@ -1,1094 +1,1205 @@ -{- Data/Singletons/TH/Promote.hs - -(c) Richard Eisenberg 2013 -rae@cs.brynmawr.edu - -This file contains functions to promote term-level constructs to the -type level. It is an internal module to the singletons-th package. --} - -module Data.Singletons.TH.Promote where - -import Language.Haskell.TH hiding ( Q, cxt ) -import Language.Haskell.TH.Syntax ( NameSpace(..), Quasi(..), Uniq ) -import Language.Haskell.TH.Desugar -import qualified Language.Haskell.TH.Desugar.OMap.Strict as OMap -import Language.Haskell.TH.Desugar.OMap.Strict (OMap) -import Data.Singletons.TH.Deriving.Bounded -import Data.Singletons.TH.Deriving.Enum -import Data.Singletons.TH.Deriving.Eq -import Data.Singletons.TH.Deriving.Ord -import Data.Singletons.TH.Deriving.Show -import Data.Singletons.TH.Deriving.Util -import Data.Singletons.TH.Names -import Data.Singletons.TH.Options -import Data.Singletons.TH.Partition -import Data.Singletons.TH.Promote.Defun -import Data.Singletons.TH.Promote.Monad -import Data.Singletons.TH.Promote.Type -import Data.Singletons.TH.Syntax -import Data.Singletons.TH.Util -import Prelude hiding (exp) -import Control.Applicative (Alternative(..)) -import Control.Arrow (second) -import Control.Monad -import Control.Monad.Trans.Maybe -import Control.Monad.Writer -import Data.List (nub) -import qualified Data.Map.Strict as Map -import Data.Map.Strict ( Map ) -import Data.Maybe -import qualified GHC.LanguageExtensions.Type as LangExt - -{- -Note [Disable genQuotedDecs in genPromotions and genSingletons] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Somewhat curiously, the genPromotions and genSingletons functions set the -genQuotedDecs option to False, despite neither function accepting quoted -declarations as arguments in the first place. There is a good reason for doing -this, however. Imagine this code: - - class C a where - infixl 9 <%%> - (<%%>) :: a -> a -> a - $(genPromotions [''C]) - -If genQuotedDecs is set to True, then the (<%%>) type family will not receive -a fixity declaration (see -Note [singletons-th and fixity declarations] in D.S.TH.Single.Fixity, wrinkle 1 for -more details on this point). Therefore, we set genQuotedDecs to False to avoid -this problem. --} - --- | Generate promoted definitions for each of the provided type-level --- declaration 'Name's. This is generally only useful with classes. -genPromotions :: OptionsMonad q => [Name] -> q [Dec] -genPromotions names = do - opts <- getOptions - -- See Note [Disable genQuotedDecs in genPromotions and genSingletons] - withOptions opts{genQuotedDecs = False} $ do - checkForRep names - infos <- mapM reifyWithLocals names - dinfos <- mapM dsInfo infos - ddecs <- promoteM_ [] $ mapM_ promoteInfo dinfos - return $ decsToTH ddecs - --- | Promote every declaration given to the type level, retaining the originals. --- See the --- @@ --- for further explanation. -promote :: OptionsMonad q => q [Dec] -> q [Dec] -promote qdecs = do - opts <- getOptions - withOptions opts{genQuotedDecs = True} $ promote' $ lift qdecs - --- | Promote each declaration, discarding the originals. Note that a promoted --- datatype uses the same definition as an original datatype, so this will --- not work with datatypes. Classes, instances, and functions are all fine. -promoteOnly :: OptionsMonad q => q [Dec] -> q [Dec] -promoteOnly qdecs = do - opts <- getOptions - withOptions opts{genQuotedDecs = False} $ promote' $ lift qdecs - --- The workhorse for 'promote' and 'promoteOnly'. The difference between the --- two functions is whether 'genQuotedDecs' is set to 'True' or 'False'. -promote' :: OptionsMonad q => q [Dec] -> q [Dec] -promote' qdecs = do - opts <- getOptions - decs <- qdecs - ddecs <- withLocalDeclarations decs $ dsDecs decs - promDecs <- promoteM_ decs $ promoteDecs ddecs - let origDecs | genQuotedDecs opts = decs - | otherwise = [] - return $ origDecs ++ decsToTH promDecs - --- | Generate defunctionalization symbols for each of the provided type-level --- declaration 'Name's. See the "Promotion and partial application" section of --- the @singletons@ --- @@ --- for further explanation. -genDefunSymbols :: OptionsMonad q => [Name] -> q [Dec] -genDefunSymbols names = do - checkForRep names - infos <- mapM (dsInfo <=< reifyWithLocals) names - decs <- promoteMDecs [] $ concatMapM defunInfo infos - return $ decsToTH decs - --- | Produce instances for @PEq@ from the given types -promoteEqInstances :: OptionsMonad q => [Name] -> q [Dec] -promoteEqInstances = concatMapM promoteEqInstance - --- | Produce an instance for @PEq@ from the given type -promoteEqInstance :: OptionsMonad q => Name -> q [Dec] -promoteEqInstance = promoteInstance mkEqInstance "Eq" - --- | Produce instances for 'POrd' from the given types -promoteOrdInstances :: OptionsMonad q => [Name] -> q [Dec] -promoteOrdInstances = concatMapM promoteOrdInstance - --- | Produce an instance for 'POrd' from the given type -promoteOrdInstance :: OptionsMonad q => Name -> q [Dec] -promoteOrdInstance = promoteInstance mkOrdInstance "Ord" - --- | Produce instances for 'PBounded' from the given types -promoteBoundedInstances :: OptionsMonad q => [Name] -> q [Dec] -promoteBoundedInstances = concatMapM promoteBoundedInstance - --- | Produce an instance for 'PBounded' from the given type -promoteBoundedInstance :: OptionsMonad q => Name -> q [Dec] -promoteBoundedInstance = promoteInstance mkBoundedInstance "Bounded" - --- | Produce instances for 'PEnum' from the given types -promoteEnumInstances :: OptionsMonad q => [Name] -> q [Dec] -promoteEnumInstances = concatMapM promoteEnumInstance - --- | Produce an instance for 'PEnum' from the given type -promoteEnumInstance :: OptionsMonad q => Name -> q [Dec] -promoteEnumInstance = promoteInstance mkEnumInstance "Enum" - --- | Produce instances for 'PShow' from the given types -promoteShowInstances :: OptionsMonad q => [Name] -> q [Dec] -promoteShowInstances = concatMapM promoteShowInstance - --- | Produce an instance for 'PShow' from the given type -promoteShowInstance :: OptionsMonad q => Name -> q [Dec] -promoteShowInstance = promoteInstance mkShowInstance "Show" - -promoteInstance :: OptionsMonad q => DerivDesc q -> String -> Name -> q [Dec] -promoteInstance mk_inst class_name name = do - (df, tvbs, cons) <- getDataD ("I cannot make an instance of " ++ class_name - ++ " for it.") name - tvbs' <- mapM dsTvbUnit tvbs - let data_ty = foldTypeTvbs (DConT name) tvbs' - cons' <- concatMapM (dsCon tvbs' data_ty) cons - let data_decl = DataDecl df name tvbs' cons' - raw_inst <- mk_inst Nothing data_ty data_decl - decs <- promoteM_ [] $ void $ - promoteInstanceDec OMap.empty Map.empty raw_inst - return $ decsToTH decs - -promoteInfo :: DInfo -> PrM () -promoteInfo (DTyConI dec _instances) = promoteDecs [dec] -promoteInfo (DPrimTyConI _name _numArgs _unlifted) = - fail "Promotion of primitive type constructors not supported" -promoteInfo (DVarI _name _ty _mdec) = - fail "Promotion of individual values not supported" -promoteInfo (DTyVarI _name _ty) = - fail "Promotion of individual type variables not supported" -promoteInfo (DPatSynI {}) = - fail "Promotion of pattern synonyms not supported" - --- Promote a list of top-level declarations. -promoteDecs :: [DDec] -> PrM () -promoteDecs raw_decls = do - decls <- expand raw_decls -- expand type synonyms - checkForRepInDecls decls - PDecs { pd_let_decs = let_decs - , pd_class_decs = classes - , pd_instance_decs = insts - , pd_data_decs = datas - , pd_ty_syn_decs = ty_syns - , pd_open_type_family_decs = o_tyfams - , pd_closed_type_family_decs = c_tyfams } <- partitionDecs decls - - defunTopLevelTypeDecls ty_syns c_tyfams o_tyfams - rec_sel_let_decs <- promoteDataDecs datas - -- promoteLetDecs returns LetBinds, which we don't need at top level - _ <- promoteLetDecs Nothing $ rec_sel_let_decs ++ let_decs - mapM_ promoteClassDec classes - let orig_meth_sigs = foldMap (lde_types . cd_lde) classes - cls_tvbs_map = Map.fromList $ map (\cd -> (cd_name cd, cd_tvbs cd)) classes - mapM_ (promoteInstanceDec orig_meth_sigs cls_tvbs_map) insts - --- curious about ALetDecEnv? See the LetDecEnv module for an explanation. -promoteLetDecs :: Maybe Uniq -- let-binding unique (if locally bound) - -> [DLetDec] -> PrM ([LetBind], ALetDecEnv) -promoteLetDecs mb_let_uniq decls = do - opts <- getOptions - let_dec_env <- buildLetDecEnv decls - all_locals <- allLocals - let binds = [ (name, foldType (DConT sym) (map DVarT all_locals)) - | (name, _) <- OMap.assocs $ lde_defns let_dec_env - , let proName = promotedValueName opts name mb_let_uniq - sym = defunctionalizedName opts proName (length all_locals) ] - (decs, let_dec_env') <- letBind binds $ promoteLetDecEnv mb_let_uniq let_dec_env - emitDecs decs - return (binds, let_dec_env' { lde_proms = OMap.fromList binds }) - -promoteDataDecs :: [DataDecl] -> PrM [DLetDec] -promoteDataDecs = concatMapM promoteDataDec - --- "Promotes" a data type, much like D.S.TH.Single.Data.singDataD singles a data --- type. Promoting a data type is much easier than singling it, however, since --- DataKinds automatically promotes data types and kinds and data constructors --- to types. That means that promoteDataDec only has to do three things: --- --- 1. Emit defunctionalization symbols for each data constructor, --- --- 2. Emit promoted fixity declarations for each data constructor and promoted --- record selector (assuming the originals have fixity declarations), and --- --- 3. Assemble a top-level function that mimics the behavior of its record --- selectors. Note that promoteDataDec does not actually promote this record --- selector function—it merely returns its DLetDecs. Later, the promoteDecs --- function takes these DLetDecs and promotes them (using promoteLetDecs). --- This greatly simplifies the plumbing, since this allows all DLetDecs to --- be promoted in a single location. --- See Note [singletons-th and record selectors] in D.S.TH.Single.Data. -promoteDataDec :: DataDecl -> PrM [DLetDec] -promoteDataDec (DataDecl _ _ _ ctors) = do - let rec_sel_names = nub $ concatMap extractRecSelNames ctors - -- Note the use of nub: the same record selector name can - -- be used in multiple constructors! - rec_sel_let_decs <- getRecordSelectors ctors - ctorSyms <- buildDefunSymsDataD ctors - infix_decs <- promoteReifiedInfixDecls rec_sel_names - emitDecs $ ctorSyms ++ infix_decs - pure rec_sel_let_decs - -promoteClassDec :: UClassDecl -> PrM AClassDecl -promoteClassDec decl@(ClassDecl { cd_name = cls_name - , cd_tvbs = tvbs - , cd_fds = fundeps - , cd_atfs = atfs - , cd_lde = lde@LetDecEnv - { lde_defns = defaults - , lde_types = meth_sigs - , lde_infix = infix_decls } }) = do - opts <- getOptions - let pClsName = promotedClassName opts cls_name - meth_sigs_list = OMap.assocs meth_sigs - meth_names = map fst meth_sigs_list - defaults_list = OMap.assocs defaults - defaults_names = map fst defaults_list - mb_cls_sak <- dsReifyType cls_name - sig_decs <- mapM (uncurry promote_sig) meth_sigs_list - (default_decs, ann_rhss, prom_rhss) - <- mapAndUnzip3M (promoteMethod DefaultMethods meth_sigs) defaults_list - defunAssociatedTypeFamilies tvbs atfs - - infix_decls' <- mapMaybeM (uncurry (promoteInfixDecl Nothing)) $ - OMap.assocs infix_decls - cls_infix_decls <- promoteReifiedInfixDecls $ cls_name:meth_names - - -- no need to do anything to the fundeps. They work as is! - let pro_cls_dec = DClassD [] pClsName tvbs fundeps - (sig_decs ++ default_decs ++ infix_decls') - mb_pro_cls_sak = fmap (DKiSigD pClsName) mb_cls_sak - emitDecs $ maybeToList mb_pro_cls_sak ++ pro_cls_dec:cls_infix_decls - let defaults_list' = zip defaults_names ann_rhss - proms = zip defaults_names prom_rhss - return (decl { cd_lde = lde { lde_defns = OMap.fromList defaults_list' - , lde_proms = OMap.fromList proms } }) - where - promote_sig :: Name -> DType -> PrM DDec - promote_sig name ty = do - opts <- getOptions - let proName = promotedTopLevelValueName opts name - -- When computing the kind to use for the defunctionalization symbols, - -- /don't/ use the type variable binders from the method's type... - (_, argKs, resK) <- promoteUnraveled ty - args <- mapM (const $ qNewName "arg") argKs - let proTvbs = zipWith (`DKindedTV` ()) args argKs - -- ...instead, compute the type variable binders in a left-to-right order, - -- since that is the same order that the promoted method's kind will use. - -- See Note [Promoted class methods and kind variable ordering] - meth_sak_tvbs = changeDTVFlags SpecifiedSpec $ - toposortTyVarsOf $ argKs ++ [resK] - meth_sak = ravelVanillaDType meth_sak_tvbs [] argKs resK - m_fixity <- reifyFixityWithLocals name - emitDecsM $ defunctionalize proName m_fixity $ DefunSAK meth_sak - - return $ DOpenTypeFamilyD (DTypeFamilyHead proName - proTvbs - (DKindSig resK) - Nothing) - -{- -Note [Promoted class methods and kind variable ordering] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general, we make an effort to preserve the order of type variables when -promoting type signatures, but there is an annoying corner case where this is -difficult: class methods. When promoting class methods, the order of kind -variables in their kinds will often "just work" by happy coincidence, but -there are some situations where this does not happen. Consider the following -class: - - class C (b :: Type) where - m :: forall a. a -> b -> a - -The full type of `m` is `forall b. C b => forall a. a -> b -> a`, which binds -`b` before `a`. This order is preserved when singling `m`, but *not* when -promoting `m`. This is because the `C` class is promoted as follows: - - class PC (b :: Type) where - type M (x :: a) (y :: b) :: a - -Due to the way GHC kind-checks associated type families, the kind of `M` is -`forall a b. a -> b -> a`, which binds `b` *after* `a`. Moreover, the -`StandaloneKindSignatures` extension does not provide a way to explicitly -declare the full kind of an associated type family, so this limitation is -not easy to work around. - -The defunctionalization symbols for `M` will also follow a similar -order of type variables: - - type MSym0 :: forall a b. a ~> b ~> a - type MSym1 :: forall a b. a -> b ~> a - -There is one potential hack we could use to rectify this: - - type FlipConst x y = y - class PC (b :: Type) where - type M (x :: FlipConst '(b, a) a) (y :: b) :: a - -Using `FlipConst` would cause `b` to be mentioned before `a`, which would give -`M` the kind `forall b a. FlipConst '(b, a) a -> b -> a`. While the order of -type variables would be preserved, the downside is that the ugly `FlipConst` -type synonym leaks into the kind. I'm not particularly fond of this, so I have -decided not to use this hack unless someone specifically requests it. --} - --- returns (unpromoted method name, ALetDecRHS) pairs -promoteInstanceDec :: OMap Name DType - -- Class method type signatures - -> Map Name [DTyVarBndrUnit] - -- Class header type variable (e.g., if `class C a b` is - -- quoted, then this will have an entry for {C |-> [a, b]}) - -> UInstDecl -> PrM AInstDecl -promoteInstanceDec orig_meth_sigs cls_tvbs_map - decl@(InstDecl { id_name = cls_name - , id_arg_tys = inst_tys - , id_sigs = inst_sigs - , id_meths = meths }) = do - opts <- getOptions - cls_tvbs <- lookup_cls_tvbs - inst_kis <- mapM promoteType inst_tys - let pClsName = promotedClassName opts cls_name - cls_tvb_names = map extractTvbName cls_tvbs - subst = Map.fromList $ zip cls_tvb_names inst_kis - meth_impl = InstanceMethods inst_sigs subst - (meths', ann_rhss, _) - <- mapAndUnzip3M (promoteMethod meth_impl orig_meth_sigs) meths - emitDecs [DInstanceD Nothing Nothing [] (foldType (DConT pClsName) - inst_kis) meths'] - return (decl { id_meths = zip (map fst meths) ann_rhss }) - where - lookup_cls_tvbs :: PrM [DTyVarBndrUnit] - lookup_cls_tvbs = - -- First, try consulting the map of class names to their type variables. - -- It is important to do this first to ensure that we consider locally - -- declared classes before imported ones. See #410 for what happens if - -- you don't. - case Map.lookup cls_name cls_tvbs_map of - Just tvbs -> pure tvbs - Nothing -> reify_cls_tvbs - -- If the class isn't present in this map, we try reifying the class - -- as a last resort. - - reify_cls_tvbs :: PrM [DTyVarBndrUnit] - reify_cls_tvbs = do - opts <- getOptions - let pClsName = promotedClassName opts cls_name - mk_tvbs = extract_tvbs (dsReifyTypeNameInfo pClsName) - <|> extract_tvbs (dsReifyTypeNameInfo cls_name) - -- See Note [Using dsReifyTypeNameInfo when promoting instances] - mb_tvbs <- runMaybeT mk_tvbs - case mb_tvbs of - Just tvbs -> pure tvbs - Nothing -> fail $ "Cannot find class declaration annotation for " ++ show cls_name - - extract_tvbs :: PrM (Maybe DInfo) -> MaybeT PrM [DTyVarBndrUnit] - extract_tvbs reify_info = do - mb_info <- lift reify_info - case mb_info of - Just (DTyConI (DClassD _ _ tvbs _ _) _) -> pure tvbs - _ -> empty - -{- -Note [Using dsReifyTypeNameInfo when promoting instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -During the promotion of a class instance, it becomes necessary to reify the -original promoted class's info to learn various things. It's tempting to think -that just calling dsReify on the class name will be sufficient, but it's not. -Consider this class and its promotion: - - class Eq a where - (==) :: a -> a -> Bool - - class PEq a where - type (==) (x :: a) (y :: a) :: Bool - -Notice how both of these classes have an identifier named (==), one at the -value level, and one at the type level. Now imagine what happens when you -attempt to promote this Template Haskell declaration: - - [d| f :: Bool - f = () == () |] - -When promoting ==, singletons-th will come up with its promoted equivalent (which also -happens to be ==). However, this promoted name is a raw Name, since it is created -with mkName. This becomes an issue when we call dsReify the raw "==" Name, as -Template Haskell has to arbitrarily choose between reifying the info for the -value-level (==) and the type-level (==), and in this case, it happens to pick the -value-level (==) info. We want the type-level (==) info, however, because we care -about the promoted version of (==). - -Fortunately, there's a serviceable workaround. Instead of dsReify, we can use -dsReifyTypeNameInfo, which first calls lookupTypeName (to ensure we can find a Name -that's in the type namespace) and _then_ reifies it. --} - --- Which sort of class methods are being promoted? -data MethodSort - -- The method defaults in class declarations. - = DefaultMethods - -- The methods in instance declarations. - | InstanceMethods (OMap Name DType) -- ^ InstanceSigs - (Map Name DKind) -- ^ Instantiations for class tyvars - -- See Note [Promoted class method kinds] - deriving Show - -promoteMethod :: MethodSort - -> OMap Name DType -- method types - -> (Name, ULetDecRHS) - -> PrM (DDec, ALetDecRHS, DType) - -- returns (type instance, ALetDecRHS, promoted RHS) -promoteMethod meth_sort orig_sigs_map (meth_name, meth_rhs) = do - opts <- getOptions - (meth_arg_kis, meth_res_ki) <- promote_meth_ty - meth_arg_tvs <- replicateM (length meth_arg_kis) (qNewName "a") - let proName = promotedTopLevelValueName opts meth_name - helperNameBase = case nameBase proName of - first:_ | not (isHsLetter first) -> "TFHelper" - alpha -> alpha - - -- family_args are the type variables in a promoted class's - -- associated type family instance (or default implementation), e.g., - -- - -- class C k where - -- type T (a :: k) (b :: Bool) - -- type T a b = THelper1 a b -- family_args = [a, b] - -- - -- instance C Bool where - -- type T a b = THelper2 a b -- family_args = [a, b] - -- - -- We could annotate these variables with explicit kinds, but it's not - -- strictly necessary, as kind inference can figure them out just as well. - family_args = map DVarT meth_arg_tvs - helperName <- newUniqueName helperNameBase - let helperDefunName = defunctionalizedName0 opts helperName - (pro_decs, defun_decs, ann_rhs) - <- promoteLetDecRHS (ClassMethodRHS meth_arg_kis meth_res_ki) - OMap.empty OMap.empty - Nothing helperName meth_rhs - emitDecs (pro_decs ++ defun_decs) - return ( DTySynInstD - (DTySynEqn Nothing - (foldType (DConT proName) family_args) - (foldApply (DConT helperDefunName) (map DVarT meth_arg_tvs))) - , ann_rhs - , DConT helperDefunName ) - where - -- Promote the type of a class method. For a default method, "the type" is - -- simply the type of the original method. For an instance method, - -- "the type" is like the type of the original method, but substituted for - -- the types in the instance head. (e.g., if you have `class C a` and - -- `instance C T`, then the substitution [a |-> T] must be applied to the - -- original method's type.) - promote_meth_ty :: PrM ([DKind], DKind) - promote_meth_ty = - case meth_sort of - DefaultMethods -> - -- No substitution for class variables is required for default - -- method type signatures, as they share type variables with the - -- class they inhabit. - lookup_meth_ty - InstanceMethods inst_sigs_map cls_subst -> - case OMap.lookup meth_name inst_sigs_map of - Just ty -> do - -- We have an InstanceSig. These are easy: we can just use the - -- instance signature's type directly, and no substitution for - -- class variables is required. - (_tvbs, arg_kis, res_ki) <- promoteUnraveled ty - pure (arg_kis, res_ki) - Nothing -> do - -- We don't have an InstanceSig, so we must compute the kind to use - -- ourselves. - (arg_kis, res_ki) <- lookup_meth_ty - -- Substitute for the class variables in the method's type. - -- See Note [Promoted class method kinds] - let arg_kis' = map (substKind cls_subst) arg_kis - res_ki' = substKind cls_subst res_ki - pure (arg_kis', res_ki') - - -- Attempt to look up a class method's original type. - lookup_meth_ty :: PrM ([DKind], DKind) - lookup_meth_ty = do - opts <- getOptions - let proName = promotedTopLevelValueName opts meth_name - case OMap.lookup meth_name orig_sigs_map of - Just ty -> do - -- The type of the method is in scope, so promote that. - (_tvbs, arg_kis, res_ki) <- promoteUnraveled ty - pure (arg_kis, res_ki) - Nothing -> do - -- If the type of the method is not in scope, the only other option - -- is to try reifying the promoted method name. - mb_info <- dsReifyTypeNameInfo proName - -- See Note [Using dsReifyTypeNameInfo when promoting instances] - case mb_info of - Just (DTyConI (DOpenTypeFamilyD (DTypeFamilyHead _ tvbs mb_res_ki _)) _) - -> let arg_kis = map (defaultMaybeToTypeKind . extractTvbKind) tvbs - res_ki = defaultMaybeToTypeKind (resultSigToMaybeKind mb_res_ki) - in pure (arg_kis, res_ki) - _ -> fail $ "Cannot find type annotation for " ++ show proName - -{- -Note [Promoted class method kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this example of a type class (and instance): - - class C a where - m :: a -> Bool -> Bool - m _ x = x - - instance C [a] where - m l _ = null l - -The promoted version of these declarations would be: - - class PC a where - type M (x :: a) (y :: Bool) :: Bool - type M x y = MHelper1 x y - - instance PC [a] where - type M x y = MHelper2 x y - - type MHelper1 :: a -> Bool -> Bool - type family MHelper1 x y where ... - - type MHelper2 :: [a] -> Bool -> Bool - type family MHelper2 x y where ... - -Getting the kind signature for MHelper1 (the promoted default implementation of -M) is quite simple, as it corresponds exactly to the kind of M. We might even -choose to make that the kind of MHelper2, but then it would be overly general -(and more difficult to find in -ddump-splices output). For this reason, we -substitute in the kinds of the instance itself to determine the kinds of -promoted method implementations like MHelper2. --} - -promoteLetDecEnv :: Maybe Uniq -> ULetDecEnv -> PrM ([DDec], ALetDecEnv) -promoteLetDecEnv mb_let_uniq (LetDecEnv { lde_defns = value_env - , lde_types = type_env - , lde_infix = fix_env }) = do - infix_decls <- mapMaybeM (uncurry (promoteInfixDecl mb_let_uniq)) $ - OMap.assocs fix_env - - -- promote all the declarations, producing annotated declarations - let (names, rhss) = unzip $ OMap.assocs value_env - (pro_decs, defun_decss, ann_rhss) - <- fmap unzip3 $ - zipWithM (promoteLetDecRHS LetBindingRHS type_env fix_env mb_let_uniq) - names rhss - - emitDecs $ concat defun_decss - let decs = concat pro_decs ++ infix_decls - - -- build the ALetDecEnv - let let_dec_env' = LetDecEnv { lde_defns = OMap.fromList $ zip names ann_rhss - , lde_types = type_env - , lde_infix = fix_env - , lde_proms = OMap.empty -- filled in promoteLetDecs - } - - return (decs, let_dec_env') - --- Promote a fixity declaration. -promoteInfixDecl :: forall q. OptionsMonad q - => Maybe Uniq -> Name -> Fixity -> q (Maybe DDec) -promoteInfixDecl mb_let_uniq name fixity = do - opts <- getOptions - mb_ns <- reifyNameSpace name - case mb_ns of - -- If we can't find the Name for some odd reason, fall back to promote_val - Nothing -> promote_val - Just VarName -> promote_val - Just DataName -> never_mind - Just TcClsName -> do - mb_info <- dsReify name - case mb_info of - Just (DTyConI DClassD{} _) - -> finish $ promotedClassName opts name - _ -> never_mind - where - -- Produce the fixity declaration. - finish :: Name -> q (Maybe DDec) - finish = pure . Just . DLetDec . DInfixD fixity - - -- Don't produce a fixity declaration at all. This happens when promoting a - -- fixity declaration for a name whose promoted counterpart is the same as - -- the original name. - -- See Note [singletons-th and fixity declarations] in D.S.TH.Single.Fixity, wrinkle 1. - never_mind :: q (Maybe DDec) - never_mind = pure Nothing - - -- Certain value names do not change when promoted (e.g., infix names). - -- Therefore, don't bother promoting their fixity declarations if - -- 'genQuotedDecs' is set to 'True', since that will run the risk of - -- generating duplicate fixity declarations. - -- See Note [singletons-th and fixity declarations] in D.S.TH.Single.Fixity, wrinkle 1. - promote_val :: q (Maybe DDec) - promote_val = do - opts <- getOptions - let promoted_name :: Name - promoted_name = promotedValueName opts name mb_let_uniq - if nameBase name == nameBase promoted_name && genQuotedDecs opts - then never_mind - else finish promoted_name - --- Try producing promoted fixity declarations for Names by reifying them --- /without/ consulting quoted declarations. If reification fails, recover and --- return the empty list. --- See [singletons-th and fixity declarations] in D.S.TH.Single.Fixity, wrinkle 2. -promoteReifiedInfixDecls :: forall q. OptionsMonad q => [Name] -> q [DDec] -promoteReifiedInfixDecls = mapMaybeM tryPromoteFixityDeclaration - where - tryPromoteFixityDeclaration :: Name -> q (Maybe DDec) - tryPromoteFixityDeclaration name = - qRecover (return Nothing) $ do - mFixity <- qReifyFixity name - case mFixity of - Nothing -> pure Nothing - Just fixity -> promoteInfixDecl Nothing name fixity - --- Which sort of let-bound declaration's right-hand side is being promoted? -data LetDecRHSSort - -- An ordinary (i.e., non-class-related) let-bound declaration. - = LetBindingRHS - -- The right-hand side of a class method (either a default method or a - -- method in an instance declaration). - | ClassMethodRHS - [DKind] DKind - -- The RHS's promoted argument and result types. Needed to fix #136. - deriving Show - --- This function is used both to promote class method defaults and normal --- let bindings. Thus, it can't quite do all the work locally and returns --- an intermediate structure. Perhaps a better design is available. -promoteLetDecRHS :: LetDecRHSSort - -> OMap Name DType -- local type env't - -> OMap Name Fixity -- local fixity env't - -> Maybe Uniq -- let-binding unique (if locally bound) - -> Name -- name of the thing being promoted - -> ULetDecRHS -- body of the thing - -> PrM ( [DDec] -- promoted type family dec, plus the - -- SAK dec (if one exists) - , [DDec] -- defunctionalization - , ALetDecRHS ) -- annotated RHS -promoteLetDecRHS rhs_sort type_env fix_env mb_let_uniq name let_dec_rhs = do - opts <- getOptions - all_locals <- allLocals - case let_dec_rhs of - UValue exp -> do - (m_ldrki, ty_num_args) <- promote_let_dec_ty all_locals 0 - if ty_num_args == 0 - then - let proName = promotedValueName opts name mb_let_uniq - prom_fun_lhs = foldType (DConT proName) $ map DVarT all_locals in - promote_let_dec_rhs all_locals m_ldrki 0 (promoteExp exp) - (\exp' -> [DTySynEqn Nothing prom_fun_lhs exp']) - AValue - else - -- If we have a UValue with a function type, process it as though it - -- were a UFunction. promote_function_rhs will take care of - -- eta-expanding arguments as necessary. - promote_function_rhs all_locals [DClause [] exp] - UFunction clauses -> promote_function_rhs all_locals clauses - where - -- Promote the RHS of a UFunction (or a UValue with a function type). - promote_function_rhs :: [Name] - -> [DClause] -> PrM ([DDec], [DDec], ALetDecRHS) - promote_function_rhs all_locals clauses = do - opts <- getOptions - numArgs <- count_args clauses - let proName = promotedValueName opts name mb_let_uniq - prom_fun_lhs = foldType (DConT proName) $ map DVarT all_locals - (m_ldrki, ty_num_args) <- promote_let_dec_ty all_locals numArgs - expClauses <- mapM (etaContractOrExpand ty_num_args numArgs) clauses - promote_let_dec_rhs all_locals m_ldrki ty_num_args - (mapAndUnzipM (promoteClause prom_fun_lhs) expClauses) - id (AFunction ty_num_args) - - -- Promote a UValue or a UFunction. - -- Notes about type variables: - -- - -- * For UValues, `prom_a` is DType and `a` is Exp. - -- - -- * For UFunctions, `prom_a` is [DTySynEqn] and `a` is [DClause]. - promote_let_dec_rhs - :: [Name] -- Local variables bound in this scope - -> Maybe LetDecRHSKindInfo -- Information about the promoted kind (if present) - -> Int -- The number of promoted function arguments - -> PrM (prom_a, a) -- Promote the RHS - -> (prom_a -> [DTySynEqn]) -- Turn the promoted RHS into type family equations - -> (a -> ALetDecRHS) -- Build an ALetDecRHS - -> PrM ([DDec], [DDec], ALetDecRHS) - promote_let_dec_rhs all_locals m_ldrki ty_num_args - promote_thing mk_prom_eqns mk_alet_dec_rhs = do - opts <- getOptions - tyvarNames <- replicateM ty_num_args (qNewName "a") - let proName = promotedValueName opts name mb_let_uniq - local_tvbs = map (`DPlainTV` ()) all_locals - m_fixity = OMap.lookup name fix_env - - mk_tf_head :: [DTyVarBndrUnit] -> DFamilyResultSig -> DTypeFamilyHead - mk_tf_head tvbs res_sig = DTypeFamilyHead proName tvbs res_sig Nothing - - (m_sak_dec, defun_ki, tf_head) = - -- There are three possible cases: - case m_ldrki of - -- 1. We have no kind information whatsoever. - Nothing -> - let all_args = local_tvbs ++ map (`DPlainTV` ()) tyvarNames in - ( Nothing - , DefunNoSAK all_args Nothing - , mk_tf_head all_args DNoSig - ) - -- 2. We have some kind information in the form of a LetDecRHSKindInfo. - Just (LDRKI m_sak argKs resK) -> - let all_args = local_tvbs ++ zipWith (`DKindedTV` ()) tyvarNames argKs in - case m_sak of - -- 2(a). We do not have a standalone kind signature. - Nothing -> - ( Nothing - , DefunNoSAK all_args (Just resK) - , mk_tf_head all_args (DKindSig resK) - ) - -- 2(b). We have a standalone kind signature. - Just sak -> - ( Just $ DKiSigD proName sak - , DefunSAK sak - -- We opt to annotate the argument and result kinds in - -- the body of the type family declaration even if it is - -- given a standalone kind signature. - -- See Note [Keep redundant kind information for Haddocks]. - , mk_tf_head all_args (DKindSig resK) - ) - - defun_decs <- defunctionalize proName m_fixity defun_ki - (prom_thing, thing) <- promote_thing - return ( catMaybes [ m_sak_dec - , Just $ DClosedTypeFamilyD tf_head (mk_prom_eqns prom_thing) - ] - , defun_decs - , mk_alet_dec_rhs thing ) - - promote_let_dec_ty :: [Name] -- The local variables that the let-dec closes - -- over. If this is non-empty, we cannot - -- produce a standalone kind signature. - -- See Note [No SAKs for let-decs with local variables] - -> Int -- The number of arguments to default to if the - -- type cannot be inferred. This is 0 for UValues - -- and the number of arguments in a single clause - -- for UFunctions. - -> PrM (Maybe LetDecRHSKindInfo, Int) - -- Returns two things in a pair: - -- - -- 1. Information about the promoted kind, - -- if available. - -- - -- 2. The number of arguments the let-dec has. - -- If no kind information is available from - -- which to infer this number, then this - -- will default to the earlier Int argument. - promote_let_dec_ty all_locals default_num_args = - case rhs_sort of - ClassMethodRHS arg_kis res_ki - -> -- For class method RHS helper functions, don't bother quantifying - -- any type variables in their SAKS. We could certainly try, but - -- given that these functions are only used internally, there's no - -- point in trying to get the order of type variables correct, - -- since we don't apply these functions with visible kind - -- applications. - let sak = ravelVanillaDType [] [] arg_kis res_ki in - return (Just (LDRKI (Just sak) arg_kis res_ki), length arg_kis) - LetBindingRHS - | Just ty <- OMap.lookup name type_env - -> do - -- promoteType turns rank-1 uses of (->) into (~>). So, we unravel - -- first to avoid this behavior, and then ravel back. - (tvbs, argKs, resultK) <- promoteUnraveled ty - let m_sak | null all_locals = Just $ ravelVanillaDType tvbs [] argKs resultK - -- If this let-dec closes over local variables, then - -- don't give it a SAK. - -- See Note [No SAKs for let-decs with local variables] - | otherwise = Nothing - -- invariant: count_args ty == length argKs - return (Just (LDRKI m_sak argKs resultK), length argKs) - - | otherwise - -> return (Nothing, default_num_args) - - etaContractOrExpand :: Int -> Int -> DClause -> PrM DClause - etaContractOrExpand ty_num_args clause_num_args (DClause pats exp) - | n >= 0 = do -- Eta-expand - names <- replicateM n (newUniqueName "a") - let newPats = map DVarP names - newArgs = map DVarE names - return $ DClause (pats ++ newPats) (foldExp exp newArgs) - | otherwise = do -- Eta-contract - let (clausePats, lamPats) = splitAt ty_num_args pats - lamExp <- mkDLamEFromDPats lamPats exp - return $ DClause clausePats lamExp - where - n = ty_num_args - clause_num_args - - count_args :: [DClause] -> PrM Int - count_args (DClause pats _ : _) = return $ length pats - count_args _ = fail $ "Impossible! A function without clauses." - --- An auxiliary data type used in promoteLetDecRHS that describes information --- related to the promoted kind of a class method default or normal --- let binding. -data LetDecRHSKindInfo = - LDRKI (Maybe DKind) -- The standalone kind signature, if applicable. - -- This will be Nothing if the let-dec RHS has local - -- variables that it closes over. - -- See Note [No SAKs for let-decs with local variables] - [DKind] -- The argument kinds. - DKind -- The result kind. - -{- -Note [No SAKs for let-decs with local variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider promoting this: - - f :: Bool - f = let x = True - g :: () -> Bool - g _ = x - in g () - -Clearly, the promoted `F` type family will have the following SAK: - - type F :: () - -What about `G`? At a passing glance, it appears that you could get away with -this: - - type G :: Bool -> () - -But this isn't quite right, since `g` closes over `x = True`. The body of `G`, -therefore, has to lift `x` to be an explicit argument: - - type family G x (u :: ()) :: Bool where - G x _ = x - -At present, we don't keep track of the types of local variables like `x`, which -makes it difficult to create a SAK for things like `G`. Here are some possible -ideas, each followed by explanations for why they are infeasible: - -* Use wildcards: - - type G :: _ -> () -> Bool - - Alas, GHC currently does not allow wildcards in SAKs. See GHC#17432. - -* Use visible dependent quantification to avoid having to say what the kind - of `x` is: - - type G :: forall x -> () -> Bool - - A clever trick to be sure, but it doesn't quite do what we want, since - GHC will generalize that kind to become `forall (x :: k) -> () -> Bool`, - which is more general than we want. - -In any case, it's probably not worth bothering with SAKs for local definitions -like `g` in the first place, so we avoid generating SAKs for anything that -closes over at least one local variable for now. If someone yells about this, -we'll reconsider this design. - -Note [Keep redundant kind information for Haddocks] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -`singletons-th` generates explicit argument kinds and result kinds for -type-level declarations whenever possible, even if those kinds are technically -redundant. For example, `singletons-th` would promote this: - - id' :: a -> a - -To this: - - type Id' :: a -> a - type family Id' (x :: a) :: a where ... - -Strictly speaking, the argument and result kind of Id' are unnecessary, since -the same information is already present in the standalone kind signature. -However, due to a Haddock limitation -(https://github.com/haskell/haddock/issues/1178), Haddock will not render -standalone kind signatures at all, so if the argument and result kind of Id' -were omitted in the body, Haddock would render it like so: - - type family Id' x where ... - -This is unfortunate for Haddock viewers, as this does not convey any kind -information whatsoever. Until the aformentioned Haddock issue is resolved, we -work around this limitation by generating the redundant argument and kind -information anyway. Thankfully, this is simple to accomplish, as we already -compute this information to begin with. --} - -promoteClause :: DType -- What to use as the LHS of the promoted type family - -- equation. This should consist of the promoted name of - -- the function to which the clause belongs, applied to - -- any local arguments (e.g., `Go x y z`). - -> DClause -> PrM (DTySynEqn, ADClause) -promoteClause pro_clause_fun (DClause pats exp) = do - -- promoting the patterns creates variable bindings. These are passed - -- to the function promoted the RHS - ((types, pats'), new_vars) <- evalForPair $ mapAndUnzipM promotePat pats - (ty, ann_exp) <- lambdaBind new_vars $ promoteExp exp - return ( DTySynEqn Nothing (foldType pro_clause_fun types) ty - , ADClause new_vars pats' ann_exp ) - -promoteMatch :: DType -- What to use as the LHS of the promoted type family - -- equation. This should consist of the promoted name of - -- the case expression to which the match belongs, applied - -- to any local arguments (e.g., `Case x y z`). - -> DMatch -> PrM (DTySynEqn, ADMatch) -promoteMatch pro_case_fun (DMatch pat exp) = do - -- promoting the patterns creates variable bindings. These are passed - -- to the function promoted the RHS - ((ty, pat'), new_vars) <- evalForPair $ promotePat pat - (rhs, ann_exp) <- lambdaBind new_vars $ promoteExp exp - return $ ( DTySynEqn Nothing (pro_case_fun `DAppT` ty) rhs - , ADMatch new_vars pat' ann_exp) - --- promotes a term pattern into a type pattern, accumulating bound variable names -promotePat :: DPat -> QWithAux VarPromotions PrM (DType, ADPat) -promotePat (DLitP lit) = (, ADLitP lit) <$> promoteLitPat lit -promotePat (DVarP name) = do - -- term vars can be symbols... type vars can't! - tyName <- mkTyName name - tell $ [(name, tyName)] - return (DVarT tyName, ADVarP name) -promotePat (DConP name tys pats) = do - opts <- getOptions - kis <- traverse (promoteType_options conOptions) tys - (types, pats') <- mapAndUnzipM promotePat pats - let name' = promotedDataTypeOrConName opts name - return (foldType (foldl DAppKindT (DConT name') kis) types, ADConP name kis pats') - where - -- Currently, visible type patterns of data constructors are the one place - -- in `singletons-th` where it makes sense to promote wildcard types, as it - -- will produce code that GHC will accept. - conOptions :: PromoteTypeOptions - conOptions = defaultPromoteTypeOptions{ptoAllowWildcards = True} -promotePat (DTildeP pat) = do - qReportWarning "Lazy pattern converted into regular pattern in promotion" - second ADTildeP <$> promotePat pat -promotePat (DBangP pat) = do - qReportWarning "Strict pattern converted into regular pattern in promotion" - second ADBangP <$> promotePat pat -promotePat (DSigP pat ty) = do - -- We must maintain the invariant that any promoted pattern signature must - -- not have any wildcards in the underlying pattern. - -- See Note [Singling pattern signatures]. - wildless_pat <- removeWilds pat - (promoted, pat') <- promotePat wildless_pat - ki <- promoteType ty - return (DSigT promoted ki, ADSigP promoted pat' ki) -promotePat DWildP = return (DWildCardT, ADWildP) - -promoteExp :: DExp -> PrM (DType, ADExp) -promoteExp (DVarE name) = fmap (, ADVarE name) $ lookupVarE name -promoteExp (DConE name) = do - opts <- getOptions - return (DConT $ defunctionalizedName0 opts name, ADConE name) -promoteExp (DLitE lit) = fmap (, ADLitE lit) $ promoteLitExp lit -promoteExp (DAppE exp1 exp2) = do - (exp1', ann_exp1) <- promoteExp exp1 - (exp2', ann_exp2) <- promoteExp exp2 - return (apply exp1' exp2', ADAppE ann_exp1 ann_exp2) --- Until we get visible kind applications, this is the best we can do. -promoteExp (DAppTypeE exp _) = do - qReportWarning "Visible type applications are ignored by `singletons-th`." - promoteExp exp -promoteExp (DLamE names exp) = do - opts <- getOptions - lambdaName <- newUniqueName "Lambda" - tyNames <- mapM mkTyName names - let var_proms = zip names tyNames - (rhs, ann_exp) <- lambdaBind var_proms $ promoteExp exp - all_locals <- allLocals - let all_args = all_locals ++ tyNames - tvbs = map (`DPlainTV` ()) all_args - emitDecs [DClosedTypeFamilyD (DTypeFamilyHead - lambdaName - tvbs - DNoSig - Nothing) - [DTySynEqn Nothing - (foldType (DConT lambdaName) $ - map DVarT all_args) - rhs]] - emitDecsM $ defunctionalize lambdaName Nothing $ DefunNoSAK tvbs Nothing - let promLambda = foldApply (DConT (defunctionalizedName opts lambdaName 0)) - (map DVarT all_locals) - return (promLambda, ADLamE tyNames promLambda names ann_exp) -promoteExp (DCaseE exp matches) = do - caseTFName <- newUniqueName "Case" - all_locals <- allLocals - let prom_case = foldType (DConT caseTFName) (map DVarT all_locals) - (exp', ann_exp) <- promoteExp exp - (eqns, ann_matches) <- mapAndUnzipM (promoteMatch prom_case) matches - tyvarName <- qNewName "t" - let all_args = all_locals ++ [tyvarName] - tvbs = map (`DPlainTV` ()) all_args - emitDecs [DClosedTypeFamilyD (DTypeFamilyHead caseTFName tvbs DNoSig Nothing) eqns] - -- See Note [Annotate case return type] in Single - let applied_case = prom_case `DAppT` exp' - return ( applied_case - , ADCaseE ann_exp ann_matches applied_case ) -promoteExp (DLetE decs exp) = do - unique <- qNewUnique - (binds, ann_env) <- promoteLetDecs (Just unique) decs - (exp', ann_exp) <- letBind binds $ promoteExp exp - return (exp', ADLetE ann_env ann_exp) -promoteExp (DSigE exp ty) = do - (exp', ann_exp) <- promoteExp exp - ty' <- promoteType ty - return (DSigT exp' ty', ADSigE exp' ann_exp ty') -promoteExp e@(DStaticE _) = fail ("Static expressions cannot be promoted: " ++ show e) - -promoteLitExp :: OptionsMonad q => Lit -> q DType -promoteLitExp (IntegerL n) = do - opts <- getOptions - let tyFromIntegerName = promotedValueName opts fromIntegerName Nothing - tyNegateName = promotedValueName opts negateName Nothing - if n >= 0 - then return $ (DConT tyFromIntegerName `DAppT` DLitT (NumTyLit n)) - else return $ (DConT tyNegateName `DAppT` - (DConT tyFromIntegerName `DAppT` DLitT (NumTyLit (-n)))) -promoteLitExp (StringL str) = do - opts <- getOptions - let prom_str_lit = DLitT (StrTyLit str) - os_enabled <- qIsExtEnabled LangExt.OverloadedStrings - pure $ if os_enabled - then DConT (promotedValueName opts fromStringName Nothing) `DAppT` prom_str_lit - else prom_str_lit -promoteLitExp (CharL c) = return $ DLitT (CharTyLit c) -promoteLitExp lit = - fail ("Only string, natural number, and character literals can be promoted: " ++ show lit) - -promoteLitPat :: MonadFail m => Lit -> m DType -promoteLitPat (IntegerL n) - | n >= 0 = return $ (DLitT (NumTyLit n)) - | otherwise = - fail $ "Negative literal patterns are not allowed,\n" ++ - "because literal patterns are promoted to natural numbers." -promoteLitPat (StringL str) = return $ DLitT (StrTyLit str) -promoteLitPat (CharL c) = return $ DLitT (CharTyLit c) -promoteLitPat lit = - fail ("Only string, natural number, and character literals can be promoted: " ++ show lit) +{- Data/Singletons/TH/Promote.hs + +(c) Richard Eisenberg 2013 +rae@cs.brynmawr.edu + +This file contains functions to promote term-level constructs to the +type level. It is an internal module to the singletons-th package. +-} + +module Data.Singletons.TH.Promote where + +import Language.Haskell.TH hiding ( Q, cxt ) +import Language.Haskell.TH.Syntax ( NameSpace(..), Quasi(..), Uniq ) +import Language.Haskell.TH.Desugar +import qualified Language.Haskell.TH.Desugar.OMap.Strict as OMap +import Language.Haskell.TH.Desugar.OMap.Strict (OMap) +import qualified Language.Haskell.TH.Desugar.OSet as OSet +import Data.Singletons.TH.Deriving.Bounded +import Data.Singletons.TH.Deriving.Enum +import Data.Singletons.TH.Deriving.Eq +import Data.Singletons.TH.Deriving.Ord +import Data.Singletons.TH.Deriving.Show +import Data.Singletons.TH.Deriving.Util +import Data.Singletons.TH.Names +import Data.Singletons.TH.Options +import Data.Singletons.TH.Partition +import Data.Singletons.TH.Promote.Defun +import Data.Singletons.TH.Promote.Monad +import Data.Singletons.TH.Promote.Type +import Data.Singletons.TH.Syntax +import Data.Singletons.TH.Util +import Prelude hiding (exp) +import Control.Applicative (Alternative(..)) +import Control.Arrow (second) +import Control.Monad +import Control.Monad.Trans.Maybe +import Control.Monad.Writer +import Data.List (nub) +import qualified Data.Map.Strict as Map +import Data.Map.Strict ( Map ) +import Data.Maybe +import qualified GHC.LanguageExtensions.Type as LangExt + +{- +Note [Disable genQuotedDecs in genPromotions and genSingletons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Somewhat curiously, the genPromotions and genSingletons functions set the +genQuotedDecs option to False, despite neither function accepting quoted +declarations as arguments in the first place. There is a good reason for doing +this, however. Imagine this code: + + class C a where + infixl 9 <%%> + (<%%>) :: a -> a -> a + $(genPromotions [''C]) + +If genQuotedDecs is set to True, then the (<%%>) type family will not receive +a fixity declaration (see +Note [singletons-th and fixity declarations] in D.S.TH.Single.Fixity, wrinkle 1 for +more details on this point). Therefore, we set genQuotedDecs to False to avoid +this problem. +-} + +-- | Generate promoted definitions for each of the provided type-level +-- declaration 'Name's. This is generally only useful with classes. +genPromotions :: OptionsMonad q => [Name] -> q [Dec] +genPromotions names = do + opts <- getOptions + -- See Note [Disable genQuotedDecs in genPromotions and genSingletons] + withOptions opts{genQuotedDecs = False} $ do + checkForRep names + infos <- mapM reifyWithLocals names + dinfos <- mapM dsInfo infos + ddecs <- promoteM_ [] $ mapM_ promoteInfo dinfos + return $ decsToTH ddecs + +-- | Promote every declaration given to the type level, retaining the originals. +-- See the +-- @@ +-- for further explanation. +promote :: OptionsMonad q => q [Dec] -> q [Dec] +promote qdecs = do + opts <- getOptions + withOptions opts{genQuotedDecs = True} $ promote' $ lift qdecs + +-- | Promote each declaration, discarding the originals. Note that a promoted +-- datatype uses the same definition as an original datatype, so this will +-- not work with datatypes. Classes, instances, and functions are all fine. +promoteOnly :: OptionsMonad q => q [Dec] -> q [Dec] +promoteOnly qdecs = do + opts <- getOptions + withOptions opts{genQuotedDecs = False} $ promote' $ lift qdecs + +-- The workhorse for 'promote' and 'promoteOnly'. The difference between the +-- two functions is whether 'genQuotedDecs' is set to 'True' or 'False'. +promote' :: OptionsMonad q => q [Dec] -> q [Dec] +promote' qdecs = do + opts <- getOptions + decs <- qdecs + ddecs <- withLocalDeclarations decs $ dsDecs decs + promDecs <- promoteM_ decs $ promoteDecs ddecs + let origDecs | genQuotedDecs opts = decs + | otherwise = [] + return $ origDecs ++ decsToTH promDecs + +-- | Generate defunctionalization symbols for each of the provided type-level +-- declaration 'Name's. See the "Promotion and partial application" section of +-- the @singletons@ +-- @@ +-- for further explanation. +genDefunSymbols :: OptionsMonad q => [Name] -> q [Dec] +genDefunSymbols names = do + checkForRep names + infos <- mapM (dsInfo <=< reifyWithLocals) names + decs <- promoteMDecs [] $ concatMapM defunInfo infos + return $ decsToTH decs + +-- | Produce instances for @PEq@ from the given types +promoteEqInstances :: OptionsMonad q => [Name] -> q [Dec] +promoteEqInstances = concatMapM promoteEqInstance + +-- | Produce an instance for @PEq@ from the given type +promoteEqInstance :: OptionsMonad q => Name -> q [Dec] +promoteEqInstance = promoteInstance mkEqInstance "Eq" + +-- | Produce instances for 'POrd' from the given types +promoteOrdInstances :: OptionsMonad q => [Name] -> q [Dec] +promoteOrdInstances = concatMapM promoteOrdInstance + +-- | Produce an instance for 'POrd' from the given type +promoteOrdInstance :: OptionsMonad q => Name -> q [Dec] +promoteOrdInstance = promoteInstance mkOrdInstance "Ord" + +-- | Produce instances for 'PBounded' from the given types +promoteBoundedInstances :: OptionsMonad q => [Name] -> q [Dec] +promoteBoundedInstances = concatMapM promoteBoundedInstance + +-- | Produce an instance for 'PBounded' from the given type +promoteBoundedInstance :: OptionsMonad q => Name -> q [Dec] +promoteBoundedInstance = promoteInstance mkBoundedInstance "Bounded" + +-- | Produce instances for 'PEnum' from the given types +promoteEnumInstances :: OptionsMonad q => [Name] -> q [Dec] +promoteEnumInstances = concatMapM promoteEnumInstance + +-- | Produce an instance for 'PEnum' from the given type +promoteEnumInstance :: OptionsMonad q => Name -> q [Dec] +promoteEnumInstance = promoteInstance mkEnumInstance "Enum" + +-- | Produce instances for 'PShow' from the given types +promoteShowInstances :: OptionsMonad q => [Name] -> q [Dec] +promoteShowInstances = concatMapM promoteShowInstance + +-- | Produce an instance for 'PShow' from the given type +promoteShowInstance :: OptionsMonad q => Name -> q [Dec] +promoteShowInstance = promoteInstance mkShowInstance "Show" + +promoteInstance :: OptionsMonad q => DerivDesc q -> String -> Name -> q [Dec] +promoteInstance mk_inst class_name name = do + (df, tvbs, cons) <- getDataD ("I cannot make an instance of " ++ class_name + ++ " for it.") name + tvbs' <- mapM dsTvbVis tvbs + let data_ty = foldTypeTvbs (DConT name) tvbs' + cons' <- concatMapM (dsCon tvbs' data_ty) cons + let data_decl = DataDecl df name tvbs' cons' + raw_inst <- mk_inst Nothing data_ty data_decl + decs <- promoteM_ [] $ void $ + promoteInstanceDec OMap.empty Map.empty raw_inst + return $ decsToTH decs + +promoteInfo :: DInfo -> PrM () +promoteInfo (DTyConI dec _instances) = promoteDecs [dec] +promoteInfo (DPrimTyConI _name _numArgs _unlifted) = + fail "Promotion of primitive type constructors not supported" +promoteInfo (DVarI _name _ty _mdec) = + fail "Promotion of individual values not supported" +promoteInfo (DTyVarI _name _ty) = + fail "Promotion of individual type variables not supported" +promoteInfo (DPatSynI {}) = + fail "Promotion of pattern synonyms not supported" + +-- Promote a list of top-level declarations. +promoteDecs :: [DDec] -> PrM () +promoteDecs raw_decls = do + decls <- expand raw_decls -- expand type synonyms + checkForRepInDecls decls + PDecs { pd_let_decs = let_decs + , pd_class_decs = classes + , pd_instance_decs = insts + , pd_data_decs = datas + , pd_ty_syn_decs = ty_syns + , pd_open_type_family_decs = o_tyfams + , pd_closed_type_family_decs = c_tyfams } <- partitionDecs decls + + defunTopLevelTypeDecls ty_syns c_tyfams o_tyfams + rec_sel_let_decs <- promoteDataDecs datas + -- promoteLetDecs returns LetBinds, which we don't need at top level + _ <- promoteLetDecs Nothing $ rec_sel_let_decs ++ let_decs + mapM_ promoteClassDec classes + let orig_meth_sigs = foldMap (lde_types . cd_lde) classes + cls_tvbs_map = Map.fromList $ map (\cd -> (cd_name cd, cd_tvbs cd)) classes + mapM_ (promoteInstanceDec orig_meth_sigs cls_tvbs_map) insts + +-- curious about ALetDecEnv? See the LetDecEnv module for an explanation. +promoteLetDecs :: Maybe Uniq -- let-binding unique (if locally bound) + -> [DLetDec] -> PrM ([LetBind], ALetDecEnv) +promoteLetDecs mb_let_uniq decls = do + opts <- getOptions + let_dec_env <- buildLetDecEnv decls + all_locals <- allLocals + let binds = [ (name, foldType (DConT sym) (map DVarT all_locals)) + | (name, _) <- OMap.assocs $ lde_defns let_dec_env + , let proName = promotedValueName opts name mb_let_uniq + sym = defunctionalizedName opts proName (length all_locals) ] + (decs, let_dec_env') <- letBind binds $ promoteLetDecEnv mb_let_uniq let_dec_env + emitDecs decs + return (binds, let_dec_env' { lde_proms = OMap.fromList binds }) + +promoteDataDecs :: [DataDecl] -> PrM [DLetDec] +promoteDataDecs = concatMapM promoteDataDec + +-- "Promotes" a data type, much like D.S.TH.Single.Data.singDataD singles a data +-- type. Promoting a data type is much easier than singling it, however, since +-- DataKinds automatically promotes data types and kinds and data constructors +-- to types. That means that promoteDataDec only has to do three things: +-- +-- 1. Emit defunctionalization symbols for each data constructor, +-- +-- 2. Emit promoted fixity declarations for each data constructor and promoted +-- record selector (assuming the originals have fixity declarations), and +-- +-- 3. Assemble a top-level function that mimics the behavior of its record +-- selectors. Note that promoteDataDec does not actually promote this record +-- selector function—it merely returns its DLetDecs. Later, the promoteDecs +-- function takes these DLetDecs and promotes them (using promoteLetDecs). +-- This greatly simplifies the plumbing, since this allows all DLetDecs to +-- be promoted in a single location. +-- See Note [singletons-th and record selectors] in D.S.TH.Single.Data. +-- +-- Note that if @NoFieldSelectors@ is active, then neither steps (2) nor (3) +-- will promote any records to top-level field selectors. +promoteDataDec :: DataDecl -> PrM [DLetDec] +promoteDataDec (DataDecl _ _ _ ctors) = do + let rec_sel_names = nub $ concatMap extractRecSelNames ctors + -- Note the use of nub: the same record selector name can + -- be used in multiple constructors! + fld_sels <- qIsExtEnabled LangExt.FieldSelectors + rec_sel_let_decs <- if fld_sels then getRecordSelectors ctors else pure [] + ctorSyms <- buildDefunSymsDataD ctors + -- NB: If NoFieldSelectors is active, then promoteReifiedInfixDecls will not + -- promote any of `rec_sel_names` to field selectors, so there is no need to + -- check for it here. + infix_decs <- promoteReifiedInfixDecls rec_sel_names + emitDecs $ ctorSyms ++ infix_decs + pure rec_sel_let_decs + +promoteClassDec :: UClassDecl -> PrM AClassDecl +promoteClassDec decl@(ClassDecl { cd_name = cls_name + , cd_tvbs = tvbs + , cd_fds = fundeps + , cd_atfs = atfs + , cd_lde = lde@LetDecEnv + { lde_defns = defaults + , lde_types = meth_sigs + , lde_infix = infix_decls } }) = do + opts <- getOptions + let pClsName = promotedClassName opts cls_name + meth_sigs_list = OMap.assocs meth_sigs + meth_names = map fst meth_sigs_list + defaults_list = OMap.assocs defaults + defaults_names = map fst defaults_list + mb_cls_sak <- dsReifyType cls_name + sig_decs <- mapM (uncurry promote_sig) meth_sigs_list + (default_decs, ann_rhss, prom_rhss) + <- mapAndUnzip3M (promoteMethod DefaultMethods meth_sigs) defaults_list + defunAssociatedTypeFamilies tvbs atfs + + infix_decls' <- mapMaybeM (uncurry (promoteInfixDecl Nothing)) $ + OMap.assocs infix_decls + cls_infix_decls <- promoteReifiedInfixDecls $ cls_name:meth_names + + -- no need to do anything to the fundeps. They work as is! + let pro_cls_dec = DClassD [] pClsName tvbs fundeps + (sig_decs ++ default_decs ++ infix_decls') + mb_pro_cls_sak = fmap (DKiSigD pClsName) mb_cls_sak + emitDecs $ maybeToList mb_pro_cls_sak ++ pro_cls_dec:cls_infix_decls + let defaults_list' = zip defaults_names ann_rhss + proms = zip defaults_names prom_rhss + return (decl { cd_lde = lde { lde_defns = OMap.fromList defaults_list' + , lde_proms = OMap.fromList proms } }) + where + promote_sig :: Name -> DType -> PrM DDec + promote_sig name ty = do + opts <- getOptions + let proName = promotedTopLevelValueName opts name + -- When computing the kind to use for the defunctionalization symbols, + -- /don't/ use the type variable binders from the method's type... + (_, argKs, resK) <- promoteUnraveled ty + args <- mapM (const $ qNewName "arg") argKs + let proTvbs = zipWith (`DKindedTV` BndrReq) args argKs + -- ...instead, compute the type variable binders in a left-to-right order, + -- since that is the same order that the promoted method's kind will use. + -- See Note [Promoted class methods and kind variable ordering] + meth_sak_tvbs = changeDTVFlags SpecifiedSpec $ + toposortTyVarsOf $ argKs ++ [resK] + meth_sak = ravelVanillaDType meth_sak_tvbs [] argKs resK + m_fixity <- reifyFixityWithLocals name + emitDecsM $ defunctionalize proName m_fixity $ DefunSAK meth_sak + + return $ DOpenTypeFamilyD (DTypeFamilyHead proName + proTvbs + (DKindSig resK) + Nothing) + +{- +Note [Promoted class methods and kind variable ordering] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general, we make an effort to preserve the order of type variables when +promoting type signatures, but there is an annoying corner case where this is +difficult: class methods. When promoting class methods, the order of kind +variables in their kinds will often "just work" by happy coincidence, but +there are some situations where this does not happen. Consider the following +class: + + class C (b :: Type) where + m :: forall a. a -> b -> a + +The full type of `m` is `forall b. C b => forall a. a -> b -> a`, which binds +`b` before `a`. This order is preserved when singling `m`, but *not* when +promoting `m`. This is because the `C` class is promoted as follows: + + class PC (b :: Type) where + type M (x :: a) (y :: b) :: a + +Due to the way GHC kind-checks associated type families, the kind of `M` is +`forall a b. a -> b -> a`, which binds `b` *after* `a`. Moreover, the +`StandaloneKindSignatures` extension does not provide a way to explicitly +declare the full kind of an associated type family, so this limitation is +not easy to work around. + +The defunctionalization symbols for `M` will also follow a similar +order of type variables: + + type MSym0 :: forall a b. a ~> b ~> a + type MSym1 :: forall a b. a -> b ~> a + +There is one potential hack we could use to rectify this: + + type FlipConst x y = y + class PC (b :: Type) where + type M (x :: FlipConst '(b, a) a) (y :: b) :: a + +Using `FlipConst` would cause `b` to be mentioned before `a`, which would give +`M` the kind `forall b a. FlipConst '(b, a) a -> b -> a`. While the order of +type variables would be preserved, the downside is that the ugly `FlipConst` +type synonym leaks into the kind. I'm not particularly fond of this, so I have +decided not to use this hack unless someone specifically requests it. +-} + +-- returns (unpromoted method name, ALetDecRHS) pairs +promoteInstanceDec :: OMap Name DType + -- Class method type signatures + -> Map Name [DTyVarBndrVis] + -- Class header type variable (e.g., if `class C a b` is + -- quoted, then this will have an entry for {C |-> [a, b]}) + -> UInstDecl -> PrM AInstDecl +promoteInstanceDec orig_meth_sigs cls_tvbs_map + decl@(InstDecl { id_name = cls_name + , id_arg_tys = inst_tys + , id_sigs = inst_sigs + , id_meths = meths }) = do + opts <- getOptions + cls_tvbs <- lookup_cls_tvbs + inst_kis <- mapM promoteType inst_tys + let pClsName = promotedClassName opts cls_name + cls_tvb_names = map extractTvbName cls_tvbs + subst = Map.fromList $ zip cls_tvb_names inst_kis + meth_impl = InstanceMethods inst_sigs subst + (meths', ann_rhss, _) + <- mapAndUnzip3M (promoteMethod meth_impl orig_meth_sigs) meths + emitDecs [DInstanceD Nothing Nothing [] (foldType (DConT pClsName) + inst_kis) meths'] + return (decl { id_meths = zip (map fst meths) ann_rhss }) + where + lookup_cls_tvbs :: PrM [DTyVarBndrVis] + lookup_cls_tvbs = + -- First, try consulting the map of class names to their type variables. + -- It is important to do this first to ensure that we consider locally + -- declared classes before imported ones. See #410 for what happens if + -- you don't. + case Map.lookup cls_name cls_tvbs_map of + Just tvbs -> pure tvbs + Nothing -> reify_cls_tvbs + -- If the class isn't present in this map, we try reifying the class + -- as a last resort. + + reify_cls_tvbs :: PrM [DTyVarBndrVis] + reify_cls_tvbs = do + opts <- getOptions + let pClsName = promotedClassName opts cls_name + mk_tvbs = extract_tvbs (dsReifyTypeNameInfo pClsName) + <|> extract_tvbs (dsReifyTypeNameInfo cls_name) + -- See Note [Using dsReifyTypeNameInfo when promoting instances] + mb_tvbs <- runMaybeT mk_tvbs + case mb_tvbs of + Just tvbs -> pure tvbs + Nothing -> fail $ "Cannot find class declaration annotation for " ++ show cls_name + + extract_tvbs :: PrM (Maybe DInfo) -> MaybeT PrM [DTyVarBndrVis] + extract_tvbs reify_info = do + mb_info <- lift reify_info + case mb_info of + Just (DTyConI (DClassD _ _ tvbs _ _) _) -> pure tvbs + _ -> empty + +{- +Note [Using dsReifyTypeNameInfo when promoting instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +During the promotion of a class instance, it becomes necessary to reify the +original promoted class's info to learn various things. It's tempting to think +that just calling dsReify on the class name will be sufficient, but it's not. +Consider this class and its promotion: + + class Eq a where + (==) :: a -> a -> Bool + + class PEq a where + type (==) (x :: a) (y :: a) :: Bool + +Notice how both of these classes have an identifier named (==), one at the +value level, and one at the type level. Now imagine what happens when you +attempt to promote this Template Haskell declaration: + + [d| f :: Bool + f = () == () |] + +When promoting ==, singletons-th will come up with its promoted equivalent (which also +happens to be ==). However, this promoted name is a raw Name, since it is created +with mkName. This becomes an issue when we call dsReify the raw "==" Name, as +Template Haskell has to arbitrarily choose between reifying the info for the +value-level (==) and the type-level (==), and in this case, it happens to pick the +value-level (==) info. We want the type-level (==) info, however, because we care +about the promoted version of (==). + +Fortunately, there's a serviceable workaround. Instead of dsReify, we can use +dsReifyTypeNameInfo, which first calls lookupTypeName (to ensure we can find a Name +that's in the type namespace) and _then_ reifies it. +-} + +-- Which sort of class methods are being promoted? +data MethodSort + -- The method defaults in class declarations. + = DefaultMethods + -- The methods in instance declarations. + | InstanceMethods (OMap Name DType) -- ^ InstanceSigs + (Map Name DKind) -- ^ Instantiations for class tyvars + -- See Note [Promoted class method kinds] + deriving Show + +promoteMethod :: MethodSort + -> OMap Name DType -- method types + -> (Name, ULetDecRHS) + -> PrM (DDec, ALetDecRHS, DType) + -- returns (type instance, ALetDecRHS, promoted RHS) +promoteMethod meth_sort orig_sigs_map (meth_name, meth_rhs) = do + opts <- getOptions + (meth_arg_kis, meth_res_ki) <- promote_meth_ty + meth_arg_tvs <- replicateM (length meth_arg_kis) (qNewName "a") + let proName = promotedTopLevelValueName opts meth_name + helperNameBase = case nameBase proName of + first:_ | not (isHsLetter first) -> "TFHelper" + alpha -> alpha + + -- family_args are the type variables in a promoted class's + -- associated type family instance (or default implementation), e.g., + -- + -- class C k where + -- type T (a :: k) (b :: Bool) + -- type T a b = THelper1 a b -- family_args = [a, b] + -- + -- instance C Bool where + -- type T a b = THelper2 a b -- family_args = [a, b] + -- + -- We could annotate these variables with explicit kinds, but it's not + -- strictly necessary, as kind inference can figure them out just as well. + family_args = map DVarT meth_arg_tvs + helperName <- newUniqueName helperNameBase + let helperDefunName = defunctionalizedName0 opts helperName + (pro_decs, defun_decs, ann_rhs) + <- promoteLetDecRHS (ClassMethodRHS meth_arg_kis meth_res_ki) + OMap.empty OMap.empty + Nothing helperName meth_rhs + emitDecs (pro_decs ++ defun_decs) + return ( DTySynInstD + (DTySynEqn Nothing + (foldType (DConT proName) family_args) + (foldApply (DConT helperDefunName) (map DVarT meth_arg_tvs))) + , ann_rhs + , DConT helperDefunName ) + where + -- Promote the type of a class method. For a default method, "the type" is + -- simply the type of the original method. For an instance method, + -- "the type" is like the type of the original method, but substituted for + -- the types in the instance head. (e.g., if you have `class C a` and + -- `instance C T`, then the substitution [a |-> T] must be applied to the + -- original method's type.) + promote_meth_ty :: PrM ([DKind], DKind) + promote_meth_ty = + case meth_sort of + DefaultMethods -> + -- No substitution for class variables is required for default + -- method type signatures, as they share type variables with the + -- class they inhabit. + lookup_meth_ty + InstanceMethods inst_sigs_map cls_subst -> + case OMap.lookup meth_name inst_sigs_map of + Just ty -> do + -- We have an InstanceSig. These are easy: we can just use the + -- instance signature's type directly, and no substitution for + -- class variables is required. + (_tvbs, arg_kis, res_ki) <- promoteUnraveled ty + pure (arg_kis, res_ki) + Nothing -> do + -- We don't have an InstanceSig, so we must compute the kind to use + -- ourselves. + (arg_kis, res_ki) <- lookup_meth_ty + -- Substitute for the class variables in the method's type. + -- See Note [Promoted class method kinds] + let arg_kis' = map (substKind cls_subst) arg_kis + res_ki' = substKind cls_subst res_ki + pure (arg_kis', res_ki') + + -- Attempt to look up a class method's original type. + lookup_meth_ty :: PrM ([DKind], DKind) + lookup_meth_ty = do + opts <- getOptions + let proName = promotedTopLevelValueName opts meth_name + case OMap.lookup meth_name orig_sigs_map of + Just ty -> do + -- The type of the method is in scope, so promote that. + (_tvbs, arg_kis, res_ki) <- promoteUnraveled ty + pure (arg_kis, res_ki) + Nothing -> do + -- If the type of the method is not in scope, the only other option + -- is to try reifying the promoted method name. + mb_info <- dsReifyTypeNameInfo proName + -- See Note [Using dsReifyTypeNameInfo when promoting instances] + case mb_info of + Just (DTyConI (DOpenTypeFamilyD (DTypeFamilyHead _ tvbs mb_res_ki _)) _) + -> let arg_kis = map (defaultMaybeToTypeKind . extractTvbKind) tvbs + res_ki = defaultMaybeToTypeKind (resultSigToMaybeKind mb_res_ki) + in pure (arg_kis, res_ki) + _ -> fail $ "Cannot find type annotation for " ++ show proName + +{- +Note [Promoted class method kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this example of a type class (and instance): + + class C a where + m :: a -> Bool -> Bool + m _ x = x + + instance C [a] where + m l _ = null l + +The promoted version of these declarations would be: + + class PC a where + type M (x :: a) (y :: Bool) :: Bool + type M x y = MHelper1 x y + + instance PC [a] where + type M x y = MHelper2 x y + + type MHelper1 :: a -> Bool -> Bool + type family MHelper1 x y where ... + + type MHelper2 :: [a] -> Bool -> Bool + type family MHelper2 x y where ... + +Getting the kind signature for MHelper1 (the promoted default implementation of +M) is quite simple, as it corresponds exactly to the kind of M. We might even +choose to make that the kind of MHelper2, but then it would be overly general +(and more difficult to find in -ddump-splices output). For this reason, we +substitute in the kinds of the instance itself to determine the kinds of +promoted method implementations like MHelper2. +-} + +promoteLetDecEnv :: Maybe Uniq -> ULetDecEnv -> PrM ([DDec], ALetDecEnv) +promoteLetDecEnv mb_let_uniq (LetDecEnv { lde_defns = value_env + , lde_types = type_env + , lde_infix = fix_env }) = do + infix_decls <- mapMaybeM (uncurry (promoteInfixDecl mb_let_uniq)) $ + OMap.assocs fix_env + + -- promote all the declarations, producing annotated declarations + let (names, rhss) = unzip $ OMap.assocs value_env + (pro_decs, defun_decss, ann_rhss) + <- fmap unzip3 $ + zipWithM (promoteLetDecRHS LetBindingRHS type_env fix_env mb_let_uniq) + names rhss + + emitDecs $ concat defun_decss + let decs = concat pro_decs ++ infix_decls + + -- build the ALetDecEnv + let let_dec_env' = LetDecEnv { lde_defns = OMap.fromList $ zip names ann_rhss + , lde_types = type_env + , lde_infix = fix_env + , lde_proms = OMap.empty -- filled in promoteLetDecs + } + + return (decs, let_dec_env') + +-- Promote a fixity declaration. +promoteInfixDecl :: forall q. OptionsMonad q + => Maybe Uniq -> Name -> Fixity -> q (Maybe DDec) +promoteInfixDecl mb_let_uniq name fixity = do + opts <- getOptions + fld_sels <- qIsExtEnabled LangExt.FieldSelectors + mb_ns <- reifyNameSpace name + case mb_ns of + -- If we can't find the Name for some odd reason, fall back to promote_val + Nothing -> promote_val + Just VarName -> promote_val + Just (FldName _) + | fld_sels -> promote_val + | otherwise -> never_mind + Just DataName -> never_mind + Just TcClsName -> do + mb_info <- dsReify name + case mb_info of + Just (DTyConI DClassD{} _) + -> finish $ promotedClassName opts name + _ -> never_mind + where + -- Produce the fixity declaration. + finish :: Name -> q (Maybe DDec) + finish = pure . Just . DLetDec . DInfixD fixity + + -- Don't produce a fixity declaration at all. This can happen in the + -- following circumstances: + -- + -- - When promoting a fixity declaration for a name whose promoted + -- counterpart is the same as the original name. + -- See Note [singletons-th and fixity declarations] in + -- D.S.TH.Single.Fixity, wrinkle 1. + -- + -- - A fixity declaration contains the name of a record selector when + -- NoFieldSelectors is active. + never_mind :: q (Maybe DDec) + never_mind = pure Nothing + + -- Certain value names do not change when promoted (e.g., infix names). + -- Therefore, don't bother promoting their fixity declarations if + -- 'genQuotedDecs' is set to 'True', since that will run the risk of + -- generating duplicate fixity declarations. + -- See Note [singletons-th and fixity declarations] in D.S.TH.Single.Fixity, wrinkle 1. + promote_val :: q (Maybe DDec) + promote_val = do + opts <- getOptions + let promoted_name :: Name + promoted_name = promotedValueName opts name mb_let_uniq + if nameBase name == nameBase promoted_name && genQuotedDecs opts + then never_mind + else finish promoted_name + +-- Try producing promoted fixity declarations for Names by reifying them +-- /without/ consulting quoted declarations. If reification fails, recover and +-- return the empty list. +-- See [singletons-th and fixity declarations] in D.S.TH.Single.Fixity, wrinkle 2. +promoteReifiedInfixDecls :: forall q. OptionsMonad q => [Name] -> q [DDec] +promoteReifiedInfixDecls = mapMaybeM tryPromoteFixityDeclaration + where + tryPromoteFixityDeclaration :: Name -> q (Maybe DDec) + tryPromoteFixityDeclaration name = + qRecover (return Nothing) $ do + mFixity <- qReifyFixity name + case mFixity of + Nothing -> pure Nothing + Just fixity -> promoteInfixDecl Nothing name fixity + +-- Which sort of let-bound declaration's right-hand side is being promoted? +data LetDecRHSSort + -- An ordinary (i.e., non-class-related) let-bound declaration. + = LetBindingRHS + -- The right-hand side of a class method (either a default method or a + -- method in an instance declaration). + | ClassMethodRHS + [DKind] DKind + -- The RHS's promoted argument and result types. Needed to fix #136. + deriving Show + +-- This function is used both to promote class method defaults and normal +-- let bindings. Thus, it can't quite do all the work locally and returns +-- an intermediate structure. Perhaps a better design is available. +promoteLetDecRHS :: LetDecRHSSort + -> OMap Name DType -- local type env't + -> OMap Name Fixity -- local fixity env't + -> Maybe Uniq -- let-binding unique (if locally bound) + -> Name -- name of the thing being promoted + -> ULetDecRHS -- body of the thing + -> PrM ( [DDec] -- promoted type family dec, plus the + -- SAK dec (if one exists) + , [DDec] -- defunctionalization + , ALetDecRHS ) -- annotated RHS +promoteLetDecRHS rhs_sort type_env fix_env mb_let_uniq name let_dec_rhs = do + all_locals <- allLocals + case let_dec_rhs of + UValue exp -> do + (m_ldrki, ty_num_args) <- promote_let_dec_ty all_locals 0 + if ty_num_args == 0 + then do + prom_fun_lhs <- promoteLetDecName mb_let_uniq name m_ldrki all_locals + promote_let_dec_rhs all_locals m_ldrki 0 (promoteExp exp) + (\exp' -> [DTySynEqn Nothing prom_fun_lhs exp']) + AValue + else + -- If we have a UValue with a function type, process it as though it + -- were a UFunction. promote_function_rhs will take care of + -- eta-expanding arguments as necessary. + promote_function_rhs all_locals [DClause [] exp] + UFunction clauses -> promote_function_rhs all_locals clauses + where + -- Promote the RHS of a UFunction (or a UValue with a function type). + promote_function_rhs :: [Name] + -> [DClause] -> PrM ([DDec], [DDec], ALetDecRHS) + promote_function_rhs all_locals clauses = do + numArgs <- count_args clauses + (m_ldrki, ty_num_args) <- promote_let_dec_ty all_locals numArgs + expClauses <- mapM (etaContractOrExpand ty_num_args numArgs) clauses + let promote_clause = promoteClause mb_let_uniq name m_ldrki all_locals + promote_let_dec_rhs all_locals m_ldrki ty_num_args + (mapAndUnzipM promote_clause expClauses) + id (AFunction ty_num_args) + + -- Promote a UValue or a UFunction. + -- Notes about type variables: + -- + -- * For UValues, `prom_a` is DType and `a` is Exp. + -- + -- * For UFunctions, `prom_a` is [DTySynEqn] and `a` is [DClause]. + promote_let_dec_rhs + :: [Name] -- Local variables bound in this scope + -> Maybe LetDecRHSKindInfo -- Information about the promoted kind (if present) + -> Int -- The number of promoted function arguments + -> PrM (prom_a, a) -- Promote the RHS + -> (prom_a -> [DTySynEqn]) -- Turn the promoted RHS into type family equations + -> (a -> ALetDecRHS) -- Build an ALetDecRHS + -> PrM ([DDec], [DDec], ALetDecRHS) + promote_let_dec_rhs all_locals m_ldrki ty_num_args + promote_thing mk_prom_eqns mk_alet_dec_rhs = do + opts <- getOptions + tyvarNames <- replicateM ty_num_args (qNewName "a") + let proName = promotedValueName opts name mb_let_uniq + local_tvbs = map (`DPlainTV` BndrReq) all_locals + m_fixity = OMap.lookup name fix_env + + mk_tf_head :: [DTyVarBndrVis] -> DFamilyResultSig -> DTypeFamilyHead + mk_tf_head arg_tvbs res_sig = + dTypeFamilyHead_with_locals proName all_locals arg_tvbs res_sig + + (lde_kvs_to_bind, m_sak_dec, defun_ki, tf_head) = + -- There are three possible cases: + case m_ldrki of + -- 1. We have no kind information whatsoever. + Nothing -> + let arg_tvbs = map (`DPlainTV` BndrReq) tyvarNames in + ( OSet.empty + , Nothing + , DefunNoSAK (local_tvbs ++ arg_tvbs) Nothing + , mk_tf_head arg_tvbs DNoSig + ) + -- 2. We have some kind information in the form of a LetDecRHSKindInfo. + Just (LDRKI m_sak tvbs argKs resK) -> + let arg_tvbs = zipWith (`DKindedTV` BndrReq) tyvarNames argKs + lde_kvs_to_bind' = OSet.fromList (map extractTvbName tvbs) in + case m_sak of + -- 2(a). We do not have a standalone kind signature. + Nothing -> + ( lde_kvs_to_bind' + , Nothing + , DefunNoSAK (local_tvbs ++ arg_tvbs) (Just resK) + , mk_tf_head arg_tvbs (DKindSig resK) + ) + -- 2(b). We have a standalone kind signature. + Just sak -> + ( lde_kvs_to_bind' + , Just $ DKiSigD proName sak + , DefunSAK sak + -- We opt to annotate the argument and result kinds in + -- the body of the type family declaration even if it is + -- given a standalone kind signature. + -- See Note [Keep redundant kind information for Haddocks]. + , mk_tf_head arg_tvbs (DKindSig resK) + ) + + defun_decs <- defunctionalize proName m_fixity defun_ki + (prom_thing, thing) <- scopedBind lde_kvs_to_bind promote_thing + return ( catMaybes [ m_sak_dec + , Just $ DClosedTypeFamilyD tf_head (mk_prom_eqns prom_thing) + ] + , defun_decs + , mk_alet_dec_rhs thing ) + + promote_let_dec_ty :: [Name] -- The local variables that the let-dec closes + -- over. If this is non-empty, we cannot + -- produce a standalone kind signature. + -- See Note [No SAKs for let-decs with local variables] + -> Int -- The number of arguments to default to if the + -- type cannot be inferred. This is 0 for UValues + -- and the number of arguments in a single clause + -- for UFunctions. + -> PrM (Maybe LetDecRHSKindInfo, Int) + -- Returns two things in a pair: + -- + -- 1. Information about the promoted kind, + -- if available. + -- + -- 2. The number of arguments the let-dec has. + -- If no kind information is available from + -- which to infer this number, then this + -- will default to the earlier Int argument. + promote_let_dec_ty all_locals default_num_args = + case rhs_sort of + ClassMethodRHS arg_kis res_ki + -> -- For class method RHS helper functions, don't bother quantifying + -- any type variables in their SAKS. We could certainly try, but + -- given that these functions are only used internally, there's no + -- point in trying to get the order of type variables correct, + -- since we don't apply these functions with visible kind + -- applications. + let sak = ravelVanillaDType [] [] arg_kis res_ki in + return (Just (LDRKI (Just sak) [] arg_kis res_ki), length arg_kis) + LetBindingRHS + | Just ty <- OMap.lookup name type_env + -> do + -- promoteType turns rank-1 uses of (->) into (~>). So, we unravel + -- first to avoid this behavior, and then ravel back. + (tvbs, argKs, resultK) <- promoteUnraveled ty + let m_sak | null all_locals = Just $ ravelVanillaDType tvbs [] argKs resultK + -- If this let-dec closes over local variables, then + -- don't give it a SAK. + -- See Note [No SAKs for let-decs with local variables] + | otherwise = Nothing + -- invariant: count_args ty == length argKs + return (Just (LDRKI m_sak tvbs argKs resultK), length argKs) + + | otherwise + -> return (Nothing, default_num_args) + + etaContractOrExpand :: Int -> Int -> DClause -> PrM DClause + etaContractOrExpand ty_num_args clause_num_args (DClause pats exp) + | n >= 0 = do -- Eta-expand + names <- replicateM n (newUniqueName "a") + let newPats = map DVarP names + newArgs = map DVarE names + return $ DClause (pats ++ newPats) (foldExp exp newArgs) + | otherwise = do -- Eta-contract + let (clausePats, lamPats) = splitAt ty_num_args pats + lamExp <- mkDLamEFromDPats lamPats exp + return $ DClause clausePats lamExp + where + n = ty_num_args - clause_num_args + + count_args :: [DClause] -> PrM Int + count_args (DClause pats _ : _) = return $ length pats + count_args _ = fail $ "Impossible! A function without clauses." + +-- An auxiliary data type used in promoteLetDecRHS that describes information +-- related to the promoted kind of a class method default or normal +-- let binding. +data LetDecRHSKindInfo = + LDRKI (Maybe DKind) -- The standalone kind signature, if applicable. + -- This will be Nothing if the let-dec RHS has local + -- variables that it closes over. + -- See Note [No SAKs for let-decs with local variables] + [DTyVarBndrSpec] -- The type variable binders of the kind. + [DKind] -- The argument kinds. + DKind -- The result kind. + +{- +Note [No SAKs for let-decs with local variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider promoting this: + + f :: Bool + f = let x = True + g :: () -> Bool + g _ = x + in g () + +Clearly, the promoted `F` type family will have the following SAK: + + type F :: () + +What about `G`? At a passing glance, it appears that you could get away with +this: + + type G :: Bool -> () + +But this isn't quite right, since `g` closes over `x = True`. The body of `G`, +therefore, has to lift `x` to be an explicit argument: + + type family G x (u :: ()) :: Bool where + G x _ = x + +At present, we don't keep track of the types of local variables like `x`, which +makes it difficult to create a SAK for things like `G`. Here are some possible +ideas, each followed by explanations for why they are infeasible: + +* Use wildcards: + + type G :: _ -> () -> Bool + + Alas, GHC currently does not allow wildcards in SAKs. See GHC#17432. + +* Use visible dependent quantification to avoid having to say what the kind + of `x` is: + + type G :: forall x -> () -> Bool + + A clever trick to be sure, but it doesn't quite do what we want, since + GHC will generalize that kind to become `forall (x :: k) -> () -> Bool`, + which is more general than we want. + +In any case, it's probably not worth bothering with SAKs for local definitions +like `g` in the first place, so we avoid generating SAKs for anything that +closes over at least one local variable for now. If someone yells about this, +we'll reconsider this design. + +Note [Keep redundant kind information for Haddocks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +`singletons-th` generates explicit argument kinds and result kinds for +type-level declarations whenever possible, even if those kinds are technically +redundant. For example, `singletons-th` would promote this: + + id' :: a -> a + +To this: + + type Id' :: a -> a + type family Id' (x :: a) :: a where ... + +Strictly speaking, the argument and result kind of Id' are unnecessary, since +the same information is already present in the standalone kind signature. +However, due to a Haddock limitation +(https://github.com/haskell/haddock/issues/1178), Haddock will not render +standalone kind signatures at all, so if the argument and result kind of Id' +were omitted in the body, Haddock would render it like so: + + type family Id' x where ... + +This is unfortunate for Haddock viewers, as this does not convey any kind +information whatsoever. Until the aformentioned Haddock issue is resolved, we +work around this limitation by generating the redundant argument and kind +information anyway. Thankfully, this is simple to accomplish, as we already +compute this information to begin with. +-} + +promoteClause :: Maybe Uniq + -- ^ Let-binding unique (if locally bound) + -> Name + -- ^ Name of the function being promoted + -> Maybe LetDecRHSKindInfo + -- ^ Information about the promoted kind (if present) + -> [Name] + -- ^ The local variables currently in scope + -> DClause -> PrM (DTySynEqn, ADClause) +promoteClause mb_let_uniq name m_ldrki all_locals (DClause pats exp) = do + -- promoting the patterns creates variable bindings. These are passed + -- to the function promoted the RHS + ((types, pats'), prom_pat_infos) <- evalForPair $ mapAndUnzipM promotePat pats + -- If the function has scoped type variables, then we annotate each argument + -- in the promoted type family equation with its kind. + -- See Note [Scoped type variables] in Data.Singletons.TH.Promote.Monad for an + -- explanation of why we do this. + scoped_tvs <- qIsExtEnabled LangExt.ScopedTypeVariables + let types_w_kinds = + case m_ldrki of + Just (LDRKI _ tvbs kinds _) + | not (null tvbs) && scoped_tvs + -> zipWith DSigT types kinds + _ -> types + let PromDPatInfos { prom_dpat_vars = new_vars + , prom_dpat_sig_kvs = sig_kvs } = prom_pat_infos + (ty, ann_exp) <- scopedBind sig_kvs $ + lambdaBind new_vars $ + promoteExp exp + pro_clause_fun <- promoteLetDecName mb_let_uniq name m_ldrki all_locals + return ( DTySynEqn Nothing (foldType pro_clause_fun types_w_kinds) ty + , ADClause new_vars pats' ann_exp ) + +promoteMatch :: DType -- What to use as the LHS of the promoted type family + -- equation. This should consist of the promoted name of + -- the case expression to which the match belongs, applied + -- to any local arguments (e.g., `Case x y z`). + -> DMatch -> PrM (DTySynEqn, ADMatch) +promoteMatch pro_case_fun (DMatch pat exp) = do + -- promoting the patterns creates variable bindings. These are passed + -- to the function promoted the RHS + ((ty, pat'), prom_pat_infos) <- evalForPair $ promotePat pat + let PromDPatInfos { prom_dpat_vars = new_vars + , prom_dpat_sig_kvs = sig_kvs } = prom_pat_infos + (rhs, ann_exp) <- scopedBind sig_kvs $ + lambdaBind new_vars $ + promoteExp exp + return $ ( DTySynEqn Nothing (pro_case_fun `DAppT` ty) rhs + , ADMatch new_vars pat' ann_exp) + +-- promotes a term pattern into a type pattern, accumulating bound variable names +promotePat :: DPat -> QWithAux PromDPatInfos PrM (DType, ADPat) +promotePat (DLitP lit) = (, ADLitP lit) <$> promoteLitPat lit +promotePat (DVarP name) = do + -- term vars can be symbols... type vars can't! + tyName <- mkTyName name + tell $ PromDPatInfos [(name, tyName)] OSet.empty + return (DVarT tyName, ADVarP name) +promotePat (DConP name tys pats) = do + opts <- getOptions + kis <- traverse (promoteType_options conOptions) tys + (types, pats') <- mapAndUnzipM promotePat pats + let name' = promotedDataTypeOrConName opts name + return (foldType (foldl DAppKindT (DConT name') kis) types, ADConP name kis pats') + where + -- Currently, visible type patterns of data constructors are the one place + -- in `singletons-th` where it makes sense to promote wildcard types, as it + -- will produce code that GHC will accept. + conOptions :: PromoteTypeOptions + conOptions = defaultPromoteTypeOptions{ptoAllowWildcards = True} +promotePat (DTildeP pat) = do + qReportWarning "Lazy pattern converted into regular pattern in promotion" + second ADTildeP <$> promotePat pat +promotePat (DBangP pat) = do + qReportWarning "Strict pattern converted into regular pattern in promotion" + second ADBangP <$> promotePat pat +promotePat (DSigP pat ty) = do + -- We must maintain the invariant that any promoted pattern signature must + -- not have any wildcards in the underlying pattern. + -- See Note [Singling pattern signatures]. + wildless_pat <- removeWilds pat + (promoted, pat') <- promotePat wildless_pat + ki <- promoteType ty + tell $ PromDPatInfos [] (fvDType ki) + return (DSigT promoted ki, ADSigP promoted pat' ki) +promotePat DWildP = return (DWildCardT, ADWildP) + +promoteExp :: DExp -> PrM (DType, ADExp) +promoteExp (DVarE name) = fmap (, ADVarE name) $ lookupVarE name +promoteExp (DConE name) = do + opts <- getOptions + return (DConT $ defunctionalizedName0 opts name, ADConE name) +promoteExp (DLitE lit) = fmap (, ADLitE lit) $ promoteLitExp lit +promoteExp (DAppE exp1 exp2) = do + (exp1', ann_exp1) <- promoteExp exp1 + (exp2', ann_exp2) <- promoteExp exp2 + return (apply exp1' exp2', ADAppE ann_exp1 ann_exp2) +-- Until we get visible kind applications, this is the best we can do. +promoteExp (DAppTypeE exp _) = do + qReportWarning "Visible type applications are ignored by `singletons-th`." + promoteExp exp +promoteExp (DLamE names exp) = do + opts <- getOptions + lambdaName <- newUniqueName "Lambda" + tyNames <- mapM mkTyName names + let var_proms = zip names tyNames + (rhs, ann_exp) <- lambdaBind var_proms $ promoteExp exp + all_locals <- allLocals + let tvbs = map (`DPlainTV` BndrReq) tyNames + all_args = all_locals ++ tyNames + all_tvbs = map (`DPlainTV` BndrReq) all_args + tfh = dTypeFamilyHead_with_locals lambdaName all_locals tvbs DNoSig + emitDecs [DClosedTypeFamilyD + tfh + [DTySynEqn Nothing + (foldType (DConT lambdaName) (map DVarT all_args)) + rhs]] + emitDecsM $ defunctionalize lambdaName Nothing $ DefunNoSAK all_tvbs Nothing + let promLambda = foldApply (DConT (defunctionalizedName opts lambdaName 0)) + (map DVarT all_locals) + return (promLambda, ADLamE tyNames promLambda names ann_exp) +promoteExp (DCaseE exp matches) = do + caseTFName <- newUniqueName "Case" + all_locals <- allLocals + let prom_case = foldType (DConT caseTFName) (map DVarT all_locals) + (exp', ann_exp) <- promoteExp exp + (eqns, ann_matches) <- mapAndUnzipM (promoteMatch prom_case) matches + tyvarName <- qNewName "t" + let tvbs = [DPlainTV tyvarName BndrReq] + tfh = dTypeFamilyHead_with_locals caseTFName all_locals tvbs DNoSig + emitDecs [DClosedTypeFamilyD tfh eqns] + -- See Note [Annotate case return type] in Single + let applied_case = prom_case `DAppT` exp' + return ( applied_case + , ADCaseE ann_exp ann_matches applied_case ) +promoteExp (DLetE decs exp) = do + unique <- qNewUnique + (binds, ann_env) <- promoteLetDecs (Just unique) decs + (exp', ann_exp) <- letBind binds $ promoteExp exp + return (exp', ADLetE ann_env ann_exp) +promoteExp (DSigE exp ty) = do + (exp', ann_exp) <- promoteExp exp + ty' <- promoteType ty + return (DSigT exp' ty', ADSigE exp' ann_exp ty') +promoteExp e@(DStaticE _) = fail ("Static expressions cannot be promoted: " ++ show e) +promoteExp e@(DTypedBracketE _) = fail ("Typed bracket expressions cannot be promoted: " ++ show e) +promoteExp e@(DTypedSpliceE _) = fail ("Typed splice expressions cannot be promoted: " ++ show e) + +promoteLitExp :: OptionsMonad q => Lit -> q DType +promoteLitExp (IntegerL n) = do + opts <- getOptions + let tyFromIntegerName = promotedValueName opts fromIntegerName Nothing + tyNegateName = promotedValueName opts negateName Nothing + if n >= 0 + then return $ (DConT tyFromIntegerName `DAppT` DLitT (NumTyLit n)) + else return $ (DConT tyNegateName `DAppT` + (DConT tyFromIntegerName `DAppT` DLitT (NumTyLit (-n)))) +promoteLitExp (StringL str) = do + opts <- getOptions + let prom_str_lit = DLitT (StrTyLit str) + os_enabled <- qIsExtEnabled LangExt.OverloadedStrings + pure $ if os_enabled + then DConT (promotedValueName opts fromStringName Nothing) `DAppT` prom_str_lit + else prom_str_lit +promoteLitExp (CharL c) = return $ DLitT (CharTyLit c) +promoteLitExp lit = + fail ("Only string, natural number, and character literals can be promoted: " ++ show lit) + +promoteLitPat :: MonadFail m => Lit -> m DType +promoteLitPat (IntegerL n) + | n >= 0 = return $ (DLitT (NumTyLit n)) + | otherwise = + fail $ "Negative literal patterns are not allowed,\n" ++ + "because literal patterns are promoted to natural numbers." +promoteLitPat (StringL str) = return $ DLitT (StrTyLit str) +promoteLitPat (CharL c) = return $ DLitT (CharTyLit c) +promoteLitPat lit = + fail ("Only string, natural number, and character literals can be promoted: " ++ show lit) + +-- Promote the name of a 'ULetDecRHS' to the type level. If the promoted +-- 'ULetDecRHS' has a standalone type signature and does not close over any +-- local variables, then this will include the scoped type variables from the +-- type signature as invisible arguments. (See Note [Scoped type variables] in +-- Data.Singletons.TH.Promote.Monad.) Otherwise, it will include any local +-- variables that it closes over as explicit arguments. +promoteLetDecName :: + Maybe Uniq + -- ^ Let-binding unique (if locally bound) + -> Name + -- ^ Name of the function being promoted + -> Maybe LetDecRHSKindInfo + -- ^ Information about the promoted kind (if present) + -> [Name] + -- ^ The local variables currently in scope + -> PrM DType +promoteLetDecName mb_let_uniq name m_ldrki all_locals = do + opts <- getOptions + let proName = promotedValueName opts name mb_let_uniq + type_args = + case m_ldrki of + Just (LDRKI m_sak tvbs _ _) + | isJust m_sak + -- Per the comments on LetDecRHSKindInfo, `isJust m_sak` is only True + -- if there are no local variables. Return the scoped type variables + -- `tvbs` as invisible arguments using `DTyArg`... + -> map (DTyArg . DVarT . extractTvbName) tvbs + _ -> -- ...otherwise, return the local variables as explicit arguments + -- using DTANormal. + map (DTANormal . DVarT) all_locals + pure $ applyDType (DConT proName) type_args + +-- Construct a 'DTypeFamilyHead' that closes over some local variables. We +-- apply `noExactName` to each local variable to avoid GHC#11812. +-- See also Note [Pitfalls of NameU/NameL] in Data.Singletons.TH.Util. +dTypeFamilyHead_with_locals :: + Name + -- ^ Name of type family + -> [Name] + -- ^ Local variables + -> [DTyVarBndrVis] + -- ^ Variables for type family arguments + -> DFamilyResultSig + -- ^ Type family result + -> DTypeFamilyHead +dTypeFamilyHead_with_locals tf_nm local_nms arg_tvbs res_sig = + DTypeFamilyHead + tf_nm + (map (`DPlainTV` BndrReq) local_nms' ++ arg_tvbs') + res_sig' + Nothing + where + -- We take care to only apply `noExactName` to the local variables and not + -- to any of the argument/result types. The latter are much more likely to + -- show up in the Haddocks, and `noExactName` produces incredibly long Names + -- that are much harder to read in the rendered Haddocks. + local_nms' = map noExactName local_nms + + -- Ensure that all references to local_nms are substituted away. + subst1 = Map.fromList $ + zipWith (\local_nm local_nm' -> (local_nm, DVarT local_nm')) + local_nms + local_nms' + (subst2, arg_tvbs') = substTvbs subst1 arg_tvbs + (_subst3, res_sig') = substFamilyResultSig subst2 res_sig diff --git a/src/Data/Singletons/TH/Promote/Defun.hs b/src/Data/Singletons/TH/Promote/Defun.hs --- a/src/Data/Singletons/TH/Promote/Defun.hs +++ b/src/Data/Singletons/TH/Promote/Defun.hs @@ -1,823 +1,826 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} - -{- Data/Singletons/TH/Promote/Defun.hs - -(c) Richard Eisenberg, Jan Stolarek 2014 -rae@cs.brynmawr.edu - -This file creates defunctionalization symbols for types during promotion. --} - -module Data.Singletons.TH.Promote.Defun where - -import Language.Haskell.TH.Desugar -import Language.Haskell.TH.Syntax -import Data.Singletons.TH.Names -import Data.Singletons.TH.Options -import Data.Singletons.TH.Promote.Monad -import Data.Singletons.TH.Promote.Type -import Data.Singletons.TH.Syntax -import Data.Singletons.TH.Util -import Control.Monad -import qualified Data.Map.Strict as Map -import Data.Map.Strict (Map) -import Data.Maybe - -defunInfo :: DInfo -> PrM [DDec] -defunInfo (DTyConI dec _instances) = buildDefunSyms dec -defunInfo (DPrimTyConI _name _numArgs _unlifted) = - fail $ "Building defunctionalization symbols of primitive " ++ - "type constructors not supported" -defunInfo (DVarI _name _ty _mdec) = - fail "Building defunctionalization symbols of values not supported" -defunInfo (DTyVarI _name _ty) = - fail "Building defunctionalization symbols of type variables not supported" -defunInfo (DPatSynI {}) = - fail "Building defunctionalization symbols of pattern synonyms not supported" - --- Defunctionalize type families defined at the top level (i.e., not associated --- with a type class). -defunTopLevelTypeDecls :: - [TySynDecl] - -> [ClosedTypeFamilyDecl] - -> [OpenTypeFamilyDecl] - -> PrM () -defunTopLevelTypeDecls ty_syns c_tyfams o_tyfams = do - defun_ty_syns <- - concatMapM (\(TySynDecl name tvbs rhs) -> buildDefunSymsTySynD name tvbs rhs) ty_syns - defun_c_tyfams <- - concatMapM (buildDefunSymsClosedTypeFamilyD . getTypeFamilyDecl) c_tyfams - defun_o_tyfams <- - concatMapM (buildDefunSymsOpenTypeFamilyD . getTypeFamilyDecl) o_tyfams - emitDecs $ defun_ty_syns ++ defun_c_tyfams ++ defun_o_tyfams - --- Defunctionalize all the type families associated with a type class. -defunAssociatedTypeFamilies :: - [DTyVarBndrUnit] -- The type variables bound by the parent class - -> [OpenTypeFamilyDecl] -- The type families associated with the parent class - -> PrM () -defunAssociatedTypeFamilies cls_tvbs atfs = do - defun_atfs <- concatMapM defun atfs - emitDecs defun_atfs - where - defun :: OpenTypeFamilyDecl -> PrM [DDec] - defun (TypeFamilyDecl tf_head) = - buildDefunSymsTypeFamilyHead ascribe_tf_tvb_kind id tf_head - - -- Maps class-bound type variables to their kind annotations (if supplied). - -- For example, `class C (a :: Bool) b (c :: Type)` will produce - -- {a |-> Bool, c |-> Type}. - cls_tvb_kind_map :: Map Name DKind - cls_tvb_kind_map = Map.fromList [ (extractTvbName tvb, tvb_kind) - | tvb <- cls_tvbs - , Just tvb_kind <- [extractTvbKind tvb] - ] - - -- If the parent class lacks a SAK, we cannot safely default kinds to - -- Type. All we can do is make use of whatever kind information that parent - -- class provides and let kind inference do the rest. - -- - -- We can sometimes learn more specific information about unannotated type - -- family binders from the parent class, as in the following example: - -- - -- class C (a :: Bool) where - -- type T a :: Type - -- - -- Here, we know that `T :: Bool -> Type` because we can infer that the `a` - -- in `type T a` should be of kind `Bool` from the class SAK. - ascribe_tf_tvb_kind :: DTyVarBndrUnit -> DTyVarBndrUnit - ascribe_tf_tvb_kind tvb = - case tvb of - DKindedTV{} -> tvb - DPlainTV n _ -> maybe tvb (DKindedTV n ()) $ Map.lookup n cls_tvb_kind_map - -buildDefunSyms :: DDec -> PrM [DDec] -buildDefunSyms dec = - case dec of - DDataD _new_or_data _cxt _tyName _tvbs _k ctors _derivings -> - buildDefunSymsDataD ctors - DClosedTypeFamilyD tf_head _ -> - buildDefunSymsClosedTypeFamilyD tf_head - DOpenTypeFamilyD tf_head -> - buildDefunSymsOpenTypeFamilyD tf_head - DTySynD name tvbs rhs -> - buildDefunSymsTySynD name tvbs rhs - DClassD _cxt name tvbs _fundeps _members -> - defunReify name tvbs (Just (DConT constraintName)) - _ -> fail $ "Defunctionalization symbols can only be built for " ++ - "type families and data declarations" - --- Unlike open type families, closed type families that lack SAKS do not --- default anything to Type, instead relying on kind inference to figure out --- unspecified kinds. -buildDefunSymsClosedTypeFamilyD :: DTypeFamilyHead -> PrM [DDec] -buildDefunSymsClosedTypeFamilyD = buildDefunSymsTypeFamilyHead id id - --- If an open type family lacks a SAK and has type variable binders or a result --- without explicit kinds, then they default to Type (hence the uses of --- default{Tvb,Maybe}ToTypeKind). -buildDefunSymsOpenTypeFamilyD :: DTypeFamilyHead -> PrM [DDec] -buildDefunSymsOpenTypeFamilyD = - buildDefunSymsTypeFamilyHead defaultTvbToTypeKind (Just . defaultMaybeToTypeKind) - -buildDefunSymsTypeFamilyHead - :: (DTyVarBndrUnit -> DTyVarBndrUnit) -- How to default each type variable binder - -> (Maybe DKind -> Maybe DKind) -- How to default the result kind - -> DTypeFamilyHead -> PrM [DDec] -buildDefunSymsTypeFamilyHead default_tvb default_kind - (DTypeFamilyHead name tvbs result_sig _) = do - let arg_tvbs = map default_tvb tvbs - res_kind = default_kind (resultSigToMaybeKind result_sig) - defunReify name arg_tvbs res_kind - -buildDefunSymsTySynD :: Name -> [DTyVarBndrUnit] -> DType -> PrM [DDec] -buildDefunSymsTySynD name tvbs rhs = defunReify name tvbs mb_res_kind - where - -- If a type synonym lacks a SAK, we can "infer" its result kind by - -- checking for an explicit kind annotation on the right-hand side. - mb_res_kind :: Maybe DKind - mb_res_kind = case rhs of - DSigT _ k -> Just k - _ -> Nothing - -buildDefunSymsDataD :: [DCon] -> PrM [DDec] -buildDefunSymsDataD ctors = - concatMapM promoteCtor ctors - where - promoteCtor :: DCon -> PrM [DDec] - promoteCtor (DCon tvbs _ name fields res_ty) = do - opts <- getOptions - let name' = promotedDataTypeOrConName opts name - arg_tys = tysOfConFields fields - arg_kis <- traverse promoteType_NC arg_tys - res_ki <- promoteType_NC res_ty - let con_ki = ravelVanillaDType tvbs [] arg_kis res_ki - m_fixity <- reifyFixityWithLocals name' - defunctionalize name' m_fixity $ DefunSAK con_ki - --- Generate defunctionalization symbols for a name, using reifyFixityWithLocals --- to determine what the fixity of each symbol should be --- (see Note [Fixity declarations for defunctionalization symbols]) --- and dsReifyType to determine whether defunctionalization should make use --- of SAKs or not (see Note [Defunctionalization game plan]). -defunReify :: Name -- Name of the declaration to be defunctionalized - -> [DTyVarBndrUnit] -- The declaration's type variable binders - -- (only used if the declaration lacks a SAK) - -> Maybe DKind -- The declaration's return kind, if it has one - -- (only used if the declaration lacks a SAK) - -> PrM [DDec] -defunReify name tvbs m_res_kind = do - m_fixity <- reifyFixityWithLocals name - m_sak <- dsReifyType name - let defun = defunctionalize name m_fixity - case m_sak of - Just sak -> defun $ DefunSAK sak - Nothing -> defun $ DefunNoSAK tvbs m_res_kind - --- Generate symbol data types, Apply instances, and other declarations required --- for defunctionalization. --- See Note [Defunctionalization game plan] for an overview of the design --- considerations involved. -defunctionalize :: Name - -> Maybe Fixity - -> DefunKindInfo - -> PrM [DDec] -defunctionalize name m_fixity defun_ki = do - case defun_ki of - DefunSAK sak -> - -- Even if a declaration has a SAK, its kind may not be vanilla. - case unravelVanillaDType_either sak of - -- If the kind isn't vanilla, use the fallback approach. - -- See Note [Defunctionalization game plan], - -- Wrinkle 2: Non-vanilla kinds. - Left _ -> defun_fallback [] (Just sak) - -- Otherwise, proceed with defun_vanilla_sak. - Right (sak_tvbs, _sak_cxt, sak_arg_kis, sak_res_ki) - -> defun_vanilla_sak sak_tvbs sak_arg_kis sak_res_ki - -- If a declaration lacks a SAK, it likely has a partial kind. - -- See Note [Defunctionalization game plan], Wrinkle 1: Partial kinds. - DefunNoSAK tvbs m_res -> defun_fallback tvbs m_res - where - -- Generate defunctionalization symbols for things with vanilla SAKs. - -- The symbols themselves will also be given SAKs. - defun_vanilla_sak :: [DTyVarBndrSpec] -> [DKind] -> DKind -> PrM [DDec] - defun_vanilla_sak sak_tvbs sak_arg_kis sak_res_ki = do - opts <- getOptions - extra_name <- qNewName "arg" - let sak_arg_n = length sak_arg_kis - -- Use noExactName below to avoid GHC#17537. - arg_names <- replicateM sak_arg_n (noExactName <$> qNewName "a") - - let -- The inner loop. @go n arg_nks res_nks@ returns @(res_k, decls)@. - -- Using one particular example: - -- - -- @ - -- type ExampleSym2 :: a -> b -> c ~> d ~> Type - -- data ExampleSym2 (x :: a) (y :: b) :: c ~> d ~> Type where ... - -- type instance Apply (ExampleSym2 x y) z = ExampleSym3 x y z - -- ... - -- @ - -- - -- We have: - -- - -- * @n@ is 2. This is incremented in each iteration of `go`. - -- - -- * @arg_nks@ is [(x, a), (y, b)]. Each element in this list is a - -- (type variable name, type variable kind) pair. The kinds appear in - -- the SAK, separated by matchable arrows (->). - -- - -- * @res_tvbs@ is [(z, c), (w, d)]. Each element in this list is a - -- (type variable name, type variable kind) pair. The kinds appear in - -- @res_k@, separated by unmatchable arrows (~>). - -- - -- * @res_k@ is `c ~> d ~> Type`. @res_k@ is returned so that earlier - -- defunctionalization symbols can build on the result kinds of - -- later symbols. For instance, ExampleSym1 would get the result - -- kind `b ~> c ~> d ~> Type` by prepending `b` to ExampleSym2's - -- result kind `c ~> d ~> Type`. - -- - -- * @decls@ are all of the declarations corresponding to ExampleSym2 - -- and later defunctionalization symbols. This is the main payload of - -- the function. - -- - -- Note that the body of ExampleSym2 redundantly includes the - -- argument kinds and result kind, which are already stated in the - -- standalone kind signature. This is a deliberate choice. - -- See Note [Keep redundant kind information for Haddocks] - -- in D.S.TH.Promote. - -- - -- This function is quadratic because it appends a variable at the end of - -- the @arg_nks@ list at each iteration. In practice, this is unlikely - -- to be a performance bottleneck since the number of arguments rarely - -- gets to be that large. - go :: Int -> [(Name, DKind)] -> [(Name, DKind)] -> (DKind, [DDec]) - go n arg_nks res_nkss = - let arg_tvbs :: [DTyVarBndrUnit] - arg_tvbs = map (\(na, ki) -> DKindedTV na () ki) arg_nks - - mk_sak_dec :: DKind -> DDec - mk_sak_dec res_ki = - DKiSigD (defunctionalizedName opts name n) $ - ravelVanillaDType sak_tvbs [] (map snd arg_nks) res_ki in - case res_nkss of - [] -> - let sat_sak_dec = mk_sak_dec sak_res_ki - sat_decs = mk_sat_decs opts n arg_tvbs (Just sak_res_ki) - in (sak_res_ki, sat_sak_dec:sat_decs) - res_nk:res_nks -> - let (res_ki, decs) = go (n+1) (arg_nks ++ [res_nk]) res_nks - tyfun = buildTyFunArrow (snd res_nk) res_ki - defun_sak_dec = mk_sak_dec tyfun - defun_other_decs = mk_defun_decs opts n sak_arg_n - arg_tvbs (fst res_nk) - extra_name (Just tyfun) - in (tyfun, defun_sak_dec:defun_other_decs ++ decs) - - pure $ snd $ go 0 [] $ zip arg_names sak_arg_kis - - -- If defun_sak can't be used to defunctionalize something, this fallback - -- approach is used. This is used when defunctionalizing something with a - -- partial kind - -- (see Note [Defunctionalization game plan], Wrinkle 1: Partial kinds) - -- or a non-vanilla kind - -- (see Note [Defunctionalization game plan], Wrinkle 2: Non-vanilla kinds). - defun_fallback :: [DTyVarBndrUnit] -> Maybe DKind -> PrM [DDec] - defun_fallback tvbs' m_res' = do - opts <- getOptions - extra_name <- qNewName "arg" - -- Use noExactTyVars below to avoid GHC#11812. - (tvbs, m_res) <- eta_expand (noExactTyVars tvbs') (noExactTyVars m_res') - - let tvbs_n = length tvbs - - -- The inner loop. @go n arg_tvbs res_tvbs@ returns @(m_res_k, decls)@. - -- Using one particular example: - -- - -- @ - -- data ExampleSym2 (x :: a) y :: c ~> d ~> Type where ... - -- type instance Apply (ExampleSym2 x y) z = ExampleSym3 x y z - -- ... - -- @ - -- - -- This works very similarly to the `go` function in - -- `defun_vanilla_sak`. The main differences are: - -- - -- * This function does not produce any SAKs for defunctionalization - -- symbols. - -- - -- * Instead of [(Name, DKind)], this function uses [DTyVarBndr] as - -- the types of @arg_tvbs@ and @res_tvbs@. This is because the - -- kinds are not always known. By a similar token, this function - -- uses Maybe DKind, not DKind, as the type of @m_res_k@, since - -- the result kind is not always fully known. - go :: Int -> [DTyVarBndrUnit] -> [DTyVarBndrUnit] -> (Maybe DKind, [DDec]) - go n arg_tvbs res_tvbss = - case res_tvbss of - [] -> - let sat_decs = mk_sat_decs opts n arg_tvbs m_res - in (m_res, sat_decs) - res_tvb:res_tvbs -> - let (m_res_ki, decs) = go (n+1) (arg_tvbs ++ [res_tvb]) res_tvbs - m_tyfun = buildTyFunArrow_maybe (extractTvbKind res_tvb) - m_res_ki - defun_decs' = mk_defun_decs opts n tvbs_n arg_tvbs - (extractTvbName res_tvb) - extra_name m_tyfun - in (m_tyfun, defun_decs' ++ decs) - - pure $ snd $ go 0 [] tvbs - - mk_defun_decs :: Options - -> Int - -> Int - -> [DTyVarBndrUnit] - -> Name - -> Name - -> Maybe DKind - -> [DDec] - mk_defun_decs opts n fully_sat_n arg_tvbs tyfun_name extra_name m_tyfun = - let data_name = defunctionalizedName opts name n - next_name = defunctionalizedName opts name (n+1) - con_name = prefixName "" ":" $ suffixName "KindInference" "###" data_name - arg_names = map extractTvbName arg_tvbs - params = arg_tvbs ++ [DPlainTV tyfun_name ()] - con_eq_ct = DConT sameKindName `DAppT` lhs `DAppT` rhs - where - lhs = foldType (DConT data_name) (map DVarT arg_names) `apply` (DVarT extra_name) - rhs = foldType (DConT next_name) (map DVarT (arg_names ++ [extra_name])) - con_decl = DCon [] [con_eq_ct] con_name (DNormalC False []) - (foldTypeTvbs (DConT data_name) params) - data_decl = DDataD Data [] data_name args m_tyfun [con_decl] [] - where - args | isJust m_tyfun = arg_tvbs - | otherwise = params - app_data_ty = foldTypeTvbs (DConT data_name) arg_tvbs - app_eqn = DTySynEqn Nothing - (DConT applyName `DAppT` app_data_ty - `DAppT` DVarT tyfun_name) - (foldTypeTvbs (DConT app_eqn_rhs_name) - (arg_tvbs ++ [DPlainTV tyfun_name ()])) - -- If the next defunctionalization symbol is fully saturated, then - -- use the original declaration name instead. - -- See Note [Fully saturated defunctionalization symbols] - -- (Wrinkle: avoiding reduction stack overflows). - app_eqn_rhs_name | n+1 == fully_sat_n = name - | otherwise = next_name - app_decl = DTySynInstD app_eqn - suppress = DInstanceD Nothing Nothing [] - (DConT suppressClassName `DAppT` app_data_ty) - [DLetDec $ DFunD suppressMethodName - [DClause [] - ((DVarE 'snd) `DAppE` - mkTupleDExp [DConE con_name, - mkTupleDExp []])]] - - -- See Note [Fixity declarations for defunctionalization symbols] - fixity_decl = maybeToList $ fmap (mk_fix_decl data_name) m_fixity - in data_decl : app_decl : suppress : fixity_decl - - -- Generate a "fully saturated" defunction symbol, along with a fixity - -- declaration (if needed). - -- See Note [Fully saturated defunctionalization symbols]. - mk_sat_decs :: Options -> Int -> [DTyVarBndrUnit] -> Maybe DKind -> [DDec] - mk_sat_decs opts n sat_tvbs m_sat_res = - let sat_name = defunctionalizedName opts name n - sat_dec = DClosedTypeFamilyD - (DTypeFamilyHead sat_name sat_tvbs - (maybeKindToResultSig m_sat_res) Nothing) - [DTySynEqn Nothing - (foldTypeTvbs (DConT sat_name) sat_tvbs) - (foldTypeTvbs (DConT name) sat_tvbs)] - sat_fixity_dec = maybeToList $ fmap (mk_fix_decl sat_name) m_fixity - in sat_dec : sat_fixity_dec - - -- Generate extra kind variable binders corresponding to the number of - -- arrows in the return kind (if provided). Examples: - -- - -- >>> eta_expand [(x :: a), (y :: b)] (Just (c -> Type)) - -- ([(x :: a), (y :: b), (e :: c)], Just Type) - -- - -- >>> eta_expand [(x :: a), (y :: b)] Nothing - -- ([(x :: a), (y :: b)], Nothing) - eta_expand :: [DTyVarBndrUnit] -> Maybe DKind -> PrM ([DTyVarBndrUnit], Maybe DKind) - eta_expand m_arg_tvbs Nothing = pure (m_arg_tvbs, Nothing) - eta_expand m_arg_tvbs (Just res_kind) = do - let (arg_ks, result_k) = unravelDType res_kind - vis_arg_ks = filterDVisFunArgs arg_ks - extra_arg_tvbs <- traverse mk_extra_tvb vis_arg_ks - pure (m_arg_tvbs ++ extra_arg_tvbs, Just result_k) - - -- Convert a DVisFunArg to a DTyVarBndr, generating a fresh type variable - -- name if the DVisFunArg is an anonymous argument. - mk_extra_tvb :: DVisFunArg -> PrM DTyVarBndrUnit - mk_extra_tvb vfa = - case vfa of - DVisFADep tvb -> pure tvb - DVisFAAnon k -> (\n -> DKindedTV n () k) <$> - -- Use noExactName below to avoid GHC#19743. - (noExactName <$> qNewName "e") - - mk_fix_decl :: Name -> Fixity -> DDec - mk_fix_decl n f = DLetDec $ DInfixD f n - --- Indicates whether the type being defunctionalized has a standalone kind --- signature. If it does, DefunSAK contains the kind. If not, DefunNoSAK --- contains whatever information is known about its type variable binders --- and result kind. --- See Note [Defunctionalization game plan] for details on how this --- information is used. -data DefunKindInfo - = DefunSAK DKind - | DefunNoSAK [DTyVarBndrUnit] (Maybe DKind) - --- Shorthand for building (k1 ~> k2) -buildTyFunArrow :: DKind -> DKind -> DKind -buildTyFunArrow k1 k2 = DConT tyFunArrowName `DAppT` k1 `DAppT` k2 - -buildTyFunArrow_maybe :: Maybe DKind -> Maybe DKind -> Maybe DKind -buildTyFunArrow_maybe m_k1 m_k2 = buildTyFunArrow <$> m_k1 <*> m_k2 - -{- -Note [Defunctionalization game plan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Generating defunctionalization symbols involves a surprising amount of -complexity. This Note gives a broad overview of what happens during -defunctionalization and highlights various design considerations. -As a working example, we will use the following type family: - - type Foo :: forall c a b. a -> b -> c -> c - type family Foo x y z where ... - -We must generate a defunctionalization symbol for every number of arguments -to which Foo can be partially applied. We do so by generating the following -declarations: - - type FooSym0 :: forall c a b. a ~> b ~> c ~> c - data FooSym0 f where - FooSym0KindInference :: SameKind (Apply FooSym0 arg) (FooSym1 arg) - => FooSym0 f - type instance Apply FooSym0 x = FooSym1 x - - type FooSym1 :: forall c a b. a -> b ~> c ~> c - data FooSym1 x f where - FooSym1KindInference :: SameKind (Apply (FooSym1 a) arg) (FooSym2 a arg) - => FooSym1 a f - type instance Apply (FooSym1 x) y = FooSym2 x y - - type FooSym2 :: forall c a b. a -> b -> c ~> c - data FooSym2 x y f where - FooSym2KindInference :: SameKind (Apply (FooSym2 x y) arg) (FooSym3 x y arg) - => FooSym2 x y f - type instance Apply (FooSym2 x y) z = Foo x y z - - type FooSym3 :: forall c a b. a -> b -> c -> c - type family FooSym3 x y z where - FooSym3 x y z = Foo x y z - -Some things to note: - -* Each defunctionalization symbol has its own standalone kind signature. The - number after `Sym` in each symbol indicates the number of leading -> arrows - in its kind—that is, the number of arguments to which it can be applied - directly to without the use of the Apply type family. - - See "Wrinkle 1: Partial kinds" below for what happens if the declaration - being defunctionalized does *not* have a standalone kind signature. - -* Each data declaration has a constructor with the suffix `-KindInference` - in its name. These are redundant in the particular case of Foo, where the - kind is already known. They play a more vital role when the kind of the - declaration being defunctionalized is only partially known. - See "Wrinkle 1: Partial kinds" below for more information. - -* FooSym3, the last defunctionalization symbol, is somewhat special in that - it is a type family, not a data type. These sorts of symbols are referred - to as "fully saturated" defunctionalization symbols. - See Note [Fully saturated defunctionalization symbols]. - -* If Foo had a fixity declaration (e.g., infixl 4 `Foo`), then we would also - generate fixity declarations for each defunctionalization symbol (e.g., - infixl 4 `FooSym0`). - See Note [Fixity declarations for defunctionalization symbols]. - -* Foo has a vanilla kind signature. (See - Note [Vanilla-type validity checking during promotion] in D.S.TH.Promote.Type - for what "vanilla" means in this context.) Having a vanilla type signature is - important, as it is a property that makes it much simpler to preserve the - order of type variables (`forall c a b.`) in each of the defunctionalization - symbols. - - That being said, it is not strictly required that the kind be vanilla. There - is another approach that can be used to defunctionalize things with - non-vanilla types, at the possible expense of having different type variable - orders between different defunctionalization symbols. - See "Wrinkle 2: Non-vanilla kinds" below for more information. - ------ --- Wrinkle 1: Partial kinds ------ - -The Foo example above has a standalone kind signature, but not everything has -this much kind information. For example, consider this: - - $(singletons [d| - type family Not x where - Not False = True - Not True = False - |]) - -The inferred kind for Not is `Bool -> Bool`, but since Not was declared in TH -quotes, `singletons-th` has no knowledge of this. Instead, we must rely on kind -inference to give Not's defunctionalization symbols the appropriate kinds. -Here is a naïve first attempt: - - data NotSym0 f - type instance Apply NotSym0 x = Not x - - type family NotSym1 x where - NotSym1 x = Not x - -NotSym1 will have the inferred kind `Bool -> Bool`, but poor NotSym0 will have -the inferred kind `forall k. k -> Type`, which is far more general than we -would like. We can do slightly better by supplying additional kind information -in a data constructor, like so: - - type SameKind :: k -> k -> Constraint - class SameKind x y = () - - data NotSym0 f where - NotSym0KindInference :: SameKind (Apply NotSym0 arg) (NotSym1 arg) - => NotSym0 f - -NotSym0KindInference is not intended to ever be seen by the user. Its only -reason for existing is its existential -`SameKind (Apply NotSym0 arg) (NotSym1 arg)` context, which allows GHC to -figure out that NotSym0 has kind `Bool ~> Bool`. This is a bit of a hack, but -it works quite nicely. The only problem is that GHC is likely to warn that -NotSym0KindInference is unused, which is annoying. To work around this, we -mention the data constructor in an instance of a dummy class: - - instance SuppressUnusedWarnings NotSym0 where - suppressUnusedWarnings = snd (NotSym0KindInference, ()) - -Similarly, this SuppressUnusedWarnings class is not intended to ever be seen -by the user. As its name suggests, it only exists to help suppress "unused -data constructor" warnings. - -Some declarations have a mixture of known kinds and unknown kinds, such as in -this example: - - $(singletons [d| - type family Bar x (y :: Nat) (z :: Nat) :: Nat where ... - |]) - -We can use the known kinds to guide kind inference. In this particular example -of Bar, here are the defunctionalization symbols that would be generated: - - data BarSym0 f where ... - data BarSym1 x :: Nat ~> Nat ~> Nat where ... - data BarSym2 x (y :: Nat) :: Nat ~> Nat where ... - type family BarSym3 x (y :: Nat) (z :: Nat) :: Nat where ... - ------ --- Wrinkle 2: Non-vanilla kinds ------ - -There is only limited support for defunctionalizing declarations with -non-vanilla kinds. One example of something with a non-vanilla kind is the -following, which uses a nested forall: - - $(singletons [d| - type Baz :: forall a. a -> forall b. b -> Type - data Baz x y - |]) - -One might envision generating the following defunctionalization symbols for -Baz: - - type BazSym0 :: forall a. a ~> forall b. b ~> Type - data BazSym0 f where ... - - type BazSym1 :: forall a. a -> forall b. b ~> Type - data BazSym1 x f where ... - - type BazSym2 :: forall a. a -> forall b. b -> Type - type family BazSym2 x y where - BazSym2 x y = Baz x y - -Unfortunately, doing so would require impredicativity, since we would have: - - forall a. a ~> forall b. b ~> Type - = forall a. (~>) a (forall b. b ~> Type) - = forall a. TyFun a (forall b. b ~> Type) -> Type - -Note that TyFun is an ordinary data type, so having its second argument be -(forall b. b ~> Type) is truly impredicative. As a result, trying to preserve -nested or higher-rank foralls is a non-starter. - -We need not reject Baz entirely, however. We can still generate perfectly -usable defunctionalization symbols if we are willing to sacrifice the exact -order of foralls. When we encounter a non-vanilla kind such as Baz's, we simply -fall back to the algorithm used when we encounter a partial kind (as described -in "Wrinkle 1: Partial kinds" above.) In other words, we generate the -following symbols: - - data BazSym0 :: a ~> b ~> Type where ... - data BazSym1 (x :: a) :: b ~> Type where ... - type family BazSym2 (x :: a) (y :: b) :: Type where ... - -The kinds of BazSym0 and BazSym1 both start with `forall a b.`, -whereas the `b` is quantified later in Baz itself. For most use cases, however, -this is not a huge concern. - -Another way kinds can be non-vanilla is if they contain visible dependent -quantification, like so: - - $(singletons [d| - type Quux :: forall (k :: Type) -> k -> Type - data Quux x y - |]) - -What should the kind of QuuxSym0 be? Intuitively, it should be this: - - type QuuxSym0 :: forall (k :: Type) ~> k ~> Type - -Alas, `forall (k :: Type) ~>` simply doesn't work. See #304. But there is an -acceptable compromise we can make that can give us defunctionalization symbols -for Quux. Once again, we fall back to the partial kind algorithm: - - data QuuxSym0 :: Type ~> k ~> Type where ... - data QuuxSym1 (k :: Type) :: k ~> Type where ... - type family QuuxSym2 (k :: Type) (x :: k) :: Type where ... - -The catch is that the kind of QuuxSym0, `forall k. Type ~> k ~> Type`, is -slightly more general than it ought to be. In practice, however, this is -unlikely to be a problem as long as you apply QuuxSym0 to arguments of the -right kinds. - -Note [Fully saturated defunctionalization symbols] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When generating defunctionalization symbols, most of the symbols are data -types. The last one, however, is a type family. For example, this code: - - $(singletons [d| - type Const :: a -> b -> a - type Const x y = x - |]) - -Will generate the following symbols: - - type ConstSym0 :: a ~> b ~> a - data ConstSym0 f where ... - - type ConstSym1 :: a -> b ~> a - data ConstSym1 x f where ... - - type ConstSym2 :: a -> b -> a - type family ConstSym2 x y where - ConstSym2 x y = Const x y - -ConstSym2, the sole type family of the bunch, is what is referred to as a -"fully saturated" defunctionaliztion symbol. - -At first glance, ConstSym2 may not seem terribly useful, since it is -effectively a thin wrapper around the original Const type. Indeed, fully -saturated symbols almost never appear directly in user-written code. Instead, -they are most valuable in TH-generated code, as singletons-th often generates code -that directly applies a defunctionalization symbol to some number of arguments -(see, for instance, D.S.TH.Names.promoteTySym). In theory, such code could carve -out a special case for fully saturated applications and apply the original -type instead of a defunctionalization symbol, but determining when an -application is fully saturated is often difficult in practice. As a result, it -is more convenient to just generate code that always applies FuncSymN to N -arguments, and to let fully saturated defunctionalization symbols handle the -case where N equals the number of arguments needed to fully saturate Func. - -One might wonder if, instead of using a closed type family with a single -equation, we could use a type synonym to define ConstSym2: - - type ConstSym2 :: a -> b -> a - type ConstSym2 x y = Const x y - -This approach has various downsides which make it impractical: - -* Type synonyms are often not expanded in the output of GHCi's :kind! command. - As issue #445 chronicles, this can significantly impact the readability of - even simple :kind! queries. It can be the difference between this: - - λ> :kind! Map IdSym0 '[1,2,3] - Map IdSym0 '[1,2,3] :: [Nat] - = 1 :@#@$$$ '[2, 3] - - And this: - - λ> :kind! Map IdSym0 '[1,2,3] - Map IdSym0 '[1,2,3] :: [Nat] - = '[1, 2, 3] - - Making fully saturated defunctionalization symbols like (:@#@$$$) type - families makes this issue moot, since :kind! always expands type families. -* There are a handful of corner cases where using type synonyms can actually - make fully saturated defunctionalization symbols fail to typecheck. - Here is one such corner case: - - $(promote [d| - class Applicative f where - pure :: a -> f a - ... - (*>) :: f a -> f b -> f b - |]) - - ==> - - class PApplicative f where - type Pure (x :: a) :: f a - type (*>) (x :: f a) (y :: f b) :: f b - - What would happen if we were to defunctionalize the promoted version of (*>)? - We'd end up with the following defunctionalization symbols: - - type (*>@#@$) :: f a ~> f b ~> f b - data (*>@#@$) f where ... - - type (*>@#@$$) :: f a -> f b ~> f b - data (*>@#@$$) x f where ... - - type (*>@#@$$$) :: f a -> f b -> f b - type (*>@#@$$$) x y = (*>) x y - - It turns out, however, that (*>@#@$$$) will not kind-check. Because (*>@#@$$$) - has a standalone kind signature, it is kind-generalized *before* kind-checking - the actual definition itself. Therefore, the full kind is: - - type (*>@#@$$$) :: forall {k} (f :: k -> Type) (a :: k) (b :: k). - f a -> f b -> f b - type (*>@#@$$$) x y = (*>) x y - - However, the kind of (*>) is - `forall (f :: Type -> Type) (a :: Type) (b :: Type). f a -> f b -> f b`. - This is not general enough for (*>@#@$$$), which expects kind-polymorphic `f`, - `a`, and `b`, leading to a kind error. You might think that we could somehow - infer this information, but note the quoted definition of Applicative (and - PApplicative, as a consequence) omits the kinds of `f`, `a`, and `b` entirely. - Unless we were to implement full-blown kind inference inside of Template - Haskell (which is a tall order), the kind `f a -> f b -> f b` is about as good - as we can get. - - Making (*>@#@$$$) a type family rather than a type synonym avoids this issue - since type family equations are allowed to match on kind arguments. In this - example, (*>@#@$$$) would have kind-polymorphic `f`, `a`, and `b` in its kind - signature, but its equation would implicitly equate `k` with `Type`. Note - that (*>@#@$) and (*>@#@$$), which are GADTs, also use a similar trick by - equating `k` with `Type` in their GADT constructors. - ------ --- Wrinkle: avoiding reduction stack overflows ------ - -A naïve attempt at declaring all fully saturated defunctionalization symbols -as type families can make certain programs overflow the reduction stack, such -as the T445 test case. This is because when evaluating -`FSym0 `Apply` x_1 `Apply` ... `Apply` x_N`, (where F is a promoted function -that requires N arguments), we will eventually bottom out by evaluating -`FSymN x_1 ... x_N`, where FSymN is a fully saturated defunctionalization -symbol. Since FSymN is a type family, this is yet another type family -reduction that contributes to the overall reduction limit. This might not -seem like a lot, but it can add up if F is invoked several times in a single -type-level computation! - -Fortunately, we can bypass evaluating FSymN entirely by just making a slight -tweak to the TH machinery. Instead of generating this Apply instance: - - type instance Apply (FSym{N-1} x_1 ... x_{N-1}) x_N = - FSymN x_1 ... x_{N-1} x_N - -Generate this instance, which jumps straight to F: - - type instance Apply (FSym{N-1} x_1 ... x_{N-1}) x_N = - F x_1 ... x_{N-1} x_N - -Now evaluating `FSym0 `Apply` x_1 `Apply` ... `Apply` x_N` will require one -less type family reduction. In practice, this is usually enough to keep the -reduction limit at bay in most situations. - -Note [Fixity declarations for defunctionalization symbols] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Just like we promote fixity declarations, we should also generate fixity -declarations for defunctionaliztion symbols. A primary use case is the -following scenario: - - (.) :: (b -> c) -> (a -> b) -> (a -> c) - (f . g) x = f (g x) - infixr 9 . - -One often writes (f . g . h) at the value level, but because (.) is promoted -to a type family with three arguments, this doesn't directly translate to the -type level. Instead, one must write this: - - f .@#@$$$ g .@#@$$$ h - -But in order to ensure that this associates to the right as expected, one must -generate an `infixr 9 .@#@#$$$` declaration. This is why defunctionalize accepts -a Maybe Fixity argument. --} +{-# LANGUAGE TemplateHaskellQuotes #-} + +{- Data/Singletons/TH/Promote/Defun.hs + +(c) Richard Eisenberg, Jan Stolarek 2014 +rae@cs.brynmawr.edu + +This file creates defunctionalization symbols for types during promotion. +-} + +module Data.Singletons.TH.Promote.Defun where + +import Language.Haskell.TH.Desugar +import Language.Haskell.TH.Syntax +import Data.Singletons.TH.Names +import Data.Singletons.TH.Options +import Data.Singletons.TH.Promote.Monad +import Data.Singletons.TH.Promote.Type +import Data.Singletons.TH.Syntax +import Data.Singletons.TH.Util +import Control.Monad +import qualified Data.Map.Strict as Map +import Data.Map.Strict (Map) +import Data.Maybe + +defunInfo :: DInfo -> PrM [DDec] +defunInfo (DTyConI dec _instances) = buildDefunSyms dec +defunInfo (DPrimTyConI _name _numArgs _unlifted) = + fail $ "Building defunctionalization symbols of primitive " ++ + "type constructors not supported" +defunInfo (DVarI _name _ty _mdec) = + fail "Building defunctionalization symbols of values not supported" +defunInfo (DTyVarI _name _ty) = + fail "Building defunctionalization symbols of type variables not supported" +defunInfo (DPatSynI {}) = + fail "Building defunctionalization symbols of pattern synonyms not supported" + +-- Defunctionalize type families defined at the top level (i.e., not associated +-- with a type class). +defunTopLevelTypeDecls :: + [TySynDecl] + -> [ClosedTypeFamilyDecl] + -> [OpenTypeFamilyDecl] + -> PrM () +defunTopLevelTypeDecls ty_syns c_tyfams o_tyfams = do + defun_ty_syns <- + concatMapM (\(TySynDecl name tvbs rhs) -> buildDefunSymsTySynD name tvbs rhs) ty_syns + defun_c_tyfams <- + concatMapM (buildDefunSymsClosedTypeFamilyD . getTypeFamilyDecl) c_tyfams + defun_o_tyfams <- + concatMapM (buildDefunSymsOpenTypeFamilyD . getTypeFamilyDecl) o_tyfams + emitDecs $ defun_ty_syns ++ defun_c_tyfams ++ defun_o_tyfams + +-- Defunctionalize all the type families associated with a type class. +defunAssociatedTypeFamilies :: + [DTyVarBndrVis] -- The type variables bound by the parent class + -> [OpenTypeFamilyDecl] -- The type families associated with the parent class + -> PrM () +defunAssociatedTypeFamilies cls_tvbs atfs = do + defun_atfs <- concatMapM defun atfs + emitDecs defun_atfs + where + defun :: OpenTypeFamilyDecl -> PrM [DDec] + defun (TypeFamilyDecl tf_head) = + buildDefunSymsTypeFamilyHead ascribe_tf_tvb_kind id tf_head + + -- Maps class-bound type variables to their kind annotations (if supplied). + -- For example, `class C (a :: Bool) b (c :: Type)` will produce + -- {a |-> Bool, c |-> Type}. + cls_tvb_kind_map :: Map Name DKind + cls_tvb_kind_map = Map.fromList [ (extractTvbName tvb, tvb_kind) + | tvb <- cls_tvbs + , Just tvb_kind <- [extractTvbKind tvb] + ] + + -- If the parent class lacks a SAK, we cannot safely default kinds to + -- Type. All we can do is make use of whatever kind information that parent + -- class provides and let kind inference do the rest. + -- + -- We can sometimes learn more specific information about unannotated type + -- family binders from the parent class, as in the following example: + -- + -- class C (a :: Bool) where + -- type T a :: Type + -- + -- Here, we know that `T :: Bool -> Type` because we can infer that the `a` + -- in `type T a` should be of kind `Bool` from the class SAK. + ascribe_tf_tvb_kind :: DTyVarBndrVis -> DTyVarBndrVis + ascribe_tf_tvb_kind tvb = + case tvb of + DKindedTV{} -> tvb + DPlainTV n _ -> maybe tvb (DKindedTV n BndrReq) $ Map.lookup n cls_tvb_kind_map + +buildDefunSyms :: DDec -> PrM [DDec] +buildDefunSyms dec = + case dec of + DDataD _new_or_data _cxt _tyName _tvbs _k ctors _derivings -> + buildDefunSymsDataD ctors + DClosedTypeFamilyD tf_head _ -> + buildDefunSymsClosedTypeFamilyD tf_head + DOpenTypeFamilyD tf_head -> + buildDefunSymsOpenTypeFamilyD tf_head + DTySynD name tvbs rhs -> + buildDefunSymsTySynD name tvbs rhs + DClassD _cxt name tvbs _fundeps _members -> + defunReify name tvbs (Just (DConT constraintName)) + _ -> fail $ "Defunctionalization symbols can only be built for " ++ + "type families and data declarations" + +-- Unlike open type families, closed type families that lack SAKS do not +-- default anything to Type, instead relying on kind inference to figure out +-- unspecified kinds. +buildDefunSymsClosedTypeFamilyD :: DTypeFamilyHead -> PrM [DDec] +buildDefunSymsClosedTypeFamilyD = buildDefunSymsTypeFamilyHead id id + +-- If an open type family lacks a SAK and has type variable binders or a result +-- without explicit kinds, then they default to Type (hence the uses of +-- default{Tvb,Maybe}ToTypeKind). +buildDefunSymsOpenTypeFamilyD :: DTypeFamilyHead -> PrM [DDec] +buildDefunSymsOpenTypeFamilyD = + buildDefunSymsTypeFamilyHead defaultTvbToTypeKind (Just . defaultMaybeToTypeKind) + +buildDefunSymsTypeFamilyHead + :: (DTyVarBndrVis -> DTyVarBndrVis) -- How to default each type variable binder + -> (Maybe DKind -> Maybe DKind) -- How to default the result kind + -> DTypeFamilyHead -> PrM [DDec] +buildDefunSymsTypeFamilyHead default_tvb default_kind + (DTypeFamilyHead name tvbs result_sig _) = do + let arg_tvbs = map default_tvb tvbs + res_kind = default_kind (resultSigToMaybeKind result_sig) + defunReify name arg_tvbs res_kind + +buildDefunSymsTySynD :: Name -> [DTyVarBndrVis] -> DType -> PrM [DDec] +buildDefunSymsTySynD name tvbs rhs = defunReify name tvbs mb_res_kind + where + -- If a type synonym lacks a SAK, we can "infer" its result kind by + -- checking for an explicit kind annotation on the right-hand side. + mb_res_kind :: Maybe DKind + mb_res_kind = case rhs of + DSigT _ k -> Just k + _ -> Nothing + +buildDefunSymsDataD :: [DCon] -> PrM [DDec] +buildDefunSymsDataD ctors = + concatMapM promoteCtor ctors + where + promoteCtor :: DCon -> PrM [DDec] + promoteCtor (DCon tvbs _ name fields res_ty) = do + opts <- getOptions + let name' = promotedDataTypeOrConName opts name + arg_tys = tysOfConFields fields + arg_kis <- traverse promoteType_NC arg_tys + res_ki <- promoteType_NC res_ty + let con_ki = ravelVanillaDType tvbs [] arg_kis res_ki + m_fixity <- reifyFixityWithLocals name' + defunctionalize name' m_fixity $ DefunSAK con_ki + +-- Generate defunctionalization symbols for a name, using reifyFixityWithLocals +-- to determine what the fixity of each symbol should be +-- (see Note [Fixity declarations for defunctionalization symbols]) +-- and dsReifyType to determine whether defunctionalization should make use +-- of SAKs or not (see Note [Defunctionalization game plan]). +defunReify :: Name -- Name of the declaration to be defunctionalized + -> [DTyVarBndrVis] -- The declaration's type variable binders + -- (only used if the declaration lacks a SAK) + -> Maybe DKind -- The declaration's return kind, if it has one + -- (only used if the declaration lacks a SAK) + -> PrM [DDec] +defunReify name tvbs m_res_kind = do + m_fixity <- reifyFixityWithLocals name + m_sak <- dsReifyType name + let defun = defunctionalize name m_fixity + case m_sak of + Just sak -> defun $ DefunSAK sak + Nothing -> defun $ DefunNoSAK tvbs m_res_kind + +-- Generate symbol data types, Apply instances, and other declarations required +-- for defunctionalization. +-- See Note [Defunctionalization game plan] for an overview of the design +-- considerations involved. +defunctionalize :: Name + -> Maybe Fixity + -> DefunKindInfo + -> PrM [DDec] +defunctionalize name m_fixity defun_ki = do + case defun_ki of + DefunSAK sak -> + -- Even if a declaration has a SAK, its kind may not be vanilla. + case unravelVanillaDType_either sak of + -- If the kind isn't vanilla, use the fallback approach. + -- See Note [Defunctionalization game plan], + -- Wrinkle 2: Non-vanilla kinds. + Left _ -> defun_fallback [] (Just sak) + -- Otherwise, proceed with defun_vanilla_sak. + Right (sak_tvbs, _sak_cxt, sak_arg_kis, sak_res_ki) + -> defun_vanilla_sak sak_tvbs sak_arg_kis sak_res_ki + -- If a declaration lacks a SAK, it likely has a partial kind. + -- See Note [Defunctionalization game plan], Wrinkle 1: Partial kinds. + DefunNoSAK tvbs m_res -> defun_fallback tvbs m_res + where + -- Generate defunctionalization symbols for things with vanilla SAKs. + -- The symbols themselves will also be given SAKs. + defun_vanilla_sak :: [DTyVarBndrSpec] -> [DKind] -> DKind -> PrM [DDec] + defun_vanilla_sak sak_tvbs sak_arg_kis sak_res_ki = do + opts <- getOptions + extra_name <- qNewName "arg" + let sak_arg_n = length sak_arg_kis + -- Use noExactName below to avoid GHC#17537. + -- See also Note [Pitfalls of NameU/NameL] in Data.Singletons.TH.Util. + arg_names <- replicateM sak_arg_n (noExactName <$> qNewName "a") + + let -- The inner loop. @go n arg_nks res_nks@ returns @(res_k, decls)@. + -- Using one particular example: + -- + -- @ + -- type ExampleSym2 :: a -> b -> c ~> d ~> Type + -- data ExampleSym2 (x :: a) (y :: b) :: c ~> d ~> Type where ... + -- type instance Apply (ExampleSym2 x y) z = ExampleSym3 x y z + -- ... + -- @ + -- + -- We have: + -- + -- * @n@ is 2. This is incremented in each iteration of `go`. + -- + -- * @arg_nks@ is [(x, a), (y, b)]. Each element in this list is a + -- (type variable name, type variable kind) pair. The kinds appear in + -- the SAK, separated by matchable arrows (->). + -- + -- * @res_tvbs@ is [(z, c), (w, d)]. Each element in this list is a + -- (type variable name, type variable kind) pair. The kinds appear in + -- @res_k@, separated by unmatchable arrows (~>). + -- + -- * @res_k@ is `c ~> d ~> Type`. @res_k@ is returned so that earlier + -- defunctionalization symbols can build on the result kinds of + -- later symbols. For instance, ExampleSym1 would get the result + -- kind `b ~> c ~> d ~> Type` by prepending `b` to ExampleSym2's + -- result kind `c ~> d ~> Type`. + -- + -- * @decls@ are all of the declarations corresponding to ExampleSym2 + -- and later defunctionalization symbols. This is the main payload of + -- the function. + -- + -- Note that the body of ExampleSym2 redundantly includes the + -- argument kinds and result kind, which are already stated in the + -- standalone kind signature. This is a deliberate choice. + -- See Note [Keep redundant kind information for Haddocks] + -- in D.S.TH.Promote. + -- + -- This function is quadratic because it appends a variable at the end of + -- the @arg_nks@ list at each iteration. In practice, this is unlikely + -- to be a performance bottleneck since the number of arguments rarely + -- gets to be that large. + go :: Int -> [(Name, DKind)] -> [(Name, DKind)] -> (DKind, [DDec]) + go n arg_nks res_nkss = + let arg_tvbs :: [DTyVarBndrVis] + arg_tvbs = map (\(na, ki) -> DKindedTV na BndrReq ki) arg_nks + + mk_sak_dec :: DKind -> DDec + mk_sak_dec res_ki = + DKiSigD (defunctionalizedName opts name n) $ + ravelVanillaDType sak_tvbs [] (map snd arg_nks) res_ki in + case res_nkss of + [] -> + let sat_sak_dec = mk_sak_dec sak_res_ki + sat_decs = mk_sat_decs opts n arg_tvbs (Just sak_res_ki) + in (sak_res_ki, sat_sak_dec:sat_decs) + res_nk:res_nks -> + let (res_ki, decs) = go (n+1) (arg_nks ++ [res_nk]) res_nks + tyfun = buildTyFunArrow (snd res_nk) res_ki + defun_sak_dec = mk_sak_dec tyfun + defun_other_decs = mk_defun_decs opts n sak_arg_n + arg_tvbs (fst res_nk) + extra_name (Just tyfun) + in (tyfun, defun_sak_dec:defun_other_decs ++ decs) + + pure $ snd $ go 0 [] $ zip arg_names sak_arg_kis + + -- If defun_sak can't be used to defunctionalize something, this fallback + -- approach is used. This is used when defunctionalizing something with a + -- partial kind + -- (see Note [Defunctionalization game plan], Wrinkle 1: Partial kinds) + -- or a non-vanilla kind + -- (see Note [Defunctionalization game plan], Wrinkle 2: Non-vanilla kinds). + defun_fallback :: [DTyVarBndrVis] -> Maybe DKind -> PrM [DDec] + defun_fallback tvbs' m_res' = do + opts <- getOptions + extra_name <- qNewName "arg" + -- Use noExactTyVars below to avoid GHC#11812. + -- See also Note [Pitfalls of NameU/NameL] in Data.Singletons.TH.Util. + (tvbs, m_res) <- eta_expand (noExactTyVars tvbs') (noExactTyVars m_res') + + let tvbs_n = length tvbs + + -- The inner loop. @go n arg_tvbs res_tvbs@ returns @(m_res_k, decls)@. + -- Using one particular example: + -- + -- @ + -- data ExampleSym2 (x :: a) y :: c ~> d ~> Type where ... + -- type instance Apply (ExampleSym2 x y) z = ExampleSym3 x y z + -- ... + -- @ + -- + -- This works very similarly to the `go` function in + -- `defun_vanilla_sak`. The main differences are: + -- + -- * This function does not produce any SAKs for defunctionalization + -- symbols. + -- + -- * Instead of [(Name, DKind)], this function uses [DTyVarBndr] as + -- the types of @arg_tvbs@ and @res_tvbs@. This is because the + -- kinds are not always known. By a similar token, this function + -- uses Maybe DKind, not DKind, as the type of @m_res_k@, since + -- the result kind is not always fully known. + go :: Int -> [DTyVarBndrVis] -> [DTyVarBndrVis] -> (Maybe DKind, [DDec]) + go n arg_tvbs res_tvbss = + case res_tvbss of + [] -> + let sat_decs = mk_sat_decs opts n arg_tvbs m_res + in (m_res, sat_decs) + res_tvb:res_tvbs -> + let (m_res_ki, decs) = go (n+1) (arg_tvbs ++ [res_tvb]) res_tvbs + m_tyfun = buildTyFunArrow_maybe (extractTvbKind res_tvb) + m_res_ki + defun_decs' = mk_defun_decs opts n tvbs_n arg_tvbs + (extractTvbName res_tvb) + extra_name m_tyfun + in (m_tyfun, defun_decs' ++ decs) + + pure $ snd $ go 0 [] tvbs + + mk_defun_decs :: Options + -> Int + -> Int + -> [DTyVarBndrVis] + -> Name + -> Name + -> Maybe DKind + -> [DDec] + mk_defun_decs opts n fully_sat_n arg_tvbs tyfun_name extra_name m_tyfun = + let data_name = defunctionalizedName opts name n + next_name = defunctionalizedName opts name (n+1) + con_name = prefixName "" ":" $ suffixName "KindInference" "###" data_name + params = arg_tvbs ++ [DPlainTV tyfun_name BndrReq] + con_eq_ct = DConT sameKindName `DAppT` lhs `DAppT` rhs + where + lhs = app_data_ty `apply` DVarT extra_name + rhs = foldTypeTvbs (DConT next_name) + (arg_tvbs ++ [DPlainTV extra_name BndrReq]) + con_decl = DCon [] [con_eq_ct] con_name (DNormalC False []) + (foldTypeTvbs (DConT data_name) params) + data_decl = DDataD Data [] data_name args m_tyfun [con_decl] [] + where + args | isJust m_tyfun = arg_tvbs + | otherwise = params + app_data_ty = foldTypeTvbs (DConT data_name) arg_tvbs + app_eqn = DTySynEqn Nothing + (DConT applyName `DAppT` app_data_ty + `DAppT` DVarT tyfun_name) + (foldTypeTvbs (DConT app_eqn_rhs_name) params) + -- If the next defunctionalization symbol is fully saturated, then + -- use the original declaration name instead. + -- See Note [Fully saturated defunctionalization symbols] + -- (Wrinkle: avoiding reduction stack overflows). + app_eqn_rhs_name | n+1 == fully_sat_n = name + | otherwise = next_name + app_decl = DTySynInstD app_eqn + suppress = DInstanceD Nothing Nothing [] + (DConT suppressClassName `DAppT` app_data_ty) + [DLetDec $ DFunD suppressMethodName + [DClause [] + ((DVarE 'snd) `DAppE` + mkTupleDExp [DConE con_name, + mkTupleDExp []])]] + + -- See Note [Fixity declarations for defunctionalization symbols] + fixity_decl = maybeToList $ fmap (mk_fix_decl data_name) m_fixity + in data_decl : app_decl : suppress : fixity_decl + + -- Generate a "fully saturated" defunction symbol, along with a fixity + -- declaration (if needed). + -- See Note [Fully saturated defunctionalization symbols]. + mk_sat_decs :: Options -> Int -> [DTyVarBndrVis] -> Maybe DKind -> [DDec] + mk_sat_decs opts n sat_tvbs m_sat_res = + let sat_name = defunctionalizedName opts name n + sat_dec = DClosedTypeFamilyD + (DTypeFamilyHead sat_name sat_tvbs + (maybeKindToResultSig m_sat_res) Nothing) + [DTySynEqn Nothing + (foldTypeTvbs (DConT sat_name) sat_tvbs) + (foldTypeTvbs (DConT name) sat_tvbs)] + sat_fixity_dec = maybeToList $ fmap (mk_fix_decl sat_name) m_fixity + in sat_dec : sat_fixity_dec + + -- Generate extra kind variable binders corresponding to the number of + -- arrows in the return kind (if provided). Examples: + -- + -- >>> eta_expand [(x :: a), (y :: b)] (Just (c -> Type)) + -- ([(x :: a), (y :: b), (e :: c)], Just Type) + -- + -- >>> eta_expand [(x :: a), (y :: b)] Nothing + -- ([(x :: a), (y :: b)], Nothing) + eta_expand :: [DTyVarBndrVis] -> Maybe DKind -> PrM ([DTyVarBndrVis], Maybe DKind) + eta_expand m_arg_tvbs Nothing = pure (m_arg_tvbs, Nothing) + eta_expand m_arg_tvbs (Just res_kind) = do + let (arg_ks, result_k) = unravelDType res_kind + vis_arg_ks = filterDVisFunArgs arg_ks + extra_arg_tvbs <- traverse mk_extra_tvb vis_arg_ks + pure (m_arg_tvbs ++ extra_arg_tvbs, Just result_k) + + -- Convert a DVisFunArg to a DTyVarBndr, generating a fresh type variable + -- name if the DVisFunArg is an anonymous argument. + mk_extra_tvb :: DVisFunArg -> PrM DTyVarBndrVis + mk_extra_tvb vfa = + case vfa of + DVisFADep tvb -> pure (BndrReq <$ tvb) + DVisFAAnon k -> (\n -> DKindedTV n BndrReq k) <$> + -- Use noExactName below to avoid GHC#19743. + -- See also Note [Pitfalls of NameU/NameL] + -- in Data.Singletons.TH.Util. + (noExactName <$> qNewName "e") + + mk_fix_decl :: Name -> Fixity -> DDec + mk_fix_decl n f = DLetDec $ DInfixD f n + +-- Indicates whether the type being defunctionalized has a standalone kind +-- signature. If it does, DefunSAK contains the kind. If not, DefunNoSAK +-- contains whatever information is known about its type variable binders +-- and result kind. +-- See Note [Defunctionalization game plan] for details on how this +-- information is used. +data DefunKindInfo + = DefunSAK DKind + | DefunNoSAK [DTyVarBndrVis] (Maybe DKind) + +-- Shorthand for building (k1 ~> k2) +buildTyFunArrow :: DKind -> DKind -> DKind +buildTyFunArrow k1 k2 = DConT tyFunArrowName `DAppT` k1 `DAppT` k2 + +buildTyFunArrow_maybe :: Maybe DKind -> Maybe DKind -> Maybe DKind +buildTyFunArrow_maybe m_k1 m_k2 = buildTyFunArrow <$> m_k1 <*> m_k2 + +{- +Note [Defunctionalization game plan] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generating defunctionalization symbols involves a surprising amount of +complexity. This Note gives a broad overview of what happens during +defunctionalization and highlights various design considerations. +As a working example, we will use the following type family: + + type Foo :: forall c a b. a -> b -> c -> c + type family Foo x y z where ... + +We must generate a defunctionalization symbol for every number of arguments +to which Foo can be partially applied. We do so by generating the following +declarations: + + type FooSym0 :: forall c a b. a ~> b ~> c ~> c + data FooSym0 f where + FooSym0KindInference :: SameKind (Apply FooSym0 arg) (FooSym1 arg) + => FooSym0 f + type instance Apply FooSym0 x = FooSym1 x + + type FooSym1 :: forall c a b. a -> b ~> c ~> c + data FooSym1 x f where + FooSym1KindInference :: SameKind (Apply (FooSym1 a) arg) (FooSym2 a arg) + => FooSym1 a f + type instance Apply (FooSym1 x) y = FooSym2 x y + + type FooSym2 :: forall c a b. a -> b -> c ~> c + data FooSym2 x y f where + FooSym2KindInference :: SameKind (Apply (FooSym2 x y) arg) (FooSym3 x y arg) + => FooSym2 x y f + type instance Apply (FooSym2 x y) z = Foo x y z + + type FooSym3 :: forall c a b. a -> b -> c -> c + type family FooSym3 x y z where + FooSym3 x y z = Foo x y z + +Some things to note: + +* Each defunctionalization symbol has its own standalone kind signature. The + number after `Sym` in each symbol indicates the number of leading -> arrows + in its kind—that is, the number of arguments to which it can be applied + directly to without the use of the Apply type family. + + See "Wrinkle 1: Partial kinds" below for what happens if the declaration + being defunctionalized does *not* have a standalone kind signature. + +* Each data declaration has a constructor with the suffix `-KindInference` + in its name. These are redundant in the particular case of Foo, where the + kind is already known. They play a more vital role when the kind of the + declaration being defunctionalized is only partially known. + See "Wrinkle 1: Partial kinds" below for more information. + +* FooSym3, the last defunctionalization symbol, is somewhat special in that + it is a type family, not a data type. These sorts of symbols are referred + to as "fully saturated" defunctionalization symbols. + See Note [Fully saturated defunctionalization symbols]. + +* If Foo had a fixity declaration (e.g., infixl 4 `Foo`), then we would also + generate fixity declarations for each defunctionalization symbol (e.g., + infixl 4 `FooSym0`). + See Note [Fixity declarations for defunctionalization symbols]. + +* Foo has a vanilla kind signature. (See + Note [Vanilla-type validity checking during promotion] in D.S.TH.Promote.Type + for what "vanilla" means in this context.) Having a vanilla type signature is + important, as it is a property that makes it much simpler to preserve the + order of type variables (`forall c a b.`) in each of the defunctionalization + symbols. + + That being said, it is not strictly required that the kind be vanilla. There + is another approach that can be used to defunctionalize things with + non-vanilla types, at the possible expense of having different type variable + orders between different defunctionalization symbols. + See "Wrinkle 2: Non-vanilla kinds" below for more information. + +----- +-- Wrinkle 1: Partial kinds +----- + +The Foo example above has a standalone kind signature, but not everything has +this much kind information. For example, consider this: + + $(singletons [d| + type family Not x where + Not False = True + Not True = False + |]) + +The inferred kind for Not is `Bool -> Bool`, but since Not was declared in TH +quotes, `singletons-th` has no knowledge of this. Instead, we must rely on kind +inference to give Not's defunctionalization symbols the appropriate kinds. +Here is a naïve first attempt: + + data NotSym0 f + type instance Apply NotSym0 x = Not x + + type family NotSym1 x where + NotSym1 x = Not x + +NotSym1 will have the inferred kind `Bool -> Bool`, but poor NotSym0 will have +the inferred kind `forall k. k -> Type`, which is far more general than we +would like. We can do slightly better by supplying additional kind information +in a data constructor, like so: + + type SameKind :: k -> k -> Constraint + class SameKind x y = () + + data NotSym0 f where + NotSym0KindInference :: SameKind (Apply NotSym0 arg) (NotSym1 arg) + => NotSym0 f + +NotSym0KindInference is not intended to ever be seen by the user. Its only +reason for existing is its existential +`SameKind (Apply NotSym0 arg) (NotSym1 arg)` context, which allows GHC to +figure out that NotSym0 has kind `Bool ~> Bool`. This is a bit of a hack, but +it works quite nicely. The only problem is that GHC is likely to warn that +NotSym0KindInference is unused, which is annoying. To work around this, we +mention the data constructor in an instance of a dummy class: + + instance SuppressUnusedWarnings NotSym0 where + suppressUnusedWarnings = snd (NotSym0KindInference, ()) + +Similarly, this SuppressUnusedWarnings class is not intended to ever be seen +by the user. As its name suggests, it only exists to help suppress "unused +data constructor" warnings. + +Some declarations have a mixture of known kinds and unknown kinds, such as in +this example: + + $(singletons [d| + type family Bar x (y :: Nat) (z :: Nat) :: Nat where ... + |]) + +We can use the known kinds to guide kind inference. In this particular example +of Bar, here are the defunctionalization symbols that would be generated: + + data BarSym0 f where ... + data BarSym1 x :: Nat ~> Nat ~> Nat where ... + data BarSym2 x (y :: Nat) :: Nat ~> Nat where ... + type family BarSym3 x (y :: Nat) (z :: Nat) :: Nat where ... + +----- +-- Wrinkle 2: Non-vanilla kinds +----- + +There is only limited support for defunctionalizing declarations with +non-vanilla kinds. One example of something with a non-vanilla kind is the +following, which uses a nested forall: + + $(singletons [d| + type Baz :: forall a. a -> forall b. b -> Type + data Baz x y + |]) + +One might envision generating the following defunctionalization symbols for +Baz: + + type BazSym0 :: forall a. a ~> forall b. b ~> Type + data BazSym0 f where ... + + type BazSym1 :: forall a. a -> forall b. b ~> Type + data BazSym1 x f where ... + + type BazSym2 :: forall a. a -> forall b. b -> Type + type family BazSym2 x y where + BazSym2 x y = Baz x y + +Unfortunately, doing so would require impredicativity, since we would have: + + forall a. a ~> forall b. b ~> Type + = forall a. (~>) a (forall b. b ~> Type) + = forall a. TyFun a (forall b. b ~> Type) -> Type + +Note that TyFun is an ordinary data type, so having its second argument be +(forall b. b ~> Type) is truly impredicative. As a result, trying to preserve +nested or higher-rank foralls is a non-starter. + +We need not reject Baz entirely, however. We can still generate perfectly +usable defunctionalization symbols if we are willing to sacrifice the exact +order of foralls. When we encounter a non-vanilla kind such as Baz's, we simply +fall back to the algorithm used when we encounter a partial kind (as described +in "Wrinkle 1: Partial kinds" above.) In other words, we generate the +following symbols: + + data BazSym0 :: a ~> b ~> Type where ... + data BazSym1 (x :: a) :: b ~> Type where ... + type family BazSym2 (x :: a) (y :: b) :: Type where ... + +The kinds of BazSym0 and BazSym1 both start with `forall a b.`, +whereas the `b` is quantified later in Baz itself. For most use cases, however, +this is not a huge concern. + +Another way kinds can be non-vanilla is if they contain visible dependent +quantification, like so: + + $(singletons [d| + type Quux :: forall (k :: Type) -> k -> Type + data Quux x y + |]) + +What should the kind of QuuxSym0 be? Intuitively, it should be this: + + type QuuxSym0 :: forall (k :: Type) ~> k ~> Type + +Alas, `forall (k :: Type) ~>` simply doesn't work. See #304. But there is an +acceptable compromise we can make that can give us defunctionalization symbols +for Quux. Once again, we fall back to the partial kind algorithm: + + data QuuxSym0 :: Type ~> k ~> Type where ... + data QuuxSym1 (k :: Type) :: k ~> Type where ... + type family QuuxSym2 (k :: Type) (x :: k) :: Type where ... + +The catch is that the kind of QuuxSym0, `forall k. Type ~> k ~> Type`, is +slightly more general than it ought to be. In practice, however, this is +unlikely to be a problem as long as you apply QuuxSym0 to arguments of the +right kinds. + +Note [Fully saturated defunctionalization symbols] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When generating defunctionalization symbols, most of the symbols are data +types. The last one, however, is a type family. For example, this code: + + $(singletons [d| + type Const :: a -> b -> a + type Const x y = x + |]) + +Will generate the following symbols: + + type ConstSym0 :: a ~> b ~> a + data ConstSym0 f where ... + + type ConstSym1 :: a -> b ~> a + data ConstSym1 x f where ... + + type ConstSym2 :: a -> b -> a + type family ConstSym2 x y where + ConstSym2 x y = Const x y + +ConstSym2, the sole type family of the bunch, is what is referred to as a +"fully saturated" defunctionaliztion symbol. + +At first glance, ConstSym2 may not seem terribly useful, since it is +effectively a thin wrapper around the original Const type. Indeed, fully +saturated symbols almost never appear directly in user-written code. Instead, +they are most valuable in TH-generated code, as singletons-th often generates code +that directly applies a defunctionalization symbol to some number of arguments +(see, for instance, D.S.TH.Names.promoteTySym). In theory, such code could carve +out a special case for fully saturated applications and apply the original +type instead of a defunctionalization symbol, but determining when an +application is fully saturated is often difficult in practice. As a result, it +is more convenient to just generate code that always applies FuncSymN to N +arguments, and to let fully saturated defunctionalization symbols handle the +case where N equals the number of arguments needed to fully saturate Func. + +One might wonder if, instead of using a closed type family with a single +equation, we could use a type synonym to define ConstSym2: + + type ConstSym2 :: a -> b -> a + type ConstSym2 x y = Const x y + +This approach has various downsides which make it impractical: + +* Type synonyms are often not expanded in the output of GHCi's :kind! command. + As issue #445 chronicles, this can significantly impact the readability of + even simple :kind! queries. It can be the difference between this: + + λ> :kind! Map IdSym0 '[1,2,3] + Map IdSym0 '[1,2,3] :: [Nat] + = 1 :@#@$$$ '[2, 3] + + And this: + + λ> :kind! Map IdSym0 '[1,2,3] + Map IdSym0 '[1,2,3] :: [Nat] + = '[1, 2, 3] + + Making fully saturated defunctionalization symbols like (:@#@$$$) type + families makes this issue moot, since :kind! always expands type families. +* There are a handful of corner cases where using type synonyms can actually + make fully saturated defunctionalization symbols fail to typecheck. + Here is one such corner case: + + $(promote [d| + class Applicative f where + pure :: a -> f a + ... + (*>) :: f a -> f b -> f b + |]) + + ==> + + class PApplicative f where + type Pure (x :: a) :: f a + type (*>) (x :: f a) (y :: f b) :: f b + + What would happen if we were to defunctionalize the promoted version of (*>)? + We'd end up with the following defunctionalization symbols: + + type (*>@#@$) :: f a ~> f b ~> f b + data (*>@#@$) f where ... + + type (*>@#@$$) :: f a -> f b ~> f b + data (*>@#@$$) x f where ... + + type (*>@#@$$$) :: f a -> f b -> f b + type (*>@#@$$$) x y = (*>) x y + + It turns out, however, that (*>@#@$$$) will not kind-check. Because (*>@#@$$$) + has a standalone kind signature, it is kind-generalized *before* kind-checking + the actual definition itself. Therefore, the full kind is: + + type (*>@#@$$$) :: forall {k} (f :: k -> Type) (a :: k) (b :: k). + f a -> f b -> f b + type (*>@#@$$$) x y = (*>) x y + + However, the kind of (*>) is + `forall (f :: Type -> Type) (a :: Type) (b :: Type). f a -> f b -> f b`. + This is not general enough for (*>@#@$$$), which expects kind-polymorphic `f`, + `a`, and `b`, leading to a kind error. You might think that we could somehow + infer this information, but note the quoted definition of Applicative (and + PApplicative, as a consequence) omits the kinds of `f`, `a`, and `b` entirely. + Unless we were to implement full-blown kind inference inside of Template + Haskell (which is a tall order), the kind `f a -> f b -> f b` is about as good + as we can get. + + Making (*>@#@$$$) a type family rather than a type synonym avoids this issue + since type family equations are allowed to match on kind arguments. In this + example, (*>@#@$$$) would have kind-polymorphic `f`, `a`, and `b` in its kind + signature, but its equation would implicitly equate `k` with `Type`. Note + that (*>@#@$) and (*>@#@$$), which are GADTs, also use a similar trick by + equating `k` with `Type` in their GADT constructors. + +----- +-- Wrinkle: avoiding reduction stack overflows +----- + +A naïve attempt at declaring all fully saturated defunctionalization symbols +as type families can make certain programs overflow the reduction stack, such +as the T445 test case. This is because when evaluating +`FSym0 `Apply` x_1 `Apply` ... `Apply` x_N`, (where F is a promoted function +that requires N arguments), we will eventually bottom out by evaluating +`FSymN x_1 ... x_N`, where FSymN is a fully saturated defunctionalization +symbol. Since FSymN is a type family, this is yet another type family +reduction that contributes to the overall reduction limit. This might not +seem like a lot, but it can add up if F is invoked several times in a single +type-level computation! + +Fortunately, we can bypass evaluating FSymN entirely by just making a slight +tweak to the TH machinery. Instead of generating this Apply instance: + + type instance Apply (FSym{N-1} x_1 ... x_{N-1}) x_N = + FSymN x_1 ... x_{N-1} x_N + +Generate this instance, which jumps straight to F: + + type instance Apply (FSym{N-1} x_1 ... x_{N-1}) x_N = + F x_1 ... x_{N-1} x_N + +Now evaluating `FSym0 `Apply` x_1 `Apply` ... `Apply` x_N` will require one +less type family reduction. In practice, this is usually enough to keep the +reduction limit at bay in most situations. + +Note [Fixity declarations for defunctionalization symbols] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Just like we promote fixity declarations, we should also generate fixity +declarations for defunctionaliztion symbols. A primary use case is the +following scenario: + + (.) :: (b -> c) -> (a -> b) -> (a -> c) + (f . g) x = f (g x) + infixr 9 . + +One often writes (f . g . h) at the value level, but because (.) is promoted +to a type family with three arguments, this doesn't directly translate to the +type level. Instead, one must write this: + + f .@#@$$$ g .@#@$$$ h + +But in order to ensure that this associates to the right as expected, one must +generate an `infixr 9 .@#@#$$$` declaration. This is why defunctionalize accepts +a Maybe Fixity argument. +-} diff --git a/src/Data/Singletons/TH/Promote/Monad.hs b/src/Data/Singletons/TH/Promote/Monad.hs --- a/src/Data/Singletons/TH/Promote/Monad.hs +++ b/src/Data/Singletons/TH/Promote/Monad.hs @@ -1,117 +1,435 @@ -{- Data/Singletons/TH/Promote/Monad.hs - -(c) Richard Eisenberg 2014 -rae@cs.brynmawr.edu - -This file defines the PrM monad and its operations, for use during promotion. - -The PrM monad allows reading from a PrEnv environment and writing to a list -of DDec, and is wrapped around a Q. --} - -module Data.Singletons.TH.Promote.Monad ( - PrM, promoteM, promoteM_, promoteMDecs, VarPromotions, - allLocals, emitDecs, emitDecsM, - lambdaBind, LetBind, letBind, lookupVarE - ) where - -import Control.Monad.Reader -import Control.Monad.Writer -import Language.Haskell.TH.Syntax hiding ( lift ) -import Language.Haskell.TH.Desugar -import qualified Language.Haskell.TH.Desugar.OMap.Strict as OMap -import Language.Haskell.TH.Desugar.OMap.Strict (OMap) -import Data.Singletons.TH.Options -import Data.Singletons.TH.Syntax - -type LetExpansions = OMap Name DType -- from **term-level** name - --- environment during promotion -data PrEnv = - PrEnv { pr_options :: Options - , pr_lambda_bound :: OMap Name Name - , pr_let_bound :: LetExpansions - , pr_local_decls :: [Dec] - } - -emptyPrEnv :: PrEnv -emptyPrEnv = PrEnv { pr_options = defaultOptions - , pr_lambda_bound = OMap.empty - , pr_let_bound = OMap.empty - , pr_local_decls = [] } - --- the promotion monad -newtype PrM a = PrM (ReaderT PrEnv (WriterT [DDec] Q) a) - deriving ( Functor, Applicative, Monad, Quasi - , MonadReader PrEnv, MonadWriter [DDec] - , MonadFail, MonadIO ) - -instance DsMonad PrM where - localDeclarations = asks pr_local_decls - -instance OptionsMonad PrM where - getOptions = asks pr_options - --- return *type-level* names -allLocals :: MonadReader PrEnv m => m [Name] -allLocals = do - lambdas <- asks (OMap.assocs . pr_lambda_bound) - lets <- asks pr_let_bound - -- filter out shadowed variables! - return [ typeName - | (termName, typeName) <- lambdas - , case OMap.lookup termName lets of - Just (DVarT typeName') | typeName' == typeName -> True - _ -> False ] - -emitDecs :: MonadWriter [DDec] m => [DDec] -> m () -emitDecs = tell - -emitDecsM :: MonadWriter [DDec] m => m [DDec] -> m () -emitDecsM action = do - decs <- action - emitDecs decs - --- when lambda-binding variables, we still need to add the variables --- to the let-expansion, because of shadowing. ugh. -lambdaBind :: VarPromotions -> PrM a -> PrM a -lambdaBind binds = local add_binds - where add_binds env@(PrEnv { pr_lambda_bound = lambdas - , pr_let_bound = lets }) = - let new_lets = OMap.fromList [ (tmN, DVarT tyN) | (tmN, tyN) <- binds ] in - env { pr_lambda_bound = OMap.fromList binds `OMap.union` lambdas - , pr_let_bound = new_lets `OMap.union` lets } - -type LetBind = (Name, DType) -letBind :: [LetBind] -> PrM a -> PrM a -letBind binds = local add_binds - where add_binds env@(PrEnv { pr_let_bound = lets }) = - env { pr_let_bound = OMap.fromList binds `OMap.union` lets } - -lookupVarE :: Name -> PrM DType -lookupVarE n = do - opts <- getOptions - lets <- asks pr_let_bound - case OMap.lookup n lets of - Just ty -> return ty - Nothing -> return $ DConT $ defunctionalizedName0 opts n - -promoteM :: OptionsMonad q => [Dec] -> PrM a -> q (a, [DDec]) -promoteM locals (PrM rdr) = do - opts <- getOptions - other_locals <- localDeclarations - let wr = runReaderT rdr (emptyPrEnv { pr_options = opts - , pr_local_decls = other_locals ++ locals }) - q = runWriterT wr - runQ q - -promoteM_ :: OptionsMonad q => [Dec] -> PrM () -> q [DDec] -promoteM_ locals thing = do - ((), decs) <- promoteM locals thing - return decs - --- promoteM specialized to [DDec] -promoteMDecs :: OptionsMonad q => [Dec] -> PrM [DDec] -> q [DDec] -promoteMDecs locals thing = do - (decs1, decs2) <- promoteM locals thing - return $ decs1 ++ decs2 +{- Data/Singletons/TH/Promote/Monad.hs + +(c) Richard Eisenberg 2014 +rae@cs.brynmawr.edu + +This file defines the PrM monad and its operations, for use during promotion. + +The PrM monad allows reading from a PrEnv environment and writing to a list +of DDec, and is wrapped around a Q. +-} + +module Data.Singletons.TH.Promote.Monad ( + PrM, promoteM, promoteM_, promoteMDecs, VarPromotions, + allLocals, emitDecs, emitDecsM, + scopedBind, lambdaBind, LetBind, letBind, lookupVarE + ) where + +import Control.Monad.Reader +import Control.Monad.Writer +import qualified Data.Foldable as F +import Language.Haskell.TH.Syntax hiding ( lift ) +import Language.Haskell.TH.Desugar +import qualified Language.Haskell.TH.Desugar.OMap.Strict as OMap +import Language.Haskell.TH.Desugar.OMap.Strict (OMap) +import qualified Language.Haskell.TH.Desugar.OSet as OSet +import Language.Haskell.TH.Desugar.OSet (OSet) +import Data.Singletons.TH.Options +import Data.Singletons.TH.Syntax + +-- environment during promotion +data PrEnv = + PrEnv { pr_options :: Options + , pr_scoped_vars :: OSet Name + -- ^ The set of scoped type variables currently in scope. + -- See @Note [Scoped type variables]@. + , pr_lambda_vars :: OMap Name Name + -- ^ Map from term-level 'Name's of variables bound in lambdas and + -- function clauses to their type-level counterparts. + -- See @Note [Tracking local variables]@. + , pr_local_vars :: OMap Name DType + -- ^ Map from term-level 'Name's of local variables to their + -- type-level counterparts. Note that scoped type variables are stored + -- separately in 'pr_scoped_tvs'. + -- See @Note [Tracking local variables]@. + , pr_local_decls :: [Dec] + } + +emptyPrEnv :: PrEnv +emptyPrEnv = PrEnv { pr_options = defaultOptions + , pr_scoped_vars = OSet.empty + , pr_lambda_vars = OMap.empty + , pr_local_vars = OMap.empty + , pr_local_decls = [] } + +-- the promotion monad +newtype PrM a = PrM (ReaderT PrEnv (WriterT [DDec] Q) a) + deriving ( Functor, Applicative, Monad, Quasi + , MonadReader PrEnv, MonadWriter [DDec] + , MonadFail, MonadIO ) + +instance DsMonad PrM where + localDeclarations = asks pr_local_decls + +instance OptionsMonad PrM where + getOptions = asks pr_options + +-- return *type-level* names +allLocals :: MonadReader PrEnv m => m [Name] +allLocals = do + scoped <- asks (F.toList . pr_scoped_vars) + lambdas <- asks (OMap.assocs . pr_lambda_vars) + return $ scoped ++ map snd lambdas + +emitDecs :: MonadWriter [DDec] m => [DDec] -> m () +emitDecs = tell + +emitDecsM :: MonadWriter [DDec] m => m [DDec] -> m () +emitDecsM action = do + decs <- action + emitDecs decs + +-- ^ Bring a list of type variables into scope for the duration the supplied +-- computation. See @Note [Tracking local variables]@ and +-- @Note [Scoped type variables]@. +scopedBind :: OSet Name -> PrM a -> PrM a +scopedBind binds = + local (\env@(PrEnv { pr_scoped_vars = scoped }) -> + env { pr_scoped_vars = binds `OSet.union` scoped }) + +-- ^ Bring a list of 'VarPromotions' into scope for the duration the supplied +-- computation. See @Note [Tracking local variables]@. +lambdaBind :: VarPromotions -> PrM a -> PrM a +lambdaBind binds = local add_binds + where add_binds env@(PrEnv { pr_lambda_vars = lambdas + , pr_local_vars = locals }) = + -- Per Note [Tracking local variables], these will be added to both + -- `pr_lambda_vars` and `pr_local_vars`. + let new_locals = OMap.fromList [ (tmN, DVarT tyN) | (tmN, tyN) <- binds ] in + env { pr_lambda_vars = OMap.fromList binds `OMap.union` lambdas + , pr_local_vars = new_locals `OMap.union` locals } + +-- ^ A pair consisting of a term-level 'Name' of a variable, bound in a @let@ +-- binding or @where@ clause, and its type-level counterpart. +-- See @Note [Tracking local variables]@. +type LetBind = (Name, DType) + +-- ^ Bring a list of 'LetBind's into scope for the duration the supplied +-- computation. See @Note [Tracking local variables]@. +letBind :: [LetBind] -> PrM a -> PrM a +letBind binds = local add_binds + where add_binds env@(PrEnv { pr_local_vars = locals }) = + env { pr_local_vars = OMap.fromList binds `OMap.union` locals } + +-- | Map a term-level 'Name' to its type-level counterpart. This function is +-- aware of any local variables that are currently in scope. +-- See @Note [Tracking local variables]@. +lookupVarE :: Name -> PrM DType +lookupVarE n = do + opts <- getOptions + locals <- asks pr_local_vars + case OMap.lookup n locals of + Just ty -> return ty + Nothing -> return $ DConT $ defunctionalizedName0 opts n + +promoteM :: OptionsMonad q => [Dec] -> PrM a -> q (a, [DDec]) +promoteM locals (PrM rdr) = do + opts <- getOptions + other_locals <- localDeclarations + let wr = runReaderT rdr (emptyPrEnv { pr_options = opts + , pr_local_decls = other_locals ++ locals }) + q = runWriterT wr + runQ q + +promoteM_ :: OptionsMonad q => [Dec] -> PrM () -> q [DDec] +promoteM_ locals thing = do + ((), decs) <- promoteM locals thing + return decs + +-- promoteM specialized to [DDec] +promoteMDecs :: OptionsMonad q => [Dec] -> PrM [DDec] -> q [DDec] +promoteMDecs locals thing = do + (decs1, decs2) <- promoteM locals thing + return $ decs1 ++ decs2 + +{- +Note [Tracking local variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Handling local variables in singletons-th requires some care. There are three +sorts of local variables that singletons-th tracks: + +1. Scoped type variables, e.g., + + d :: forall a. Maybe a + d = Nothing :: Maybe a + + e (x :: a) = Nothing :: Maybe a + + In both `d` and `e`, the variable `a` in `:: Maybe a` is scoped. + +2. Lambda-bound variables, e.g., + + f = \x -> x + g x = x + + In both `f` and `g`, the variable `x` is considered lambda-bound. + +3. Let-bound variables, e.g., + + h = + let x = 42 in + x + x + + i = x + x + where + x = 42 + + In both `h` and `i`, the variable `x` is considered let-bound. + +Why does singletons-th need to track local variables? It's because they must +be promoted differently depending on whether they are local or not. Consider: + + j = ... x ... + +When promoting the `j` function to a type family `J`, there are four possible +ways of promoting `x`: + +* If `x` is a scoped type variable, then `x` must be promoted to the same + name. This is because promoting a type variable to a kind variable is a + no-op. For instance, we would promote this: + + j (z :: x) = (z :: x) + + Here, `(%%)`, `x`, and `y` are lambda-bound variables. But we cannot promote + `j` to this type family: + + type family J arg where + J (z :: x) = (z :: x) + +* If `x` is a lambda-bound variable, then `x` must be promoted to a type + variable. In general, we cannot promote `x` to the same name. Consider this + example: + + j (%%) x y = x %% y + + Here, `(%%)`, `x`, and `y` are lambda-bound variables. But we cannot promote + `j` to this type family: + + type family J (%%) x y where + J (%%) x y = x %% y + + This is because type variable names cannot be symbolic like `(%%)` is. As a + result, we create a fresh name `ty` and promote each occurrence of `(%%)` to + `ty`: + + type family J ty x y where + J ty x y = x `ty` y + + See `mkTyName` in Data.Singletons.TH.Names. In fact, `mkTyName` will also + freshen alphanumeric names, so it would be more accurate to say that `j` will + be promoted to this: + + type family J ty x_123 y_456 where + J ty x_123 y_456 = x_123 `ty` y_456 + + Where `x_123` and `y_456` are fresh names that are distinct from `x` and `y`. + Freshening alphanumeric names like `x` and `y` is probably not strictly + necessary, but `mkTyName` does it anyway (1) for consistency with symbolic + names and (2) to make the type-level names easier to tell apart from the + original term-level names. + +* If `x` is a let-bound variable, then `x` must be promoted to something like + `LetX`, where `LetX` is the lambda-lifted version of `x`. For instance, we + would promote this: + + j = x + where + x = True + + To this: + + type family J where + J = LetX + type family LetX where + LetX = True + +* If `x` is not a local variable at all, then `x` must be promoted to something + like `X`, which is assumed to be a top-level function. For instance, we would + promote this: + + x = 42 + j = x + + To this: + + type family X where + X = 42 + type family J where + J = X + +Being able to distinguish between all these sorts of variables requires +recording whether they are scoped, lambda-bound, or let-bound at their binding +sites during promotion and singling. This is primarily done in two places: + +* During promotion, the `pr_local_vars` field of `PrEnv` tracks lambda- and + let-bound variables. + +* During singling, the `sg_local_vars` field of `SgEnv` tracks lambda- and + let-bound variables. + +Each of these fields are Maps from the original, term-level Names to the +promoted or singled versions of the Names. The `lookupVarE` functions (which +can be found in both Data.Singletons.TH.Promote.Monad and +Data.Singletons.TH.Single.Monad) are responsible for determining what a +term-level Name should be mapped to. + +In addition to `pr_local_vars` and `sg_local_vars`, which include both lambda- +and let-bound variables, `PrEnv` also includes two additional fields for +tracking other sorts of local variables: + +* The `pr_scoped_vars` field tracks which scoped type variables are currently + in scope. As discussed above, promoting an occurrence of a scoped type + variable is a no-op, and as such, we never need to use `lookupVarE` to figure + out what a scoped type variable promotes to. As such, there is no need to put + the scoped type variables in `pr_local_vars`. + + On the other hand, we /do/ need to track the scoped type variables for + lambda-lifting purposes (see Note [Scoped type variables]), and this is the + only reason why we bother maintaining the `pr_scoped_vars` field in the first + place. See the `scopedBind` function, which is responsible for adding new + scoped type variables to `pr_scoped_vars`. + +* The `pr_lambda_vars` field only tracks lambda-bound variables, unlike + `pr_local_vars`, which also includes let-bound variables. We must do this + because lambda-bound variables are treated differently during lambda lifting. + Lambda-lifted functions must close over any lambda-bound variables in scope, + but /not/ any let-bound variables in scope, since the latter are + lambda-lifted separately. + + A consequence of this is that when we lambda-bind a variable during promotion + (see `lambdaBind`), we add the variable to both `pr_lambda_vars` and + `pr_local_vars`. When we let-bind a variable during promotion (see + `letBind`), we only add the variable to `pr_local_vars`. This means that + `pr_lambda_vars` will always be a subset of `pr_local_vars`. + +Because singling does not do anything akin to lambda lifting, `SgEnv` does not +have anything like `sg_scoped_vars` or `sg_lambda_vars`. + +Note [Scoped type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Scoped type variables are a particular form of local variable (see Note +[Tracking local variables]). They are arguably the trickiest form of local +variable to handle, and as noted in the singletons README, there are still some +forms of scoped type variables that singletons-th cannot handle during +promotion. + +First, let's discuss how singletons-th promotes scoped type variables in +general: + +* When promoting a function with a top-level type signature, we annotate each + argument on the left-hand sides of type family equations with its kind. This + is usually redundant, but it can sometimes be useful for bringing type + variables into scope. For example, this: + + f :: forall a. a -> Maybe a + f x = (Just x :: Maybe a) + + Will be promoted to something like this: + + type F :: forall a. a -> Maybe a + type family F x where + F (x :: a) = (Just x :: Maybe a) + + Note that we gave the `x` on the left-hand side of `F`'s equation an explicit + `:: a` kind signature to ensure that the `a` on the right-hand side of the + type family equation is in scope. + + The `promoteClause` function in Data.Singletons.TH.Promote is responsible for + implementing this. + +* Sometimes, there are no arguments available to bring type variables into + scope. In these situations, we can sometimes use `@` in type family equations + as an alternative. For example, this: + + g :: forall a. Maybe a + g = (Nothing :: Maybe a) + + Will be promoted to this: + + type G :: forall a. Maybe a + type family G where + G @a = (Nothing :: Maybe a) + + Note the `@a` on `G`'s left-hand side. This relies on `G` having a standalone + kind signature to work. + + The `promoteLetDecName` function in Data.Singletons.TH.Promote is responsible + for implementing this. + +* When lambda-lifting, singletons-th tracks the current set of scoped type + variables and includes them as explicit arguments when promoting local + definitions. For example, this: + + h :: forall a. a -> a + h x = i + where + i = (x :: a) + + Will be promoted to this: + + type H :: forall a. a -> a + type family H x where + H @a (x :: a) = LetI a x + + type I a x where + I a x = (x :: a) + + The `I` type family includes both `a` (a scoped type variable) and `x` (a + lambda-bound variable) as explicit arguments to ensure that they are in scope + on the right-hand side, which mentions both of them. + + singletons-th uses the `pr_scoped_vars` field of `PrM` to track scoped type + variables. Whenever new scoped type variables are bound during promotion, the + `scopedBind` function is used to add the variables to `pr_scoped_vars`. + +These three tricks suffice to handle a substantial number of ways that scoped +type variables can be used. The approach is not perfect, however. Here are two +scenarios where singletons-th fails to promote scoped type variables: + +* Funky pattern signatures like this one will not work: + + j :: forall a. a -> a + j (x :: b) = b + + This is because singletons-th will attempt to promote `j` like so: + + type J :: forall a. a -> a + type J x where + J @a ((x :: b) :: a) = b + + But unlike in terms, GHC has no way to know that `a` and `b` are meant to + refer to the same type variable. In order to make this work, we would need to + substitute all occurrences of `a` with `b` in the type family equation (or + vice versa), which seems challenging in the general case. + +* Scoped type variables that are only mentioned in the return types of local + definitions may not always work, such as in this example: + + k x = y + where + y :: forall b. Maybe b + y = Nothing :: Maybe b + + singletons-th would promote `k` and `y` to the following type families: + + type K x where + K x = LetY x + + type LetY x :: Maybe b where + LetY x = Nothing :: Maybe b + + Note that because `LetY` closes over the `x` argument, it cannot easily be + given a standalone kind signature, and this prevents us from writing + `LetY @b x = ...`. Moreover, `LetY` does not have an argument that we can + attach an explicit `:: b` signature to. (Attaching it to `x` would be + incorrect, as that would give `LetY` a less general kind.) + + One possible way forward here would be to give type families the ability to + write result signatures on their left-hand sides, similar to what GHC + proposal #228 + (https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0228-function-result-sigs.rst) + offers: + + type LetY x :: Maybe b where + LetY x :: Maybe b = Nothing :: Maybe b +-} diff --git a/src/Data/Singletons/TH/Promote/Type.hs b/src/Data/Singletons/TH/Promote/Type.hs --- a/src/Data/Singletons/TH/Promote/Type.hs +++ b/src/Data/Singletons/TH/Promote/Type.hs @@ -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. +-} diff --git a/src/Data/Singletons/TH/Single.hs b/src/Data/Singletons/TH/Single.hs --- a/src/Data/Singletons/TH/Single.hs +++ b/src/Data/Singletons/TH/Single.hs @@ -1,1093 +1,1118 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} - -{- Data/Singletons/TH/Single.hs - -(c) Richard Eisenberg 2013 -rae@cs.brynmawr.edu - -This file contains functions to refine constructs to work with singleton -types. It is an internal module to the singletons-th package. --} - -module Data.Singletons.TH.Single where - -import Prelude hiding ( exp ) -import Language.Haskell.TH hiding ( cxt ) -import Language.Haskell.TH.Syntax (NameSpace(..), Quasi(..)) -import Data.Singletons.TH.Deriving.Bounded -import Data.Singletons.TH.Deriving.Enum -import Data.Singletons.TH.Deriving.Eq -import Data.Singletons.TH.Deriving.Infer -import Data.Singletons.TH.Deriving.Ord -import Data.Singletons.TH.Deriving.Show -import Data.Singletons.TH.Deriving.Util -import Data.Singletons.TH.Names -import Data.Singletons.TH.Options -import Data.Singletons.TH.Partition -import Data.Singletons.TH.Promote -import Data.Singletons.TH.Promote.Defun -import Data.Singletons.TH.Promote.Monad ( promoteM ) -import Data.Singletons.TH.Promote.Type -import Data.Singletons.TH.Single.Data -import Data.Singletons.TH.Single.Decide -import Data.Singletons.TH.Single.Defun -import Data.Singletons.TH.Single.Fixity -import Data.Singletons.TH.Single.Monad -import Data.Singletons.TH.Single.Type -import Data.Singletons.TH.Syntax -import Data.Singletons.TH.Util -import Language.Haskell.TH.Desugar -import qualified Language.Haskell.TH.Desugar.OMap.Strict as OMap -import Language.Haskell.TH.Desugar.OMap.Strict (OMap) -import qualified Data.Map.Strict as Map -import Data.Map.Strict ( Map ) -import Data.Maybe -import qualified Data.Set as Set -import Control.Monad -import Control.Monad.Trans.Class -import Data.List (unzip6, zipWith4) -import qualified GHC.LanguageExtensions.Type as LangExt - -{- -How singletons-th works -~~~~~~~~~~~~~~~~~~~~~~~ - -Singling, on the surface, doesn't seem all that complicated. Promote the type, -and singletonize all the terms. That's essentially what was done singletons < 1.0. -But, now we want to deal with higher-order singletons. So, things are a little -more complicated. - -The way to understand all of this is that *every* variable maps to something -of type (Sing t), for an appropriately-kinded t. This includes functions, which -use the "SLambda" instance of Sing. To apply singleton functions, we use the -applySing function. - -That, in and of itself, wouldn't be too hard, but it's really annoying from -the user standpoint. After dutifully singling `map`, a user doesn't want to -have to use two `applySing`s to actually use it. So, any let-bound identifier -is eta-expanded so that the singled type has the same number of arrows as -the original type. (If there is no original type signature, then it has as -many arrows as the original had patterns.) Then, we store a use of one of the -singFunX functions in the SgM environment so that every use of a let-bound -identifier has a proper type (Sing t). - -It would be consistent to avoid this eta-expansion for local lets (as opposed -to top-level lets), but that seemed like more bother than it was worth. It -may also be possible to be cleverer about nested eta-expansions and contractions, -but that also seemed not to be worth it. Though I haven't tested it, my hope -is that the eta-expansions and contractions have no runtime effect, especially -because SLambda is a *newtype* instance, not a *data* instance. - -Note that to maintain the desired invariant, we must also be careful to eta- -contract constructors. This is the point of buildDataLets. --} - --- | Generate singled definitions for each of the provided type-level --- declaration 'Name's. For example, the singletons-th package itself uses --- --- > $(genSingletons [''Bool, ''Maybe, ''Either, ''[]]) --- --- to generate singletons for Prelude types. -genSingletons :: OptionsMonad q => [Name] -> q [Dec] -genSingletons names = do - opts <- getOptions - -- See Note [Disable genQuotedDecs in genPromotions and genSingletons] - -- in D.S.TH.Promote - withOptions opts{genQuotedDecs = False} $ do - checkForRep names - ddecs <- concatMapM (singInfo <=< dsInfo <=< reifyWithLocals) names - return $ decsToTH ddecs - --- | Make promoted and singled versions of all declarations given, retaining --- the original declarations. See the --- @@ --- for further explanation. -singletons :: OptionsMonad q => q [Dec] -> q [Dec] -singletons qdecs = do - opts <- getOptions - withOptions opts{genQuotedDecs = True} $ singletons' $ lift qdecs - --- | Make promoted and singled versions of all declarations given, discarding --- the original declarations. Note that a singleton based on a datatype needs --- the original datatype, so this will fail if it sees any datatype declarations. --- Classes, instances, and functions are all fine. -singletonsOnly :: OptionsMonad q => q [Dec] -> q [Dec] -singletonsOnly qdecs = do - opts <- getOptions - withOptions opts{genQuotedDecs = False} $ singletons' $ lift qdecs - --- The workhorse for 'singletons' and 'singletonsOnly'. The difference between --- the two functions is whether 'genQuotedDecs' is set to 'True' or 'False'. -singletons' :: OptionsMonad q => q [Dec] -> q [Dec] -singletons' qdecs = do - opts <- getOptions - decs <- qdecs - ddecs <- withLocalDeclarations decs $ dsDecs decs - singDecs <- singTopLevelDecs decs ddecs - let origDecs | genQuotedDecs opts = decs - | otherwise = [] - return $ origDecs ++ decsToTH singDecs - --- | Create instances of 'SEq' for the given types -singEqInstances :: OptionsMonad q => [Name] -> q [Dec] -singEqInstances = concatMapM singEqInstance - --- | Create instance of 'SEq' for the given type -singEqInstance :: OptionsMonad q => Name -> q [Dec] -singEqInstance = singInstance mkEqInstance "Eq" - --- | Create instances of 'SDecide', 'TestEquality', and 'TestCoercion' for each --- type in the list. -singDecideInstances :: OptionsMonad q => [Name] -> q [Dec] -singDecideInstances = concatMapM singDecideInstance - --- | Create instances of 'SDecide', 'TestEquality', and 'TestCoercion' for the --- given type. -singDecideInstance :: OptionsMonad q => Name -> q [Dec] -singDecideInstance name = do - (_df, tvbs, cons) <- getDataD ("I cannot make an instance of SDecide for it.") name - dtvbs <- mapM dsTvbUnit tvbs - let data_ty = foldTypeTvbs (DConT name) dtvbs - dcons <- concatMapM (dsCon dtvbs data_ty) cons - (scons, _) <- singM [] $ mapM (singCtor name) dcons - sDecideInstance <- mkDecideInstance Nothing data_ty dcons scons - testInstances <- traverse (mkTestInstance Nothing data_ty name dcons) - [TestEquality, TestCoercion] - return $ decsToTH (sDecideInstance:testInstances) - --- | Create instances of 'SOrd' for the given types -singOrdInstances :: OptionsMonad q => [Name] -> q [Dec] -singOrdInstances = concatMapM singOrdInstance - --- | Create instance of 'SOrd' for the given type -singOrdInstance :: OptionsMonad q => Name -> q [Dec] -singOrdInstance = singInstance mkOrdInstance "Ord" - --- | Create instances of 'SBounded' for the given types -singBoundedInstances :: OptionsMonad q => [Name] -> q [Dec] -singBoundedInstances = concatMapM singBoundedInstance - --- | Create instance of 'SBounded' for the given type -singBoundedInstance :: OptionsMonad q => Name -> q [Dec] -singBoundedInstance = singInstance mkBoundedInstance "Bounded" - --- | Create instances of 'SEnum' for the given types -singEnumInstances :: OptionsMonad q => [Name] -> q [Dec] -singEnumInstances = concatMapM singEnumInstance - --- | Create instance of 'SEnum' for the given type -singEnumInstance :: OptionsMonad q => Name -> q [Dec] -singEnumInstance = singInstance mkEnumInstance "Enum" - --- | Create instance of 'SShow' for the given type --- --- (Not to be confused with 'showShowInstance'.) -singShowInstance :: OptionsMonad q => Name -> q [Dec] -singShowInstance = singInstance mkShowInstance "Show" - --- | Create instances of 'SShow' for the given types --- --- (Not to be confused with 'showSingInstances'.) -singShowInstances :: OptionsMonad q => [Name] -> q [Dec] -singShowInstances = concatMapM singShowInstance - --- | Create instance of 'Show' for the given singleton type --- --- (Not to be confused with 'singShowInstance'.) -showSingInstance :: OptionsMonad q => Name -> q [Dec] -showSingInstance name = do - (df, tvbs, cons) <- getDataD ("I cannot make an instance of Show for it.") name - dtvbs <- mapM dsTvbUnit tvbs - let data_ty = foldTypeTvbs (DConT name) dtvbs - dcons <- concatMapM (dsCon dtvbs data_ty) cons - let tyvars = map (DVarT . extractTvbName) dtvbs - kind = foldType (DConT name) tyvars - data_decl = DataDecl df name dtvbs dcons - deriv_show_decl = DerivedDecl { ded_mb_cxt = Nothing - , ded_type = kind - , ded_type_tycon = name - , ded_decl = data_decl } - (show_insts, _) <- singM [] $ singDerivedShowDecs deriv_show_decl - pure $ decsToTH show_insts - --- | Create instances of 'Show' for the given singleton types --- --- (Not to be confused with 'singShowInstances'.) -showSingInstances :: OptionsMonad q => [Name] -> q [Dec] -showSingInstances = concatMapM showSingInstance - --- | Create an instance for @'SingI' TyCon{N}@, where @N@ is the positive --- number provided as an argument. --- --- Note that the generated code requires the use of the @QuantifiedConstraints@ --- language extension. -singITyConInstances :: DsMonad q => [Int] -> q [Dec] -singITyConInstances = mapM singITyConInstance - --- | Create an instance for @'SingI' TyCon{N}@, where @N@ is the positive --- number provided as an argument. --- --- Note that the generated code requires the use of the @QuantifiedConstraints@ --- language extension. -singITyConInstance :: DsMonad q => Int -> q Dec -singITyConInstance n - | n <= 0 - = fail $ "Argument must be a positive number (given " ++ show n ++ ")" - | otherwise - = do as <- replicateM n (qNewName "a") - ks <- replicateM n (qNewName "k") - k_last <- qNewName "k_last" - f <- qNewName "f" - x <- qNewName "x" - let k_penult = last ks - k_fun = ravelVanillaDType [] [] (map DVarT ks) (DVarT k_last) - f_ty = DVarT f - a_tys = map DVarT as - mk_fun arrow t1 t2 = arrow `DAppT` t1 `DAppT` t2 - matchable_apply_fun = mk_fun DArrowT (DVarT k_penult) (DVarT k_last) - unmatchable_apply_fun = mk_fun (DConT tyFunArrowName) (DVarT k_penult) (DVarT k_last) - ctxt = [ DForallT (DForallInvis (map (`DPlainTV` SpecifiedSpec) as)) $ - DConstrainedT (map (DAppT (DConT singIName)) a_tys) - (DConT singIName `DAppT` foldType f_ty a_tys) - , DConT equalityName - `DAppT` (DConT applyTyConName `DSigT` - mk_fun DArrowT matchable_apply_fun unmatchable_apply_fun) - `DAppT` DConT applyTyConAux1Name - ] - pure $ decToTH - $ DInstanceD - Nothing Nothing ctxt - (DConT singIName `DAppT` (DConT (mkTyConName n) `DAppT` (f_ty `DSigT` k_fun))) - [DLetDec $ DFunD singMethName - [DClause [] $ - wrapSingFun 1 DWildCardT $ - DLamE [x] $ - DVarE withSingIName `DAppE` DVarE x - `DAppE` DVarE singMethName]] - -singInstance :: OptionsMonad q => DerivDesc q -> String -> Name -> q [Dec] -singInstance mk_inst inst_name name = do - (df, tvbs, cons) <- getDataD ("I cannot make an instance of " ++ inst_name - ++ " for it.") name - dtvbs <- mapM dsTvbUnit tvbs - let data_ty = foldTypeTvbs (DConT name) dtvbs - dcons <- concatMapM (dsCon dtvbs data_ty) cons - let data_decl = DataDecl df name dtvbs dcons - raw_inst <- mk_inst Nothing data_ty data_decl - (a_inst, decs) <- promoteM [] $ - promoteInstanceDec OMap.empty Map.empty raw_inst - decs' <- singDecsM [] $ (:[]) <$> singInstD a_inst - return $ decsToTH (decs ++ decs') - -singInfo :: OptionsMonad q => DInfo -> q [DDec] -singInfo (DTyConI dec _) = - singTopLevelDecs [] [dec] -singInfo (DPrimTyConI _name _numArgs _unlifted) = - fail "Singling of primitive type constructors not supported" -singInfo (DVarI _name _ty _mdec) = - fail "Singling of value info not supported" -singInfo (DTyVarI _name _ty) = - fail "Singling of type variable info not supported" -singInfo (DPatSynI {}) = - fail "Singling of pattern synonym info not supported" - -singTopLevelDecs :: OptionsMonad q => [Dec] -> [DDec] -> q [DDec] -singTopLevelDecs locals raw_decls = withLocalDeclarations locals $ do - decls <- expand raw_decls -- expand type synonyms - PDecs { pd_let_decs = letDecls - , pd_class_decs = classes - , pd_instance_decs = insts - , pd_data_decs = datas - , pd_ty_syn_decs = ty_syns - , pd_open_type_family_decs = o_tyfams - , pd_closed_type_family_decs = c_tyfams - , pd_derived_eq_decs = derivedEqDecs - , pd_derived_show_decs = derivedShowDecs } <- partitionDecs decls - - ((letDecEnv, classes', insts'), promDecls) <- promoteM locals $ do - defunTopLevelTypeDecls ty_syns c_tyfams o_tyfams - recSelLetDecls <- promoteDataDecs datas - (_, letDecEnv) <- promoteLetDecs Nothing $ recSelLetDecls ++ letDecls - classes' <- mapM promoteClassDec classes - let meth_sigs = foldMap (lde_types . cd_lde) classes - cls_tvbs_map = Map.fromList $ map (\cd -> (cd_name cd, cd_tvbs cd)) classes - insts' <- mapM (promoteInstanceDec meth_sigs cls_tvbs_map) insts - return (letDecEnv, classes', insts') - - singDecsM locals $ do - dataLetBinds <- concatMapM buildDataLets datas - methLetBinds <- concatMapM buildMethLets classes - let letBinds = dataLetBinds ++ methLetBinds - (newLetDecls, singIDefunDecls, newDecls) - <- bindLets letBinds $ - singLetDecEnv letDecEnv $ do - newDataDecls <- concatMapM singDataD datas - newClassDecls <- mapM singClassD classes' - newInstDecls <- mapM singInstD insts' - newDerivedEqDecs <- concatMapM singDerivedEqDecs derivedEqDecs - newDerivedShowDecs <- concatMapM singDerivedShowDecs derivedShowDecs - return $ newDataDecls ++ newClassDecls - ++ newInstDecls - ++ newDerivedEqDecs - ++ newDerivedShowDecs - return $ promDecls ++ (map DLetDec newLetDecls) ++ singIDefunDecls ++ newDecls - --- see comment at top of file -buildDataLets :: OptionsMonad q => DataDecl -> q [(Name, DExp)] -buildDataLets (DataDecl _df _name _tvbs cons) = do - opts <- getOptions - pure $ concatMap (con_num_args opts) cons - where - con_num_args :: Options -> DCon -> [(Name, DExp)] - con_num_args opts (DCon _tvbs _cxt name fields _rty) = - (name, wrapSingFun (length (tysOfConFields fields)) - (DConT $ defunctionalizedName0 opts name) - (DConE $ singledDataConName opts name)) - : rec_selectors opts fields - - rec_selectors :: Options -> DConFields -> [(Name, DExp)] - rec_selectors _ (DNormalC {}) = [] - rec_selectors opts (DRecC fields) = - let names = map fstOf3 fields in - [ (name, wrapSingFun 1 (DConT $ defunctionalizedName0 opts name) - (DVarE $ singledValueName opts name)) - | name <- names ] - --- see comment at top of file -buildMethLets :: OptionsMonad q => UClassDecl -> q [(Name, DExp)] -buildMethLets (ClassDecl { cd_lde = LetDecEnv { lde_types = meth_sigs } }) = do - opts <- getOptions - pure $ map (mk_bind opts) (OMap.assocs meth_sigs) - where - mk_bind opts (meth_name, meth_ty) = - ( meth_name - , wrapSingFun (countArgs meth_ty) (DConT $ defunctionalizedName0 opts meth_name) - (DVarE $ singledValueName opts meth_name) ) - -singClassD :: AClassDecl -> SgM DDec -singClassD (ClassDecl { cd_cxt = cls_cxt - , cd_name = cls_name - , cd_tvbs = cls_tvbs - , cd_fds = cls_fundeps - , cd_lde = LetDecEnv { lde_defns = default_defns - , lde_types = meth_sigs - , lde_infix = fixities - , lde_proms = promoted_defaults } }) = - bindContext [foldTypeTvbs (DConT cls_name) cls_tvbs] $ do - opts <- getOptions - mb_cls_sak <- dsReifyType cls_name - let sing_cls_name = singledClassName opts cls_name - mb_sing_cls_sak = fmap (DKiSigD sing_cls_name) mb_cls_sak - cls_infix_decls <- singReifiedInfixDecls $ cls_name:meth_names - (sing_sigs, _, tyvar_names, cxts, res_kis, singIDefunss) - <- unzip6 <$> zipWithM (singTySig no_meth_defns meth_sigs) - meth_names - (map (DConT . defunctionalizedName0 opts) meth_names) - emitDecs $ maybeToList mb_sing_cls_sak ++ cls_infix_decls ++ concat singIDefunss - let default_sigs = catMaybes $ - zipWith4 (mk_default_sig opts) meth_names sing_sigs - tyvar_names res_kis - sing_meths <- mapM (uncurry (singLetDecRHS (Map.fromList cxts))) - (OMap.assocs default_defns) - fixities' <- mapMaybeM (uncurry singInfixDecl) $ OMap.assocs fixities - cls_cxt' <- mapM singPred cls_cxt - return $ DClassD cls_cxt' - sing_cls_name - cls_tvbs - cls_fundeps -- they are fine without modification - (map DLetDec (sing_sigs ++ sing_meths ++ fixities') ++ default_sigs) - where - no_meth_defns = error "Internal error: can't find declared method type" - meth_names = map fst $ OMap.assocs meth_sigs - - mk_default_sig :: Options -> Name -> DLetDec -> [Name] -> Maybe DType -> Maybe DDec - mk_default_sig opts meth_name (DSigD s_name sty) bound_kvs (Just res_ki) = - DDefaultSigD s_name <$> add_constraints opts meth_name sty bound_kvs res_ki - mk_default_sig _ _ _ _ _ = error "Internal error: a singled signature isn't a signature." - - add_constraints :: Options -> Name -> DType -> [Name] -> DType -> Maybe DType - -- We must look through `... :: Type` kind annotations, which can be added - -- when singling type signatures lacking explicit `forall`s. - -- See Note [Preserve the order of type variables during singling] - -- (wrinkle 1) in D.S.TH.Single.Type. - add_constraints opts meth_name (DSigT sty ski) bound_kvs res_ki = do - sty' <- add_constraints opts meth_name sty bound_kvs res_ki - pure $ DSigT sty' ski - add_constraints opts meth_name sty bound_kvs res_ki = do - (tvbs, cxt, args, res) <- unravelVanillaDType sty - prom_dflt <- OMap.lookup meth_name promoted_defaults - - -- Filter out explicitly bound kind variables. Otherwise, if you had - -- the following class (#312): - -- - -- class Foo a where - -- bar :: a -> b -> b - -- bar _ x = x - -- - -- Then it would be singled to: - -- - -- class SFoo a where - -- sBar :: forall b (x :: a) (y :: b). Sing x -> Sing y -> Sing (sBar x y) - -- default :: forall b (x :: a) (y :: b). - -- (Bar b x y) ~ (BarDefault b x y) => ... - -- - -- Which applies Bar/BarDefault to b, which shouldn't happen. - let tvs = map tvbToType $ - filter (\tvb -> extractTvbName tvb `Set.member` bound_kv_set) tvbs - prom_meth = DConT $ defunctionalizedName0 opts meth_name - default_pred = foldType (DConT equalityName) - -- NB: Need the res_ki here to prevent ambiguous - -- kinds in result-inferred default methods. - -- See #175 - [ foldApply prom_meth tvs `DSigT` res_ki - , foldApply prom_dflt tvs ] - return $ ravelVanillaDType tvbs (default_pred : cxt) args res - where - bound_kv_set = Set.fromList bound_kvs - -singInstD :: AInstDecl -> SgM DDec -singInstD (InstDecl { id_cxt = cxt, id_name = inst_name, id_arg_tys = inst_tys - , id_sigs = inst_sigs, id_meths = ann_meths }) = do - opts <- getOptions - let s_inst_name = singledClassName opts inst_name - bindContext cxt $ do - cxt' <- mapM singPred cxt - inst_kis <- mapM promoteType inst_tys - meths <- concatMapM (uncurry sing_meth) ann_meths - return (DInstanceD Nothing - Nothing - cxt' - (foldl DAppT (DConT s_inst_name) inst_kis) - meths) - - where - sing_meth :: Name -> ALetDecRHS -> SgM [DDec] - sing_meth name rhs = do - opts <- getOptions - mb_s_info <- dsReify (singledValueName opts name) - inst_kis <- mapM promoteType inst_tys - let mk_subst cls_tvbs = Map.fromList $ zip (map extractTvbName vis_cls_tvbs) inst_kis - where - -- This is a half-hearted attempt to address the underlying problem - -- in #358, where we can sometimes have more class type variables - -- (due to implicit kind arguments) than class arguments. This just - -- ensures that the explicit type variables are properly mapped - -- to the class arguments, leaving the implicit kind variables - -- unmapped. That could potentially cause *other* problems, but - -- those are perhaps best avoided by using InstanceSigs. At the - -- very least, this workaround will make error messages slightly - -- less confusing. - vis_cls_tvbs = drop (length cls_tvbs - length inst_kis) cls_tvbs - - sing_meth_ty :: DType -> SgM DType - sing_meth_ty inner_ty = do - -- Make sure to expand through type synonyms here! Not doing so - -- resulted in #167. - raw_ty <- expand inner_ty - (s_ty, _num_args, _tyvar_names, _ctxt, _arg_kis, _res_ki) - <- singType (DConT $ defunctionalizedName0 opts name) raw_ty - pure s_ty - - s_ty <- case OMap.lookup name inst_sigs of - Just inst_sig -> - -- We have an InstanceSig, so just single that type. - sing_meth_ty inst_sig - Nothing -> case mb_s_info of - -- We don't have an InstanceSig, so we must compute the type to use - -- in the singled instance ourselves through reification. - Just (DVarI _ (DForallT (DForallInvis cls_tvbs) (DConstrainedT _cls_pred s_ty)) _) -> - pure $ substType (mk_subst cls_tvbs) s_ty - _ -> do - mb_info <- dsReify name - case mb_info of - Just (DVarI _ (DForallT (DForallInvis cls_tvbs) - (DConstrainedT _cls_pred inner_ty)) _) -> do - s_ty <- sing_meth_ty inner_ty - pure $ substType (mk_subst cls_tvbs) s_ty - _ -> fail $ "Cannot find type of method " ++ show name - - meth' <- singLetDecRHS - Map.empty -- Because we are singling an instance declaration, - -- we aren't generating defunctionalization symbols - -- for the class methods, and hence we aren't - -- generating any SingI instances. Therefore, we - -- don't need to include anything in this Map. - name rhs - return $ map DLetDec [DSigD (singledValueName opts name) s_ty, meth'] - -singLetDecEnv :: ALetDecEnv - -> SgM a - -> SgM ([DLetDec], [DDec], a) - -- Return: - -- - -- 1. The singled let-decs - -- 2. SingI instances for any defunctionalization symbols - -- (see Data.Singletons.TH.Single.Defun) - -- 3. The result of running the `SgM a` action -singLetDecEnv (LetDecEnv { lde_defns = defns - , lde_types = types - , lde_infix = infix_decls - , lde_proms = proms }) - thing_inside = do - let prom_list = OMap.assocs proms - (typeSigs, letBinds, _tyvarNames, cxts, _res_kis, singIDefunss) - <- unzip6 <$> mapM (uncurry (singTySig defns types)) prom_list - infix_decls' <- mapMaybeM (uncurry singInfixDecl) $ OMap.assocs infix_decls - bindLets letBinds $ do - let_decs <- mapM (uncurry (singLetDecRHS (Map.fromList cxts))) - (OMap.assocs defns) - thing <- thing_inside - return (infix_decls' ++ typeSigs ++ let_decs, concat singIDefunss, thing) - -singTySig :: OMap Name ALetDecRHS -- definitions - -> OMap Name DType -- type signatures - -> Name -> DType -- the type is the promoted type, not the type sig! - -> SgM ( DLetDec -- the new type signature - , (Name, DExp) -- the let-bind entry - , [Name] -- the scoped tyvar names in the tysig - , (Name, DCxt) -- the context of the type signature - , Maybe DKind -- the result kind in the tysig - , [DDec] -- SingI instances for defun symbols - ) -singTySig defns types name prom_ty = do - opts <- getOptions - let sName = singledValueName opts name - case OMap.lookup name types of - Nothing -> do - num_args <- guess_num_args - (sty, tyvar_names) <- mk_sing_ty num_args - singIDefuns <- singDefuns name VarName [] - (map (const Nothing) tyvar_names) Nothing - return ( DSigD sName sty - , (name, wrapSingFun num_args prom_ty (DVarE sName)) - , tyvar_names - , (name, []) - , Nothing - , singIDefuns ) - Just ty -> do - (sty, num_args, tyvar_names, ctxt, arg_kis, res_ki) - <- singType prom_ty ty - bound_cxt <- askContext - singIDefuns <- singDefuns name VarName (bound_cxt ++ ctxt) - (map Just arg_kis) (Just res_ki) - return ( DSigD sName sty - , (name, wrapSingFun num_args prom_ty (DVarE sName)) - , tyvar_names - , (name, ctxt) - , Just res_ki - , singIDefuns ) - where - guess_num_args :: SgM Int - guess_num_args = - case OMap.lookup name defns of - Nothing -> fail "Internal error: promotion known for something not let-bound." - Just (AValue _) -> return 0 - Just (AFunction n _) -> return n - - -- create a Sing t1 -> Sing t2 -> ... type of a given arity and result type - mk_sing_ty :: Int -> SgM (DType, [Name]) - mk_sing_ty n = do - arg_names <- replicateM n (qNewName "arg") - -- If there are no arguments, use `Sing @_` instead of `Sing`. - -- See Note [Disable kind generalization for local functions if possible] - let sing_w_wildcard | n == 0 = singFamily `DAppKindT` DWildCardT - | otherwise = singFamily - return ( ravelVanillaDType - (map (`DPlainTV` SpecifiedSpec) arg_names) - [] - (map (\nm -> singFamily `DAppT` DVarT nm) arg_names) - (sing_w_wildcard `DAppT` - (foldApply prom_ty (map DVarT arg_names))) - , arg_names ) - -{- -Note [Disable kind generalization for local functions if possible] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this example (from #296): - - f :: forall a. MyProxy a -> MyProxy a - f MyProxy = - let x = let z :: MyProxy a - z = MyProxy in z - in x - -A naïve attempt at singling `f` is as follows: - - type LetZ :: MyProxy a - type family LetZ where - LetZ = 'MyProxy - - type family LetX where - LetX = LetZ - - type F :: forall a. MyProxy a -> MyProxy a - type family F x where - F 'MyProxy = LetX - - sF :: forall a (t :: MyProxy a). Sing t -> Sing (F t :: MyProxy a) - sF SMyProxy = - let sX :: Sing LetX - sX = let sZ :: Sing (LetZ :: MyProxy a) - sZ = SMyProxy in sZ - in sX - -This will not typecheck, however. The is because the return kind of -`LetX` (in `let sX :: Sing LetX`) will get generalized by virtue of `sX` -having a type signature. It's as if one had written this: - - sF :: forall a (t :: MyProxy a). Sing t -> Sing (F t :: MyProxy a) - sF SMyProxy = - let sX :: forall a1. Sing (LetX :: MyProxy a1) - sX = ... - -This is too general, since `sX` will only typecheck if the return kind of -`LetX` is `MyProxy a`, not `MyProxy a1`. In order to avoid this problem, -we need to avoid kind generalization when kind-checking the type of `sX`. -To accomplish this, we borrow a trick from -Note [The id hack; or, how singletons-th learned to stop worrying and avoid kind generalization] -and use TypeApplications plus a wildcard type. That is, we generate this code -for `sF`: - - sF :: forall a (t :: MyProxy a). Sing t -> Sing (F t :: MyProxy a) - sF SMyProxy = - let sX :: Sing @_ LetX - sX = ... - -The presence of the wildcard type disables kind generalization, which allows -GHC's kind inference to deduce that the return kind of `LetX` should be `a`. -Now `sF` typechecks, and since we only use wildcards within visible kind -applications, we don't even have to force users to enable -PartialTypeSignatures. Hooray! - -Question: where should we put wildcard types when singling? One possible answer -is: put a wildcard in any type signature that gets generated when singling a -function that lacks a type signature. Unfortunately, this is a step too far. -This will break singling the `foldr` function: - - foldr :: (a -> b -> b) -> b -> [a] -> b - foldr k z = go - where - go [] = z - go (y:ys) = y `k` go ys - -If the type of `sGo` is given a wildcard, then it will fail to typecheck. This -is because `sGo` is polymorphically recursive, so disabling kind generalization -forces GHC to infer `sGo`'s type. Attempting to infer a polymorphically -recursive type, unsurprisingly, leads to failure. - -To avoid this sort of situation, where adopt a simple metric: if a function -lacks a type signature, only put @_ in its singled type signature if it has -zero arguments. This allows `sX` to typecheck without breaking things like -`sGo`. This metric is a bit conservative, however, since it means that this -small tweak to `x` still would not typecheck: - - f :: forall a. MyProxy a -> MyProxy a - f MyProxy = - let x () = let z :: MyProxy a - z = MyProxy in z - in x () - -We need not let perfect be the enemy of good, however. It is extremely -common for local definitions to have zero arguments, so it makes good sense -to optimize for that special case. In fact, this special treatment is the only -reason that `foo8` from the `T183` test case singles successfully, since -the as-patterns in `foo8` desugar to code very similar to the `f` example -above. --} - -singLetDecRHS :: Map Name DCxt -- the context of the type signature - -- (might not be known) - -> Name -> ALetDecRHS -> SgM DLetDec -singLetDecRHS cxts name ld_rhs = do - opts <- getOptions - bindContext (Map.findWithDefault [] name cxts) $ - case ld_rhs of - AValue exp -> - DValD (DVarP (singledValueName opts name)) <$> - singExp exp - AFunction _num_arrows clauses -> - DFunD (singledValueName opts name) <$> - mapM singClause clauses - -singClause :: ADClause -> SgM DClause -singClause (ADClause var_proms pats exp) = do - (sPats, sigPaExpsSigs) <- evalForPair $ mapM (singPat (Map.fromList var_proms)) pats - sBody <- singExp exp - return $ DClause sPats $ mkSigPaCaseE sigPaExpsSigs sBody - -singPat :: Map Name Name -- from term-level names to type-level names - -> ADPat - -> QWithAux SingDSigPaInfos SgM DPat -singPat var_proms = go - where - go :: ADPat -> QWithAux SingDSigPaInfos SgM DPat - go (ADLitP _lit) = - fail "Singling of literal patterns not yet supported" - go (ADVarP name) = do - opts <- getOptions - tyname <- case Map.lookup name var_proms of - Nothing -> - fail "Internal error: unknown variable when singling pattern" - Just tyname -> return tyname - pure $ DVarP (singledValueName opts name) - `DSigP` (singFamily `DAppT` DVarT tyname) - go (ADConP name tys pats) = do - opts <- getOptions - DConP (singledDataConName opts name) tys <$> mapM go pats - go (ADTildeP pat) = do - qReportWarning - "Lazy pattern converted into regular pattern during singleton generation." - go pat - go (ADBangP pat) = DBangP <$> go pat - go (ADSigP prom_pat pat ty) = do - pat' <- go pat - -- Normally, calling dPatToDExp would be dangerous, since it fails if the - -- supplied pattern contains any wildcard patterns. However, promotePat - -- (which produced the pattern we're passing into dPatToDExp) maintains - -- an invariant that any promoted pattern signatures will be free of - -- wildcard patterns in the underlying pattern. - -- See Note [Singling pattern signatures]. - addElement (dPatToDExp pat', DSigT prom_pat ty) - pure pat' - go ADWildP = pure DWildP - --- | If given a non-empty list of 'SingDSigPaInfos', construct a case expression --- that brings singleton equality constraints into scope via pattern-matching. --- See @Note [Singling pattern signatures]@. -mkSigPaCaseE :: SingDSigPaInfos -> DExp -> DExp -mkSigPaCaseE exps_with_sigs exp - | null exps_with_sigs = exp - | otherwise = - let (exps, sigs) = unzip exps_with_sigs - scrutinee = mkTupleDExp exps - pats = map (DSigP DWildP . DAppT (DConT singFamilyName)) sigs - in DCaseE scrutinee [DMatch (mkTupleDPat pats) exp] - --- Note [Annotate case return type] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- We're straining GHC's type inference here. One particular trouble area --- is determining the return type of a GADT pattern match. In general, GHC --- cannot infer return types of GADT pattern matches because the return type --- becomes "untouchable" in the case matches. See the OutsideIn paper. But, --- during singletonization, we *know* the return type. So, just add a type --- annotation. See #54. --- --- In particular, we add a type annotation in a somewhat unorthodox fashion. --- Instead of the usual `(x :: t)`, we use `id @t x`. See --- Note [The id hack; or, how singletons-th learned to stop worrying and avoid --- kind generalization] for an explanation of why we do this. - --- Note [Why error is so special] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Some of the transformations that happen before this point produce impossible --- case matches. We must be careful when processing these so as not to make --- an error GHC will complain about. When binding the case-match variables, we --- normally include an equality constraint saying that the scrutinee is equal --- to the matched pattern. But, we can't do this in inaccessible matches, because --- equality is bogus, and GHC (rightly) complains. However, we then have another --- problem, because GHC doesn't have enough information when type-checking the --- RHS of the inaccessible match to deem it type-safe. The solution: treat error --- as super-special, so that GHC doesn't look too hard at singletonized error --- calls. Specifically, DON'T do the applySing stuff. Just use sError, which --- has a custom type (Sing x -> a) anyway. - --- Note [Singling pattern signatures] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- We want to single a pattern signature, like so: --- --- f :: Maybe a -> a --- f (Just x :: Maybe a) = x --- --- Naïvely, one might expect this to single straightfowardly as: --- --- sF :: forall (z :: Maybe a). Sing z -> Sing (F z) --- sF (SJust sX :: Sing (Just x :: Maybe a)) = sX --- --- But the way GHC typechecks patterns prevents this from working, as GHC won't --- know that the type `z` is actually `Just x` until /after/ the entirety of --- the `SJust sX` pattern has been typechecked. (See Trac #12018 for an --- extended discussion on this topic.) --- --- To work around this design, we resort to a somewhat unsightly trick: --- immediately after matching on all the patterns, we perform a case on every --- pattern with a pattern signature, like so: --- --- sF :: forall (z :: Maybe a). Sing z -> Sing (F z) --- sF (SJust sX :: Sing z) --- = case (SJust sX :: Sing z) of --- (_ :: Sing (Just x :: Maybe a)) -> sX --- --- Now GHC accepts the fact that `z` is `Just x`, and all is well. In order --- to support this construction, the type of singPat is augmented with some --- extra information in the form of SingDSigPaInfos: --- --- type SingDSigPaInfos = [(DExp, DType)] --- --- Where the DExps corresponds to the expressions we case on just after the --- patterns (`SJust sX :: Sing x`, in the example above), and the DTypes --- correspond to the singled pattern signatures to use in the case alternative --- (`Sing (Just x :: Maybe a)` in the example above). singPat appends to the --- list of SingDSigPaInfos whenever it processes a DSigPa (pattern signature), --- and call sites can pass these SingDSigPaInfos to mkSigPaCaseE to construct a --- case expression like the one featured above. --- --- Some interesting consequences of this design: --- --- 1. We must promote DPats to ADPats, a variation of DPat where the annotated --- DSigPa counterpart, ADSigPa, stores the type that the original DPat was --- promoted to. This is necessary since promoting the type might have --- generated fresh variable names, so we need to be able to use the same --- names when singling. --- --- 2. Also when promoting a DSigPa to an ADSigPa, we remove any wildcards from --- the underlying pattern. To see why this is necessary, consider singling --- this example: --- --- g (Just _ :: Maybe a) = "hi" --- --- This must single to something like this: --- --- sG (SJust _ :: Sing z) --- = case (SJust _ :: Sing z) of --- (_ :: Sing (Just _ :: Maybe a)) -> "hi" --- --- But `SJust _` is not a valid expression, and since the minimal th-desugar --- AST lacks as-patterns, we can't replace it with something like --- `sG x@(SJust _ :: Sing z) = case x of ...`. But even if the th-desugar --- AST /did/ have as-patterns, we'd still be in trouble, as `Just _` isn't --- a valid type without the use of -XPartialTypeSignatures, which isn't a --- design we want to force upon others. --- --- We work around both issues by simply converting all wildcard patterns --- from the pattern that has a signature. That means our example becomes: --- --- sG (SJust sWild :: Sing z) --- = case (SJust sWild :: Sing z) of --- (_ :: Sing (Just wild :: Maybe a)) -> "hi" --- --- And now everything is hunky-dory. - -singExp :: ADExp -> SgM DExp - -- See Note [Why error is so special] -singExp (ADVarE err `ADAppE` arg) - | err == errorName = do opts <- getOptions - DAppE (DVarE (singledValueName opts err)) <$> - singExp arg -singExp (ADVarE name) = lookupVarE name -singExp (ADConE name) = lookupConE name -singExp (ADLitE lit) = singLit lit -singExp (ADAppE e1 e2) = do - e1' <- singExp e1 - e2' <- singExp e2 - -- `applySing undefined x` kills type inference, because GHC can't figure - -- out the type of `undefined`. So we don't emit `applySing` there. - if isException e1' - then return $ e1' `DAppE` e2' - else return $ (DVarE applySingName) `DAppE` e1' `DAppE` e2' -singExp (ADLamE ty_names prom_lam names exp) = do - opts <- getOptions - let sNames = map (singledValueName opts) names - exp' <- singExp exp - -- we need to bind the type variables... but DLamE doesn't allow SigT patterns. - -- So: build a case - let caseExp = DCaseE (mkTupleDExp (map DVarE sNames)) - [DMatch (mkTupleDPat - (map ((DWildP `DSigP`) . - (singFamily `DAppT`) . - DVarT) ty_names)) exp'] - return $ wrapSingFun (length names) prom_lam $ DLamE sNames caseExp -singExp (ADCaseE exp matches ret_ty) = - -- See Note [Annotate case return type] and - -- Note [The id hack; or, how singletons-th learned to stop worrying and - -- avoid kind generalization] - DAppE (DAppTypeE (DVarE 'id) - (singFamily `DAppT` ret_ty)) - <$> (DCaseE <$> singExp exp <*> mapM singMatch matches) -singExp (ADLetE env exp) = do - -- We intentionally discard the SingI instances for exp's defunctionalization - -- symbols, as we also do not generate the declarations for the - -- defunctionalization symbols in the first place during promotion. - (let_decs, _, exp') <- singLetDecEnv env $ singExp exp - pure $ DLetE let_decs exp' -singExp (ADSigE prom_exp exp ty) = do - exp' <- singExp exp - pure $ DSigE exp' $ DConT singFamilyName `DAppT` DSigT prom_exp ty - --- See Note [DerivedDecl] in Data.Singletons.TH.Syntax -singDerivedEqDecs :: DerivedEqDecl -> SgM [DDec] -singDerivedEqDecs (DerivedDecl { ded_mb_cxt = mb_ctxt - , ded_type = ty - , ded_type_tycon = ty_tycon - , ded_decl = DataDecl _ _ _ cons }) = do - (scons, _) <- singM [] $ mapM (singCtor ty_tycon) cons - mb_sctxt <- mapM (mapM singPred) mb_ctxt - kind <- promoteType ty - -- Beware! The user might have specified an instance context like this: - -- - -- deriving instance Eq a => Eq (T a Int) - -- - -- When we single the context, it will become (SEq a). But we do *not* want - -- this for the SDecide instance! The simplest solution is to simply replace - -- all occurrences of SEq with SDecide in the context. - mb_sctxtDecide <- traverse (traverse sEqToSDecide) mb_sctxt - sDecideInst <- mkDecideInstance mb_sctxtDecide kind cons scons - testInsts <- traverse (mkTestInstance mb_sctxtDecide kind ty_tycon cons) - [TestEquality, TestCoercion] - return (sDecideInst:testInsts) - --- Walk a DPred, replacing all occurrences of SEq with SDecide. -sEqToSDecide :: OptionsMonad q => DPred -> q DPred -sEqToSDecide p = do - opts <- getOptions - pure $ modifyConNameDType (\n -> - if n == singledClassName opts eqName - then sDecideClassName - else n) p - --- See Note [DerivedDecl] in Data.Singletons.TH.Syntax -singDerivedShowDecs :: DerivedShowDecl -> SgM [DDec] -singDerivedShowDecs (DerivedDecl { ded_mb_cxt = mb_cxt - , ded_type = ty - , ded_type_tycon = ty_tycon - , ded_decl = DataDecl _ _ _ cons }) = do - opts <- getOptions - z <- qNewName "z" - -- Generate a Show instance for a singleton type, like this: - -- - -- deriving instance (ShowSing a, ShowSing b) => Sing (SEither (z :: Either a b)) - -- - -- Be careful: we want to generate an instance context that uses ShowSing, - -- not SShow. - show_cxt <- inferConstraintsDef (fmap mkShowSingContext mb_cxt) - (DConT showSingName) - ty cons - ki <- promoteType ty - let sty_tycon = singledDataTypeName opts ty_tycon - show_inst = DStandaloneDerivD Nothing Nothing show_cxt - (DConT showName `DAppT` (DConT sty_tycon `DAppT` DSigT (DVarT z) ki)) - pure [show_inst] - -isException :: DExp -> Bool -isException (DVarE n) = nameBase n == "sUndefined" -isException (DConE {}) = False -isException (DLitE {}) = False -isException (DAppE (DVarE fun) _) | nameBase fun == "sError" = True -isException (DAppE fun _) = isException fun -isException (DAppTypeE e _) = isException e -isException (DLamE _ _) = False -isException (DCaseE e _) = isException e -isException (DLetE _ e) = isException e -isException (DSigE e _) = isException e -isException (DStaticE e) = isException e - -singMatch :: ADMatch -> SgM DMatch -singMatch (ADMatch var_proms pat exp) = do - (sPat, sigPaExpsSigs) <- evalForPair $ singPat (Map.fromList var_proms) pat - sExp <- singExp exp - return $ DMatch sPat $ mkSigPaCaseE sigPaExpsSigs sExp - -singLit :: Lit -> SgM DExp -singLit (IntegerL n) = do - opts <- getOptions - if n >= 0 - then return $ - DVarE (singledValueName opts fromIntegerName) `DAppE` - (DVarE singMethName `DSigE` - (singFamily `DAppT` DLitT (NumTyLit n))) - else do sLit <- singLit (IntegerL (-n)) - return $ DVarE (singledValueName opts negateName) `DAppE` sLit -singLit (StringL str) = do - opts <- getOptions - let sing_str_lit = DVarE singMethName `DSigE` - (singFamily `DAppT` DLitT (StrTyLit str)) - os_enabled <- qIsExtEnabled LangExt.OverloadedStrings - pure $ if os_enabled - then DVarE (singledValueName opts fromStringName) `DAppE` sing_str_lit - else sing_str_lit -singLit (CharL c) = - return $ DVarE singMethName `DSigE` (singFamily `DAppT` DLitT (CharTyLit c)) -singLit lit = - fail ("Only string, natural number, and character literals can be singled: " ++ show lit) - -{- -Note [The id hack; or, how singletons-th learned to stop worrying and avoid kind generalization] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC 8.8 was a time of great change. In particular, 8.8 debuted a fix for -Trac #15141 (decideKindGeneralisationPlan is too complicated). To fix this, a -wily GHC developer—who shall remain unnamed, but whose username rhymes with -schmoldfire—decided to make decideKindGeneralisationPlan less complicated by, -well, removing the whole thing. One consequence of this is that local -definitions are now kind-generalized (whereas they would not have been -previously). - -While schmoldfire had the noblest of intentions when authoring his fix, he -unintentionally made life much harder for singletons-th. Why? Consider the -following program: - - class Foo a where - bar :: a -> (a -> b) -> b - baz :: a - - quux :: Foo a => a -> a - quux x = x `bar` \_ -> baz - -When singled, this program will turn into something like this: - - type family Quux (x :: a) :: a where - Quux x = Bar x (LambdaSym1 x) - - sQuux :: forall a (x :: a). SFoo a => Sing x -> Sing (Quux x :: a) - sQuux (sX :: Sing x) - = sBar sX - ((singFun1 @(LambdaSym1 x)) - (\ sArg - -> case sArg of { - (_ :: Sing arg) - -> (case sArg of { _ -> sBaz }) :: - Sing (Case x arg arg) })) - - type family Case x arg t where - Case x arg _ = Baz - type family Lambda x t where - Lambda x arg = Case x arg arg - data LambdaSym1 x t - type instance Apply (LambdaSym1 x) t = Lambda x t - -The high-level bit is the explicit `Sing (Case x arg arg)` signature. Question: -what is the kind of `Case x arg arg`? The answer depends on whether local -definitions are kind-generalized or not! - -1. If local definitions are *not* kind-generalized (i.e., the status quo before - GHC 8.8), then `Case x arg arg :: a`. -2. If local definitions *are* kind-generalized (i.e., the status quo in GHC 8.8 - and later), then `Case x arg arg :: k` for some fresh kind variable `k`. - -Unfortunately, the kind of `Case x arg arg` *must* be `a` in order for `sQuux` -to type-check. This means that the code above suddenly stopped working in GHC -8.8. What's more, we can't just remove these explicit signatures, as there is -code elsewhere in `singletons-th` that crucially relies on them to guide type -inference along (e.g., `sShowParen` in `Text.Show.Singletons`). - -Luckily, there is an ingenious hack that lets us the benefits of explicit -signatures without the pain of kind generalization: our old friend, the `id` -function. The plan is as follows: instead of generating this code: - - (case sArg of ...) :: Sing (Case x arg arg) - -We instead generate this code: - - id @(Sing (Case x arg arg)) (case sArg of ...) - -That's it! This works because visible type arguments in terms do not get kind- -generalized, unlike top-level or local signatures. Now `Case x arg arg`'s kind -is not generalized, and all is well. We dub this: the `id` hack. - -One might wonder: will we need the `id` hack around forever? Perhaps not. While -GHC 8.8 removed the decideKindGeneralisationPlan function, there have been -rumblings that a future version of GHC may bring it back (in a limited form). -If this happens, it is possibly that GHC's attitude towards kind-generalizing -local definitions may change *again*, which could conceivably render the `id` -hack unnecessary. This is all speculation, of course, so all we can do now is -wait and revisit this design at a later date. --} +{-# LANGUAGE TemplateHaskellQuotes #-} + +{- Data/Singletons/TH/Single.hs + +(c) Richard Eisenberg 2013 +rae@cs.brynmawr.edu + +This file contains functions to refine constructs to work with singleton +types. It is an internal module to the singletons-th package. +-} + +module Data.Singletons.TH.Single where + +import Prelude hiding ( exp ) +import Language.Haskell.TH hiding ( cxt ) +import Language.Haskell.TH.Syntax (NameSpace(..), Quasi(..)) +import Data.Singletons.TH.Deriving.Bounded +import Data.Singletons.TH.Deriving.Enum +import Data.Singletons.TH.Deriving.Eq +import Data.Singletons.TH.Deriving.Infer +import Data.Singletons.TH.Deriving.Ord +import Data.Singletons.TH.Deriving.Show +import Data.Singletons.TH.Deriving.Util +import Data.Singletons.TH.Names +import Data.Singletons.TH.Options +import Data.Singletons.TH.Partition +import Data.Singletons.TH.Promote +import Data.Singletons.TH.Promote.Defun +import Data.Singletons.TH.Promote.Monad ( promoteM ) +import Data.Singletons.TH.Promote.Type +import Data.Singletons.TH.Single.Data +import Data.Singletons.TH.Single.Decide +import Data.Singletons.TH.Single.Defun +import Data.Singletons.TH.Single.Fixity +import Data.Singletons.TH.Single.Monad +import Data.Singletons.TH.Single.Ord +import Data.Singletons.TH.Single.Type +import Data.Singletons.TH.Syntax +import Data.Singletons.TH.Util +import Language.Haskell.TH.Desugar +import qualified Language.Haskell.TH.Desugar.OMap.Strict as OMap +import Language.Haskell.TH.Desugar.OMap.Strict (OMap) +import qualified Data.Map.Strict as Map +import Data.Map.Strict ( Map ) +import Data.Maybe +import qualified Data.Set as Set +import Control.Monad +import Control.Monad.Trans.Class +import Data.List (unzip6, zipWith4) +import qualified GHC.LanguageExtensions.Type as LangExt + +{- +How singletons-th works +~~~~~~~~~~~~~~~~~~~~~~~ + +Singling, on the surface, doesn't seem all that complicated. Promote the type, +and singletonize all the terms. That's essentially what was done singletons < 1.0. +But, now we want to deal with higher-order singletons. So, things are a little +more complicated. + +The way to understand all of this is that *every* variable maps to something +of type (Sing t), for an appropriately-kinded t. This includes functions, which +use the "SLambda" instance of Sing. To apply singleton functions, we use the +applySing function. + +That, in and of itself, wouldn't be too hard, but it's really annoying from +the user standpoint. After dutifully singling `map`, a user doesn't want to +have to use two `applySing`s to actually use it. So, any let-bound identifier +is eta-expanded so that the singled type has the same number of arrows as +the original type. (If there is no original type signature, then it has as +many arrows as the original had patterns.) Then, we store a use of one of the +singFunX functions in the SgM environment so that every use of a let-bound +identifier has a proper type (Sing t). + +It would be consistent to avoid this eta-expansion for local lets (as opposed +to top-level lets), but that seemed like more bother than it was worth. It +may also be possible to be cleverer about nested eta-expansions and contractions, +but that also seemed not to be worth it. Though I haven't tested it, my hope +is that the eta-expansions and contractions have no runtime effect, especially +because SLambda is a *newtype* instance, not a *data* instance. + +Note that to maintain the desired invariant, we must also be careful to eta- +contract constructors. This is the point of buildDataLets. +-} + +-- | Generate singled definitions for each of the provided type-level +-- declaration 'Name's. For example, the singletons-th package itself uses +-- +-- > $(genSingletons [''Bool, ''Maybe, ''Either, ''[]]) +-- +-- to generate singletons for Prelude types. +genSingletons :: OptionsMonad q => [Name] -> q [Dec] +genSingletons names = do + opts <- getOptions + -- See Note [Disable genQuotedDecs in genPromotions and genSingletons] + -- in D.S.TH.Promote + withOptions opts{genQuotedDecs = False} $ do + checkForRep names + ddecs <- concatMapM (singInfo <=< dsInfo <=< reifyWithLocals) names + return $ decsToTH ddecs + +-- | Make promoted and singled versions of all declarations given, retaining +-- the original declarations. See the +-- @@ +-- for further explanation. +singletons :: OptionsMonad q => q [Dec] -> q [Dec] +singletons qdecs = do + opts <- getOptions + withOptions opts{genQuotedDecs = True} $ singletons' $ lift qdecs + +-- | Make promoted and singled versions of all declarations given, discarding +-- the original declarations. Note that a singleton based on a datatype needs +-- the original datatype, so this will fail if it sees any datatype declarations. +-- Classes, instances, and functions are all fine. +singletonsOnly :: OptionsMonad q => q [Dec] -> q [Dec] +singletonsOnly qdecs = do + opts <- getOptions + withOptions opts{genQuotedDecs = False} $ singletons' $ lift qdecs + +-- The workhorse for 'singletons' and 'singletonsOnly'. The difference between +-- the two functions is whether 'genQuotedDecs' is set to 'True' or 'False'. +singletons' :: OptionsMonad q => q [Dec] -> q [Dec] +singletons' qdecs = do + opts <- getOptions + decs <- qdecs + ddecs <- withLocalDeclarations decs $ dsDecs decs + singDecs <- singTopLevelDecs decs ddecs + let origDecs | genQuotedDecs opts = decs + | otherwise = [] + return $ origDecs ++ decsToTH singDecs + +-- | Create instances of 'SEq' for the given types +singEqInstances :: OptionsMonad q => [Name] -> q [Dec] +singEqInstances = concatMapM singEqInstance + +-- | Create instance of 'SEq' for the given type +singEqInstance :: OptionsMonad q => Name -> q [Dec] +singEqInstance = singInstance mkEqInstance "Eq" + +-- | Create instances of 'SDecide', 'Eq', 'TestEquality', and 'TestCoercion' for +-- each type in the list. +singDecideInstances :: OptionsMonad q => [Name] -> q [Dec] +singDecideInstances = concatMapM singDecideInstance + +-- | Create instances of 'SDecide', 'Eq', 'TestEquality', and 'TestCoercion' for +-- the given type. +singDecideInstance :: OptionsMonad q => Name -> q [Dec] +singDecideInstance name = do + (_df, tvbs, cons) <- getDataD ("I cannot make an instance of SDecide for it.") name + dtvbs <- mapM dsTvbVis tvbs + let data_ty = foldTypeTvbs (DConT name) dtvbs + dcons <- concatMapM (dsCon dtvbs data_ty) cons + (scons, _) <- singM [] $ mapM (singCtor name) dcons + sDecideInstance <- mkDecideInstance Nothing data_ty dcons scons + eqInstance <- mkEqInstanceForSingleton data_ty name + testInstances <- traverse (mkTestInstance Nothing data_ty name dcons) + [TestEquality, TestCoercion] + return $ decsToTH (sDecideInstance:eqInstance:testInstances) + +-- | Create instances of 'SOrd' for the given types +singOrdInstances :: OptionsMonad q => [Name] -> q [Dec] +singOrdInstances = concatMapM singOrdInstance + +-- | Create instance of 'SOrd' for the given type +singOrdInstance :: OptionsMonad q => Name -> q [Dec] +singOrdInstance = singInstance mkOrdInstance "Ord" + +-- | Create instances of 'SBounded' for the given types +singBoundedInstances :: OptionsMonad q => [Name] -> q [Dec] +singBoundedInstances = concatMapM singBoundedInstance + +-- | Create instance of 'SBounded' for the given type +singBoundedInstance :: OptionsMonad q => Name -> q [Dec] +singBoundedInstance = singInstance mkBoundedInstance "Bounded" + +-- | Create instances of 'SEnum' for the given types +singEnumInstances :: OptionsMonad q => [Name] -> q [Dec] +singEnumInstances = concatMapM singEnumInstance + +-- | Create instance of 'SEnum' for the given type +singEnumInstance :: OptionsMonad q => Name -> q [Dec] +singEnumInstance = singInstance mkEnumInstance "Enum" + +-- | Create instance of 'SShow' for the given type +-- +-- (Not to be confused with 'showShowInstance'.) +singShowInstance :: OptionsMonad q => Name -> q [Dec] +singShowInstance = singInstance mkShowInstance "Show" + +-- | Create instances of 'SShow' for the given types +-- +-- (Not to be confused with 'showSingInstances'.) +singShowInstances :: OptionsMonad q => [Name] -> q [Dec] +singShowInstances = concatMapM singShowInstance + +-- | Create instance of 'Show' for the given singleton type +-- +-- (Not to be confused with 'singShowInstance'.) +showSingInstance :: OptionsMonad q => Name -> q [Dec] +showSingInstance name = do + (df, tvbs, cons) <- getDataD ("I cannot make an instance of Show for it.") name + dtvbs <- mapM dsTvbVis tvbs + let data_ty = foldTypeTvbs (DConT name) dtvbs + dcons <- concatMapM (dsCon dtvbs data_ty) cons + let tyvars = map (DVarT . extractTvbName) dtvbs + kind = foldType (DConT name) tyvars + data_decl = DataDecl df name dtvbs dcons + deriv_show_decl = DerivedDecl { ded_mb_cxt = Nothing + , ded_type = kind + , ded_type_tycon = name + , ded_decl = data_decl } + (show_insts, _) <- singM [] $ singDerivedShowDecs deriv_show_decl + pure $ decsToTH show_insts + +-- | Create instances of 'Show' for the given singleton types +-- +-- (Not to be confused with 'singShowInstances'.) +showSingInstances :: OptionsMonad q => [Name] -> q [Dec] +showSingInstances = concatMapM showSingInstance + +-- | Create an instance for @'SingI' TyCon{N}@, where @N@ is the positive +-- number provided as an argument. +-- +-- Note that the generated code requires the use of the @QuantifiedConstraints@ +-- language extension. +singITyConInstances :: DsMonad q => [Int] -> q [Dec] +singITyConInstances = mapM singITyConInstance + +-- | Create an instance for @'SingI' TyCon{N}@, where @N@ is the positive +-- number provided as an argument. +-- +-- Note that the generated code requires the use of the @QuantifiedConstraints@ +-- language extension. +singITyConInstance :: DsMonad q => Int -> q Dec +singITyConInstance n + | n <= 0 + = fail $ "Argument must be a positive number (given " ++ show n ++ ")" + | otherwise + = do as <- replicateM n (qNewName "a") + ks <- replicateM n (qNewName "k") + k_last <- qNewName "k_last" + f <- qNewName "f" + x <- qNewName "x" + let k_penult = last ks + k_fun = ravelVanillaDType [] [] (map DVarT ks) (DVarT k_last) + f_ty = DVarT f + a_tys = map DVarT as + mk_fun arrow t1 t2 = arrow `DAppT` t1 `DAppT` t2 + matchable_apply_fun = mk_fun DArrowT (DVarT k_penult) (DVarT k_last) + unmatchable_apply_fun = mk_fun (DConT tyFunArrowName) (DVarT k_penult) (DVarT k_last) + ctxt = [ DForallT (DForallInvis (map (`DPlainTV` SpecifiedSpec) as)) $ + DConstrainedT (map (DAppT (DConT singIName)) a_tys) + (DConT singIName `DAppT` foldType f_ty a_tys) + , DConT equalityName + `DAppT` (DConT applyTyConName `DSigT` + mk_fun DArrowT matchable_apply_fun unmatchable_apply_fun) + `DAppT` DConT applyTyConAux1Name + ] + pure $ decToTH + $ DInstanceD + Nothing Nothing ctxt + (DConT singIName `DAppT` (DConT (mkTyConName n) `DAppT` (f_ty `DSigT` k_fun))) + [DLetDec $ DFunD singMethName + [DClause [] $ + wrapSingFun 1 DWildCardT $ + DLamE [x] $ + DVarE withSingIName `DAppE` DVarE x + `DAppE` DVarE singMethName]] + +singInstance :: OptionsMonad q => DerivDesc q -> String -> Name -> q [Dec] +singInstance mk_inst inst_name name = do + (df, tvbs, cons) <- getDataD ("I cannot make an instance of " ++ inst_name + ++ " for it.") name + dtvbs <- mapM dsTvbVis tvbs + let data_ty = foldTypeTvbs (DConT name) dtvbs + dcons <- concatMapM (dsCon dtvbs data_ty) cons + let data_decl = DataDecl df name dtvbs dcons + raw_inst <- mk_inst Nothing data_ty data_decl + (a_inst, decs) <- promoteM [] $ + promoteInstanceDec OMap.empty Map.empty raw_inst + decs' <- singDecsM [] $ (:[]) <$> singInstD a_inst + return $ decsToTH (decs ++ decs') + +singInfo :: OptionsMonad q => DInfo -> q [DDec] +singInfo (DTyConI dec _) = + singTopLevelDecs [] [dec] +singInfo (DPrimTyConI _name _numArgs _unlifted) = + fail "Singling of primitive type constructors not supported" +singInfo (DVarI _name _ty _mdec) = + fail "Singling of value info not supported" +singInfo (DTyVarI _name _ty) = + fail "Singling of type variable info not supported" +singInfo (DPatSynI {}) = + fail "Singling of pattern synonym info not supported" + +singTopLevelDecs :: OptionsMonad q => [Dec] -> [DDec] -> q [DDec] +singTopLevelDecs locals raw_decls = withLocalDeclarations locals $ do + decls <- expand raw_decls -- expand type synonyms + PDecs { pd_let_decs = letDecls + , pd_class_decs = classes + , pd_instance_decs = insts + , pd_data_decs = datas + , pd_ty_syn_decs = ty_syns + , pd_open_type_family_decs = o_tyfams + , pd_closed_type_family_decs = c_tyfams + , pd_derived_eq_decs = derivedEqDecs + , pd_derived_ord_decs = derivedOrdDecs + , pd_derived_show_decs = derivedShowDecs } <- partitionDecs decls + + ((letDecEnv, classes', insts'), promDecls) <- promoteM locals $ do + defunTopLevelTypeDecls ty_syns c_tyfams o_tyfams + recSelLetDecls <- promoteDataDecs datas + (_, letDecEnv) <- promoteLetDecs Nothing $ recSelLetDecls ++ letDecls + classes' <- mapM promoteClassDec classes + let meth_sigs = foldMap (lde_types . cd_lde) classes + cls_tvbs_map = Map.fromList $ map (\cd -> (cd_name cd, cd_tvbs cd)) classes + insts' <- mapM (promoteInstanceDec meth_sigs cls_tvbs_map) insts + return (letDecEnv, classes', insts') + + singDecsM locals $ do + dataLetBinds <- concatMapM buildDataLets datas + methLetBinds <- concatMapM buildMethLets classes + let letBinds = dataLetBinds ++ methLetBinds + (newLetDecls, singIDefunDecls, newDecls) + <- bindLets letBinds $ + singLetDecEnv letDecEnv $ do + newDataDecls <- concatMapM singDataD datas + newClassDecls <- mapM singClassD classes' + newInstDecls <- mapM singInstD insts' + newDerivedEqDecs <- concatMapM singDerivedEqDecs derivedEqDecs + newDerivedOrdDecs <- concatMapM singDerivedOrdDecs derivedOrdDecs + newDerivedShowDecs <- concatMapM singDerivedShowDecs derivedShowDecs + return $ newDataDecls ++ newClassDecls + ++ newInstDecls + ++ newDerivedEqDecs + ++ newDerivedOrdDecs + ++ newDerivedShowDecs + return $ promDecls ++ (map DLetDec newLetDecls) ++ singIDefunDecls ++ newDecls + +-- see comment at top of file +buildDataLets :: OptionsMonad q => DataDecl -> q [(Name, DExp)] +buildDataLets (DataDecl _df _name _tvbs cons) = do + opts <- getOptions + fld_sels <- qIsExtEnabled LangExt.FieldSelectors + pure $ concatMap (con_num_args opts fld_sels) cons + where + con_num_args :: Options -> Bool -> DCon -> [(Name, DExp)] + con_num_args opts fld_sels (DCon _tvbs _cxt name fields _rty) = + (name, wrapSingFun (length (tysOfConFields fields)) + (DConT $ defunctionalizedName0 opts name) + (DConE $ singledDataConName opts name)) + : rec_selectors opts fld_sels fields + + rec_selectors :: Options -> Bool -> DConFields -> [(Name, DExp)] + rec_selectors opts fld_sels con + | fld_sels + = case con of + DNormalC {} -> [] + DRecC fields -> + let names = map fstOf3 fields in + [ (name, wrapSingFun 1 (DConT $ defunctionalizedName0 opts name) + (DVarE $ singledValueName opts name)) + | name <- names ] + + | otherwise + = [] + +-- see comment at top of file +buildMethLets :: OptionsMonad q => UClassDecl -> q [(Name, DExp)] +buildMethLets (ClassDecl { cd_lde = LetDecEnv { lde_types = meth_sigs } }) = do + opts <- getOptions + pure $ map (mk_bind opts) (OMap.assocs meth_sigs) + where + mk_bind opts (meth_name, meth_ty) = + ( meth_name + , wrapSingFun (countArgs meth_ty) (DConT $ defunctionalizedName0 opts meth_name) + (DVarE $ singledValueName opts meth_name) ) + +singClassD :: AClassDecl -> SgM DDec +singClassD (ClassDecl { cd_cxt = cls_cxt + , cd_name = cls_name + , cd_tvbs = cls_tvbs + , cd_fds = cls_fundeps + , cd_lde = LetDecEnv { lde_defns = default_defns + , lde_types = meth_sigs + , lde_infix = fixities + , lde_proms = promoted_defaults } }) = + bindContext [foldTypeTvbs (DConT cls_name) cls_tvbs] $ do + opts <- getOptions + mb_cls_sak <- dsReifyType cls_name + let sing_cls_name = singledClassName opts cls_name + mb_sing_cls_sak = fmap (DKiSigD sing_cls_name) mb_cls_sak + cls_infix_decls <- singReifiedInfixDecls $ cls_name:meth_names + (sing_sigs, _, tyvar_names, cxts, res_kis, singIDefunss) + <- unzip6 <$> zipWithM (singTySig no_meth_defns meth_sigs) + meth_names + (map (DConT . defunctionalizedName0 opts) meth_names) + emitDecs $ maybeToList mb_sing_cls_sak ++ cls_infix_decls ++ concat singIDefunss + let default_sigs = catMaybes $ + zipWith4 (mk_default_sig opts) meth_names sing_sigs + tyvar_names res_kis + sing_meths <- mapM (uncurry (singLetDecRHS (Map.fromList cxts))) + (OMap.assocs default_defns) + fixities' <- mapMaybeM (uncurry singInfixDecl) $ OMap.assocs fixities + cls_cxt' <- mapM singPred cls_cxt + return $ DClassD cls_cxt' + sing_cls_name + cls_tvbs + cls_fundeps -- they are fine without modification + (map DLetDec (sing_sigs ++ sing_meths ++ fixities') ++ default_sigs) + where + no_meth_defns = error "Internal error: can't find declared method type" + meth_names = map fst $ OMap.assocs meth_sigs + + mk_default_sig :: Options -> Name -> DLetDec -> [Name] -> Maybe DType -> Maybe DDec + mk_default_sig opts meth_name (DSigD s_name sty) bound_kvs (Just res_ki) = + DDefaultSigD s_name <$> add_constraints opts meth_name sty bound_kvs res_ki + mk_default_sig _ _ _ _ _ = error "Internal error: a singled signature isn't a signature." + + add_constraints :: Options -> Name -> DType -> [Name] -> DType -> Maybe DType + -- We must look through `... :: Type` kind annotations, which can be added + -- when singling type signatures lacking explicit `forall`s. + -- See Note [Preserve the order of type variables during singling] + -- (wrinkle 1) in D.S.TH.Single.Type. + add_constraints opts meth_name (DSigT sty ski) bound_kvs res_ki = do + sty' <- add_constraints opts meth_name sty bound_kvs res_ki + pure $ DSigT sty' ski + add_constraints opts meth_name sty bound_kvs res_ki = do + (tvbs, cxt, args, res) <- unravelVanillaDType sty + prom_dflt <- OMap.lookup meth_name promoted_defaults + + -- Filter out explicitly bound kind variables. Otherwise, if you had + -- the following class (#312): + -- + -- class Foo a where + -- bar :: a -> b -> b + -- bar _ x = x + -- + -- Then it would be singled to: + -- + -- class SFoo a where + -- sBar :: forall b (x :: a) (y :: b). Sing x -> Sing y -> Sing (sBar x y) + -- default :: forall b (x :: a) (y :: b). + -- (Bar b x y) ~ (BarDefault b x y) => ... + -- + -- Which applies Bar/BarDefault to b, which shouldn't happen. + let tvs = map tvbToType $ + filter (\tvb -> extractTvbName tvb `Set.member` bound_kv_set) tvbs + prom_meth = DConT $ defunctionalizedName0 opts meth_name + default_pred = foldType (DConT equalityName) + -- NB: Need the res_ki here to prevent ambiguous + -- kinds in result-inferred default methods. + -- See #175 + [ foldApply prom_meth tvs `DSigT` res_ki + , foldApply prom_dflt tvs ] + return $ ravelVanillaDType tvbs (default_pred : cxt) args res + where + bound_kv_set = Set.fromList bound_kvs + +singInstD :: AInstDecl -> SgM DDec +singInstD (InstDecl { id_cxt = cxt, id_name = inst_name, id_arg_tys = inst_tys + , id_sigs = inst_sigs, id_meths = ann_meths }) = do + opts <- getOptions + let s_inst_name = singledClassName opts inst_name + bindContext cxt $ do + cxt' <- mapM singPred cxt + inst_kis <- mapM promoteType inst_tys + meths <- concatMapM (uncurry sing_meth) ann_meths + return (DInstanceD Nothing + Nothing + cxt' + (foldl DAppT (DConT s_inst_name) inst_kis) + meths) + + where + sing_meth :: Name -> ALetDecRHS -> SgM [DDec] + sing_meth name rhs = do + opts <- getOptions + mb_s_info <- dsReify (singledValueName opts name) + inst_kis <- mapM promoteType inst_tys + let mk_subst cls_tvbs = Map.fromList $ zip (map extractTvbName vis_cls_tvbs) inst_kis + where + -- This is a half-hearted attempt to address the underlying problem + -- in #358, where we can sometimes have more class type variables + -- (due to implicit kind arguments) than class arguments. This just + -- ensures that the explicit type variables are properly mapped + -- to the class arguments, leaving the implicit kind variables + -- unmapped. That could potentially cause *other* problems, but + -- those are perhaps best avoided by using InstanceSigs. At the + -- very least, this workaround will make error messages slightly + -- less confusing. + vis_cls_tvbs = drop (length cls_tvbs - length inst_kis) cls_tvbs + + sing_meth_ty :: DType -> SgM DType + sing_meth_ty inner_ty = do + -- Make sure to expand through type synonyms here! Not doing so + -- resulted in #167. + raw_ty <- expand inner_ty + (s_ty, _num_args, _tyvar_names, _ctxt, _arg_kis, _res_ki) + <- singType (DConT $ defunctionalizedName0 opts name) raw_ty + pure s_ty + + s_ty <- case OMap.lookup name inst_sigs of + Just inst_sig -> + -- We have an InstanceSig, so just single that type. + sing_meth_ty inst_sig + Nothing -> case mb_s_info of + -- We don't have an InstanceSig, so we must compute the type to use + -- in the singled instance ourselves through reification. + Just (DVarI _ (DForallT (DForallInvis cls_tvbs) (DConstrainedT _cls_pred s_ty)) _) -> + pure $ substType (mk_subst cls_tvbs) s_ty + _ -> do + mb_info <- dsReify name + case mb_info of + Just (DVarI _ (DForallT (DForallInvis cls_tvbs) + (DConstrainedT _cls_pred inner_ty)) _) -> do + s_ty <- sing_meth_ty inner_ty + pure $ substType (mk_subst cls_tvbs) s_ty + _ -> fail $ "Cannot find type of method " ++ show name + + meth' <- singLetDecRHS + Map.empty -- Because we are singling an instance declaration, + -- we aren't generating defunctionalization symbols + -- for the class methods, and hence we aren't + -- generating any SingI instances. Therefore, we + -- don't need to include anything in this Map. + name rhs + return $ map DLetDec [DSigD (singledValueName opts name) s_ty, meth'] + +singLetDecEnv :: ALetDecEnv + -> SgM a + -> SgM ([DLetDec], [DDec], a) + -- Return: + -- + -- 1. The singled let-decs + -- 2. SingI instances for any defunctionalization symbols + -- (see Data.Singletons.TH.Single.Defun) + -- 3. The result of running the `SgM a` action +singLetDecEnv (LetDecEnv { lde_defns = defns + , lde_types = types + , lde_infix = infix_decls + , lde_proms = proms }) + thing_inside = do + let prom_list = OMap.assocs proms + (typeSigs, letBinds, _tyvarNames, cxts, _res_kis, singIDefunss) + <- unzip6 <$> mapM (uncurry (singTySig defns types)) prom_list + infix_decls' <- mapMaybeM (uncurry singInfixDecl) $ OMap.assocs infix_decls + bindLets letBinds $ do + let_decs <- mapM (uncurry (singLetDecRHS (Map.fromList cxts))) + (OMap.assocs defns) + thing <- thing_inside + return (infix_decls' ++ typeSigs ++ let_decs, concat singIDefunss, thing) + +singTySig :: OMap Name ALetDecRHS -- definitions + -> OMap Name DType -- type signatures + -> Name -> DType -- the type is the promoted type, not the type sig! + -> SgM ( DLetDec -- the new type signature + , (Name, DExp) -- the let-bind entry + , [Name] -- the scoped tyvar names in the tysig + , (Name, DCxt) -- the context of the type signature + , Maybe DKind -- the result kind in the tysig + , [DDec] -- SingI instances for defun symbols + ) +singTySig defns types name prom_ty = do + opts <- getOptions + let sName = singledValueName opts name + case OMap.lookup name types of + Nothing -> do + num_args <- guess_num_args + (sty, tyvar_names) <- mk_sing_ty num_args + singIDefuns <- singDefuns name VarName [] + (map (const Nothing) tyvar_names) Nothing + return ( DSigD sName sty + , (name, wrapSingFun num_args prom_ty (DVarE sName)) + , tyvar_names + , (name, []) + , Nothing + , singIDefuns ) + Just ty -> do + (sty, num_args, tyvar_names, ctxt, arg_kis, res_ki) + <- singType prom_ty ty + bound_cxt <- askContext + singIDefuns <- singDefuns name VarName (bound_cxt ++ ctxt) + (map Just arg_kis) (Just res_ki) + return ( DSigD sName sty + , (name, wrapSingFun num_args prom_ty (DVarE sName)) + , tyvar_names + , (name, ctxt) + , Just res_ki + , singIDefuns ) + where + guess_num_args :: SgM Int + guess_num_args = + case OMap.lookup name defns of + Nothing -> fail "Internal error: promotion known for something not let-bound." + Just (AValue _) -> return 0 + Just (AFunction n _) -> return n + + -- create a Sing t1 -> Sing t2 -> ... type of a given arity and result type + mk_sing_ty :: Int -> SgM (DType, [Name]) + mk_sing_ty n = do + arg_names <- replicateM n (qNewName "arg") + -- If there are no arguments, use `Sing @_` instead of `Sing`. + -- See Note [Disable kind generalization for local functions if possible] + let sing_w_wildcard | n == 0 = singFamily `DAppKindT` DWildCardT + | otherwise = singFamily + return ( ravelVanillaDType + (map (`DPlainTV` SpecifiedSpec) arg_names) + [] + (map (\nm -> singFamily `DAppT` DVarT nm) arg_names) + (sing_w_wildcard `DAppT` + (foldApply prom_ty (map DVarT arg_names))) + , arg_names ) + +{- +Note [Disable kind generalization for local functions if possible] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this example (from #296): + + f :: forall a. MyProxy a -> MyProxy a + f MyProxy = + let x = let z :: MyProxy a + z = MyProxy in z + in x + +A naïve attempt at singling `f` is as follows: + + type LetZ :: MyProxy a + type family LetZ where + LetZ = 'MyProxy + + type family LetX where + LetX = LetZ + + type F :: forall a. MyProxy a -> MyProxy a + type family F x where + F 'MyProxy = LetX + + sF :: forall a (t :: MyProxy a). Sing t -> Sing (F t :: MyProxy a) + sF SMyProxy = + let sX :: Sing LetX + sX = let sZ :: Sing (LetZ :: MyProxy a) + sZ = SMyProxy in sZ + in sX + +This will not typecheck, however. The is because the return kind of +`LetX` (in `let sX :: Sing LetX`) will get generalized by virtue of `sX` +having a type signature. It's as if one had written this: + + sF :: forall a (t :: MyProxy a). Sing t -> Sing (F t :: MyProxy a) + sF SMyProxy = + let sX :: forall a1. Sing (LetX :: MyProxy a1) + sX = ... + +This is too general, since `sX` will only typecheck if the return kind of +`LetX` is `MyProxy a`, not `MyProxy a1`. In order to avoid this problem, +we need to avoid kind generalization when kind-checking the type of `sX`. +To accomplish this, we borrow a trick from +Note [The id hack; or, how singletons-th learned to stop worrying and avoid kind generalization] +and use TypeApplications plus a wildcard type. That is, we generate this code +for `sF`: + + sF :: forall a (t :: MyProxy a). Sing t -> Sing (F t :: MyProxy a) + sF SMyProxy = + let sX :: Sing @_ LetX + sX = ... + +The presence of the wildcard type disables kind generalization, which allows +GHC's kind inference to deduce that the return kind of `LetX` should be `a`. +Now `sF` typechecks, and since we only use wildcards within visible kind +applications, we don't even have to force users to enable +PartialTypeSignatures. Hooray! + +Question: where should we put wildcard types when singling? One possible answer +is: put a wildcard in any type signature that gets generated when singling a +function that lacks a type signature. Unfortunately, this is a step too far. +This will break singling the `foldr` function: + + foldr :: (a -> b -> b) -> b -> [a] -> b + foldr k z = go + where + go [] = z + go (y:ys) = y `k` go ys + +If the type of `sGo` is given a wildcard, then it will fail to typecheck. This +is because `sGo` is polymorphically recursive, so disabling kind generalization +forces GHC to infer `sGo`'s type. Attempting to infer a polymorphically +recursive type, unsurprisingly, leads to failure. + +To avoid this sort of situation, where adopt a simple metric: if a function +lacks a type signature, only put @_ in its singled type signature if it has +zero arguments. This allows `sX` to typecheck without breaking things like +`sGo`. This metric is a bit conservative, however, since it means that this +small tweak to `x` still would not typecheck: + + f :: forall a. MyProxy a -> MyProxy a + f MyProxy = + let x () = let z :: MyProxy a + z = MyProxy in z + in x () + +We need not let perfect be the enemy of good, however. It is extremely +common for local definitions to have zero arguments, so it makes good sense +to optimize for that special case. In fact, this special treatment is the only +reason that `foo8` from the `T183` test case singles successfully, since +the as-patterns in `foo8` desugar to code very similar to the `f` example +above. +-} + +singLetDecRHS :: Map Name DCxt -- the context of the type signature + -- (might not be known) + -> Name -> ALetDecRHS -> SgM DLetDec +singLetDecRHS cxts name ld_rhs = do + opts <- getOptions + bindContext (Map.findWithDefault [] name cxts) $ + case ld_rhs of + AValue exp -> + DValD (DVarP (singledValueName opts name)) <$> + singExp exp + AFunction _num_arrows clauses -> + DFunD (singledValueName opts name) <$> + mapM singClause clauses + +singClause :: ADClause -> SgM DClause +singClause (ADClause var_proms pats exp) = do + opts <- getOptions + (sPats, sigPaExpsSigs) <- evalForPair $ mapM (singPat (Map.fromList var_proms)) pats + let lambda_binds = map (\(n,_) -> (n, singledValueName opts n)) var_proms + sBody <- bindLambdas lambda_binds $ singExp exp + return $ DClause sPats $ mkSigPaCaseE sigPaExpsSigs sBody + +singPat :: Map Name Name -- from term-level names to type-level names + -> ADPat + -> QWithAux SingDSigPaInfos SgM DPat +singPat var_proms = go + where + go :: ADPat -> QWithAux SingDSigPaInfos SgM DPat + go (ADLitP _lit) = + fail "Singling of literal patterns not yet supported" + go (ADVarP name) = do + opts <- getOptions + tyname <- case Map.lookup name var_proms of + Nothing -> + fail "Internal error: unknown variable when singling pattern" + Just tyname -> return tyname + pure $ DVarP (singledValueName opts name) + `DSigP` (singFamily `DAppT` DVarT tyname) + go (ADConP name tys pats) = do + opts <- getOptions + DConP (singledDataConName opts name) tys <$> mapM go pats + go (ADTildeP pat) = do + qReportWarning + "Lazy pattern converted into regular pattern during singleton generation." + go pat + go (ADBangP pat) = DBangP <$> go pat + go (ADSigP prom_pat pat ty) = do + pat' <- go pat + -- Normally, calling dPatToDExp would be dangerous, since it fails if the + -- supplied pattern contains any wildcard patterns. However, promotePat + -- (which produced the pattern we're passing into dPatToDExp) maintains + -- an invariant that any promoted pattern signatures will be free of + -- wildcard patterns in the underlying pattern. + -- See Note [Singling pattern signatures]. + addElement (dPatToDExp pat', DSigT prom_pat ty) + pure pat' + go ADWildP = pure DWildP + +-- | If given a non-empty list of 'SingDSigPaInfos', construct a case expression +-- that brings singleton equality constraints into scope via pattern-matching. +-- See @Note [Singling pattern signatures]@. +mkSigPaCaseE :: SingDSigPaInfos -> DExp -> DExp +mkSigPaCaseE exps_with_sigs exp + | null exps_with_sigs = exp + | otherwise = + let (exps, sigs) = unzip exps_with_sigs + scrutinee = mkTupleDExp exps + pats = map (DSigP DWildP . DAppT (DConT singFamilyName)) sigs + in DCaseE scrutinee [DMatch (mkTupleDPat pats) exp] + +-- Note [Annotate case return type] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- We're straining GHC's type inference here. One particular trouble area +-- is determining the return type of a GADT pattern match. In general, GHC +-- cannot infer return types of GADT pattern matches because the return type +-- becomes "untouchable" in the case matches. See the OutsideIn paper. But, +-- during singletonization, we *know* the return type. So, just add a type +-- annotation. See #54. +-- +-- In particular, we add a type annotation in a somewhat unorthodox fashion. +-- Instead of the usual `(x :: t)`, we use `id @t x`. See +-- Note [The id hack; or, how singletons-th learned to stop worrying and avoid +-- kind generalization] for an explanation of why we do this. + +-- Note [Why error is so special] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Some of the transformations that happen before this point produce impossible +-- case matches. We must be careful when processing these so as not to make +-- an error GHC will complain about. When binding the case-match variables, we +-- normally include an equality constraint saying that the scrutinee is equal +-- to the matched pattern. But, we can't do this in inaccessible matches, because +-- equality is bogus, and GHC (rightly) complains. However, we then have another +-- problem, because GHC doesn't have enough information when type-checking the +-- RHS of the inaccessible match to deem it type-safe. The solution: treat error +-- as super-special, so that GHC doesn't look too hard at singletonized error +-- calls. Specifically, DON'T do the applySing stuff. Just use sError, which +-- has a custom type (Sing x -> a) anyway. + +-- Note [Singling pattern signatures] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- We want to single a pattern signature, like so: +-- +-- f :: Maybe a -> a +-- f (Just x :: Maybe a) = x +-- +-- Naïvely, one might expect this to single straightfowardly as: +-- +-- sF :: forall (z :: Maybe a). Sing z -> Sing (F z) +-- sF (SJust sX :: Sing (Just x :: Maybe a)) = sX +-- +-- But the way GHC typechecks patterns prevents this from working, as GHC won't +-- know that the type `z` is actually `Just x` until /after/ the entirety of +-- the `SJust sX` pattern has been typechecked. (See Trac #12018 for an +-- extended discussion on this topic.) +-- +-- To work around this design, we resort to a somewhat unsightly trick: +-- immediately after matching on all the patterns, we perform a case on every +-- pattern with a pattern signature, like so: +-- +-- sF :: forall (z :: Maybe a). Sing z -> Sing (F z) +-- sF (SJust sX :: Sing z) +-- = case (SJust sX :: Sing z) of +-- (_ :: Sing (Just x :: Maybe a)) -> sX +-- +-- Now GHC accepts the fact that `z` is `Just x`, and all is well. In order +-- to support this construction, the type of singPat is augmented with some +-- extra information in the form of SingDSigPaInfos: +-- +-- type SingDSigPaInfos = [(DExp, DType)] +-- +-- Where the DExps corresponds to the expressions we case on just after the +-- patterns (`SJust sX :: Sing x`, in the example above), and the DTypes +-- correspond to the singled pattern signatures to use in the case alternative +-- (`Sing (Just x :: Maybe a)` in the example above). singPat appends to the +-- list of SingDSigPaInfos whenever it processes a DSigPa (pattern signature), +-- and call sites can pass these SingDSigPaInfos to mkSigPaCaseE to construct a +-- case expression like the one featured above. +-- +-- Some interesting consequences of this design: +-- +-- 1. We must promote DPats to ADPats, a variation of DPat where the annotated +-- DSigPa counterpart, ADSigPa, stores the type that the original DPat was +-- promoted to. This is necessary since promoting the type might have +-- generated fresh variable names, so we need to be able to use the same +-- names when singling. +-- +-- 2. Also when promoting a DSigPa to an ADSigPa, we remove any wildcards from +-- the underlying pattern. To see why this is necessary, consider singling +-- this example: +-- +-- g (Just _ :: Maybe a) = "hi" +-- +-- This must single to something like this: +-- +-- sG (SJust _ :: Sing z) +-- = case (SJust _ :: Sing z) of +-- (_ :: Sing (Just _ :: Maybe a)) -> "hi" +-- +-- But `SJust _` is not a valid expression, and since the minimal th-desugar +-- AST lacks as-patterns, we can't replace it with something like +-- `sG x@(SJust _ :: Sing z) = case x of ...`. But even if the th-desugar +-- AST /did/ have as-patterns, we'd still be in trouble, as `Just _` isn't +-- a valid type without the use of -XPartialTypeSignatures, which isn't a +-- design we want to force upon others. +-- +-- We work around both issues by simply converting all wildcard patterns +-- from the pattern that has a signature. That means our example becomes: +-- +-- sG (SJust sWild :: Sing z) +-- = case (SJust sWild :: Sing z) of +-- (_ :: Sing (Just wild :: Maybe a)) -> "hi" +-- +-- And now everything is hunky-dory. + +singExp :: ADExp -> SgM DExp + -- See Note [Why error is so special] +singExp (ADVarE err `ADAppE` arg) + | err == errorName = do opts <- getOptions + DAppE (DVarE (singledValueName opts err)) <$> + singExp arg +singExp (ADVarE name) = lookupVarE name +singExp (ADConE name) = lookupConE name +singExp (ADLitE lit) = singLit lit +singExp (ADAppE e1 e2) = do + e1' <- singExp e1 + e2' <- singExp e2 + -- `applySing undefined x` kills type inference, because GHC can't figure + -- out the type of `undefined`. So we don't emit `applySing` there. + if isException e1' + then return $ e1' `DAppE` e2' + else return $ (DVarE applySingName) `DAppE` e1' `DAppE` e2' +singExp (ADLamE ty_names prom_lam names exp) = do + opts <- getOptions + let sNames = map (singledValueName opts) names + exp' <- bindLambdas (zip names sNames) $ singExp exp + -- we need to bind the type variables... but DLamE doesn't allow SigT patterns. + -- So: build a case + let caseExp = DCaseE (mkTupleDExp (map DVarE sNames)) + [DMatch (mkTupleDPat + (map ((DWildP `DSigP`) . + (singFamily `DAppT`) . + DVarT) ty_names)) exp'] + return $ wrapSingFun (length names) prom_lam $ DLamE sNames caseExp +singExp (ADCaseE exp matches ret_ty) = + -- See Note [Annotate case return type] and + -- Note [The id hack; or, how singletons-th learned to stop worrying and + -- avoid kind generalization] + DAppE (DAppTypeE (DVarE 'id) + (singFamily `DAppT` ret_ty)) + <$> (DCaseE <$> singExp exp <*> mapM singMatch matches) +singExp (ADLetE env exp) = do + -- We intentionally discard the SingI instances for exp's defunctionalization + -- symbols, as we also do not generate the declarations for the + -- defunctionalization symbols in the first place during promotion. + (let_decs, _, exp') <- singLetDecEnv env $ singExp exp + pure $ DLetE let_decs exp' +singExp (ADSigE prom_exp exp ty) = do + exp' <- singExp exp + pure $ DSigE exp' $ DConT singFamilyName `DAppT` DSigT prom_exp ty + +-- See Note [DerivedDecl] in Data.Singletons.TH.Syntax +singDerivedEqDecs :: DerivedEqDecl -> SgM [DDec] +singDerivedEqDecs (DerivedDecl { ded_mb_cxt = mb_ctxt + , ded_type = ty + , ded_type_tycon = ty_tycon + , ded_decl = DataDecl _ _ _ cons }) = do + (scons, _) <- singM [] $ mapM (singCtor ty_tycon) cons + mb_sctxt <- mapM (mapM singPred) mb_ctxt + -- Beware! The user might have specified an instance context like this: + -- + -- deriving instance Eq a => Eq (T a Int) + -- + -- When we single the context, it will become (SEq a). But we do *not* want + -- this for the SDecide instance! The simplest solution is to simply replace + -- all occurrences of SEq with SDecide in the context. + mb_sctxtDecide <- traverse (traverse sEqToSDecide) mb_sctxt + sDecideInst <- mkDecideInstance mb_sctxtDecide ty cons scons + eqInst <- mkEqInstanceForSingleton ty ty_tycon + testInsts <- traverse (mkTestInstance mb_sctxtDecide ty ty_tycon cons) + [TestEquality, TestCoercion] + return (sDecideInst:eqInst:testInsts) + +-- Walk a DPred, replacing all occurrences of SEq with SDecide. +sEqToSDecide :: OptionsMonad q => DPred -> q DPred +sEqToSDecide p = do + opts <- getOptions + pure $ modifyConNameDType (\n -> + if n == singledClassName opts eqName + then sDecideClassName + else n) p + +-- See Note [DerivedDecl] in Data.Singletons.TH.Syntax +singDerivedOrdDecs :: DerivedOrdDecl -> SgM [DDec] +singDerivedOrdDecs (DerivedDecl { ded_type = ty + , ded_type_tycon = ty_tycon }) = do + ord_inst <- mkOrdInstanceForSingleton ty ty_tycon + pure [ord_inst] + +-- See Note [DerivedDecl] in Data.Singletons.TH.Syntax +singDerivedShowDecs :: DerivedShowDecl -> SgM [DDec] +singDerivedShowDecs (DerivedDecl { ded_mb_cxt = mb_cxt + , ded_type = ty + , ded_type_tycon = ty_tycon + , ded_decl = DataDecl _ _ _ cons }) = do + opts <- getOptions + z <- qNewName "z" + -- Generate a Show instance for a singleton type, like this: + -- + -- deriving instance (ShowSing a, ShowSing b) => Sing (SEither (z :: Either a b)) + -- + -- Be careful: we want to generate an instance context that uses ShowSing, + -- not SShow. + show_cxt <- inferConstraintsDef (fmap mkShowSingContext mb_cxt) + (DConT showSingName) + ty cons + ki <- promoteType ty + let sty_tycon = singledDataTypeName opts ty_tycon + show_inst = DStandaloneDerivD Nothing Nothing show_cxt + (DConT showName `DAppT` (DConT sty_tycon `DAppT` DSigT (DVarT z) ki)) + pure [show_inst] + +isException :: DExp -> Bool +isException (DVarE n) = nameBase n == "sUndefined" +isException (DConE {}) = False +isException (DLitE {}) = False +isException (DAppE (DVarE fun) _) | nameBase fun == "sError" = True +isException (DAppE fun _) = isException fun +isException (DAppTypeE e _) = isException e +isException (DLamE _ _) = False +isException (DCaseE e _) = isException e +isException (DLetE _ e) = isException e +isException (DSigE e _) = isException e +isException (DStaticE e) = isException e +isException (DTypedBracketE e) = isException e +isException (DTypedSpliceE e) = isException e + +singMatch :: ADMatch -> SgM DMatch +singMatch (ADMatch var_proms pat exp) = do + opts <- getOptions + (sPat, sigPaExpsSigs) <- evalForPair $ singPat (Map.fromList var_proms) pat + let lambda_binds = map (\(n,_) -> (n, singledValueName opts n)) var_proms + sExp <- bindLambdas lambda_binds $ singExp exp + return $ DMatch sPat $ mkSigPaCaseE sigPaExpsSigs sExp + +singLit :: Lit -> SgM DExp +singLit (IntegerL n) = do + opts <- getOptions + if n >= 0 + then return $ + DVarE (singledValueName opts fromIntegerName) `DAppE` + (DVarE singMethName `DSigE` + (singFamily `DAppT` DLitT (NumTyLit n))) + else do sLit <- singLit (IntegerL (-n)) + return $ DVarE (singledValueName opts negateName) `DAppE` sLit +singLit (StringL str) = do + opts <- getOptions + let sing_str_lit = DVarE singMethName `DSigE` + (singFamily `DAppT` DLitT (StrTyLit str)) + os_enabled <- qIsExtEnabled LangExt.OverloadedStrings + pure $ if os_enabled + then DVarE (singledValueName opts fromStringName) `DAppE` sing_str_lit + else sing_str_lit +singLit (CharL c) = + return $ DVarE singMethName `DSigE` (singFamily `DAppT` DLitT (CharTyLit c)) +singLit lit = + fail ("Only string, natural number, and character literals can be singled: " ++ show lit) + +{- +Note [The id hack; or, how singletons-th learned to stop worrying and avoid kind generalization] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC 8.8 was a time of great change. In particular, 8.8 debuted a fix for +Trac #15141 (decideKindGeneralisationPlan is too complicated). To fix this, a +wily GHC developer—who shall remain unnamed, but whose username rhymes with +schmoldfire—decided to make decideKindGeneralisationPlan less complicated by, +well, removing the whole thing. One consequence of this is that local +definitions are now kind-generalized (whereas they would not have been +previously). + +While schmoldfire had the noblest of intentions when authoring his fix, he +unintentionally made life much harder for singletons-th. Why? Consider the +following program: + + class Foo a where + bar :: a -> (a -> b) -> b + baz :: a + + quux :: Foo a => a -> a + quux x = x `bar` \_ -> baz + +When singled, this program will turn into something like this: + + type family Quux (x :: a) :: a where + Quux x = Bar x (LambdaSym1 x) + + sQuux :: forall a (x :: a). SFoo a => Sing x -> Sing (Quux x :: a) + sQuux (sX :: Sing x) + = sBar sX + ((singFun1 @(LambdaSym1 x)) + (\ sArg + -> case sArg of { + (_ :: Sing arg) + -> (case sArg of { _ -> sBaz }) :: + Sing (Case x arg arg) })) + + type family Case x arg t where + Case x arg _ = Baz + type family Lambda x t where + Lambda x arg = Case x arg arg + data LambdaSym1 x t + type instance Apply (LambdaSym1 x) t = Lambda x t + +The high-level bit is the explicit `Sing (Case x arg arg)` signature. Question: +what is the kind of `Case x arg arg`? The answer depends on whether local +definitions are kind-generalized or not! + +1. If local definitions are *not* kind-generalized (i.e., the status quo before + GHC 8.8), then `Case x arg arg :: a`. +2. If local definitions *are* kind-generalized (i.e., the status quo in GHC 8.8 + and later), then `Case x arg arg :: k` for some fresh kind variable `k`. + +Unfortunately, the kind of `Case x arg arg` *must* be `a` in order for `sQuux` +to type-check. This means that the code above suddenly stopped working in GHC +8.8. What's more, we can't just remove these explicit signatures, as there is +code elsewhere in `singletons-th` that crucially relies on them to guide type +inference along (e.g., `sShowParen` in `Text.Show.Singletons`). + +Luckily, there is an ingenious hack that lets us the benefits of explicit +signatures without the pain of kind generalization: our old friend, the `id` +function. The plan is as follows: instead of generating this code: + + (case sArg of ...) :: Sing (Case x arg arg) + +We instead generate this code: + + id @(Sing (Case x arg arg)) (case sArg of ...) + +That's it! This works because visible type arguments in terms do not get kind- +generalized, unlike top-level or local signatures. Now `Case x arg arg`'s kind +is not generalized, and all is well. We dub this: the `id` hack. + +One might wonder: will we need the `id` hack around forever? Perhaps not. While +GHC 8.8 removed the decideKindGeneralisationPlan function, there have been +rumblings that a future version of GHC may bring it back (in a limited form). +If this happens, it is possibly that GHC's attitude towards kind-generalizing +local definitions may change *again*, which could conceivably render the `id` +hack unnecessary. This is all speculation, of course, so all we can do now is +wait and revisit this design at a later date. +-} diff --git a/src/Data/Singletons/TH/Single/Data.hs b/src/Data/Singletons/TH/Single/Data.hs --- a/src/Data/Singletons/TH/Single/Data.hs +++ b/src/Data/Singletons/TH/Single/Data.hs @@ -1,405 +1,644 @@ -{- Data/Singletons/TH/Single/Data.hs - -(c) Richard Eisenberg 2013 -rae@cs.brynmawr.edu - -Singletonizes constructors. --} - -module Data.Singletons.TH.Single.Data where - -import Language.Haskell.TH.Desugar as Desugar -import Language.Haskell.TH.Syntax -import Data.Maybe -import Data.Singletons.TH.Names -import Data.Singletons.TH.Options -import Data.Singletons.TH.Promote.Type -import Data.Singletons.TH.Single.Defun -import Data.Singletons.TH.Single.Fixity -import Data.Singletons.TH.Single.Monad -import Data.Singletons.TH.Syntax -import Data.Singletons.TH.Util -import Control.Monad - --- We wish to consider the promotion of "Rep" to be * --- not a promoted data constructor. -singDataD :: DataDecl -> SgM [DDec] -singDataD (DataDecl df name tvbs ctors) = do - opts <- getOptions - let tvbNames = map extractTvbName tvbs - ctor_names = map extractName ctors - rec_sel_names = concatMap extractRecSelNames ctors - k <- promoteType (foldType (DConT name) (map DVarT tvbNames)) - mb_data_sak <- dsReifyType name - ctors' <- mapM (singCtor name) ctors - fixityDecs <- singReifiedInfixDecls $ ctor_names ++ rec_sel_names - -- instance for SingKind - fromSingClauses <- mapM mkFromSingClause ctors - emptyFromSingClause <- mkEmptyFromSingClause - toSingClauses <- mapM mkToSingClause ctors - emptyToSingClause <- mkEmptyToSingClause - let singKindInst = - DInstanceD Nothing Nothing - (map (singKindConstraint . DVarT) tvbNames) - (DAppT (DConT singKindClassName) k) - [ DTySynInstD $ DTySynEqn Nothing - (DConT demoteName `DAppT` k) - (foldType (DConT name) - (map (DAppT demote . DVarT) tvbNames)) - , DLetDec $ DFunD fromSingName - (fromSingClauses `orIfEmpty` [emptyFromSingClause]) - , DLetDec $ DFunD toSingName - (toSingClauses `orIfEmpty` [emptyToSingClause]) ] - - let singDataName = singledDataTypeName opts name - -- e.g. type instance Sing @Nat = SNat - singSynInst = - DTySynInstD $ DTySynEqn Nothing - (DConT singFamilyName `DAppKindT` k) - (DConT singDataName) - - -- Note that we always include an explicit result kind in the body of the - -- singleton data type declaration, even if it has a standalone kind - -- signature that would make this explicit result kind redudant. - -- See Note [Keep redundant kind information for Haddocks] - -- in D.S.TH.Promote. - mk_data_dec kind = - DDataD Data [] singDataName [] (Just kind) ctors' [] - - data_decs = case mb_data_sak of - -- No standalone kind signature. Try to figure out the order of kind - -- variables on a best-effort basis. - Nothing -> - let sing_tvbs = changeDTVFlags SpecifiedSpec $ - toposortTyVarsOf $ map dTyVarBndrToDType tvbs - kinded_sing_ty = DForallT (DForallInvis sing_tvbs) $ - DArrowT `DAppT` k `DAppT` DConT typeKindName in - [mk_data_dec kinded_sing_ty] - - -- A standalone kind signature is provided, so use that to determine the - -- order of kind variables. - Just data_sak -> - let (args, _) = unravelDType data_sak - vis_args = filterDVisFunArgs args - vis_tvbs = changeDTVFlags SpecifiedSpec $ - zipWith replaceTvbKind vis_args tvbs - invis_args = filterInvisTvbArgs args - -- If the standalone kind signature did not explicitly quantify its - -- kind variables, do so ourselves. This is very similar to what - -- D.S.TH.Single.Type.singTypeKVBs does. - invis_tvbs | null invis_args - = changeDTVFlags SpecifiedSpec $ - toposortTyVarsOf [data_sak] - | otherwise - = invis_args - sing_data_sak = DForallT (DForallInvis (invis_tvbs ++ vis_tvbs)) $ - DArrowT `DAppT` k `DAppT` DConT typeKindName in - [ DKiSigD singDataName sing_data_sak - , mk_data_dec sing_data_sak - ] - - return $ data_decs ++ - singSynInst : - [ singKindInst | genSingKindInsts opts - , -- `type data` data constructors only exist at the - -- type level. As such, we cannot define SingKind - -- instances for them, as they require term-level - -- data constructors to implement. - df /= Desugar.TypeData - ] ++ - fixityDecs - where -- in the Rep case, the names of the constructors are in the wrong scope - -- (they're types, not datacons), so we have to reinterpret them. - mkConName :: Name -> SgM Name - mkConName - | nameBase name == nameBase repName = mkDataName . nameBase - | otherwise = return - - mkFromSingClause :: DCon -> SgM DClause - mkFromSingClause c = do - opts <- getOptions - let (cname, numArgs) = extractNameArgs c - cname' <- mkConName cname - varNames <- replicateM numArgs (qNewName "b") - return $ DClause [DConP (singledDataConName opts cname) [] (map DVarP varNames)] - (foldExp - (DConE cname') - (map (DAppE (DVarE fromSingName) . DVarE) varNames)) - - mkToSingClause :: DCon -> SgM DClause - mkToSingClause (DCon _tvbs _cxt cname fields _rty) = do - opts <- getOptions - let types = tysOfConFields fields - varNames <- mapM (const $ qNewName "b") types - svarNames <- mapM (const $ qNewName "c") types - promoted <- mapM promoteType types - cname' <- mkConName cname - let varPats = zipWith mkToSingVarPat varNames promoted - recursiveCalls = zipWith mkRecursiveCall varNames promoted - return $ - DClause [DConP cname' [] varPats] - (multiCase recursiveCalls - (map (DConP someSingDataName [] . listify . DVarP) - svarNames) - (DAppE (DConE someSingDataName) - (foldExp (DConE (singledDataConName opts cname)) - (map DVarE svarNames)))) - - mkToSingVarPat :: Name -> DKind -> DPat - mkToSingVarPat varName ki = - DSigP (DVarP varName) (DAppT (DConT demoteName) ki) - - mkRecursiveCall :: Name -> DKind -> DExp - mkRecursiveCall var_name ki = - DSigE (DAppE (DVarE toSingName) (DVarE var_name)) - (DAppT (DConT someSingTypeName) ki) - - mkEmptyFromSingClause :: SgM DClause - mkEmptyFromSingClause = do - x <- qNewName "x" - pure $ DClause [DVarP x] - $ DCaseE (DVarE x) [] - - mkEmptyToSingClause :: SgM DClause - mkEmptyToSingClause = do - x <- qNewName "x" - pure $ DClause [DVarP x] - $ DConE someSingDataName `DAppE` DCaseE (DVarE x) [] - --- Single a constructor. -singCtor :: Name -> DCon -> SgM DCon - -- polymorphic constructors are handled just - -- like monomorphic ones -- the polymorphism in - -- the kind is automatic -singCtor dataName (DCon con_tvbs cxt name fields rty) - | not (null cxt) - = fail "Singling of constrained constructors not yet supported" - | otherwise - = do - opts <- getOptions - let types = tysOfConFields fields - numTypes = length types - sName = singledDataConName opts name - sCon = DConE sName - pCon = DConT $ promotedDataTypeOrConName opts name - checkVanillaDType $ ravelVanillaDType con_tvbs [] types rty - indexNames <- mapM (const $ qNewName "n") types - kinds <- mapM promoteType_NC types - rty' <- promoteType_NC rty - let indices = map DVarT indexNames - kindedIndices = zipWith DSigT indices kinds - -- The approach we use for singling data constructor types differs - -- slightly from the approach taken in D.S.TH.Single.Type.singType in that - -- we always explicitly quantify all type variables in a singled data - -- constructor, regardless of whether the original data constructor - -- explicitly quantified them or not. This explains the use of - -- toposortTyVarsOf below. - -- See Note [Preserve the order of type variables during singling] - -- (wrinkle 1) in D.S.TH.Single.Type. - kvbs | null con_tvbs - = changeDTVFlags SpecifiedSpec (toposortTyVarsOf (kinds ++ [rty'])) ++ - con_tvbs - | otherwise - = con_tvbs - all_tvbs = kvbs ++ zipWith (`DKindedTV` SpecifiedSpec) indexNames kinds - - -- @mb_SingI_dec k@ returns 'Just' an instance of @SingI@ if @k@ is - -- less than or equal to the number of fields in the data constructor. - -- Otherwise, it returns 'Nothing'. - let mb_SingI_dec :: Int -> Maybe DDec - mb_SingI_dec k - | k <= numTypes - = let take_until_k = take (numTypes - k) in - Just $ DInstanceD Nothing Nothing - (map (DAppT (DConT singIName)) (take_until_k indices)) - (DAppT (DConT (mkSingIName k)) - (foldType pCon (take_until_k kindedIndices))) - [DLetDec $ DValD (DVarP (mkSingMethName k)) - (foldExp sCon (replicate (numTypes - k) (DVarE singMethName)))] - | otherwise - = Nothing - - -- SingI instance for data constructor - emitDecs $ mapMaybe mb_SingI_dec [0, 1, 2] - -- SingI instances for defunctionalization symbols. Note that we don't - -- support contexts in constructors at the moment, so it's fine for now to - -- just assume that the context is always (). - emitDecs =<< singDefuns name DataName [] (map Just kinds) (Just rty') - - conFields <- case fields of - DNormalC dInfix bts -> DNormalC dInfix <$> - zipWithM (\(b, _) index -> mk_bang_type b index) - bts indices - DRecC vbts -> DNormalC False <$> - zipWithM (\(_, b, _) index -> mk_bang_type b index) - vbts indices - -- Don't bother looking at record selectors, as they are - -- handled separately in singTopLevelDecs. - -- See Note [singletons-th and record selectors] - return $ DCon all_tvbs [] sName conFields - (DConT (singledDataTypeName opts dataName) `DAppT` - (foldType pCon indices `DSigT` rty')) - -- Make sure to include an explicit `rty'` kind annotation. - -- See Note [Preserve the order of type variables during singling], - -- wrinkle 3, in D.S.TH.Single.Type. - where - mk_source_unpackedness :: SourceUnpackedness -> SgM SourceUnpackedness - mk_source_unpackedness su = case su of - NoSourceUnpackedness -> pure su - SourceNoUnpack -> pure su - SourceUnpack -> do - -- {-# UNPACK #-} is essentially useless in a singletons setting, since - -- all singled data types are GADTs. See GHC#10016. - qReportWarning "{-# UNPACK #-} pragmas are ignored by `singletons-th`." - pure NoSourceUnpackedness - - mk_bang :: Bang -> SgM Bang - mk_bang (Bang su ss) = do su' <- mk_source_unpackedness su - pure $ Bang su' ss - - mk_bang_type :: Bang -> DType -> SgM DBangType - mk_bang_type b index = do b' <- mk_bang b - pure (b', DAppT singFamily index) - -{- -Note [singletons-th and record selectors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Record selectors are annoying to deal with in singletons-th for various reasons: - -1. There is no record syntax at the type level, so promoting code that involves - records in some way is not straightforward. -2. One can define record selectors for singled data types, but they're rife - with peril. Some pitfalls include: - - * Singling record updates often produces code that does not typecheck. For - example, this works: - - let i = Identity True in i { runIdentity = False } - - But this does /not/ work: - - let si = SIdentity STrue in si { sRunIdentity = SFalse } - - error: - • Record update for insufficiently polymorphic field: - sRunIdentity :: Sing n - • In the expression: si {sRunIdentity = SFalse} - In the expression: - let si = SIdentity STrue in si {sRunIdentity = SFalse} - - Ugh. See GHC#16501. - - * Singling a data type with multiple constructors that share a record - selector name will /also/ not typecheck. While this works: - - data X = X1 {y :: Bool} | X2 {y :: Bool} - - This does not: - - data SX :: X -> Type where - SX1 :: { sY :: Sing n } -> SX ('X1 n) - SY1 :: { sY :: Sing n } -> SX ('X2 n) - - error: - • Constructors SX1 and SX2 have a common field ‘sY’, - but have different result types - • In the data type declaration for ‘SX’ - - Double ugh. See GHC#8673/GHC#12159. - - * Even if a data type only has a single constructor with record selectors, - singling it can induce headaches. One might be tempted to single this type: - - newtype Unit = MkUnit { runUnit :: () } - - With this code: - - data SUnit :: Unit -> Type where - SMkUnit :: { sRunUnit :: Sing u } -> SUnit (MkUnit u) - - Somewhat surprisingly, the type of sRunUnit: - - sRunUnit :: Sing (MkUnit u) -> Sing u - - Is not general enough to handle common uses of record selectors. For - example, if you try to single this function: - - f :: Unit -> () - f = runUnit - - Then the resulting code: - - sF :: Sing (x :: Unit) -> Sing (F x :: ()) - sF = sRunUnit - - Will not typecheck. Note that sRunUnit expects an argument of type - `Sing (MkUnit u)`, but there is no way to know a priori that the `x` in - `Sing (x :: Unit)` is `MkUnit u` without pattern-matching on SMkUnit. - -Hopefully I have convinced you that handling records in singletons-th is a bit of -a nightmare. Thankfully, there is a simple trick to avoid most of the pitfalls -above: just desugar code (using th-desugar) to avoid records! -In more concrete terms, we do the following: - -* A record constructions desugars to a normal constructor application. For example: - - MkT{a = x, b = y} - - ==> - - MkT x y - - Something similar occurs for record syntax in patterns. - -* A record update desugars to a case expression. For example: - - t{a = x} - - ==> - - case t of MkT _ y => MkT x y - -We can't easily desugar away all uses of records, however. After all, records -can be used as ordinary functions as well. We leave such uses of records alone -when desugaring and accommodate them during promotion and singling by generating -"manual" record selectors. As a running example, consider the earlier Unit example: - - newtype Unit = MkUnit { runUnit :: () } - -When singling Unit, we do not give SMkUnit a record selector: - - data SUnit :: Unit -> Type where - SMkUnit :: Sing u -> SUnit (MkUnit u) - -Instead, we generate a top-level function that behaves equivalently to runUnit. -This function then gets promoted and singled (in D.S.TH.Promote.promoteDecs and -D.S.TH.Single.singTopLevelDecs): - - type family RunUnit (x :: Unit) :: () where - RunUnit (MkUnit x) = x - - sRunUnit :: Sing (x :: Unit) -> Sing (RunUnit x :: ()) - sRunUnit (SMkUnit sx) = sx - -Now promoting/singling uses of runUnit as an ordinary function work as expected -since the types of RunUnit/sRunUnit are sufficiently general. This technique also -scales up to data types with multiple constructors sharing a record selector name. -For instance, in the earlier X example: - - data X = X1 {y :: Bool} | X2 {y :: Bool} - -We would promote/single `y` like so: - - type family Y (x :: X) :: Bool where - Y (X1 y) = y - Y (X2 y) = y - - sY :: Sing (x :: X) -> Sing (Y x :: Bool) - sY (SX1 sy) = sy - sY (SX2 sy) = sy - -Manual record selectors cannot be used in record constructions or updates, but -for most use cases this won't be an issue, since singletons-th makes an effort to -desugar away fancy uses of records anyway. The only time this would bite is if -you wanted to use record syntax in hand-written singletons code. --} +{- Data/Singletons/TH/Single/Data.hs + +(c) Richard Eisenberg 2013 +rae@cs.brynmawr.edu + +Singletonizes constructors. +-} + +module Data.Singletons.TH.Single.Data + ( singDataD + , singCtor + ) where + +import Language.Haskell.TH.Desugar as Desugar +import Language.Haskell.TH.Syntax +import qualified Data.Map.Strict as Map +import Data.Map.Strict (Map) +import Data.Maybe +import Data.Traversable (mapAccumL) +import Data.Singletons.TH.Names +import Data.Singletons.TH.Options +import Data.Singletons.TH.Promote.Type +import Data.Singletons.TH.Single.Defun +import Data.Singletons.TH.Single.Fixity +import Data.Singletons.TH.Single.Monad +import Data.Singletons.TH.Syntax +import Data.Singletons.TH.Util +import Control.Monad + +-- We wish to consider the promotion of "Rep" to be * +-- not a promoted data constructor. +singDataD :: DataDecl -> SgM [DDec] +singDataD (DataDecl df name tvbs ctors) = do + opts <- getOptions + let reqTvbNames = map extractTvbName $ + filter (\tvb -> extractTvbFlag tvb == BndrReq) tvbs + ctor_names = map extractName ctors + rec_sel_names = concatMap extractRecSelNames ctors + k <- promoteType (foldTypeTvbs (DConT name) tvbs) + mb_data_sak <- dsReifyType name + ctors' <- mapM (singCtor name) ctors + fixityDecs <- singReifiedInfixDecls $ ctor_names ++ rec_sel_names + -- instance for SingKind + fromSingClauses <- mapM mkFromSingClause ctors + emptyFromSingClause <- mkEmptyFromSingClause + toSingClauses <- mapM mkToSingClause ctors + emptyToSingClause <- mkEmptyToSingClause + let singKindInst = + DInstanceD Nothing Nothing + (map (singKindConstraint . DVarT) reqTvbNames) + (DAppT (DConT singKindClassName) k) + [ DTySynInstD $ DTySynEqn Nothing + (DConT demoteName `DAppT` k) + (foldType (DConT name) + (map (DAppT demote . DVarT) reqTvbNames)) + , DLetDec $ DFunD fromSingName + (fromSingClauses `orIfEmpty` [emptyFromSingClause]) + , DLetDec $ DFunD toSingName + (toSingClauses `orIfEmpty` [emptyToSingClause]) ] + + let singDataName = singledDataTypeName opts name + -- e.g. type instance Sing @Nat = SNat + singSynInst = + DTySynInstD $ DTySynEqn Nothing + (DConT singFamilyName `DAppKindT` k) + (DConT singDataName) + + -- Note that we always include an explicit result kind in the body of the + -- singleton data type declaration, even if it has a standalone kind + -- signature that would make this explicit result kind redudant. + -- See Note [Keep redundant kind information for Haddocks] + -- in D.S.TH.Promote. + mk_data_dec kind = + DDataD Data [] singDataName [] (Just kind) ctors' [] + + data_decs <- case mb_data_sak of + -- No standalone kind signature. Try to figure out the order of kind + -- variables on a best-effort basis. + Nothing -> do + let sing_tvbs = changeDTVFlags SpecifiedSpec $ + toposortTyVarsOf $ map dTyVarBndrToDType tvbs + kinded_sing_ty = DForallT (DForallInvis sing_tvbs) $ + DArrowT `DAppT` k `DAppT` DConT typeKindName + pure [mk_data_dec kinded_sing_ty] + + -- A standalone kind signature is provided, so use that to determine the + -- order of kind variables. + Just data_sak -> do + sing_data_sak <- singDataSAK data_sak tvbs k + pure [ DKiSigD singDataName sing_data_sak + , mk_data_dec sing_data_sak + ] + + return $ data_decs ++ + singSynInst : + [ singKindInst | genSingKindInsts opts + , -- `type data` data constructors only exist at the + -- type level. As such, we cannot define SingKind + -- instances for them, as they require term-level + -- data constructors to implement. + df /= Desugar.TypeData + ] ++ + fixityDecs + where -- in the Rep case, the names of the constructors are in the wrong scope + -- (they're types, not datacons), so we have to reinterpret them. + mkConName :: Name -> SgM Name + mkConName + | nameBase name == nameBase repName = mkDataName . nameBase + | otherwise = return + + mkFromSingClause :: DCon -> SgM DClause + mkFromSingClause c = do + opts <- getOptions + let (cname, numArgs) = extractNameArgs c + cname' <- mkConName cname + varNames <- replicateM numArgs (qNewName "b") + return $ DClause [DConP (singledDataConName opts cname) [] (map DVarP varNames)] + (foldExp + (DConE cname') + (map (DAppE (DVarE fromSingName) . DVarE) varNames)) + + mkToSingClause :: DCon -> SgM DClause + mkToSingClause (DCon _tvbs _cxt cname fields _rty) = do + opts <- getOptions + let types = tysOfConFields fields + varNames <- mapM (const $ qNewName "b") types + svarNames <- mapM (const $ qNewName "c") types + promoted <- mapM promoteType types + cname' <- mkConName cname + let varPats = zipWith mkToSingVarPat varNames promoted + recursiveCalls = zipWith mkRecursiveCall varNames promoted + return $ + DClause [DConP cname' [] varPats] + (multiCase recursiveCalls + (map (DConP someSingDataName [] . listify . DVarP) + svarNames) + (DAppE (DConE someSingDataName) + (foldExp (DConE (singledDataConName opts cname)) + (map DVarE svarNames)))) + + mkToSingVarPat :: Name -> DKind -> DPat + mkToSingVarPat varName ki = + DSigP (DVarP varName) (DAppT (DConT demoteName) ki) + + mkRecursiveCall :: Name -> DKind -> DExp + mkRecursiveCall var_name ki = + DSigE (DAppE (DVarE toSingName) (DVarE var_name)) + (DAppT (DConT someSingTypeName) ki) + + mkEmptyFromSingClause :: SgM DClause + mkEmptyFromSingClause = do + x <- qNewName "x" + pure $ DClause [DVarP x] + $ DCaseE (DVarE x) [] + + mkEmptyToSingClause :: SgM DClause + mkEmptyToSingClause = do + x <- qNewName "x" + pure $ DClause [DVarP x] + $ DConE someSingDataName `DAppE` DCaseE (DVarE x) [] + +-- Single a constructor. +singCtor :: Name -> DCon -> SgM DCon + -- polymorphic constructors are handled just + -- like monomorphic ones -- the polymorphism in + -- the kind is automatic +singCtor dataName (DCon con_tvbs cxt name fields rty) + | not (null cxt) + = fail "Singling of constrained constructors not yet supported" + | otherwise + = do + opts <- getOptions + let types = tysOfConFields fields + numTypes = length types + sName = singledDataConName opts name + sCon = DConE sName + pCon = DConT $ promotedDataTypeOrConName opts name + checkVanillaDType $ ravelVanillaDType con_tvbs [] types rty + indexNames <- mapM (const $ qNewName "n") types + kinds <- mapM promoteType_NC types + rty' <- promoteType_NC rty + let indices = map DVarT indexNames + kindedIndices = zipWith DSigT indices kinds + -- The approach we use for singling data constructor types differs + -- slightly from the approach taken in D.S.TH.Single.Type.singType in that + -- we always explicitly quantify all type variables in a singled data + -- constructor, regardless of whether the original data constructor + -- explicitly quantified them or not. This explains the use of + -- toposortTyVarsOf below. + -- See Note [Preserve the order of type variables during singling] + -- (wrinkle 1) in D.S.TH.Single.Type. + kvbs | null con_tvbs + = changeDTVFlags SpecifiedSpec (toposortTyVarsOf (kinds ++ [rty'])) ++ + con_tvbs + | otherwise + = con_tvbs + all_tvbs = kvbs ++ zipWith (`DKindedTV` SpecifiedSpec) indexNames kinds + + -- @mb_SingI_dec k@ returns 'Just' an instance of @SingI@ if @k@ is + -- less than or equal to the number of fields in the data constructor. + -- Otherwise, it returns 'Nothing'. + let mb_SingI_dec :: Int -> Maybe DDec + mb_SingI_dec k + | k <= numTypes + = let take_until_k = take (numTypes - k) in + Just $ DInstanceD Nothing Nothing + (map (DAppT (DConT singIName)) (take_until_k indices)) + (DAppT (DConT (mkSingIName k)) + (foldType pCon (take_until_k kindedIndices))) + [DLetDec $ DValD (DVarP (mkSingMethName k)) + (foldExp sCon (replicate (numTypes - k) (DVarE singMethName)))] + | otherwise + = Nothing + + -- SingI instance for data constructor + emitDecs $ mapMaybe mb_SingI_dec [0, 1, 2] + -- SingI instances for defunctionalization symbols. Note that we don't + -- support contexts in constructors at the moment, so it's fine for now to + -- just assume that the context is always (). + emitDecs =<< singDefuns name DataName [] (map Just kinds) (Just rty') + + conFields <- case fields of + DNormalC dInfix bts -> DNormalC dInfix <$> + zipWithM (\(b, _) index -> mk_bang_type b index) + bts indices + DRecC vbts -> DNormalC False <$> + zipWithM (\(_, b, _) index -> mk_bang_type b index) + vbts indices + -- Don't bother looking at record selectors, as they are + -- handled separately in singTopLevelDecs. + -- See Note [singletons-th and record selectors] + return $ DCon all_tvbs [] sName conFields + (DConT (singledDataTypeName opts dataName) `DAppT` + (foldType pCon indices `DSigT` rty')) + -- Make sure to include an explicit `rty'` kind annotation. + -- See Note [Preserve the order of type variables during singling], + -- wrinkle 3, in D.S.TH.Single.Type. + where + mk_source_unpackedness :: SourceUnpackedness -> SgM SourceUnpackedness + mk_source_unpackedness su = case su of + NoSourceUnpackedness -> pure su + SourceNoUnpack -> pure su + SourceUnpack -> do + -- {-# UNPACK #-} is essentially useless in a singletons setting, since + -- all singled data types are GADTs. See GHC#10016. + qReportWarning "{-# UNPACK #-} pragmas are ignored by `singletons-th`." + pure NoSourceUnpackedness + + mk_bang :: Bang -> SgM Bang + mk_bang (Bang su ss) = do su' <- mk_source_unpackedness su + pure $ Bang su' ss + + mk_bang_type :: Bang -> DType -> SgM DBangType + mk_bang_type b index = do b' <- mk_bang b + pure (b', DAppT singFamily index) + +-- @'singDataSAK' sak data_bndrs@ produces a standalone kind signature for a +-- singled data declaration, using the original data type's standalone kind +-- signature (@sak@) and its user-written binders (@data_bndrs@) as a template. +-- For this example: +-- +-- @ +-- type D :: forall j k. k -> j -> Type +-- data D @j @l (a :: l) b = ... +-- @ +-- +-- We would produce the following standalone kind signature: +-- +-- @ +-- type SD :: forall j l (a :: l) (b :: j). D @j @l (a :: l) b -> Type +-- @ +-- +-- Note that: +-- +-- * This function has a precondition that the length of @data_bndrs@ must +-- always be equal to the number of visible quantifiers (i.e., the number of +-- function arrows plus the number of visible @forall@–bound variables) in +-- @sak@. @singletons-th@ maintains this invariant when constructing a +-- 'DataDecl' (see the 'buildDataDTvbs' function). +-- +-- * The order of the invisible quantifiers is preserved, so both +-- @D \@Bool \@Ordering@ and @SD \@Bool \@Ordering@ will work the way you would +-- expect it to. +-- +-- * Whenever possible, this function reuses type variable names from the data +-- type's user-written binders. This is why the standalone kind signature uses +-- @forall j l@ instead of @forall j k@, since the @(a :: l)@ binder uses @l@ +-- instead of @k@. We could have just as well chose the other way around, but +-- we chose to pick variable names from the data type binders since they scope +-- over other parts of the data type declaration (e.g., in @deriving@ +-- clauses), so keeping these names avoids having to perform some +-- alpha-renaming. +singDataSAK :: + MonadFail q + => DKind + -- ^ The standalone kind signature for the original data type + -> [DTyVarBndrVis] + -- ^ The user-written binders for the original data type + -> DKind + -- ^ The original data type, promoted to a kind + -> q DKind + -- ^ The standalone kind signature for the singled data type +singDataSAK data_sak data_bndrs data_k = do + -- (1) First, explicitly quantify any free kind variables in `data_sak` using + -- an invisible @forall@. This is done to ensure that precondition (2) in + -- `matchUpSigWithDecl` is upheld. (See the Haddocks for that function). + let data_sak_free_tvbs = + changeDTVFlags SpecifiedSpec $ toposortTyVarsOf [data_sak] + data_sak' = DForallT (DForallInvis data_sak_free_tvbs) data_sak + + -- (2) Next, compute type variable binders for the singled data type's + -- standalone kind signature using `matchUpSigWithDecl`. Note that these can + -- be biased towards type variable names mention in `data_sak` over names + -- mentioned in `data_bndrs`, but we will fix that up in the next step. + let (data_sak_args, _) = unravelDType data_sak' + sing_sak_tvbs <- matchUpSigWithDecl data_sak_args data_bndrs + + -- (3) Swizzle the type variable names so that names in `data_bndrs` are + -- preferred over names in `data_sak`. + -- + -- This is heavily inspired by similar code in GHC: + -- https://gitlab.haskell.org/ghc/ghc/-/blob/cec903899234bf9e25ea404477ba846ac1e963bb/compiler/GHC/Tc/Gen/HsType.hs#L2607-2616 + let invis_data_sak_args = filterInvisTvbArgs data_sak_args + invis_data_sak_arg_nms = map extractTvbName invis_data_sak_args + + invis_data_bndrs = toposortKindVarsOfTvbs data_bndrs + invis_data_bndr_nms = map extractTvbName invis_data_bndrs + + swizzle_env = + Map.fromList $ zip invis_data_sak_arg_nms invis_data_bndr_nms + (_, swizzled_sing_sak_tvbs) = + mapAccumL (swizzleTvb swizzle_env) Map.empty sing_sak_tvbs + + -- (4) Finally, construct the kind of the singled data type. + pure $ DForallT (DForallInvis swizzled_sing_sak_tvbs) + $ DArrowT `DAppT` data_k `DAppT` DConT typeKindName + +-- Match the quantifiers in a data type's standalone kind signature with the +-- binders in the data type declaration. This function assumes the following +-- preconditions: +-- +-- 1. The number of required binders in the data type declaration is equal to +-- the number of visible quantifiers (i.e., the number of function arrows +-- plus the number of visible @forall@–bound variables) in the standalone +-- kind signature. +-- +-- 2. The number of invisible \@-binders in the data type declaration is less +-- than or equal to the number of invisible quantifiers (i.e., the number of +-- invisible @forall@–bound variables) in the standalone kind signature. +-- +-- The implementation of this function is heavily based on a GHC function of +-- the same name: +-- https://gitlab.haskell.org/ghc/ghc/-/blob/1464a2a8de082f66ae250d63ab9d94dbe2ef8620/compiler/GHC/Tc/Gen/HsType.hs#L2645-2715 +matchUpSigWithDecl :: + forall q. + MonadFail q + => DFunArgs + -- ^ The quantifiers in the data type's standalone kind signature + -> [DTyVarBndrVis] + -- ^ The user-written binders in the data type declaration + -> q [DTyVarBndrSpec] +matchUpSigWithDecl = go_fun_args Map.empty + where + go_fun_args :: + DSubst + -- ^ A substitution from the names of @forall@-bound variables in the + -- standalone kind signature to corresponding binder names in the + -- user-written binders. (See the Haddocks for `singDataSAK` for an + -- explanation of why we perform this substitution.) For example: + -- + -- @ + -- type T :: forall a. forall b -> Maybe (a, b) -> Type + -- data T @x y z + -- @ + -- + -- After matching up the @a@ in @forall a.@ with @x@ and + -- the @b@ in @forall b ->@ with @y@, this substitution will be + -- extended with @[a :-> x, b :-> y]@. This ensures that we will + -- produce @Maybe (x, y)@ instead of @Maybe (a, b)@ in + -- the kind for @z@. + -> DFunArgs -> [DTyVarBndrVis] -> q [DTyVarBndrSpec] + go_fun_args _ DFANil [] = + pure [] + -- This should not happen, per the function's precondition + go_fun_args _ DFANil data_bndrs = + fail $ "matchUpSigWithDecl.go_fun_args: Too many binders: " ++ show data_bndrs + -- GHC now disallows kind-level constraints, per this GHC proposal: + -- https://github.com/ghc-proposals/ghc-proposals/blob/b0687d96ce8007294173b7f628042ac4260cc738/proposals/0547-no-kind-equalities.rst + go_fun_args _ (DFACxt{}) _ = + fail "matchUpSigWithDecl.go_fun_args: Unexpected kind-level constraint" + go_fun_args subst (DFAForalls (DForallInvis tvbs) sig_args) data_bndrs = + go_invis_tvbs subst tvbs sig_args data_bndrs + go_fun_args subst (DFAForalls (DForallVis tvbs) sig_args) data_bndrs = + go_vis_tvbs subst tvbs sig_args data_bndrs + go_fun_args subst (DFAAnon anon sig_args) (data_bndr:data_bndrs) = do + let data_bndr_name = extractTvbName data_bndr + mb_data_bndr_kind = extractTvbKind data_bndr + anon' = substType subst anon + + anon'' = + case mb_data_bndr_kind of + Nothing -> anon' + Just data_bndr_kind -> + let mb_match_subst = matchTy NoIgnore data_bndr_kind anon' in + maybe data_bndr_kind (`substType` data_bndr_kind) mb_match_subst + sig_args' <- go_fun_args subst sig_args data_bndrs + pure $ DKindedTV data_bndr_name SpecifiedSpec anon'' : sig_args' + -- This should not happen, per precondition (1). + go_fun_args _ _ [] = + fail "matchUpSigWithDecl.go_fun_args: Too few binders" + + go_invis_tvbs :: DSubst -> [DTyVarBndrSpec] -> DFunArgs -> [DTyVarBndrVis] -> q [DTyVarBndrSpec] + go_invis_tvbs subst [] sig_args data_bndrs = + go_fun_args subst sig_args data_bndrs + -- This should not happen, per precondition (2). + go_invis_tvbs _ (_:_) _ [] = + fail $ "matchUpSigWithDecl.go_invis_tvbs: Too few binders" + go_invis_tvbs subst (invis_tvb:invis_tvbs) sig_args data_bndrss@(data_bndr:data_bndrs) = + case extractTvbFlag data_bndr of + -- If the next data_bndr is required, then we have a invisible forall in + -- the kind without a corresponding invisible @-binder, which is + -- allowed. In this case, we simply apply the substitution and recurse. + BndrReq -> do + let (subst', invis_tvb') = substTvb subst invis_tvb + sig_args' <- go_invis_tvbs subst' invis_tvbs sig_args data_bndrss + pure $ invis_tvb' : sig_args' + -- If the next data_bndr is an invisible @-binder, then we must match it + -- against the invisible forall–bound variable in the kind. + BndrInvis -> do + let (subst', sig_tvb) = match_tvbs subst invis_tvb data_bndr + sig_args' <- go_invis_tvbs subst' invis_tvbs sig_args data_bndrs + pure (sig_tvb : sig_args') + + go_vis_tvbs :: DSubst -> [DTyVarBndrUnit] -> DFunArgs -> [DTyVarBndrVis] -> q [DTyVarBndrSpec] + go_vis_tvbs subst [] sig_args data_bndrs = + go_fun_args subst sig_args data_bndrs + -- This should not happen, per precondition (1). + go_vis_tvbs _ (_:_) _ [] = + fail $ "matchUpSigWithDecl.go_vis_tvbs: Too few binders" + go_vis_tvbs subst (vis_tvb:vis_tvbs) sig_args (data_bndr:data_bndrs) = do + case extractTvbFlag data_bndr of + -- If the next data_bndr is required, then we must match it against the + -- visible forall–bound variable in the kind. + BndrReq -> do + let (subst', sig_tvb) = match_tvbs subst vis_tvb data_bndr + sig_args' <- go_vis_tvbs subst' vis_tvbs sig_args data_bndrs + pure (sig_tvb : sig_args') + -- We have a visible forall in the kind, but an invisible @-binder as + -- the next data_bndr. This is ill kinded, so throw an error. + BndrInvis -> + fail $ "matchUpSigWithDecl.go_vis_tvbs: Expected visible binder, encountered invisible binder: " + ++ show data_bndr + + -- @match_tvbs subst sig_tvb data_bndr@ will match the kind of @data_bndr@ + -- against the kind of @sig_tvb@ to produce a new kind. This function + -- produces two values as output: + -- + -- 1. A new @subst@ that has been extended such that the name of @sig_tvb@ + -- maps to the name of @data_bndr@. (See the Haddocks for the 'DSubst' + -- argument to @go_fun_args@ for an explanation of why we do this.) + -- + -- 2. A 'DTyVarBndrSpec' that has the name of @data_bndr@, but with the new + -- kind resulting from matching. + match_tvbs :: DSubst -> DTyVarBndr flag -> DTyVarBndrVis -> (DSubst, DTyVarBndrSpec) + match_tvbs subst sig_tvb data_bndr = + let data_bndr_name = extractTvbName data_bndr + mb_data_bndr_kind = extractTvbKind data_bndr + + sig_tvb_name = extractTvbName sig_tvb + mb_sig_tvb_kind = substType subst <$> extractTvbKind sig_tvb + + mb_kind :: Maybe DKind + mb_kind = + case (mb_data_bndr_kind, mb_sig_tvb_kind) of + (Nothing, Nothing) -> Nothing + (Just data_bndr_kind, Nothing) -> Just data_bndr_kind + (Nothing, Just sig_tvb_kind) -> Just sig_tvb_kind + (Just data_bndr_kind, Just sig_tvb_kind) -> do + match_subst <- matchTy NoIgnore data_bndr_kind sig_tvb_kind + Just $ substType match_subst data_bndr_kind + + subst' = Map.insert sig_tvb_name (DVarT data_bndr_name) subst + sig_tvb' = case mb_kind of + Nothing -> DPlainTV data_bndr_name SpecifiedSpec + Just kind -> DKindedTV data_bndr_name SpecifiedSpec kind in + + (subst', sig_tvb') + +-- This is heavily inspired by the `swizzleTcb` function in GHC: +-- https://gitlab.haskell.org/ghc/ghc/-/blob/cec903899234bf9e25ea404477ba846ac1e963bb/compiler/GHC/Tc/Gen/HsType.hs#L2741-2755 +swizzleTvb :: Map Name Name -> DSubst -> DTyVarBndrSpec -> (DSubst, DTyVarBndrSpec) +swizzleTvb swizzle_env subst tvb = + (subst', tvb2) + where + subst' = Map.insert tvb_name (DVarT (extractTvbName tvb2)) subst + tvb_name = extractTvbName tvb + tvb1 = mapDTVKind (substType subst) tvb + tvb2 = + case Map.lookup tvb_name swizzle_env of + Just user_name -> mapDTVName (const user_name) tvb1 + Nothing -> tvb1 + +{- +Note [singletons-th and record selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Record selectors are annoying to deal with in singletons-th for various reasons: + +1. There is no record syntax at the type level, so promoting code that involves + records in some way is not straightforward. +2. One can define record selectors for singled data types, but they're rife + with peril. Some pitfalls include: + + * Singling record updates often produces code that does not typecheck. For + example, this works: + + let i = Identity True in i { runIdentity = False } + + But this does /not/ work: + + let si = SIdentity STrue in si { sRunIdentity = SFalse } + + error: + • Record update for insufficiently polymorphic field: + sRunIdentity :: Sing n + • In the expression: si {sRunIdentity = SFalse} + In the expression: + let si = SIdentity STrue in si {sRunIdentity = SFalse} + + Ugh. See GHC#16501. + + * Singling a data type with multiple constructors that share a record + selector name will /also/ not typecheck. While this works: + + data X = X1 {y :: Bool} | X2 {y :: Bool} + + This does not: + + data SX :: X -> Type where + SX1 :: { sY :: Sing n } -> SX ('X1 n) + SY1 :: { sY :: Sing n } -> SX ('X2 n) + + error: + • Constructors SX1 and SX2 have a common field ‘sY’, + but have different result types + • In the data type declaration for ‘SX’ + + Double ugh. See GHC#8673/GHC#12159. + + * Even if a data type only has a single constructor with record selectors, + singling it can induce headaches. One might be tempted to single this type: + + newtype Unit = MkUnit { runUnit :: () } + + With this code: + + data SUnit :: Unit -> Type where + SMkUnit :: { sRunUnit :: Sing u } -> SUnit (MkUnit u) + + Somewhat surprisingly, the type of sRunUnit: + + sRunUnit :: Sing (MkUnit u) -> Sing u + + Is not general enough to handle common uses of record selectors. For + example, if you try to single this function: + + f :: Unit -> () + f = runUnit + + Then the resulting code: + + sF :: Sing (x :: Unit) -> Sing (F x :: ()) + sF = sRunUnit + + Will not typecheck. Note that sRunUnit expects an argument of type + `Sing (MkUnit u)`, but there is no way to know a priori that the `x` in + `Sing (x :: Unit)` is `MkUnit u` without pattern-matching on SMkUnit. + +Hopefully I have convinced you that handling records in singletons-th is a bit of +a nightmare. Thankfully, there is a simple trick to avoid most of the pitfalls +above: just desugar code (using th-desugar) to avoid records! +In more concrete terms, we do the following: + +* A record constructions desugars to a normal constructor application. For example: + + MkT{a = x, b = y} + + ==> + + MkT x y + + Something similar occurs for record syntax in patterns. + +* A record update desugars to a case expression. For example: + + t{a = x} + + ==> + + case t of MkT _ y => MkT x y + +We can't easily desugar away all uses of records, however. After all, records +can be used as ordinary functions as well. We leave such uses of records alone +when desugaring and accommodate them during promotion and singling by generating +"manual" record selectors. As a running example, consider the earlier Unit example: + + newtype Unit = MkUnit { runUnit :: () } + +When singling Unit, we do not give SMkUnit a record selector: + + data SUnit :: Unit -> Type where + SMkUnit :: Sing u -> SUnit (MkUnit u) + +Instead, we generate a top-level function that behaves equivalently to runUnit. +This function then gets promoted and singled (in D.S.TH.Promote.promoteDecs and +D.S.TH.Single.singTopLevelDecs): + + type family RunUnit (x :: Unit) :: () where + RunUnit (MkUnit x) = x + + sRunUnit :: Sing (x :: Unit) -> Sing (RunUnit x :: ()) + sRunUnit (SMkUnit sx) = sx + +Now promoting/singling uses of runUnit as an ordinary function work as expected +since the types of RunUnit/sRunUnit are sufficiently general. This technique also +scales up to data types with multiple constructors sharing a record selector name. +For instance, in the earlier X example: + + data X = X1 {y :: Bool} | X2 {y :: Bool} + +We would promote/single `y` like so: + + type family Y (x :: X) :: Bool where + Y (X1 y) = y + Y (X2 y) = y + + sY :: Sing (x :: X) -> Sing (Y x :: Bool) + sY (SX1 sy) = sy + sY (SX2 sy) = sy + +Manual record selectors cannot be used in record constructions or updates, but +for most use cases this won't be an issue, since singletons-th makes an effort to +desugar away fancy uses of records anyway. The only time this would bite is if +you wanted to use record syntax in hand-written singletons code. +-} diff --git a/src/Data/Singletons/TH/Single/Decide.hs b/src/Data/Singletons/TH/Single/Decide.hs --- a/src/Data/Singletons/TH/Single/Decide.hs +++ b/src/Data/Singletons/TH/Single/Decide.hs @@ -1,112 +1,134 @@ -{- Data/Singletons/TH/Single/Decide.hs - -(c) Richard Eisenberg 2014 -rae@cs.brynmawr.edu - -Defines functions to generate SDecide instances, as well as TestEquality and -TestCoercion instances that leverage SDecide. --} - -module Data.Singletons.TH.Single.Decide where - -import Language.Haskell.TH.Syntax -import Language.Haskell.TH.Desugar -import Data.Singletons.TH.Deriving.Infer -import Data.Singletons.TH.Names -import Data.Singletons.TH.Options -import Data.Singletons.TH.Promote.Type -import Data.Singletons.TH.Util -import Control.Monad - --- Make an instance of SDecide. -mkDecideInstance :: OptionsMonad q => Maybe DCxt -> DType - -> [DCon] -- ^ The /original/ constructors (for inferring the instance context) - -> [DCon] -- ^ The /singletons/ constructors - -> q DDec -mkDecideInstance mb_ctxt data_ty ctors sctors = do - let sctorPairs = [ (sc1, sc2) | sc1 <- sctors, sc2 <- sctors ] - methClauses <- if null sctors - then (:[]) <$> mkEmptyDecideMethClause - else mapM mkDecideMethClause sctorPairs - constraints <- inferConstraintsDef mb_ctxt (DConT sDecideClassName) data_ty ctors - data_ki <- promoteType data_ty - return $ DInstanceD Nothing Nothing - constraints - (DAppT (DConT sDecideClassName) data_ki) - [DLetDec $ DFunD sDecideMethName methClauses] - -data TestInstance = TestEquality - | TestCoercion - --- Make an instance of TestEquality or TestCoercion by leveraging SDecide. -mkTestInstance :: OptionsMonad q => Maybe DCxt -> DType - -> Name -- ^ The name of the data type - -> [DCon] -- ^ The /original/ constructors (for inferring the instance context) - -> TestInstance -> q DDec -mkTestInstance mb_ctxt data_ty data_name ctors ti = do - opts <- getOptions - constraints <- inferConstraintsDef mb_ctxt (DConT sDecideClassName) data_ty ctors - data_ki <- promoteType data_ty - pure $ DInstanceD Nothing Nothing - constraints - (DAppT (DConT tiClassName) - (DConT (singledDataTypeName opts data_name) - `DSigT` (DArrowT `DAppT` data_ki `DAppT` DConT typeKindName))) - [DLetDec $ DFunD tiMethName - [DClause [] (DVarE tiDefaultName)]] - where - (tiClassName, tiMethName, tiDefaultName) = - case ti of - TestEquality -> (testEqualityClassName, testEqualityMethName, decideEqualityName) - TestCoercion -> (testCoercionClassName, testCoercionMethName, decideCoercionName) - -mkDecideMethClause :: Quasi q => (DCon, DCon) -> q DClause -mkDecideMethClause (c1, c2) - | lname == rname = - if lNumArgs == 0 - then return $ DClause [DConP lname [] [], DConP rname [] []] - (DAppE (DConE provedName) (DConE reflName)) - else do - lnames <- replicateM lNumArgs (qNewName "a") - rnames <- replicateM lNumArgs (qNewName "b") - contra <- qNewName "contra" - let lpats = map DVarP lnames - rpats = map DVarP rnames - lvars = map DVarE lnames - rvars = map DVarE rnames - refl <- qNewName "refl" - return $ DClause - [DConP lname [] lpats, DConP rname [] rpats] - (DCaseE (mkTupleDExp $ - zipWith (\l r -> foldExp (DVarE sDecideMethName) [l, r]) - lvars rvars) - ((DMatch (mkTupleDPat (replicate lNumArgs - (DConP provedName [] [DConP reflName [] []]))) - (DAppE (DConE provedName) (DConE reflName))) : - [DMatch (mkTupleDPat (replicate i DWildP ++ - DConP disprovedName [] [DVarP contra] : - replicate (lNumArgs - i - 1) DWildP)) - (DAppE (DConE disprovedName) - (DLamE [refl] $ - DCaseE (DVarE refl) - [DMatch (DConP reflName [] []) $ - (DAppE (DVarE contra) - (DConE reflName))])) - | i <- [0..lNumArgs-1] ])) - - | otherwise = do - x <- qNewName "x" - return $ DClause - [DConP lname [] (replicate lNumArgs DWildP), - DConP rname [] (replicate rNumArgs DWildP)] - (DAppE (DConE disprovedName) (DLamE [x] (DCaseE (DVarE x) []))) - - where - (lname, lNumArgs) = extractNameArgs c1 - (rname, rNumArgs) = extractNameArgs c2 - -mkEmptyDecideMethClause :: Quasi q => q DClause -mkEmptyDecideMethClause = do - x <- qNewName "x" - pure $ DClause [DVarP x, DWildP] - $ DConE provedName `DAppE` DCaseE (DVarE x) [] +{- Data/Singletons/TH/Single/Decide.hs + +(c) Richard Eisenberg 2014 +rae@cs.brynmawr.edu + +Defines functions to generate SDecide instances, as well as TestEquality and +TestCoercion instances that leverage SDecide. +-} + +module Data.Singletons.TH.Single.Decide where + +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Desugar +import Data.Singletons.TH.Deriving.Infer +import Data.Singletons.TH.Names +import Data.Singletons.TH.Options +import Data.Singletons.TH.Promote.Type +import Data.Singletons.TH.Util +import Control.Monad + +-- Make an instance of SDecide. +mkDecideInstance :: OptionsMonad q => Maybe DCxt -> DType + -> [DCon] -- ^ The /original/ constructors (for inferring the instance context) + -> [DCon] -- ^ The /singletons/ constructors + -> q DDec +mkDecideInstance mb_ctxt data_ty ctors sctors = do + let sctorPairs = [ (sc1, sc2) | sc1 <- sctors, sc2 <- sctors ] + methClauses <- if null sctors + then (:[]) <$> mkEmptyDecideMethClause + else mapM mkDecideMethClause sctorPairs + constraints <- inferConstraintsDef mb_ctxt (DConT sDecideClassName) data_ty ctors + data_ki <- promoteType data_ty + return $ DInstanceD Nothing Nothing + constraints + (DAppT (DConT sDecideClassName) data_ki) + [DLetDec $ DFunD sDecideMethName methClauses] + +-- Make a boilerplate Eq instance for a singleton type, e.g., +-- +-- @ +-- instance Eq (SExample (z :: Example a)) where +-- _ == _ = True +-- @ +mkEqInstanceForSingleton :: OptionsMonad q + => DType + -> Name + -- ^ The name of the data type + -> q DDec +mkEqInstanceForSingleton data_ty data_name = do + opts <- getOptions + z <- qNewName "z" + data_ki <- promoteType data_ty + let sdata_name = singledDataTypeName opts data_name + pure $ DInstanceD Nothing Nothing [] + (DAppT (DConT eqName) (DConT sdata_name `DAppT` DSigT (DVarT z) data_ki)) + [DLetDec $ + DFunD equalsName + [DClause [DWildP, DWildP] (DConE trueName)]] + +data TestInstance = TestEquality + | TestCoercion + +-- Make an instance of TestEquality or TestCoercion by leveraging SDecide. +mkTestInstance :: OptionsMonad q => Maybe DCxt -> DType + -> Name -- ^ The name of the data type + -> [DCon] -- ^ The /original/ constructors (for inferring the instance context) + -> TestInstance -> q DDec +mkTestInstance mb_ctxt data_ty data_name ctors ti = do + opts <- getOptions + constraints <- inferConstraintsDef mb_ctxt (DConT sDecideClassName) data_ty ctors + data_ki <- promoteType data_ty + pure $ DInstanceD Nothing Nothing + constraints + (DAppT (DConT tiClassName) + (DConT (singledDataTypeName opts data_name) + `DSigT` (DArrowT `DAppT` data_ki `DAppT` DConT typeKindName))) + [DLetDec $ DFunD tiMethName + [DClause [] (DVarE tiDefaultName)]] + where + (tiClassName, tiMethName, tiDefaultName) = + case ti of + TestEquality -> (testEqualityClassName, testEqualityMethName, decideEqualityName) + TestCoercion -> (testCoercionClassName, testCoercionMethName, decideCoercionName) + +mkDecideMethClause :: Quasi q => (DCon, DCon) -> q DClause +mkDecideMethClause (c1, c2) + | lname == rname = + if lNumArgs == 0 + then return $ DClause [DConP lname [] [], DConP rname [] []] + (DAppE (DConE provedName) (DConE reflName)) + else do + lnames <- replicateM lNumArgs (qNewName "a") + rnames <- replicateM lNumArgs (qNewName "b") + contra <- qNewName "contra" + let lpats = map DVarP lnames + rpats = map DVarP rnames + lvars = map DVarE lnames + rvars = map DVarE rnames + refl <- qNewName "refl" + return $ DClause + [DConP lname [] lpats, DConP rname [] rpats] + (DCaseE (mkTupleDExp $ + zipWith (\l r -> foldExp (DVarE sDecideMethName) [l, r]) + lvars rvars) + ((DMatch (mkTupleDPat (replicate lNumArgs + (DConP provedName [] [DConP reflName [] []]))) + (DAppE (DConE provedName) (DConE reflName))) : + [DMatch (mkTupleDPat (replicate i DWildP ++ + DConP disprovedName [] [DVarP contra] : + replicate (lNumArgs - i - 1) DWildP)) + (DAppE (DConE disprovedName) + (DLamE [refl] $ + DCaseE (DVarE refl) + [DMatch (DConP reflName [] []) $ + (DAppE (DVarE contra) + (DConE reflName))])) + | i <- [0..lNumArgs-1] ])) + + | otherwise = do + x <- qNewName "x" + return $ DClause + [DConP lname [] (replicate lNumArgs DWildP), + DConP rname [] (replicate rNumArgs DWildP)] + (DAppE (DConE disprovedName) (DLamE [x] (DCaseE (DVarE x) []))) + + where + (lname, lNumArgs) = extractNameArgs c1 + (rname, rNumArgs) = extractNameArgs c2 + +mkEmptyDecideMethClause :: Quasi q => q DClause +mkEmptyDecideMethClause = do + x <- qNewName "x" + pure $ DClause [DVarP x, DWildP] + $ DConE provedName `DAppE` DCaseE (DVarE x) [] diff --git a/src/Data/Singletons/TH/Single/Defun.hs b/src/Data/Singletons/TH/Single/Defun.hs --- a/src/Data/Singletons/TH/Single/Defun.hs +++ b/src/Data/Singletons/TH/Single/Defun.hs @@ -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@ 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@ 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. +-} diff --git a/src/Data/Singletons/TH/Single/Fixity.hs b/src/Data/Singletons/TH/Single/Fixity.hs --- a/src/Data/Singletons/TH/Single/Fixity.hs +++ b/src/Data/Singletons/TH/Single/Fixity.hs @@ -1,170 +1,178 @@ -module Data.Singletons.TH.Single.Fixity where - -import Prelude hiding ( exp ) -import Language.Haskell.TH hiding ( cxt ) -import Language.Haskell.TH.Syntax (NameSpace(..), Quasi(..)) -import Data.Singletons.TH.Options -import Data.Singletons.TH.Util -import Language.Haskell.TH.Desugar - --- Single a fixity declaration. -singInfixDecl :: forall q. OptionsMonad q => Name -> Fixity -> q (Maybe DLetDec) -singInfixDecl name fixity = do - opts <- getOptions - mb_ns <- reifyNameSpace name - case mb_ns of - -- If we can't find the Name for some odd reason, - -- fall back to singValName - Nothing -> finish $ singledValueName opts name - Just VarName -> finish $ singledValueName opts name - Just DataName -> finish $ singledDataConName opts name - Just TcClsName -> do - mb_info <- dsReify name - case mb_info of - Just (DTyConI DClassD{} _) - -> finish $ singledClassName opts name - _ -> pure Nothing - -- Don't produce anything for other type constructors (type synonyms, - -- type families, data types, etc.). - -- See [singletons-th and fixity declarations], wrinkle 1. - where - finish :: Name -> q (Maybe DLetDec) - finish = pure . Just . DInfixD fixity - --- Try producing singled fixity declarations for Names by reifying them --- /without/ consulting quoted declarations. If reification fails, recover and --- return the empty list. --- See [singletons-th and fixity declarations], wrinkle 2. -singReifiedInfixDecls :: forall q. OptionsMonad q => [Name] -> q [DDec] -singReifiedInfixDecls = mapMaybeM trySingFixityDeclaration - where - trySingFixityDeclaration :: Name -> q (Maybe DDec) - trySingFixityDeclaration name = - qRecover (return Nothing) $ do - mFixity <- qReifyFixity name - case mFixity of - Nothing -> pure Nothing - Just fixity -> fmap (fmap DLetDec) $ singInfixDecl name fixity - -{- -Note [singletons-th and fixity declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Promoting and singling fixity declarations is surprisingly tricky to get right. -This Note serves as a place to document the insights learned after getting this -wrong at various points. - -As a general rule, when promoting something with a fixity declaration like this -one: - - infixl 5 `foo` - -singletons-th will produce promoted and singled versions of them: - - infixl 5 `Foo` - infixl 5 `sFoo` - -singletons-th will also produce fixity declarations for its defunctionalization -symbols (see Note [Fixity declarations for defunctionalization symbols] in -D.S.TH.Promote.Defun): - - infixl 5 `FooSym0` - infixl 5 `FooSym1` - ... - ------ --- Wrinkle 1: When not to promote/single fixity declarations ------ - -Rules are meant to be broken, and the general rule above is no exception. There -are certain cases where singletons-th does *not* produce promoted or singled -versions of fixity declarations: - -* During promotion, fixity declarations for the following sorts of names will - not receive promoted counterparts: - - - Data types - - Type synonyms - - Type families - - Data constructors - - Infix values - - We exclude the first four because the promoted versions of these names are - the same as the originals, so generating an extra fixity declaration for them - would run the risk of having duplicates, which GHC would reject with an error. - - We exclude infix value because while their promoted versions are different, - they share the same name base. In concrete terms, this: - - $(promote [d| - infixl 4 ### - (###) :: a -> a -> a - |]) - - Is promoted to the following: - - type family (###) (x :: a) (y :: a) :: a where ... - - So giving the type-level (###) a fixity declaration would clash with the - existing one for the value-level (###). - - There *is* a scenario where we should generate a fixity declaration for the - type-level (###), however. Imagine the above example used the `promoteOnly` - function instead of `promote`. Then the type-level (###) would lack a fixity - declaration altogether because the original fixity declaration was discarded - by `promoteOnly`! The same problem would arise if one had to choose between - the `singletons` and `singletonsOnly` functions. - - The difference between `promote` and `promoteOnly` (as well as `singletons` - and `singletonsOnly`) is whether the `genQuotedDecs` option is set to `True` - or `False`, respectively. Therefore, if `genQuotedDecs` is set to `False` - when promoting the fixity declaration for an infix value, we opt to generate - a fixity declaration (with the same name base) so that the type-level version - of that value gets one. - -* During singling, the following things will not have their fixity declarations - singled: - - - Type synonyms or type families. This is because singletons-th does not - generate singled versions of them in the first place (they only receive - defunctionalization symbols). - - - Data types. This is because the singled version of a data type T is - always of the form: - - data ST :: forall a_1 ... a_n. T a_1 ... a_n -> Type where ... - - Regardless of how many arguments T has, ST will have exactly one argument. - This makes is rather pointless to generate a fixity declaration for it. - ------ --- Wrinkle 2: Making sure fixity declarations are promoted/singled properly ------ - -There are two situations where singletons-th must promote/single fixity -declarations: - -1. When quoting code, i.e., with `promote` or `singletons`. -2. When reifying code, i.e., with `genPromotions` or `genSingletons`. - -In the case of (1), singletons-th stores the quoted fixity declarations in the -lde_infix field of LetDecEnv. Therefore, it suffices to call -promoteInfixDecl/singleInfixDecl when processing LetDecEnvs. - -In the case of (2), there is no LetDecEnv to use, so we must instead reify -the fixity declarations and promote/single those. See D.S.TH.Single.Data.singDataD -(which singles data constructors) for a place that does this—we will use -singDataD as a running example for the rest of this section. - -One complication is that code paths like singDataD are invoked in both (1) and -(2). This runs the risk that singletons-th will generate duplicate infix -declarations for data constructors in situation (1), as it will try to single -their fixity declarations once when processing them in LetDecEnvs and again -when reifying them in singDataD. - -To avoid this pitfall, when reifying declarations in singDataD we take care -*not* to consult any quoted declarations when reifying (i.e., we do not use -reifyWithLocals for functions like it). Therefore, it we are in situation (1), -then the reification in singDataD will fail (and recover gracefully), so it -will not produce any singled fixity declarations. Therefore, the only singled -fixity declarations will be produced by processing LetDecEnvs. --} +module Data.Singletons.TH.Single.Fixity where + +import Prelude hiding ( exp ) +import Language.Haskell.TH hiding ( cxt ) +import Language.Haskell.TH.Syntax (NameSpace(..), Quasi(..)) +import Data.Singletons.TH.Options +import Data.Singletons.TH.Util +import Language.Haskell.TH.Desugar +import qualified GHC.LanguageExtensions.Type as LangExt + +-- Single a fixity declaration. +singInfixDecl :: forall q. OptionsMonad q => Name -> Fixity -> q (Maybe DLetDec) +singInfixDecl name fixity = do + opts <- getOptions + fld_sels <- qIsExtEnabled LangExt.FieldSelectors + mb_ns <- reifyNameSpace name + case mb_ns of + -- If we can't find the Name for some odd reason, + -- fall back to singValName + Nothing -> finish $ singledValueName opts name + Just VarName -> finish $ singledValueName opts name + Just (FldName _) + | fld_sels -> finish $ singledValueName opts name + | otherwise -> never_mind + Just DataName -> finish $ singledDataConName opts name + Just TcClsName -> do + mb_info <- dsReify name + case mb_info of + Just (DTyConI DClassD{} _) + -> finish $ singledClassName opts name + _ -> never_mind + -- Don't produce anything for other type constructors (type synonyms, + -- type families, data types, etc.). + -- See [singletons-th and fixity declarations], wrinkle 1. + where + finish :: Name -> q (Maybe DLetDec) + finish = pure . Just . DInfixD fixity + + never_mind :: q (Maybe DLetDec) + never_mind = pure Nothing + +-- Try producing singled fixity declarations for Names by reifying them +-- /without/ consulting quoted declarations. If reification fails, recover and +-- return the empty list. +-- See [singletons-th and fixity declarations], wrinkle 2. +singReifiedInfixDecls :: forall q. OptionsMonad q => [Name] -> q [DDec] +singReifiedInfixDecls = mapMaybeM trySingFixityDeclaration + where + trySingFixityDeclaration :: Name -> q (Maybe DDec) + trySingFixityDeclaration name = + qRecover (return Nothing) $ do + mFixity <- qReifyFixity name + case mFixity of + Nothing -> pure Nothing + Just fixity -> fmap (fmap DLetDec) $ singInfixDecl name fixity + +{- +Note [singletons-th and fixity declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Promoting and singling fixity declarations is surprisingly tricky to get right. +This Note serves as a place to document the insights learned after getting this +wrong at various points. + +As a general rule, when promoting something with a fixity declaration like this +one: + + infixl 5 `foo` + +singletons-th will produce promoted and singled versions of them: + + infixl 5 `Foo` + infixl 5 `sFoo` + +singletons-th will also produce fixity declarations for its defunctionalization +symbols (see Note [Fixity declarations for defunctionalization symbols] in +D.S.TH.Promote.Defun): + + infixl 5 `FooSym0` + infixl 5 `FooSym1` + ... + +----- +-- Wrinkle 1: When not to promote/single fixity declarations +----- + +Rules are meant to be broken, and the general rule above is no exception. There +are certain cases where singletons-th does *not* produce promoted or singled +versions of fixity declarations: + +* During promotion, fixity declarations for the following sorts of names will + not receive promoted counterparts: + + - Data types + - Type synonyms + - Type families + - Data constructors + - Infix values + + We exclude the first four because the promoted versions of these names are + the same as the originals, so generating an extra fixity declaration for them + would run the risk of having duplicates, which GHC would reject with an error. + + We exclude infix value because while their promoted versions are different, + they share the same name base. In concrete terms, this: + + $(promote [d| + infixl 4 ### + (###) :: a -> a -> a + |]) + + Is promoted to the following: + + type family (###) (x :: a) (y :: a) :: a where ... + + So giving the type-level (###) a fixity declaration would clash with the + existing one for the value-level (###). + + There *is* a scenario where we should generate a fixity declaration for the + type-level (###), however. Imagine the above example used the `promoteOnly` + function instead of `promote`. Then the type-level (###) would lack a fixity + declaration altogether because the original fixity declaration was discarded + by `promoteOnly`! The same problem would arise if one had to choose between + the `singletons` and `singletonsOnly` functions. + + The difference between `promote` and `promoteOnly` (as well as `singletons` + and `singletonsOnly`) is whether the `genQuotedDecs` option is set to `True` + or `False`, respectively. Therefore, if `genQuotedDecs` is set to `False` + when promoting the fixity declaration for an infix value, we opt to generate + a fixity declaration (with the same name base) so that the type-level version + of that value gets one. + +* During singling, the following things will not have their fixity declarations + singled: + + - Type synonyms or type families. This is because singletons-th does not + generate singled versions of them in the first place (they only receive + defunctionalization symbols). + + - Data types. This is because the singled version of a data type T is + always of the form: + + data ST :: forall a_1 ... a_n. T a_1 ... a_n -> Type where ... + + Regardless of how many arguments T has, ST will have exactly one argument. + This makes is rather pointless to generate a fixity declaration for it. + +----- +-- Wrinkle 2: Making sure fixity declarations are promoted/singled properly +----- + +There are two situations where singletons-th must promote/single fixity +declarations: + +1. When quoting code, i.e., with `promote` or `singletons`. +2. When reifying code, i.e., with `genPromotions` or `genSingletons`. + +In the case of (1), singletons-th stores the quoted fixity declarations in the +lde_infix field of LetDecEnv. Therefore, it suffices to call +promoteInfixDecl/singleInfixDecl when processing LetDecEnvs. + +In the case of (2), there is no LetDecEnv to use, so we must instead reify +the fixity declarations and promote/single those. See D.S.TH.Single.Data.singDataD +(which singles data constructors) for a place that does this—we will use +singDataD as a running example for the rest of this section. + +One complication is that code paths like singDataD are invoked in both (1) and +(2). This runs the risk that singletons-th will generate duplicate infix +declarations for data constructors in situation (1), as it will try to single +their fixity declarations once when processing them in LetDecEnvs and again +when reifying them in singDataD. + +To avoid this pitfall, when reifying declarations in singDataD we take care +*not* to consult any quoted declarations when reifying (i.e., we do not use +reifyWithLocals for functions like it). Therefore, it we are in situation (1), +then the reification in singDataD will fail (and recover gracefully), so it +will not produce any singled fixity declarations. Therefore, the only singled +fixity declarations will be produced by processing LetDecEnvs. +-} diff --git a/src/Data/Singletons/TH/Single/Monad.hs b/src/Data/Singletons/TH/Single/Monad.hs --- a/src/Data/Singletons/TH/Single/Monad.hs +++ b/src/Data/Singletons/TH/Single/Monad.hs @@ -1,182 +1,205 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} - -{- Data/Singletons/TH/Single/Monad.hs - -(c) Richard Eisenberg 2014 -rae@cs.brynmawr.edu - -This file defines the SgM monad and its operations, for use during singling. - -The SgM monad allows reading from a SgEnv environment and is wrapped around a Q. --} - -module Data.Singletons.TH.Single.Monad ( - SgM, bindLets, bindContext, askContext, lookupVarE, lookupConE, - wrapSingFun, - singM, singDecsM, - emitDecs, emitDecsM - ) where - -import Prelude hiding ( exp ) -import Data.Map ( Map ) -import qualified Data.Map as Map -import Data.Singletons -import Data.Singletons.TH.Options -import Data.Singletons.TH.Promote.Monad ( emitDecs, emitDecsM ) -import Data.Singletons.TH.Util -import Language.Haskell.TH.Syntax hiding ( lift ) -import Language.Haskell.TH.Desugar -import Control.Monad ( liftM2 ) -import Control.Monad.IO.Class ( MonadIO ) -import Control.Monad.Reader ( MonadReader(..), ReaderT(..), asks ) -import Control.Monad.Writer ( MonadWriter, WriterT(..) ) -import Control.Applicative - --- environment during singling -data SgEnv = - SgEnv { sg_options :: Options - , sg_let_binds :: Map Name DExp -- from the *original* name - , sg_context :: DCxt -- See Note [Tracking the current type signature context] - , sg_local_decls :: [Dec] - } - -emptySgEnv :: SgEnv -emptySgEnv = SgEnv { sg_options = defaultOptions - , sg_let_binds = Map.empty - , sg_context = [] - , sg_local_decls = [] - } - --- the singling monad -newtype SgM a = SgM (ReaderT SgEnv (WriterT [DDec] Q) a) - deriving ( Functor, Applicative, Monad - , MonadReader SgEnv, MonadWriter [DDec] - , MonadFail, MonadIO, Quasi ) - -instance DsMonad SgM where - localDeclarations = asks sg_local_decls - -instance OptionsMonad SgM where - getOptions = asks sg_options - -bindLets :: [(Name, DExp)] -> SgM a -> SgM a -bindLets lets1 = - local (\env@(SgEnv { sg_let_binds = lets2 }) -> - env { sg_let_binds = (Map.fromList lets1) `Map.union` lets2 }) - --- Add some constraints to the current type signature context. --- See Note [Tracking the current type signature context] -bindContext :: DCxt -> SgM a -> SgM a -bindContext ctxt1 - = local (\env@(SgEnv { sg_context = ctxt2 }) -> - env { sg_context = ctxt1 ++ ctxt2 }) - --- Retrieve the current type signature context. --- See Note [Tracking the current type signature context] -askContext :: SgM DCxt -askContext = asks sg_context - -lookupVarE :: Name -> SgM DExp -lookupVarE name = do - opts <- getOptions - lookup_var_con (singledValueName opts) - (DVarE . singledValueName opts) name - -lookupConE :: Name -> SgM DExp -lookupConE name = do - opts <- getOptions - lookup_var_con (singledDataConName opts) - (DConE . singledDataConName opts) name - -lookup_var_con :: (Name -> Name) -> (Name -> DExp) -> Name -> SgM DExp -lookup_var_con mk_sing_name mk_exp name = do - opts <- getOptions - letExpansions <- asks sg_let_binds - sName <- mkDataName (nameBase (mk_sing_name name)) -- we want *term* names! - case Map.lookup name letExpansions of - Nothing -> do - -- try to get it from the global context - m_dinfo <- liftM2 (<|>) (dsReify sName) (dsReify name) - -- try the unrefined name too -- it's needed to bootstrap Enum - case m_dinfo of - Just (DVarI _ ty _) -> - let num_args = countArgs ty in - return $ wrapSingFun num_args (DConT $ defunctionalizedName0 opts name) - (mk_exp name) - _ -> return $ mk_exp name -- lambda-bound - Just exp -> return exp - -wrapSingFun :: Int -> DType -> DExp -> DExp -wrapSingFun 0 _ = id -wrapSingFun n ty = - let wrap_fun = DVarE $ case n of - 1 -> 'singFun1 - 2 -> 'singFun2 - 3 -> 'singFun3 - 4 -> 'singFun4 - 5 -> 'singFun5 - 6 -> 'singFun6 - 7 -> 'singFun7 - _ -> error "No support for functions of arity > 7." - in - (wrap_fun `DAppTypeE` ty `DAppE`) - -singM :: OptionsMonad q => [Dec] -> SgM a -> q (a, [DDec]) -singM locals (SgM rdr) = do - opts <- getOptions - other_locals <- localDeclarations - let wr = runReaderT rdr (emptySgEnv { sg_options = opts - , sg_local_decls = other_locals ++ locals }) - q = runWriterT wr - runQ q - -singDecsM :: OptionsMonad q => [Dec] -> SgM [DDec] -> q [DDec] -singDecsM locals thing = do - (decs1, decs2) <- singM locals thing - return $ decs1 ++ decs2 - -{- -Note [Tracking the current type signature context] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Much like we track the let-bound names in scope, we also track the current -context. For instance, in the following program: - - -- (1) - f :: forall a. Show a => a -> String -> Bool - f x y = g (show x) y - where - -- (2) - g :: forall b. Eq b => b -> b -> Bool - g = h - where - -- (3) - h :: b -> b -> Bool - h = (==) - -Here is the context at various points: - -(1) () -(2) (Show a) -(3) (Show a, Eq b) - -We track this informating during singling instead of during promotion, as the -promoted versions of things are often type families, which do not have -contexts. - -Why do we bother tracking this at all? Ultimately, because singDefuns (from -Data.Singletons.TH.Single.Defun) needs to know the current context in order to -generate a correctly typed SingI instance. For instance, if you called -singDefuns on the class method bar: - - class Foo a where - bar :: Eq a => a -> Bool - -Then if you only grabbed the context of `bar` itself, then you'd end up -generating the following SingI instance for BarSym0: - - instance SEq a => SingI (FooSym0 :: a ~> Bool) where ... - -Which is incorrect—there needs to be an (SFoo a) constraint as well! If we -track the current context when singling Foo, then we will correctly propagate -this information to singDefuns. --} +{-# LANGUAGE TemplateHaskellQuotes #-} + +{- Data/Singletons/TH/Single/Monad.hs + +(c) Richard Eisenberg 2014 +rae@cs.brynmawr.edu + +This file defines the SgM monad and its operations, for use during singling. + +The SgM monad allows reading from a SgEnv environment and is wrapped around a Q. +-} + +module Data.Singletons.TH.Single.Monad ( + SgM, bindLambdas, bindLets, bindContext, + askContext, lookupVarE, lookupConE, + wrapSingFun, + singM, singDecsM, + emitDecs, emitDecsM + ) where + +import Prelude hiding ( exp ) +import Data.Map ( Map ) +import qualified Data.Map as Map +import Data.Singletons +import Data.Singletons.TH.Options +import Data.Singletons.TH.Promote.Monad ( emitDecs, emitDecsM ) +import Data.Singletons.TH.Util +import Language.Haskell.TH.Syntax hiding ( lift ) +import Language.Haskell.TH.Desugar +import Control.Monad ( liftM2 ) +import Control.Monad.IO.Class ( MonadIO ) +import Control.Monad.Reader ( MonadReader(..), ReaderT(..), asks ) +import Control.Monad.Writer ( MonadWriter, WriterT(..) ) +import Control.Applicative + +-- environment during singling +data SgEnv = + SgEnv { sg_options :: Options + , sg_local_vars :: Map Name DExp + -- ^ Map from term-level 'Name's of local variables to their + -- singled counterparts. See @Note [Tracking local variables]@ in + -- "Data.Singletons.TH.Promote.Monad". + , sg_context :: DCxt -- See Note [Tracking the current type signature context] + , sg_local_decls :: [Dec] + } + +emptySgEnv :: SgEnv +emptySgEnv = SgEnv { sg_options = defaultOptions + , sg_local_vars = Map.empty + , sg_context = [] + , sg_local_decls = [] + } + +-- the singling monad +newtype SgM a = SgM (ReaderT SgEnv (WriterT [DDec] Q) a) + deriving ( Functor, Applicative, Monad + , MonadReader SgEnv, MonadWriter [DDec] + , MonadFail, MonadIO, Quasi ) + +instance DsMonad SgM where + localDeclarations = asks sg_local_decls + +instance OptionsMonad SgM where + getOptions = asks sg_options + +-- ^ Bring a list of lambda-bound names into scope for the duration the supplied +-- computation, where the first element of each pair is the original, term-level +-- name, and the second element of each pair is the singled counterpart. +-- See @Note [Tracking local variables]@ in "Data.Singletons.TH.Promote.Monad". +bindLambdas :: [(Name, Name)] -> SgM a -> SgM a +bindLambdas lambdas = local add_binds + where add_binds env@(SgEnv { sg_local_vars = locals }) = + let new_locals = Map.fromList [ (tmN, DVarE tyN) | (tmN, tyN) <- lambdas ] in + env { sg_local_vars = new_locals `Map.union` locals } + +-- ^ Bring a list of let-bound names into scope for the duration the supplied +-- computation, where the first element of each pair is the original, term-level +-- name, and the second element of each pair is the singled counterpart. +-- See @Note [Tracking local variables]@ in "Data.Singletons.TH.Promote.Monad". +bindLets :: [(Name, DExp)] -> SgM a -> SgM a +bindLets lets = + local (\env@(SgEnv { sg_local_vars = locals }) -> + env { sg_local_vars = Map.fromList lets `Map.union` locals }) + +-- Add some constraints to the current type signature context. +-- See Note [Tracking the current type signature context] +bindContext :: DCxt -> SgM a -> SgM a +bindContext ctxt1 + = local (\env@(SgEnv { sg_context = ctxt2 }) -> + env { sg_context = ctxt1 ++ ctxt2 }) + +-- Retrieve the current type signature context. +-- See Note [Tracking the current type signature context] +askContext :: SgM DCxt +askContext = asks sg_context + +-- | Map a term-level 'Name' to its singled counterpart. This function is aware +-- of any local variables that are currently in scope. +-- See @Note [Tracking local variables]@ in "Data.Singletons.TH.Promote.Monad". +lookupVarE :: Name -> SgM DExp +lookupVarE name = do + opts <- getOptions + lookup_var_con (singledValueName opts) + (DVarE . singledValueName opts) name + +-- | Map a data constructor name to its singled counterpart. +lookupConE :: Name -> SgM DExp +lookupConE name = do + opts <- getOptions + lookup_var_con (singledDataConName opts) + (DConE . singledDataConName opts) name + +lookup_var_con :: (Name -> Name) -> (Name -> DExp) -> Name -> SgM DExp +lookup_var_con mk_sing_name mk_exp name = do + opts <- getOptions + localExpansions <- asks sg_local_vars + sName <- mkDataName (nameBase (mk_sing_name name)) -- we want *term* names! + case Map.lookup name localExpansions of + Nothing -> do + -- try to get it from the global context + m_dinfo <- liftM2 (<|>) (dsReify sName) (dsReify name) + -- try the unrefined name too -- it's needed to bootstrap Enum + case m_dinfo of + Just (DVarI _ ty _) -> + let num_args = countArgs ty in + return $ wrapSingFun num_args (DConT $ defunctionalizedName0 opts name) + (mk_exp name) + _ -> return $ mk_exp name -- lambda-bound + Just exp -> return exp + +wrapSingFun :: Int -> DType -> DExp -> DExp +wrapSingFun 0 _ = id +wrapSingFun n ty = + let wrap_fun = DVarE $ case n of + 1 -> 'singFun1 + 2 -> 'singFun2 + 3 -> 'singFun3 + 4 -> 'singFun4 + 5 -> 'singFun5 + 6 -> 'singFun6 + 7 -> 'singFun7 + _ -> error "No support for functions of arity > 7." + in + (wrap_fun `DAppTypeE` ty `DAppE`) + +singM :: OptionsMonad q => [Dec] -> SgM a -> q (a, [DDec]) +singM locals (SgM rdr) = do + opts <- getOptions + other_locals <- localDeclarations + let wr = runReaderT rdr (emptySgEnv { sg_options = opts + , sg_local_decls = other_locals ++ locals }) + q = runWriterT wr + runQ q + +singDecsM :: OptionsMonad q => [Dec] -> SgM [DDec] -> q [DDec] +singDecsM locals thing = do + (decs1, decs2) <- singM locals thing + return $ decs1 ++ decs2 + +{- +Note [Tracking the current type signature context] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Much like we track the locally-bound names in scope (see Note [Tracking local +variables] in Data.Singletons.TH.Promote.Monad), we also track the current +context. For instance, in the following program: + + -- (1) + f :: forall a. Show a => a -> String -> Bool + f x y = g (show x) y + where + -- (2) + g :: forall b. Eq b => b -> b -> Bool + g = h + where + -- (3) + h :: b -> b -> Bool + h = (==) + +Here is the context at various points: + +(1) () +(2) (Show a) +(3) (Show a, Eq b) + +We track this informating during singling instead of during promotion, as the +promoted versions of things are often type families, which do not have +contexts. + +Why do we bother tracking this at all? Ultimately, because singDefuns (from +Data.Singletons.TH.Single.Defun) needs to know the current context in order to +generate a correctly typed SingI instance. For instance, if you called +singDefuns on the class method bar: + + class Foo a where + bar :: Eq a => a -> Bool + +Then if you only grabbed the context of `bar` itself, then you'd end up +generating the following SingI instance for BarSym0: + + instance SEq a => SingI (FooSym0 :: a ~> Bool) where ... + +Which is incorrect—there needs to be an (SFoo a) constraint as well! If we +track the current context when singling Foo, then we will correctly propagate +this information to singDefuns. +-} diff --git a/src/Data/Singletons/TH/Single/Ord.hs b/src/Data/Singletons/TH/Single/Ord.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/TH/Single/Ord.hs @@ -0,0 +1,43 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Singletons.TH.Single.Ord +-- Copyright : (C) 2023 Ryan Scott +-- License : BSD-style (see LICENSE) +-- Maintainer : Ryan Scott +-- Stability : experimental +-- Portability : non-portable +-- +-- Defines a function to generate boilerplate Ord instances for singleton +-- types. +-- +----------------------------------------------------------------------------- + +module Data.Singletons.TH.Single.Ord (mkOrdInstanceForSingleton) where + +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Desugar +import Data.Singletons.TH.Names +import Data.Singletons.TH.Options +import Data.Singletons.TH.Promote.Type + +-- Make a boilerplate Ord instance for a singleton type, e.g., +-- +-- @ +-- instance Ord (SExample (z :: Example a)) where +-- compare _ _ = EQ +-- @ +mkOrdInstanceForSingleton :: OptionsMonad q + => DType + -> Name + -- ^ The name of the data type + -> q DDec +mkOrdInstanceForSingleton data_ty data_name = do + opts <- getOptions + z <- qNewName "z" + data_ki <- promoteType data_ty + let sdata_name = singledDataTypeName opts data_name + pure $ DInstanceD Nothing Nothing [] + (DAppT (DConT ordName) (DConT sdata_name `DAppT` DSigT (DVarT z) data_ki)) + [DLetDec $ + DFunD compareName + [DClause [DWildP, DWildP] (DConE cmpEQName)]] diff --git a/src/Data/Singletons/TH/Single/Type.hs b/src/Data/Singletons/TH/Single/Type.hs --- a/src/Data/Singletons/TH/Single/Type.hs +++ b/src/Data/Singletons/TH/Single/Type.hs @@ -1,336 +1,336 @@ -{- Data/Singletons/TH/Single/Type.hs - -(c) Richard Eisenberg 2013 -rae@cs.brynmawr.edu - -Singletonizes types. --} - -module Data.Singletons.TH.Single.Type where - -import Language.Haskell.TH.Desugar -import Language.Haskell.TH.Syntax -import Data.Singletons.TH.Names -import Data.Singletons.TH.Options -import Data.Singletons.TH.Promote.Type -import Data.Singletons.TH.Single.Monad -import Data.Singletons.TH.Util -import Control.Monad - -singType :: DType -- the promoted version of the thing classified by... - -> DType -- ... this type - -> SgM ( DType -- the singletonized type - , Int -- the number of arguments - , [Name] -- the names of the tyvars used in the sing'd type - , DCxt -- the context of the singletonized type - , [DKind] -- the kinds of the argument types - , DKind ) -- the kind of the result type -singType prom ty = do - (orig_tvbs, cxt, args, res) <- unravelVanillaDType ty - let num_args = length args - cxt' <- mapM singPred_NC cxt - arg_names <- replicateM num_args (qNewName "t") - prom_args <- mapM promoteType_NC args - prom_res <- promoteType_NC res - let args' = map (\n -> singFamily `DAppT` (DVarT n)) arg_names - res' = singFamily `DAppT` (foldApply prom (map DVarT arg_names) `DSigT` prom_res) - -- Make sure to include an explicit `prom_res` kind annotation. - -- See Note [Preserve the order of type variables during singling], - -- wrinkle 3. - arg_tvbs = zipWith (`DKindedTV` SpecifiedSpec) arg_names prom_args - -- If the original type signature lacks an explicit `forall`, then do not - -- give the singled type signature an outermost `forall`. Instead, give it - -- a ` :: Type` kind annotation and let GHC implicitly - -- quantify any type variables that are free in ``. - -- See Note [Preserve the order of type variables during singling], - -- wrinkle 1. - ty' | null orig_tvbs - = ravelVanillaDType arg_tvbs cxt' args' res' `DSigT` DConT typeKindName - | otherwise - = ravelVanillaDType (orig_tvbs ++ arg_tvbs) cxt' args' res' - return (ty', num_args, arg_names, cxt, prom_args, prom_res) - --- Single a DPred, checking that it is a vanilla type in the process. --- See [Vanilla-type validity checking during promotion] --- in Data.Singletons.TH.Promote.Type. -singPred :: DPred -> SgM DPred -singPred p = do - checkVanillaDType p - singPred_NC p - --- Single a DPred. Does not check if the argument is a vanilla type. --- See [Vanilla-type validity checking during promotion] --- in Data.Singletons.TH.Promote.Type. -singPred_NC :: DPred -> SgM DPred -singPred_NC = singPredRec [] - --- The workhorse for singPred_NC. -singPredRec :: [DTypeArg] -> DPred -> SgM DPred -singPredRec _cxt (DForallT {}) = - fail "Singling of quantified constraints not yet supported" -singPredRec _cxt (DConstrainedT {}) = - fail "Singling of quantified constraints not yet supported" -singPredRec ctx (DAppT pr ty) = singPredRec (DTANormal ty : ctx) pr -singPredRec ctx (DAppKindT pr ki) = singPredRec (DTyArg ki : ctx) pr -singPredRec _ctx (DSigT _pr _ki) = - fail "Singling of constraints with explicit kinds not yet supported" -singPredRec _ctx (DVarT _n) = - fail "Singling of contraint variables not yet supported" -singPredRec ctx (DConT n) - | n == equalityName - = fail "Singling of type equality constraints not yet supported" - | otherwise = do - opts <- getOptions - kis <- mapM promoteTypeArg_NC ctx - let sName = singledClassName opts n - return $ applyDType (DConT sName) kis -singPredRec _ctx DWildCardT = return DWildCardT -- it just might work -singPredRec _ctx DArrowT = - fail "(->) spotted at head of a constraint" -singPredRec _ctx (DLitT {}) = - fail "Type-level literal spotted at head of a constraint" - -{- -Note [Preserve the order of type variables during singling] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -singletons-th does its best to preseve the order in which users write type -variables in type signatures for functions and data constructors. They are -"preserved" in the sense that if one writes `foo @T1 @T2`, one should be -able to write out `sFoo @T1 @T2` by hand and have the same order of visible -type applications still work. Accomplishing this is surprisingly nontrivial, -so this Note documents the various wrinkles one must iron out to get this -working. - ------ --- Wrinkle 1: Dealing with the presence (and absence) of `forall` ------ - -If we single a function that has an explicit `forall`, such as this example: - - const2 :: forall b a. a -> b -> a - const2 x _ = x - -Then our job is easy, as the exact order of type variables has already been -spelled out in advance. We single this to: - - sConst2 :: forall b a (x :: a) (y :: b). Sing x -> Sing y -> Sing (Const2 x y :: a) - sConst2 = ... - -What happens if there is no explicit `forall`, as in this example? - - data V a - - absurd :: V a -> b - absurd v = case v of {} - -This time, the order of type variables vis-à-vis TypeApplications is determined -by their left-to-right order of appearance in the type signature. This order -dictates that `a` is quantified before `b`, so we must mirror this order in the -singled type signature. - -One way to accomplish this would be to compute the order in which the type -variables appear and then explicitly quantify them. In the `absurd` example -above, this would be tantamount to writing: - - sAbsurd :: forall a b (v :: V a). Sing v -> Sing (Absurd v :: b) - ^^^ - ||| - Explicitly quantified by singletons-th, - not in the original type signature - -This is possible to do, and indeed, singletons-th used to do this. However, it -is a bit tiresome to implement. In order to know which type variables to -quantify, you must keep track of which type variables have been brought into -scope at all times. For the historical details on how this worked, see this -now-removed Note describing the old implementation: -https://github.com/goldfirere/singletons/blob/10ef27880d7ecc16241824c504ca83e2bb6ca787/singletons-th/src/Data/Singletons/TH/Promote/Monad.hs#L135-L192 - -A much more straightforward approach, which singletons-th currently uses, is to -let GHC do the hard work of implicitly quantifying the type variables. That is, -we will single `absurd` to something like this: - - sAbsurd :: () => forall (v :: V a). Sing v -> Sing (Absurd v :: b) - -This works because just like in the original type signature, `a` and `b` are -implicitly quantified, and more importantly, they are quantified in exactly the -same order as in the original type signature. - -Why do we need the `() => ...` part? If we had instead written the type -signature like this: - - sAbsurd :: forall (v :: V a). Sing v -> Sing (Absurd v :: b) - -Then GHC would reject `a` and `b` for being out of scope. This is because of -GHC's "forall-or-nothing" rule: if a type signature has an outermost forall, -then all type variable occurrences in the type signature must have explicit -binding sites. Using `() => forall (v :: V a). ...` prevents the `forall` from -being an outermost `forall`, which bypasses the forall-or-nothing rule. - -Some further complications: - -* Template Haskell doesn't actually allow you to splice in types of the form - `() => ...` in practice. - See https://gitlab.haskell.org/ghc/ghc/-/issues/16396. Luckily, this isn't a - deal-breaker, as we can also avoid the forall-or-nothing rule by annotating - the type signature with an explicit `... :: Type` annotation: - - sAbsurd :: ((forall (v :: V a). Sing v -> Sing (Absurd v :: b)) :: Type) - - This is the approach that singletons-th actually uses. Note that there is one - spot in the code (in D.S.TH.Single.singInstD) that must be taught to look - through these `... :: Type` annotations, but this approach is otherwise fairly - non-invasive. - -* We cannot use this trick when singling the types of data constructors. That - is, we cannot single this: - - data T a where - MkT :: a -> T a - - To this: - - data ST z where - SMkT :: ((forall (x :: a). Sing x -> ST (MkT x)) :: Type) - - This is because GADT syntax does not currently permit nested `forall`s of this - sort. (It might permit them in the future if - https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0402-gadt-syntax.rst - is implemented, but not currently.) As a result, we /always/ explicitly - quantify all type variables in a data constructor's type, regardless of - whether the original type implicitly quantified them or not. In the example - above, that means that the singled version would be: - - data ST z where - SMkT :: forall a (x :: a). Sing x -> ST (MkT x) - ------ --- Wrinkle 2: The TH reification swamp ------ - -There is another issue with type signatures that lack explicit `forall`s, one -which the current design of Template Haskell does not make simple to fix. -If we single code that is wrapped in TH quotes, such as in the following example: - - {-# LANGUAGE PolyKinds, ... #-} - $(singletons [d| - data Proxy a = MkProxy - |]) - -Then our job is made much easier when singling MkProxy, since we know that the -only type variable that must be quantified is `a`, as that is the only one -specified by the user. This results in the following type signature for -MkProxy: - - MkProxy :: forall a. Proxy a - -However, this is not the only possible way to single MkProxy. One can -alternatively use $(genSingletons [''Proxy]), which uses TH reification to -infer the type of MkProxy. There is perilous, however, because this is how -TH reifies Proxy: - - DataD - [] ''Proxy [KindedTV a () (VarT k)] Nothing - [NormalC 'MkProxy []] - [] - -We must then construct a type signature for MkProxy using nothing but the type -variables from the data type header. But notice that `KindedTV a () (VarT k)` -gives no indication of whether `k` is specified or inferred! As a result, we -conservatively assume that `k` is specified, resulting the following type -signature for MkProxy: - - MkProxy :: forall k (a :: k). Proxy a - -Contrast this with `MkProxy :: Proxy a`, where `k` is inferred. In other words, -if you single MkProxy using genSingletons, then `Proxy @True` will typecheck -but `SMkProxy @True` will /not/ typecheck—you'd have to use -`SMkProxy @_ @True` instead. Urk! - -At present, Template Haskell does not have a way to distinguish among the -specificities bound by a data type header. Without this knowledge, it is -unclear how one could work around this issue. Thankfully, this issue is -only likely to surface in very limited circumstances, so the damage is somewhat -minimal. - ------ --- Wrinkle 3: Where to put explicit kind annotations ------ - -Type variable binders are only part of the story—we must also determine what -the body of the type signature will be singled to. As a general rule, if the -original type signature is of the form: - - f :: forall a_1 ... a_m. (C_1, ..., C_n) - => T_1 -> ... -> T_p -> R - -Then the singled type signature will be: - - sF :: forall a_1 ... a_m (x_1 :: PT_1) ... (x_p :: PT_p). (SC_1, ..., SC_n) - => Sing x1 -> ... -> Sing x_p -> SRes (F x1 ... x_p :: PR) - -Where: - -* x_i is a fresh type variable of kind PT_i. -* PT_i is the promoted version of the type T_i, and PR is the promoted version - of the type R. -* SC_i is the singled version of the constraint SC_i. -* SRes is either `Sing` if dealing with a function, or a singled data type if - dealing with a data constructor. For instance, SRes is `SBool` in - `STrue :: SBool (True :: Bool)`. - -One aspect of this worth pointing out is the explicit `:: PR` kind annotation -in the result type `Sing (F x1 ... x_p :: PR)`. As it turns out, this kind -annotation is mandatory, as omitting can result in singled type signatures -with the wrong semantics. For instance, consider the `Nothing` data -constructor: - - Nothing :: forall a. Maybe a - -Consider what would happen if it were singled to this type: - - SNothing :: forall a. SMaybe Nothing - -This is not what we want at all, since the `a` has no connection to the -`Nothing` in the result type. It's as if we had written this: - - SNothing :: forall {t} a. SMaybe (Nothing :: Maybe t) - -If we instead generate `forall a. SMaybe (Nothing :: Maybe a)`, then this issue -is handily avoided. - -You might wonder if it would be cleaner to use visible kind applications -instead: - - SNothing :: forall a. SMaybe (Nothing @a) - -This does work for many cases, but there are also some corner cases where this -approach fails. Recall the `MkProxy` example from Wrinkle 2 above: - - {-# LANGUAGE PolyKinds, ... #-} - data Proxy a = MkProxy - $(genSingletons [''Proxy]) - -Due to the design of Template Haskell (discussed in Wrinkle 2), `MkProxy` will -be reified with the type of `forall k (a :: k). Proxy a`. This means that -if we used visible kind applications in the result type, we would end up with -this: - - SMkProxy :: forall k (a :: k). SProxy (MkProxy @k @a) - -This will not kind-check because MkProxy only accepts /one/ visible kind argument, -whereas this supplies it with two. To avoid this issue, we instead use the type -`forall k (a :: k). SProxy (MkProxy :: Proxy a)`. Granted, this type is /still/ -technically wrong due to the fact that it explicitly quantifies `k`, but at the -very least it typechecks. If Template Haskell gained the ability to distinguish -among the specificities of type variables bound by a data type header -(perhaps by way of a language feature akin to -https://github.com/ghc-proposals/ghc-proposals/pull/326), then we could revisit -this design choice. - -Finally, note that we need only write `Sing x_1 -> ... -> Sing x_p`, and not -`Sing (x_1 :: PT_1) -> ... Sing (x_p :: PT_p)`. This is simply because we -always use explicit `forall`s in singled type signatures, and therefore always -explicitly bind `(x_1 :: PT_1) ... (x_p :: PT_p)`, which fully determine the -kinds of `x_1 ... x_p`. It wouldn't be wrong to add extra kind annotations to -`Sing x_1 -> ... -> Sing x_p`, just redundant. --} +{- Data/Singletons/TH/Single/Type.hs + +(c) Richard Eisenberg 2013 +rae@cs.brynmawr.edu + +Singletonizes types. +-} + +module Data.Singletons.TH.Single.Type where + +import Language.Haskell.TH.Desugar +import Language.Haskell.TH.Syntax +import Data.Singletons.TH.Names +import Data.Singletons.TH.Options +import Data.Singletons.TH.Promote.Type +import Data.Singletons.TH.Single.Monad +import Data.Singletons.TH.Util +import Control.Monad + +singType :: DType -- the promoted version of the thing classified by... + -> DType -- ... this type + -> SgM ( DType -- the singletonized type + , Int -- the number of arguments + , [Name] -- the names of the tyvars used in the sing'd type + , DCxt -- the context of the singletonized type + , [DKind] -- the kinds of the argument types + , DKind ) -- the kind of the result type +singType prom ty = do + (orig_tvbs, cxt, args, res) <- unravelVanillaDType ty + let num_args = length args + cxt' <- mapM singPred_NC cxt + arg_names <- replicateM num_args (qNewName "t") + prom_args <- mapM promoteType_NC args + prom_res <- promoteType_NC res + let args' = map (\n -> singFamily `DAppT` (DVarT n)) arg_names + res' = singFamily `DAppT` (foldApply prom (map DVarT arg_names) `DSigT` prom_res) + -- Make sure to include an explicit `prom_res` kind annotation. + -- See Note [Preserve the order of type variables during singling], + -- wrinkle 3. + arg_tvbs = zipWith (`DKindedTV` SpecifiedSpec) arg_names prom_args + -- If the original type signature lacks an explicit `forall`, then do not + -- give the singled type signature an outermost `forall`. Instead, give it + -- a ` :: Type` kind annotation and let GHC implicitly + -- quantify any type variables that are free in ``. + -- 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. +-} diff --git a/src/Data/Singletons/TH/SuppressUnusedWarnings.hs b/src/Data/Singletons/TH/SuppressUnusedWarnings.hs --- a/src/Data/Singletons/TH/SuppressUnusedWarnings.hs +++ b/src/Data/Singletons/TH/SuppressUnusedWarnings.hs @@ -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 :: () diff --git a/src/Data/Singletons/TH/Syntax.hs b/src/Data/Singletons/TH/Syntax.hs --- a/src/Data/Singletons/TH/Syntax.hs +++ b/src/Data/Singletons/TH/Syntax.hs @@ -1,224 +1,243 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} - -{- Data/Singletons/TH/Syntax.hs - -(c) Richard Eisenberg 2014 -rae@cs.brynmawr.edu - -Converts a list of DLetDecs into a LetDecEnv for easier processing, -and contains various other AST definitions. --} - -module Data.Singletons.TH.Syntax where - -import Prelude hiding ( exp ) -import Data.Kind (Constraint, Type) -import Language.Haskell.TH.Syntax hiding (Type) -import Language.Haskell.TH.Desugar -import qualified Language.Haskell.TH.Desugar.OMap.Strict as OMap -import Language.Haskell.TH.Desugar.OMap.Strict (OMap) - -type VarPromotions = [(Name, Name)] -- from term-level name to type-level name - --- A list of 'SingDSigPaInfos' is produced when singling pattern signatures, as we --- must case on the 'DExp's and match on them using the supplied 'DType's to --- bring the necessary singleton equality constraints into scope. --- See @Note [Singling pattern signatures]@. -type SingDSigPaInfos = [(DExp, DType)] - --- The parts of data declarations that are relevant to singletons-th. -data DataDecl = DataDecl DataFlavor Name [DTyVarBndrUnit] [DCon] - --- The parts of type synonyms that are relevant to singletons-th. -data TySynDecl = TySynDecl Name [DTyVarBndrUnit] DType - --- The parts of open type families that are relevant to singletons-th. -type OpenTypeFamilyDecl = TypeFamilyDecl 'Open - --- The parts of closed type families that are relevant to singletons-th. -type ClosedTypeFamilyDecl = TypeFamilyDecl 'Closed - --- The parts of type families that are relevant to singletons-th. -newtype TypeFamilyDecl (info :: FamilyInfo) - = TypeFamilyDecl { getTypeFamilyDecl :: DTypeFamilyHead } --- Whether a type family is open or closed. -data FamilyInfo = Open | Closed - -data ClassDecl ann - = ClassDecl { cd_cxt :: DCxt - , cd_name :: Name - , cd_tvbs :: [DTyVarBndrUnit] - , cd_fds :: [FunDep] - , cd_lde :: LetDecEnv ann - , cd_atfs :: [OpenTypeFamilyDecl] - -- Associated type families. Only recorded for - -- defunctionalization purposes. - -- See Note [Partitioning, type synonyms, and type families] - -- in D.S.TH.Partition. - } - -data InstDecl ann = InstDecl { id_cxt :: DCxt - , id_name :: Name - , id_arg_tys :: [DType] - , id_sigs :: OMap Name DType - , id_meths :: [(Name, LetDecRHS ann)] } - -type UClassDecl = ClassDecl Unannotated -type UInstDecl = InstDecl Unannotated - -type AClassDecl = ClassDecl Annotated -type AInstDecl = InstDecl Annotated - -{- -We see below several datatypes beginning with "A". These are annotated structures, -necessary for Promote to communicate key things to Single. In particular, promotion -of expressions is *not* deterministic, due to the necessity to create unique names -for lets, cases, and lambdas. So, we put these promotions into an annotated AST -so that Single can use the right promotions. --} - --- A DExp with let, lambda, and type-signature nodes annotated with their --- type-level equivalents -data ADExp = ADVarE Name - | ADConE Name - | ADLitE Lit - | ADAppE ADExp ADExp - | ADLamE [Name] -- type-level names corresponding to term-level ones - DType -- the promoted lambda - [Name] ADExp - | ADCaseE ADExp [ADMatch] DType - -- the type is the return type - | ADLetE ALetDecEnv ADExp - | ADSigE DType -- the promoted expression - ADExp DType - --- A DPat with a pattern-signature node annotated with its type-level equivalent -data ADPat = ADLitP Lit - | ADVarP Name - | ADConP Name [DType] [ADPat] - | ADTildeP ADPat - | ADBangP ADPat - | ADSigP DType -- The promoted pattern. Will not contain any wildcards, - -- as per Note [Singling pattern signatures] - ADPat DType - | ADWildP - -data ADMatch = ADMatch VarPromotions ADPat ADExp -data ADClause = ADClause VarPromotions - [ADPat] ADExp - -data AnnotationFlag = Annotated | Unannotated - --- These are used at the type-level exclusively -type Annotated = 'Annotated -type Unannotated = 'Unannotated - -type family IfAnn (ann :: AnnotationFlag) (yes :: k) (no :: k) :: k where - IfAnn Annotated yes no = yes - IfAnn Unannotated yes no = no - -data family LetDecRHS :: AnnotationFlag -> Type -data instance LetDecRHS Annotated - = -- A function definition. Invariant: each ADClause contains at least one - -- pattern. - AFunction - Int -- The number of arrows in the type. As a consequence of the invariant - -- above, this is always a positive number. - [ADClause] - - | -- A value whose definition is given by the DExp. Invariant: the value is - -- not a function (i.e., there are no occurrences of (->) in the value's - -- type). - AValue - ADExp -data instance LetDecRHS Unannotated = UFunction [DClause] - | UValue DExp - -type ALetDecRHS = LetDecRHS Annotated -type ULetDecRHS = LetDecRHS Unannotated - -data LetDecEnv ann = LetDecEnv - { lde_defns :: OMap Name (LetDecRHS ann) - , lde_types :: OMap Name DType -- type signatures - , lde_infix :: OMap Name Fixity -- infix declarations - , lde_proms :: IfAnn ann (OMap Name DType) () -- possibly, promotions - } -type ALetDecEnv = LetDecEnv Annotated -type ULetDecEnv = LetDecEnv Unannotated - -instance Semigroup ULetDecEnv where - LetDecEnv defns1 types1 infx1 _ <> LetDecEnv defns2 types2 infx2 _ = - LetDecEnv (defns1 <> defns2) (types1 <> types2) (infx1 <> infx2) () - -instance Monoid ULetDecEnv where - mempty = LetDecEnv OMap.empty OMap.empty OMap.empty () - -valueBinding :: Name -> ULetDecRHS -> ULetDecEnv -valueBinding n v = emptyLetDecEnv { lde_defns = OMap.singleton n v } - -typeBinding :: Name -> DType -> ULetDecEnv -typeBinding n t = emptyLetDecEnv { lde_types = OMap.singleton n t } - -infixDecl :: Fixity -> Name -> ULetDecEnv -infixDecl f n = emptyLetDecEnv { lde_infix = OMap.singleton n f } - -emptyLetDecEnv :: ULetDecEnv -emptyLetDecEnv = mempty - -buildLetDecEnv :: Quasi q => [DLetDec] -> q ULetDecEnv -buildLetDecEnv = go emptyLetDecEnv - where - go acc [] = return acc - go acc (DFunD name clauses : rest) = - go (valueBinding name (UFunction clauses) <> acc) rest - go acc (DValD (DVarP name) exp : rest) = - go (valueBinding name (UValue exp) <> acc) rest - go acc (dec@(DValD {}) : rest) = do - flattened <- flattenDValD dec - go acc (flattened ++ rest) - go acc (DSigD name ty : rest) = - go (typeBinding name ty <> acc) rest - go acc (DInfixD f n : rest) = - go (infixDecl f n <> acc) rest - go acc (DPragmaD{} : rest) = go acc rest - --- See Note [DerivedDecl] -data DerivedDecl (cls :: Type -> Constraint) = DerivedDecl - { ded_mb_cxt :: Maybe DCxt - , ded_type :: DType - , ded_type_tycon :: Name - , ded_decl :: DataDecl - } - -type DerivedEqDecl = DerivedDecl Eq -type DerivedShowDecl = DerivedDecl Show - -{- Note [DerivedDecl] -~~~~~~~~~~~~~~~~~~~~~ -Most derived instances are wholly handled in -Data.Singletons.TH.Partition.partitionDecs. There are two notable exceptions to -this rule, however, that are partially handled outside of partitionDecs: -Eq and Show instances. For these instances, we use a DerivedDecl data type to -encode just enough information to recreate the derived instance: - -1. Just the instance context, if it's standalone-derived, or Nothing if it's in - a deriving clause (ded_mb_cxt) -2. The datatype, applied to some number of type arguments, as in the - instance declaration (ded_type) -3. The datatype name (ded_type_tycon), cached for convenience -4. The datatype's constructors (ded_cons) - -Why are these instances handled outside of partitionDecs? - -* Deriving Eq in singletons-th not only derives PEq/SEq instances, but it also - derives SDecide, TestEquality, and TestCoercion instances. - Data.Singletons.TH.Single (depending on the task at hand). -* Deriving Show in singletons-th not only derives PShow/SShow instances, but it - also derives Show instances for singletons-th types. - -To make this work, we let partitionDecs handle the P{Eq,Show} and S{Eq,Show} -instances, but we also stick the relevant info into a DerivedDecl value for -later use in Data.Singletons.TH.Single, where we additionally generate -SDecide, TestEquality, TestCoercion and Show instances for singleton types. --} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} + +{- Data/Singletons/TH/Syntax.hs + +(c) Richard Eisenberg 2014 +rae@cs.brynmawr.edu + +Converts a list of DLetDecs into a LetDecEnv for easier processing, +and contains various other AST definitions. +-} + +module Data.Singletons.TH.Syntax where + +import Prelude hiding ( exp ) +import Data.Kind (Constraint, Type) +import Language.Haskell.TH.Syntax hiding (Type) +import Language.Haskell.TH.Desugar +import qualified Language.Haskell.TH.Desugar.OMap.Strict as OMap +import Language.Haskell.TH.Desugar.OMap.Strict (OMap) +import Language.Haskell.TH.Desugar.OSet (OSet) + +type VarPromotions = [(Name, Name)] -- from term-level name to type-level name + +-- Information that is accumulated when promoting patterns. +data PromDPatInfos = PromDPatInfos + { prom_dpat_vars :: VarPromotions + -- Maps term-level pattern variables to their promoted, type-level counterparts. + , prom_dpat_sig_kvs :: OSet Name + -- Kind variables bound by DSigPas. + -- See Note [Scoped type variables] in Data.Singletons.TH.Promote.Monad. + } + +instance Semigroup PromDPatInfos where + PromDPatInfos vars1 sig_kvs1 <> PromDPatInfos vars2 sig_kvs2 + = PromDPatInfos (vars1 <> vars2) (sig_kvs1 <> sig_kvs2) + +instance Monoid PromDPatInfos where + mempty = PromDPatInfos mempty mempty + +-- A list of 'SingDSigPaInfos' is produced when singling pattern signatures, as we +-- must case on the 'DExp's and match on them using the supplied 'DType's to +-- bring the necessary singleton equality constraints into scope. +-- See @Note [Singling pattern signatures]@. +type SingDSigPaInfos = [(DExp, DType)] + +-- The parts of data declarations that are relevant to singletons-th. +data DataDecl = DataDecl DataFlavor Name [DTyVarBndrVis] [DCon] + +-- The parts of type synonyms that are relevant to singletons-th. +data TySynDecl = TySynDecl Name [DTyVarBndrVis] DType + +-- The parts of open type families that are relevant to singletons-th. +type OpenTypeFamilyDecl = TypeFamilyDecl 'Open + +-- The parts of closed type families that are relevant to singletons-th. +type ClosedTypeFamilyDecl = TypeFamilyDecl 'Closed + +-- The parts of type families that are relevant to singletons-th. +newtype TypeFamilyDecl (info :: FamilyInfo) + = TypeFamilyDecl { getTypeFamilyDecl :: DTypeFamilyHead } +-- Whether a type family is open or closed. +data FamilyInfo = Open | Closed + +data ClassDecl ann + = ClassDecl { cd_cxt :: DCxt + , cd_name :: Name + , cd_tvbs :: [DTyVarBndrVis] + , cd_fds :: [FunDep] + , cd_lde :: LetDecEnv ann + , cd_atfs :: [OpenTypeFamilyDecl] + -- Associated type families. Only recorded for + -- defunctionalization purposes. + -- See Note [Partitioning, type synonyms, and type families] + -- in D.S.TH.Partition. + } + +data InstDecl ann = InstDecl { id_cxt :: DCxt + , id_name :: Name + , id_arg_tys :: [DType] + , id_sigs :: OMap Name DType + , id_meths :: [(Name, LetDecRHS ann)] } + +type UClassDecl = ClassDecl Unannotated +type UInstDecl = InstDecl Unannotated + +type AClassDecl = ClassDecl Annotated +type AInstDecl = InstDecl Annotated + +{- +We see below several datatypes beginning with "A". These are annotated structures, +necessary for Promote to communicate key things to Single. In particular, promotion +of expressions is *not* deterministic, due to the necessity to create unique names +for lets, cases, and lambdas. So, we put these promotions into an annotated AST +so that Single can use the right promotions. +-} + +-- A DExp with let, lambda, and type-signature nodes annotated with their +-- type-level equivalents +data ADExp = ADVarE Name + | ADConE Name + | ADLitE Lit + | ADAppE ADExp ADExp + | ADLamE [Name] -- type-level names corresponding to term-level ones + DType -- the promoted lambda + [Name] ADExp + | ADCaseE ADExp [ADMatch] DType + -- the type is the return type + | ADLetE ALetDecEnv ADExp + | ADSigE DType -- the promoted expression + ADExp DType + +-- A DPat with a pattern-signature node annotated with its type-level equivalent +data ADPat = ADLitP Lit + | ADVarP Name + | ADConP Name [DType] [ADPat] + | ADTildeP ADPat + | ADBangP ADPat + | ADSigP DType -- The promoted pattern. Will not contain any wildcards, + -- as per Note [Singling pattern signatures] + ADPat DType + | ADWildP + +data ADMatch = ADMatch VarPromotions ADPat ADExp +data ADClause = ADClause VarPromotions + [ADPat] ADExp + +data AnnotationFlag = Annotated | Unannotated + +-- These are used at the type-level exclusively +type Annotated = 'Annotated +type Unannotated = 'Unannotated + +type family IfAnn (ann :: AnnotationFlag) (yes :: k) (no :: k) :: k where + IfAnn Annotated yes no = yes + IfAnn Unannotated yes no = no + +data family LetDecRHS :: AnnotationFlag -> Type +data instance LetDecRHS Annotated + = -- A function definition. Invariant: each ADClause contains at least one + -- pattern. + AFunction + Int -- The number of arrows in the type. As a consequence of the invariant + -- above, this is always a positive number. + [ADClause] + + | -- A value whose definition is given by the DExp. Invariant: the value is + -- not a function (i.e., there are no occurrences of (->) in the value's + -- type). + AValue + ADExp +data instance LetDecRHS Unannotated = UFunction [DClause] + | UValue DExp + +type ALetDecRHS = LetDecRHS Annotated +type ULetDecRHS = LetDecRHS Unannotated + +data LetDecEnv ann = LetDecEnv + { lde_defns :: OMap Name (LetDecRHS ann) + , lde_types :: OMap Name DType -- type signatures + , lde_infix :: OMap Name Fixity -- infix declarations + , lde_proms :: IfAnn ann (OMap Name DType) () -- possibly, promotions + } +type ALetDecEnv = LetDecEnv Annotated +type ULetDecEnv = LetDecEnv Unannotated + +instance Semigroup ULetDecEnv where + LetDecEnv defns1 types1 infx1 _ <> LetDecEnv defns2 types2 infx2 _ = + LetDecEnv (defns1 <> defns2) (types1 <> types2) (infx1 <> infx2) () + +instance Monoid ULetDecEnv where + mempty = LetDecEnv OMap.empty OMap.empty OMap.empty () + +valueBinding :: Name -> ULetDecRHS -> ULetDecEnv +valueBinding n v = emptyLetDecEnv { lde_defns = OMap.singleton n v } + +typeBinding :: Name -> DType -> ULetDecEnv +typeBinding n t = emptyLetDecEnv { lde_types = OMap.singleton n t } + +infixDecl :: Fixity -> Name -> ULetDecEnv +infixDecl f n = emptyLetDecEnv { lde_infix = OMap.singleton n f } + +emptyLetDecEnv :: ULetDecEnv +emptyLetDecEnv = mempty + +buildLetDecEnv :: Quasi q => [DLetDec] -> q ULetDecEnv +buildLetDecEnv = go emptyLetDecEnv + where + go acc [] = return acc + go acc (DFunD name clauses : rest) = + go (valueBinding name (UFunction clauses) <> acc) rest + go acc (DValD (DVarP name) exp : rest) = + go (valueBinding name (UValue exp) <> acc) rest + go acc (dec@(DValD {}) : rest) = do + flattened <- flattenDValD dec + go acc (flattened ++ rest) + go acc (DSigD name ty : rest) = + go (typeBinding name ty <> acc) rest + go acc (DInfixD f n : rest) = + go (infixDecl f n <> acc) rest + go acc (DPragmaD{} : rest) = go acc rest + +-- See Note [DerivedDecl] +data DerivedDecl (cls :: Type -> Constraint) = DerivedDecl + { ded_mb_cxt :: Maybe DCxt + , ded_type :: DType + , ded_type_tycon :: Name + , ded_decl :: DataDecl + } + +type DerivedEqDecl = DerivedDecl Eq +type DerivedOrdDecl = DerivedDecl Ord +type DerivedShowDecl = DerivedDecl Show + +{- Note [DerivedDecl] +~~~~~~~~~~~~~~~~~~~~~ +Most derived instances are wholly handled in +Data.Singletons.TH.Partition.partitionDecs. There are two notable exceptions to +this rule, however, that are partially handled outside of partitionDecs: +Eq and Show instances. For these instances, we use a DerivedDecl data type to +encode just enough information to recreate the derived instance: + +1. Just the instance context, if it's standalone-derived, or Nothing if it's in + a deriving clause (ded_mb_cxt) +2. The datatype, applied to some number of type arguments, as in the + instance declaration (ded_type) +3. The datatype name (ded_type_tycon), cached for convenience +4. The datatype's constructors (ded_cons) + +Why are these instances handled outside of partitionDecs? + +* Deriving Eq in singletons-th not only derives PEq/SEq instances, but it also + derives SDecide, Eq, TestEquality, and TestCoercion instances. +* Deriving Ord in singletons-th not only derives POrd/SOrd instances, but it also + derives Ord instances for the singleton types themselves. +* Deriving Show in singletons-th not only derives PShow/SShow instances, but it + also derives Show instances for the singleton types themselves. + +To make this work, we let partitionDecs handle the P{Eq,Show} and S{Eq,Show} +instances, but we also stick the relevant info into a DerivedDecl value for +later use in Data.Singletons.TH.Single, where we additionally generate +SDecide, Eq, TestEquality, TestCoercion and Show instances for singleton types. +-} diff --git a/src/Data/Singletons/TH/Util.hs b/src/Data/Singletons/TH/Util.hs --- a/src/Data/Singletons/TH/Util.hs +++ b/src/Data/Singletons/TH/Util.hs @@ -1,577 +1,697 @@ -{-# LANGUAGE LambdaCase #-} - -{- Data/Singletons/TH/Util.hs - -(c) Richard Eisenberg 2013 -rae@cs.brynmawr.edu - -This file contains helper functions internal to the singletons-th package. -Users of the package should not need to consult this file. --} - -module Data.Singletons.TH.Util where - -import Prelude hiding ( exp, foldl, concat, mapM, any, pred ) -import Language.Haskell.TH ( pprint ) -import Language.Haskell.TH.Syntax hiding ( lift ) -import Language.Haskell.TH.Desugar -import Data.Char -import Control.Monad ( liftM, unless, when ) -import Control.Monad.Except ( ExceptT, runExceptT, MonadError(..) ) -import Control.Monad.IO.Class ( MonadIO ) -import Control.Monad.Reader ( MonadReader(..), Reader, ReaderT(..) ) -import Control.Monad.Trans ( MonadTrans ) -import Control.Monad.Writer ( MonadWriter(..), WriterT(..), execWriterT ) -import qualified Data.Map as Map -import Data.Map ( Map ) -import Data.Bifunctor (second) -import Data.Foldable -import Data.Functor.Identity -import Data.Traversable -import Data.Generics -import Data.Maybe - --- like reportWarning, but generalized to any Quasi -qReportWarning :: Quasi q => String -> q () -qReportWarning = qReport False - --- like reportError, but generalized to any Quasi -qReportError :: Quasi q => String -> q () -qReportError = qReport True - --- | Generate a new Unique -qNewUnique :: DsMonad q => q Uniq -qNewUnique = do - Name _ flav <- qNewName "x" - case flav of - NameU n -> return n - _ -> error "Internal error: `qNewName` didn't return a NameU" - -checkForRep :: Quasi q => [Name] -> q () -checkForRep names = - when (any ((== "Rep") . nameBase) names) - (fail $ "A data type named <> 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 <> is a special case.\n" ++ + "Promoting it will not work as expected.\n" ++ + "Please choose another name for your data type.") + +checkForRepInDecls :: Quasi q => [DDec] -> q () +checkForRepInDecls decls = + checkForRep (allNamesIn decls) + +tysOfConFields :: DConFields -> [DType] +tysOfConFields (DNormalC _ stys) = map snd stys +tysOfConFields (DRecC vstys) = map (\(_,_,ty) -> ty) vstys + +recSelsOfConFields :: DConFields -> [Name] +recSelsOfConFields DNormalC{} = [] +recSelsOfConFields (DRecC vstys) = map (\(n,_,_) -> n) vstys + +-- Extract a data constructor's name and the number of arguments it accepts. +extractNameArgs :: DCon -> (Name, Int) +extractNameArgs (DCon _ _ n fields _) = (n, length (tysOfConFields fields)) + +-- Extract a data constructor's name. +extractName :: DCon -> Name +extractName (DCon _ _ n _ _) = n + +-- Extract the names of a data constructor's record selectors. +extractRecSelNames :: DCon -> [Name] +extractRecSelNames (DCon _ _ _ fields _) = recSelsOfConFields fields + +-- | is a valid Haskell infix data constructor (i.e., does it begin with a colon?) +isInfixDataCon :: String -> Bool +isInfixDataCon (':':_) = True +isInfixDataCon _ = False + +-- | Is an identifier a legal data constructor name in Haskell? That is, is its +-- first character an uppercase letter (prefix) or a colon (infix)? +isDataConName :: Name -> Bool +isDataConName n = let first = headNameStr (nameBase n) in isUpper first || first == ':' + +-- | Is an identifier uppercase? +-- +-- Note that this will always return 'False' for infix names, since the concept +-- of upper- and lower-case doesn't make sense for non-alphabetic characters. +-- If you want to check if a name is legal as a data constructor, use the +-- 'isDataConName' function. +isUpcase :: Name -> Bool +isUpcase n = let first = headNameStr (nameBase n) in isUpper first + +-- Make an identifier uppercase. If the identifier is infix, this acts as the +-- identity function. +upcase :: Name -> Name +upcase = mkName . toUpcaseStr noPrefix + +-- make an identifier uppercase and return it as a String +toUpcaseStr :: (String, String) -- (alpha, symb) prefixes to prepend + -> Name -> String +toUpcaseStr (alpha, symb) n + | isHsLetter first + = upcase_alpha + + | otherwise + = upcase_symb + + where + str = nameBase n + first = headNameStr str + + upcase_alpha = alpha ++ (toUpper first) : tailNameStr str + upcase_symb = symb ++ str + +noPrefix :: (String, String) +noPrefix = ("", "") + +-- Put an uppercase prefix on a constructor name. Takes two prefixes: +-- one for identifiers and one for symbols. +-- +-- This is different from 'prefixName' in that infix constructor names always +-- start with a colon, so we must insert the prefix after the colon in order +-- for the new name to be syntactically valid. +prefixConName :: String -> String -> Name -> Name +prefixConName pre tyPre n = case (nameBase n) of + (':' : rest) -> mkName (':' : tyPre ++ rest) + alpha -> mkName (pre ++ alpha) + +-- Put a prefix on a name. Takes two prefixes: one for identifiers +-- and one for symbols. +prefixName :: String -> String -> Name -> Name +prefixName pre tyPre n = + let str = nameBase n + first = headNameStr str in + if isHsLetter first + then mkName (pre ++ str) + else mkName (tyPre ++ str) + +-- Put a suffix on a name. Takes two suffixes: one for identifiers +-- and one for symbols. +suffixName :: String -> String -> Name -> Name +suffixName ident symb n = + let str = nameBase n + first = headNameStr str in + if isHsLetter first + then mkName (str ++ ident) + else mkName (str ++ symb) + +-- Return the first character in a Name's string (i.e., nameBase). +-- Precondition: the string is non-empty. +headNameStr :: String -> Char +headNameStr str = + case str of + (c:_) -> c + [] -> error "headNameStr: Expected non-empty string" + +-- Drop the first character in a Name's string (i.e., nameBase). +-- Precondition: the string is non-empty. +tailNameStr :: String -> String +tailNameStr str = + case str of + (_:cs) -> cs + [] -> error "tailNameStr: Expected non-empty string" + +-- convert a number into both alphanumeric and symoblic forms +uniquePrefixes :: String -- alphanumeric prefix + -> String -- symbolic prefix + -> Uniq + -> (String, String) -- (alphanum, symbolic) +uniquePrefixes alpha symb n = (alpha ++ n_str, symb ++ convert n_str) + where + n_str = show n + + convert [] = [] + convert (d : ds) = + let d' = case d of + '0' -> '!' + '1' -> '#' + '2' -> '$' + '3' -> '%' + '4' -> '&' + '5' -> '*' + '6' -> '+' + '7' -> '.' + '8' -> '/' + '9' -> '>' + _ -> error "non-digit in show #" + in d' : convert ds + +-- extract the kind from a TyVarBndr +extractTvbKind :: DTyVarBndr flag -> Maybe DKind +extractTvbKind (DPlainTV _ _) = Nothing +extractTvbKind (DKindedTV _ _ k) = Just k + +-- extract the name from a TyVarBndr. +extractTvbName :: DTyVarBndr flag -> Name +extractTvbName (DPlainTV n _) = n +extractTvbName (DKindedTV n _ _) = n + +-- extract the flag from a TyVarBndr. +extractTvbFlag :: DTyVarBndr flag -> flag +extractTvbFlag (DPlainTV _ f) = f +extractTvbFlag (DKindedTV _ f _) = f + +-- Map over the 'Name' of a 'DTyVarBndr'. +mapDTVName :: (Name -> Name) -> DTyVarBndr flag -> DTyVarBndr flag +mapDTVName f (DPlainTV name flag) = DPlainTV (f name) flag +mapDTVName f (DKindedTV name flag kind) = DKindedTV (f name) flag kind + +-- Map over the 'DKind' of a 'DTyVarBndr'. +mapDTVKind :: (DKind -> DKind) -> DTyVarBndr flag -> DTyVarBndr flag +mapDTVKind _ tvb@(DPlainTV{}) = tvb +mapDTVKind f (DKindedTV name flag kind) = DKindedTV name flag (f kind) + +tvbToType :: DTyVarBndr flag -> DType +tvbToType = DVarT . extractTvbName + +-- If a type variable binder lacks an explicit kind, pick a default kind of +-- Type. Otherwise, leave the binder alone. +defaultTvbToTypeKind :: DTyVarBndr flag -> DTyVarBndr flag +defaultTvbToTypeKind (DPlainTV tvname f) = DKindedTV tvname f $ DConT typeKindName +defaultTvbToTypeKind tvb = tvb + +-- If @Nothing@, return @Type@. If @Just k@, return @k@. +defaultMaybeToTypeKind :: Maybe DKind -> DKind +defaultMaybeToTypeKind (Just k) = k +defaultMaybeToTypeKind Nothing = DConT typeKindName + +inferMaybeKindTV :: Name -> Maybe DKind -> DTyVarBndrUnit +inferMaybeKindTV n Nothing = DPlainTV n () +inferMaybeKindTV n (Just k) = DKindedTV n () k + +resultSigToMaybeKind :: DFamilyResultSig -> Maybe DKind +resultSigToMaybeKind DNoSig = Nothing +resultSigToMaybeKind (DKindSig k) = Just k +resultSigToMaybeKind (DTyVarSig DPlainTV{}) = Nothing +resultSigToMaybeKind (DTyVarSig (DKindedTV _ _ k)) = Just k + +maybeKindToResultSig :: Maybe DKind -> DFamilyResultSig +maybeKindToResultSig = maybe DNoSig DKindSig + +maybeSigT :: DType -> Maybe DKind -> DType +maybeSigT ty Nothing = ty +maybeSigT ty (Just ki) = ty `DSigT` ki + +-- Reconstruct a vanilla function type from its individual type variable +-- binders, constraints, argument types, and result type. (See +-- Note [Vanilla-type validity checking during promotion] in +-- Data.Singletons.TH.Promote.Type for what "vanilla" means.) +ravelVanillaDType :: [DTyVarBndrSpec] -> DCxt -> [DType] -> DType -> DType +ravelVanillaDType tvbs ctxt args res = + ifNonEmpty tvbs (DForallT . DForallInvis) $ + ifNonEmpty ctxt DConstrainedT $ + go args + where + ifNonEmpty :: [a] -> ([a] -> b -> b) -> b -> b + ifNonEmpty [] _ z = z + ifNonEmpty l f z = f l z + + go :: [DType] -> DType + go [] = res + go (h:t) = DAppT (DAppT DArrowT h) (go t) + +-- Decompose a vanilla function type into its type variables, its context, its +-- argument types, and its result type. (See +-- Note [Vanilla-type validity checking during promotion] in +-- Data.Singletons.TH.Promote.Type for what "vanilla" means.) +-- If a non-vanilla construct is encountered while decomposing the function +-- type, an error is thrown monadically. +-- +-- This should be contrasted with the 'unravelDType' function from +-- @th-desugar@, which supports the full gamut of function types. @singletons-th@ +-- only supports a subset of these types, which is why this function is used +-- to decompose them instead. +unravelVanillaDType :: forall m. MonadFail m + => DType -> m ([DTyVarBndrSpec], DCxt, [DType], DType) +unravelVanillaDType ty = + case unravelVanillaDType_either ty of + Left err -> fail err + Right payload -> pure payload + +-- Ensures that a 'DType' is a vanilla type. (See +-- Note [Vanilla-type validity checking during promotion] in +-- Data.Singletons.TH.Promote.Type for what "vanilla" means.) +-- +-- The only monadic thing that this function can do is 'fail', which it does +-- if a non-vanilla construct is encountered. +checkVanillaDType :: forall m. MonadFail m => DType -> m () +checkVanillaDType ty = + case unravelVanillaDType_either ty of + Left err -> fail err + Right _ -> pure () + +-- The workhorse that powers unravelVanillaDType and checkVanillaDType. +-- Returns @Right payload@ upon success, and @Left error_msg@ upon failure. +unravelVanillaDType_either :: + DType -> Either String ([DTyVarBndrSpec], DCxt, [DType], DType) +unravelVanillaDType_either ty = + runIdentity $ flip runReaderT True $ runExceptT $ runUnravelM $ go_ty ty + where + go_ty :: DType -> UnravelM ([DTyVarBndrSpec], DCxt, [DType], DType) + go_ty typ = do + let (args1, res) = unravelDType typ + (args2, tvbs) <- take_tvbs args1 + (args3, ctxt) <- take_ctxt args2 + anons <- take_anons args3 + pure (tvbs, ctxt, anons, res) + + -- Process a type in a higher-order position (e.g., the @forall a. a -> a@ in + -- @(forall a. a -> a) -> b -> b@). This is only done to check for the + -- presence of higher-rank foralls or constraints, which are not permitted + -- in vanilla types. + go_higher_order_ty :: DType -> UnravelM () + go_higher_order_ty typ = () <$ local (const False) (go_ty typ) + + take_tvbs :: DFunArgs -> UnravelM (DFunArgs, [DTyVarBndrSpec]) + take_tvbs (DFAForalls (DForallInvis tvbs) args) = do + rank_1 <- ask + unless rank_1 $ fail_forall "higher-rank" + _ <- traverse_ (traverse_ go_higher_order_ty . extractTvbKind) tvbs + (args', tvbs') <- take_tvbs args + pure (args', tvbs ++ tvbs') + take_tvbs (DFAForalls DForallVis{} _) = fail_vdq + take_tvbs args = pure (args, []) + + take_ctxt :: DFunArgs -> UnravelM (DFunArgs, DCxt) + take_ctxt (DFACxt ctxt args) = do + rank_1 <- ask + unless rank_1 $ fail_ctxt "higher-rank" + traverse_ go_higher_order_ty ctxt + (args', ctxt') <- take_ctxt args + pure (args', ctxt ++ ctxt') + take_ctxt (DFAForalls tele _) = + case tele of + DForallInvis{} -> fail_forall "nested" + DForallVis{} -> fail_vdq + take_ctxt args = pure (args, []) + + take_anons :: DFunArgs -> UnravelM [DType] + take_anons (DFAAnon anon args) = do + go_higher_order_ty anon + anons <- take_anons args + pure (anon:anons) + take_anons (DFAForalls tele _) = + case tele of + DForallInvis{} -> fail_forall "nested" + DForallVis{} -> fail_vdq + take_anons (DFACxt _ _) = fail_ctxt "nested" + take_anons DFANil = pure [] + + failWith :: MonadError String m => String -> m a + failWith thing = throwError $ unlines + [ "`singletons-th` does not support " ++ thing + , "In the type: " ++ pprint (sweeten ty) + ] + + fail_forall :: MonadError String m => String -> m a + fail_forall sort = failWith $ sort ++ " `forall`s" + + fail_vdq :: MonadError String m => m a + fail_vdq = failWith "visible dependent quantification" + + fail_ctxt :: MonadError String m => String -> m a + fail_ctxt sort = failWith $ sort ++ " contexts" + +-- The monad that powers the internals of unravelVanillaDType_either. +-- +-- * ExceptT String: records the error message upon failure. +-- +-- * Reader Bool: True if we are in a rank-1 position in a type, False otherwise +newtype UnravelM a = UnravelM { runUnravelM :: ExceptT String (Reader Bool) a } + deriving (Functor, Applicative, Monad, MonadError String, MonadReader Bool) + +-- count the number of arguments in a type +countArgs :: DType -> Int +countArgs ty = length $ filterDVisFunArgs args + where (args, _) = unravelDType ty + +-- Collect the invisible type variable binders from a sequence of DFunArgs. +filterInvisTvbArgs :: DFunArgs -> [DTyVarBndrSpec] +filterInvisTvbArgs DFANil = [] +filterInvisTvbArgs (DFACxt _ args) = filterInvisTvbArgs args +filterInvisTvbArgs (DFAAnon _ args) = filterInvisTvbArgs args +filterInvisTvbArgs (DFAForalls tele args) = + let res = filterInvisTvbArgs args in + case tele of + DForallVis _ -> res + DForallInvis tvbs' -> tvbs' ++ res + +-- Change all unique Names with a NameU or NameL namespace to non-unique Names +-- by performing a syb-based traversal. See Note [Pitfalls of NameU/NameL] for +-- why this is useful. +noExactTyVars :: Data a => a -> a +noExactTyVars = everywhere go + where + go :: Data a => a -> a + go = mkT (fix_tvb @Specificity) + `extT` fix_tvb @() + `extT` fix_tvb @BndrVis + `extT` fix_ty + `extT` fix_inj_ann + + fix_tvb :: Typeable flag => DTyVarBndr flag -> DTyVarBndr flag + fix_tvb (DPlainTV n f) = DPlainTV (noExactName n) f + fix_tvb (DKindedTV n f k) = DKindedTV (noExactName n) f k + + fix_ty (DVarT n) = DVarT (noExactName n) + fix_ty ty = ty + + fix_inj_ann (InjectivityAnn lhs rhs) + = InjectivityAnn (noExactName lhs) (map noExactName rhs) + +-- Changes a unique Name with a NameU or NameL namespace to a non-unique Name. +-- See Note [Pitfalls of NameU/NameL] for why this is useful. +noExactName :: Name -> Name +noExactName n@(Name (OccName occ) ns) = + case ns of + NameU unique -> mk_name unique + NameL unique -> mk_name unique + _ -> n + where + mk_name unique = mkName (occ ++ show unique) + +{- +Note [Pitfalls of NameU/NameL] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Most of the Names used in singletons-th come from reified or quoted Template +Haskell definitions. Because these definitions have passed through GHC's +renamer, they have unique Names with unique a NameU/NameL namespace. For the +sake of convenience, we often reuse these Names in the definitions that we +generate. For example, if singletons-th is given a declaration +`f :: forall a_123. a_123 -> a_123`, it will produce a standalone kind signature +`type F :: forall a_123. a_123 -> a_123`, reusing the unique Name `a_123`. + +While reusing unique Names is convenient, it does have a downside. In +particular, GHC can sometimes get confused when the same unique Name is reused +in distinct type variable scopes. In the best case, this can lead to confusing +type errors, but in the worst case, it can cause GHC to panic, as seen in the +following issues (all of which were first observed in singletons-th): + +* https://gitlab.haskell.org/ghc/ghc/-/issues/11812 +* https://gitlab.haskell.org/ghc/ghc/-/issues/17537 +* https://gitlab.haskell.org/ghc/ghc/-/issues/19743 + +This is pretty terrible. Arguably, we are abusing Template Haskell here, since +GHC likely assumes the invariant that each unique Name only has a single +binding site. On the other hand, rearchitecting singletons-th to uphold this +invariant would require a substantial amount of work. + +A far easier solution is to identify any problematic areas where unique Names +are reused and work around the issue by changing unique Names to non-unique +Names. The issues above all have a common theme: they arise when unique Names +are reused in the type variable binders of a data type or type family +declaration. For instance, when promoting a function like this: + + f :: forall a_123. a_123 -> a_123 + f x_456 = g + where + g = x_456 + +We must promote `f` and `g` to something like this: + + type F :: forall a_123. a_123 -> a_123 + type family F (arg :: a_123) :: a_123 where + F x_456 = G x_456 + + type family LetG x_456 where + LetG x_456 = x_456 + +This looks sensible enough. But note that we are reusing the same unique Name +`x_456` in three different scopes: once in the equation for `F`, once in the +the equation for `G`, and once more in the type variable binder in +`type family LetG x_456`. The last of these scopes in particular is enough to +confuse GHC in some situations and trigger GHC#11812. + +Our workaround is to apply the `noExactName` function to such names, which +converts any Names with NameU/NameL namespaces into non-unique Names with +longer OccNames. For instance, `noExactName x_456` will return a non-unique +Name with the OccName `x456`. We use `noExactName` when generating `LetG` so +that it will instead be: + + type family LetG x456 where + LetG x_456 = x_456 + +Here, `x456` is a non-unique Name, and `x_456` is a Unique name. Thankfully, +this is sufficient to work around GHC#11812. There is still some amount of +risk, since we are reusing `x_456` in two different type family equations (one +for `LetG` and one for `F`), but GHC accepts this for now. We prefer to use the +`noExactName` in as few places as possible, as using longer OccNames makes the +Haddocks harder to read, so we will continue to reuse unique Names unless GHC +forces us to behave differently. + +In addition to the type family example above, we also make use of `noExactName` +(as well as its cousin, `noExactTyVars`) when generating defunctionalization +symbols, as these also require reusing Unique names in several type family and +data type declarations. See references to this Note in the code for particular +locations where we must apply this workaround. +-} + +substKind :: Map Name DKind -> DKind -> DKind +substKind = substType + +-- | Non–capture-avoiding substitution. (If you want capture-avoiding +-- substitution, use @substTy@ from "Language.Haskell.TH.Desugar.Subst". +substType :: Map Name DType -> DType -> DType +substType subst ty | Map.null subst = ty +substType subst (DForallT tele inner_ty) + = DForallT tele' inner_ty' + where + (subst', tele') = subst_tele subst tele + inner_ty' = substType subst' inner_ty +substType subst (DConstrainedT cxt inner_ty) = + DConstrainedT (map (substType subst) cxt) (substType subst inner_ty) +substType subst (DAppT ty1 ty2) = substType subst ty1 `DAppT` substType subst ty2 +substType subst (DAppKindT ty ki) = substType subst ty `DAppKindT` substType subst ki +substType subst (DSigT ty ki) = substType subst ty `DSigT` substType subst ki +substType subst (DVarT n) = + case Map.lookup n subst of + Just ki -> ki + Nothing -> DVarT n +substType _ ty@(DConT {}) = ty +substType _ ty@(DArrowT) = ty +substType _ ty@(DLitT {}) = ty +substType _ ty@DWildCardT = ty + +subst_tele :: Map Name DKind -> DForallTelescope -> (Map Name DKind, DForallTelescope) +subst_tele s (DForallInvis tvbs) = second DForallInvis $ substTvbs s tvbs +subst_tele s (DForallVis tvbs) = second DForallVis $ substTvbs s tvbs + +substTvbs :: Map Name DKind -> [DTyVarBndr flag] -> (Map Name DKind, [DTyVarBndr flag]) +substTvbs = mapAccumL substTvb + +substTvb :: Map Name DKind -> DTyVarBndr flag -> (Map Name DKind, DTyVarBndr flag) +substTvb s tvb@(DPlainTV n _) = (Map.delete n s, tvb) +substTvb s (DKindedTV n f k) = (Map.delete n s, DKindedTV n f (substKind s k)) + +substFamilyResultSig :: Map Name DKind -> DFamilyResultSig -> (Map Name DKind, DFamilyResultSig) +substFamilyResultSig s frs@DNoSig = (s, frs) +substFamilyResultSig s (DKindSig k) = (s, DKindSig (substKind s k)) +substFamilyResultSig s (DTyVarSig tvb) = let (s', tvb') = substTvb s tvb in + (s', DTyVarSig tvb') + +dropTvbKind :: DTyVarBndr flag -> DTyVarBndr flag +dropTvbKind tvb@(DPlainTV {}) = tvb +dropTvbKind (DKindedTV n f _) = DPlainTV n f + +-- apply a type to a list of types +foldType :: DType -> [DType] -> DType +foldType = foldl DAppT + +-- apply a type to a list of type variable binders +foldTypeTvbs :: DType -> [DTyVarBndrVis] -> DType +foldTypeTvbs ty = applyDType ty . map dTyVarBndrVisToDTypeArg + +-- Construct a data type's variable binders, possibly using fresh variables +-- from the data type's kind signature. This function is used when constructing +-- a @DataDecl@ to ensure that it has a number of binders equal in length to the +-- number of visible quantifiers (i.e., the number of function arrows plus the +-- number of visible @forall@–bound variables) in the data type's kind. +buildDataDTvbs :: DsMonad q => [DTyVarBndrVis] -> Maybe DKind -> q [DTyVarBndrVis] +buildDataDTvbs tvbs mk = do + extra_tvbs <- mkExtraDKindBinders $ fromMaybe (DConT typeKindName) mk + pure $ tvbs ++ extra_tvbs + +-- apply an expression to a list of expressions +foldExp :: DExp -> [DExp] -> DExp +foldExp = foldl DAppE + +-- choose the first non-empty list +orIfEmpty :: [a] -> [a] -> [a] +orIfEmpty [] x = x +orIfEmpty x _ = x + +-- build a pattern match over several expressions, each with only one pattern +multiCase :: [DExp] -> [DPat] -> DExp -> DExp +multiCase [] [] body = body +multiCase scruts pats body = + DCaseE (mkTupleDExp scruts) [DMatch (mkTupleDPat pats) body] + +-- a monad transformer for writing a monoid alongside returning a Q +newtype QWithAux m q a = QWA { runQWA :: WriterT m q a } + deriving ( Functor, Applicative, Monad, MonadTrans + , MonadWriter m, MonadReader r + , MonadFail, MonadIO, Quasi, DsMonad ) + +-- run a computation with an auxiliary monoid, discarding the monoid result +evalWithoutAux :: Quasi q => QWithAux m q a -> q a +evalWithoutAux = liftM fst . runWriterT . runQWA + +-- run a computation with an auxiliary monoid, returning only the monoid result +evalForAux :: Quasi q => QWithAux m q a -> q m +evalForAux = execWriterT . runQWA + +-- run a computation with an auxiliary monoid, return both the result +-- of the computation and the monoid result +evalForPair :: QWithAux m q a -> q (a, m) +evalForPair = runWriterT . runQWA + +-- in a computation with an auxiliary map, add a binding to the map +addBinding :: (Quasi q, Ord k) => k -> v -> QWithAux (Map.Map k v) q () +addBinding k v = tell (Map.singleton k v) + +-- in a computation with an auxiliar list, add an element to the list +addElement :: Quasi q => elt -> QWithAux [elt] q () +addElement elt = tell [elt] + +-- | Call 'lookupTypeNameWithLocals' first to ensure we have a 'Name' in the +-- type namespace, then call 'dsReify'. + +-- See also Note [Using dsReifyTypeNameInfo when promoting instances] +-- in Data.Singletons.TH.Promote. +dsReifyTypeNameInfo :: DsMonad q => Name -> q (Maybe DInfo) +dsReifyTypeNameInfo ty_name = do + mb_name <- lookupTypeNameWithLocals (nameBase ty_name) + case mb_name of + Just n -> dsReify n + Nothing -> pure Nothing + +-- lift concatMap into a monad +-- could this be more efficient? +concatMapM :: (Monad monad, Monoid monoid, Traversable t) + => (a -> monad monoid) -> t a -> monad monoid +concatMapM fn list = do + bss <- mapM fn list + return $ fold bss + +-- like GHC's +mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b] +mapMaybeM _ [] = return [] +mapMaybeM f (x:xs) = do + y <- f x + ys <- mapMaybeM f xs + return $ case y of + Nothing -> ys + Just z -> z : ys + +-- make a one-element list +listify :: a -> [a] +listify = (:[]) + +fstOf3 :: (a,b,c) -> a +fstOf3 (a,_,_) = a + +liftFst :: (a -> b) -> (a, c) -> (b, c) +liftFst f (a, c) = (f a, c) + +liftSnd :: (a -> b) -> (c, a) -> (c, b) +liftSnd f (c, a) = (c, f a) + +snocView :: [a] -> ([a], a) +snocView [] = error "snocView nil" +snocView [x] = ([], x) +snocView (x : xs) = liftFst (x:) (snocView xs) + +partitionWith :: (a -> Either b c) -> [a] -> ([b], [c]) +partitionWith f = go [] [] + where go bs cs [] = (reverse bs, reverse cs) + go bs cs (a:as) = + case f a of + Left b -> go (b:bs) cs as + Right c -> go bs (c:cs) as + +partitionWithM :: Monad m => (a -> m (Either b c)) -> [a] -> m ([b], [c]) +partitionWithM f = go [] [] + where go bs cs [] = return (reverse bs, reverse cs) + go bs cs (a:as) = do + fa <- f a + case fa of + Left b -> go (b:bs) cs as + Right c -> go bs (c:cs) as + +partitionLetDecs :: [DDec] -> ([DLetDec], [DDec]) +partitionLetDecs = partitionWith (\case DLetDec ld -> Left ld + dec -> Right dec) + +{-# INLINEABLE zipWith3M #-} +zipWith3M :: Monad m => (a -> b -> m c) -> [a] -> [b] -> m [c] +zipWith3M f (a:as) (b:bs) = (:) <$> f a b <*> zipWith3M f as bs +zipWith3M _ _ _ = return [] + +mapAndUnzip3M :: Monad m => (a -> m (b,c,d)) -> [a] -> m ([b],[c],[d]) +mapAndUnzip3M _ [] = return ([],[],[]) +mapAndUnzip3M f (x:xs) = do + (r1, r2, r3) <- f x + (rs1, rs2, rs3) <- mapAndUnzip3M f xs + return (r1:rs1, r2:rs2, r3:rs3) + +-- is it a letter or underscore? +isHsLetter :: Char -> Bool +isHsLetter c = isLetter c || c == '_'