diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 --- /dev/null +++ b/CHANGES.md @@ -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 |] + ``` diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,26 @@ +`singletons-th` +=============== + +[![Hackage](https://img.shields.io/hackage/v/singletons-th.svg)](http://hackage.haskell.org/package/singletons-th) + +`singletons-th` defines Template Haskell functionality that allows +_promotion_ of term-level functions to type-level equivalents and +_singling_ functions to dependently typed equivalents. This library was +originally presented in +[_Dependently Typed Programming with Singletons_](https://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`. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/singletons-th.cabal b/singletons-th.cabal new file mode 100644 --- /dev/null +++ b/singletons-th.cabal @@ -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 , Jan Stolarek +maintainer: Ryan Scott +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. + () + See also the paper published at Haskell Symposium, 2014, which describes + how promotion works in greater detail: + . + . + @singletons-th@ generates code that relies on bleeding-edge GHC language + extensions. As such, @singletons-th@ only supports the latest major version + of GHC (currently GHC 9.0). For more information, + consult the @singletons@ + @@. + . + You may also be interested in the following related libraries: + . + * The @singletons@ library is a small, foundational library that defines + basic singleton-related types and definitions. + . + * The @singletons-base@ library uses @singletons-th@ to define promoted and + singled functions from the @base@ library, including the "Prelude". + +source-repository this + type: git + location: https://github.com/goldfirere/singletons.git + subdir: singletons-th + tag: v3.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 diff --git a/src/Data/Singletons/TH.hs b/src/Data/Singletons/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/TH.hs @@ -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 <> 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 <> with something other than a type constructor: " + ++ (show tyName) + _ -> fail $ "Cannot find " ++ show tyName + +buildCases :: DsMonad m + => [(Name, Int)] + -> m Exp -- scrutinee + -> m Exp -- body + -> m DExp +buildCases ctor_infos expq bodyq = + DCaseE <$> (dsExp =<< expq) <*> + mapM (\con -> DMatch (conToPat con) <$> (dsExp =<< bodyq)) ctor_infos + where + conToPat :: (Name, Int) -> DPat + conToPat (name, num_fields) = + DConP name (replicate num_fields DWildP) diff --git a/src/Data/Singletons/TH/CustomStar.hs b/src/Data/Singletons/TH/CustomStar.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/TH/CustomStar.hs @@ -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 diff --git a/src/Data/Singletons/TH/Deriving/Bounded.hs b/src/Data/Singletons/TH/Deriving/Bounded.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/TH/Deriving/Bounded.hs @@ -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) ] } diff --git a/src/Data/Singletons/TH/Deriving/Enum.hs b/src/Data/Singletons/TH/Deriving/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/TH/Deriving/Enum.hs @@ -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) ] }) diff --git a/src/Data/Singletons/TH/Deriving/Eq.hs b/src/Data/Singletons/TH/Deriving/Eq.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/TH/Deriving/Eq.hs @@ -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 diff --git a/src/Data/Singletons/TH/Deriving/Foldable.hs b/src/Data/Singletons/TH/Deriving/Foldable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/TH/Deriving/Foldable.hs @@ -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 } diff --git a/src/Data/Singletons/TH/Deriving/Functor.hs b/src/Data/Singletons/TH/Deriving/Functor.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/TH/Deriving/Functor.hs @@ -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 } diff --git a/src/Data/Singletons/TH/Deriving/Infer.hs b/src/Data/Singletons/TH/Deriving/Infer.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/TH/Deriving/Infer.hs @@ -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 diff --git a/src/Data/Singletons/TH/Deriving/Ord.hs b/src/Data/Singletons/TH/Deriving/Ord.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/TH/Deriving/Ord.hs @@ -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) diff --git a/src/Data/Singletons/TH/Deriving/Show.hs b/src/Data/Singletons/TH/Deriving/Show.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/TH/Deriving/Show.hs @@ -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 diff --git a/src/Data/Singletons/TH/Deriving/Traversable.hs b/src/Data/Singletons/TH/Deriving/Traversable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/TH/Deriving/Traversable.hs @@ -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) ] } diff --git a/src/Data/Singletons/TH/Deriving/Util.hs b/src/Data/Singletons/TH/Deriving/Util.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/TH/Deriving/Util.hs @@ -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] diff --git a/src/Data/Singletons/TH/Names.hs b/src/Data/Singletons/TH/Names.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/TH/Names.hs @@ -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. +-} diff --git a/src/Data/Singletons/TH/Options.hs b/src/Data/Singletons/TH/Options.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/TH/Options.hs @@ -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@ + -- @@ + -- for more details. + , promotedClassName :: Name -> Name + -- ^ Given the name of the original, unrefined class, produces the name of + -- the promoted equivalent of the class. + , promotedValueName :: Name -> Maybe Uniq -> Name + -- ^ Given the name of the original, unrefined value, produces the name of + -- the promoted equivalent of the value. This is used for both top-level + -- and @let@-bound names, and the difference is encoded in the + -- @'Maybe' 'Uniq'@ argument. If promoting a top-level name, the argument + -- is 'Nothing'. If promoting a @let@-bound name, the argument is + -- @Just uniq@, where @uniq@ is a globally unique number that can be used + -- to distinguish the name from other local definitions of the same name + -- (e.g., if two functions both use @let x = ... in x@). + , singledDataTypeName :: Name -> Name + -- ^ Given the name of the original, unrefined data type, produces the name + -- of the corresponding singleton type. + , singledClassName :: Name -> Name + -- ^ Given the name of the original, unrefined class, produces the name of + -- the singled equivalent of the class. + , singledDataConName :: Name -> Name + -- ^ Given the name of the original, unrefined data constructor, produces + -- the name of the corresponding singleton data constructor. + , singledValueName :: Name -> Name + -- ^ Given the name of the original, unrefined value, produces the name of + -- the singled equivalent of the value. + , defunctionalizedName :: Name -> Int -> Name + -- ^ Given the original name and the number of parameters it is applied to + -- (the 'Int' argument), produces a type-level function name that can be + -- partially applied when given the same number of parameters. + -- + -- Note that defunctionalization works over both term-level names + -- (producing symbols for the promoted name) and type-level names + -- (producing symbols directly for the name itself). As a result, this + -- callback is used for names in both the term and type namespaces. + } + +-- | Sensible default 'Options'. +-- +-- 'genQuotedDecs' defaults to 'True'. +-- That is, quoted declarations are generated alongside their promoted and +-- singled counterparts. +-- +-- 'genSingKindInsts' defaults to 'True'. +-- That is, 'SingKind' instances are generated. +-- +-- The default behaviors for 'promotedClassName', 'promotedValueNamePrefix', +-- 'singledDataTypeName', 'singledClassName', 'singledDataConName', +-- 'singledValueName', and 'defunctionalizedName' are described in the +-- \"On names\" section of the @singletons@ +-- @@. +defaultOptions :: Options +defaultOptions = Options + { genQuotedDecs = True + , genSingKindInsts = True + , promotedDataTypeOrConName = promoteDataTypeOrConName + , promotedClassName = promoteClassName + , promotedValueName = promoteValNameLhs + , singledDataTypeName = singTyConName + , singledClassName = singClassName + , singledDataConName = singDataConName + , singledValueName = singValName + , defunctionalizedName = promoteTySym + } + +-- | Given the name of the original, unrefined, top-level value, produces the +-- name of the promoted equivalent of the value. +promotedTopLevelValueName :: Options -> Name -> Name +promotedTopLevelValueName opts name = promotedValueName opts name Nothing + +-- | Given the name of the original, unrefined, @let@-bound value and its +-- globally unique number, produces the name of the promoted equivalent of the +-- value. +promotedLetBoundValueName :: Options -> Name -> Uniq -> Name +promotedLetBoundValueName opts name = promotedValueName opts name . Just + +-- | Given the original name of a function (term- or type-level), produces a +-- type-level function name that can be partially applied even without being +-- given any arguments (i.e., @0@ arguments). +defunctionalizedName0 :: Options -> Name -> Name +defunctionalizedName0 opts name = defunctionalizedName opts name 0 + +-- | Class that describes monads that contain 'Options'. +class DsMonad m => OptionsMonad m where + getOptions :: m Options + +instance OptionsMonad Q where + getOptions = pure defaultOptions + +instance OptionsMonad m => OptionsMonad (DsM m) where + getOptions = lift getOptions + +instance (OptionsMonad q, Monoid m) => OptionsMonad (QWithAux m q) where + getOptions = lift getOptions + +instance OptionsMonad m => OptionsMonad (ReaderT r m) where + getOptions = lift getOptions + +instance OptionsMonad m => OptionsMonad (StateT s m) where + getOptions = lift getOptions + +instance (OptionsMonad m, Monoid w) => OptionsMonad (WriterT w m) where + getOptions = lift getOptions + +instance (OptionsMonad m, Monoid w) => OptionsMonad (RWST r w s m) where + getOptions = lift getOptions + +-- | A convenient implementation of the 'OptionsMonad' class. Use by calling +-- 'withOptions'. +newtype OptionsM m a = OptionsM (ReaderT Options m a) + deriving ( Functor, Applicative, Monad, MonadTrans + , Quote, Quasi, MonadFail, MonadIO, DsMonad ) + +-- | Turn any 'DsMonad' into an 'OptionsMonad'. +instance DsMonad m => OptionsMonad (OptionsM m) where + getOptions = OptionsM ask + +-- | Declare the 'Options' that a TH computation should use. +withOptions :: Options -> OptionsM m a -> m a +withOptions opts (OptionsM x) = runReaderT x opts + +-- Used when a value name appears in a pattern context. +-- Works only for proper variables (lower-case names). +-- +-- If the Maybe Uniq argument is Nothing, then the name is top-level (and +-- thus globally unique on its own). +-- If the Maybe Uniq argument is `Just uniq`, then the name is let-bound and +-- should use `uniq` to make the promoted name globally unique. +promoteValNameLhs :: Name -> Maybe Uniq -> Name +promoteValNameLhs n mb_let_uniq + -- We can't promote promote idenitifers beginning with underscores to + -- type names, so we work around the issue by prepending "US" at the + -- front of the name (#229). + | Just (us, rest) <- splitUnderscores (nameBase n) + = mkName $ alpha ++ "US" ++ us ++ rest + + | otherwise + = mkName $ toUpcaseStr pres n + where + pres = maybe noPrefix (uniquePrefixes "Let" "<<<") mb_let_uniq + (alpha, _) = pres + +-- generates type-level symbol for a given name. Int parameter represents +-- saturation: 0 - no parameters passed to the symbol, 1 - one parameter +-- passed to the symbol, and so on. Works on both promoted and unpromoted +-- names. +promoteTySym :: Name -> Int -> Name +promoteTySym name sat + -- We can't promote promote idenitifers beginning with underscores to + -- type names, so we work around the issue by prepending "US" at the + -- front of the name (#229). + | Just (us, rest) <- splitUnderscores (nameBase name) + = default_case (mkName $ "US" ++ us ++ rest) + + | name == nilName + = mkName $ "NilSym" ++ (show sat) + + -- Treat unboxed tuples like tuples. + -- See Note [Promoting and singling unboxed tuples]. + | Just degree <- tupleNameDegree_maybe name <|> + unboxedTupleNameDegree_maybe name + = mkName $ "Tuple" ++ show degree ++ "Sym" ++ show sat + + | otherwise + = default_case name + where + default_case :: Name -> Name + default_case name' = + let capped = toUpcaseStr noPrefix name' in + if isHsLetter (head capped) + then mkName (capped ++ "Sym" ++ (show sat)) + else mkName (capped ++ "@#@" -- See Note [Defunctionalization symbol suffixes] + ++ (replicate (sat + 1) '$')) + +promoteClassName :: Name -> Name +promoteClassName = prefixName "P" "#" + +promoteDataTypeOrConName :: Name -> Name +promoteDataTypeOrConName nm + | nameBase nm == nameBase repName = typeKindName + -- See Note [Promoting and singling unboxed tuples] + | Just degree <- unboxedTupleNameDegree_maybe nm + = if isDataName nm then tupleDataName degree else tupleTypeName degree + | otherwise = nm + where + -- Is this name a data constructor name? A 'False' answer means "unsure". + isDataName :: Name -> Bool + isDataName (Name _ (NameG DataName _ _)) = True + isDataName _ = False + +-- Singletons + +singDataConName :: Name -> Name +singDataConName nm + | nm == nilName = mkName "SNil" + | nm == consName = mkName "SCons" + | Just degree <- tupleNameDegree_maybe nm = mkTupleName degree + -- See Note [Promoting and singling unboxed tuples] + | Just degree <- unboxedTupleNameDegree_maybe nm = mkTupleName degree + | otherwise = prefixConName "S" "%" nm + +singTyConName :: Name -> Name +singTyConName name + | name == listName = mkName "SList" + | Just degree <- tupleNameDegree_maybe name = mkTupleName degree + -- See Note [Promoting and singling unboxed tuples] + | Just degree <- unboxedTupleNameDegree_maybe name = mkTupleName degree + | otherwise = prefixName "S" "%" name + +mkTupleName :: Int -> Name +mkTupleName n = mkName $ "STuple" ++ show n + +singClassName :: Name -> Name +singClassName = singTyConName + +singValName :: Name -> Name +singValName n + -- Push the 's' past the underscores, as this lets us avoid some unused + -- variable warnings (#229). + | Just (us, rest) <- splitUnderscores (nameBase n) + = prefixName (us ++ "s") "%" $ mkName rest + | otherwise + = prefixName "s" "%" $ upcase n + +{- +Note [Promoting and singling unboxed tuples] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Unfortunately, today's GHC is not quite up to the task of promoting types +involving unboxed tuples. Consider this example: + + swapperino :: (# a, b #) -> (# b, a #) + +What would this look like when promoted? Presumably, it would have a kind +signature like this: + + type Swapperino :: (# a, b #) -> (# b, a #) + +Surprisingly, this won't kindcheck: + + error: + • Expecting a lifted type, but ‘(# a, b #)’ is unlifted + • In a standalone kind signature for ‘Swapperino’: + (# a, b #) -> (# b, a #) + +Even though (->) is levity polymorphic, this levity polymorphism only kicks in +for types, not kinds. In other words, the (->) in the kind of Swapperino is +completely levity monomorphic and only accepts Type-kinded arguments. This +oddity is tracked upstream as GHC#14180. Until that is fixed, there is no hope +of using promoted unboxed tuples freely in kinds. + +However, we don't have to give up quite yet. As a crude-but-effective +workaround, we can simply promote value-level unboxed tuples to type-level boxed +tuples. In other words, we would promote swapperino to this: + + type Swapperino :: (a, b) -> (b, a) + +This trick is enough to make many (but not all) uses of unboxed tuples +Just Work™ when promoted. We use a similar trick when singling unboxed tuples +as well. +-} diff --git a/src/Data/Singletons/TH/Partition.hs b/src/Data/Singletons/TH/Partition.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/TH/Partition.hs @@ -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. +-} diff --git a/src/Data/Singletons/TH/Promote.hs b/src/Data/Singletons/TH/Promote.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/TH/Promote.hs @@ -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 +-- @@ +-- for further explanation. +promote :: OptionsMonad q => q [Dec] -> q [Dec] +promote qdecs = do + opts <- getOptions + withOptions opts{genQuotedDecs = True} $ promote' $ lift qdecs + +-- | Promote each declaration, discarding the originals. Note that a promoted +-- datatype uses the same definition as an original datatype, so this will +-- not work with datatypes. Classes, instances, and functions are all fine. +promoteOnly :: OptionsMonad q => q [Dec] -> q [Dec] +promoteOnly qdecs = do + opts <- getOptions + withOptions opts{genQuotedDecs = False} $ promote' $ lift qdecs + +-- The workhorse for 'promote' and 'promoteOnly'. The difference between the +-- two functions is whether 'genQuotedDecs' is set to 'True' or 'False'. +promote' :: OptionsMonad q => q [Dec] -> q [Dec] +promote' qdecs = do + opts <- getOptions + decs <- qdecs + ddecs <- withLocalDeclarations decs $ dsDecs decs + promDecs <- promoteM_ decs $ promoteDecs ddecs + let origDecs | genQuotedDecs opts = decs + | otherwise = [] + return $ origDecs ++ decsToTH promDecs + +-- | Generate defunctionalization symbols for each of the provided type-level +-- declaration 'Name's. See the "Promotion and partial application" section of +-- the @singletons@ +-- @@ +-- for further explanation. +genDefunSymbols :: OptionsMonad q => [Name] -> q [Dec] +genDefunSymbols names = do + checkForRep names + infos <- mapM (dsInfo <=< reifyWithLocals) names + decs <- promoteMDecs [] $ concatMapM defunInfo infos + return $ decsToTH decs + +-- | Produce instances for @PEq@ from the given types +promoteEqInstances :: OptionsMonad q => [Name] -> q [Dec] +promoteEqInstances = concatMapM promoteEqInstance + +-- | Produce an instance for @PEq@ from the given type +promoteEqInstance :: OptionsMonad q => Name -> q [Dec] +promoteEqInstance = promoteInstance mkEqInstance "Eq" + +-- | Produce instances for 'POrd' from the given types +promoteOrdInstances :: OptionsMonad q => [Name] -> q [Dec] +promoteOrdInstances = concatMapM promoteOrdInstance + +-- | Produce an instance for 'POrd' from the given type +promoteOrdInstance :: OptionsMonad q => Name -> q [Dec] +promoteOrdInstance = promoteInstance mkOrdInstance "Ord" + +-- | Produce instances for 'PBounded' from the given types +promoteBoundedInstances :: OptionsMonad q => [Name] -> q [Dec] +promoteBoundedInstances = concatMapM promoteBoundedInstance + +-- | Produce an instance for 'PBounded' from the given type +promoteBoundedInstance :: OptionsMonad q => Name -> q [Dec] +promoteBoundedInstance = promoteInstance mkBoundedInstance "Bounded" + +-- | Produce instances for 'PEnum' from the given types +promoteEnumInstances :: OptionsMonad q => [Name] -> q [Dec] +promoteEnumInstances = concatMapM promoteEnumInstance + +-- | Produce an instance for 'PEnum' from the given type +promoteEnumInstance :: OptionsMonad q => Name -> q [Dec] +promoteEnumInstance = promoteInstance mkEnumInstance "Enum" + +-- | Produce instances for 'PShow' from the given types +promoteShowInstances :: OptionsMonad q => [Name] -> q [Dec] +promoteShowInstances = concatMapM promoteShowInstance + +-- | Produce an instance for 'PShow' from the given type +promoteShowInstance :: OptionsMonad q => Name -> q [Dec] +promoteShowInstance = promoteInstance mkShowInstance "Show" + +promoteInstance :: OptionsMonad q => DerivDesc q -> String -> Name -> q [Dec] +promoteInstance mk_inst class_name name = do + (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) diff --git a/src/Data/Singletons/TH/Promote/Defun.hs b/src/Data/Singletons/TH/Promote/Defun.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/TH/Promote/Defun.hs @@ -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. +-} diff --git a/src/Data/Singletons/TH/Promote/Monad.hs b/src/Data/Singletons/TH/Promote/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/TH/Promote/Monad.hs @@ -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 +-} diff --git a/src/Data/Singletons/TH/Promote/Type.hs b/src/Data/Singletons/TH/Promote/Type.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/TH/Promote/Type.hs @@ -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. +-} diff --git a/src/Data/Singletons/TH/Single.hs b/src/Data/Singletons/TH/Single.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/TH/Single.hs @@ -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 +-- @@ +-- 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. +-} diff --git a/src/Data/Singletons/TH/Single/Data.hs b/src/Data/Singletons/TH/Single/Data.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/TH/Single/Data.hs @@ -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. +-} diff --git a/src/Data/Singletons/TH/Single/Decide.hs b/src/Data/Singletons/TH/Single/Decide.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/TH/Single/Decide.hs @@ -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) [] diff --git a/src/Data/Singletons/TH/Single/Defun.hs b/src/Data/Singletons/TH/Single/Defun.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/TH/Single/Defun.hs @@ -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. +-} diff --git a/src/Data/Singletons/TH/Single/Fixity.hs b/src/Data/Singletons/TH/Single/Fixity.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/TH/Single/Fixity.hs @@ -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. +-} diff --git a/src/Data/Singletons/TH/Single/Monad.hs b/src/Data/Singletons/TH/Single/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/TH/Single/Monad.hs @@ -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. +-} diff --git a/src/Data/Singletons/TH/Single/Type.hs b/src/Data/Singletons/TH/Single/Type.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/TH/Single/Type.hs @@ -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. +-} diff --git a/src/Data/Singletons/TH/SuppressUnusedWarnings.hs b/src/Data/Singletons/TH/SuppressUnusedWarnings.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/TH/SuppressUnusedWarnings.hs @@ -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 :: () diff --git a/src/Data/Singletons/TH/Syntax.hs b/src/Data/Singletons/TH/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/TH/Syntax.hs @@ -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. +-} diff --git a/src/Data/Singletons/TH/Util.hs b/src/Data/Singletons/TH/Util.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/TH/Util.hs @@ -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 <> 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 == '_'