singletons-th (empty) → 3.0
raw patch · 34 files changed
+8285/−0 lines, 34 filesdep +basedep +containersdep +ghc-boot-thsetup-changed
Dependencies added: base, containers, ghc-boot-th, mtl, singletons, syb, template-haskell, th-desugar, th-orphans, transformers
Files
- CHANGES.md +130/−0
- LICENSE +27/−0
- README.md +26/−0
- Setup.hs +2/−0
- singletons-th.cabal +104/−0
- src/Data/Singletons/TH.hs +124/−0
- src/Data/Singletons/TH/CustomStar.hs +158/−0
- src/Data/Singletons/TH/Deriving/Bounded.hs +59/−0
- src/Data/Singletons/TH/Deriving/Enum.hs +60/−0
- src/Data/Singletons/TH/Deriving/Eq.hs +62/−0
- src/Data/Singletons/TH/Deriving/Foldable.hs +99/−0
- src/Data/Singletons/TH/Deriving/Functor.hs +95/−0
- src/Data/Singletons/TH/Deriving/Infer.hs +162/−0
- src/Data/Singletons/TH/Deriving/Ord.hs +71/−0
- src/Data/Singletons/TH/Deriving/Show.hs +165/−0
- src/Data/Singletons/TH/Deriving/Traversable.hs +69/−0
- src/Data/Singletons/TH/Deriving/Util.hs +300/−0
- src/Data/Singletons/TH/Names.hs +254/−0
- src/Data/Singletons/TH/Options.hs +343/−0
- src/Data/Singletons/TH/Partition.hs +329/−0
- src/Data/Singletons/TH/Promote.hs +1163/−0
- src/Data/Singletons/TH/Promote/Defun.hs +821/−0
- src/Data/Singletons/TH/Promote/Monad.hs +195/−0
- src/Data/Singletons/TH/Promote/Type.hs +112/−0
- src/Data/Singletons/TH/Single.hs +1151/−0
- src/Data/Singletons/TH/Single/Data.hs +378/−0
- src/Data/Singletons/TH/Single/Decide.hs +109/−0
- src/Data/Singletons/TH/Single/Defun.hs +199/−0
- src/Data/Singletons/TH/Single/Fixity.hs +171/−0
- src/Data/Singletons/TH/Single/Monad.hs +195/−0
- src/Data/Singletons/TH/Single/Type.hs +312/−0
- src/Data/Singletons/TH/SuppressUnusedWarnings.hs +21/−0
- src/Data/Singletons/TH/Syntax.hs +240/−0
- src/Data/Singletons/TH/Util.hs +579/−0
+ CHANGES.md view
@@ -0,0 +1,130 @@+Changelog for the `singletons-th` project+=========================================++3.0 [2021.03.12]+----------------+* The `singletons` library has been split into three libraries:++ * The new `singletons` library is now a minimal library that only provides+ `Data.Singletons`, `Data.Singletons.Decide`, `Data.Singletons.Sigma`, and+ `Data.Singletons.ShowSing` (if compiled with GHC 8.6 or later).+ `singletons` now supports building GHCs back to GHC 8.0, as well as GHCJS.+ * The `singletons-th` library defines Template Haskell functionality for+ promoting and singling term-level definitions, but but nothing else. This+ library continues to require the latest stable release of GHC.+ * The `singletons-base` library defines promoted and singled versions of+ definitions from the `base` library, including the `Prelude`. This library+ continues to require the latest stable release of GHC.++ Consult the changelogs for `singletons` and `singletons-base` for changes+ specific to those libraries. For more information on this split, see the+ [relevant GitHub discussion](https://github.com/goldfirere/singletons/issues/420).+* Require building with GHC 9.0.+* `Data.Singletons.CustomStar` and `Data.Singletons.SuppressUnusedWarnings`+ have been renamed to `Data.Singletons.TH.CustomStar` and+ `Data.Singletons.SuppressUnusedWarnings`, respectively, to give every module+ in `singletons-th` a consistent module prefix.+* Due to the `singletons` package split, the `singletons-th` modules+ `Data.Singletons.TH` and `Data.Singletons.TH.CustomStar` (formerly known as+ `Data.Singletons.CustomStar`) no longer re-export any definitions from the+ `singletons-base` module `Prelude.Singletons` (formerly known as+ `Data.Singletons.Prelude`). The `singletons-base` library now provides+ versions of these modules—`Data.Singletons.Base.CustomStar` and+ `Data.Singletons.Base.TH`, respectively—that do re-export definitions+ from `Prelude.Singletons`.+* "Fully saturated" defunctionalization symbols (e.g., `IdSym1`) are now+ defined as type families instead of type synonyms. This has two notable+ benefits:++ * Fully saturated defunctionalization symbols can now be given standalone+ kind signatures, which ensures that the order of kind variables is the+ same as the user originally declared them.+ * This fixes a minor regression in `singletons-2.7` in which the quality+ of `:kind!` output in GHCi would become worse when using promoted type+ families generated by Template Haskell.++ Under certain circumstances, this can be a breaking change:++ * Since more TH-generated promoted functions now have type families on+ their right-hand sides, some programs will now require+ `UndecidableInstances` where they didn't before.+ * Certain definitions that made use of overlapping patterns, such as+ `natMinus` below, will no longer typecheck:++ ```hs+ $(singletons [d|+ data Nat = Z | S Nat++ natMinus :: Nat -> Nat -> Nat+ natMinus Z _ = Z+ natMinus (S a) (S b) = natMinus a b+ natMinus a Z = a+ |])+ ```++ This can be worked around by avoiding the use of overlapping patterns.+ In the case of `natMinus`, this amounts to changing the third equation+ to match on its first argument:++ ```hs+ $(singletons [d|+ natMinus :: Nat -> Nat -> Nat+ natMinus Z _ = Z+ natMinus (S a) (S b) = natMinus a b+ natMinus a@(S _) Z = a+ |])+ ```+* The specification for how `singletons` deals with record selectors has been+ simplified. Previously, `singletons` would try to avoid promoting so-called+ "naughty" selectors (those whose types mention existential type variables+ that do not appear in the constructor's return type) to top-level functions.+ Determing if a selector is naughty is quite challenging in practice, as+ determining if a type variable is existential or not in the context of+ Template Haskell is difficult in the general case. As a result, `singletons`+ now adopts the dumb-but-predictable approach of always promoting record+ selectors to top-level functions, naughty or not.++ This means that attempting to promote code with a naughty record selector,+ like in the example below, will no longer work:++ ```hs+ $(promote [d|+ data Some :: (Type -> Type) -> Type where+ MkSome :: { getSome :: f a } -> Some f+ -- getSome is naughty due to mentioning the type variable `a`+ |])+ ```++ Please open an issue if you find this restriction burdensome in practice.+* The `singEqInstanceOnly` and `singEqInstancesOnly` functions, which generate+ `SEq` (but not `PEq`) instances, have been removed. There is not much point+ in keeping these functions around now that `PEq` now longer has a special+ default implementation. Use `singEqInstance{s}` instead.+* The Template Haskell machinery will no longer promote `TypeRep` to `Type`,+ as this special case never worked properly in the first place.+* The Template Haskell machinery will now preserve strict fields in data types+ when generating their singled counterparts.+* Introduce a new `promotedDataTypeOrConName` option to+ `Data.Singletons.TH.Options`. Overriding this option can be useful in+ situations where one wishes to promote types such as `Nat`, `Symbol`, or+ data types built on top of them. See the+ "Arrows, `Nat`, `Symbol`, and literals" section of the `README` for more+ information.+* Define a `Quote` instance for `OptionsM`. A notable benefit of this instance+ is that it avoids the need to explicitly `lift` TH quotes into `OptionsM`.+ Before, you would have to do this:++ ```hs+ import Control.Monad.Trans.Class (lift)++ withOptions defaultOptions+ $ singletons+ $ lift [d| data T = MkT |]+ ```++ But now, it suffices to simply do this:++ ```hs+ withOptions defaultOptions+ $ singletons [d| data T = MkT |]+ ```
+ LICENSE view
@@ -0,0 +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.
+ README.md view
@@ -0,0 +1,26 @@+`singletons-th`+===============++[](http://hackage.haskell.org/package/singletons-th)++`singletons-th` defines Template Haskell functionality that allows+_promotion_ of term-level functions to type-level equivalents and+_singling_ functions to dependently typed equivalents. This library was+originally presented in+[_Dependently Typed Programming with Singletons_](https://cs.brynmawr.edu/~rae/papers/2012/singletons/paper.pdf),+published at the Haskell Symposium, 2012. See also+[the paper published at Haskell Symposium, 2014](https://cs.brynmawr.edu/~rae/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.0). For more information,+consult the `singletons`+[`README`](https://github.com/goldfirere/singletons/blob/master/README.md).++You may also be interested in the following related libraries:++* The `singletons` library is a small, foundational library that defines+ basic singleton-related types and definitions.+* The `singletons-base` library uses `singletons-th` to define promoted and+ singled functions from the `base` library, including the `Prelude`.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ singletons-th.cabal view
@@ -0,0 +1,104 @@+name: singletons-th+version: 3.0+cabal-version: 1.24+synopsis: A framework for generating singleton types+homepage: http://www.github.com/goldfirere/singletons+category: Dependent Types+author: Richard Eisenberg <rae@cs.brynmawr.edu>, Jan Stolarek <jan.stolarek@p.lodz.pl>+maintainer: Ryan Scott <ryan.gl.scott@gmail.com>+bug-reports: https://github.com/goldfirere/singletons/issues+stability: experimental+tested-with: GHC == 9.0.1+extra-source-files: README.md, CHANGES.md+license: BSD3+license-file: LICENSE+build-type: Simple+description:+ @singletons-th@ defines Template Haskell functionality that allows+ /promotion/ of term-level functions to type-level equivalents and+ /singling/ functions to dependently typed equivalents. This library was+ originally presented in /Dependently Typed Programming with Singletons/,+ published at the Haskell Symposium, 2012.+ (<https://cs.brynmawr.edu/~rae/papers/2012/singletons/paper.pdf>)+ See also the paper published at Haskell Symposium, 2014, which describes+ how promotion works in greater detail:+ <https://cs.brynmawr.edu/~rae/papers/2014/promotion/promotion.pdf>.+ .+ @singletons-th@ generates code that relies on bleeding-edge GHC language+ extensions. As such, @singletons-th@ only supports the latest major version+ of GHC (currently GHC 9.0). For more information,+ consult the @singletons@+ @<https://github.com/goldfirere/singletons/blob/master/README.md README>@.+ .+ You may also be interested in the following related libraries:+ .+ * The @singletons@ library is a small, foundational library that defines+ basic singleton-related types and definitions.+ .+ * The @singletons-base@ library uses @singletons-th@ to define promoted and+ singled functions from the @base@ library, including the "Prelude".++source-repository this+ type: git+ location: https://github.com/goldfirere/singletons.git+ subdir: singletons-th+ tag: v3.0++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.15 && < 4.16,+ containers >= 0.5,+ mtl >= 2.2.1,+ ghc-boot-th,+ singletons == 3.0.*,+ syb >= 0.4,+ template-haskell >= 2.17 && < 2.18,+ th-desugar >= 1.12 && < 1.13,+ th-orphans >= 0.13.11 && < 0.14,+ transformers >= 0.5.2+ default-language: Haskell2010+ other-extensions: TemplateHaskellQuotes+ exposed-modules: Data.Singletons.TH+ Data.Singletons.TH.CustomStar+ Data.Singletons.TH.Options+ Data.Singletons.TH.SuppressUnusedWarnings++ other-modules: Data.Singletons.TH.Deriving.Bounded+ Data.Singletons.TH.Deriving.Enum+ Data.Singletons.TH.Deriving.Eq+ Data.Singletons.TH.Deriving.Foldable+ Data.Singletons.TH.Deriving.Functor+ Data.Singletons.TH.Deriving.Infer+ Data.Singletons.TH.Deriving.Ord+ Data.Singletons.TH.Deriving.Show+ Data.Singletons.TH.Deriving.Traversable+ Data.Singletons.TH.Deriving.Util+ Data.Singletons.TH.Names+ Data.Singletons.TH.Partition+ Data.Singletons.TH.Promote+ Data.Singletons.TH.Promote.Defun+ Data.Singletons.TH.Promote.Monad+ Data.Singletons.TH.Promote.Type+ Data.Singletons.TH.Single+ Data.Singletons.TH.Single.Data+ Data.Singletons.TH.Single.Decide+ Data.Singletons.TH.Single.Defun+ Data.Singletons.TH.Single.Fixity+ Data.Singletons.TH.Single.Monad+ Data.Singletons.TH.Single.Type+ Data.Singletons.TH.Syntax+ Data.Singletons.TH.Util++ -- singletons re-exports+ reexported-modules: Data.Singletons+ , Data.Singletons.Decide+ , Data.Singletons.ShowSing+ , Data.Singletons.Sigma++ ghc-options: -Wall -Wcompat
+ src/Data/Singletons/TH.hs view
@@ -0,0 +1,124 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.Singletons.TH+-- Copyright : (C) 2013 Richard Eisenberg+-- License : BSD-style (see LICENSE)+-- Maintainer : Ryan Scott+-- Stability : experimental+-- Portability : non-portable+--+-- This module contains basic functionality for deriving your own singletons+-- via Template Haskell. Note that this module does not define any singled+-- definitions on its own. For a version of this module that comes pre-equipped+-- with several singled definitions based on the "Prelude", see+-- @Data.Singletons.Base.TH@ from the @singletons-base@ library.+--+----------------------------------------------------------------------------++module Data.Singletons.TH (+ -- * Primary Template Haskell generation functions+ singletons, singletonsOnly, genSingletons,+ promote, promoteOnly, genDefunSymbols, genPromotions,++ -- ** Functions to generate equality instances+ promoteEqInstances, promoteEqInstance,+ singEqInstances, singEqInstance,+ singDecideInstances, singDecideInstance,++ -- ** Functions to generate 'Ord' instances+ promoteOrdInstances, promoteOrdInstance,+ singOrdInstances, singOrdInstance,++ -- ** Functions to generate 'Bounded' instances+ promoteBoundedInstances, promoteBoundedInstance,+ singBoundedInstances, singBoundedInstance,++ -- ** Functions to generate 'Enum' instances+ promoteEnumInstances, promoteEnumInstance,+ singEnumInstances, singEnumInstance,++ -- ** Functions to generate 'Show' instances+ promoteShowInstances, promoteShowInstance,+ singShowInstances, singShowInstance,+ showSingInstances, showSingInstance,++ -- ** Utility functions+ singITyConInstances, singITyConInstance,+ cases, sCases,++ -- * Basic singleton definitions+ module Data.Singletons,++ -- * Auxiliary definitions+ SDecide(..), (:~:)(..), Void, Refuted, Decision(..),++ SuppressUnusedWarnings(..)++ ) where++import Control.Arrow ( first )+import Data.Singletons+import Data.Singletons.Decide+import Data.Singletons.TH.Options+import Data.Singletons.TH.Promote+import Data.Singletons.TH.Single+import Data.Singletons.TH.SuppressUnusedWarnings+import Data.Singletons.TH.Util+import Language.Haskell.TH+import Language.Haskell.TH.Desugar++-- | The function 'cases' generates a case expression where each right-hand side+-- is identical. This may be useful if the type-checker requires knowledge of which+-- constructor is used to satisfy equality or type-class constraints, but where+-- each constructor is treated the same.+cases :: DsMonad q+ => Name -- ^ The head of the type of the scrutinee. (Like @''Maybe@ or @''Bool@.)+ -> q Exp -- ^ The scrutinee, in a Template Haskell quote+ -> q Exp -- ^ The body, in a Template Haskell quote+ -> q Exp+cases tyName expq bodyq = do+ dinfo <- dsReify tyName+ case dinfo of+ Just (DTyConI (DDataD _ _ _ _ _ ctors _) _) ->+ expToTH <$> buildCases (map extractNameArgs ctors) expq bodyq+ Just _ ->+ fail $ "Using <<cases>> with something other than a type constructor: "+ ++ (show tyName)+ _ -> fail $ "Cannot find " ++ show tyName++-- | The function 'sCases' generates a case expression where each right-hand side+-- is identical. This may be useful if the type-checker requires knowledge of which+-- constructor is used to satisfy equality or type-class constraints, but where+-- each constructor is treated the same. For 'sCases', unlike 'cases', the+-- scrutinee is a singleton. But make sure to pass in the name of the /original/+-- datatype, preferring @''Maybe@ over @''SMaybe@.+sCases :: OptionsMonad q+ => Name -- ^ The head of the type the scrutinee's type is based on.+ -- (Like @''Maybe@ or @''Bool@.)+ -> q Exp -- ^ The scrutinee, in a Template Haskell quote+ -> q Exp -- ^ The body, in a Template Haskell quote+ -> q Exp+sCases tyName expq bodyq = do+ opts <- getOptions+ dinfo <- dsReify tyName+ case dinfo of+ Just (DTyConI (DDataD _ _ _ _ _ ctors _) _) ->+ let ctor_stuff = map (first (singledDataConName opts) . extractNameArgs) ctors in+ expToTH <$> buildCases ctor_stuff expq bodyq+ Just _ ->+ fail $ "Using <<cases>> with something other than a type constructor: "+ ++ (show tyName)+ _ -> fail $ "Cannot find " ++ show tyName++buildCases :: DsMonad m+ => [(Name, Int)]+ -> m Exp -- scrutinee+ -> m Exp -- body+ -> m DExp+buildCases ctor_infos expq bodyq =+ DCaseE <$> (dsExp =<< expq) <*>+ mapM (\con -> DMatch (conToPat con) <$> (dsExp =<< bodyq)) ctor_infos+ where+ conToPat :: (Name, Int) -> DPat+ conToPat (name, num_fields) =+ DConP name (replicate num_fields DWildP)
+ src/Data/Singletons/TH/CustomStar.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE DataKinds, TypeFamilies, KindSignatures, TemplateHaskell #-}++-----------------------------------------------------------------------------+-- |+-- Module : Data.Singletons.TH.CustomStar+-- Copyright : (C) 2013 Richard Eisenberg+-- License : BSD-style (see LICENSE)+-- Maintainer : Ryan Scott+-- Stability : experimental+-- Portability : non-portable+--+-- This file implements 'singletonStar', which generates a datatype @Rep@ and associated+-- singleton from a list of types. The promoted version of @Rep@ is kind @*@ and the+-- Haskell types themselves. This is still very experimental, so expect unusual+-- results!+--+-- See also @Data.Singletons.Base.CustomStar@ from @singletons-base@, a+-- variant of this module that also re-exports related definitions from+-- @Prelude.Singletons@.+--+----------------------------------------------------------------------------++module Data.Singletons.TH.CustomStar (+ singletonStar,++ module Data.Singletons.TH+ ) where++import Language.Haskell.TH+import Data.Singletons.TH+import Data.Singletons.TH.Deriving.Eq+import Data.Singletons.TH.Deriving.Infer+import Data.Singletons.TH.Deriving.Ord+import Data.Singletons.TH.Deriving.Show+import Data.Singletons.TH.Promote+import Data.Singletons.TH.Promote.Monad+import Data.Singletons.TH.Names+import Data.Singletons.TH.Options+import Data.Singletons.TH.Single+import Data.Singletons.TH.Single.Data+import Data.Singletons.TH.Single.Monad+import Data.Singletons.TH.Syntax+import Data.Singletons.TH.Util+import Control.Monad+import Data.Maybe+import Language.Haskell.TH.Desugar++-- | Produce a representation and singleton for the collection of types given.+--+-- A datatype @Rep@ is created, with one constructor per type in the declared+-- universe. When this type is promoted by the @singletons-th@ library, the+-- constructors become full types in @*@, not just promoted data constructors.+--+-- For example,+--+-- > $(singletonStar [''Nat, ''Bool, ''Maybe])+--+-- generates the following:+--+-- > data Rep = Nat | Bool | Maybe Rep deriving (Eq, Ord, Read, Show)+--+-- and its singleton. However, because @Rep@ is promoted to @*@, the singleton+-- is perhaps slightly unexpected:+--+-- > data SRep (a :: *) where+-- > SNat :: Sing Nat+-- > SBool :: Sing Bool+-- > SMaybe :: Sing a -> Sing (Maybe a)+-- > type instance Sing = SRep+--+-- The unexpected part is that @Nat@, @Bool@, and @Maybe@ above are the real @Nat@,+-- @Bool@, and @Maybe@, not just promoted data constructors.+--+-- Please note that this function is /very/ experimental. Use at your own risk.+singletonStar :: OptionsMonad q+ => [Name] -- ^ A list of Template Haskell @Name@s for types+ -> q [Dec]+singletonStar names = do+ kinds <- mapM getKind names+ ctors <- zipWithM (mkCtor True) names kinds+ let repDecl = DDataD Data [] repName [] (Just (DConT typeKindName)) ctors+ [DDerivClause Nothing (map DConT [''Eq, ''Ord, ''Read, ''Show])]+ fakeCtors <- zipWithM (mkCtor False) names kinds+ let dataDecl = DataDecl repName [] fakeCtors+ -- Why do we need withLocalDeclarations here? It's because we end up+ -- expanding type synonyms when deriving instances for Rep, which requires+ -- reifying Rep itself. Since Rep hasn't been spliced in yet, we must put it+ -- into the local declarations.+ withLocalDeclarations [decToTH repDecl] $ do+ -- We opt to infer the constraints for the Eq instance here so that when it's+ -- promoted, Rep will be promoted to Type.+ dataDeclEqCxt <- inferConstraints (DConT ''Eq) (DConT repName) fakeCtors+ let dataDeclEqInst = DerivedDecl (Just dataDeclEqCxt) (DConT repName) repName dataDecl+ eqInst <- mkEqInstance Nothing (DConT repName) dataDecl+ ordInst <- mkOrdInstance Nothing (DConT repName) dataDecl+ showInst <- mkShowInstance Nothing (DConT repName) dataDecl+ (pInsts, promDecls) <- promoteM [] $ do _ <- promoteDataDec dataDecl+ traverse (promoteInstanceDec mempty mempty)+ [eqInst, ordInst, showInst]+ singletonDecls <- singDecsM [] $ do decs1 <- singDataD dataDecl+ decs2 <- singDerivedEqDecs dataDeclEqInst+ decs3 <- traverse singInstD pInsts+ return (decs1 ++ decs2 ++ decs3)+ return $ decsToTH $ repDecl :+ promDecls +++ singletonDecls+ where -- get the kinds of the arguments to the tycon with the given name+ getKind :: DsMonad q => Name -> q [DKind]+ getKind name = do+ info <- reifyWithLocals name+ dinfo <- dsInfo info+ case dinfo of+ DTyConI (DDataD _ (_:_) _ _ _ _ _) _ ->+ fail "Cannot make a representation of a constrained data type"+ DTyConI (DDataD _ [] _ tvbs mk _ _) _ -> do+ all_tvbs <- buildDataDTvbs tvbs mk+ return $ map (fromMaybe (DConT typeKindName) . extractTvbKind) all_tvbs+ DTyConI (DTySynD _ tvbs _) _ ->+ return $ map (fromMaybe (DConT typeKindName) . extractTvbKind) tvbs+ DPrimTyConI _ n _ ->+ return $ replicate n $ DConT typeKindName+ _ -> fail $ "Invalid thing for representation: " ++ (show name)++ -- first parameter is whether this is a real ctor (with a fresh name)+ -- or a fake ctor (when the name is actually a Haskell type)+ mkCtor :: DsMonad q => Bool -> Name -> [DKind] -> q DCon+ mkCtor real name args = do+ (types, vars) <- evalForPair $ mapM (kindToType []) args+ dataName <- if real then mkDataName (nameBase name) else return name+ return $ DCon (map (`DPlainTV` SpecifiedSpec) vars) [] dataName+ (DNormalC False (map (\ty -> (noBang, ty)) types))+ (DConT repName)+ where+ noBang = Bang NoSourceUnpackedness NoSourceStrictness++ -- demote a kind back to a type, accumulating any unbound parameters+ kindToType :: DsMonad q => [DTypeArg] -> DKind -> QWithAux [Name] q DType+ kindToType _ (DForallT _ _) = fail "Explicit forall encountered in kind"+ kindToType _ (DConstrainedT _ _) = fail "Explicit constraint encountered in kind"+ kindToType args (DAppT f a) = do+ a' <- kindToType [] a+ kindToType (DTANormal a' : args) f+ kindToType args (DAppKindT f a) = do+ a' <- kindToType [] a+ kindToType (DTyArg a' : args) f+ kindToType args (DSigT t k) = do+ t' <- kindToType [] t+ k' <- kindToType [] k+ return $ DSigT t' k' `applyDType` args+ kindToType args (DVarT n) = do+ addElement n+ return $ DVarT n `applyDType` args+ kindToType args (DConT n) = return $ DConT name `applyDType` args+ where name | isTypeKindName n = repName+ | otherwise = n+ kindToType args DArrowT = return $ DArrowT `applyDType` args+ kindToType args k@(DLitT {}) = return $ k `applyDType` args+ kindToType args DWildCardT = return $ DWildCardT `applyDType` args
+ src/Data/Singletons/TH/Deriving/Bounded.hs view
@@ -0,0 +1,59 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.Singletons.TH.Deriving.Bounded+-- Copyright : (C) 2015 Richard Eisenberg+-- License : BSD-style (see LICENSE)+-- Maintainer : Ryan Scott+-- Stability : experimental+-- Portability : non-portable+--+-- Implements deriving of Bounded instances+--+----------------------------------------------------------------------------++module Data.Singletons.TH.Deriving.Bounded where++import Language.Haskell.TH.Ppr+import Language.Haskell.TH.Desugar+import Data.Singletons.TH.Deriving.Infer+import Data.Singletons.TH.Deriving.Util+import Data.Singletons.TH.Names+import Data.Singletons.TH.Syntax+import Data.Singletons.TH.Util+import Control.Monad++-- monadic only for failure and parallelism with other functions+-- that make instances+mkBoundedInstance :: DsMonad q => DerivDesc q+mkBoundedInstance mb_ctxt ty (DataDecl _ _ cons) = do+ -- We can derive instance of Bounded if datatype is an enumeration (all+ -- constructors must be nullary) or has only one constructor. See Section 11+ -- of Haskell 2010 Language Report.+ -- Note that order of conditions below is important.+ when (null cons+ || (any (\(DCon _ _ _ f _) -> not . null . tysOfConFields $ f) cons+ && (not . null . tail $ cons))) $+ fail ("Can't derive Bounded instance for "+ ++ pprint (typeToTH ty) ++ ".")+ -- at this point we know that either we have a datatype that has only one+ -- constructor or a datatype where each constructor is nullary+ let (DCon _ _ minName fields _) = head cons+ (DCon _ _ maxName _ _) = last cons+ fieldsCount = length $ tysOfConFields fields+ (minRHS, maxRHS) = case fieldsCount of+ 0 -> (DConE minName, DConE maxName)+ _ ->+ let minEqnRHS = foldExp (DConE minName)+ (replicate fieldsCount (DVarE minBoundName))+ maxEqnRHS = foldExp (DConE maxName)+ (replicate fieldsCount (DVarE maxBoundName))+ in (minEqnRHS, maxEqnRHS)++ mk_rhs rhs = UFunction [DClause [] rhs]+ constraints <- inferConstraintsDef mb_ctxt (DConT boundedName) ty cons+ return $ InstDecl { id_cxt = constraints+ , id_name = boundedName+ , id_arg_tys = [ty]+ , id_sigs = mempty+ , id_meths = [ (minBoundName, mk_rhs minRHS)+ , (maxBoundName, mk_rhs maxRHS) ] }
+ src/Data/Singletons/TH/Deriving/Enum.hs view
@@ -0,0 +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) ] })
+ src/Data/Singletons/TH/Deriving/Eq.hs view
@@ -0,0 +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
+ src/Data/Singletons/TH/Deriving/Foldable.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE ScopedTypeVariables #-}++-----------------------------------------------------------------------------+-- |+-- Module : Data.Singletons.TH.Deriving.Foldable+-- Copyright : (C) 2018 Ryan Scott+-- License : BSD-style (see LICENSE)+-- Maintainer : Ryan Scott+-- Stability : experimental+-- Portability : non-portable+--+-- Implements deriving of Foldable instances+--+----------------------------------------------------------------------------++module Data.Singletons.TH.Deriving.Foldable where++import Data.Singletons.TH.Deriving.Infer+import Data.Singletons.TH.Deriving.Util+import Data.Singletons.TH.Names+import Data.Singletons.TH.Syntax+import Language.Haskell.TH.Desugar++mkFoldableInstance :: forall q. DsMonad q => DerivDesc q+mkFoldableInstance mb_ctxt ty dd@(DataDecl _ _ cons) = do+ functorLikeValidityChecks False dd+ f <- newUniqueName "_f"+ z <- newUniqueName "_z"+ let ft_foldMap :: FFoldType (q DExp)+ ft_foldMap = FT { ft_triv = mkSimpleLam $ \_ -> pure $ DVarE memptyName+ -- foldMap f = \x -> mempty+ , ft_var = pure $ DVarE f+ -- foldMap f = f+ , ft_ty_app = \_ g -> DAppE (DVarE foldMapName) <$> g+ -- foldMap f = foldMap g+ , ft_forall = \_ g -> g+ , ft_bad_app = error "in other argument in ft_foldMap"+ }++ ft_foldr :: FFoldType (q DExp)+ ft_foldr = FT { ft_triv = mkSimpleLam2 $ \_ z' -> pure z'+ -- foldr f = \x z -> z+ , ft_var = pure $ DVarE f+ -- foldr f = f+ , ft_ty_app = \_ g -> do+ gg <- g+ mkSimpleLam2 $ \x z' -> pure $+ DVarE foldrName `DAppE` gg `DAppE` z' `DAppE` x+ -- foldr f = (\x z -> foldr g z x)+ , ft_forall = \_ g -> g+ , ft_bad_app = error "in other argument in ft_foldr"+ }++ clause_for_foldMap :: [DPat] -> DCon -> [DExp] -> q DClause+ clause_for_foldMap = mkSimpleConClause $ \_ -> mkFoldMap+ where+ -- mappend v1 (mappend v2 ..)+ mkFoldMap :: [DExp] -> DExp+ mkFoldMap [] = DVarE memptyName+ mkFoldMap xs = foldr1 (\x y -> DVarE mappendName `DAppE` x `DAppE` y) xs++ clause_for_foldr :: [DPat] -> DCon -> [DExp] -> q DClause+ clause_for_foldr = mkSimpleConClause $ \_ -> mkFoldr+ where+ -- g1 v1 (g2 v2 (.. z))+ mkFoldr :: [DExp] -> DExp+ mkFoldr = foldr DAppE (DVarE z)++ mk_foldMap_clause :: DCon -> q DClause+ mk_foldMap_clause con = do+ parts <- foldDataConArgs ft_foldMap con+ clause_for_foldMap [DVarP f] con =<< sequence parts++ mk_foldr_clause :: DCon -> q DClause+ mk_foldr_clause con = do+ parts <- foldDataConArgs ft_foldr con+ clause_for_foldr [DVarP f, DVarP z] con =<< sequence parts++ mk_foldMap :: q [DClause]+ mk_foldMap =+ case cons of+ [] -> pure [DClause [DWildP, DWildP] (DVarE memptyName)]+ _ -> traverse mk_foldMap_clause cons++ mk_foldr :: q [DClause]+ mk_foldr = traverse mk_foldr_clause cons++ foldMap_clauses <- mk_foldMap+ foldr_clauses <- mk_foldr+ let meths = (foldMapName, UFunction foldMap_clauses)+ : case cons of+ [] -> []+ _ -> [(foldrName, UFunction foldr_clauses)]+ constraints <- inferConstraintsDef mb_ctxt (DConT foldableName) ty cons+ return $ InstDecl { id_cxt = constraints+ , id_name = foldableName+ , id_arg_tys = [ty]+ , id_sigs = mempty+ , id_meths = meths }
+ src/Data/Singletons/TH/Deriving/Functor.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE ScopedTypeVariables #-}++-----------------------------------------------------------------------------+-- |+-- Module : Data.Singletons.TH.Deriving.Functor+-- Copyright : (C) 2018 Ryan Scott+-- License : BSD-style (see LICENSE)+-- Maintainer : Ryan Scott+-- Stability : experimental+-- Portability : non-portable+--+-- Implements deriving of Functor instances+--+----------------------------------------------------------------------------++module Data.Singletons.TH.Deriving.Functor where++import Data.Singletons.TH.Deriving.Infer+import Data.Singletons.TH.Deriving.Util+import Data.Singletons.TH.Names+import Data.Singletons.TH.Syntax+import Data.Singletons.TH.Util+import Language.Haskell.TH.Desugar++mkFunctorInstance :: forall q. DsMonad q => DerivDesc q+mkFunctorInstance mb_ctxt ty dd@(DataDecl _ _ cons) = do+ functorLikeValidityChecks False dd+ f <- newUniqueName "_f"+ z <- newUniqueName "_z"+ let ft_fmap :: FFoldType (q DExp)+ ft_fmap = FT { ft_triv = mkSimpleLam pure+ -- fmap f = \x -> x+ , ft_var = pure $ DVarE f+ -- fmap f = f+ , ft_ty_app = \_ g -> DAppE (DVarE fmapName) <$> g+ -- fmap f = fmap g+ , ft_forall = \_ g -> g+ , ft_bad_app = error "in other argument in ft_fmap"+ }++ ft_replace :: FFoldType (q Replacer)+ ft_replace = FT { ft_triv = fmap Nested $ mkSimpleLam pure+ -- (p <$) = \x -> x+ , ft_var = fmap Immediate $ mkSimpleLam $ \_ -> pure $ DVarE z+ -- (p <$) = const p+ , ft_ty_app = \_ gm -> do+ g <- gm+ case g of+ Nested g' -> pure . Nested $ DVarE fmapName `DAppE` g'+ Immediate _ -> pure . Nested $ DVarE replaceName `DAppE` DVarE z+ -- (p <$) = fmap (p <$)+ , ft_forall = \_ g -> g+ , ft_bad_app = error "in other argument in ft_replace"+ }++ -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...+ clause_for_con :: [DPat] -> DCon -> [DExp] -> q DClause+ clause_for_con = mkSimpleConClause $ \con_name ->+ foldExp (DConE con_name) -- Con x1 x2 ...++ mk_fmap_clause :: DCon -> q DClause+ mk_fmap_clause con = do+ parts <- foldDataConArgs ft_fmap con+ clause_for_con [DVarP f] con =<< sequence parts++ mk_replace_clause :: DCon -> q DClause+ mk_replace_clause con = do+ parts <- foldDataConArgs ft_replace con+ clause_for_con [DVarP z] con =<< traverse (fmap replace) parts++ mk_fmap :: q [DClause]+ mk_fmap = case cons of+ [] -> do v <- newUniqueName "v"+ pure [DClause [DWildP, DVarP v] (DCaseE (DVarE v) [])]+ _ -> traverse mk_fmap_clause cons++ mk_replace :: q [DClause]+ mk_replace = case cons of+ [] -> do v <- newUniqueName "v"+ pure [DClause [DWildP, DVarP v] (DCaseE (DVarE v) [])]+ _ -> traverse mk_replace_clause cons++ fmap_clauses <- mk_fmap+ replace_clauses <- mk_replace+ constraints <- inferConstraintsDef mb_ctxt (DConT functorName) ty cons+ return $ InstDecl { id_cxt = constraints+ , id_name = functorName+ , id_arg_tys = [ty]+ , id_sigs = mempty+ , id_meths = [ (fmapName, UFunction fmap_clauses)+ , (replaceName, UFunction replace_clauses)+ ] }++data Replacer = Immediate { replace :: DExp }+ | Nested { replace :: DExp }
+ src/Data/Singletons/TH/Deriving/Infer.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE ScopedTypeVariables #-}++-----------------------------------------------------------------------------+-- |+-- Module : Data.Singletons.TH.Deriving.Infer+-- Copyright : (C) 2015 Richard Eisenberg+-- License : BSD-style (see LICENSE)+-- Maintainer : Ryan Scott+-- Stability : experimental+-- Portability : non-portable+--+-- Infers constraints for a `deriving` class+--+----------------------------------------------------------------------------++module Data.Singletons.TH.Deriving.Infer ( inferConstraints, inferConstraintsDef ) where++import Language.Haskell.TH.Desugar+import Language.Haskell.TH.Syntax+import Data.Singletons.TH.Deriving.Util+import Data.Singletons.TH.Util+import Data.List (nub)+import Data.Maybe (fromJust)++-- @inferConstraints cls inst_ty cons@ infers the instance context for a+-- derived type class instance of @cls@ for @inst_ty@, using the constructors+-- @cons@. For instance, if @cls@ is 'Ord' and @inst_ty@ is @Either a b@, then+-- that means we are attempting to derive the instance:+--+-- @+-- instance ??? => Ord (Either a b)+-- @+--+-- The role of 'inferConstraints' is to determine what @???@ should be in that+-- derived instance. To accomplish this, the list of @cons@ (in this example,+-- @cons@ would be @[Left a, Right b]@) is used as follows:+--+-- 1. For each @con@ in @cons@, find the types of each of its fields+-- (call these @field_tys@), perhaps after renaming the type variables of+-- @field_tys@.+-- 2. For each @field_ty@ in @field_tys@, apply @cls@ to @field_ty@ to obtain+-- a constraint.+-- 3. The final instance context is the set of all such constraints obtained+-- in step 2.+--+-- To complete the running example, this algorithm would produce the instance+-- context @(Ord a, Ord b)@, since @Left a@ has one field of type @a@, and+-- @Right b@ has one field of type @b@.+--+-- This algorithm is a crude approximation of what GHC actually does when+-- deriving instances. It is crude in the sense that one can end up with+-- redundant constraints. For instance, if the data type for which an 'Ord'+-- instance is being derived is @data Foo = MkFoo Bool Foo@, then the+-- inferred constraints would be @(Ord Bool, Ord Foo)@. Technically, neither+-- constraint is necessary, but it is not simple in general to eliminate+-- redundant constraints like these, so we do not attept to do so. (This is+-- one reason why @singletons-th@ requires the use of the @UndecidableInstances@+-- GHC extension.)+--+-- Observant readers will notice that the phrase \"perhaps afer renaming the+-- type variables\" was casually dropped in step 1 of the above algorithm.+-- For more information on what this means, refer to the documentation for+-- infer_ct below.+inferConstraints :: forall q. DsMonad q => DPred -> DType -> [DCon] -> q DCxt+inferConstraints pr inst_ty = fmap nub . concatMapM infer_ct+ where+ -- A thorny situation arises when attempting to infer an instance context+ -- for a GADT. Consider the following example:+ --+ -- newtype Bar a where+ -- MkBar :: b -> Bar b+ -- deriving Show+ --+ -- If we blindly apply 'Show' to the field type of @MkBar@, we will end up+ -- with a derived instance of:+ --+ -- instance Show b => Show (Bar a)+ --+ -- This is completely wrong, since the type variable @b@ is never used in+ -- the instance head! This reveals that we need a slightly more nuanced+ -- strategy for gathering constraints for GADT constructors. To account+ -- for this, when gathering @field_tys@ (from step 1 in the above algorithm)+ -- we perform the following extra steps:+ --+ -- 1(a). Take the return type of @con@ and match it with @inst_ty@ (e.g.,+ -- match @Bar b@ with @Bar a@). Doing so will produce a substitution+ -- that maps the universally quantified type variables in the GADT+ -- (i.e., @b@) to the corresponding type variables in the data type+ -- constructor (i.e., @a@).+ -- 1(b). Use the resulting substitution to rename the universally+ -- quantified type variables of @con@ as necessary.+ --+ -- After this renaming, the algorithm will produce an instance context of+ -- @Show a@ (since @b@ was renamed to @a@), as expected.+ infer_ct :: DCon -> q DCxt+ infer_ct (DCon _ _ _ fields res_ty) = do+ let field_tys = tysOfConFields fields+ -- We need to match the constructor's result type with the type given+ -- in the generated instance. But if we have:+ --+ -- data Foo a where+ -- MkFoo :: a -> Foo a+ -- deriving Functor+ --+ -- Then the generated instance will be:+ --+ -- instance Functor Foo where ...+ --+ -- Which means that if we're not careful, we might try to match the+ -- types (Foo a) and (Foo), which will fail.+ --+ -- To avoid this, we employ a grimy hack where we pad the instance+ -- type with an extra (dummy) type variable. It doesn't matter what+ -- we name it, since none of the inferred constraints will mention+ -- it anyway.+ eta_expanded_inst_ty+ | is_functor_like = inst_ty `DAppT` DVarT (mkName "dummy")+ | otherwise = inst_ty+ res_ty' <- expandType res_ty+ inst_ty' <- expandType eta_expanded_inst_ty+ field_tys' <- case matchTy YesIgnore res_ty' inst_ty' of+ Nothing -> fail $ showString "Unable to match type "+ . showsPrec 11 res_ty'+ . showString " with "+ . showsPrec 11 inst_ty'+ $ ""+ Just subst -> traverse (substTy subst) field_tys+ if is_functor_like+ then mk_functor_like_constraints field_tys' res_ty'+ else pure $ map (pr `DAppT`) field_tys'++ -- If we derive a Functor-like class, e.g.,+ --+ -- data Foo f g h a = MkFoo (f a) (g (h a)) deriving Functor+ --+ -- Then we infer constraints by sticking Functor on the subtypes of kind+ -- (Type -> Type). In the example above, that would give us+ -- (Functor f, Functor g, Functor h).+ mk_functor_like_constraints :: [DType] -> DType -> q DCxt+ mk_functor_like_constraints fields res_ty = do+ -- This function is partial. But that's OK, because+ -- functorLikeValidityChecks ensures that this is total by the time+ -- we invoke this.+ let (_, res_ty_args) = unfoldDType res_ty+ (_, last_res_ty_arg) = snocView $ filterDTANormals res_ty_args+ last_tv = fromJust $ getDVarTName_maybe last_res_ty_arg+ deep_subtypes <- concatMapM (deepSubtypesContaining last_tv) fields+ pure $ map (pr `DAppT`) deep_subtypes++ is_functor_like :: Bool+ is_functor_like+ | (DConT pr_class_name, _) <- unfoldDType pr+ = isFunctorLikeClassName pr_class_name+ | otherwise+ = False++-- For @inferConstraintsDef mb_cxt@, if @mb_cxt@ is 'Just' a context, then it will+-- simply return that context. Otherwise, if @mb_cxt@ is 'Nothing', then+-- 'inferConstraintsDef' will infer an instance context (using 'inferConstraints').+inferConstraintsDef :: DsMonad q => Maybe DCxt -> DPred -> DType -> [DCon] -> q DCxt+inferConstraintsDef mb_ctxt pr inst_ty cons =+ maybe (inferConstraints pr inst_ty cons) pure mb_ctxt
+ src/Data/Singletons/TH/Deriving/Ord.hs view
@@ -0,0 +1,71 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.Singletons.TH.Deriving.Ord+-- Copyright : (C) 2015 Richard Eisenberg+-- License : BSD-style (see LICENSE)+-- Maintainer : Ryan Scott+-- Stability : experimental+-- Portability : non-portable+--+-- Implements deriving of Ord instances+--+----------------------------------------------------------------------------++module Data.Singletons.TH.Deriving.Ord ( mkOrdInstance ) where++import Language.Haskell.TH.Desugar+import Language.Haskell.TH.Syntax+import Data.Singletons.TH.Deriving.Infer+import Data.Singletons.TH.Deriving.Util+import Data.Singletons.TH.Names+import Data.Singletons.TH.Syntax+import Data.Singletons.TH.Util++-- | Make a *non-singleton* Ord instance+mkOrdInstance :: DsMonad q => DerivDesc q+mkOrdInstance mb_ctxt ty (DataDecl _ _ cons) = do+ constraints <- inferConstraintsDef mb_ctxt (DConT ordName) ty cons+ compare_eq_clauses <- mapM mk_equal_clause cons+ let compare_noneq_clauses = map (uncurry mk_nonequal_clause)+ [ (con1, con2)+ | con1 <- zip cons [1..]+ , con2 <- zip cons [1..]+ , extractName (fst con1) /=+ extractName (fst con2) ]+ clauses | null cons = [mk_empty_clause]+ | otherwise = compare_eq_clauses ++ compare_noneq_clauses+ return (InstDecl { id_cxt = constraints+ , id_name = ordName+ , id_arg_tys = [ty]+ , id_sigs = mempty+ , id_meths = [(compareName, UFunction clauses)] })++mk_equal_clause :: Quasi q => DCon -> q DClause+mk_equal_clause (DCon _tvbs _cxt name fields _rty) = do+ let tys = tysOfConFields fields+ a_names <- mapM (const $ newUniqueName "a") tys+ b_names <- mapM (const $ newUniqueName "b") tys+ let pat1 = DConP name (map DVarP a_names)+ pat2 = DConP name (map DVarP b_names)+ return $ DClause [pat1, pat2] (DVarE foldlName `DAppE`+ DVarE thenCmpName `DAppE`+ DConE cmpEQName `DAppE`+ mkListE (zipWith+ (\a b -> DVarE compareName `DAppE` DVarE a+ `DAppE` DVarE b)+ a_names b_names))++mk_nonequal_clause :: (DCon, Int) -> (DCon, Int) -> DClause+mk_nonequal_clause (DCon _tvbs1 _cxt1 name1 fields1 _rty1, n1)+ (DCon _tvbs2 _cxt2 name2 fields2 _rty2, n2) =+ DClause [pat1, pat2] (case n1 `compare` n2 of+ LT -> DConE cmpLTName+ EQ -> DConE cmpEQName+ GT -> DConE cmpGTName)+ where+ pat1 = DConP name1 (map (const DWildP) (tysOfConFields fields1))+ pat2 = DConP name2 (map (const DWildP) (tysOfConFields fields2))++-- A variant of mk_equal_clause tailored to empty datatypes+mk_empty_clause :: DClause+mk_empty_clause = DClause [DWildP, DWildP] (DConE cmpEQName)
+ src/Data/Singletons/TH/Deriving/Show.hs view
@@ -0,0 +1,165 @@+-----------------------------------------------------------------------------+-- |+-- 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+--+----------------------------------------------------------------------------+{-# LANGUAGE ScopedTypeVariables #-}+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 c = DLitE $ StringL [c] -- There aren't type-level characters yet,+ -- so fake it with a string++dStringE :: String -> DExp+dStringE = DLitE . StringL++dIntegerE :: Int -> DExp+dIntegerE = DLitE . IntegerL . fromIntegral++isSym :: String -> Bool+isSym "" = False+isSym (c : _) = startsVarSym c || startsConSym c++-- | Turn a context like @('Show' a, 'Show' b)@ into @('ShowSing' a, 'ShowSing' b)@.+-- This is necessary for standalone-derived 'Show' instances for singleton types.+mkShowSingContext :: DCxt -> DCxt+mkShowSingContext = map show_to_SingShow+ where+ show_to_SingShow :: DPred -> DPred+ show_to_SingShow = modifyConNameDType $ \n ->+ if n == showName+ then showSingName+ else n
+ src/Data/Singletons/TH/Deriving/Traversable.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE ScopedTypeVariables #-}++-----------------------------------------------------------------------------+-- |+-- Module : Data.Singletons.TH.Deriving.Traversable+-- Copyright : (C) 2018 Ryan Scott+-- License : BSD-style (see LICENSE)+-- Maintainer : Ryan Scott+-- Stability : experimental+-- Portability : non-portable+--+-- Implements deriving of Traversable instances+--+----------------------------------------------------------------------------++module Data.Singletons.TH.Deriving.Traversable where++import Data.Singletons.TH.Deriving.Infer+import Data.Singletons.TH.Deriving.Util+import Data.Singletons.TH.Names+import Data.Singletons.TH.Syntax+import Language.Haskell.TH.Desugar++mkTraversableInstance :: forall q. DsMonad q => DerivDesc q+mkTraversableInstance mb_ctxt ty dd@(DataDecl _ _ cons) = do+ functorLikeValidityChecks False dd+ f <- newUniqueName "_f"+ let ft_trav :: FFoldType (q DExp)+ ft_trav = FT { ft_triv = pure $ DVarE pureName+ -- traverse f = pure x+ , ft_var = pure $ DVarE f+ -- traverse f = f x+ , ft_ty_app = \_ g -> DAppE (DVarE traverseName) <$> g+ -- traverse f = traverse g+ , ft_forall = \_ g -> g+ , ft_bad_app = error "in other argument in ft_trav"+ }++ -- Con a1 a2 ... -> Con <$> g1 a1 <*> g2 a2 <*> ...+ clause_for_con :: [DPat] -> DCon -> [DExp] -> q DClause+ clause_for_con = mkSimpleConClause $ \con_name -> mkApCon (DConE con_name)+ where+ -- ((Con <$> x1) <*> x2) <*> ...+ mkApCon :: DExp -> [DExp] -> DExp+ mkApCon con [] = DVarE pureName `DAppE` con+ mkApCon con [x] = DVarE fmapName `DAppE` con `DAppE` x+ mkApCon con (x1:x2:xs) =+ foldl appAp (DVarE liftA2Name `DAppE` con `DAppE` x1 `DAppE` x2) xs+ where appAp x y = DVarE apName `DAppE` x `DAppE` y++ mk_trav_clause :: DCon -> q DClause+ mk_trav_clause con = do+ parts <- foldDataConArgs ft_trav con+ clause_for_con [DVarP f] con =<< sequence parts++ mk_trav :: q [DClause]+ mk_trav = case cons of+ [] -> do v <- newUniqueName "v"+ pure [DClause [DWildP, DVarP v]+ (DVarE pureName `DAppE` DCaseE (DVarE v) [])]+ _ -> traverse mk_trav_clause cons++ trav_clauses <- mk_trav+ constraints <- inferConstraintsDef mb_ctxt (DConT traversableName) ty cons+ return $ InstDecl { id_cxt = constraints+ , id_name = traversableName+ , id_arg_tys = [ty]+ , id_sigs = mempty+ , id_meths = [ (traverseName, UFunction trav_clauses) ] }
+ src/Data/Singletons/TH/Deriving/Util.hs view
@@ -0,0 +1,300 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ScopedTypeVariables #-}++-----------------------------------------------------------------------------+-- |+-- Module : Data.Singletons.TH.Deriving.Util+-- Copyright : (C) 2018 Ryan Scott+-- License : BSD-style (see LICENSE)+-- Maintainer : Ryan Scott+-- Stability : experimental+-- Portability : non-portable+--+-- Utilities used by the `deriving` machinery in singletons-th.+--+----------------------------------------------------------------------------+module Data.Singletons.TH.Deriving.Util where++import Control.Monad+import Data.Singletons.TH.Names+import Data.Singletons.TH.Syntax+import Data.Singletons.TH.Util+import Language.Haskell.TH.Desugar+import qualified Language.Haskell.TH.Desugar.OSet as OSet+import Language.Haskell.TH.Syntax++-- A generic type signature for describing how to produce a derived instance.+type DerivDesc q+ = Maybe DCxt -- (Just ctx) if ctx was provided via StandaloneDeriving.+ -- Nothing if using a deriving clause.+ -> DType -- The data type argument to the class.+ -> DataDecl -- The original data type information.+ -> q UInstDecl -- The derived instance.++-----+-- Utilities for deriving Functor-like classes.+-- Much of this was cargo-culted from the GHC source code.+-----++data FFoldType a -- Describes how to fold over a DType in a functor like way+ = FT { ft_triv :: a+ -- ^ Does not contain variable+ , ft_var :: a+ -- ^ The variable itself+ , ft_ty_app :: DType -> a -> a+ -- ^ Type app, variable only in last argument+ , ft_bad_app :: a+ -- ^ Type app, variable other than in last argument+ , ft_forall :: [DTyVarBndrSpec] -> a -> a+ -- ^ Forall type+ }++-- Note that in GHC, this function is pure. It must be monadic here since we:+--+-- (1) Expand type synonyms+-- (2) Detect type family applications+--+-- Which require reification in Template Haskell, but are pure in Core.+functorLikeTraverse :: forall q a.+ DsMonad q+ => Name -- ^ Variable to look for+ -> FFoldType a -- ^ How to fold+ -> DType -- ^ Type to process+ -> q a+functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar+ , ft_ty_app = caseTyApp, ft_bad_app = caseWrongArg+ , ft_forall = caseForAll })+ ty+ = do ty' <- expandType ty+ (res, _) <- go ty'+ pure res+ where+ go :: DType+ -> q (a, Bool) -- (result of type a, does type contain var)+ go t@DAppT{} = do+ let (f, args) = unfoldDType t+ vis_args = filterDTANormals args+ (_, fc) <- go f+ (xrs, xcs) <- mapAndUnzipM go vis_args+ let wrongArg :: q (a, Bool)+ wrongArg = pure (caseWrongArg, True)+ if | not (or xcs)+ -> trivial -- Variable does not occur+ -- At this point we know that xrs, xcs is not empty,+ -- and at least one xr is True+ | fc || or (init xcs)+ -> wrongArg -- T (..var..) ty+ | otherwise -- T (..no var..) ty+ -> do itf <- isInTypeFamilyApp var f vis_args+ if itf -- We can't decompose type families, so+ -- error if we encounter one here.+ then wrongArg+ else pure (caseTyApp (last vis_args) (last xrs), True)+ go (DAppKindT t k) = do+ (_, kc) <- go k+ if kc+ then pure (caseWrongArg, True)+ else go t+ go (DSigT t k) = do+ (_, kc) <- go k+ if kc+ then pure (caseWrongArg, True)+ else go t+ go (DVarT v)+ | v == var = pure (caseVar, True)+ | otherwise = trivial+ go (DForallT tele t) = case tele of+ DForallVis{} ->+ fail "Unexpected visible forall in the type of a data constructor"+ DForallInvis tvbs -> do+ (tr, tc) <- go t+ if var `notElem` map extractTvbName tvbs && tc+ then pure (caseForAll tvbs tr, True)+ else trivial+ go (DConstrainedT _ t) = go t+ go (DConT {}) = trivial+ go DArrowT = trivial+ go (DLitT {}) = trivial+ go DWildCardT = trivial++ trivial :: q (a, Bool)+ trivial = pure (caseTrivial, False)++-- | Detect if a Name occurs as an argument to some type family. This makes an+-- effort to exclude /oversaturated/ arguments to type families. For instance,+-- if one declared the following type family:+--+-- @+-- type family F a :: Type -> Type+-- @+--+-- Then in the type @F a b@, we would consider @a@ to be an argument to @F@,+-- but not @b@.+isInTypeFamilyApp :: forall q. DsMonad q => Name -> DType -> [DType] -> q Bool+isInTypeFamilyApp name tyFun tyArgs =+ case tyFun of+ DConT tcName -> go tcName+ _ -> pure False+ where+ go :: Name -> q Bool+ go tcName = do+ info <- dsReify tcName+ case info of+ Just (DTyConI dec _)+ | DOpenTypeFamilyD (DTypeFamilyHead _ bndrs _ _) <- dec+ -> withinFirstArgs bndrs+ | DClosedTypeFamilyD (DTypeFamilyHead _ bndrs _ _) _ <- dec+ -> withinFirstArgs bndrs+ _ -> pure False++ withinFirstArgs :: [a] -> q Bool+ withinFirstArgs bndrs =+ let firstArgs = take (length bndrs) tyArgs+ argFVs = foldMap fvDType firstArgs+ in pure $ name `elem` argFVs++-- A crude approximation of cond_functorOK from GHC. This checks that:+--+-- (1) There's at least one type variable in the data type.+-- (2) It doesn't constrain the last type variable, e.g., data T a = Eq a => MkT a+-- (3) It doesn't use the last type variable in the wrong place, e.g. data T a = MkT (X a a)+--+-- This skips some things that cond_functorOK checks for but are tricky to+-- implement in Template Haskell, such as if the last type variable in the+-- constructor's return type is universally quantified. For example,+-- functorLikeValidityChecks would accept the following example that+-- cond_functorOK would reject:+--+-- @+-- data T a b where+-- MkT :: z -> T z z -- Last type variable is existential+-- deriving instance Functor (T a)+-- @+--+-- This isn't the end of the world, as it just means that the user will have to+-- deal with a more complex error message when the generate code fails to+-- typecheck.+functorLikeValidityChecks :: forall q. DsMonad q => Bool -> DataDecl -> q ()+functorLikeValidityChecks allowConstrainedLastTyVar (DataDecl n data_tvbs cons)+ | null data_tvbs -- (1)+ = fail $ "Data type " ++ nameBase n ++ " must have some type parameters"+ | otherwise+ = mapM_ check_con cons+ where+ check_con :: DCon -> q ()+ check_con con = do+ check_universal con+ checks <- foldDataConArgs (ft_check (extractName con)) con+ sequence_ checks++ -- (2)+ check_universal :: DCon -> q ()+ check_universal (DCon _ con_theta con_name _ res_ty)+ | allowConstrainedLastTyVar+ = pure ()+ | (_, res_ty_args) <- unfoldDType res_ty+ , (_, last_res_ty_arg) <- snocView $ filterDTANormals res_ty_args+ , Just last_tv <- getDVarTName_maybe last_res_ty_arg+ = do if last_tv `OSet.notMember` foldMap fvDType con_theta+ then pure ()+ else fail $ badCon con_name existential+ | otherwise+ = fail $ badCon con_name existential++ -- (3)+ ft_check :: Name -> FFoldType (q ())+ ft_check con_name =+ FT { ft_triv = pure ()+ , ft_var = pure ()+ , ft_ty_app = \_ x -> x+ , ft_bad_app = fail $ badCon con_name wrong_arg+ , ft_forall = \_ x -> x+ }++ badCon :: Name -> String -> String+ badCon con_name msg = "Constructor " ++ nameBase con_name ++ " " ++ msg++ existential, wrong_arg :: String+ existential = "must be truly polymorphic in the last argument of the data type"+ wrong_arg = "must use the type variable only as the last argument of a data type"++-- Return all syntactic subterms of a type that contain the given variable somewhere.+-- These are the things that should appear in Functor-like instance constraints.+deepSubtypesContaining :: DsMonad q => Name -> DType -> q [DType]+deepSubtypesContaining tv+ = functorLikeTraverse tv+ (FT { ft_triv = []+ , ft_var = []+ , ft_ty_app = (:)+ , ft_bad_app = error "in other argument in deepSubtypesContaining"+ , ft_forall = \tvbs xs -> filter (\x -> all (not_in_ty x) tvbs) xs })+ where+ not_in_ty :: DType -> DTyVarBndrSpec -> Bool+ not_in_ty ty tvb = extractTvbName tvb `OSet.notMember` fvDType ty++-- Fold over the arguments of a data constructor in a Functor-like way.+foldDataConArgs :: forall q a. DsMonad q => FFoldType a -> DCon -> q [a]+foldDataConArgs ft (DCon _ _ _ fields res_ty) = do+ field_tys <- traverse expandType $ tysOfConFields fields+ traverse foldArg field_tys+ where+ foldArg :: DType -> q a+ foldArg+ | (_, res_ty_args) <- unfoldDType res_ty+ , (_, last_res_ty_arg) <- snocView $ filterDTANormals res_ty_args+ , Just last_tv <- getDVarTName_maybe last_res_ty_arg+ = functorLikeTraverse last_tv ft+ | otherwise+ = const (return (ft_triv ft))++-- If a type is a type variable (or a variable with a kind signature), return+-- 'Just' that. Otherwise, return 'Nothing'.+getDVarTName_maybe :: DType -> Maybe Name+getDVarTName_maybe (DSigT t _) = getDVarTName_maybe t+getDVarTName_maybe (DVarT n) = Just n+getDVarTName_maybe _ = Nothing++-- Make a 'DLamE' using a fresh variable.+mkSimpleLam :: Quasi q => (DExp -> q DExp) -> q DExp+mkSimpleLam lam = do+ n <- newUniqueName "n"+ body <- lam (DVarE n)+ return $ DLamE [n] body++-- Make a 'DLamE' using two fresh variables.+mkSimpleLam2 :: Quasi q => (DExp -> DExp -> q DExp) -> q DExp+mkSimpleLam2 lam = do+ n1 <- newUniqueName "n1"+ n2 <- newUniqueName "n2"+ body <- lam (DVarE n1) (DVarE n2)+ return $ DLamE [n1, n2] body++-- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"+--+-- @mkSimpleConClause fold extra_pats con insides@ produces a match clause in+-- which the LHS pattern-matches on @extra_pats@, followed by a match on the+-- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@+-- and its arguments, applying an expression (from @insides@) to each of the+-- respective arguments of @con@.+mkSimpleConClause :: Quasi q+ => (Name -> [DExp] -> DExp)+ -> [DPat]+ -> DCon+ -> [DExp]+ -> q DClause+mkSimpleConClause fold extra_pats (DCon _ _ con_name _ _) insides = do+ vars_needed <- replicateM (length insides) $ newUniqueName "a"+ let pat = DConP con_name (map DVarP vars_needed)+ rhs = fold con_name (zipWith (\i v -> i `DAppE` DVarE v) insides vars_needed)+ pure $ DClause (extra_pats ++ [pat]) rhs++-- 'True' if the derived class's last argument is of kind (Type -> Type),+-- and thus needs a different constraint inference approach.+--+-- Really, we should be determining this information by inspecting the kind+-- of the class being used. But that comes dangerously close to kind+-- inference territory, so for now we simply hardcode which stock derivable+-- classes are Functor-like.+isFunctorLikeClassName :: Name -> Bool+isFunctorLikeClassName class_name+ = class_name `elem` [functorName, foldableName, traversableName]
+ src/Data/Singletons/TH/Names.hs view
@@ -0,0 +1,254 @@+{- 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.+-}++{-# LANGUAGE TemplateHaskellQuotes #-}++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 ( Nat, Symbol )+import GHC.Exts ( Constraint )+import GHC.Show ( showCommaSpace, showSpace )+import Data.String (fromString)+import Data.Type.Equality ( TestEquality(..) )+import Data.Type.Coercion ( TestCoercion(..) )+import Control.Applicative++{-+Note [Wired-in Names]+~~~~~~~~~~~~~~~~~~~~~+The list of Names below contains everything that the Template Haskell machinery+needs to have special knowledge of. These names can be broadly categorized into+two groups:++1. Names of basic singleton definitions (Sing, SingKind, etc.). These are+ spliced directly into TH-generated code.+2. Names of definitions from the Prelude. These are not spliced into+ TH-generated code, but are instead used as the namesakes for promoted and+ singled definitions. For example, the TH machinery must be aware of the Name+ `fromInteger` so that it can promote and single the expression `42` to+ `FromInteger 42` and `sFromInteger (sing @42)`, respectively.++Note that we deliberately do not wire in promoted or singled Names, such as+FromInteger or sFromInteger, for two reasons:++a. We want all promoted and singled names to go through the naming options in+ D.S.TH.Options. Splicing the name FromInteger directly into TH-generated+ code, for instance, would prevent users from overriding the default options+ in order to promote `fromInteger` to something else (e.g.,+ MyCustomFromInteger).+b. Wired in names live in particular modules, so if we were to wire in the name+ FromInteger, it would come from GHC.Num.Singletons. This would effectively+ prevent anyone from defining their own version of FromInteger and+ piggybacking on top of the TH machinery to generate it, however. As a+ result, we generate the name FromInteger completely unqualified so that+ it picks up whichever version of FromInteger is in scope.+-}++boolName, andName, compareName, minBoundName,+ maxBoundName, repName,+ nilName, consName, listName, tyFunArrowName,+ applyName, applyTyConName, applyTyConAux1Name,+ natName, symbolName, stringName,+ eqName, ordName, boundedName, orderingName,+ singFamilyName, singIName, singMethName, demoteName, withSingIName,+ singKindClassName, someSingTypeName, someSingDataName,+ sDecideClassName, sDecideMethName,+ testEqualityClassName, testEqualityMethName, decideEqualityName,+ testCoercionClassName, testCoercionMethName, decideCoercionName,+ provedName, disprovedName, reflName, toSingName, fromSingName,+ equalityName, applySingName, suppressClassName, suppressMethodName,+ thenCmpName, sameKindName, fromIntegerName, negateName,+ errorName, foldlName, cmpEQName, cmpLTName, cmpGTName,+ toEnumName, fromEnumName, enumName,+ equalsName, constraintName,+ showName, showSName, showCharName, showCommaSpaceName, showParenName, showsPrecName,+ showSpaceName, showStringName, showSingName,+ composeName, gtName, fromStringName,+ foldableName, foldMapName, memptyName, mappendName, foldrName,+ functorName, fmapName, replaceName,+ traversableName, traverseName, pureName, apName, liftA2Name :: Name+boolName = ''Bool+andName = '(&&)+compareName = 'compare+minBoundName = 'minBound+maxBoundName = 'maxBound+repName = mkName "Rep" -- this is actually defined in client code!+nilName = '[]+consName = '(:)+listName = ''[]+tyFunArrowName = ''(~>)+applyName = ''Apply+applyTyConName = ''ApplyTyCon+applyTyConAux1Name = ''ApplyTyConAux1+symbolName = ''Symbol+natName = ''Nat+stringName = ''String+eqName = ''Eq+ordName = ''Ord+boundedName = ''Bounded+orderingName = ''Ordering+singFamilyName = ''Sing+singIName = ''SingI+singMethName = 'sing+toSingName = 'toSing+fromSingName = 'fromSing+demoteName = ''Demote+withSingIName = 'withSingI+singKindClassName = ''SingKind+someSingTypeName = ''SomeSing+someSingDataName = 'SomeSing+sDecideClassName = ''SDecide+sDecideMethName = '(%~)+testEqualityClassName = ''TestEquality+testEqualityMethName = 'testEquality+decideEqualityName = 'decideEquality+testCoercionClassName = ''TestCoercion+testCoercionMethName = 'testCoercion+decideCoercionName = 'decideCoercion+provedName = 'Proved+disprovedName = 'Disproved+reflName = 'Refl+equalityName = ''(~)+applySingName = 'applySing+suppressClassName = ''SuppressUnusedWarnings+suppressMethodName = 'suppressUnusedWarnings+thenCmpName = 'thenCmp+sameKindName = ''SameKind+fromIntegerName = 'fromInteger+negateName = 'negate+errorName = 'error+foldlName = 'foldl+cmpEQName = 'EQ+cmpLTName = 'LT+cmpGTName = 'GT+toEnumName = 'toEnum+fromEnumName = 'fromEnum+enumName = ''Enum+equalsName = '(==)+constraintName = ''Constraint+showName = ''Show+showSName = ''ShowS+showCharName = 'showChar+showParenName = 'showParen+showSpaceName = 'showSpace+showsPrecName = 'showsPrec+showStringName = 'showString+showSingName = ''ShowSing+composeName = '(.)+gtName = '(>)+showCommaSpaceName = 'showCommaSpace+fromStringName = 'fromString+foldableName = ''Foldable+foldMapName = 'foldMap+memptyName = 'mempty+mappendName = 'mappend+foldrName = 'foldr+functorName = ''Functor+fmapName = 'fmap+replaceName = '(<$)+traversableName = ''Traversable+traverseName = 'traverse+pureName = 'pure+apName = '(<*>)+liftA2Name = 'liftA2++mkTyName :: Quasi q => Name -> q Name+mkTyName tmName = do+ let nameStr = nameBase tmName+ symbolic = not (isHsLetter (head nameStr))+ qNewName (if symbolic then "ty" else nameStr)++mkTyConName :: Int -> Name+mkTyConName i = mkName $ "TyCon" ++ show i++boolKi :: DKind+boolKi = DConT boolName++singFamily :: DType+singFamily = DConT singFamilyName++singKindConstraint :: DKind -> DPred+singKindConstraint = DAppT (DConT singKindClassName)++demote :: DType+demote = DConT demoteName++apply :: DType -> DType -> DType+apply t1 t2 = DAppT (DAppT (DConT applyName) t1) t2++mkListE :: [DExp] -> DExp+mkListE =+ foldr (\h t -> DConE consName `DAppE` h `DAppE` t) (DConE nilName)++-- apply a type to a list of types using Apply type family+-- This is defined here, not in Utils, to avoid cyclic dependencies+foldApply :: DType -> [DType] -> DType+foldApply = foldl apply++-- make an equality predicate+mkEqPred :: DType -> DType -> DPred+mkEqPred ty1 ty2 = foldType (DConT equalityName) [ty1, ty2]++-- | If a 'String' begins with one or more underscores, return+-- @'Just' (us, rest)@, where @us@ contain all of the underscores at the+-- beginning of the 'String' and @rest@ contains the remainder of the 'String'.+-- Otherwise, return 'Nothing'.+splitUnderscores :: String -> Maybe (String, String)+splitUnderscores s = case span (== '_') s of+ ([], _) -> Nothing+ res -> Just res++-- Walk a DType, applying a function to all occurrences of constructor names.+modifyConNameDType :: (Name -> Name) -> DType -> DType+modifyConNameDType mod_con_name = go+ where+ go :: DType -> DType+ go (DForallT tele p) = DForallT tele (go p)+ go (DConstrainedT cxt p) = DConstrainedT (map go cxt) (go p)+ go (DAppT p t) = DAppT (go p) t+ go (DAppKindT p k) = DAppKindT (go p) k+ go (DSigT p k) = DSigT (go p) k+ go p@(DVarT _) = p+ go (DConT n) = DConT (mod_con_name n)+ go p@DWildCardT = p+ go p@(DLitT {}) = p+ go p@DArrowT = p++{-+Note [Defunctionalization symbol suffixes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Before, we used to denote defunctionalization symbols by simply appending dollar+signs at the end (e.g., (+$) and (+$$)). But this can lead to ambiguity when you+have function names that consist of solely $ characters. For instance, if you+tried to promote ($) and ($$) simultaneously, you'd get these promoted types:++$+$$++And these defunctionalization symbols:++$$+$$$++But now there's a name clash between the promoted type for ($) and the+defunctionalization symbol for ($$)! The solution is to use a precede these+defunctionalization dollar signs with another string (we choose @#@).+So now the new defunctionalization symbols would be:++$@#@$+$@#@$$++And there is no conflict.+-}
+ src/Data/Singletons/TH/Options.hs view
@@ -0,0 +1,343 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-----------------------------------------------------------------------------+-- |+-- Module : Data.Singletons.TH.Options+-- Copyright : (C) 2019 Ryan Scott+-- License : BSD-style (see LICENSE)+-- Maintainer : Ryan Scott+-- Stability : experimental+-- Portability : non-portable+--+-- This module defines 'Options' that control finer details of how the Template+-- Haskell machinery works, as well as an @mtl@-like 'OptionsMonad' class+-- and an 'OptionsM' monad transformer.+--+----------------------------------------------------------------------------++module Data.Singletons.TH.Options+ ( -- * Options+ Options, defaultOptions+ -- ** Options record selectors+ , genQuotedDecs+ , genSingKindInsts+ , promotedDataTypeOrConName+ , promotedClassName+ , promotedValueName+ , singledDataTypeName+ , singledClassName+ , singledDataConName+ , singledValueName+ , defunctionalizedName+ -- ** Derived functions over Options+ , promotedTopLevelValueName+ , promotedLetBoundValueName+ , defunctionalizedName0++ -- * OptionsMonad+ , OptionsMonad(..), OptionsM, withOptions+ ) where++import Control.Applicative+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Reader (ReaderT(..), ask)+import Control.Monad.RWS (RWST)+import Control.Monad.State (StateT)+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Writer (WriterT)+import Data.Singletons.TH.Names+import Data.Singletons.TH.Util+import Language.Haskell.TH.Desugar+import Language.Haskell.TH.Instances () -- To obtain a Quote instance for ReaderT+import Language.Haskell.TH.Syntax hiding (Lift(..))++-- | Options that control the finer details of how @singletons-th@'s Template+-- Haskell machinery works.+data Options = Options+ { genQuotedDecs :: Bool+ -- ^ If 'True', then quoted declarations will be generated alongside their+ -- promoted and singled counterparts. If 'False', then quoted+ -- declarations will be discarded.+ , genSingKindInsts :: Bool+ -- ^ If 'True', then 'SingKind' instances will be generated. If 'False',+ -- they will be omitted entirely. This can be useful in scenarios where+ -- TH-generated 'SingKind' instances do not typecheck (for instance,+ -- when generating singletons for GADTs).+ , promotedDataTypeOrConName :: Name -> Name+ -- ^ Given the name of the original data type or data constructor, produces+ -- the name of the promoted equivalent. Unlike the singling-related+ -- options, in which there are separate 'singledDataTypeName' and+ -- 'singledDataConName' functions, we combine the handling of promoted+ -- data types and data constructors into a single option. This is because+ -- the names of promoted data types and data constructors can be+ -- difficult to distinguish in certain contexts without expensive+ -- compile-time checks.+ --+ -- Because of the @DataKinds@ extension, most data type and data+ -- constructor names can be used in promoted contexts without any+ -- changes. As a result, this option will act like the identity function+ -- 99% of the time. There are some situations where it can be useful to+ -- override this option, however, as it can be used to promote primitive+ -- data types that do not have proper type-level equivalents, such as+ -- 'Natural' and 'Text'. See the+ -- \"Arrows, 'Nat', 'Symbol', and literals\" section of the @singletons@+ -- @<https://github.com/goldfirere/singletons/blob/master/README.md README>@+ -- for more details.+ , promotedClassName :: Name -> Name+ -- ^ Given the name of the original, unrefined class, produces the name of+ -- the promoted equivalent of the class.+ , promotedValueName :: Name -> Maybe Uniq -> Name+ -- ^ Given the name of the original, unrefined value, produces the name of+ -- the promoted equivalent of the value. This is used for both top-level+ -- and @let@-bound names, and the difference is encoded in the+ -- @'Maybe' 'Uniq'@ argument. If promoting a top-level name, the argument+ -- is 'Nothing'. If promoting a @let@-bound name, the argument is+ -- @Just uniq@, where @uniq@ is a globally unique number that can be used+ -- to distinguish the name from other local definitions of the same name+ -- (e.g., if two functions both use @let x = ... in x@).+ , singledDataTypeName :: Name -> Name+ -- ^ Given the name of the original, unrefined data type, produces the name+ -- of the corresponding singleton type.+ , singledClassName :: Name -> Name+ -- ^ Given the name of the original, unrefined class, produces the name of+ -- the singled equivalent of the class.+ , singledDataConName :: Name -> Name+ -- ^ Given the name of the original, unrefined data constructor, produces+ -- the name of the corresponding singleton data constructor.+ , singledValueName :: Name -> Name+ -- ^ Given the name of the original, unrefined value, produces the name of+ -- the singled equivalent of the value.+ , defunctionalizedName :: Name -> Int -> Name+ -- ^ Given the original name and the number of parameters it is applied to+ -- (the 'Int' argument), produces a type-level function name that can be+ -- partially applied when given the same number of parameters.+ --+ -- Note that defunctionalization works over both term-level names+ -- (producing symbols for the promoted name) and type-level names+ -- (producing symbols directly for the name itself). As a result, this+ -- callback is used for names in both the term and type namespaces.+ }++-- | Sensible default 'Options'.+--+-- 'genQuotedDecs' defaults to 'True'.+-- That is, quoted declarations are generated alongside their promoted and+-- singled counterparts.+--+-- 'genSingKindInsts' defaults to 'True'.+-- That is, 'SingKind' instances are generated.+--+-- The default behaviors for 'promotedClassName', 'promotedValueNamePrefix',+-- 'singledDataTypeName', 'singledClassName', 'singledDataConName',+-- 'singledValueName', and 'defunctionalizedName' are described in the+-- \"On names\" section of the @singletons@+-- @<https://github.com/goldfirere/singletons/blob/master/README.md README>@.+defaultOptions :: Options+defaultOptions = Options+ { genQuotedDecs = True+ , genSingKindInsts = True+ , promotedDataTypeOrConName = promoteDataTypeOrConName+ , promotedClassName = promoteClassName+ , promotedValueName = promoteValNameLhs+ , singledDataTypeName = singTyConName+ , singledClassName = singClassName+ , singledDataConName = singDataConName+ , singledValueName = singValName+ , defunctionalizedName = promoteTySym+ }++-- | Given the name of the original, unrefined, top-level value, produces the+-- name of the promoted equivalent of the value.+promotedTopLevelValueName :: Options -> Name -> Name+promotedTopLevelValueName opts name = promotedValueName opts name Nothing++-- | Given the name of the original, unrefined, @let@-bound value and its+-- globally unique number, produces the name of the promoted equivalent of the+-- value.+promotedLetBoundValueName :: Options -> Name -> Uniq -> Name+promotedLetBoundValueName opts name = promotedValueName opts name . Just++-- | Given the original name of a function (term- or type-level), produces a+-- type-level function name that can be partially applied even without being+-- given any arguments (i.e., @0@ arguments).+defunctionalizedName0 :: Options -> Name -> Name+defunctionalizedName0 opts name = defunctionalizedName opts name 0++-- | Class that describes monads that contain 'Options'.+class DsMonad m => OptionsMonad m where+ getOptions :: m Options++instance OptionsMonad Q where+ getOptions = pure defaultOptions++instance OptionsMonad m => OptionsMonad (DsM m) where+ getOptions = lift getOptions++instance (OptionsMonad q, Monoid m) => OptionsMonad (QWithAux m q) where+ getOptions = lift getOptions++instance OptionsMonad m => OptionsMonad (ReaderT r m) where+ getOptions = lift getOptions++instance OptionsMonad m => OptionsMonad (StateT s m) where+ getOptions = lift getOptions++instance (OptionsMonad m, Monoid w) => OptionsMonad (WriterT w m) where+ getOptions = lift getOptions++instance (OptionsMonad m, Monoid w) => OptionsMonad (RWST r w s m) where+ getOptions = lift getOptions++-- | A convenient implementation of the 'OptionsMonad' class. Use by calling+-- 'withOptions'.+newtype OptionsM m a = OptionsM (ReaderT Options m a)+ deriving ( Functor, Applicative, Monad, MonadTrans+ , Quote, Quasi, MonadFail, MonadIO, DsMonad )++-- | Turn any 'DsMonad' into an 'OptionsMonad'.+instance DsMonad m => OptionsMonad (OptionsM m) where+ getOptions = OptionsM ask++-- | Declare the 'Options' that a TH computation should use.+withOptions :: Options -> OptionsM m a -> m a+withOptions opts (OptionsM x) = runReaderT x opts++-- Used when a value name appears in a pattern context.+-- Works only for proper variables (lower-case names).+--+-- If the Maybe Uniq argument is Nothing, then the name is top-level (and+-- thus globally unique on its own).+-- If the Maybe Uniq argument is `Just uniq`, then the name is let-bound and+-- should use `uniq` to make the promoted name globally unique.+promoteValNameLhs :: Name -> Maybe Uniq -> Name+promoteValNameLhs n mb_let_uniq+ -- We can't promote promote idenitifers beginning with underscores to+ -- type names, so we work around the issue by prepending "US" at the+ -- front of the name (#229).+ | Just (us, rest) <- splitUnderscores (nameBase n)+ = mkName $ alpha ++ "US" ++ us ++ rest++ | otherwise+ = mkName $ toUpcaseStr pres n+ where+ pres = maybe noPrefix (uniquePrefixes "Let" "<<<") mb_let_uniq+ (alpha, _) = pres++-- generates type-level symbol for a given name. Int parameter represents+-- saturation: 0 - no parameters passed to the symbol, 1 - one parameter+-- passed to the symbol, and so on. Works on both promoted and unpromoted+-- names.+promoteTySym :: Name -> Int -> Name+promoteTySym name sat+ -- We can't promote promote idenitifers beginning with underscores to+ -- type names, so we work around the issue by prepending "US" at the+ -- front of the name (#229).+ | Just (us, rest) <- splitUnderscores (nameBase name)+ = default_case (mkName $ "US" ++ us ++ rest)++ | name == nilName+ = mkName $ "NilSym" ++ (show sat)++ -- Treat unboxed tuples like tuples.+ -- See Note [Promoting and singling unboxed tuples].+ | Just degree <- tupleNameDegree_maybe name <|>+ unboxedTupleNameDegree_maybe name+ = mkName $ "Tuple" ++ show degree ++ "Sym" ++ show sat++ | otherwise+ = default_case name+ where+ default_case :: Name -> Name+ default_case name' =+ let capped = toUpcaseStr noPrefix name' in+ if isHsLetter (head capped)+ then mkName (capped ++ "Sym" ++ (show sat))+ else mkName (capped ++ "@#@" -- See Note [Defunctionalization symbol suffixes]+ ++ (replicate (sat + 1) '$'))++promoteClassName :: Name -> Name+promoteClassName = prefixName "P" "#"++promoteDataTypeOrConName :: Name -> Name+promoteDataTypeOrConName nm+ | nameBase nm == nameBase repName = typeKindName+ -- See Note [Promoting and singling unboxed tuples]+ | Just degree <- unboxedTupleNameDegree_maybe nm+ = if isDataName nm then tupleDataName degree else tupleTypeName degree+ | otherwise = nm+ where+ -- Is this name a data constructor name? A 'False' answer means "unsure".+ isDataName :: Name -> Bool+ isDataName (Name _ (NameG DataName _ _)) = True+ isDataName _ = False++-- Singletons++singDataConName :: Name -> Name+singDataConName nm+ | nm == nilName = mkName "SNil"+ | nm == consName = mkName "SCons"+ | Just degree <- tupleNameDegree_maybe nm = mkTupleName degree+ -- See Note [Promoting and singling unboxed tuples]+ | Just degree <- unboxedTupleNameDegree_maybe nm = mkTupleName degree+ | otherwise = prefixConName "S" "%" nm++singTyConName :: Name -> Name+singTyConName name+ | name == listName = mkName "SList"+ | Just degree <- tupleNameDegree_maybe name = mkTupleName degree+ -- See Note [Promoting and singling unboxed tuples]+ | Just degree <- unboxedTupleNameDegree_maybe name = mkTupleName degree+ | otherwise = prefixName "S" "%" name++mkTupleName :: Int -> Name+mkTupleName n = mkName $ "STuple" ++ show n++singClassName :: Name -> Name+singClassName = singTyConName++singValName :: Name -> Name+singValName n+ -- Push the 's' past the underscores, as this lets us avoid some unused+ -- variable warnings (#229).+ | Just (us, rest) <- splitUnderscores (nameBase n)+ = prefixName (us ++ "s") "%" $ mkName rest+ | otherwise+ = prefixName "s" "%" $ upcase n++{-+Note [Promoting and singling unboxed tuples]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Unfortunately, today's GHC is not quite up to the task of promoting types+involving unboxed tuples. Consider this example:++ swapperino :: (# a, b #) -> (# b, a #)++What would this look like when promoted? Presumably, it would have a kind+signature like this:++ type Swapperino :: (# a, b #) -> (# b, a #)++Surprisingly, this won't kindcheck:++ error:+ • Expecting a lifted type, but ‘(# a, b #)’ is unlifted+ • In a standalone kind signature for ‘Swapperino’:+ (# a, b #) -> (# b, a #)++Even though (->) is levity polymorphic, this levity polymorphism only kicks in+for types, not kinds. In other words, the (->) in the kind of Swapperino is+completely levity monomorphic and only accepts Type-kinded arguments. This+oddity is tracked upstream as GHC#14180. Until that is fixed, there is no hope+of using promoted unboxed tuples freely in kinds.++However, we don't have to give up quite yet. As a crude-but-effective+workaround, we can simply promote value-level unboxed tuples to type-level boxed+tuples. In other words, we would promote swapperino to this:++ type Swapperino :: (a, b) -> (b, a)++This trick is enough to make many (but not all) uses of unboxed tuples+Just Work™ when promoted. We use a similar trick when singling unboxed tuples+as well.+-}
+ src/Data/Singletons/TH/Partition.hs view
@@ -0,0 +1,329 @@+-----------------------------------------------------------------------------+-- |+-- 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+--+----------------------------------------------------------------------------++{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++module Data.Singletons.TH.Partition where++import Prelude hiding ( exp )+import Data.Singletons.TH.Deriving.Bounded+import Data.Singletons.TH.Deriving.Enum+import Data.Singletons.TH.Deriving.Eq+import Data.Singletons.TH.Deriving.Foldable+import Data.Singletons.TH.Deriving.Functor+import Data.Singletons.TH.Deriving.Ord+import Data.Singletons.TH.Deriving.Show+import Data.Singletons.TH.Deriving.Traversable+import Data.Singletons.TH.Deriving.Util+import Data.Singletons.TH.Names+import Data.Singletons.TH.Options+import Data.Singletons.TH.Syntax+import Data.Singletons.TH.Util+import Language.Haskell.TH.Syntax hiding (showName)+import Language.Haskell.TH.Ppr+import Language.Haskell.TH.Desugar+import qualified Language.Haskell.TH.Desugar.OMap.Strict as OMap+import Language.Haskell.TH.Desugar.OMap.Strict (OMap)++import Control.Monad+import Data.Bifunctor (bimap)+import qualified Data.Map as Map+import Data.Map (Map)+import Data.Maybe++data PartitionedDecs =+ PDecs { pd_let_decs :: [DLetDec]+ , pd_class_decs :: [UClassDecl]+ , pd_instance_decs :: [UInstDecl]+ , pd_data_decs :: [DataDecl]+ , pd_ty_syn_decs :: [TySynDecl]+ , pd_open_type_family_decs :: [OpenTypeFamilyDecl]+ , pd_closed_type_family_decs :: [ClosedTypeFamilyDecl]+ , pd_derived_eq_decs :: [DerivedEqDecl]+ , pd_derived_show_decs :: [DerivedShowDecl]+ }++instance Semigroup PartitionedDecs where+ PDecs a1 b1 c1 d1 e1 f1 g1 h1 i1 <> PDecs a2 b2 c2 d2 e2 f2 g2 h2 i2 =+ PDecs (a1 <> a2) (b1 <> b2) (c1 <> c2) (d1 <> d2) (e1 <> e2)+ (f1 <> f2) (g1 <> g2) (h1 <> h2) (i1 <> i2)++instance Monoid PartitionedDecs where+ mempty = PDecs mempty mempty mempty mempty mempty+ mempty mempty mempty mempty++-- | Split up a @[DDec]@ into its pieces, extracting 'Ord' instances+-- from deriving clauses+partitionDecs :: OptionsMonad m => [DDec] -> m PartitionedDecs+partitionDecs = concatMapM partitionDec++partitionDec :: OptionsMonad m => DDec -> m PartitionedDecs+partitionDec (DLetDec (DPragmaD {})) = return mempty+partitionDec (DLetDec letdec) = return $ mempty { pd_let_decs = [letdec] }++partitionDec (DDataD _nd _cxt name tvbs mk cons derivings) = do+ all_tvbs <- buildDataDTvbs tvbs mk+ let data_decl = DataDecl name all_tvbs cons+ derived_dec = mempty { pd_data_decs = [data_decl] }+ derived_decs+ <- mapM (\(strat, deriv_pred) ->+ let etad_tvbs+ | (DConT pred_name, _) <- unfoldDType deriv_pred+ , isFunctorLikeClassName pred_name+ -- If deriving Functor, Foldable, or Traversable,+ -- we need to use one less type variable than we normally do.+ = take (length all_tvbs - 1) all_tvbs+ | otherwise+ = all_tvbs+ ty = foldTypeTvbs (DConT name) etad_tvbs+ in partitionDeriving strat deriv_pred Nothing ty data_decl)+ $ concatMap flatten_clause derivings+ return $ mconcat $ derived_dec : derived_decs+ where+ flatten_clause :: DDerivClause -> [(Maybe DDerivStrategy, DPred)]+ flatten_clause (DDerivClause strat preds) =+ map (\p -> (strat, p)) preds++partitionDec (DClassD cxt name tvbs fds decs) = do+ (lde, otfs) <- concatMapM partitionClassDec decs+ return $ mempty { pd_class_decs = [ClassDecl { cd_cxt = cxt+ , cd_name = name+ , cd_tvbs = tvbs+ , cd_fds = fds+ , cd_lde = lde+ , cd_atfs = otfs}] }+partitionDec (DInstanceD _ _ cxt ty decs) = do+ (defns, sigs) <- liftM (bimap catMaybes mconcat) $+ mapAndUnzipM partitionInstanceDec decs+ (name, tys) <- split_app_tys [] ty+ return $ mempty { pd_instance_decs = [InstDecl { id_cxt = cxt+ , id_name = name+ , id_arg_tys = tys+ , id_sigs = sigs+ , id_meths = defns }] }+ where+ split_app_tys acc (DAppT t1 t2) = split_app_tys (t2:acc) t1+ split_app_tys acc (DConT name) = return (name, acc)+ split_app_tys acc (DSigT t _) = split_app_tys acc t+ split_app_tys _ _ = fail $ "Illegal instance head: " ++ show ty+partitionDec (DRoleAnnotD {}) = return mempty -- ignore these+partitionDec (DTySynD name tvbs rhs) =+ -- See Note [Partitioning, type synonyms, and type families]+ pure $ mempty { pd_ty_syn_decs = [TySynDecl name tvbs rhs] }+partitionDec (DClosedTypeFamilyD tf_head _) =+ -- See Note [Partitioning, type synonyms, and type families]+ pure $ mempty { pd_closed_type_family_decs = [TypeFamilyDecl tf_head] }+partitionDec (DOpenTypeFamilyD tf_head) =+ -- See Note [Partitioning, type synonyms, and type families]+ pure $ mempty { pd_open_type_family_decs = [TypeFamilyDecl tf_head] }+partitionDec (DTySynInstD {}) = pure mempty+ -- There's no need to track type family instances, since+ -- we already record the type family itself separately.+partitionDec (DKiSigD {}) = pure mempty+ -- There's no need to track standalone kind signatures, since we use+ -- dsReifyType to look them up.+partitionDec (DStandaloneDerivD mb_strat _ ctxt ty) =+ case unfoldDType ty of+ (cls_pred_ty, cls_tys)+ | let cls_normal_tys = filterDTANormals cls_tys+ , not (null cls_normal_tys) -- We can't handle zero-parameter type classes+ , let cls_arg_tys = init cls_normal_tys+ data_ty = last cls_normal_tys+ data_ty_head = case unfoldDType data_ty of (ty_head, _) -> ty_head+ , DConT data_tycon <- data_ty_head -- We can't handle deriving an instance for something+ -- other than a type constructor application+ -> do let cls_pred = foldType cls_pred_ty cls_arg_tys+ dinfo <- dsReify data_tycon+ case dinfo of+ Just (DTyConI (DDataD _ _ dn dtvbs dk dcons _) _) -> do+ all_tvbs <- buildDataDTvbs dtvbs dk+ let data_decl = DataDecl dn all_tvbs dcons+ partitionDeriving mb_strat cls_pred (Just ctxt) data_ty data_decl+ Just _ ->+ fail $ "Standalone derived instance for something other than a datatype: "+ ++ show data_ty+ _ -> fail $ "Cannot find " ++ show data_ty+ _ -> return mempty+partitionDec dec =+ fail $ "Declaration cannot be promoted: " ++ pprint (decToTH dec)++partitionClassDec :: MonadFail m => DDec -> m (ULetDecEnv, [OpenTypeFamilyDecl])+partitionClassDec (DLetDec (DSigD name ty)) =+ pure (typeBinding name ty, mempty)+partitionClassDec (DLetDec (DValD (DVarP name) exp)) =+ pure (valueBinding name (UValue exp), mempty)+partitionClassDec (DLetDec (DFunD name clauses)) =+ pure (valueBinding name (UFunction clauses), mempty)+partitionClassDec (DLetDec (DInfixD fixity name)) =+ pure (infixDecl fixity name, mempty)+partitionClassDec (DLetDec (DPragmaD {})) =+ pure (mempty, mempty)+partitionClassDec (DOpenTypeFamilyD tf_head) =+ -- See Note [Partitioning, type synonyms, and type families]+ pure (mempty, [TypeFamilyDecl tf_head])+partitionClassDec (DTySynInstD {}) =+ -- There's no need to track associated type family default equations, since+ -- we already record the type family itself separately.+ pure (mempty, mempty)+partitionClassDec _ =+ fail "Only method declarations can be promoted within a class."++partitionInstanceDec :: MonadFail m => DDec+ -> m ( Maybe (Name, ULetDecRHS) -- right-hand sides of methods+ , OMap Name DType -- method type signatures+ )+partitionInstanceDec (DLetDec (DValD (DVarP name) exp)) =+ pure (Just (name, UValue exp), mempty)+partitionInstanceDec (DLetDec (DFunD name clauses)) =+ pure (Just (name, UFunction clauses), mempty)+partitionInstanceDec (DLetDec (DSigD name ty)) =+ pure (Nothing, OMap.singleton name ty)+partitionInstanceDec (DLetDec (DPragmaD {})) =+ pure (Nothing, mempty)+partitionInstanceDec (DTySynInstD {}) =+ pure (Nothing, mempty)+ -- There's no need to track associated type family instances, since+ -- we already record the type family itself separately.+partitionInstanceDec _ =+ fail "Only method bodies can be promoted within an instance."++partitionDeriving+ :: forall m. OptionsMonad m+ => Maybe DDerivStrategy+ -- ^ The deriving strategy, if present.+ -> DPred -- ^ The class being derived (e.g., 'Eq'), possibly applied to+ -- some number of arguments (e.g., @C Int Bool@).+ -> Maybe DCxt -- ^ @'Just' ctx@ if @ctx@ was provided via @StandaloneDeriving@.+ -- 'Nothing' if using a @deriving@ clause.+ -> DType -- ^ The data type argument to the class.+ -> DataDecl -- ^ The original data type information (e.g., its constructors).+ -> m PartitionedDecs+partitionDeriving mb_strat deriv_pred mb_ctxt ty data_decl =+ case unfoldDType deriv_pred of+ (DConT deriv_name, arg_tys)+ -- Here, we are more conservative than GHC: DeriveAnyClass only kicks+ -- in if the user explicitly chooses to do so with the anyclass+ -- deriving strategy+ | Just DAnyclassStrategy <- mb_strat+ -> return $ mk_derived_inst+ InstDecl { id_cxt = fromMaybe [] mb_ctxt+ -- For now at least, there's no point in attempting to+ -- infer an instance context for DeriveAnyClass, since+ -- the other language feature that requires it,+ -- DefaultSignatures, can't be singled. Thus, inferring an+ -- empty context will Just Work for all currently supported+ -- default implementations.+ --+ -- (Of course, if a user specifies a context with+ -- StandaloneDeriving, use that.)++ , id_name = deriv_name+ , id_arg_tys = filterDTANormals arg_tys ++ [ty]+ , id_sigs = mempty+ , id_meths = [] }++ | Just DNewtypeStrategy <- mb_strat+ -> do qReportWarning "GeneralizedNewtypeDeriving is ignored by `singletons-th`."+ return mempty++ | Just (DViaStrategy {}) <- mb_strat+ -> do qReportWarning "DerivingVia is ignored by `singletons-th`."+ return mempty++ -- Stock classes. These are derived only if `singletons-th` supports them+ -- (and, optionally, if an explicit stock deriving strategy is used)+ (DConT deriv_name, []) -- For now, all stock derivable class supported in+ -- singletons-th take just one argument (the data+ -- type itself)+ | stock_or_default+ , Just decs <- Map.lookup deriv_name stock_map+ -> decs++ -- If we can't find a stock class, but the user bothered to use an+ -- explicit stock keyword, we can at least warn them about it.+ | Just DStockStrategy <- mb_strat+ -> do qReportWarning $ "`singletons-th` doesn't recognize the stock class "+ ++ nameBase deriv_name+ return mempty++ _ -> return mempty -- singletons-th doesn't support deriving this instance+ where+ mk_instance :: DerivDesc m -> m UInstDecl+ mk_instance maker = maker mb_ctxt ty data_decl++ mk_derived_inst dec = mempty { pd_instance_decs = [dec] }++ derived_decl :: DerivedDecl cls+ derived_decl = DerivedDecl { ded_mb_cxt = mb_ctxt+ , ded_type = ty+ , ded_type_tycon = ty_tycon+ , ded_decl = data_decl }+ where+ ty_tycon :: Name+ ty_tycon = case unfoldDType ty of+ (DConT tc, _) -> tc+ (t, _) -> error $ "Not a data type: " ++ show t+ stock_or_default = isStockOrDefault mb_strat++ -- A mapping from all stock derivable classes (that singletons-th supports)+ -- to to derived code that they produce.+ stock_map :: Map Name (m PartitionedDecs)+ stock_map = Map.fromList+ [ ( ordName, mk_derived_inst <$> mk_instance mkOrdInstance )+ , ( boundedName, mk_derived_inst <$> mk_instance mkBoundedInstance )+ , ( enumName, mk_derived_inst <$> mk_instance mkEnumInstance )+ , ( functorName, mk_derived_inst <$> mk_instance mkFunctorInstance )+ , ( foldableName, mk_derived_inst <$> mk_instance mkFoldableInstance )+ , ( traversableName, mk_derived_inst <$> mk_instance mkTraversableInstance )++ -- See Note [DerivedDecl] in Data.Singletons.TH.Syntax+ , ( eqName, do -- These will become PEq/SEq instances...+ inst_for_promotion <- mk_instance mkEqInstance+ -- ...and these will become SDecide/TestEquality/TestCoercion instances.+ let inst_for_decide = derived_decl+ return $ mempty { pd_instance_decs = [inst_for_promotion]+ , pd_derived_eq_decs = [inst_for_decide] } )+ , ( showName, do -- These will become PShow/SShow instances...+ inst_for_promotion <- mk_instance mkShowInstance+ -- ...and this will become a Show instance.+ let inst_for_show = derived_decl+ pure $ mempty { pd_instance_decs = [inst_for_promotion]+ , pd_derived_show_decs = [inst_for_show] } )+ ]++-- Is this being used with an explicit stock strategy, or no strategy at all?+isStockOrDefault :: Maybe DDerivStrategy -> Bool+isStockOrDefault Nothing = True+isStockOrDefault (Just DStockStrategy) = True+isStockOrDefault (Just _) = False++{-+Note [Partitioning, type synonyms, and type families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The process of singling does not produce any new declarations corresponding to+type synonyms or type families, so they are "ignored" in a sense. Nevertheless,+we explicitly track them during partitioning, since we want to create+defunctionalization symbols for them.++Also note that:++1. Other uses of type synonyms in singled code will be expanded away.+2. Other uses of type families in singled code are unlikely to work at present+ due to Trac #12564.+3. We track open type families, closed type families, and associated type+ families separately, as each form of type family has different kind+ inference behavior. See defunTopLevelTypeDecls and+ defunAssociatedTypeFamilies in D.S.TH.Promote.Defun for how these differences+ manifest.+-}
+ src/Data/Singletons/TH/Promote.hs view
@@ -0,0 +1,1163 @@+{- 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.+-}++{-# LANGUAGE MultiWayIf, LambdaCase, TupleSections, ScopedTypeVariables #-}++module Data.Singletons.TH.Promote where++import Language.Haskell.TH hiding ( Q, cxt )+import Language.Haskell.TH.Syntax ( NameSpace(..), Quasi(..), Uniq )+import Language.Haskell.TH.Desugar+import qualified Language.Haskell.TH.Desugar.OMap.Strict as OMap+import Language.Haskell.TH.Desugar.OMap.Strict (OMap)+import qualified Language.Haskell.TH.Desugar.OSet as OSet+import Language.Haskell.TH.Desugar.OSet (OSet)+import Data.Singletons.TH.Deriving.Bounded+import Data.Singletons.TH.Deriving.Enum+import Data.Singletons.TH.Deriving.Eq+import Data.Singletons.TH.Deriving.Ord+import Data.Singletons.TH.Deriving.Show+import Data.Singletons.TH.Deriving.Util+import Data.Singletons.TH.Names+import Data.Singletons.TH.Options+import Data.Singletons.TH.Partition+import Data.Singletons.TH.Promote.Defun+import Data.Singletons.TH.Promote.Monad+import Data.Singletons.TH.Promote.Type+import Data.Singletons.TH.Syntax+import Data.Singletons.TH.Util+import Prelude hiding (exp)+import Control.Applicative (Alternative(..))+import Control.Arrow (second)+import Control.Monad+import Control.Monad.Trans.Maybe+import Control.Monad.Writer+import Data.List (nub)+import qualified Data.Map.Strict as Map+import Data.Map.Strict ( Map )+import Data.Maybe+import qualified GHC.LanguageExtensions.Type as LangExt++{-+Note [Disable genQuotedDecs in genPromotions and genSingletons]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Somewhat curiously, the genPromotions and genSingletons functions set the+genQuotedDecs option to False, despite neither function accepting quoted+declarations as arguments in the first place. There is a good reason for doing+this, however. Imagine this code:++ class C a where+ infixl 9 <%%>+ (<%%>) :: a -> a -> a+ $(genPromotions [''C])++If genQuotedDecs is set to True, then the (<%%>) type family will not receive+a fixity declaration (see+Note [singletons-th and fixity declarations] in D.S.TH.Single.Fixity, wrinkle 1 for+more details on this point). Therefore, we set genQuotedDecs to False to avoid+this problem.+-}++-- | Generate promoted definitions for each of the provided type-level+-- declaration 'Name's. This is generally only useful with classes.+genPromotions :: OptionsMonad q => [Name] -> q [Dec]+genPromotions names = do+ opts <- getOptions+ -- See Note [Disable genQuotedDecs in genPromotions and genSingletons]+ withOptions opts{genQuotedDecs = False} $ do+ checkForRep names+ infos <- mapM reifyWithLocals names+ dinfos <- mapM dsInfo infos+ ddecs <- promoteM_ [] $ mapM_ promoteInfo dinfos+ return $ decsToTH ddecs++-- | Promote every declaration given to the type level, retaining the originals.+-- See the+-- @<https://github.com/goldfirere/singletons/blob/master/README.md README>@+-- for further explanation.+promote :: OptionsMonad q => q [Dec] -> q [Dec]+promote qdecs = do+ opts <- getOptions+ withOptions opts{genQuotedDecs = True} $ promote' $ lift qdecs++-- | Promote each declaration, discarding the originals. Note that a promoted+-- datatype uses the same definition as an original datatype, so this will+-- not work with datatypes. Classes, instances, and functions are all fine.+promoteOnly :: OptionsMonad q => q [Dec] -> q [Dec]+promoteOnly qdecs = do+ opts <- getOptions+ withOptions opts{genQuotedDecs = False} $ promote' $ lift qdecs++-- The workhorse for 'promote' and 'promoteOnly'. The difference between the+-- two functions is whether 'genQuotedDecs' is set to 'True' or 'False'.+promote' :: OptionsMonad q => q [Dec] -> q [Dec]+promote' qdecs = do+ opts <- getOptions+ decs <- qdecs+ ddecs <- withLocalDeclarations decs $ dsDecs decs+ promDecs <- promoteM_ decs $ promoteDecs ddecs+ let origDecs | genQuotedDecs opts = decs+ | otherwise = []+ return $ origDecs ++ decsToTH promDecs++-- | Generate defunctionalization symbols for each of the provided type-level+-- declaration 'Name's. See the "Promotion and partial application" section of+-- the @singletons@+-- @<https://github.com/goldfirere/singletons/blob/master/README.md README>@+-- for further explanation.+genDefunSymbols :: OptionsMonad q => [Name] -> q [Dec]+genDefunSymbols names = do+ checkForRep names+ infos <- mapM (dsInfo <=< reifyWithLocals) names+ decs <- promoteMDecs [] $ concatMapM defunInfo infos+ return $ decsToTH decs++-- | Produce instances for @PEq@ from the given types+promoteEqInstances :: OptionsMonad q => [Name] -> q [Dec]+promoteEqInstances = concatMapM promoteEqInstance++-- | Produce an instance for @PEq@ from the given type+promoteEqInstance :: OptionsMonad q => Name -> q [Dec]+promoteEqInstance = promoteInstance mkEqInstance "Eq"++-- | Produce instances for 'POrd' from the given types+promoteOrdInstances :: OptionsMonad q => [Name] -> q [Dec]+promoteOrdInstances = concatMapM promoteOrdInstance++-- | Produce an instance for 'POrd' from the given type+promoteOrdInstance :: OptionsMonad q => Name -> q [Dec]+promoteOrdInstance = promoteInstance mkOrdInstance "Ord"++-- | Produce instances for 'PBounded' from the given types+promoteBoundedInstances :: OptionsMonad q => [Name] -> q [Dec]+promoteBoundedInstances = concatMapM promoteBoundedInstance++-- | Produce an instance for 'PBounded' from the given type+promoteBoundedInstance :: OptionsMonad q => Name -> q [Dec]+promoteBoundedInstance = promoteInstance mkBoundedInstance "Bounded"++-- | Produce instances for 'PEnum' from the given types+promoteEnumInstances :: OptionsMonad q => [Name] -> q [Dec]+promoteEnumInstances = concatMapM promoteEnumInstance++-- | Produce an instance for 'PEnum' from the given type+promoteEnumInstance :: OptionsMonad q => Name -> q [Dec]+promoteEnumInstance = promoteInstance mkEnumInstance "Enum"++-- | Produce instances for 'PShow' from the given types+promoteShowInstances :: OptionsMonad q => [Name] -> q [Dec]+promoteShowInstances = concatMapM promoteShowInstance++-- | Produce an instance for 'PShow' from the given type+promoteShowInstance :: OptionsMonad q => Name -> q [Dec]+promoteShowInstance = promoteInstance mkShowInstance "Show"++promoteInstance :: OptionsMonad q => DerivDesc q -> String -> Name -> q [Dec]+promoteInstance mk_inst class_name name = do+ (tvbs, cons) <- getDataD ("I cannot make an instance of " ++ class_name+ ++ " for it.") name+ tvbs' <- mapM dsTvbUnit tvbs+ let data_ty = foldTypeTvbs (DConT name) tvbs'+ cons' <- concatMapM (dsCon tvbs' data_ty) cons+ let data_decl = DataDecl name tvbs' cons'+ raw_inst <- mk_inst Nothing data_ty data_decl+ decs <- promoteM_ [] $ void $+ promoteInstanceDec OMap.empty Map.empty raw_inst+ return $ decsToTH decs++promoteInfo :: DInfo -> PrM ()+promoteInfo (DTyConI dec _instances) = promoteDecs [dec]+promoteInfo (DPrimTyConI _name _numArgs _unlifted) =+ fail "Promotion of primitive type constructors not supported"+promoteInfo (DVarI _name _ty _mdec) =+ fail "Promotion of individual values not supported"+promoteInfo (DTyVarI _name _ty) =+ fail "Promotion of individual type variables not supported"+promoteInfo (DPatSynI {}) =+ fail "Promotion of pattern synonyms not supported"++-- Note [Promoting declarations in two stages]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- It is necessary to know the types of things when promoting. So,+-- we promote in two stages: first, we build a LetDecEnv, which allows+-- for easy lookup. Then, we go through the actual elements of the LetDecEnv,+-- performing the promotion.+--+-- Why do we need the types? For kind annotations on the type family. We also+-- need to have both the types and the actual function definition at the same+-- time, because the function definition tells us how many patterns are+-- matched. Note that an eta-contracted function needs to return a TyFun,+-- not a proper type-level function.+--+-- Consider this example:+--+-- foo :: Nat -> Bool -> Bool+-- foo Zero = id+-- foo _ = not+--+-- Here the first parameter to foo is non-uniform, because it is+-- inspected in a pattern and can be different in each defining+-- equation of foo. The second parameter to foo, specified in the type+-- signature as Bool, is a uniform parameter - it is not inspected and+-- each defining equation of foo uses it the same way. The foo+-- function will be promoted to a type familty Foo like this:+--+-- type family Foo (n :: Nat) :: Bool ~> Bool where+-- Foo Zero = Id+-- Foo a = Not+--+-- To generate type signature for Foo type family we must first learn+-- what is the actual number of patterns used in defining cequations+-- of foo. In this case there is only one so we declare Foo to take+-- one argument and have return type of Bool -> Bool.++-- Promote a list of top-level declarations.+promoteDecs :: [DDec] -> PrM ()+promoteDecs raw_decls = do+ decls <- expand raw_decls -- expand type synonyms+ checkForRepInDecls decls+ PDecs { pd_let_decs = let_decs+ , pd_class_decs = classes+ , pd_instance_decs = insts+ , pd_data_decs = datas+ , pd_ty_syn_decs = ty_syns+ , pd_open_type_family_decs = o_tyfams+ , pd_closed_type_family_decs = c_tyfams } <- partitionDecs decls++ defunTopLevelTypeDecls ty_syns c_tyfams o_tyfams+ rec_sel_let_decs <- promoteDataDecs datas+ -- promoteLetDecs returns LetBinds, which we don't need at top level+ _ <- promoteLetDecs Nothing $ rec_sel_let_decs ++ let_decs+ mapM_ promoteClassDec classes+ let orig_meth_sigs = foldMap (lde_types . cd_lde) classes+ cls_tvbs_map = Map.fromList $ map (\cd -> (cd_name cd, cd_tvbs cd)) classes+ mapM_ (promoteInstanceDec orig_meth_sigs cls_tvbs_map) insts++-- curious about ALetDecEnv? See the LetDecEnv module for an explanation.+promoteLetDecs :: Maybe Uniq -- let-binding unique (if locally bound)+ -> [DLetDec] -> PrM ([LetBind], ALetDecEnv)+ -- See Note [Promoting declarations in two stages]+promoteLetDecs mb_let_uniq decls = do+ opts <- getOptions+ let_dec_env <- buildLetDecEnv decls+ all_locals <- allLocals+ let binds = [ (name, foldType (DConT sym) (map DVarT all_locals))+ | (name, _) <- OMap.assocs $ lde_defns let_dec_env+ , let proName = promotedValueName opts name mb_let_uniq+ sym = defunctionalizedName opts proName (length all_locals) ]+ (decs, let_dec_env') <- letBind binds $ promoteLetDecEnv mb_let_uniq let_dec_env+ emitDecs decs+ return (binds, let_dec_env' { lde_proms = OMap.fromList binds })++promoteDataDecs :: [DataDecl] -> PrM [DLetDec]+promoteDataDecs = concatMapM promoteDataDec++-- "Promotes" a data type, much like D.S.TH.Single.Data.singDataD singles a data+-- type. Promoting a data type is much easier than singling it, however, since+-- DataKinds automatically promotes data types and kinds and data constructors+-- to types. That means that promoteDataDec only has to do three things:+--+-- 1. Emit defunctionalization symbols for each data constructor,+--+-- 2. Emit promoted fixity declarations for each data constructor and promoted+-- record selector (assuming the originals have fixity declarations), and+--+-- 3. Assemble a top-level function that mimics the behavior of its record+-- selectors. Note that promoteDataDec does not actually promote this record+-- selector function—it merely returns its DLetDecs. Later, the promoteDecs+-- function takes these DLetDecs and promotes them (using promoteLetDecs).+-- This greatly simplifies the plumbing, since this allows all DLetDecs to+-- be promoted in a single location.+-- See Note [singletons-th and record selectors] in D.S.TH.Single.Data.+promoteDataDec :: DataDecl -> PrM [DLetDec]+promoteDataDec (DataDecl _ _ ctors) = do+ let rec_sel_names = nub $ concatMap extractRecSelNames ctors+ -- Note the use of nub: the same record selector name can+ -- be used in multiple constructors!+ rec_sel_let_decs <- getRecordSelectors ctors+ ctorSyms <- buildDefunSymsDataD ctors+ infix_decs <- promoteReifiedInfixDecls rec_sel_names+ emitDecs $ ctorSyms ++ infix_decs+ pure rec_sel_let_decs++promoteClassDec :: UClassDecl -> PrM AClassDecl+promoteClassDec decl@(ClassDecl { cd_name = cls_name+ , cd_tvbs = tvbs+ , cd_fds = fundeps+ , cd_atfs = atfs+ , cd_lde = lde@LetDecEnv+ { lde_defns = defaults+ , lde_types = meth_sigs+ , lde_infix = infix_decls } }) = do+ opts <- getOptions+ let pClsName = promotedClassName opts cls_name+ forallBind cls_kvs_to_bind $ do+ let meth_sigs_list = OMap.assocs meth_sigs+ meth_names = map fst meth_sigs_list+ defaults_list = OMap.assocs defaults+ defaults_names = map fst defaults_list+ mb_cls_sak <- dsReifyType cls_name+ sig_decs <- mapM (uncurry promote_sig) meth_sigs_list+ (default_decs, ann_rhss, prom_rhss)+ <- mapAndUnzip3M (promoteMethod DefaultMethods meth_sigs) defaults_list+ defunAssociatedTypeFamilies tvbs atfs++ infix_decls' <- mapMaybeM (uncurry (promoteInfixDecl Nothing)) $+ OMap.assocs infix_decls+ cls_infix_decls <- promoteReifiedInfixDecls $ cls_name:meth_names++ -- no need to do anything to the fundeps. They work as is!+ let pro_cls_dec = DClassD [] pClsName tvbs fundeps+ (sig_decs ++ default_decs ++ infix_decls')+ mb_pro_cls_sak = fmap (DKiSigD pClsName) mb_cls_sak+ emitDecs $ maybeToList mb_pro_cls_sak ++ pro_cls_dec:cls_infix_decls+ let defaults_list' = zip defaults_names ann_rhss+ proms = zip defaults_names prom_rhss+ cls_kvs_to_bind' = cls_kvs_to_bind <$ meth_sigs+ return (decl { cd_lde = lde { lde_defns = OMap.fromList defaults_list'+ , lde_proms = OMap.fromList proms+ , lde_bound_kvs = cls_kvs_to_bind' } })+ where+ cls_kvb_names, cls_tvb_names, cls_kvs_to_bind :: OSet Name+ cls_kvb_names = foldMap (foldMap fvDType . extractTvbKind) tvbs+ cls_tvb_names = OSet.fromList $ map extractTvbName tvbs+ cls_kvs_to_bind = cls_kvb_names `OSet.union` cls_tvb_names++ promote_sig :: Name -> DType -> PrM DDec+ promote_sig name ty = do+ opts <- getOptions+ let proName = promotedTopLevelValueName opts name+ -- When computing the kind to use for the defunctionalization symbols,+ -- /don't/ use the type variable binders from the method's type...+ (_, argKs, resK) <- promoteUnraveled ty+ args <- mapM (const $ qNewName "arg") argKs+ let proTvbs = zipWith (`DKindedTV` ()) args argKs+ -- ...instead, compute the type variable binders in a left-to-right order,+ -- since that is the same order that the promoted method's kind will use.+ -- See Note [Promoted class methods and kind variable ordering]+ meth_sak_tvbs = changeDTVFlags SpecifiedSpec $+ toposortTyVarsOf $ argKs ++ [resK]+ meth_sak = ravelVanillaDType meth_sak_tvbs [] argKs resK+ m_fixity <- reifyFixityWithLocals name+ emitDecsM $ defunctionalize proName m_fixity $ DefunSAK meth_sak++ return $ DOpenTypeFamilyD (DTypeFamilyHead proName+ proTvbs+ (DKindSig resK)+ Nothing)++{-+Note [Promoted class methods and kind variable ordering]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general, we make an effort to preserve the order of type variables when+promoting type signatures, but there is an annoying corner case where this is+difficult: class methods. When promoting class methods, the order of kind+variables in their kinds will often "just work" by happy coincidence, but+there are some situations where this does not happen. Consider the following+class:++ class C (b :: Type) where+ m :: forall a. a -> b -> a++The full type of `m` is `forall b. C b => forall a. a -> b -> a`, which binds+`b` before `a`. This order is preserved when singling `m`, but *not* when+promoting `m`. This is because the `C` class is promoted as follows:++ class PC (b :: Type) where+ type M (x :: a) (y :: b) :: a++Due to the way GHC kind-checks associated type families, the kind of `M` is+`forall a b. a -> b -> a`, which binds `b` *after* `a`. Moreover, the+`StandaloneKindSignatures` extension does not provide a way to explicitly+declare the full kind of an associated type family, so this limitation is+not easy to work around.++The defunctionalization symbols for `M` will also follow a similar+order of type variables:++ type MSym0 :: forall a b. a ~> b ~> a+ type MSym1 :: forall a b. a -> b ~> a++There is one potential hack we could use to rectify this:++ type FlipConst x y = y+ class PC (b :: Type) where+ type M (x :: FlipConst '(b, a) a) (y :: b) :: a++Using `FlipConst` would cause `b` to be mentioned before `a`, which would give+`M` the kind `forall b a. FlipConst '(b, a) a -> b -> a`. While the order of+type variables would be preserved, the downside is that the ugly `FlipConst`+type synonym leaks into the kind. I'm not particularly fond of this, so I have+decided not to use this hack unless someone specifically requests it.+-}++-- returns (unpromoted method name, ALetDecRHS) pairs+promoteInstanceDec :: OMap Name DType+ -- Class method type signatures+ -> Map Name [DTyVarBndrUnit]+ -- Class header type variable (e.g., if `class C a b` is+ -- quoted, then this will have an entry for {C |-> [a, b]})+ -> UInstDecl -> PrM AInstDecl+promoteInstanceDec orig_meth_sigs cls_tvbs_map+ decl@(InstDecl { id_name = cls_name+ , id_arg_tys = inst_tys+ , id_sigs = inst_sigs+ , id_meths = meths }) = do+ opts <- getOptions+ cls_tvbs <- lookup_cls_tvbs+ inst_kis <- mapM promoteType inst_tys+ let pClsName = promotedClassName opts cls_name+ cls_tvb_names = map extractTvbName cls_tvbs+ kvs_to_bind = foldMap fvDType inst_kis+ forallBind kvs_to_bind $ do+ let subst = Map.fromList $ zip cls_tvb_names inst_kis+ meth_impl = InstanceMethods inst_sigs subst+ (meths', ann_rhss, _)+ <- mapAndUnzip3M (promoteMethod meth_impl orig_meth_sigs) meths+ emitDecs [DInstanceD Nothing Nothing [] (foldType (DConT pClsName)+ inst_kis) meths']+ return (decl { id_meths = zip (map fst meths) ann_rhss })+ where+ lookup_cls_tvbs :: PrM [DTyVarBndrUnit]+ lookup_cls_tvbs =+ -- First, try consulting the map of class names to their type variables.+ -- It is important to do this first to ensure that we consider locally+ -- declared classes before imported ones. See #410 for what happens if+ -- you don't.+ case Map.lookup cls_name cls_tvbs_map of+ Just tvbs -> pure tvbs+ Nothing -> reify_cls_tvbs+ -- If the class isn't present in this map, we try reifying the class+ -- as a last resort.++ reify_cls_tvbs :: PrM [DTyVarBndrUnit]+ reify_cls_tvbs = do+ opts <- getOptions+ let pClsName = promotedClassName opts cls_name+ mk_tvbs = extract_tvbs (dsReifyTypeNameInfo pClsName)+ <|> extract_tvbs (dsReifyTypeNameInfo cls_name)+ -- See Note [Using dsReifyTypeNameInfo when promoting instances]+ mb_tvbs <- runMaybeT mk_tvbs+ case mb_tvbs of+ Just tvbs -> pure tvbs+ Nothing -> fail $ "Cannot find class declaration annotation for " ++ show cls_name++ extract_tvbs :: PrM (Maybe DInfo) -> MaybeT PrM [DTyVarBndrUnit]+ extract_tvbs reify_info = do+ mb_info <- lift reify_info+ case mb_info of+ Just (DTyConI (DClassD _ _ tvbs _ _) _) -> pure tvbs+ _ -> empty++{-+Note [Using dsReifyTypeNameInfo when promoting instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+During the promotion of a class instance, it becomes necessary to reify the+original promoted class's info to learn various things. It's tempting to think+that just calling dsReify on the class name will be sufficient, but it's not.+Consider this class and its promotion:++ class Eq a where+ (==) :: a -> a -> Bool++ class PEq a where+ type (==) (x :: a) (y :: a) :: Bool++Notice how both of these classes have an identifier named (==), one at the+value level, and one at the type level. Now imagine what happens when you+attempt to promote this Template Haskell declaration:++ [d| f :: Bool+ f = () == () |]++When promoting ==, singletons-th will come up with its promoted equivalent (which also+happens to be ==). However, this promoted name is a raw Name, since it is created+with mkName. This becomes an issue when we call dsReify the raw "==" Name, as+Template Haskell has to arbitrarily choose between reifying the info for the+value-level (==) and the type-level (==), and in this case, it happens to pick the+value-level (==) info. We want the type-level (==) info, however, because we care+about the promoted version of (==).++Fortunately, there's a serviceable workaround. Instead of dsReify, we can use+dsReifyTypeNameInfo, which first calls lookupTypeName (to ensure we can find a Name+that's in the type namespace) and _then_ reifies it.+-}++-- Which sort of class methods are being promoted?+data MethodSort+ -- The method defaults in class declarations.+ = DefaultMethods+ -- The methods in instance declarations.+ | InstanceMethods (OMap Name DType) -- ^ InstanceSigs+ (Map Name DKind) -- ^ Instantiations for class tyvars+ -- See Note [Promoted class method kinds]+ deriving Show++promoteMethod :: MethodSort+ -> OMap Name DType -- method types+ -> (Name, ULetDecRHS)+ -> PrM (DDec, ALetDecRHS, DType)+ -- returns (type instance, ALetDecRHS, promoted RHS)+promoteMethod meth_sort orig_sigs_map (meth_name, meth_rhs) = do+ opts <- getOptions+ (meth_tvbs, meth_arg_kis, meth_res_ki) <- promote_meth_ty+ meth_arg_tvs <- replicateM (length meth_arg_kis) (qNewName "a")+ let proName = promotedTopLevelValueName opts meth_name+ helperNameBase = case nameBase proName of+ first:_ | not (isHsLetter first) -> "TFHelper"+ alpha -> alpha++ -- family_args are the type variables in a promoted class's+ -- associated type family instance (or default implementation), e.g.,+ --+ -- class C k where+ -- type T (a :: k) (b :: Bool)+ -- type T a b = THelper1 a b -- family_args = [a, b]+ --+ -- instance C Bool where+ -- type T a b = THelper2 a b -- family_args = [a, b]+ --+ -- We could annotate these variables with explicit kinds, but it's not+ -- strictly necessary, as kind inference can figure them out just as well.+ family_args = map DVarT meth_arg_tvs+ helperName <- newUniqueName helperNameBase+ let helperDefunName = defunctionalizedName0 opts helperName+ (pro_decs, defun_decs, ann_rhs)+ <- promoteLetDecRHS (ClassMethodRHS meth_tvbs meth_arg_kis meth_res_ki)+ OMap.empty OMap.empty+ Nothing helperName meth_rhs+ emitDecs (pro_decs ++ defun_decs)+ return ( DTySynInstD+ (DTySynEqn Nothing+ (foldType (DConT proName) family_args)+ (foldApply (DConT helperDefunName) (map DVarT meth_arg_tvs)))+ , ann_rhs+ , DConT helperDefunName )+ where+ -- Promote the type of a class method. For a default method, "the type" is+ -- simply the type of the original method. For an instance method,+ -- "the type" is like the type of the original method, but substituted for+ -- the types in the instance head. (e.g., if you have `class C a` and+ -- `instance C T`, then the substitution [a |-> T] must be applied to the+ -- original method's type.)+ promote_meth_ty :: PrM ([DTyVarBndrSpec], [DKind], DKind)+ promote_meth_ty =+ case meth_sort of+ DefaultMethods ->+ -- No substitution for class variables is required for default+ -- method type signatures, as they share type variables with the+ -- class they inhabit.+ lookup_meth_ty+ InstanceMethods inst_sigs_map cls_subst ->+ case OMap.lookup meth_name inst_sigs_map of+ Just ty -> do+ -- We have an InstanceSig. These are easy: we can just use the+ -- instance signature's type directly, and no substitution for+ -- class variables is required.+ promoteUnraveled ty+ Nothing -> do+ -- We don't have an InstanceSig, so we must compute the kind to use+ -- ourselves.+ (_, arg_kis, res_ki) <- lookup_meth_ty+ -- Substitute for the class variables in the method's type.+ -- See Note [Promoted class method kinds]+ let arg_kis' = map (substKind cls_subst) arg_kis+ res_ki' = substKind cls_subst res_ki+ -- Compute the type variable binders in a left-to-right+ -- order, since that is the same order that the promoted+ -- method's kind will use.+ -- See Note [Promoted class methods and kind variable ordering]+ tvbs' = changeDTVFlags SpecifiedSpec $+ toposortTyVarsOf (arg_kis' ++ [res_ki'])+ pure (tvbs', arg_kis', res_ki')++ -- Attempt to look up a class method's original type.+ lookup_meth_ty :: PrM ([DTyVarBndrSpec], [DKind], DKind)+ lookup_meth_ty = do+ opts <- getOptions+ let proName = promotedTopLevelValueName opts meth_name+ case OMap.lookup meth_name orig_sigs_map of+ Just ty -> do+ -- The type of the method is in scope, so promote that.+ promoteUnraveled ty+ Nothing -> do+ -- If the type of the method is not in scope, the only other option+ -- is to try reifying the promoted method name.+ mb_info <- dsReifyTypeNameInfo proName+ -- See Note [Using dsReifyTypeNameInfo when promoting instances]+ case mb_info of+ Just (DTyConI (DOpenTypeFamilyD (DTypeFamilyHead _ tvbs mb_res_ki _)) _)+ -> let arg_kis = map (defaultMaybeToTypeKind . extractTvbKind) tvbs+ res_ki = defaultMaybeToTypeKind (resultSigToMaybeKind mb_res_ki)+ -- Compute the type variable binders in a left-to-right+ -- order, since that is the same order that the promoted+ -- method's kind will use.+ -- See Note [Promoted class methods and kind variable ordering]+ tvbs' = changeDTVFlags SpecifiedSpec $+ toposortTyVarsOf (arg_kis ++ [res_ki])+ in pure (tvbs', arg_kis, res_ki)+ _ -> fail $ "Cannot find type annotation for " ++ show proName++{-+Note [Promoted class method kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this example of a type class (and instance):++ class C a where+ m :: a -> Bool -> Bool+ m _ x = x++ instance C [a] where+ m l _ = null l++The promoted version of these declarations would be:++ class PC a where+ type M (x :: a) (y :: Bool) :: Bool+ type M x y = MHelper1 x y++ instance PC [a] where+ type M x y = MHelper2 x y++ type MHelper1 :: a -> Bool -> Bool+ type family MHelper1 x y where ...++ type MHelper2 :: [a] -> Bool -> Bool+ type family MHelper2 x y where ...++Getting the kind signature for MHelper1 (the promoted default implementation of+M) is quite simple, as it corresponds exactly to the kind of M. We might even+choose to make that the kind of MHelper2, but then it would be overly general+(and more difficult to find in -ddump-splices output). For this reason, we+substitute in the kinds of the instance itself to determine the kinds of+promoted method implementations like MHelper2.+-}++promoteLetDecEnv :: Maybe Uniq -> ULetDecEnv -> PrM ([DDec], ALetDecEnv)+promoteLetDecEnv mb_let_uniq (LetDecEnv { lde_defns = value_env+ , lde_types = type_env+ , lde_infix = fix_env }) = do+ infix_decls <- mapMaybeM (uncurry (promoteInfixDecl mb_let_uniq)) $+ OMap.assocs fix_env++ -- promote all the declarations, producing annotated declarations+ let (names, rhss) = unzip $ OMap.assocs value_env+ (pro_decs, defun_decss, ann_rhss)+ <- fmap unzip3 $+ zipWithM (promoteLetDecRHS LetBindingRHS type_env fix_env mb_let_uniq)+ names rhss++ emitDecs $ concat defun_decss+ bound_kvs <- allBoundKindVars+ let decs = concat pro_decs ++ infix_decls++ -- build the ALetDecEnv+ let let_dec_env' = LetDecEnv { lde_defns = OMap.fromList $ zip names ann_rhss+ , lde_types = type_env+ , lde_infix = fix_env+ , lde_proms = OMap.empty -- filled in promoteLetDecs+ , lde_bound_kvs = OMap.fromList $ map (, bound_kvs) names }++ return (decs, let_dec_env')++-- Promote a fixity declaration.+promoteInfixDecl :: forall q. OptionsMonad q+ => Maybe Uniq -> Name -> Fixity -> q (Maybe DDec)+promoteInfixDecl mb_let_uniq name fixity = do+ opts <- getOptions+ mb_ns <- reifyNameSpace name+ case mb_ns of+ -- If we can't find the Name for some odd reason, fall back to promote_val+ Nothing -> promote_val+ Just VarName -> promote_val+ Just DataName -> never_mind+ Just TcClsName -> do+ mb_info <- dsReify name+ case mb_info of+ Just (DTyConI DClassD{} _)+ -> finish $ promotedClassName opts name+ _ -> never_mind+ where+ -- Produce the fixity declaration.+ finish :: Name -> q (Maybe DDec)+ finish = pure . Just . DLetDec . DInfixD fixity++ -- Don't produce a fixity declaration at all. This happens when promoting a+ -- fixity declaration for a name whose promoted counterpart is the same as+ -- the original name.+ -- See Note [singletons-th and fixity declarations] in D.S.TH.Single.Fixity, wrinkle 1.+ never_mind :: q (Maybe DDec)+ never_mind = pure Nothing++ -- Certain value names do not change when promoted (e.g., infix names).+ -- Therefore, don't bother promoting their fixity declarations if+ -- 'genQuotedDecs' is set to 'True', since that will run the risk of+ -- generating duplicate fixity declarations.+ -- See Note [singletons-th and fixity declarations] in D.S.TH.Single.Fixity, wrinkle 1.+ promote_val :: q (Maybe DDec)+ promote_val = do+ opts <- getOptions+ let promoted_name :: Name+ promoted_name = promotedValueName opts name mb_let_uniq+ if nameBase name == nameBase promoted_name && genQuotedDecs opts+ then never_mind+ else finish promoted_name++-- Try producing promoted fixity declarations for Names by reifying them+-- /without/ consulting quoted declarations. If reification fails, recover and+-- return the empty list.+-- See [singletons-th and fixity declarations] in D.S.TH.Single.Fixity, wrinkle 2.+promoteReifiedInfixDecls :: forall q. OptionsMonad q => [Name] -> q [DDec]+promoteReifiedInfixDecls = mapMaybeM tryPromoteFixityDeclaration+ where+ tryPromoteFixityDeclaration :: Name -> q (Maybe DDec)+ tryPromoteFixityDeclaration name =+ qRecover (return Nothing) $ do+ mFixity <- qReifyFixity name+ case mFixity of+ Nothing -> pure Nothing+ Just fixity -> promoteInfixDecl Nothing name fixity++-- Which sort of let-bound declaration's right-hand side is being promoted?+data LetDecRHSSort+ -- An ordinary (i.e., non-class-related) let-bound declaration.+ = LetBindingRHS+ -- The right-hand side of a class method (either a default method or a+ -- method in an instance declaration).+ | ClassMethodRHS+ [DTyVarBndrSpec] [DKind] DKind+ -- The RHS's promoted type variable binders, argument types, and+ -- result type. Needed to fix #136.+ deriving Show++-- This function is used both to promote class method defaults and normal+-- let bindings. Thus, it can't quite do all the work locally and returns+-- an intermediate structure. Perhaps a better design is available.+promoteLetDecRHS :: LetDecRHSSort+ -> OMap Name DType -- local type env't+ -> OMap Name Fixity -- local fixity env't+ -> Maybe Uniq -- let-binding unique (if locally bound)+ -> Name -- name of the thing being promoted+ -> ULetDecRHS -- body of the thing+ -> PrM ( [DDec] -- promoted type family dec, plus the+ -- SAK dec (if one exists)+ , [DDec] -- defunctionalization+ , ALetDecRHS ) -- annotated RHS+promoteLetDecRHS rhs_sort type_env fix_env mb_let_uniq name let_dec_rhs = do+ opts <- getOptions+ all_locals <- allLocals+ case let_dec_rhs of+ UValue exp -> do+ (m_ldrki, ty_num_args) <- promote_let_dec_ty all_locals 0+ if ty_num_args == 0+ then+ let proName = promotedValueName opts name mb_let_uniq+ prom_fun_lhs = foldType (DConT proName) $ map DVarT all_locals in+ promote_let_dec_rhs all_locals m_ldrki 0 (promoteExp exp)+ (\exp' -> [DTySynEqn Nothing prom_fun_lhs exp'])+ AValue+ else+ -- If we have a UValue with a function type, process it as though it+ -- were a UFunction. promote_function_rhs will take care of+ -- eta-expanding arguments as necessary.+ promote_function_rhs all_locals [DClause [] exp]+ UFunction clauses -> promote_function_rhs all_locals clauses+ where+ -- Promote the RHS of a UFunction (or a UValue with a function type).+ promote_function_rhs :: [Name]+ -> [DClause] -> PrM ([DDec], [DDec], ALetDecRHS)+ promote_function_rhs all_locals clauses = do+ opts <- getOptions+ numArgs <- count_args clauses+ let proName = promotedValueName opts name mb_let_uniq+ prom_fun_lhs = foldType (DConT proName) $ map DVarT all_locals+ (m_ldrki, ty_num_args) <- promote_let_dec_ty all_locals numArgs+ expClauses <- mapM (etaContractOrExpand ty_num_args numArgs) clauses+ promote_let_dec_rhs all_locals m_ldrki ty_num_args+ (mapAndUnzipM (promoteClause prom_fun_lhs) expClauses)+ id AFunction++ -- Promote a UValue or a UFunction.+ -- Notes about type variables:+ --+ -- * For UValues, `prom_a` is DType and `a` is Exp.+ --+ -- * For UFunctions, `prom_a` is [DTySynEqn] and `a` is [DClause].+ promote_let_dec_rhs+ :: [Name] -- Local variables bound in this scope+ -> Maybe LetDecRHSKindInfo -- Information about the promoted kind (if present)+ -> Int -- The number of promoted function arguments+ -> PrM (prom_a, a) -- Promote the RHS+ -> (prom_a -> [DTySynEqn]) -- Turn the promoted RHS into type family equations+ -> (DType -> Int -> a -> ALetDecRHS) -- Build an ALetDecRHS+ -> PrM ([DDec], [DDec], ALetDecRHS)+ promote_let_dec_rhs all_locals m_ldrki ty_num_args+ promote_thing mk_prom_eqns mk_alet_dec_rhs = do+ opts <- getOptions+ tyvarNames <- replicateM ty_num_args (qNewName "a")+ let proName = promotedValueName opts name mb_let_uniq+ local_tvbs = map (`DPlainTV` ()) all_locals+ m_fixity = OMap.lookup name fix_env++ mk_tf_head :: [DTyVarBndrUnit] -> DFamilyResultSig -> DTypeFamilyHead+ mk_tf_head tvbs res_sig = DTypeFamilyHead proName tvbs res_sig Nothing++ (lde_kvs_to_bind, m_sak_dec, defun_ki, tf_head) =+ -- There are three possible cases:+ case m_ldrki of+ -- 1. We have no kind information whatsoever.+ Nothing ->+ let all_args = local_tvbs ++ map (`DPlainTV` ()) tyvarNames in+ ( OSet.empty+ , Nothing+ , DefunNoSAK all_args Nothing+ , mk_tf_head all_args DNoSig+ )+ -- 2. We have some kind information in the form of a LetDecRHSKindInfo.+ Just (LDRKI m_sak tvbs argKs resK) ->+ let all_args = local_tvbs ++ zipWith (`DKindedTV` ()) tyvarNames argKs+ lde_kvs_to_bind' = OSet.fromList (map extractTvbName tvbs) in+ case m_sak of+ -- 2(a). We do not have a standalone kind signature.+ Nothing ->+ ( lde_kvs_to_bind'+ , Nothing+ , DefunNoSAK all_args (Just resK)+ , mk_tf_head all_args (DKindSig resK)+ )+ -- 2(b). We have a standalone kind signature.+ Just sak ->+ ( lde_kvs_to_bind'+ , Just $ DKiSigD proName sak+ , DefunSAK sak+ -- We opt to annotate the argument and result kinds in+ -- the body of the type family declaration even if it is+ -- given a standalone kind signature.+ -- See Note [Keep redundant kind information for Haddocks].+ , mk_tf_head all_args (DKindSig resK)+ )++ defun_decs <- defunctionalize proName m_fixity defun_ki+ (prom_thing, thing) <- forallBind lde_kvs_to_bind promote_thing+ prom_fun_rhs <- lookupVarE name+ return ( catMaybes [ m_sak_dec+ , Just $ DClosedTypeFamilyD tf_head (mk_prom_eqns prom_thing)+ ]+ , defun_decs+ , mk_alet_dec_rhs prom_fun_rhs ty_num_args thing )++ promote_let_dec_ty :: [Name] -- The local variables that the let-dec closes+ -- over. If this is non-empty, we cannot+ -- produce a standalone kind signature.+ -- See Note [No SAKs for let-decs with local variables]+ -> Int -- The number of arguments to default to if the+ -- type cannot be inferred. This is 0 for UValues+ -- and the number of arguments in a single clause+ -- for UFunctions.+ -> PrM (Maybe LetDecRHSKindInfo, Int)+ -- Returns two things in a pair:+ --+ -- 1. Information about the promoted kind,+ -- if available.+ --+ -- 2. The number of arguments the let-dec has.+ -- If no kind information is available from+ -- which to infer this number, then this+ -- will default to the earlier Int argument.+ promote_let_dec_ty all_locals default_num_args =+ case rhs_sort of+ ClassMethodRHS tvbs arg_kis res_ki+ -> -- For class method RHS helper functions, don't bother quantifying+ -- any type variables in their SAKS. We could certainly try, but+ -- given that these functions are only used internally, there's no+ -- point in trying to get the order of type variables correct,+ -- since we don't apply these functions with visible kind+ -- applications.+ let sak = ravelVanillaDType [] [] arg_kis res_ki in+ return (Just (LDRKI (Just sak) tvbs arg_kis res_ki), length arg_kis)+ LetBindingRHS+ | Just ty <- OMap.lookup name type_env+ -> do+ -- promoteType turns rank-1 uses of (->) into (~>). So, we unravel+ -- first to avoid this behavior, and then ravel back.+ (tvbs, argKs, resultK) <- promoteUnraveled ty+ let m_sak | null all_locals = Just $ ravelVanillaDType tvbs [] argKs resultK+ -- If this let-dec closes over local variables, then+ -- don't give it a SAK.+ -- See Note [No SAKs for let-decs with local variables]+ | otherwise = Nothing+ -- invariant: count_args ty == length argKs+ return (Just (LDRKI m_sak tvbs argKs resultK), length argKs)++ | otherwise+ -> return (Nothing, default_num_args)++ etaContractOrExpand :: Int -> Int -> DClause -> PrM DClause+ etaContractOrExpand ty_num_args clause_num_args (DClause pats exp)+ | n >= 0 = do -- Eta-expand+ names <- replicateM n (newUniqueName "a")+ let newPats = map DVarP names+ newArgs = map DVarE names+ return $ DClause (pats ++ newPats) (foldExp exp newArgs)+ | otherwise = do -- Eta-contract+ let (clausePats, lamPats) = splitAt ty_num_args pats+ lamExp <- mkDLamEFromDPats lamPats exp+ return $ DClause clausePats lamExp+ where+ n = ty_num_args - clause_num_args++ count_args :: [DClause] -> PrM Int+ count_args (DClause pats _ : _) = return $ length pats+ count_args _ = fail $ "Impossible! A function without clauses."++-- An auxiliary data type used in promoteLetDecRHS that describes information+-- related to the promoted kind of a class method default or normal+-- let binding.+data LetDecRHSKindInfo =+ LDRKI (Maybe DKind) -- The standalone kind signature, if applicable.+ -- This will be Nothing if the let-dec RHS has local+ -- variables that it closes over.+ -- See Note [No SAKs for let-decs with local variables]+ [DTyVarBndrSpec] -- The type variable binders of the kind.+ [DKind] -- The argument kinds.+ DKind -- The result kind.++{-+Note [No SAKs for let-decs with local variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider promoting this:++ f :: Bool+ f = let x = True+ g :: () -> Bool+ g _ = x+ in g ()++Clearly, the promoted `F` type family will have the following SAK:++ type F :: ()++What about `G`? At a passing glance, it appears that you could get away with+this:++ type G :: Bool -> ()++But this isn't quite right, since `g` closes over `x = True`. The body of `G`,+therefore, has to lift `x` to be an explicit argument:++ type family G x (u :: ()) :: Bool where+ G x _ = x++At present, we don't keep track of the types of local variables like `x`, which+makes it difficult to create a SAK for things like `G`. Here are some possible+ideas, each followed by explanations for why they are infeasible:++* Use wildcards:++ type G :: _ -> () -> Bool++ Alas, GHC currently does not allow wildcards in SAKs. See GHC#17432.++* Use visible dependent quantification to avoid having to say what the kind+ of `x` is:++ type G :: forall x -> () -> Bool++ A clever trick to be sure, but it doesn't quite do what we want, since+ GHC will generalize that kind to become `forall (x :: k) -> () -> Bool`,+ which is more general than we want.++In any case, it's probably not worth bothering with SAKs for local definitions+like `g` in the first place, so we avoid generating SAKs for anything that+closes over at least one local variable for now. If someone yells about this,+we'll reconsider this design.++Note [Keep redundant kind information for Haddocks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+`singletons-th` generates explicit argument kinds and result kinds for+type-level declarations whenever possible, even if those kinds are technically+redundant. For example, `singletons-th` would promote this:++ id' :: a -> a++To this:++ type Id' :: a -> a+ type family Id' (x :: a) :: a where ...++Strictly speaking, the argument and result kind of Id' are unnecessary, since+the same information is already present in the standalone kind signature.+However, due to a Haddock limitation+(https://github.com/haskell/haddock/issues/1178), Haddock will not render+standalone kind signatures at all, so if the argument and result kind of Id'+were omitted in the body, Haddock would render it like so:++ type family Id' x where ...++This is unfortunate for Haddock viewers, as this does not convey any kind+information whatsoever. Until the aformentioned Haddock issue is resolved, we+work around this limitation by generating the redundant argument and kind+information anyway. Thankfully, this is simple to accomplish, as we already+compute this information to begin with.+-}++promoteClause :: DType -- What to use as the LHS of the promoted type family+ -- equation. This should consist of the promoted name of+ -- the function to which the clause belongs, applied to+ -- any local arguments (e.g., `Go x y z`).+ -> DClause -> PrM (DTySynEqn, ADClause)+promoteClause pro_clause_fun (DClause pats exp) = do+ -- promoting the patterns creates variable bindings. These are passed+ -- to the function promoted the RHS+ ((types, pats'), prom_pat_infos) <- evalForPair $ mapAndUnzipM promotePat pats+ let PromDPatInfos { prom_dpat_vars = new_vars+ , prom_dpat_sig_kvs = sig_kvs } = prom_pat_infos+ (ty, ann_exp) <- forallBind sig_kvs $+ lambdaBind new_vars $+ promoteExp exp+ return ( DTySynEqn Nothing (foldType pro_clause_fun types) ty+ , ADClause new_vars pats' ann_exp )++promoteMatch :: DType -- What to use as the LHS of the promoted type family+ -- equation. This should consist of the promoted name of+ -- the case expression to which the match belongs, applied+ -- to any local arguments (e.g., `Case x y z`).+ -> DMatch -> PrM (DTySynEqn, ADMatch)+promoteMatch pro_case_fun (DMatch pat exp) = do+ -- promoting the patterns creates variable bindings. These are passed+ -- to the function promoted the RHS+ ((ty, pat'), prom_pat_infos) <- evalForPair $ promotePat pat+ let PromDPatInfos { prom_dpat_vars = new_vars+ , prom_dpat_sig_kvs = sig_kvs } = prom_pat_infos+ (rhs, ann_exp) <- forallBind sig_kvs $+ lambdaBind new_vars $+ promoteExp exp+ return $ ( DTySynEqn Nothing (pro_case_fun `DAppT` ty) rhs+ , ADMatch new_vars pat' ann_exp)++-- promotes a term pattern into a type pattern, accumulating bound variable names+promotePat :: DPat -> QWithAux PromDPatInfos PrM (DType, ADPat)+promotePat (DLitP lit) = (, ADLitP lit) <$> promoteLitPat lit+promotePat (DVarP name) = do+ -- term vars can be symbols... type vars can't!+ tyName <- mkTyName name+ tell $ PromDPatInfos [(name, tyName)] OSet.empty+ return (DVarT tyName, ADVarP name)+promotePat (DConP name pats) = do+ opts <- getOptions+ (types, pats') <- mapAndUnzipM promotePat pats+ let name' = promotedDataTypeOrConName opts name+ return (foldType (DConT name') types, ADConP name pats')+promotePat (DTildeP pat) = do+ qReportWarning "Lazy pattern converted into regular pattern in promotion"+ second ADTildeP <$> promotePat pat+promotePat (DBangP pat) = do+ qReportWarning "Strict pattern converted into regular pattern in promotion"+ second ADBangP <$> promotePat pat+promotePat (DSigP pat ty) = do+ -- We must maintain the invariant that any promoted pattern signature must+ -- not have any wildcards in the underlying pattern.+ -- See Note [Singling pattern signatures].+ wildless_pat <- removeWilds pat+ (promoted, pat') <- promotePat wildless_pat+ ki <- promoteType ty+ tell $ PromDPatInfos [] (fvDType ki)+ return (DSigT promoted ki, ADSigP promoted pat' ki)+promotePat DWildP = return (DWildCardT, ADWildP)++promoteExp :: DExp -> PrM (DType, ADExp)+promoteExp (DVarE name) = fmap (, ADVarE name) $ lookupVarE name+promoteExp (DConE name) = do+ opts <- getOptions+ return (DConT $ defunctionalizedName0 opts name, ADConE name)+promoteExp (DLitE lit) = fmap (, ADLitE lit) $ promoteLitExp lit+promoteExp (DAppE exp1 exp2) = do+ (exp1', ann_exp1) <- promoteExp exp1+ (exp2', ann_exp2) <- promoteExp exp2+ return (apply exp1' exp2', ADAppE ann_exp1 ann_exp2)+-- Until we get visible kind applications, this is the best we can do.+promoteExp (DAppTypeE exp _) = do+ qReportWarning "Visible type applications are ignored by `singletons-th`."+ promoteExp exp+promoteExp (DLamE names exp) = do+ opts <- getOptions+ lambdaName <- newUniqueName "Lambda"+ tyNames <- mapM mkTyName names+ let var_proms = zip names tyNames+ (rhs, ann_exp) <- lambdaBind var_proms $ promoteExp exp+ all_locals <- allLocals+ let all_args = all_locals ++ tyNames+ tvbs = map (`DPlainTV` ()) all_args+ emitDecs [DClosedTypeFamilyD (DTypeFamilyHead+ lambdaName+ tvbs+ DNoSig+ Nothing)+ [DTySynEqn Nothing+ (foldType (DConT lambdaName) $+ map DVarT all_args)+ rhs]]+ emitDecsM $ defunctionalize lambdaName Nothing $ DefunNoSAK tvbs Nothing+ let promLambda = foldl apply (DConT (defunctionalizedName opts lambdaName 0))+ (map DVarT all_locals)+ return (promLambda, ADLamE tyNames promLambda names ann_exp)+promoteExp (DCaseE exp matches) = do+ caseTFName <- newUniqueName "Case"+ all_locals <- allLocals+ let prom_case = foldType (DConT caseTFName) (map DVarT all_locals)+ (exp', ann_exp) <- promoteExp exp+ (eqns, ann_matches) <- mapAndUnzipM (promoteMatch prom_case) matches+ tyvarName <- qNewName "t"+ let all_args = all_locals ++ [tyvarName]+ tvbs = map (`DPlainTV` ()) all_args+ emitDecs [DClosedTypeFamilyD (DTypeFamilyHead caseTFName tvbs DNoSig Nothing) eqns]+ -- See Note [Annotate case return type] in Single+ let applied_case = prom_case `DAppT` exp'+ return ( applied_case+ , ADCaseE ann_exp ann_matches applied_case )+promoteExp (DLetE decs exp) = do+ unique <- qNewUnique+ (binds, ann_env) <- promoteLetDecs (Just unique) decs+ (exp', ann_exp) <- letBind binds $ promoteExp exp+ return (exp', ADLetE ann_env ann_exp)+promoteExp (DSigE exp ty) = do+ (exp', ann_exp) <- promoteExp exp+ ty' <- promoteType ty+ return (DSigT exp' ty', ADSigE exp' ann_exp ty')+promoteExp e@(DStaticE _) = fail ("Static expressions cannot be promoted: " ++ show e)++promoteLitExp :: OptionsMonad q => Lit -> q DType+promoteLitExp (IntegerL n) = do+ opts <- getOptions+ let tyFromIntegerName = promotedValueName opts fromIntegerName Nothing+ tyNegateName = promotedValueName opts negateName Nothing+ if n >= 0+ then return $ (DConT tyFromIntegerName `DAppT` DLitT (NumTyLit n))+ else return $ (DConT tyNegateName `DAppT`+ (DConT tyFromIntegerName `DAppT` DLitT (NumTyLit (-n))))+promoteLitExp (StringL str) = do+ opts <- getOptions+ let prom_str_lit = DLitT (StrTyLit str)+ os_enabled <- qIsExtEnabled LangExt.OverloadedStrings+ pure $ if os_enabled+ then DConT (promotedValueName opts fromStringName Nothing) `DAppT` prom_str_lit+ else prom_str_lit+promoteLitExp lit =+ fail ("Only string and natural number literals can be promoted: " ++ show lit)++promoteLitPat :: MonadFail m => Lit -> m DType+promoteLitPat (IntegerL n)+ | n >= 0 = return $ (DLitT (NumTyLit n))+ | otherwise =+ fail $ "Negative literal patterns are not allowed,\n" +++ "because literal patterns are promoted to natural numbers."+promoteLitPat (StringL str) = return $ DLitT (StrTyLit str)+promoteLitPat lit =+ fail ("Only string and natural number literals can be promoted: " ++ show lit)
+ src/Data/Singletons/TH/Promote/Defun.hs view
@@ -0,0 +1,821 @@+{- 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.+-}++{-# LANGUAGE TemplateHaskellQuotes #-}++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 #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 #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) <$> qNewName "e"++ mk_fix_decl :: Name -> Fixity -> DDec+ mk_fix_decl n f = DLetDec $ DInfixD f n++-- Indicates whether the type being defunctionalized has a standalone kind+-- signature. If it does, DefunSAK contains the kind. If not, DefunNoSAK+-- contains whatever information is known about its type variable binders+-- and result kind.+-- See Note [Defunctionalization game plan] for details on how this+-- information is used.+data DefunKindInfo+ = DefunSAK DKind+ | DefunNoSAK [DTyVarBndrUnit] (Maybe DKind)++-- Shorthand for building (k1 ~> k2)+buildTyFunArrow :: DKind -> DKind -> DKind+buildTyFunArrow k1 k2 = DConT tyFunArrowName `DAppT` k1 `DAppT` k2++buildTyFunArrow_maybe :: Maybe DKind -> Maybe DKind -> Maybe DKind+buildTyFunArrow_maybe m_k1 m_k2 = buildTyFunArrow <$> m_k1 <*> m_k2++{-+Note [Defunctionalization game plan]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Generating defunctionalization symbols involves a surprising amount of+complexity. This Note gives a broad overview of what happens during+defunctionalization and highlights various design considerations.+As a working example, we will use the following type family:++ type Foo :: forall c a b. a -> b -> c -> c+ type family Foo x y z where ...++We must generate a defunctionalization symbol for every number of arguments+to which Foo can be partially applied. We do so by generating the following+declarations:++ type FooSym0 :: forall c a b. a ~> b ~> c ~> c+ data FooSym0 f where+ FooSym0KindInference :: SameKind (Apply FooSym0 arg) (FooSym1 arg)+ => FooSym0 f+ type instance Apply FooSym0 x = FooSym1 x++ type FooSym1 :: forall c a b. a -> b ~> c ~> c+ data FooSym1 x f where+ FooSym1KindInference :: SameKind (Apply (FooSym1 a) arg) (FooSym2 a arg)+ => FooSym1 a f+ type instance Apply (FooSym1 x) y = FooSym2 x y++ type FooSym2 :: forall c a b. a -> b -> c ~> c+ data FooSym2 x y f where+ FooSym2KindInference :: SameKind (Apply (FooSym2 x y) arg) (FooSym3 x y arg)+ => FooSym2 x y f+ type instance Apply (FooSym2 x y) z = Foo x y z++ type FooSym3 :: forall c a b. a -> b -> c -> c+ type family FooSym3 x y z where+ FooSym3 x y z = Foo x y z++Some things to note:++* Each defunctionalization symbol has its own standalone kind signature. The+ number after `Sym` in each symbol indicates the number of leading -> arrows+ in its kind—that is, the number of arguments to which it can be applied+ directly to without the use of the Apply type family.++ See "Wrinkle 1: Partial kinds" below for what happens if the declaration+ being defunctionalized does *not* have a standalone kind signature.++* Each data declaration has a constructor with the suffix `-KindInference`+ in its name. These are redundant in the particular case of Foo, where the+ kind is already known. They play a more vital role when the kind of the+ declaration being defunctionalized is only partially known.+ See "Wrinkle 1: Partial kinds" below for more information.++* FooSym3, the last defunctionalization symbol, is somewhat special in that+ it is a type family, not a data type. These sorts of symbols are referred+ to as "fully saturated" defunctionalization symbols.+ See Note [Fully saturated defunctionalization symbols].++* If Foo had a fixity declaration (e.g., infixl 4 `Foo`), then we would also+ generate fixity declarations for each defunctionalization symbol (e.g.,+ infixl 4 `FooSym0`).+ See Note [Fixity declarations for defunctionalization symbols].++* Foo has a vanilla kind signature. (See+ Note [Vanilla-type validity checking during promotion] in D.S.TH.Promote.Type+ for what "vanilla" means in this context.) Having a vanilla type signature is+ important, as it is a property that makes it much simpler to preserve the+ order of type variables (`forall c a b.`) in each of the defunctionalization+ symbols.++ That being said, it is not strictly required that the kind be vanilla. There+ is another approach that can be used to defunctionalize things with+ non-vanilla types, at the possible expense of having different type variable+ orders between different defunctionalization symbols.+ See "Wrinkle 2: Non-vanilla kinds" below for more information.++-----+-- Wrinkle 1: Partial kinds+-----++The Foo example above has a standalone kind signature, but not everything has+this much kind information. For example, consider this:++ $(singletons [d|+ type family Not x where+ Not False = True+ Not True = False+ |])++The inferred kind for Not is `Bool -> Bool`, but since Not was declared in TH+quotes, `singletons-th` has no knowledge of this. Instead, we must rely on kind+inference to give Not's defunctionalization symbols the appropriate kinds.+Here is a naïve first attempt:++ data NotSym0 f+ type instance Apply NotSym0 x = Not x++ type family NotSym1 x where+ NotSym1 x = Not x++NotSym1 will have the inferred kind `Bool -> Bool`, but poor NotSym0 will have+the inferred kind `forall k. k -> Type`, which is far more general than we+would like. We can do slightly better by supplying additional kind information+in a data constructor, like so:++ type SameKind :: k -> k -> Constraint+ class SameKind x y = ()++ data NotSym0 f where+ NotSym0KindInference :: SameKind (Apply NotSym0 arg) (NotSym1 arg)+ => NotSym0 f++NotSym0KindInference is not intended to ever be seen by the user. Its only+reason for existing is its existential+`SameKind (Apply NotSym0 arg) (NotSym1 arg)` context, which allows GHC to+figure out that NotSym0 has kind `Bool ~> Bool`. This is a bit of a hack, but+it works quite nicely. The only problem is that GHC is likely to warn that+NotSym0KindInference is unused, which is annoying. To work around this, we+mention the data constructor in an instance of a dummy class:++ instance SuppressUnusedWarnings NotSym0 where+ suppressUnusedWarnings = snd (NotSym0KindInference, ())++Similarly, this SuppressUnusedWarnings class is not intended to ever be seen+by the user. As its name suggests, it only exists to help suppress "unused+data constructor" warnings.++Some declarations have a mixture of known kinds and unknown kinds, such as in+this example:++ $(singletons [d|+ type family Bar x (y :: Nat) (z :: Nat) :: Nat where ...+ |])++We can use the known kinds to guide kind inference. In this particular example+of Bar, here are the defunctionalization symbols that would be generated:++ data BarSym0 f where ...+ data BarSym1 x :: Nat ~> Nat ~> Nat where ...+ data BarSym2 x (y :: Nat) :: Nat ~> Nat where ...+ type family BarSym3 x (y :: Nat) (z :: Nat) :: Nat where ...++-----+-- Wrinkle 2: Non-vanilla kinds+-----++There is only limited support for defunctionalizing declarations with+non-vanilla kinds. One example of something with a non-vanilla kind is the+following, which uses a nested forall:++ $(singletons [d|+ type Baz :: forall a. a -> forall b. b -> Type+ data Baz x y+ |])++One might envision generating the following defunctionalization symbols for+Baz:++ type BazSym0 :: forall a. a ~> forall b. b ~> Type+ data BazSym0 f where ...++ type BazSym1 :: forall a. a -> forall b. b ~> Type+ data BazSym1 x f where ...++ type BazSym2 :: forall a. a -> forall b. b -> Type+ type family BazSym2 x y where+ BazSym2 x y = Baz x y++Unfortunately, doing so would require impredicativity, since we would have:++ forall a. a ~> forall b. b ~> Type+ = forall a. (~>) a (forall b. b ~> Type)+ = forall a. TyFun a (forall b. b ~> Type) -> Type++Note that TyFun is an ordinary data type, so having its second argument be+(forall b. b ~> Type) is truly impredicative. As a result, trying to preserve+nested or higher-rank foralls is a non-starter.++We need not reject Baz entirely, however. We can still generate perfectly+usable defunctionalization symbols if we are willing to sacrifice the exact+order of foralls. When we encounter a non-vanilla kind such as Baz's, we simply+fall back to the algorithm used when we encounter a partial kind (as described+in "Wrinkle 1: Partial kinds" above.) In other words, we generate the+following symbols:++ data BazSym0 :: a ~> b ~> Type where ...+ data BazSym1 (x :: a) :: b ~> Type where ...+ type family BazSym2 (x :: a) (y :: b) :: Type where ...++The kinds of BazSym0 and BazSym1 both start with `forall a b.`,+whereas the `b` is quantified later in Baz itself. For most use cases, however,+this is not a huge concern.++Another way kinds can be non-vanilla is if they contain visible dependent+quantification, like so:++ $(singletons [d|+ type Quux :: forall (k :: Type) -> k -> Type+ data Quux x y+ |])++What should the kind of QuuxSym0 be? Intuitively, it should be this:++ type QuuxSym0 :: forall (k :: Type) ~> k ~> Type++Alas, `forall (k :: Type) ~>` simply doesn't work. See #304. But there is an+acceptable compromise we can make that can give us defunctionalization symbols+for Quux. Once again, we fall back to the partial kind algorithm:++ data QuuxSym0 :: Type ~> k ~> Type where ...+ data QuuxSym1 (k :: Type) :: k ~> Type where ...+ type family QuuxSym2 (k :: Type) (x :: k) :: Type where ...++The catch is that the kind of QuuxSym0, `forall k. Type ~> k ~> Type`, is+slightly more general than it ought to be. In practice, however, this is+unlikely to be a problem as long as you apply QuuxSym0 to arguments of the+right kinds.++Note [Fully saturated defunctionalization symbols]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When generating defunctionalization symbols, most of the symbols are data+types. The last one, however, is a type family. For example, this code:++ $(singletons [d|+ type Const :: a -> b -> a+ type Const x y = x+ |])++Will generate the following symbols:++ type ConstSym0 :: a ~> b ~> a+ data ConstSym0 f where ...++ type ConstSym1 :: a -> b ~> a+ data ConstSym1 x f where ...++ type ConstSym2 :: a -> b -> a+ type family ConstSym2 x y where+ ConstSym2 x y = Const x y++ConstSym2, the sole type family of the bunch, is what is referred to as a+"fully saturated" defunctionaliztion symbol.++At first glance, ConstSym2 may not seem terribly useful, since it is+effectively a thin wrapper around the original Const type. Indeed, fully+saturated symbols almost never appear directly in user-written code. Instead,+they are most valuable in TH-generated code, as singletons-th often generates code+that directly applies a defunctionalization symbol to some number of arguments+(see, for instance, D.S.TH.Names.promoteTySym). In theory, such code could carve+out a special case for fully saturated applications and apply the original+type instead of a defunctionalization symbol, but determining when an+application is fully saturated is often difficult in practice. As a result, it+is more convenient to just generate code that always applies FuncSymN to N+arguments, and to let fully saturated defunctionalization symbols handle the+case where N equals the number of arguments needed to fully saturate Func.++One might wonder if, instead of using a closed type family with a single+equation, we could use a type synonym to define ConstSym2:++ type ConstSym2 :: a -> b -> a+ type ConstSym2 x y = Const x y++This approach has various downsides which make it impractical:++* Type synonyms are often not expanded in the output of GHCi's :kind! command.+ As issue #445 chronicles, this can significantly impact the readability of+ even simple :kind! queries. It can be the difference between this:++ λ> :kind! Map IdSym0 '[1,2,3]+ Map IdSym0 '[1,2,3] :: [Nat]+ = 1 :@#@$$$ '[2, 3]++ And this:++ λ> :kind! Map IdSym0 '[1,2,3]+ Map IdSym0 '[1,2,3] :: [Nat]+ = '[1, 2, 3]++ Making fully saturated defunctionalization symbols like (:@#@$$$) type+ families makes this issue moot, since :kind! always expands type families.+* There are a handful of corner cases where using type synonyms can actually+ make fully saturated defunctionalization symbols fail to typecheck.+ Here is one such corner case:++ $(promote [d|+ class Applicative f where+ pure :: a -> f a+ ...+ (*>) :: f a -> f b -> f b+ |])++ ==>++ class PApplicative f where+ type Pure (x :: a) :: f a+ type (*>) (x :: f a) (y :: f b) :: f b++ What would happen if we were to defunctionalize the promoted version of (*>)?+ We'd end up with the following defunctionalization symbols:++ type (*>@#@$) :: f a ~> f b ~> f b+ data (*>@#@$) f where ...++ type (*>@#@$$) :: f a -> f b ~> f b+ data (*>@#@$$) x f where ...++ type (*>@#@$$$) :: f a -> f b -> f b+ type (*>@#@$$$) x y = (*>) x y++ It turns out, however, that (*>@#@$$$) will not kind-check. Because (*>@#@$$$)+ has a standalone kind signature, it is kind-generalized *before* kind-checking+ the actual definition itself. Therefore, the full kind is:++ type (*>@#@$$$) :: forall {k} (f :: k -> Type) (a :: k) (b :: k).+ f a -> f b -> f b+ type (*>@#@$$$) x y = (*>) x y++ However, the kind of (*>) is+ `forall (f :: Type -> Type) (a :: Type) (b :: Type). f a -> f b -> f b`.+ This is not general enough for (*>@#@$$$), which expects kind-polymorphic `f`,+ `a`, and `b`, leading to a kind error. You might think that we could somehow+ infer this information, but note the quoted definition of Applicative (and+ PApplicative, as a consequence) omits the kinds of `f`, `a`, and `b` entirely.+ Unless we were to implement full-blown kind inference inside of Template+ Haskell (which is a tall order), the kind `f a -> f b -> f b` is about as good+ as we can get.++ Making (*>@#@$$$) a type family rather than a type synonym avoids this issue+ since type family equations are allowed to match on kind arguments. In this+ example, (*>@#@$$$) would have kind-polymorphic `f`, `a`, and `b` in its kind+ signature, but its equation would implicitly equate `k` with `Type`. Note+ that (*>@#@$) and (*>@#@$$), which are GADTs, also use a similar trick by+ equating `k` with `Type` in their GADT constructors.++-----+-- Wrinkle: avoiding reduction stack overflows+-----++A naïve attempt at declaring all fully saturated defunctionalization symbols+as type families can make certain programs overflow the reduction stack, such+as the T445 test case. This is because when evaluating+`FSym0 `Apply` x_1 `Apply` ... `Apply` x_N`, (where F is a promoted function+that requires N arguments), we will eventually bottom out by evaluating+`FSymN x_1 ... x_N`, where FSymN is a fully saturated defunctionalization+symbol. Since FSymN is a type family, this is yet another type family+reduction that contributes to the overall reduction limit. This might not+seem like a lot, but it can add up if F is invoked several times in a single+type-level computation!++Fortunately, we can bypass evaluating FSymN entirely by just making a slight+tweak to the TH machinery. Instead of generating this Apply instance:++ type instance Apply (FSym{N-1} x_1 ... x_{N-1}) x_N =+ FSymN x_1 ... x_{N-1} x_N++Generate this instance, which jumps straight to F:++ type instance Apply (FSym{N-1} x_1 ... x_{N-1}) x_N =+ F x_1 ... x_{N-1} x_N++Now evaluating `FSym0 `Apply` x_1 `Apply` ... `Apply` x_N` will require one+less type family reduction. In practice, this is usually enough to keep the+reduction limit at bay in most situations.++Note [Fixity declarations for defunctionalization symbols]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Just like we promote fixity declarations, we should also generate fixity+declarations for defunctionaliztion symbols. A primary use case is the+following scenario:++ (.) :: (b -> c) -> (a -> b) -> (a -> c)+ (f . g) x = f (g x)+ infixr 9 .++One often writes (f . g . h) at the value level, but because (.) is promoted+to a type family with three arguments, this doesn't directly translate to the+type level. Instead, one must write this:++ f .@#@$$$ g .@#@$$$ h++But in order to ensure that this associates to the right as expected, one must+generate an `infixr 9 .@#@#$$$` declaration. This is why defunctionalize accepts+a Maybe Fixity argument.+-}
+ src/Data/Singletons/TH/Promote/Monad.hs view
@@ -0,0 +1,195 @@+{- 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.+-}++{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts,+ TypeFamilies, KindSignatures #-}++module Data.Singletons.TH.Promote.Monad (+ PrM, promoteM, promoteM_, promoteMDecs, VarPromotions,+ allLocals, emitDecs, emitDecsM,+ lambdaBind, LetBind, letBind, lookupVarE, forallBind, allBoundKindVars+ ) where++import Control.Monad.Reader+import Control.Monad.Writer+import Language.Haskell.TH.Syntax hiding ( lift )+import Language.Haskell.TH.Desugar+import qualified Language.Haskell.TH.Desugar.OMap.Strict as OMap+import Language.Haskell.TH.Desugar.OMap.Strict (OMap)+import qualified Language.Haskell.TH.Desugar.OSet as OSet+import Language.Haskell.TH.Desugar.OSet (OSet)+import Data.Singletons.TH.Options+import Data.Singletons.TH.Syntax++type LetExpansions = OMap Name DType -- from **term-level** name++-- environment during promotion+data PrEnv =+ PrEnv { pr_options :: Options+ , pr_lambda_bound :: OMap Name Name+ , pr_let_bound :: LetExpansions+ , pr_forall_bound :: OSet Name -- See Note [Explicitly binding kind variables]+ , pr_local_decls :: [Dec]+ }++emptyPrEnv :: PrEnv+emptyPrEnv = PrEnv { pr_options = defaultOptions+ , pr_lambda_bound = OMap.empty+ , pr_let_bound = OMap.empty+ , pr_forall_bound = OSet.empty+ , pr_local_decls = [] }++-- the promotion monad+newtype PrM a = PrM (ReaderT PrEnv (WriterT [DDec] Q) a)+ deriving ( Functor, Applicative, Monad, Quasi+ , MonadReader PrEnv, MonadWriter [DDec]+ , MonadFail, MonadIO )++instance DsMonad PrM where+ localDeclarations = asks pr_local_decls++instance OptionsMonad PrM where+ getOptions = asks pr_options++-- return *type-level* names+allLocals :: MonadReader PrEnv m => m [Name]+allLocals = do+ lambdas <- asks (OMap.assocs . pr_lambda_bound)+ lets <- asks pr_let_bound+ -- filter out shadowed variables!+ return [ typeName+ | (termName, typeName) <- lambdas+ , case OMap.lookup termName lets of+ Just (DVarT typeName') | typeName' == typeName -> True+ _ -> False ]++emitDecs :: MonadWriter [DDec] m => [DDec] -> m ()+emitDecs = tell++emitDecsM :: MonadWriter [DDec] m => m [DDec] -> m ()+emitDecsM action = do+ decs <- action+ emitDecs decs++-- when lambda-binding variables, we still need to add the variables+-- to the let-expansion, because of shadowing. ugh.+lambdaBind :: VarPromotions -> PrM a -> PrM a+lambdaBind binds = local add_binds+ where add_binds env@(PrEnv { pr_lambda_bound = lambdas+ , pr_let_bound = lets }) =+ let new_lets = OMap.fromList [ (tmN, DVarT tyN) | (tmN, tyN) <- binds ] in+ env { pr_lambda_bound = OMap.fromList binds `OMap.union` lambdas+ , pr_let_bound = new_lets `OMap.union` lets }++type LetBind = (Name, DType)+letBind :: [LetBind] -> PrM a -> PrM a+letBind binds = local add_binds+ where add_binds env@(PrEnv { pr_let_bound = lets }) =+ env { pr_let_bound = OMap.fromList binds `OMap.union` lets }++lookupVarE :: Name -> PrM DType+lookupVarE n = do+ opts <- getOptions+ lets <- asks pr_let_bound+ case OMap.lookup n lets of+ Just ty -> return ty+ Nothing -> return $ DConT $ defunctionalizedName0 opts n++-- Add to the set of bound kind variables currently in scope.+-- See Note [Explicitly binding kind variables]+forallBind :: OSet Name -> PrM a -> PrM a+forallBind kvs1 =+ local (\env@(PrEnv { pr_forall_bound = kvs2 }) ->+ env { pr_forall_bound = kvs1 `OSet.union` kvs2 })++-- Look up the set of bound kind variables currently in scope.+-- See Note [Explicitly binding kind variables]+allBoundKindVars :: PrM (OSet Name)+allBoundKindVars = asks pr_forall_bound++promoteM :: OptionsMonad q => [Dec] -> PrM a -> q (a, [DDec])+promoteM locals (PrM rdr) = do+ opts <- getOptions+ other_locals <- localDeclarations+ let wr = runReaderT rdr (emptyPrEnv { pr_options = opts+ , pr_local_decls = other_locals ++ locals })+ q = runWriterT wr+ runQ q++promoteM_ :: OptionsMonad q => [Dec] -> PrM () -> q [DDec]+promoteM_ locals thing = do+ ((), decs) <- promoteM locals thing+ return decs++-- promoteM specialized to [DDec]+promoteMDecs :: OptionsMonad q => [Dec] -> PrM [DDec] -> q [DDec]+promoteMDecs locals thing = do+ (decs1, decs2) <- promoteM locals thing+ return $ decs1 ++ decs2++{-+Note [Explicitly binding kind variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to ensure that when we single type signatures for functions and data+constructors, we should explicitly quantify every kind variable bound by a+forall. For example, if we were to single the identity function:++ identity :: forall a. a -> a+ identity x = x++We want the final result to be:++ sIdentity :: forall a (x :: a). Sing x -> Sing (Identity x :: a)+ sIdentity sX = sX++Accomplishing this takes a bit of care during promotion. When promoting a+function, we determine what set of kind variables are currently bound at that+point and store them in an ALetDecEnv (as lde_bound_kvs), which in turn is+singled. Then, during singling, we extract every kind variable in a singled+type signature, subtract the lde_bound_kvs, and explicitly bind the variables+that remain.++For a top-level function like identity, lde_bound_kvs is the empty set. But+consider this more complicated example:++ f :: forall a. a -> a+ f = g+ where+ g :: a -> a+ g x = x++When singling, we would eventually end up in this spot:++ sF :: forall a (x :: a). Sing a -> Sing (F a :: a)+ sF = sG+ where+ sG :: _+ sG x = x++We must make sure /not/ to fill in the following type for _:++ sF :: forall a (x :: a). Sing a -> Sing (F a :: a)+ sF = sG+ where+ sG :: forall a (y :: a). Sing a -> Sing (G a :: a)+ sG x = x++This would be incorrect, as the `a` bound by sF /must/ be the same one used in+sG, as per the scoping of the original `f` function. Thus, we ensure that the+bound variables from `f` are put into lde_bound_kvs when promoting `g` so+that we subtract out `a` and are left with the correct result:++ sF :: forall a (x :: a). Sing a -> Sing (F a :: a)+ sF = sG+ where+ sG :: forall (y :: a). Sing a -> Sing (G a :: a)+ sG x = x+-}
+ src/Data/Singletons/TH/Promote/Type.hs view
@@ -0,0 +1,112 @@+{- 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+ , promoteTypeArg_NC, promoteUnraveled+ ) where++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.+promoteType :: OptionsMonad m => DType -> m DKind+promoteType ty = do+ checkVanillaDType ty+ promoteType_NC ty++-- Promote a DType to the kind level. This is suffixed with "_NC" because+-- we do not invoke checkVanillaDType here.+-- See [Vanilla-type validity checking during promotion].+promoteType_NC :: OptionsMonad m => DType -> m DKind+promoteType_NC = go []+ where+ go :: OptionsMonad m => [DTypeArg] -> DType -> m DKind+ go [] (DForallT tele ty) = do+ ty' <- go [] ty+ pure $ DForallT tele ty'+ -- We don't need to worry about constraints: they are used to express+ -- static guarantees at runtime. But, because we don't need to do+ -- anything special to keep static guarantees at compile time, we don't+ -- need to promote them.+ go [] (DConstrainedT _cxt ty) = go [] ty+ go args (DAppT t1 t2) = do+ k2 <- go [] t2+ go (DTANormal k2 : args) t1+ -- NB: This next case means that promoting something like+ -- (((->) a) :: Type -> Type) b+ -- will fail because the pattern below won't recognize the+ -- arrow to turn it into a TyFun. But I'm not terribly+ -- bothered by this, and it would be annoying to fix. Wait+ -- for someone to report.+ go args (DAppKindT ty ki) = do+ ki' <- go [] ki+ go (DTyArg ki' : args) ty+ go args (DSigT ty ki) = do+ ty' <- go [] ty+ -- No need to promote 'ki' - it is already a kind.+ return $ applyDType (DSigT ty' ki) args+ go args (DVarT name) = return $ applyDType (DVarT name) args+ go args (DConT name) = do+ opts <- getOptions+ return $ applyDType (DConT (promotedDataTypeOrConName opts name)) args+ go [DTANormal k1, DTANormal k2] DArrowT+ = return $ DConT tyFunArrowName `DAppT` k1 `DAppT` k2+ go _ ty@DLitT{} = pure ty++ go args hd = fail $ "Illegal Haskell construct encountered:\n" +++ "headed by: " ++ show hd ++ "\n" +++ "applied to: " ++ show args++-- | Promote a DTypeArg to the kind level. This is suffixed with "_NC" because+-- we do not invoke checkVanillaDType here.+-- See [Vanilla-type validity checking during promotion].+promoteTypeArg_NC :: OptionsMonad m => DTypeArg -> m DTypeArg+promoteTypeArg_NC (DTANormal t) = DTANormal <$> promoteType_NC t+promoteTypeArg_NC ta@(DTyArg _) = pure ta -- Kinds are already promoted++-- | Promote a DType to the kind level, splitting it into its type variable+-- binders, argument types, and result type in the process.+promoteUnraveled :: OptionsMonad m+ => DType -> m ([DTyVarBndrSpec], [DKind], DKind)+promoteUnraveled ty = do+ (tvbs, _, arg_tys, res_ty) <- unravelVanillaDType ty+ arg_kis <- mapM promoteType_NC arg_tys+ res_ki <- promoteType_NC res_ty+ return (tvbs, arg_kis, res_ki)++{-+Note [Vanilla-type validity checking during promotion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We only support promoting (and singling) vanilla types, where a vanilla+function type is a type that:++1. Only uses a @forall@ at the top level, if used at all. That is to say, it+ does not contain any nested or higher-rank @forall@s.++2. Only uses a context (e.g., @c => ...@) at the top level, if used at all,+ and only after the top-level @forall@ if one is present. That is to say,+ it does not contain any nested or higher-rank contexts.++3. Contains no visible dependent quantification.++The checkVanillaDType function checks if a type is vanilla. Note that it is+crucial to call checkVanillaDType on the /entire/ type. For instance, it would+be incorrect to call unravelVanillaDType and then check each argument type+individually, since that loses information about which @forall@s/constraints+are higher-rank.++We make an effort to avoiding calling checkVanillaDType on the same type twice,+since checkVanillaDType must traverse the entire type. (It would not be+incorrect to do so, just wasteful.) For this certain, certain functions are+suffixed with "_NC" (short for "no checking") to indicate that they do not+invoke checkVanillaDType. These functions are used on types that have already+been validity-checked.+-}
+ src/Data/Singletons/TH/Single.hs view
@@ -0,0 +1,1151 @@+{- 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.+-}+{-# LANGUAGE TemplateHaskellQuotes, TupleSections, ParallelListComp #-}++module Data.Singletons.TH.Single where++import Prelude hiding ( exp )+import Language.Haskell.TH hiding ( cxt )+import Language.Haskell.TH.Syntax (NameSpace(..), Quasi(..))+import Data.Singletons.TH.Deriving.Bounded+import Data.Singletons.TH.Deriving.Enum+import Data.Singletons.TH.Deriving.Eq+import Data.Singletons.TH.Deriving.Infer+import Data.Singletons.TH.Deriving.Ord+import Data.Singletons.TH.Deriving.Show+import Data.Singletons.TH.Deriving.Util+import Data.Singletons.TH.Names+import Data.Singletons.TH.Options+import Data.Singletons.TH.Partition+import Data.Singletons.TH.Promote+import Data.Singletons.TH.Promote.Defun+import Data.Singletons.TH.Promote.Monad ( promoteM )+import Data.Singletons.TH.Promote.Type+import Data.Singletons.TH.Single.Data+import Data.Singletons.TH.Single.Decide+import Data.Singletons.TH.Single.Defun+import Data.Singletons.TH.Single.Fixity+import Data.Singletons.TH.Single.Monad+import Data.Singletons.TH.Single.Type+import Data.Singletons.TH.Syntax+import Data.Singletons.TH.Util+import Language.Haskell.TH.Desugar+import qualified Language.Haskell.TH.Desugar.OMap.Strict as OMap+import Language.Haskell.TH.Desugar.OMap.Strict (OMap)+import qualified Language.Haskell.TH.Desugar.OSet as OSet+import Language.Haskell.TH.Desugar.OSet (OSet)+import qualified Data.Map.Strict as Map+import Data.Map.Strict ( Map )+import Data.Maybe+import qualified Data.Set as Set+import Control.Monad+import Control.Monad.Trans.Class+import Data.List (unzip6, zipWith4)+import qualified GHC.LanguageExtensions.Type as LangExt++{-+How singletons-th works+~~~~~~~~~~~~~~~~~~~~~~~++Singling, on the surface, doesn't seem all that complicated. Promote the type,+and singletonize all the terms. That's essentially what was done singletons < 1.0.+But, now we want to deal with higher-order singletons. So, things are a little+more complicated.++The way to understand all of this is that *every* variable maps to something+of type (Sing t), for an appropriately-kinded t. This includes functions, which+use the "SLambda" instance of Sing. To apply singleton functions, we use the+applySing function.++That, in and of itself, wouldn't be too hard, but it's really annoying from+the user standpoint. After dutifully singling `map`, a user doesn't want to+have to use two `applySing`s to actually use it. So, any let-bound identifier+is eta-expanded so that the singled type has the same number of arrows as+the original type. (If there is no original type signature, then it has as+many arrows as the original had patterns.) Then, we store a use of one of the+singFunX functions in the SgM environment so that every use of a let-bound+identifier has a proper type (Sing t).++It would be consistent to avoid this eta-expansion for local lets (as opposed+to top-level lets), but that seemed like more bother than it was worth. It+may also be possible to be cleverer about nested eta-expansions and contractions,+but that also seemed not to be worth it. Though I haven't tested it, my hope+is that the eta-expansions and contractions have no runtime effect, especially+because SLambda is a *newtype* instance, not a *data* instance.++Note that to maintain the desired invariant, we must also be careful to eta-+contract constructors. This is the point of buildDataLets.+-}++-- | Generate singled definitions for each of the provided type-level+-- declaration 'Name's. For example, the singletons-th package itself uses+--+-- > $(genSingletons [''Bool, ''Maybe, ''Either, ''[]])+--+-- to generate singletons for Prelude types.+genSingletons :: OptionsMonad q => [Name] -> q [Dec]+genSingletons names = do+ opts <- getOptions+ -- See Note [Disable genQuotedDecs in genPromotions and genSingletons]+ -- in D.S.TH.Promote+ withOptions opts{genQuotedDecs = False} $ do+ checkForRep names+ ddecs <- concatMapM (singInfo <=< dsInfo <=< reifyWithLocals) names+ return $ decsToTH ddecs++-- | Make promoted and singled versions of all declarations given, retaining+-- the original declarations. See the+-- @<https://github.com/goldfirere/singletons/blob/master/README.md README>@+-- for further explanation.+singletons :: OptionsMonad q => q [Dec] -> q [Dec]+singletons qdecs = do+ opts <- getOptions+ withOptions opts{genQuotedDecs = True} $ singletons' $ lift qdecs++-- | Make promoted and singled versions of all declarations given, discarding+-- the original declarations. Note that a singleton based on a datatype needs+-- the original datatype, so this will fail if it sees any datatype declarations.+-- Classes, instances, and functions are all fine.+singletonsOnly :: OptionsMonad q => q [Dec] -> q [Dec]+singletonsOnly qdecs = do+ opts <- getOptions+ withOptions opts{genQuotedDecs = False} $ singletons' $ lift qdecs++-- The workhorse for 'singletons' and 'singletonsOnly'. The difference between+-- the two functions is whether 'genQuotedDecs' is set to 'True' or 'False'.+singletons' :: OptionsMonad q => q [Dec] -> q [Dec]+singletons' qdecs = do+ opts <- getOptions+ decs <- qdecs+ ddecs <- withLocalDeclarations decs $ dsDecs decs+ singDecs <- singTopLevelDecs decs ddecs+ let origDecs | genQuotedDecs opts = decs+ | otherwise = []+ return $ origDecs ++ decsToTH singDecs++-- | Create instances of 'SEq' for the given types+singEqInstances :: OptionsMonad q => [Name] -> q [Dec]+singEqInstances = concatMapM singEqInstance++-- | Create instance of 'SEq' for the given type+singEqInstance :: OptionsMonad q => Name -> q [Dec]+singEqInstance = singInstance mkEqInstance "Eq"++-- | Create instances of 'SDecide', 'TestEquality', and 'TestCoercion' for each+-- type in the list.+singDecideInstances :: OptionsMonad q => [Name] -> q [Dec]+singDecideInstances = concatMapM singDecideInstance++-- | Create instances of 'SDecide', 'TestEquality', and 'TestCoercion' for the+-- given type.+singDecideInstance :: OptionsMonad q => Name -> q [Dec]+singDecideInstance name = do+ (tvbs, cons) <- getDataD ("I cannot make an instance of SDecide for it.") name+ dtvbs <- mapM dsTvbUnit tvbs+ let data_ty = foldTypeTvbs (DConT name) dtvbs+ dcons <- concatMapM (dsCon dtvbs data_ty) cons+ let tyvars = map (DVarT . extractTvbName) dtvbs+ kind = foldType (DConT name) tyvars+ (scons, _) <- singM [] $ mapM (singCtor name) dcons+ sDecideInstance <- mkDecideInstance Nothing kind dcons scons+ testInstances <- traverse (mkTestInstance Nothing kind name dcons)+ [TestEquality, TestCoercion]+ return $ decsToTH (sDecideInstance:testInstances)++-- | Create instances of 'SOrd' for the given types+singOrdInstances :: OptionsMonad q => [Name] -> q [Dec]+singOrdInstances = concatMapM singOrdInstance++-- | Create instance of 'SOrd' for the given type+singOrdInstance :: OptionsMonad q => Name -> q [Dec]+singOrdInstance = singInstance mkOrdInstance "Ord"++-- | Create instances of 'SBounded' for the given types+singBoundedInstances :: OptionsMonad q => [Name] -> q [Dec]+singBoundedInstances = concatMapM singBoundedInstance++-- | Create instance of 'SBounded' for the given type+singBoundedInstance :: OptionsMonad q => Name -> q [Dec]+singBoundedInstance = singInstance mkBoundedInstance "Bounded"++-- | Create instances of 'SEnum' for the given types+singEnumInstances :: OptionsMonad q => [Name] -> q [Dec]+singEnumInstances = concatMapM singEnumInstance++-- | Create instance of 'SEnum' for the given type+singEnumInstance :: OptionsMonad q => Name -> q [Dec]+singEnumInstance = singInstance mkEnumInstance "Enum"++-- | Create instance of 'SShow' for the given type+--+-- (Not to be confused with 'showShowInstance'.)+singShowInstance :: OptionsMonad q => Name -> q [Dec]+singShowInstance = singInstance mkShowInstance "Show"++-- | Create instances of 'SShow' for the given types+--+-- (Not to be confused with 'showSingInstances'.)+singShowInstances :: OptionsMonad q => [Name] -> q [Dec]+singShowInstances = concatMapM singShowInstance++-- | Create instance of 'Show' for the given singleton type+--+-- (Not to be confused with 'singShowInstance'.)+showSingInstance :: OptionsMonad q => Name -> q [Dec]+showSingInstance name = do+ (tvbs, cons) <- getDataD ("I cannot make an instance of Show for it.") name+ dtvbs <- mapM dsTvbUnit tvbs+ let data_ty = foldTypeTvbs (DConT name) dtvbs+ dcons <- concatMapM (dsCon dtvbs data_ty) cons+ let tyvars = map (DVarT . extractTvbName) dtvbs+ kind = foldType (DConT name) tyvars+ data_decl = DataDecl name dtvbs dcons+ deriv_show_decl = DerivedDecl { ded_mb_cxt = Nothing+ , ded_type = kind+ , ded_type_tycon = name+ , ded_decl = data_decl }+ (show_insts, _) <- singM [] $ singDerivedShowDecs deriv_show_decl+ pure $ decsToTH show_insts++-- | Create instances of 'Show' for the given singleton types+--+-- (Not to be confused with 'singShowInstances'.)+showSingInstances :: OptionsMonad q => [Name] -> q [Dec]+showSingInstances = concatMapM showSingInstance++-- | Create an instance for @'SingI' TyCon{N}@, where @N@ is the positive+-- number provided as an argument.+--+-- Note that the generated code requires the use of the @QuantifiedConstraints@+-- language extension.+singITyConInstances :: DsMonad q => [Int] -> q [Dec]+singITyConInstances = mapM singITyConInstance++-- | Create an instance for @'SingI' TyCon{N}@, where @N@ is the positive+-- number provided as an argument.+--+-- Note that the generated code requires the use of the @QuantifiedConstraints@+-- language extension.+singITyConInstance :: DsMonad q => Int -> q Dec+singITyConInstance n+ | n <= 0+ = fail $ "Argument must be a positive number (given " ++ show n ++ ")"+ | otherwise+ = do as <- replicateM n (qNewName "a")+ ks <- replicateM n (qNewName "k")+ k_last <- qNewName "k_last"+ f <- qNewName "f"+ x <- qNewName "x"+ let k_penult = last ks+ k_fun = ravelVanillaDType [] [] (map DVarT ks) (DVarT k_last)+ f_ty = DVarT f+ a_tys = map DVarT as+ mk_fun arrow t1 t2 = arrow `DAppT` t1 `DAppT` t2+ matchable_apply_fun = mk_fun DArrowT (DVarT k_penult) (DVarT k_last)+ unmatchable_apply_fun = mk_fun (DConT tyFunArrowName) (DVarT k_penult) (DVarT k_last)+ ctxt = [ DForallT (DForallInvis (map (`DPlainTV` SpecifiedSpec) as)) $+ DConstrainedT (map (DAppT (DConT singIName)) a_tys)+ (DConT singIName `DAppT` foldType f_ty a_tys)+ , DConT equalityName+ `DAppT` (DConT applyTyConName `DSigT`+ mk_fun DArrowT matchable_apply_fun unmatchable_apply_fun)+ `DAppT` DConT applyTyConAux1Name+ ]+ pure $ decToTH+ $ DInstanceD+ Nothing Nothing ctxt+ (DConT singIName `DAppT` (DConT (mkTyConName n) `DAppT` (f_ty `DSigT` k_fun)))+ [DLetDec $ DFunD singMethName+ [DClause [] $+ wrapSingFun 1 DWildCardT $+ DLamE [x] $+ DVarE withSingIName `DAppE` DVarE x+ `DAppE` DVarE singMethName]]++singInstance :: OptionsMonad q => DerivDesc q -> String -> Name -> q [Dec]+singInstance mk_inst inst_name name = do+ (tvbs, cons) <- getDataD ("I cannot make an instance of " ++ inst_name+ ++ " for it.") name+ dtvbs <- mapM dsTvbUnit tvbs+ let data_ty = foldTypeTvbs (DConT name) dtvbs+ dcons <- concatMapM (dsCon dtvbs data_ty) cons+ let data_decl = DataDecl name dtvbs dcons+ raw_inst <- mk_inst Nothing data_ty data_decl+ (a_inst, decs) <- promoteM [] $+ promoteInstanceDec OMap.empty Map.empty raw_inst+ decs' <- singDecsM [] $ (:[]) <$> singInstD a_inst+ return $ decsToTH (decs ++ decs')++singInfo :: OptionsMonad q => DInfo -> q [DDec]+singInfo (DTyConI dec _) =+ singTopLevelDecs [] [dec]+singInfo (DPrimTyConI _name _numArgs _unlifted) =+ fail "Singling of primitive type constructors not supported"+singInfo (DVarI _name _ty _mdec) =+ fail "Singling of value info not supported"+singInfo (DTyVarI _name _ty) =+ fail "Singling of type variable info not supported"+singInfo (DPatSynI {}) =+ fail "Singling of pattern synonym info not supported"++singTopLevelDecs :: OptionsMonad q => [Dec] -> [DDec] -> q [DDec]+singTopLevelDecs locals raw_decls = withLocalDeclarations locals $ do+ decls <- expand raw_decls -- expand type synonyms+ PDecs { pd_let_decs = letDecls+ , pd_class_decs = classes+ , pd_instance_decs = insts+ , pd_data_decs = datas+ , pd_ty_syn_decs = ty_syns+ , pd_open_type_family_decs = o_tyfams+ , pd_closed_type_family_decs = c_tyfams+ , pd_derived_eq_decs = derivedEqDecs+ , pd_derived_show_decs = derivedShowDecs } <- partitionDecs decls++ ((letDecEnv, classes', insts'), promDecls) <- promoteM locals $ do+ defunTopLevelTypeDecls ty_syns c_tyfams o_tyfams+ recSelLetDecls <- promoteDataDecs datas+ (_, letDecEnv) <- promoteLetDecs Nothing $ recSelLetDecls ++ letDecls+ classes' <- mapM promoteClassDec classes+ let meth_sigs = foldMap (lde_types . cd_lde) classes+ cls_tvbs_map = Map.fromList $ map (\cd -> (cd_name cd, cd_tvbs cd)) classes+ insts' <- mapM (promoteInstanceDec meth_sigs cls_tvbs_map) insts+ return (letDecEnv, classes', insts')++ singDecsM locals $ do+ dataLetBinds <- concatMapM buildDataLets datas+ methLetBinds <- concatMapM buildMethLets classes+ let letBinds = dataLetBinds ++ methLetBinds+ (newLetDecls, singIDefunDecls, newDecls)+ <- bindLets letBinds $+ singLetDecEnv letDecEnv $ do+ newDataDecls <- concatMapM singDataD datas+ newClassDecls <- mapM singClassD classes'+ newInstDecls <- mapM singInstD insts'+ newDerivedEqDecs <- concatMapM singDerivedEqDecs derivedEqDecs+ newDerivedShowDecs <- concatMapM singDerivedShowDecs derivedShowDecs+ return $ newDataDecls ++ newClassDecls+ ++ newInstDecls+ ++ newDerivedEqDecs+ ++ newDerivedShowDecs+ return $ promDecls ++ (map DLetDec newLetDecls) ++ singIDefunDecls ++ newDecls++-- see comment at top of file+buildDataLets :: OptionsMonad q => DataDecl -> q [(Name, DExp)]+buildDataLets (DataDecl _name _tvbs cons) = do+ opts <- getOptions+ pure $ concatMap (con_num_args opts) cons+ where+ con_num_args :: Options -> DCon -> [(Name, DExp)]+ con_num_args opts (DCon _tvbs _cxt name fields _rty) =+ (name, wrapSingFun (length (tysOfConFields fields))+ (DConT $ defunctionalizedName0 opts name)+ (DConE $ singledDataConName opts name))+ : rec_selectors opts fields++ rec_selectors :: Options -> DConFields -> [(Name, DExp)]+ rec_selectors _ (DNormalC {}) = []+ rec_selectors opts (DRecC fields) =+ let names = map fstOf3 fields in+ [ (name, wrapSingFun 1 (DConT $ defunctionalizedName0 opts name)+ (DVarE $ singledValueName opts name))+ | name <- names ]++-- see comment at top of file+buildMethLets :: OptionsMonad q => UClassDecl -> q [(Name, DExp)]+buildMethLets (ClassDecl { cd_lde = LetDecEnv { lde_types = meth_sigs } }) = do+ opts <- getOptions+ pure $ map (mk_bind opts) (OMap.assocs meth_sigs)+ where+ mk_bind opts (meth_name, meth_ty) =+ ( meth_name+ , wrapSingFun (countArgs meth_ty) (DConT $ defunctionalizedName0 opts meth_name)+ (DVarE $ singledValueName opts meth_name) )++singClassD :: AClassDecl -> SgM DDec+singClassD (ClassDecl { cd_cxt = cls_cxt+ , cd_name = cls_name+ , cd_tvbs = cls_tvbs+ , cd_fds = cls_fundeps+ , cd_lde = LetDecEnv { lde_defns = default_defns+ , lde_types = meth_sigs+ , lde_infix = fixities+ , lde_proms = promoted_defaults+ , lde_bound_kvs = meth_bound_kvs } }) =+ bindContext [foldTypeTvbs (DConT cls_name) cls_tvbs] $ do+ opts <- getOptions+ mb_cls_sak <- dsReifyType cls_name+ let sing_cls_name = singledClassName opts cls_name+ mb_sing_cls_sak = fmap (DKiSigD sing_cls_name) mb_cls_sak+ cls_infix_decls <- singReifiedInfixDecls $ cls_name:meth_names+ (sing_sigs, _, tyvar_names, cxts, res_kis, singIDefunss)+ <- unzip6 <$> zipWithM (singTySig no_meth_defns meth_sigs meth_bound_kvs)+ meth_names+ (map (DConT . defunctionalizedName0 opts) meth_names)+ emitDecs $ maybeToList mb_sing_cls_sak ++ cls_infix_decls ++ concat singIDefunss+ let default_sigs = catMaybes $+ zipWith4 (mk_default_sig opts) meth_names sing_sigs+ tyvar_names res_kis+ res_ki_map = Map.fromList (zip meth_names+ (map (fromMaybe always_sig) res_kis))+ sing_meths <- mapM (uncurry (singLetDecRHS (Map.fromList tyvar_names)+ (Map.fromList cxts)+ res_ki_map))+ (OMap.assocs default_defns)+ fixities' <- mapMaybeM (uncurry singInfixDecl) $ OMap.assocs fixities+ cls_cxt' <- mapM singPred cls_cxt+ return $ DClassD cls_cxt'+ sing_cls_name+ cls_tvbs+ cls_fundeps -- they are fine without modification+ (map DLetDec (sing_sigs ++ sing_meths ++ fixities') ++ default_sigs)+ where+ no_meth_defns = error "Internal error: can't find declared method type"+ always_sig = error "Internal error: no signature for default method"+ meth_names = map fst $ OMap.assocs meth_sigs++ mk_default_sig opts meth_name (DSigD s_name sty) bound_kvs (Just res_ki) =+ DDefaultSigD s_name <$> add_constraints opts meth_name sty bound_kvs res_ki+ mk_default_sig _ _ _ _ _ = error "Internal error: a singled signature isn't a signature."++ add_constraints opts meth_name sty (_, bound_kvs) res_ki = do -- Maybe monad+ (tvbs, cxt, args, res) <- unravelVanillaDType sty+ prom_dflt <- OMap.lookup meth_name promoted_defaults++ -- Filter out explicitly bound kind variables. Otherwise, if you had+ -- the following class (#312):+ --+ -- class Foo a where+ -- bar :: a -> b -> b+ -- bar _ x = x+ --+ -- Then it would be singled to:+ --+ -- class SFoo a where+ -- sBar :: forall b (x :: a) (y :: b). Sing x -> Sing y -> Sing (sBar x y)+ -- default :: forall b (x :: a) (y :: b).+ -- (Bar b x y) ~ (BarDefault b x y) => ...+ --+ -- Which applies Bar/BarDefault to b, which shouldn't happen.+ let tvs = map tvbToType $+ filter (\tvb -> extractTvbName tvb `Set.member` bound_kv_set) tvbs+ prom_meth = DConT $ defunctionalizedName0 opts meth_name+ default_pred = foldType (DConT equalityName)+ -- NB: Need the res_ki here to prevent ambiguous+ -- kinds in result-inferred default methods.+ -- See #175+ [ foldApply prom_meth tvs `DSigT` res_ki+ , foldApply prom_dflt tvs ]+ return $ ravelVanillaDType tvbs (default_pred : cxt) args res+ where+ bound_kv_set = Set.fromList bound_kvs++singInstD :: AInstDecl -> SgM DDec+singInstD (InstDecl { id_cxt = cxt, id_name = inst_name, id_arg_tys = inst_tys+ , id_sigs = inst_sigs, id_meths = ann_meths }) = do+ opts <- getOptions+ let s_inst_name = singledClassName opts inst_name+ bindContext cxt $ do+ cxt' <- mapM singPred cxt+ inst_kis <- mapM promoteType inst_tys+ meths <- concatMapM (uncurry sing_meth) ann_meths+ return (DInstanceD Nothing+ Nothing+ cxt'+ (foldl DAppT (DConT s_inst_name) inst_kis)+ meths)++ where+ sing_meth :: Name -> ALetDecRHS -> SgM [DDec]+ sing_meth name rhs = do+ opts <- getOptions+ mb_s_info <- dsReify (singledValueName opts name)+ inst_kis <- mapM promoteType inst_tys+ let mk_subst cls_tvbs = Map.fromList $ zip (map extractTvbName vis_cls_tvbs) inst_kis+ where+ -- This is a half-hearted attempt to address the underlying problem+ -- in #358, where we can sometimes have more class type variables+ -- (due to implicit kind arguments) than class arguments. This just+ -- ensures that the explicit type variables are properly mapped+ -- to the class arguments, leaving the implicit kind variables+ -- unmapped. That could potentially cause *other* problems, but+ -- those are perhaps best avoided by using InstanceSigs. At the+ -- very least, this workaround will make error messages slightly+ -- less confusing.+ vis_cls_tvbs = drop (length cls_tvbs - length inst_kis) cls_tvbs++ sing_meth_ty :: OSet Name -> DType+ -> SgM (DType, [Name], DCxt, DKind)+ sing_meth_ty bound_kvs inner_ty = do+ -- Make sure to expand through type synonyms here! Not doing so+ -- resulted in #167.+ raw_ty <- expand inner_ty+ (s_ty, _num_args, tyvar_names, ctxt, _arg_kis, res_ki)+ <- singType bound_kvs (DConT $ defunctionalizedName0 opts name) raw_ty+ pure (s_ty, tyvar_names, ctxt, res_ki)++ (s_ty, tyvar_names, ctxt, m_res_ki) <- case OMap.lookup name inst_sigs of+ Just inst_sig -> do+ -- We have an InstanceSig, so just single that type. Take care to+ -- avoid binding the variables bound by the instance head as well.+ let inst_bound = foldMap fvDType (cxt ++ inst_kis)+ (s_ty, tyvar_names, ctxt, res_ki) <- sing_meth_ty inst_bound inst_sig+ pure (s_ty, tyvar_names, ctxt, Just res_ki)+ Nothing -> case mb_s_info of+ -- We don't have an InstanceSig, so we must compute the type to use+ -- in the singled instance ourselves through reification.+ Just (DVarI _ (DForallT (DForallInvis cls_tvbs) (DConstrainedT _cls_pred s_ty)) _) -> do+ (sing_tvbs, ctxt, _args, res_ty) <- unravelVanillaDType s_ty+ let subst = mk_subst cls_tvbs+ m_res_ki = case res_ty of+ _sing `DAppT` (_prom_func `DSigT` res_ki) -> Just (substKind subst res_ki)+ _ -> Nothing++ pure ( substType subst s_ty+ , map extractTvbName sing_tvbs+ , map (substType subst) ctxt+ , m_res_ki )+ _ -> do+ mb_info <- dsReify name+ case mb_info of+ Just (DVarI _ (DForallT (DForallInvis cls_tvbs)+ (DConstrainedT _cls_pred inner_ty)) _) -> do+ let subst = mk_subst cls_tvbs+ cls_kvb_names = foldMap (foldMap fvDType . extractTvbKind) cls_tvbs+ cls_tvb_names = OSet.fromList $ map extractTvbName cls_tvbs+ cls_bound = cls_kvb_names `OSet.union` cls_tvb_names+ (s_ty, tyvar_names, ctxt, res_ki) <- sing_meth_ty cls_bound inner_ty+ pure ( substType subst s_ty+ , tyvar_names+ , ctxt+ , Just (substKind subst res_ki) )+ _ -> fail $ "Cannot find type of method " ++ show name++ let kind_map = maybe Map.empty (Map.singleton name) m_res_ki+ meth' <- singLetDecRHS (Map.singleton name tyvar_names)+ (Map.singleton name ctxt)+ kind_map name rhs+ return $ map DLetDec [DSigD (singledValueName opts name) s_ty, meth']++singLetDecEnv :: ALetDecEnv+ -> SgM a+ -> SgM ([DLetDec], [DDec], a)+ -- Return:+ --+ -- 1. The singled let-decs+ -- 2. SingI instances for any defunctionalization symbols+ -- (see Data.Singletons.TH.Single.Defun)+ -- 3. The result of running the `SgM a` action+singLetDecEnv (LetDecEnv { lde_defns = defns+ , lde_types = types+ , lde_infix = infix_decls+ , lde_proms = proms+ , lde_bound_kvs = bound_kvs })+ thing_inside = do+ let prom_list = OMap.assocs proms+ (typeSigs, letBinds, tyvarNames, cxts, res_kis, singIDefunss)+ <- unzip6 <$> mapM (uncurry (singTySig defns types bound_kvs)) prom_list+ infix_decls' <- mapMaybeM (uncurry singInfixDecl) $ OMap.assocs infix_decls+ let res_ki_map = Map.fromList [ (name, res_ki) | ((name, _), Just res_ki)+ <- zip prom_list res_kis ]+ bindLets letBinds $ do+ let_decs <- mapM (uncurry (singLetDecRHS (Map.fromList tyvarNames)+ (Map.fromList cxts)+ res_ki_map))+ (OMap.assocs defns)+ thing <- thing_inside+ return (infix_decls' ++ typeSigs ++ let_decs, concat singIDefunss, thing)++singTySig :: OMap Name ALetDecRHS -- definitions+ -> OMap Name DType -- type signatures+ -> OMap Name (OSet Name) -- bound kind variables+ -> Name -> DType -- the type is the promoted type, not the type sig!+ -> SgM ( DLetDec -- the new type signature+ , (Name, DExp) -- the let-bind entry+ , (Name, [Name]) -- the scoped tyvar names in the tysig+ , (Name, DCxt) -- the context of the type signature+ , Maybe DKind -- the result kind in the tysig+ , [DDec] -- SingI instances for defun symbols+ )+singTySig defns types bound_kvs name prom_ty = do+ opts <- getOptions+ let sName = singledValueName opts name+ case OMap.lookup name types of+ Nothing -> do+ num_args <- guess_num_args+ (sty, tyvar_names) <- mk_sing_ty num_args+ singIDefuns <- singDefuns name VarName []+ (map (const Nothing) tyvar_names) Nothing+ return ( DSigD sName sty+ , (name, wrapSingFun num_args prom_ty (DVarE sName))+ , (name, tyvar_names)+ , (name, [])+ , Nothing+ , singIDefuns )+ Just ty -> do+ all_bound_kvs <- lookup_bound_kvs+ (sty, num_args, tyvar_names, ctxt, arg_kis, res_ki)+ <- singType all_bound_kvs prom_ty ty+ bound_cxt <- askContext+ singIDefuns <- singDefuns name VarName (bound_cxt ++ ctxt)+ (map Just arg_kis) (Just res_ki)+ return ( DSigD sName sty+ , (name, wrapSingFun num_args prom_ty (DVarE sName))+ , (name, tyvar_names)+ , (name, ctxt)+ , Just res_ki+ , singIDefuns )+ where+ guess_num_args :: SgM Int+ guess_num_args =+ case OMap.lookup name defns of+ Nothing -> fail "Internal error: promotion known for something not let-bound."+ Just (AValue _ n _) -> return n+ Just (AFunction _ n _) -> return n++ lookup_bound_kvs :: SgM (OSet Name)+ lookup_bound_kvs =+ case OMap.lookup name bound_kvs of+ Nothing -> fail $ "Internal error: " ++ nameBase name ++ " has no type variable "+ ++ "bindings, despite having a type signature"+ Just kvs -> pure kvs++ -- create a Sing t1 -> Sing t2 -> ... type of a given arity and result type+ mk_sing_ty :: Int -> SgM (DType, [Name])+ mk_sing_ty n = do+ arg_names <- replicateM n (qNewName "arg")+ -- If there are no arguments, use `Sing @_` instead of `Sing`.+ -- See Note [Disable kind generalization for local functions if possible]+ let sing_w_wildcard | n == 0 = singFamily `DAppKindT` DWildCardT+ | otherwise = singFamily+ return ( ravelVanillaDType+ (map (`DPlainTV` SpecifiedSpec) arg_names)+ []+ (map (\nm -> singFamily `DAppT` DVarT nm) arg_names)+ (sing_w_wildcard `DAppT`+ (foldl apply prom_ty (map DVarT arg_names)))+ , arg_names )++{-+Note [Disable kind generalization for local functions if possible]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this example (from #296):++ f :: forall a. MyProxy a -> MyProxy a+ f MyProxy =+ let x = let z :: MyProxy a+ z = MyProxy in z+ in x++A naïve attempt at singling `f` is as follows:++ type LetZ :: MyProxy a+ type family LetZ where+ LetZ = 'MyProxy++ type family LetX where+ LetX = LetZ++ type F :: forall a. MyProxy a -> MyProxy a+ type family F x where+ F 'MyProxy = LetX++ sF :: forall a (t :: MyProxy a). Sing t -> Sing (F t :: MyProxy a)+ sF SMyProxy =+ let sX :: Sing LetX+ sX = let sZ :: Sing (LetZ :: MyProxy a)+ sZ = SMyProxy in sZ+ in sX++This will not typecheck, however. The is because the return kind of+`LetX` (in `let sX :: Sing LetX`) will get generalized by virtue of `sX`+having a type signature. It's as if one had written this:++ sF :: forall a (t :: MyProxy a). Sing t -> Sing (F t :: MyProxy a)+ sF SMyProxy =+ let sX :: forall a1. Sing (LetX :: MyProxy a1)+ sX = ...++This is too general, since `sX` will only typecheck if the return kind of+`LetX` is `MyProxy a`, not `MyProxy a1`. In order to avoid this problem,+we need to avoid kind generalization when kind-checking the type of `sX`.+To accomplish this, we borrow a trick from+Note [The id hack; or, how singletons-th learned to stop worrying and avoid kind generalization]+and use TypeApplications plus a wildcard type. That is, we generate this code+for `sF`:++ sF :: forall a (t :: MyProxy a). Sing t -> Sing (F t :: MyProxy a)+ sF SMyProxy =+ let sX :: Sing @_ LetX+ sX = ...++The presence of the wildcard type disables kind generalization, which allows+GHC's kind inference to deduce that the return kind of `LetX` should be `a`.+Now `sF` typechecks, and since we only use wildcards within visible kind+applications, we don't even have to force users to enable+PartialTypeSignatures. Hooray!++Question: where should we put wildcard types when singling? One possible answer+is: put a wildcard in any type signature that gets generated when singling a+function that lacks a type signature. Unfortunately, this is a step too far.+This will break singling the `foldr` function:++ foldr :: (a -> b -> b) -> b -> [a] -> b+ foldr k z = go+ where+ go [] = z+ go (y:ys) = y `k` go ys++If the type of `sGo` is given a wildcard, then it will fail to typecheck. This+is because `sGo` is polymorphically recursive, so disabling kind generalization+forces GHC to infer `sGo`'s type. Attempting to infer a polymorphically+recursive type, unsurprisingly, leads to failure.++To avoid this sort of situation, where adopt a simple metric: if a function+lacks a type signature, only put @_ in its singled type signature if it has+zero arguments. This allows `sX` to typecheck without breaking things like+`sGo`. This metric is a bit conservative, however, since it means that this+small tweak to `x` still would not typecheck:++ f :: forall a. MyProxy a -> MyProxy a+ f MyProxy =+ let x () = let z :: MyProxy a+ z = MyProxy in z+ in x ()++We need not let perfect be the enemy of good, however. It is extremely+common for local definitions to have zero arguments, so it makes good sense+to optimize for that special case. In fact, this special treatment is the only+reason that `foo8` from the `T183` test case singles successfully, since+the as-patterns in `foo8` desugar to code very similar to the `f` example+above.+-}++singLetDecRHS :: Map Name [Name]+ -> Map Name DCxt -- the context of the type signature+ -- (might not be known)+ -> Map Name DKind -- result kind (might not be known)+ -> Name -> ALetDecRHS -> SgM DLetDec+singLetDecRHS bound_names cxts res_kis name ld_rhs = do+ opts <- getOptions+ bindContext (Map.findWithDefault [] name cxts) $+ case ld_rhs of+ AValue prom num_arrows exp ->+ DValD (DVarP (singledValueName opts name)) <$>+ (wrapUnSingFun num_arrows prom <$> singExp exp (Map.lookup name res_kis))+ AFunction prom_fun num_arrows clauses ->+ let tyvar_names = case Map.lookup name bound_names of+ Nothing -> []+ Just ns -> ns+ res_ki = Map.lookup name res_kis+ in+ DFunD (singledValueName opts name) <$>+ mapM (singClause prom_fun num_arrows tyvar_names res_ki) clauses++singClause :: DType -- the promoted function+ -> Int -- the number of arrows in the type. If this is more+ -- than the number of patterns, we need to eta-expand+ -- with unSingFun.+ -> [Name] -- the names of the forall'd vars in the type sig of this+ -- function. This list should have at least the length as the+ -- number of patterns in the clause+ -> Maybe DKind -- result kind, if known+ -> ADClause -> SgM DClause+singClause prom_fun num_arrows bound_names res_ki+ (ADClause var_proms pats exp) = do++ -- Fix #166:+ when (num_arrows - length pats < 0) $+ fail $ "Function being promoted to " ++ (pprint (typeToTH prom_fun)) +++ " has too many arguments."++ (sPats, sigPaExpsSigs) <- evalForPair $ mapM (singPat (Map.fromList var_proms)) pats+ sBody <- singExp exp res_ki+ -- when calling unSingFun, the promoted pats aren't in scope, so we use the+ -- bound_names instead+ let pattern_bound_names = zipWith const bound_names pats+ -- this does eta-expansion. See comment at top of file.+ sBody' = wrapUnSingFun (num_arrows - length pats)+ (foldl apply prom_fun (map DVarT pattern_bound_names)) sBody+ return $ DClause sPats $ mkSigPaCaseE sigPaExpsSigs sBody'++singPat :: Map Name Name -- from term-level names to type-level names+ -> ADPat+ -> QWithAux SingDSigPaInfos SgM DPat+singPat var_proms = go+ where+ go :: ADPat -> QWithAux SingDSigPaInfos SgM DPat+ go (ADLitP _lit) =+ fail "Singling of literal patterns not yet supported"+ go (ADVarP name) = do+ opts <- getOptions+ tyname <- case Map.lookup name var_proms of+ Nothing ->+ fail "Internal error: unknown variable when singling pattern"+ Just tyname -> return tyname+ pure $ DVarP (singledValueName opts name)+ `DSigP` (singFamily `DAppT` DVarT tyname)+ go (ADConP name pats) = do+ opts <- getOptions+ DConP (singledDataConName opts name) <$> mapM go pats+ go (ADTildeP pat) = do+ qReportWarning+ "Lazy pattern converted into regular pattern during singleton generation."+ go pat+ go (ADBangP pat) = DBangP <$> go pat+ go (ADSigP prom_pat pat ty) = do+ pat' <- go pat+ -- Normally, calling dPatToDExp would be dangerous, since it fails if the+ -- supplied pattern contains any wildcard patterns. However, promotePat+ -- (which produced the pattern we're passing into dPatToDExp) maintains+ -- an invariant that any promoted pattern signatures will be free of+ -- wildcard patterns in the underlying pattern.+ -- See Note [Singling pattern signatures].+ addElement (dPatToDExp pat', DSigT prom_pat ty)+ pure pat'+ go ADWildP = pure DWildP++-- | If given a non-empty list of 'SingDSigPaInfos', construct a case expression+-- that brings singleton equality constraints into scope via pattern-matching.+-- See @Note [Singling pattern signatures]@.+mkSigPaCaseE :: SingDSigPaInfos -> DExp -> DExp+mkSigPaCaseE exps_with_sigs exp+ | null exps_with_sigs = exp+ | otherwise =+ let (exps, sigs) = unzip exps_with_sigs+ scrutinee = mkTupleDExp exps+ pats = map (DSigP DWildP . DAppT (DConT singFamilyName)) sigs+ in DCaseE scrutinee [DMatch (mkTupleDPat pats) exp]++-- Note [Annotate case return type]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- We're straining GHC's type inference here. One particular trouble area+-- is determining the return type of a GADT pattern match. In general, GHC+-- cannot infer return types of GADT pattern matches because the return type+-- becomes "untouchable" in the case matches. See the OutsideIn paper. But,+-- during singletonization, we *know* the return type. So, just add a type+-- annotation. See #54.+--+-- In particular, we add a type annotation in a somewhat unorthodox fashion.+-- Instead of the usual `(x :: t)`, we use `id @t x`. See+-- Note [The id hack; or, how singletons-th learned to stop worrying and avoid+-- kind generalization] for an explanation of why we do this.++-- Note [Why error is so special]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Some of the transformations that happen before this point produce impossible+-- case matches. We must be careful when processing these so as not to make+-- an error GHC will complain about. When binding the case-match variables, we+-- normally include an equality constraint saying that the scrutinee is equal+-- to the matched pattern. But, we can't do this in inaccessible matches, because+-- equality is bogus, and GHC (rightly) complains. However, we then have another+-- problem, because GHC doesn't have enough information when type-checking the+-- RHS of the inaccessible match to deem it type-safe. The solution: treat error+-- as super-special, so that GHC doesn't look too hard at singletonized error+-- calls. Specifically, DON'T do the applySing stuff. Just use sError, which+-- has a custom type (Sing x -> a) anyway.++-- Note [Singling pattern signatures]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- We want to single a pattern signature, like so:+--+-- f :: Maybe a -> a+-- f (Just x :: Maybe a) = x+--+-- Naïvely, one might expect this to single straightfowardly as:+--+-- sF :: forall (z :: Maybe a). Sing z -> Sing (F z)+-- sF (SJust sX :: Sing (Just x :: Maybe a)) = sX+--+-- But the way GHC typechecks patterns prevents this from working, as GHC won't+-- know that the type `z` is actually `Just x` until /after/ the entirety of+-- the `SJust sX` pattern has been typechecked. (See Trac #12018 for an+-- extended discussion on this topic.)+--+-- To work around this design, we resort to a somewhat unsightly trick:+-- immediately after matching on all the patterns, we perform a case on every+-- pattern with a pattern signature, like so:+--+-- sF :: forall (z :: Maybe a). Sing z -> Sing (F z)+-- sF (SJust sX :: Sing z)+-- = case (SJust sX :: Sing z) of+-- (_ :: Sing (Just x :: Maybe a)) -> sX+--+-- Now GHC accepts the fact that `z` is `Just x`, and all is well. In order+-- to support this construction, the type of singPat is augmented with some+-- extra information in the form of SingDSigPaInfos:+--+-- type SingDSigPaInfos = [(DExp, DType)]+--+-- Where the DExps corresponds to the expressions we case on just after the+-- patterns (`SJust sX :: Sing x`, in the example above), and the DTypes+-- correspond to the singled pattern signatures to use in the case alternative+-- (`Sing (Just x :: Maybe a)` in the example above). singPat appends to the+-- list of SingDSigPaInfos whenever it processes a DSigPa (pattern signature),+-- and call sites can pass these SingDSigPaInfos to mkSigPaCaseE to construct a+-- case expression like the one featured above.+--+-- Some interesting consequences of this design:+--+-- 1. We must promote DPats to ADPats, a variation of DPat where the annotated+-- DSigPa counterpart, ADSigPa, stores the type that the original DPat was+-- promoted to. This is necessary since promoting the type might have+-- generated fresh variable names, so we need to be able to use the same+-- names when singling.+--+-- 2. Also when promoting a DSigPa to an ADSigPa, we remove any wildcards from+-- the underlying pattern. To see why this is necessary, consider singling+-- this example:+--+-- g (Just _ :: Maybe a) = "hi"+--+-- This must single to something like this:+--+-- sG (SJust _ :: Sing z)+-- = case (SJust _ :: Sing z) of+-- (_ :: Sing (Just _ :: Maybe a)) -> "hi"+--+-- But `SJust _` is not a valid expression, and since the minimal th-desugar+-- AST lacks as-patterns, we can't replace it with something like+-- `sG x@(SJust _ :: Sing z) = case x of ...`. But even if the th-desugar+-- AST /did/ have as-patterns, we'd still be in trouble, as `Just _` isn't+-- a valid type without the use of -XPartialTypeSignatures, which isn't a+-- design we want to force upon others.+--+-- We work around both issues by simply converting all wildcard patterns+-- from the pattern that has a signature. That means our example becomes:+--+-- sG (SJust sWild :: Sing z)+-- = case (SJust sWild :: Sing z) of+-- (_ :: Sing (Just wild :: Maybe a)) -> "hi"+--+-- And now everything is hunky-dory.++singExp :: ADExp -> Maybe DKind -- the kind of the expression, if known+ -> SgM DExp+ -- See Note [Why error is so special]+singExp (ADVarE err `ADAppE` arg) _res_ki+ | err == errorName = do opts <- getOptions+ DAppE (DVarE (singledValueName opts err)) <$>+ singExp arg (Just (DConT symbolName))+singExp (ADVarE name) _res_ki = lookupVarE name+singExp (ADConE name) _res_ki = lookupConE name+singExp (ADLitE lit) _res_ki = singLit lit+singExp (ADAppE e1 e2) _res_ki = do+ e1' <- singExp e1 Nothing+ e2' <- singExp e2 Nothing+ -- `applySing undefined x` kills type inference, because GHC can't figure+ -- out the type of `undefined`. So we don't emit `applySing` there.+ if isException e1'+ then return $ e1' `DAppE` e2'+ else return $ (DVarE applySingName) `DAppE` e1' `DAppE` e2'+singExp (ADLamE ty_names prom_lam names exp) _res_ki = do+ opts <- getOptions+ let sNames = map (singledValueName opts) names+ exp' <- singExp exp Nothing+ -- we need to bind the type variables... but DLamE doesn't allow SigT patterns.+ -- So: build a case+ let caseExp = DCaseE (mkTupleDExp (map DVarE sNames))+ [DMatch (mkTupleDPat+ (map ((DWildP `DSigP`) .+ (singFamily `DAppT`) .+ DVarT) ty_names)) exp']+ return $ wrapSingFun (length names) prom_lam $ DLamE sNames caseExp+singExp (ADCaseE exp matches ret_ty) res_ki =+ -- See Note [Annotate case return type] and+ -- Note [The id hack; or, how singletons-th learned to stop worrying and+ -- avoid kind generalization]+ DAppE (DAppTypeE (DVarE 'id)+ (singFamily `DAppT` (ret_ty `maybeSigT` res_ki)))+ <$> (DCaseE <$> singExp exp Nothing <*> mapM (singMatch res_ki) matches)+singExp (ADLetE env exp) res_ki = do+ -- We intentionally discard the SingI instances for exp's defunctionalization+ -- symbols, as we also do not generate the declarations for the+ -- defunctionalization symbols in the first place during promotion.+ (let_decs, _, exp') <- singLetDecEnv env $ singExp exp res_ki+ pure $ DLetE let_decs exp'+singExp (ADSigE prom_exp exp ty) _ = do+ exp' <- singExp exp (Just ty)+ pure $ DSigE exp' $ DConT singFamilyName `DAppT` DSigT prom_exp ty++-- See Note [DerivedDecl] in Data.Singletons.TH.Syntax+singDerivedEqDecs :: DerivedEqDecl -> SgM [DDec]+singDerivedEqDecs (DerivedDecl { ded_mb_cxt = mb_ctxt+ , ded_type = ty+ , ded_type_tycon = ty_tycon+ , ded_decl = DataDecl _ _ cons }) = do+ (scons, _) <- singM [] $ mapM (singCtor ty_tycon) cons+ mb_sctxt <- mapM (mapM singPred) mb_ctxt+ kind <- promoteType ty+ -- Beware! The user might have specified an instance context like this:+ --+ -- deriving instance Eq a => Eq (T a Int)+ --+ -- When we single the context, it will become (SEq a). But we do *not* want+ -- this for the SDecide instance! The simplest solution is to simply replace+ -- all occurrences of SEq with SDecide in the context.+ mb_sctxtDecide <- traverse (traverse sEqToSDecide) mb_sctxt+ sDecideInst <- mkDecideInstance mb_sctxtDecide kind cons scons+ testInsts <- traverse (mkTestInstance mb_sctxtDecide kind ty_tycon cons)+ [TestEquality, TestCoercion]+ return (sDecideInst:testInsts)++-- Walk a DPred, replacing all occurrences of SEq with SDecide.+sEqToSDecide :: OptionsMonad q => DPred -> q DPred+sEqToSDecide p = do+ opts <- getOptions+ pure $ modifyConNameDType (\n ->+ if n == singledClassName opts eqName+ then sDecideClassName+ else n) p++-- See Note [DerivedDecl] in Data.Singletons.TH.Syntax+singDerivedShowDecs :: DerivedShowDecl -> SgM [DDec]+singDerivedShowDecs (DerivedDecl { ded_mb_cxt = mb_cxt+ , ded_type = ty+ , ded_type_tycon = ty_tycon+ , ded_decl = DataDecl _ _ cons }) = do+ opts <- getOptions+ z <- qNewName "z"+ -- Generate a Show instance for a singleton type, like this:+ --+ -- deriving instance (ShowSing a, ShowSing b) => Sing (SEither (z :: Either a b))+ --+ -- Be careful: we want to generate an instance context that uses ShowSing,+ -- not SShow.+ show_cxt <- inferConstraintsDef (fmap mkShowSingContext mb_cxt)+ (DConT showSingName)+ ty cons+ let sty_tycon = singledDataTypeName opts ty_tycon+ show_inst = DStandaloneDerivD Nothing Nothing show_cxt+ (DConT showName `DAppT` (DConT sty_tycon `DAppT` DSigT (DVarT z) ty))+ pure [show_inst]++isException :: DExp -> Bool+isException (DVarE n) = nameBase n == "sUndefined"+isException (DConE {}) = False+isException (DLitE {}) = False+isException (DAppE (DVarE fun) _) | nameBase fun == "sError" = True+isException (DAppE fun _) = isException fun+isException (DAppTypeE e _) = isException e+isException (DLamE _ _) = False+isException (DCaseE e _) = isException e+isException (DLetE _ e) = isException e+isException (DSigE e _) = isException e+isException (DStaticE e) = isException e++singMatch :: Maybe DKind -- ^ the result kind, if known+ -> ADMatch -> SgM DMatch+singMatch res_ki (ADMatch var_proms pat exp) = do+ (sPat, sigPaExpsSigs) <- evalForPair $ singPat (Map.fromList var_proms) pat+ sExp <- singExp exp res_ki+ return $ DMatch sPat $ mkSigPaCaseE sigPaExpsSigs sExp++singLit :: Lit -> SgM DExp+singLit (IntegerL n) = do+ opts <- getOptions+ if n >= 0+ then return $+ DVarE (singledValueName opts fromIntegerName) `DAppE`+ (DVarE singMethName `DSigE`+ (singFamily `DAppT` DLitT (NumTyLit n)))+ else do sLit <- singLit (IntegerL (-n))+ return $ DVarE (singledValueName opts negateName) `DAppE` sLit+singLit (StringL str) = do+ opts <- getOptions+ let sing_str_lit = DVarE singMethName `DSigE`+ (singFamily `DAppT` DLitT (StrTyLit str))+ os_enabled <- qIsExtEnabled LangExt.OverloadedStrings+ pure $ if os_enabled+ then DVarE (singledValueName opts fromStringName) `DAppE` sing_str_lit+ else sing_str_lit+singLit lit =+ fail ("Only string and natural number literals can be singled: " ++ show lit)++{-+Note [The id hack; or, how singletons-th learned to stop worrying and avoid kind generalization]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC 8.8 was a time of great change. In particular, 8.8 debuted a fix for+Trac #15141 (decideKindGeneralisationPlan is too complicated). To fix this, a+wily GHC developer—who shall remain unnamed, but whose username rhymes with+schmoldfire—decided to make decideKindGeneralisationPlan less complicated by,+well, removing the whole thing. One consequence of this is that local+definitions are now kind-generalized (whereas they would not have been+previously).++While schmoldfire had the noblest of intentions when authoring his fix, he+unintentionally made life much harder for singletons-th. Why? Consider the+following program:++ class Foo a where+ bar :: a -> (a -> b) -> b+ baz :: a++ quux :: Foo a => a -> a+ quux x = x `bar` \_ -> baz++When singled, this program will turn into something like this:++ type family Quux (x :: a) :: a where+ Quux x = Bar x (LambdaSym1 x)++ sQuux :: forall a (x :: a). SFoo a => Sing x -> Sing (Quux x :: a)+ sQuux (sX :: Sing x)+ = sBar sX+ ((singFun1 @(LambdaSym1 x))+ (\ sArg+ -> case sArg of {+ (_ :: Sing arg)+ -> (case sArg of { _ -> sBaz }) ::+ Sing (Case x arg arg) }))++ type family Case x arg t where+ Case x arg _ = Baz+ type family Lambda x t where+ Lambda x arg = Case x arg arg+ data LambdaSym1 x t+ type instance Apply (LambdaSym1 x) t = Lambda x t++The high-level bit is the explicit `Sing (Case x arg arg)` signature. Question:+what is the kind of `Case x arg arg`? The answer depends on whether local+definitions are kind-generalized or not!++1. If local definitions are *not* kind-generalized (i.e., the status quo before+ GHC 8.8), then `Case x arg arg :: a`.+2. If local definitions *are* kind-generalized (i.e., the status quo in GHC 8.8+ and later), then `Case x arg arg :: k` for some fresh kind variable `k`.++Unfortunately, the kind of `Case x arg arg` *must* be `a` in order for `sQuux`+to type-check. This means that the code above suddenly stopped working in GHC+8.8. What's more, we can't just remove these explicit signatures, as there is+code elsewhere in `singletons-th` that crucially relies on them to guide type+inference along (e.g., `sShowParen` in `Text.Show.Singletons`).++Luckily, there is an ingenious hack that lets us the benefits of explicit+signatures without the pain of kind generalization: our old friend, the `id`+function. The plan is as follows: instead of generating this code:++ (case sArg of ...) :: Sing (Case x arg arg)++We instead generate this code:++ id @(Sing (Case x arg arg)) (case sArg of ...)++That's it! This works because visible type arguments in terms do not get kind-+generalized, unlike top-level or local signatures. Now `Case x arg arg`'s kind+is not generalized, and all is well. We dub this: the `id` hack.++One might wonder: will we need the `id` hack around forever? Perhaps not. While+GHC 8.8 removed the decideKindGeneralisationPlan function, there have been+rumblings that a future version of GHC may bring it back (in a limited form).+If this happens, it is possibly that GHC's attitude towards kind-generalizing+local definitions may change *again*, which could conceivably render the `id`+hack unnecessary. This is all speculation, of course, so all we can do now is+wait and revisit this design at a later date.+-}
+ src/Data/Singletons/TH/Single/Data.hs view
@@ -0,0 +1,378 @@+{- Data/Singletons/TH/Single/Data.hs++(c) Richard Eisenberg 2013+rae@cs.brynmawr.edu++Singletonizes constructors.+-}++{-# LANGUAGE ParallelListComp, TupleSections, LambdaCase #-}++module Data.Singletons.TH.Single.Data 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.Defun+import Data.Singletons.TH.Single.Fixity+import Data.Singletons.TH.Single.Monad+import Data.Singletons.TH.Single.Type+import Data.Singletons.TH.Syntax+import Data.Singletons.TH.Util+import Control.Monad++-- We wish to consider the promotion of "Rep" to be *+-- not a promoted data constructor.+singDataD :: DataDecl -> SgM [DDec]+singDataD (DataDecl name tvbs ctors) = do+ opts <- getOptions+ let tvbNames = map extractTvbName tvbs+ ctor_names = map extractName ctors+ rec_sel_names = concatMap extractRecSelNames ctors+ k <- promoteType (foldType (DConT name) (map DVarT tvbNames))+ mb_data_sak <- dsReifyType name+ ctors' <- mapM (singCtor name) ctors+ fixityDecs <- singReifiedInfixDecls $ ctor_names ++ rec_sel_names+ -- instance for SingKind+ fromSingClauses <- mapM mkFromSingClause ctors+ emptyFromSingClause <- mkEmptyFromSingClause+ toSingClauses <- mapM mkToSingClause ctors+ emptyToSingClause <- mkEmptyToSingClause+ let singKindInst =+ DInstanceD Nothing Nothing+ (map (singKindConstraint . DVarT) tvbNames)+ (DAppT (DConT singKindClassName) k)+ [ DTySynInstD $ DTySynEqn Nothing+ (DConT demoteName `DAppT` k)+ (foldType (DConT name)+ (map (DAppT demote . DVarT) tvbNames))+ , DLetDec $ DFunD fromSingName+ (fromSingClauses `orIfEmpty` [emptyFromSingClause])+ , DLetDec $ DFunD toSingName+ (toSingClauses `orIfEmpty` [emptyToSingClause]) ]++ let singDataName = singledDataTypeName opts name+ -- e.g. type instance Sing @Nat = SNat+ singSynInst =+ DTySynInstD $ DTySynEqn Nothing+ (DConT singFamilyName `DAppKindT` k)+ (DConT singDataName)++ -- Note that we always include an explicit result kind in the body of the+ -- singleton data type declaration, even if it has a standalone kind+ -- signature that would make this explicit result kind redudant.+ -- See Note [Keep redundant kind information for Haddocks]+ -- in D.S.TH.Promote.+ mk_data_dec kind =+ DDataD Data [] singDataName [] (Just kind) ctors' []++ data_decs = case mb_data_sak of+ -- No standalone kind signature. Try to figure out the order of kind+ -- variables on a best-effort basis.+ Nothing ->+ let sing_tvbs = changeDTVFlags SpecifiedSpec $+ toposortTyVarsOf $ map dTyVarBndrToDType tvbs+ kinded_sing_ty = DForallT (DForallInvis sing_tvbs) $+ DArrowT `DAppT` k `DAppT` DConT typeKindName in+ [mk_data_dec kinded_sing_ty]++ -- A standalone kind signature is provided, so use that to determine the+ -- order of kind variables.+ Just data_sak ->+ let (args, _) = unravelDType data_sak+ vis_args = filterDVisFunArgs args+ vis_tvbs = changeDTVFlags SpecifiedSpec $+ zipWith replaceTvbKind vis_args tvbs+ invis_args = filterInvisTvbArgs args+ -- If the standalone kind signature did not explicitly quantify its+ -- kind variables, do so ourselves. This is very similar to what+ -- D.S.TH.Single.Type.singTypeKVBs does.+ invis_tvbs | null invis_args+ = changeDTVFlags SpecifiedSpec $+ toposortTyVarsOf [data_sak]+ | otherwise+ = invis_args+ sing_data_sak = DForallT (DForallInvis (invis_tvbs ++ vis_tvbs)) $+ DArrowT `DAppT` k `DAppT` DConT typeKindName in+ [ DKiSigD singDataName sing_data_sak+ , mk_data_dec sing_data_sak+ ]++ return $ data_decs +++ singSynInst :+ [singKindInst | genSingKindInsts opts] +++ fixityDecs+ where -- in the Rep case, the names of the constructors are in the wrong scope+ -- (they're types, not datacons), so we have to reinterpret them.+ mkConName :: Name -> SgM Name+ mkConName+ | nameBase name == nameBase repName = mkDataName . nameBase+ | otherwise = return++ mkFromSingClause :: DCon -> SgM DClause+ mkFromSingClause c = do+ opts <- getOptions+ let (cname, numArgs) = extractNameArgs c+ cname' <- mkConName cname+ varNames <- replicateM numArgs (qNewName "b")+ return $ DClause [DConP (singledDataConName opts cname) (map DVarP varNames)]+ (foldExp+ (DConE cname')+ (map (DAppE (DVarE fromSingName) . DVarE) varNames))++ mkToSingClause :: DCon -> SgM DClause+ mkToSingClause (DCon _tvbs _cxt cname fields _rty) = do+ opts <- getOptions+ let types = tysOfConFields fields+ varNames <- mapM (const $ qNewName "b") types+ svarNames <- mapM (const $ qNewName "c") types+ promoted <- mapM promoteType types+ cname' <- mkConName cname+ let varPats = zipWith mkToSingVarPat varNames promoted+ recursiveCalls = zipWith mkRecursiveCall varNames promoted+ return $+ DClause [DConP cname' varPats]+ (multiCase recursiveCalls+ (map (DConP someSingDataName . listify . DVarP)+ svarNames)+ (DAppE (DConE someSingDataName)+ (foldExp (DConE (singledDataConName opts cname))+ (map DVarE svarNames))))++ mkToSingVarPat :: Name -> DKind -> DPat+ mkToSingVarPat varName ki =+ DSigP (DVarP varName) (DAppT (DConT demoteName) ki)++ mkRecursiveCall :: Name -> DKind -> DExp+ mkRecursiveCall var_name ki =+ DSigE (DAppE (DVarE toSingName) (DVarE var_name))+ (DAppT (DConT someSingTypeName) ki)++ mkEmptyFromSingClause :: SgM DClause+ mkEmptyFromSingClause = do+ x <- qNewName "x"+ pure $ DClause [DVarP x]+ $ DCaseE (DVarE x) []++ mkEmptyToSingClause :: SgM DClause+ mkEmptyToSingClause = do+ x <- qNewName "x"+ pure $ DClause [DVarP x]+ $ DConE someSingDataName `DAppE` DCaseE (DVarE x) []++-- Single a constructor.+singCtor :: Name -> DCon -> SgM DCon+ -- polymorphic constructors are handled just+ -- like monomorphic ones -- the polymorphism in+ -- the kind is automatic+singCtor dataName (DCon con_tvbs cxt name fields rty)+ | not (null cxt)+ = fail "Singling of constrained constructors not yet supported"+ | otherwise+ = do+ opts <- getOptions+ let types = tysOfConFields fields+ sName = singledDataConName opts name+ sCon = DConE sName+ pCon = DConT $ promotedDataTypeOrConName opts name+ checkVanillaDType $ ravelVanillaDType con_tvbs [] types rty+ indexNames <- mapM (const $ qNewName "n") types+ kinds <- mapM promoteType_NC types+ rty' <- promoteType_NC rty+ let indices = map DVarT indexNames+ kindedIndices = zipWith DSigT indices kinds+ kvbs = singTypeKVBs con_tvbs kinds [] rty' mempty+ all_tvbs = kvbs ++ zipWith (`DKindedTV` SpecifiedSpec) indexNames kinds++ -- SingI instance for data constructor+ emitDecs+ [DInstanceD Nothing Nothing+ (map (DAppT (DConT singIName)) indices)+ (DAppT (DConT singIName)+ (foldType pCon kindedIndices))+ [DLetDec $ DValD (DVarP singMethName)+ (foldExp sCon (map (const $ DVarE singMethName) types))]]+ -- SingI instances for defunctionalization symbols. Note that we don't+ -- support contexts in constructors at the moment, so it's fine for now to+ -- just assume that the context is always ().+ emitDecs =<< singDefuns name DataName [] (map Just kinds) (Just rty')++ conFields <- case fields of+ DNormalC dInfix bts -> DNormalC dInfix <$>+ zipWithM (\(b, _) index -> mk_bang_type b index)+ bts indices+ DRecC vbts -> DNormalC False <$>+ zipWithM (\(_, b, _) index -> mk_bang_type b index)+ vbts indices+ -- Don't bother looking at record selectors, as they are+ -- handled separately in singTopLevelDecs.+ -- See Note [singletons-th and record selectors]+ return $ DCon all_tvbs [] sName conFields+ (DConT (singledDataTypeName opts dataName) `DAppT`+ (foldType pCon indices `DSigT` rty'))+ -- Make sure to include an explicit `rty'` kind annotation.+ -- See Note [Preserve the order of type variables during singling],+ -- wrinkle 3, in D.S.TH.Single.Type.+ where+ mk_source_unpackedness :: SourceUnpackedness -> SgM SourceUnpackedness+ mk_source_unpackedness su = case su of+ NoSourceUnpackedness -> pure su+ SourceNoUnpack -> pure su+ SourceUnpack -> do+ -- {-# UNPACK #-} is essentially useless in a singletons setting, since+ -- all singled data types are GADTs. See GHC#10016.+ qReportWarning "{-# UNPACK #-} pragmas are ignored by `singletons-th`."+ pure NoSourceUnpackedness++ mk_bang :: Bang -> SgM Bang+ mk_bang (Bang su ss) = do su' <- mk_source_unpackedness su+ pure $ Bang su' ss++ mk_bang_type :: Bang -> DType -> SgM DBangType+ mk_bang_type b index = do b' <- mk_bang b+ pure (b', DAppT singFamily index)++{-+Note [singletons-th and record selectors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Record selectors are annoying to deal with in singletons-th for various reasons:++1. There is no record syntax at the type level, so promoting code that involves+ records in some way is not straightforward.+2. One can define record selectors for singled data types, but they're rife+ with peril. Some pitfalls include:++ * Singling record updates often produces code that does not typecheck. For+ example, this works:++ let i = Identity True in i { runIdentity = False }++ But this does /not/ work:++ let si = SIdentity STrue in si { sRunIdentity = SFalse }++ error:+ • Record update for insufficiently polymorphic field:+ sRunIdentity :: Sing n+ • In the expression: si {sRunIdentity = SFalse}+ In the expression:+ let si = SIdentity STrue in si {sRunIdentity = SFalse}++ Ugh. See GHC#16501.++ * Singling a data type with multiple constructors that share a record+ selector name will /also/ not typecheck. While this works:++ data X = X1 {y :: Bool} | X2 {y :: Bool}++ This does not:++ data SX :: X -> Type where+ SX1 :: { sY :: Sing n } -> SX ('X1 n)+ SY1 :: { sY :: Sing n } -> SX ('X2 n)++ error:+ • Constructors SX1 and SX2 have a common field ‘sY’,+ but have different result types+ • In the data type declaration for ‘SX’++ Double ugh. See GHC#8673/GHC#12159.++ * Even if a data type only has a single constructor with record selectors,+ singling it can induce headaches. One might be tempted to single this type:++ newtype Unit = MkUnit { runUnit :: () }++ With this code:++ data SUnit :: Unit -> Type where+ SMkUnit :: { sRunUnit :: Sing u } -> SUnit (MkUnit u)++ Somewhat surprisingly, the type of sRunUnit:++ sRunUnit :: Sing (MkUnit u) -> Sing u++ Is not general enough to handle common uses of record selectors. For+ example, if you try to single this function:++ f :: Unit -> ()+ f = runUnit++ Then the resulting code:++ sF :: Sing (x :: Unit) -> Sing (F x :: ())+ sF = sRunUnit++ Will not typecheck. Note that sRunUnit expects an argument of type+ `Sing (MkUnit u)`, but there is no way to know a priori that the `x` in+ `Sing (x :: Unit)` is `MkUnit u` without pattern-matching on SMkUnit.++Hopefully I have convinced you that handling records in singletons-th is a bit of+a nightmare. Thankfully, there is a simple trick to avoid most of the pitfalls+above: just desugar code (using th-desugar) to avoid records!+In more concrete terms, we do the following:++* A record constructions desugars to a normal constructor application. For example:++ MkT{a = x, b = y}++ ==>++ MkT x y++ Something similar occurs for record syntax in patterns.++* A record update desugars to a case expression. For example:++ t{a = x}++ ==>++ case t of MkT _ y => MkT x y++We can't easily desugar away all uses of records, however. After all, records+can be used as ordinary functions as well. We leave such uses of records alone+when desugaring and accommodate them during promotion and singling by generating+"manual" record selectors. As a running example, consider the earlier Unit example:++ newtype Unit = MkUnit { runUnit :: () }++When singling Unit, we do not give SMkUnit a record selector:++ data SUnit :: Unit -> Type where+ SMkUnit :: Sing u -> SUnit (MkUnit u)++Instead, we generate a top-level function that behaves equivalently to runUnit.+This function then gets promoted and singled (in D.S.TH.Promote.promoteDecs and+D.S.TH.Single.singTopLevelDecs):++ type family RunUnit (x :: Unit) :: () where+ RunUnit (MkUnit x) = x++ sRunUnit :: Sing (x :: Unit) -> Sing (RunUnit x :: ())+ sRunUnit (SMkUnit sx) = sx++Now promoting/singling uses of runUnit as an ordinary function work as expected+since the types of RunUnit/sRunUnit are sufficiently general. This technique also+scales up to data types with multiple constructors sharing a record selector name.+For instance, in the earlier X example:++ data X = X1 {y :: Bool} | X2 {y :: Bool}++We would promote/single `y` like so:++ type family Y (x :: X) :: Bool where+ Y (X1 y) = y+ Y (X2 y) = y++ sY :: Sing (x :: X) -> Sing (Y x :: Bool)+ sY (SX1 sy) = sy+ sY (SX2 sy) = sy++Manual record selectors cannot be used in record constructions or updates, but+for most use cases this won't be an issue, since singletons-th makes an effort to+desugar away fancy uses of records anyway. The only time this would bite is if+you wanted to use record syntax in hand-written singletons code.+-}
+ src/Data/Singletons/TH/Single/Decide.hs view
@@ -0,0 +1,109 @@+{- Data/Singletons/TH/Single/Decide.hs++(c) Richard Eisenberg 2014+rae@cs.brynmawr.edu++Defines functions to generate SDecide instances, as well as TestEquality and+TestCoercion instances that leverage SDecide.+-}++module Data.Singletons.TH.Single.Decide where++import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Desugar+import Data.Singletons.TH.Deriving.Infer+import Data.Singletons.TH.Names+import Data.Singletons.TH.Options+import Data.Singletons.TH.Util+import Control.Monad++-- Make an instance of SDecide.+mkDecideInstance :: DsMonad q => Maybe DCxt -> DKind+ -> [DCon] -- ^ The /original/ constructors (for inferring the instance context)+ -> [DCon] -- ^ The /singletons/ constructors+ -> q DDec+mkDecideInstance mb_ctxt k ctors sctors = do+ let sctorPairs = [ (sc1, sc2) | sc1 <- sctors, sc2 <- sctors ]+ methClauses <- if null sctors+ then (:[]) <$> mkEmptyDecideMethClause+ else mapM mkDecideMethClause sctorPairs+ constraints <- inferConstraintsDef mb_ctxt (DConT sDecideClassName) k ctors+ return $ DInstanceD Nothing Nothing+ constraints+ (DAppT (DConT sDecideClassName) k)+ [DLetDec $ DFunD sDecideMethName methClauses]++data TestInstance = TestEquality+ | TestCoercion++-- Make an instance of TestEquality or TestCoercion by leveraging SDecide.+mkTestInstance :: OptionsMonad q => Maybe DCxt -> DKind+ -> Name -- ^ The name of the data type+ -> [DCon] -- ^ The /original/ constructors (for inferring the instance context)+ -> TestInstance -> q DDec+mkTestInstance mb_ctxt k data_name ctors ti = do+ opts <- getOptions+ constraints <- inferConstraintsDef mb_ctxt (DConT sDecideClassName) k ctors+ pure $ DInstanceD Nothing Nothing+ constraints+ (DAppT (DConT tiClassName)+ (DConT (singledDataTypeName opts data_name)+ `DSigT` (DArrowT `DAppT` k `DAppT` DConT typeKindName)))+ [DLetDec $ DFunD tiMethName+ [DClause [] (DVarE tiDefaultName)]]+ where+ (tiClassName, tiMethName, tiDefaultName) =+ case ti of+ TestEquality -> (testEqualityClassName, testEqualityMethName, decideEqualityName)+ TestCoercion -> (testCoercionClassName, testCoercionMethName, decideCoercionName)++mkDecideMethClause :: Quasi q => (DCon, DCon) -> q DClause+mkDecideMethClause (c1, c2)+ | lname == rname =+ if lNumArgs == 0+ then return $ DClause [DConP lname [], DConP rname []]+ (DAppE (DConE provedName) (DConE reflName))+ else do+ lnames <- replicateM lNumArgs (qNewName "a")+ rnames <- replicateM lNumArgs (qNewName "b")+ contra <- qNewName "contra"+ let lpats = map DVarP lnames+ rpats = map DVarP rnames+ lvars = map DVarE lnames+ rvars = map DVarE rnames+ refl <- qNewName "refl"+ return $ DClause+ [DConP lname lpats, DConP rname rpats]+ (DCaseE (mkTupleDExp $+ zipWith (\l r -> foldExp (DVarE sDecideMethName) [l, r])+ lvars rvars)+ ((DMatch (mkTupleDPat (replicate lNumArgs+ (DConP provedName [DConP reflName []])))+ (DAppE (DConE provedName) (DConE reflName))) :+ [DMatch (mkTupleDPat (replicate i DWildP +++ DConP disprovedName [DVarP contra] :+ replicate (lNumArgs - i - 1) DWildP))+ (DAppE (DConE disprovedName)+ (DLamE [refl] $+ DCaseE (DVarE refl)+ [DMatch (DConP reflName []) $+ (DAppE (DVarE contra)+ (DConE reflName))]))+ | i <- [0..lNumArgs-1] ]))++ | otherwise = do+ x <- qNewName "x"+ return $ DClause+ [DConP lname (replicate lNumArgs DWildP),+ DConP rname (replicate rNumArgs DWildP)]+ (DAppE (DConE disprovedName) (DLamE [x] (DCaseE (DVarE x) [])))++ where+ (lname, lNumArgs) = extractNameArgs c1+ (rname, rNumArgs) = extractNameArgs c2++mkEmptyDecideMethClause :: Quasi q => q DClause+mkEmptyDecideMethClause = do+ x <- qNewName "x"+ pure $ DClause [DVarP x, DWildP]+ $ DConE provedName `DAppE` DCaseE (DVarE x) []
+ src/Data/Singletons/TH/Single/Defun.hs view
@@ -0,0 +1,199 @@+-----------------------------------------------------------------------------+-- |+-- 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 instances for them. As a concrete+-- example, if you have:+--+-- foo :: Eq a => a -> a -> Bool+--+-- Then foo's promoted counterpart, Foo, will have two defunctionalization+-- symbols:+--+-- FooSym0 :: a ~> a ~> Bool+-- FooSym1 :: a -> a ~> Bool+--+-- We can declare SingI instances for these two symbols like so:+--+-- instance SEq a => SingI (FooSym0 :: a ~> a ~> Bool) where+-- sing = singFun2 sFoo+--+-- instance (SEq a, SingI x) => SingI (FooSym1 x :: a ~> Bool) where+-- sing = singFun1 (sFoo (sing @_ @x))+--+-- Note that singDefuns takes Maybe DKinds for the promoted argument and result+-- types, in case we have an entity whose type needs to be inferred.+-- See Note [singDefuns and type inference].+singDefuns :: Name -- The Name of the thing to promote.+ -> NameSpace -- Whether the above Name is a value, data constructor,+ -- or a type constructor.+ -> DCxt -- The type's context.+ -> [Maybe DKind] -- The promoted argument types (if known).+ -> Maybe DKind -- The promoted result type (if known).+ -> SgM [DDec]+singDefuns n ns ty_ctxt mb_ty_args mb_ty_res =+ case mb_ty_args of+ [] -> pure [] -- If a function has no arguments, then it has no+ -- defunctionalization symbols, so there's nothing to be done.+ _ -> do opts <- getOptions+ sty_ctxt <- mapM singPred ty_ctxt+ names <- replicateM (length mb_ty_args) $ qNewName "d"+ let tvbs = zipWith inferMaybeKindTV names mb_ty_args+ (_, insts) = go opts 0 sty_ctxt [] tvbs+ pure insts+ where+ num_ty_args :: Int+ num_ty_args = length mb_ty_args++ -- The inner loop. @go n ctxt arg_tvbs res_tvbs@ returns @(m_result, insts)@.+ -- Using one particular example:+ --+ -- @+ -- instance (SingI a, SingI b, SEq c, SEq d) =>+ -- SingI (ExampleSym2 (x :: a) (y :: b) :: c ~> d ~> Type) where ...+ -- @+ --+ -- We have:+ --+ -- * @n@ is 2. This is incremented in each iteration of `go`.+ --+ -- * @ctxt@ is (SEq c, SEq d). The (SingI a, SingI b) part of the instance+ -- context is added separately.+ --+ -- * @arg_tvbs@ is [(x :: a), (y :: b)].+ --+ -- * @res_tvbs@ is [(z :: c), (w :: d)]. The kinds of these type variable+ -- binders appear in the result kind.+ --+ -- * @m_result@ is `Just (c ~> d ~> Type)`. @m_result@ is returned so+ -- that earlier defunctionalization symbols can build on the result+ -- kinds of later symbols. For instance, ExampleSym1 would get the+ -- result kind `b ~> c ~> d ~> Type` by prepending `b` to ExampleSym2's+ -- result kind `c ~> d ~> Type`.+ --+ -- * @insts@ are all of the instance declarations corresponding to+ -- ExampleSym2 and later defunctionalization symbols. This is the main+ -- payload of the function.+ --+ -- This function is quadratic because it appends a variable at the end of+ -- the @arg_tvbs@ list at each iteration. In practice, this is unlikely+ -- to be a performance bottleneck since the number of arguments rarely+ -- gets to be that large.+ go :: Options -> Int -> DCxt -> [DTyVarBndrUnit] -> [DTyVarBndrUnit]+ -> (Maybe DKind, [DDec])+ go _ _ _ _ [] = (mb_ty_res, [])+ go opts sym_num sty_ctxt arg_tvbs (res_tvb:res_tvbs) =+ (mb_new_res, new_inst:insts)+ where+ mb_res :: Maybe DKind+ insts :: [DDec]+ (mb_res, insts) = go opts (sym_num + 1) sty_ctxt (arg_tvbs ++ [res_tvb]) res_tvbs++ mb_new_res :: Maybe DKind+ mb_new_res = mk_inst_kind res_tvb mb_res++ sing_fun_num :: Int+ sing_fun_num = num_ty_args - sym_num++ mk_sing_fun_expr :: DExp -> DExp+ mk_sing_fun_expr sing_expr =+ foldl' (\f tvb_n -> f `DAppE` (DVarE singMethName `DAppTypeE` DVarT tvb_n))+ sing_expr+ (map extractTvbName arg_tvbs)++ singI_ctxt :: DCxt+ singI_ctxt = map (DAppT (DConT singIName) . tvbToType) arg_tvbs++ mk_inst_ty :: DType -> DType+ mk_inst_ty inst_head+ = case mb_new_res of+ Just inst_kind -> inst_head `DSigT` inst_kind+ Nothing -> inst_head++ arg_tvb_tys :: [DType]+ arg_tvb_tys = map dTyVarBndrToDType arg_tvbs++ -- Construct the arrow kind used to annotate the defunctionalization+ -- symbol (e.g., the `a ~> a ~> Bool` in+ -- `SingI (FooSym0 :: a ~> a ~> Bool)`).+ -- If any of the argument kinds or result kind isn't known (i.e., is+ -- Nothing), then we opt not to construct this arrow kind altogether.+ -- See Note [singDefuns and type inference]+ mk_inst_kind :: DTyVarBndrUnit -> Maybe DKind -> Maybe DKind+ mk_inst_kind tvb' = buildTyFunArrow_maybe (extractTvbKind tvb')++ new_inst :: DDec+ new_inst = DInstanceD Nothing Nothing+ (sty_ctxt ++ singI_ctxt)+ (DConT singIName `DAppT` mk_inst_ty defun_inst_ty)+ [DLetDec $ DValD (DVarP singMethName)+ $ wrapSingFun sing_fun_num defun_inst_ty+ $ mk_sing_fun_expr sing_exp ]+ where+ defun_inst_ty :: DType+ defun_inst_ty = foldType (DConT (defunctionalizedName opts n sym_num))+ arg_tvb_tys++ sing_exp :: DExp+ sing_exp = case ns of+ DataName -> DConE $ singledDataConName opts n+ _ -> DVarE $ singledValueName opts n++{-+Note [singDefuns and type inference]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following function:++ foo :: a -> Bool+ foo _ = True++singDefuns would give the following SingI instance for FooSym0, with an+explicit kind signature:++ instance SingI (FooSym0 :: a ~> Bool) where ...++What happens if we leave off the type signature for foo?++ foo _ = True++Can singDefuns still do its job? Yes! It will simply generate:++ instance SingI FooSym0 where ...++In general, if any of the promoted argument or result types given to singDefun+are Nothing, then we avoid crafting an explicit kind signature. You might worry+that this could lead to SingI instances being generated that GHC cannot infer+the type for, such as:++ bar x = x == x+ ==>+ instance SingI BarSym0 -- Missing an SEq constraint?++This is true, but also not unprecedented, as the singled version of bar, sBar,+will /also/ fail to typecheck due to a missing SEq constraint. Therefore, this+design choice fits within the existing tradition of type inference in+singletons-th.+-}
+ src/Data/Singletons/TH/Single/Fixity.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Data.Singletons.TH.Single.Fixity where++import Prelude hiding ( exp )+import Language.Haskell.TH hiding ( cxt )+import Language.Haskell.TH.Syntax (NameSpace(..), Quasi(..))+import Data.Singletons.TH.Options+import Data.Singletons.TH.Util+import Language.Haskell.TH.Desugar++-- Single a fixity declaration.+singInfixDecl :: forall q. OptionsMonad q => Name -> Fixity -> q (Maybe DLetDec)+singInfixDecl name fixity = do+ opts <- getOptions+ mb_ns <- reifyNameSpace name+ case mb_ns of+ -- If we can't find the Name for some odd reason,+ -- fall back to singValName+ Nothing -> finish $ singledValueName opts name+ Just VarName -> finish $ singledValueName opts name+ Just DataName -> finish $ singledDataConName opts name+ Just TcClsName -> do+ mb_info <- dsReify name+ case mb_info of+ Just (DTyConI DClassD{} _)+ -> finish $ singledClassName opts name+ _ -> pure Nothing+ -- Don't produce anything for other type constructors (type synonyms,+ -- type families, data types, etc.).+ -- See [singletons-th and fixity declarations], wrinkle 1.+ where+ finish :: Name -> q (Maybe DLetDec)+ finish = pure . Just . DInfixD fixity++-- Try producing singled fixity declarations for Names by reifying them+-- /without/ consulting quoted declarations. If reification fails, recover and+-- return the empty list.+-- See [singletons-th and fixity declarations], wrinkle 2.+singReifiedInfixDecls :: forall q. OptionsMonad q => [Name] -> q [DDec]+singReifiedInfixDecls = mapMaybeM trySingFixityDeclaration+ where+ trySingFixityDeclaration :: Name -> q (Maybe DDec)+ trySingFixityDeclaration name =+ qRecover (return Nothing) $ do+ mFixity <- qReifyFixity name+ case mFixity of+ Nothing -> pure Nothing+ Just fixity -> fmap (fmap DLetDec) $ singInfixDecl name fixity++{-+Note [singletons-th and fixity declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Promoting and singling fixity declarations is surprisingly tricky to get right.+This Note serves as a place to document the insights learned after getting this+wrong at various points.++As a general rule, when promoting something with a fixity declaration like this+one:++ infixl 5 `foo`++singletons-th will produce promoted and singled versions of them:++ infixl 5 `Foo`+ infixl 5 `sFoo`++singletons-th will also produce fixity declarations for its defunctionalization+symbols (see Note [Fixity declarations for defunctionalization symbols] in+D.S.TH.Promote.Defun):++ infixl 5 `FooSym0`+ infixl 5 `FooSym1`+ ...++-----+-- Wrinkle 1: When not to promote/single fixity declarations+-----++Rules are meant to be broken, and the general rule above is no exception. There+are certain cases where singletons-th does *not* produce promoted or singled+versions of fixity declarations:++* During promotion, fixity declarations for the following sorts of names will+ not receive promoted counterparts:++ - Data types+ - Type synonyms+ - Type families+ - Data constructors+ - Infix values++ We exclude the first four because the promoted versions of these names are+ the same as the originals, so generating an extra fixity declaration for them+ would run the risk of having duplicates, which GHC would reject with an error.++ We exclude infix value because while their promoted versions are different,+ they share the same name base. In concrete terms, this:++ $(promote [d|+ infixl 4 ###+ (###) :: a -> a -> a+ |])++ Is promoted to the following:++ type family (###) (x :: a) (y :: a) :: a where ...++ So giving the type-level (###) a fixity declaration would clash with the+ existing one for the value-level (###).++ There *is* a scenario where we should generate a fixity declaration for the+ type-level (###), however. Imagine the above example used the `promoteOnly`+ function instead of `promote`. Then the type-level (###) would lack a fixity+ declaration altogether because the original fixity declaration was discarded+ by `promoteOnly`! The same problem would arise if one had to choose between+ the `singletons` and `singletonsOnly` functions.++ The difference between `promote` and `promoteOnly` (as well as `singletons`+ and `singletonsOnly`) is whether the `genQuotedDecs` option is set to `True`+ or `False`, respectively. Therefore, if `genQuotedDecs` is set to `False`+ when promoting the fixity declaration for an infix value, we opt to generate+ a fixity declaration (with the same name base) so that the type-level version+ of that value gets one.++* During singling, the following things will not have their fixity declarations+ singled:++ - Type synonyms or type families. This is because singletons-th does not+ generate singled versions of them in the first place (they only receive+ defunctionalization symbols).++ - Data types. This is because the singled version of a data type T is+ always of the form:++ data ST :: forall a_1 ... a_n. T a_1 ... a_n -> Type where ...++ Regardless of how many arguments T has, ST will have exactly one argument.+ This makes is rather pointless to generate a fixity declaration for it.++-----+-- Wrinkle 2: Making sure fixity declarations are promoted/singled properly+-----++There are two situations where singletons-th must promote/single fixity+declarations:++1. When quoting code, i.e., with `promote` or `singletons`.+2. When reifying code, i.e., with `genPromotions` or `genSingletons`.++In the case of (1), singletons-th stores the quoted fixity declarations in the+lde_infix field of LetDecEnv. Therefore, it suffices to call+promoteInfixDecl/singleInfixDecl when processing LetDecEnvs.++In the case of (2), there is no LetDecEnv to use, so we must instead reify+the fixity declarations and promote/single those. See D.S.TH.Single.Data.singDataD+(which singles data constructors) for a place that does this—we will use+singDataD as a running example for the rest of this section.++One complication is that code paths like singDataD are invoked in both (1) and+(2). This runs the risk that singletons-th will generate duplicate infix+declarations for data constructors in situation (1), as it will try to single+their fixity declarations once when processing them in LetDecEnvs and again+when reifying them in singDataD.++To avoid this pitfall, when reifying declarations in singDataD we take care+*not* to consult any quoted declarations when reifying (i.e., we do not use+reifyWithLocals for functions like it). Therefore, it we are in situation (1),+then the reification in singDataD will fail (and recover gracefully), so it+will not produce any singled fixity declarations. Therefore, the only singled+fixity declarations will be produced by processing LetDecEnvs.+-}
+ src/Data/Singletons/TH/Single/Monad.hs view
@@ -0,0 +1,195 @@+{- 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.+-}++{-# LANGUAGE GeneralizedNewtypeDeriving, ParallelListComp, TemplateHaskellQuotes #-}++module Data.Singletons.TH.Single.Monad (+ SgM, bindLets, bindContext, askContext, lookupVarE, lookupConE,+ wrapSingFun, wrapUnSingFun,+ singM, singDecsM,+ emitDecs, emitDecsM+ ) where++import Prelude hiding ( exp )+import Data.Map ( Map )+import qualified Data.Map as Map+import Data.Singletons+import Data.Singletons.TH.Options+import Data.Singletons.TH.Promote.Monad ( emitDecs, emitDecsM )+import Data.Singletons.TH.Util+import Language.Haskell.TH.Syntax hiding ( lift )+import Language.Haskell.TH.Desugar+import Control.Monad.Reader+import Control.Monad.Writer+import Control.Applicative++-- environment during singling+data SgEnv =+ SgEnv { sg_options :: Options+ , sg_let_binds :: Map Name DExp -- from the *original* name+ , sg_context :: DCxt -- See Note [Tracking the current type signature context]+ , sg_local_decls :: [Dec]+ }++emptySgEnv :: SgEnv+emptySgEnv = SgEnv { sg_options = defaultOptions+ , sg_let_binds = Map.empty+ , sg_context = []+ , sg_local_decls = []+ }++-- the singling monad+newtype SgM a = SgM (ReaderT SgEnv (WriterT [DDec] Q) a)+ deriving ( Functor, Applicative, Monad+ , MonadReader SgEnv, MonadWriter [DDec]+ , MonadFail, MonadIO, Quasi )++instance DsMonad SgM where+ localDeclarations = asks sg_local_decls++instance OptionsMonad SgM where+ getOptions = asks sg_options++bindLets :: [(Name, DExp)] -> SgM a -> SgM a+bindLets lets1 =+ local (\env@(SgEnv { sg_let_binds = lets2 }) ->+ env { sg_let_binds = (Map.fromList lets1) `Map.union` lets2 })++-- Add some constraints to the current type signature context.+-- See Note [Tracking the current type signature context]+bindContext :: DCxt -> SgM a -> SgM a+bindContext ctxt1+ = local (\env@(SgEnv { sg_context = ctxt2 }) ->+ env { sg_context = ctxt1 ++ ctxt2 })++-- Retrieve the current type signature context.+-- See Note [Tracking the current type signature context]+askContext :: SgM DCxt+askContext = asks sg_context++lookupVarE :: Name -> SgM DExp+lookupVarE name = do+ opts <- getOptions+ lookup_var_con (singledValueName opts)+ (DVarE . singledValueName opts) name++lookupConE :: Name -> SgM DExp+lookupConE name = do+ opts <- getOptions+ lookup_var_con (singledDataConName opts)+ (DConE . singledDataConName opts) name++lookup_var_con :: (Name -> Name) -> (Name -> DExp) -> Name -> SgM DExp+lookup_var_con mk_sing_name mk_exp name = do+ opts <- getOptions+ letExpansions <- asks sg_let_binds+ sName <- mkDataName (nameBase (mk_sing_name name)) -- we want *term* names!+ case Map.lookup name letExpansions of+ Nothing -> do+ -- try to get it from the global context+ m_dinfo <- liftM2 (<|>) (dsReify sName) (dsReify name)+ -- try the unrefined name too -- it's needed to bootstrap Enum+ case m_dinfo of+ Just (DVarI _ ty _) ->+ let num_args = countArgs ty in+ return $ wrapSingFun num_args (DConT $ defunctionalizedName0 opts name)+ (mk_exp name)+ _ -> return $ mk_exp name -- lambda-bound+ Just exp -> return exp++wrapSingFun :: Int -> DType -> DExp -> DExp+wrapSingFun 0 _ = id+wrapSingFun n ty =+ let wrap_fun = DVarE $ case n of+ 1 -> 'singFun1+ 2 -> 'singFun2+ 3 -> 'singFun3+ 4 -> 'singFun4+ 5 -> 'singFun5+ 6 -> 'singFun6+ 7 -> 'singFun7+ _ -> error "No support for functions of arity > 7."+ in+ (wrap_fun `DAppTypeE` ty `DAppE`)++wrapUnSingFun :: Int -> DType -> DExp -> DExp+wrapUnSingFun 0 _ = id+wrapUnSingFun n ty =+ let unwrap_fun = DVarE $ case n of+ 1 -> 'unSingFun1+ 2 -> 'unSingFun2+ 3 -> 'unSingFun3+ 4 -> 'unSingFun4+ 5 -> 'unSingFun5+ 6 -> 'unSingFun6+ 7 -> 'unSingFun7+ _ -> error "No support for functions of arity > 7."+ in+ (unwrap_fun `DAppTypeE` ty `DAppE`)++singM :: OptionsMonad q => [Dec] -> SgM a -> q (a, [DDec])+singM locals (SgM rdr) = do+ opts <- getOptions+ other_locals <- localDeclarations+ let wr = runReaderT rdr (emptySgEnv { sg_options = opts+ , sg_local_decls = other_locals ++ locals })+ q = runWriterT wr+ runQ q++singDecsM :: OptionsMonad q => [Dec] -> SgM [DDec] -> q [DDec]+singDecsM locals thing = do+ (decs1, decs2) <- singM locals thing+ return $ decs1 ++ decs2++{-+Note [Tracking the current type signature context]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Much like we track the let-bound names in scope, we also track the current+context. For instance, in the following program:++ -- (1)+ f :: forall a. Show a => a -> String -> Bool+ f x y = g (show x) y+ where+ -- (2)+ g :: forall b. Eq b => b -> b -> Bool+ g = h+ where+ -- (3)+ h :: b -> b -> Bool+ h = (==)++Here is the context at various points:++(1) ()+(2) (Show a)+(3) (Show a, Eq b)++We track this informating during singling instead of during promotion, as the+promoted versions of things are often type families, which do not have+contexts.++Why do we bother tracking this at all? Ultimately, because singDefuns (from+Data.Singletons.TH.Single.Defun) needs to know the current context in order to+generate a correctly typed SingI instance. For instance, if you called+singDefuns on the class method bar:++ class Foo a where+ bar :: Eq a => a -> Bool++Then if you only grabbed the context of `bar` itself, then you'd end up+generating the following SingI instance for BarSym0:++ instance SEq a => SingI (FooSym0 :: a ~> Bool) where ...++Which is incorrect—there needs to be an (SFoo a) constraint as well! If we+track the current context when singling Foo, then we will correctly propagate+this information to singDefuns.+-}
+ src/Data/Singletons/TH/Single/Type.hs view
@@ -0,0 +1,312 @@+{- Data/Singletons/TH/Single/Type.hs++(c) Richard Eisenberg 2013+rae@cs.brynmawr.edu++Singletonizes types.+-}++module Data.Singletons.TH.Single.Type where++import Language.Haskell.TH.Desugar+import Language.Haskell.TH.Desugar.OSet (OSet)+import Language.Haskell.TH.Syntax+import Data.Singletons.TH.Names+import Data.Singletons.TH.Options+import Data.Singletons.TH.Promote.Type+import Data.Singletons.TH.Single.Monad+import Data.Singletons.TH.Util+import Control.Monad+import Data.Foldable+import Data.Function+import Data.List (deleteFirstsBy)++singType :: OSet Name -- the set of bound kind variables in this scope+ -- see Note [Explicitly binding kind variables]+ -- in Data.Singletons.TH.Promote.Monad+ -> DType -- the promoted version of the thing classified by...+ -> DType -- ... this type+ -> SgM ( DType -- the singletonized type+ , Int -- the number of arguments+ , [Name] -- the names of the tyvars used in the sing'd type+ , DCxt -- the context of the singletonized type+ , [DKind] -- the kinds of the argument types+ , DKind ) -- the kind of the result type+singType bound_kvs prom ty = do+ (orig_tvbs, cxt, args, res) <- unravelVanillaDType ty+ let num_args = length args+ cxt' <- mapM singPred_NC cxt+ arg_names <- replicateM num_args (qNewName "t")+ prom_args <- mapM promoteType_NC args+ prom_res <- promoteType_NC res+ let args' = map (\n -> singFamily `DAppT` (DVarT n)) arg_names+ res' = singFamily `DAppT` (foldl apply prom (map DVarT arg_names) `DSigT` prom_res)+ -- Make sure to include an explicit `prom_res` kind annotation.+ -- See Note [Preserve the order of type variables during singling],+ -- wrinkle 3.+ kvbs = singTypeKVBs orig_tvbs prom_args cxt' prom_res bound_kvs+ all_tvbs = kvbs ++ zipWith (`DKindedTV` SpecifiedSpec) arg_names prom_args+ ty' = ravelVanillaDType all_tvbs cxt' args' res'+ return (ty', num_args, arg_names, cxt, prom_args, prom_res)++-- Compute the kind variable binders to use in the singled version of a type+-- signature. This has two main call sites: singType and D.S.TH.Single.Data.singCtor.+--+-- This implements the advice documented in+-- Note [Preserve the order of type variables during singling], wrinkle 1.+singTypeKVBs ::+ [DTyVarBndrSpec] -- ^ The bound type variables from the original type signature.+ -> [DType] -- ^ The argument types of the signature (promoted).+ -> DCxt -- ^ The context of the signature (singled).+ -> DType -- ^ The result type of the signature (promoted).+ -> OSet Name -- ^ The type variables previously bound in the current scope.+ -> [DTyVarBndrSpec] -- ^ The kind variables for the singled type signature.+singTypeKVBs orig_tvbs prom_args sing_ctxt prom_res bound_tvbs+ | null orig_tvbs+ -- There are no explicitly `forall`ed type variable binders, so we must+ -- infer them ourselves.+ = changeDTVFlags SpecifiedSpec $+ deleteFirstsBy+ ((==) `on` extractTvbName)+ (toposortTyVarsOf $ prom_args ++ sing_ctxt ++ [prom_res])+ (map (`DPlainTV` ()) $ toList bound_tvbs)+ -- Make sure to subtract out the bound variables currently in scope,+ -- lest we accidentally shadow them in this type signature.+ -- See Note [Explicitly binding kind variables] in D.S.TH.Promote.Monad.+ | otherwise+ -- There is an explicit `forall`, so this case is easy.+ = orig_tvbs++-- Single a DPred, checking that it is a vanilla type in the process.+-- See [Vanilla-type validity checking during promotion]+-- in Data.Singletons.TH.Promote.Type.+singPred :: DPred -> SgM DPred+singPred p = do+ checkVanillaDType p+ singPred_NC p++-- Single a DPred. Does not check if the argument is a vanilla type.+-- See [Vanilla-type validity checking during promotion]+-- in Data.Singletons.TH.Promote.Type.+singPred_NC :: DPred -> SgM DPred+singPred_NC = singPredRec []++-- The workhorse for singPred_NC.+singPredRec :: [DTypeArg] -> DPred -> SgM DPred+singPredRec _cxt (DForallT {}) =+ fail "Singling of quantified constraints not yet supported"+singPredRec _cxt (DConstrainedT {}) =+ fail "Singling of quantified constraints not yet supported"+singPredRec ctx (DAppT pr ty) = singPredRec (DTANormal ty : ctx) pr+singPredRec ctx (DAppKindT pr ki) = singPredRec (DTyArg ki : ctx) pr+singPredRec _ctx (DSigT _pr _ki) =+ fail "Singling of constraints with explicit kinds not yet supported"+singPredRec _ctx (DVarT _n) =+ fail "Singling of contraint variables not yet supported"+singPredRec ctx (DConT n)+ | n == equalityName+ = fail "Singling of type equality constraints not yet supported"+ | otherwise = do+ opts <- getOptions+ kis <- mapM promoteTypeArg_NC ctx+ let sName = singledClassName opts n+ return $ applyDType (DConT sName) kis+singPredRec _ctx DWildCardT = return DWildCardT -- it just might work+singPredRec _ctx DArrowT =+ fail "(->) spotted at head of a constraint"+singPredRec _ctx (DLitT {}) =+ fail "Type-level literal spotted at head of a constraint"++{-+Note [Preserve the order of type variables during singling]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+singletons-th does its best to preseve the order in which users write type+variables in type signatures for functions and data constructors. They are+"preserved" in the sense that if one writes `foo @T1 @T2`, one should be+able to write out `sFoo @T1 @T2` by hand and have the same order of visible+type applications still work. Accomplishing this is surprisingly nontrivial,+so this Note documents the various wrinkles one must iron out to get this+working.++-----+-- Wrinkle 1: Dealing with the presence (and absence) of `forall`+-----++If we single a function that has an explicit `forall`, such as this example:++ const2 :: forall b a. a -> b -> a+ const2 x _ = x++Then our job is easy, as the exact order of type variables has already been+spelled out in advance. We single this to:++ sConst2 :: forall b a (x :: a) (y :: b). Sing x -> Sing y -> Sing (Const2 x y :: a)+ sConst2 = ...++What happens if there is no explicit `forall`, as in this example?++ data V a++ absurd :: V a -> b+ absurd v = case v of {}++This time, the order of type variables vis-à-vis TypeApplications is determined+by their left-to-right order of appearance in the type signature. It's tempting+to think that since there is no explicit `forall` in the original type+signature, we could get away without an explicit `forall` in the singled type+signature. That is, one could write:++ sAbsurd :: Sing (v :: V a) -> Sing (Absurd :: b)++This would have the right type variable order, but unfortunately, this approach+does not play well with singletons-th's style of code generation. Consider the code+that would be generated for the body of sAbsurd:++ sAbsurd :: Sing (v :: V a) -> Sing (Absurd :: b)+ sAbsurd (sV :: Sing v) = id @(Case v v :: b) (case sV of {})++Note the use of the type `Case v v :: b` in the right-hand side of sAbsurd.+However, because `b` was not bound by a top-level `forall`, it won't be in+scope here, resulting in an error!++(Why do we generate the code `id @(Case v v :: b)` in the first place? See+Note [The id hack; or, how singletons-th learned to stop worrying and avoid kind generalization]+in D.S.TH.Single.)++The simplest approach is to just always generate singled type signatures with+explicit `forall`s. In the event that the original type signature lacks an+explicit `forall`, we infer the correct type variable ordering ourselves and+synthesize a `forall` with that order. The `singTypeKVBs` function implements+this logic.++-----+-- Wrinkle 2: The TH reification swamp+-----++There is another issue with type signatures that lack explicit `forall`s, one+which the current design of Template Haskell does not make simple to fix.+If we single code that is wrapped in TH quotes, such as in the following example:++ {-# LANGUAGE PolyKinds, ... #-}+ $(singletons [d|+ data Proxy a = MkProxy+ |])++Then our job is made much easier when singling MkProxy, since we know that the+only type variable that must be quantified is `a`, as that is the only one+specified by the user. This results in the following type signature for+MkProxy:++ MkProxy :: forall a. Proxy a++However, this is not the only possible way to single MkProxy. One can+alternatively use $(genSingletons [''Proxy]), which uses TH reification to+infer the type of MkProxy. There is perilous, however, because this is how+TH reifies Proxy:++ DataD+ [] ''Proxy [KindedTV a () (VarT k)] Nothing+ [NormalC 'MkProxy []]+ []++We must then construct a type signature for MkProxy using nothing but the type+variables from the data type header. But notice that `KindedTV a () (VarT k)`+gives no indication of whether `k` is specified or inferred! As a result, we+conservatively assume that `k` is specified, resulting the following type+signature for MkProxy:++ MkProxy :: forall k (a :: k). Proxy a++Contrast this with `MkProxy :: Proxy a`, where `k` is inferred. In other words,+if you single MkProxy using genSingletons, then `Proxy @True` will typecheck+but `SMkProxy @True` will /not/ typecheck—you'd have to use+`SMkProxy @_ @True` instead. Urk!++At present, Template Haskell does not have a way to distinguish among the+specificities bound by a data type header. Without this knowledge, it is+unclear how one could work around this issue. Thankfully, this issue is+only likely to surface in very limited circumstances, so the damage is somewhat+minimal.++-----+-- Wrinkle 3: Where to put explicit kind annotations+-----++Type variable binders are only part of the story—we must also determine what+the body of the type signature will be singled to. As a general rule, if the+original type signature is of the form:++ f :: forall a_1 ... a_m. (C_1, ..., C_n)+ => T_1 -> ... -> T_p -> R++Then the singled type signature will be:++ sF :: forall a_1 ... a_m (x_1 :: PT_1) ... (x_p :: PT_p). (SC_1, ..., SC_n)+ => Sing x1 -> ... -> Sing x_p -> SRes (F x1 ... x_p :: PR)++Where:++* x_i is a fresh type variable of kind PT_i.+* PT_i is the promoted version of the type T_i, and PR is the promoted version+ of the type R.+* SC_i is the singled version of the constraint SC_i.+* SRes is either `Sing` if dealing with a function, or a singled data type if+ dealing with a data constructor. For instance, SRes is `SBool` in+ `STrue :: SBool (True :: Bool)`.++One aspect of this worth pointing out is the explicit `:: PR` kind annotation+in the result type `Sing (F x1 ... x_p :: PR)`. As it turns out, this kind+annotation is mandatory, as omitting can result in singled type signatures+with the wrong semantics. For instance, consider the `Nothing` data+constructor:++ Nothing :: forall a. Maybe a++Consider what would happen if it were singled to this type:++ SNothing :: forall a. SMaybe Nothing++This is not what we want at all, since the `a` has no connection to the+`Nothing` in the result type. It's as if we had written this:++ SNothing :: forall {t} a. SMaybe (Nothing :: Maybe t)++If we instead generate `forall a. SMaybe (Nothing :: Maybe a)`, then this issue+is handily avoided.++You might wonder if it would be cleaner to use visible kind applications+instead:++ SNothing :: forall a. SMaybe (Nothing @a)++This does work for many cases, but there are also some corner cases where this+approach fails. Recall the `MkProxy` example from Wrinkle 2 above:++ {-# LANGUAGE PolyKinds, ... #-}+ data Proxy a = MkProxy+ $(genSingletons [''Proxy])++Due to the design of Template Haskell (discussed in Wrinkle 2), `MkProxy` will+be reified with the type of `forall k (a :: k). Proxy a`. This means that+if we used visible kind applications in the result type, we would end up with+this:++ SMkProxy :: forall k (a :: k). SProxy (MkProxy @k @a)++This will not kind-check because MkProxy only accepts /one/ visible kind argument,+whereas this supplies it with two. To avoid this issue, we instead use the type+`forall k (a :: k). SProxy (MkProxy :: Proxy a)`. Granted, this type is /still/+technically wrong due to the fact that it explicitly quantifies `k`, but at the+very least it typechecks. If Template Haskell gained the ability to distinguish+among the specificities of type variables bound by a data type header+(perhaps by way of a language feature akin to+https://github.com/ghc-proposals/ghc-proposals/pull/326), then we could revisit+this design choice.++Finally, note that we need only write `Sing x_1 -> ... -> Sing x_p`, and not+`Sing (x_1 :: PT_1) -> ... Sing (x_p :: PT_p)`. This is simply because we+always use explicit `forall`s in singled type signatures, and therefore always+explicitly bind `(x_1 :: PT_1) ... (x_p :: PT_p)`, which fully determine the+kinds of `x_1 ... x_p`. It wouldn't be wrong to add extra kind annotations to+`Sing x_1 -> ... -> Sing x_p`, just redundant.+-}
+ src/Data/Singletons/TH/SuppressUnusedWarnings.hs view
@@ -0,0 +1,21 @@+-- 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.++{-# LANGUAGE AllowAmbiguousTypes, PolyKinds, StandaloneKindSignatures #-}++module Data.Singletons.TH.SuppressUnusedWarnings where++import Data.Kind++-- | This class (which users should never see) is to be instantiated in order+-- to use an otherwise-unused data constructor, such as the "kind-inference"+-- data constructor for defunctionalization symbols.+type SuppressUnusedWarnings :: k -> Constraint+class SuppressUnusedWarnings (t :: k) where+ suppressUnusedWarnings :: ()
+ src/Data/Singletons/TH/Syntax.hs view
@@ -0,0 +1,240 @@+{- 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.+-}++{-# LANGUAGE DataKinds, TypeFamilies, PolyKinds, DeriveDataTypeable,+ FlexibleInstances, ConstraintKinds #-}++module Data.Singletons.TH.Syntax where++import Prelude hiding ( exp )+import Data.Kind (Constraint, Type)+import Language.Haskell.TH.Syntax hiding (Type)+import Language.Haskell.TH.Desugar+import qualified Language.Haskell.TH.Desugar.OMap.Strict as OMap+import Language.Haskell.TH.Desugar.OMap.Strict (OMap)+import Language.Haskell.TH.Desugar.OSet (OSet)++type VarPromotions = [(Name, Name)] -- from term-level name to type-level name++-- Information that is accumulated when promoting patterns.+data PromDPatInfos = PromDPatInfos+ { prom_dpat_vars :: VarPromotions+ -- Maps term-level pattern variables to their promoted, type-level counterparts.+ , prom_dpat_sig_kvs :: OSet Name+ -- Kind variables bound by DSigPas.+ -- See Note [Explicitly binding kind variables] in+ -- Data.Singletons.TH.Promote.Monad.+ }++instance Semigroup PromDPatInfos where+ PromDPatInfos vars1 sig_kvs1 <> PromDPatInfos vars2 sig_kvs2+ = PromDPatInfos (vars1 <> vars2) (sig_kvs1 <> sig_kvs2)++instance Monoid PromDPatInfos where+ mempty = PromDPatInfos mempty mempty++-- A list of 'SingDSigPaInfos' is produced when singling pattern signatures, as we+-- must case on the 'DExp's and match on them using the supplied 'DType's to+-- bring the necessary singleton equality constraints into scope.+-- See @Note [Singling pattern signatures]@.+type SingDSigPaInfos = [(DExp, DType)]++-- The parts of data declarations that are relevant to singletons-th.+data DataDecl = DataDecl Name [DTyVarBndrUnit] [DCon]++-- The parts of type synonyms that are relevant to singletons-th.+data TySynDecl = TySynDecl Name [DTyVarBndrUnit] DType++-- The parts of open type families that are relevant to singletons-th.+type OpenTypeFamilyDecl = TypeFamilyDecl 'Open++-- The parts of closed type families that are relevant to singletons-th.+type ClosedTypeFamilyDecl = TypeFamilyDecl 'Closed++-- The parts of type families that are relevant to singletons-th.+newtype TypeFamilyDecl (info :: FamilyInfo)+ = TypeFamilyDecl { getTypeFamilyDecl :: DTypeFamilyHead }+-- Whether a type family is open or closed.+data FamilyInfo = Open | Closed++data ClassDecl ann+ = ClassDecl { cd_cxt :: DCxt+ , cd_name :: Name+ , cd_tvbs :: [DTyVarBndrUnit]+ , cd_fds :: [FunDep]+ , cd_lde :: LetDecEnv ann+ , cd_atfs :: [OpenTypeFamilyDecl]+ -- Associated type families. Only recorded for+ -- defunctionalization purposes.+ -- See Note [Partitioning, type synonyms, and type families]+ -- in D.S.TH.Partition.+ }++data InstDecl ann = InstDecl { id_cxt :: DCxt+ , id_name :: Name+ , id_arg_tys :: [DType]+ , id_sigs :: OMap Name DType+ , id_meths :: [(Name, LetDecRHS ann)] }++type UClassDecl = ClassDecl Unannotated+type UInstDecl = InstDecl Unannotated++type AClassDecl = ClassDecl Annotated+type AInstDecl = InstDecl Annotated++{-+We see below several datatypes beginning with "A". These are annotated structures,+necessary for Promote to communicate key things to Single. In particular, promotion+of expressions is *not* deterministic, due to the necessity to create unique names+for lets, cases, and lambdas. So, we put these promotions into an annotated AST+so that Single can use the right promotions.+-}++-- A DExp with let, lambda, and type-signature nodes annotated with their+-- type-level equivalents+data ADExp = ADVarE Name+ | ADConE Name+ | ADLitE Lit+ | ADAppE ADExp ADExp+ | ADLamE [Name] -- type-level names corresponding to term-level ones+ DType -- the promoted lambda+ [Name] ADExp+ | ADCaseE ADExp [ADMatch] DType+ -- the type is the return type+ | ADLetE ALetDecEnv ADExp+ | ADSigE DType -- the promoted expression+ ADExp DType++-- A DPat with a pattern-signature node annotated with its type-level equivalent+data ADPat = ADLitP Lit+ | ADVarP Name+ | ADConP Name [ADPat]+ | ADTildeP ADPat+ | ADBangP ADPat+ | ADSigP DType -- The promoted pattern. Will not contain any wildcards,+ -- as per Note [Singling pattern signatures]+ ADPat DType+ | ADWildP++data ADMatch = ADMatch VarPromotions ADPat ADExp+data ADClause = ADClause VarPromotions+ [ADPat] ADExp++data AnnotationFlag = Annotated | Unannotated++-- These are used at the type-level exclusively+type Annotated = 'Annotated+type Unannotated = 'Unannotated++type family IfAnn (ann :: AnnotationFlag) (yes :: k) (no :: k) :: k where+ IfAnn Annotated yes no = yes+ IfAnn Unannotated yes no = no++data family LetDecRHS :: AnnotationFlag -> Type+data instance LetDecRHS Annotated+ = AFunction DType -- promote function (unapplied)+ Int -- number of arrows in type+ [ADClause]+ | AValue DType -- promoted exp+ Int -- number of arrows in type+ ADExp+data instance LetDecRHS Unannotated = UFunction [DClause]+ | UValue DExp++type ALetDecRHS = LetDecRHS Annotated+type ULetDecRHS = LetDecRHS Unannotated++data LetDecEnv ann = LetDecEnv+ { lde_defns :: OMap Name (LetDecRHS ann)+ , lde_types :: OMap Name DType -- type signatures+ , lde_infix :: OMap Name Fixity -- infix declarations+ , lde_proms :: IfAnn ann (OMap Name DType) () -- possibly, promotions+ , lde_bound_kvs :: IfAnn ann (OMap Name (OSet Name)) ()+ -- The set of bound variables in scope.+ -- See Note [Explicitly binding kind variables]+ -- in Data.Singletons.TH.Promote.Monad.+ }+type ALetDecEnv = LetDecEnv Annotated+type ULetDecEnv = LetDecEnv Unannotated++instance Semigroup ULetDecEnv where+ LetDecEnv defns1 types1 infx1 _ _ <> LetDecEnv defns2 types2 infx2 _ _ =+ LetDecEnv (defns1 <> defns2) (types1 <> types2) (infx1 <> infx2) () ()++instance Monoid ULetDecEnv where+ mempty = LetDecEnv OMap.empty OMap.empty OMap.empty () ()++valueBinding :: Name -> ULetDecRHS -> ULetDecEnv+valueBinding n v = emptyLetDecEnv { lde_defns = OMap.singleton n v }++typeBinding :: Name -> DType -> ULetDecEnv+typeBinding n t = emptyLetDecEnv { lde_types = OMap.singleton n t }++infixDecl :: Fixity -> Name -> ULetDecEnv+infixDecl f n = emptyLetDecEnv { lde_infix = OMap.singleton n f }++emptyLetDecEnv :: ULetDecEnv+emptyLetDecEnv = mempty++buildLetDecEnv :: Quasi q => [DLetDec] -> q ULetDecEnv+buildLetDecEnv = go emptyLetDecEnv+ where+ go acc [] = return acc+ go acc (DFunD name clauses : rest) =+ go (valueBinding name (UFunction clauses) <> acc) rest+ go acc (DValD (DVarP name) exp : rest) =+ go (valueBinding name (UValue exp) <> acc) rest+ go acc (dec@(DValD {}) : rest) = do+ flattened <- flattenDValD dec+ go acc (flattened ++ rest)+ go acc (DSigD name ty : rest) =+ go (typeBinding name ty <> acc) rest+ go acc (DInfixD f n : rest) =+ go (infixDecl f n <> acc) rest+ go acc (DPragmaD{} : rest) = go acc rest++-- See Note [DerivedDecl]+data DerivedDecl (cls :: Type -> Constraint) = DerivedDecl+ { ded_mb_cxt :: Maybe DCxt+ , ded_type :: DType+ , ded_type_tycon :: Name+ , ded_decl :: DataDecl+ }++type DerivedEqDecl = DerivedDecl Eq+type DerivedShowDecl = DerivedDecl Show++{- Note [DerivedDecl]+~~~~~~~~~~~~~~~~~~~~~+Most derived instances are wholly handled in+Data.Singletons.TH.Partition.partitionDecs. There are two notable exceptions to+this rule, however, that are partially handled outside of partitionDecs:+Eq and Show instances. For these instances, we use a DerivedDecl data type to+encode just enough information to recreate the derived instance:++1. Just the instance context, if it's standalone-derived, or Nothing if it's in+ a deriving clause (ded_mb_cxt)+2. The datatype, applied to some number of type arguments, as in the+ instance declaration (ded_type)+3. The datatype name (ded_type_tycon), cached for convenience+4. The datatype's constructors (ded_cons)++Why are these instances handled outside of partitionDecs?++* Deriving Eq in singletons-th not only derives PEq/SEq instances, but it also+ derives SDecide, TestEquality, and TestCoercion instances.+ Data.Singletons.TH.Single (depending on the task at hand).+* Deriving Show in singletons-th not only derives PShow/SShow instances, but it+ also derives Show instances for singletons-th types.++To make this work, we let partitionDecs handle the P{Eq,Show} and S{Eq,Show}+instances, but we also stick the relevant info into a DerivedDecl value for+later use in Data.Singletons.TH.Single, where we additionally generate+SDecide, TestEquality, TestCoercion and Show instances for singleton types.+-}
+ src/Data/Singletons/TH/Util.hs view
@@ -0,0 +1,579 @@+{- 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.+-}++{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, RankNTypes,+ GeneralizedNewtypeDeriving, MultiParamTypeClasses,+ UndecidableInstances, MagicHash, LambdaCase,+ NoMonomorphismRestriction, ScopedTypeVariables,+ FlexibleContexts, TypeApplications #-}++module Data.Singletons.TH.Util where++import Prelude hiding ( exp, foldl, concat, mapM, any, pred )+import Language.Haskell.TH ( pprint )+import Language.Haskell.TH.Syntax hiding ( lift )+import Language.Haskell.TH.Desugar+import Data.Char+import Control.Monad hiding ( mapM )+import Control.Monad.Except hiding ( mapM )+import Control.Monad.Reader hiding ( mapM )+import Control.Monad.Writer hiding ( mapM )+import qualified Data.Map as Map+import Data.Map ( Map )+import Data.Bifunctor (second)+import Data.Foldable+import Data.Functor.Identity+import Data.Traversable+import Data.Generics+import Data.Maybe++-- like reportWarning, but generalized to any Quasi+qReportWarning :: Quasi q => String -> q ()+qReportWarning = qReport False++-- like reportError, but generalized to any Quasi+qReportError :: Quasi q => String -> q ()+qReportError = qReport True++-- | Generate a new Unique+qNewUnique :: DsMonad q => q Uniq+qNewUnique = do+ Name _ flav <- qNewName "x"+ case flav of+ NameU n -> return n+ _ -> error "Internal error: `qNewName` didn't return a NameU"++checkForRep :: Quasi q => [Name] -> q ()+checkForRep names =+ when (any ((== "Rep") . nameBase) names)+ (fail $ "A data type named <<Rep>> is a special case.\n" +++ "Promoting it will not work as expected.\n" +++ "Please choose another name for your data type.")++checkForRepInDecls :: Quasi q => [DDec] -> q ()+checkForRepInDecls decls =+ checkForRep (allNamesIn decls)++tysOfConFields :: DConFields -> [DType]+tysOfConFields (DNormalC _ stys) = map snd stys+tysOfConFields (DRecC vstys) = map (\(_,_,ty) -> ty) vstys++recSelsOfConFields :: DConFields -> [Name]+recSelsOfConFields DNormalC{} = []+recSelsOfConFields (DRecC vstys) = map (\(n,_,_) -> n) vstys++-- Extract a data constructor's name and the number of arguments it accepts.+extractNameArgs :: DCon -> (Name, Int)+extractNameArgs (DCon _ _ n fields _) = (n, length (tysOfConFields fields))++-- Extract a data constructor's name.+extractName :: DCon -> Name+extractName (DCon _ _ n _ _) = n++-- Extract the names of a data constructor's record selectors.+extractRecSelNames :: DCon -> [Name]+extractRecSelNames (DCon _ _ _ fields _) = recSelsOfConFields fields++-- | is a valid Haskell infix data constructor (i.e., does it begin with a colon?)+isInfixDataCon :: String -> Bool+isInfixDataCon (':':_) = True+isInfixDataCon _ = False++-- | Is an identifier a legal data constructor name in Haskell? That is, is its+-- first character an uppercase letter (prefix) or a colon (infix)?+isDataConName :: Name -> Bool+isDataConName n = let first = head (nameBase n) in isUpper first || first == ':'++-- | Is an identifier uppercase?+--+-- Note that this will always return 'False' for infix names, since the concept+-- of upper- and lower-case doesn't make sense for non-alphabetic characters.+-- If you want to check if a name is legal as a data constructor, use the+-- 'isDataConName' function.+isUpcase :: Name -> Bool+isUpcase n = let first = head (nameBase n) in isUpper first++-- Make an identifier uppercase. If the identifier is infix, this acts as the+-- identity function.+upcase :: Name -> Name+upcase = mkName . toUpcaseStr noPrefix++-- make an identifier uppercase and return it as a String+toUpcaseStr :: (String, String) -- (alpha, symb) prefixes to prepend+ -> Name -> String+toUpcaseStr (alpha, symb) n+ | isHsLetter first+ = upcase_alpha++ | otherwise+ = upcase_symb++ where+ str = nameBase n+ first = head str++ upcase_alpha = alpha ++ (toUpper first) : tail str+ upcase_symb = symb ++ str++noPrefix :: (String, String)+noPrefix = ("", "")++-- Put an uppercase prefix on a constructor name. Takes two prefixes:+-- one for identifiers and one for symbols.+--+-- This is different from 'prefixName' in that infix constructor names always+-- start with a colon, so we must insert the prefix after the colon in order+-- for the new name to be syntactically valid.+prefixConName :: String -> String -> Name -> Name+prefixConName pre tyPre n = case (nameBase n) of+ (':' : rest) -> mkName (':' : tyPre ++ rest)+ alpha -> mkName (pre ++ alpha)++-- Put a prefix on a name. Takes two prefixes: one for identifiers+-- and one for symbols.+prefixName :: String -> String -> Name -> Name+prefixName pre tyPre n =+ let str = nameBase n+ first = head str in+ if isHsLetter first+ then mkName (pre ++ str)+ else mkName (tyPre ++ str)++-- Put a suffix on a name. Takes two suffixes: one for identifiers+-- and one for symbols.+suffixName :: String -> String -> Name -> Name+suffixName ident symb n =+ let str = nameBase n+ first = head str in+ if isHsLetter first+ then mkName (str ++ ident)+ else mkName (str ++ symb)++-- convert a number into both alphanumeric and symoblic forms+uniquePrefixes :: String -- alphanumeric prefix+ -> String -- symbolic prefix+ -> Uniq+ -> (String, String) -- (alphanum, symbolic)+uniquePrefixes alpha symb n = (alpha ++ n_str, symb ++ convert n_str)+ where+ n_str = show n++ convert [] = []+ convert (d : ds) =+ let d' = case d of+ '0' -> '!'+ '1' -> '#'+ '2' -> '$'+ '3' -> '%'+ '4' -> '&'+ '5' -> '*'+ '6' -> '+'+ '7' -> '.'+ '8' -> '/'+ '9' -> '>'+ _ -> error "non-digit in show #"+ in d' : convert ds++-- extract the kind from a TyVarBndr+extractTvbKind :: DTyVarBndr flag -> Maybe DKind+extractTvbKind (DPlainTV _ _) = Nothing+extractTvbKind (DKindedTV _ _ k) = Just k++-- extract the name from a TyVarBndr.+extractTvbName :: DTyVarBndr flag -> Name+extractTvbName (DPlainTV n _) = n+extractTvbName (DKindedTV n _ _) = n++tvbToType :: DTyVarBndr flag -> DType+tvbToType = DVarT . extractTvbName++-- If a type variable binder lacks an explicit kind, pick a default kind of+-- Type. Otherwise, leave the binder alone.+defaultTvbToTypeKind :: DTyVarBndr flag -> DTyVarBndr flag+defaultTvbToTypeKind (DPlainTV tvname f) = DKindedTV tvname f $ DConT typeKindName+defaultTvbToTypeKind tvb = tvb++-- If @Nothing@, return @Type@. If @Just k@, return @k@.+defaultMaybeToTypeKind :: Maybe DKind -> DKind+defaultMaybeToTypeKind (Just k) = k+defaultMaybeToTypeKind Nothing = DConT typeKindName++inferMaybeKindTV :: Name -> Maybe DKind -> DTyVarBndrUnit+inferMaybeKindTV n Nothing = DPlainTV n ()+inferMaybeKindTV n (Just k) = DKindedTV n () k++resultSigToMaybeKind :: DFamilyResultSig -> Maybe DKind+resultSigToMaybeKind DNoSig = Nothing+resultSigToMaybeKind (DKindSig k) = Just k+resultSigToMaybeKind (DTyVarSig DPlainTV{}) = Nothing+resultSigToMaybeKind (DTyVarSig (DKindedTV _ _ k)) = Just k++maybeKindToResultSig :: Maybe DKind -> DFamilyResultSig+maybeKindToResultSig = maybe DNoSig DKindSig++maybeSigT :: DType -> Maybe DKind -> DType+maybeSigT ty Nothing = ty+maybeSigT ty (Just ki) = ty `DSigT` ki++-- Reconstruct a vanilla function type from its individual type variable+-- binders, constraints, argument types, and result type. (See+-- Note [Vanilla-type validity checking during promotion] in+-- Data.Singletons.TH.Promote.Type for what "vanilla" means.)+ravelVanillaDType :: [DTyVarBndrSpec] -> DCxt -> [DType] -> DType -> DType+ravelVanillaDType tvbs ctxt args res =+ ifNonEmpty tvbs (DForallT . DForallInvis) $+ ifNonEmpty ctxt DConstrainedT $+ go args+ where+ ifNonEmpty :: [a] -> ([a] -> b -> b) -> b -> b+ ifNonEmpty [] _ z = z+ ifNonEmpty l f z = f l z++ go :: [DType] -> DType+ go [] = res+ go (h:t) = DAppT (DAppT DArrowT h) (go t)++-- Decompose a vanilla function type into its type variables, its context, its+-- argument types, and its result type. (See+-- Note [Vanilla-type validity checking during promotion] in+-- Data.Singletons.TH.Promote.Type for what "vanilla" means.)+-- If a non-vanilla construct is encountered while decomposing the function+-- type, an error is thrown monadically.+--+-- This should be contrasted with the 'unravelDType' function from+-- @th-desugar@, which supports the full gamut of function types. @singletons-th@+-- only supports a subset of these types, which is why this function is used+-- to decompose them instead.+unravelVanillaDType :: forall m. MonadFail m+ => DType -> m ([DTyVarBndrSpec], DCxt, [DType], DType)+unravelVanillaDType ty =+ case unravelVanillaDType_either ty of+ Left err -> fail err+ Right payload -> pure payload++-- Ensures that a 'DType' is a vanilla type. (See+-- Note [Vanilla-type validity checking during promotion] in+-- Data.Singletons.TH.Promote.Type for what "vanilla" means.)+--+-- The only monadic thing that this function can do is 'fail', which it does+-- if a non-vanilla construct is encountered.+checkVanillaDType :: forall m. MonadFail m => DType -> m ()+checkVanillaDType ty =+ case unravelVanillaDType_either ty of+ Left err -> fail err+ Right _ -> pure ()++-- The workhorse that powers unravelVanillaDType and checkVanillaDType.+-- Returns @Right payload@ upon success, and @Left error_msg@ upon failure.+unravelVanillaDType_either ::+ DType -> Either String ([DTyVarBndrSpec], DCxt, [DType], DType)+unravelVanillaDType_either ty =+ runIdentity $ flip runReaderT True $ runExceptT $ runUnravelM $ go_ty ty+ where+ go_ty :: DType -> UnravelM ([DTyVarBndrSpec], DCxt, [DType], DType)+ go_ty typ = do+ let (args1, res) = unravelDType typ+ (args2, tvbs) <- take_tvbs args1+ (args3, ctxt) <- take_ctxt args2+ anons <- take_anons args3+ pure (tvbs, ctxt, anons, res)++ -- Process a type in a higher-order position (e.g., the @forall a. a -> a@ in+ -- @(forall a. a -> a) -> b -> b@). This is only done to check for the+ -- presence of higher-rank foralls or constraints, which are not permitted+ -- in vanilla types.+ go_higher_order_ty :: DType -> UnravelM ()+ go_higher_order_ty typ = () <$ local (const False) (go_ty typ)++ take_tvbs :: DFunArgs -> UnravelM (DFunArgs, [DTyVarBndrSpec])+ take_tvbs (DFAForalls (DForallInvis tvbs) args) = do+ rank_1 <- ask+ unless rank_1 $ fail_forall "higher-rank"+ _ <- traverse_ (traverse_ go_higher_order_ty . extractTvbKind) tvbs+ (args', tvbs') <- take_tvbs args+ pure (args', tvbs ++ tvbs')+ take_tvbs (DFAForalls DForallVis{} _) = fail_vdq+ take_tvbs args = pure (args, [])++ take_ctxt :: DFunArgs -> UnravelM (DFunArgs, DCxt)+ take_ctxt (DFACxt ctxt args) = do+ rank_1 <- ask+ unless rank_1 $ fail_ctxt "higher-rank"+ traverse_ go_higher_order_ty ctxt+ (args', ctxt') <- take_ctxt args+ pure (args', ctxt ++ ctxt')+ take_ctxt (DFAForalls tele _) =+ case tele of+ DForallInvis{} -> fail_forall "nested"+ DForallVis{} -> fail_vdq+ take_ctxt args = pure (args, [])++ take_anons :: DFunArgs -> UnravelM [DType]+ take_anons (DFAAnon anon args) = do+ go_higher_order_ty anon+ anons <- take_anons args+ pure (anon:anons)+ take_anons (DFAForalls tele _) =+ case tele of+ DForallInvis{} -> fail_forall "nested"+ DForallVis{} -> fail_vdq+ take_anons (DFACxt _ _) = fail_ctxt "nested"+ take_anons DFANil = pure []++ failWith :: MonadError String m => String -> m a+ failWith thing = throwError $ unlines+ [ "`singletons-th` does not support " ++ thing+ , "In the type: " ++ pprint (sweeten ty)+ ]++ fail_forall :: MonadError String m => String -> m a+ fail_forall sort = failWith $ sort ++ " `forall`s"++ fail_vdq :: MonadError String m => m a+ fail_vdq = failWith "visible dependent quantification"++ fail_ctxt :: MonadError String m => String -> m a+ fail_ctxt sort = failWith $ sort ++ " contexts"++-- The monad that powers the internals of unravelVanillaDType_either.+--+-- * ExceptT String: records the error message upon failure.+--+-- * Reader Bool: True if we are in a rank-1 position in a type, False otherwise+newtype UnravelM a = UnravelM { runUnravelM :: ExceptT String (Reader Bool) a }+ deriving (Functor, Applicative, Monad, MonadError String, MonadReader Bool)++-- count the number of arguments in a type+countArgs :: DType -> Int+countArgs ty = length $ filterDVisFunArgs args+ where (args, _) = unravelDType ty++-- Collect the invisible type variable binders from a sequence of DFunArgs.+filterInvisTvbArgs :: DFunArgs -> [DTyVarBndrSpec]+filterInvisTvbArgs DFANil = []+filterInvisTvbArgs (DFACxt _ args) = filterInvisTvbArgs args+filterInvisTvbArgs (DFAAnon _ args) = filterInvisTvbArgs args+filterInvisTvbArgs (DFAForalls tele args) =+ let res = filterInvisTvbArgs args in+ case tele of+ DForallVis _ -> res+ DForallInvis tvbs' -> tvbs' ++ res++-- Infer the kind of a DTyVarBndr by using information from a DVisFunArg.+replaceTvbKind :: DVisFunArg -> DTyVarBndrUnit -> DTyVarBndrUnit+replaceTvbKind (DVisFADep tvb) _ = tvb+replaceTvbKind (DVisFAAnon k) tvb = DKindedTV (extractTvbName tvb) () k++-- changes all TyVars not to be NameU's. Workaround for GHC#11812/#17537+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+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 == '_'