diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,100 @@ `th-desugar` release notes ========================== +Version 1.9 +----------- +* Suppose GHC 8.6. + +* Add support for `DerivingVia`. Correspondingly, there is now a + `DDerivStrategy` data type. + +* Add support for `QuantifiedConstraints`. Correspondingly, there is now a + `DForallPr` constructor in `DPred` to represent quantified constraint types. + +* Remove the `DStarT` constructor of `DType` in favor of `DConT ''Type`. + Two utility functions have been added to `Language.Haskell.TH.Desugar` to + ease this transition: + + * `isTypeKindName`: returns `True` if the argument `Name` is that + of `Type` or `★` (or `*`, to support older GHCs). + * `typeKindName`: the name of `Type` (on GHC 8.0 or later) or `*` (on older + GHCs). + +* `th-desugar` now desugars all data types to GADT syntax. The most significant + API-facing changes resulting from this new design are: + + * The `DDataD`, `DDataFamilyD`, and `DDataFamInstD` constructors of `DDec` + now have `Maybe DKind` fields that either have `Just` an explicit return + kind (e.g., the `k -> Type -> Type` in `data Foo :: k -> Type -> Type`) + or `Nothing` (if lacking an explicit return kind). + * The `DCon` constructor previously had a field of type `Maybe DType`, since + there was a possibility it could be a GADT (with an explicit return type) + or non-GADT (without an explicit return type) constructor. Since all data + types are desugared to GADTs now, this field has been changed to be simply + a `DType`. + * The type signature of `dsCon` was previously: + + ```haskell + dsCon :: DsMonad q => Con -> q [DCon] + ``` + + However, desugaring constructors now needs more information than before, + since GADT constructors have richer type signatures. Accordingly, the type + of `dsCon` is now: + + ```haskell + dsCon :: DsMonad q + => [DTyVarBndr] -- ^ The universally quantified type variables + -- (used if desugaring a non-GADT constructor) + -> DType -- ^ The original data declaration's type + -- (used if desugaring a non-GADT constructor). + -> Con -> q [DCon] + ``` + + The `instance Desugar [Con] [DCon]` has also been removed, as the previous + implementation of `desugar` (`concatMapM dsCon`) no longer has enough + information to work. + + Some other utility functions have also been added as part of this change: + + * A `conExistentialTvbs` function has been introduced to determine the + existentially quantified type variables of a `DCon`. Note that this + function is not 100% accurate—refer to the documentation for + `conExistentialTvbs` for more information. + + * A `mkExtraDKindBinders` function has been introduced to turn a data type's + return kind into explicit, fresh type variable binders. + + * A `toposortTyVarsOf` function, which finds the free variables of a list of + `DType`s and returns them in a well scoped list that has been sorted in + reverse topological order. + +* `th-desugar` now desugars partial pattern matches in `do`-notation and + list/monad comprehensions to the appropriate invocation of `fail`. + (Previously, these were incorrectly desugared into `case` expressions with + incomplete patterns.) + +* Add a `mkDLamEFromDPats` function for constructing a `DLamE` expression using + a list of `DPat` arguments and a `DExp` body. + +* Add an `unravel` function for decomposing a function type into its `forall`'d + type variables, its context, its argument types, and its result type. + +* Export a `substTyVarBndrs` function from `Language.Haskell.TH.Desugar.Subst`, + which substitutes over type variable binders in a capture-avoiding fashion. + +* `getDataD`, `dataConNameToDataName`, and `dataConNameToCon` from + `Language.Haskell.TH.Desugar.Reify` now look up local declarations. As a + result, the contexts in their type signatures have been strengthened from + `Quasi` to `DsMonad`. + +* Export a `dTyVarBndrToDType` function which converts a `DTyVarBndr` to a + `DType`, which preserves its kind. + +* Previously, `th-desugar` would silently accept illegal uses of record + construction with fields that did not belong to the constructor, such as + `Identity { notAField = "wat" }`. This is now an error. + Version 1.8 ----------- * Support GHC 8.4. diff --git a/Language/Haskell/TH/Desugar.hs b/Language/Haskell/TH/Desugar.hs --- a/Language/Haskell/TH/Desugar.hs +++ b/Language/Haskell/TH/Desugar.hs @@ -12,12 +12,12 @@ -- Module : Language.Haskell.TH.Desugar -- Copyright : (C) 2014 Richard Eisenberg -- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) +-- Maintainer : Ryan Scott -- Stability : experimental -- Portability : non-portable -- -- Desugars full Template Haskell syntax into a smaller core syntax for further --- processing. The desugared types and constructors are prefixed with a D. +-- processing. -- ---------------------------------------------------------------------------- @@ -25,7 +25,7 @@ -- * Desugared data types DExp(..), DLetDec(..), DPat(..), DType(..), DKind, DCxt, DPred(..), DTyVarBndr(..), DMatch(..), DClause(..), DDec(..), - DDerivClause(..), DerivStrategy(..), DPatSynDir(..), DPatSynType, + DDerivClause(..), DDerivStrategy(..), DPatSynDir(..), DPatSynType, Overlap(..), PatSynArgs(..), NewOrData(..), DTypeFamilyHead(..), DFamilyResultSig(..), InjectivityAnn(..), DCon(..), DConFields(..), DDeclaredInfix, DBangType, DVarBangType, @@ -84,17 +84,20 @@ getDataD, dataConNameToDataName, dataConNameToCon, nameOccursIn, allNamesIn, flattenDValD, getRecordSelectors, mkTypeName, mkDataName, newUniqueName, - mkTupleDExp, mkTupleDPat, maybeDLetE, maybeDCaseE, + mkTupleDExp, mkTupleDPat, maybeDLetE, maybeDCaseE, mkDLamEFromDPats, fvDType, tupleDegree_maybe, tupleNameDegree_maybe, unboxedSumDegree_maybe, unboxedSumNameDegree_maybe, unboxedTupleDegree_maybe, unboxedTupleNameDegree_maybe, - strictToBang, + strictToBang, isTypeKindName, typeKindName, + unravel, conExistentialTvbs, mkExtraDKindBinders, + dTyVarBndrToDType, toposortTyVarsOf, -- ** Extracting bound names extractBoundNamesStmt, extractBoundNamesDec, extractBoundNamesPat ) where +import Language.Haskell.TH.Desugar.AST import Language.Haskell.TH.Desugar.Core import Language.Haskell.TH.Desugar.Util import Language.Haskell.TH.Desugar.Sweeten @@ -104,12 +107,9 @@ import Language.Haskell.TH.Desugar.Match import Language.Haskell.TH.Desugar.Subst +import Control.Monad import qualified Data.Map as M -import Data.Monoid import qualified Data.Set as S -#if __GLASGOW_HASKELL__ < 709 -import Data.Foldable ( foldMap ) -#endif import Prelude hiding ( exp ) -- | This class relates a TH type with its th-desugar type and allows @@ -140,10 +140,6 @@ desugar = dsDecs sweeten = decsToTH -instance Desugar [Con] [DCon] where - desugar = concatMapM dsCon - sweeten = map conToTH - -- | If the declaration passed in is a 'DValD', creates new, equivalent -- declarations such that the 'DPat' in all 'DValD's is just a plain -- 'DVarPa'. Other declarations are passed through unchanged. @@ -180,35 +176,6 @@ flattenDValD other_dec = return [other_dec] -fvDType :: DType -> S.Set Name -fvDType = go_ty - where - go_ty :: DType -> S.Set Name - go_ty (DForallT tvbs cxt ty) = (foldMap go_tvb tvbs <> go_ty ty <> foldMap go_pred cxt) - S.\\ foldMap dtvbName tvbs - go_ty (DAppT t1 t2) = go_ty t1 <> go_ty t2 - go_ty (DSigT ty ki) = go_ty ty <> go_ty ki - go_ty (DVarT n) = S.singleton n - go_ty (DConT {}) = S.empty - go_ty DArrowT = S.empty - go_ty (DLitT {}) = S.empty - go_ty DWildCardT = S.empty - go_ty DStarT = S.empty - - go_pred :: DPred -> S.Set Name - go_pred (DAppPr pr ty) = go_pred pr <> go_ty ty - go_pred (DSigPr pr ki) = go_pred pr <> go_ty ki - go_pred (DVarPr n) = S.singleton n - go_pred _ = S.empty - - go_tvb :: DTyVarBndr -> S.Set Name - go_tvb (DPlainTV{}) = S.empty - go_tvb (DKindedTV _ k) = go_ty k - -dtvbName :: DTyVarBndr -> S.Set Name -dtvbName (DPlainTV n) = S.singleton n -dtvbName (DKindedTV n _) = S.singleton n - -- | Produces 'DLetDec's representing the record selector functions from -- the provided 'DCon's. -- @@ -229,9 +196,14 @@ -- @ -- -- instead of returning one binding for @X1@ and another binding for @X2@. +-- +-- 'getRecordSelectors' attempts to filter out \"naughty\" record selectors +-- whose types mention existentially quantified type variables. But see the +-- documentation for 'conExistentialTvbs' for limitations to this approach. -- See https://github.com/goldfirere/singletons/issues/180 for an example where -- the latter behavior can bite you. + getRecordSelectors :: Quasi q => DType -- ^ the type of the argument -> [DCon] @@ -319,3 +291,98 @@ | DFunD n _ <- x, Just merged_clauses <- n `M.lookup` name_clause_map = DFunD n merged_clauses:augment_clauses name_clause_map xs | otherwise = x:augment_clauses name_clause_map xs + +-- | Create new kind variable binder names corresponding to the return kind of +-- a data type. This is useful when you have a data type like: +-- +-- @ +-- data Foo :: forall k. k -> Type -> Type where ... +-- @ +-- +-- But you want to be able to refer to the type @Foo a b@. +-- 'mkExtraDKindBinders' will take the kind @forall k. k -> Type -> Type@, +-- discover that is has two visible argument kinds, and return as a result +-- two new kind variable binders @[a :: k, b :: Type]@, where @a@ and @b@ +-- are fresh type variable names. +-- +-- This expands kind synonyms if necessary. +mkExtraDKindBinders :: DsMonad q => DKind -> q [DTyVarBndr] +mkExtraDKindBinders = expandType >=> mkExtraDKindBinders' + +-- | Returns all of a constructor's existentially quantified type variable +-- binders. +-- +-- Detecting the presence of existentially quantified type variables in the +-- context of Template Haskell is quite involved. Here is an example that +-- we will use to explain how this works: +-- +-- @ +-- data family Foo a b +-- data instance Foo (Maybe a) b where +-- MkFoo :: forall x y z. x -> y -> z -> Foo (Maybe x) [z] +-- @ +-- +-- In @MkFoo@, @x@ is universally quantified, whereas @y@ and @z@ are +-- existentially quantified. Note that @MkFoo@ desugars (in Core) to +-- something like this: +-- +-- @ +-- data instance Foo (Maybe a) b where +-- MkFoo :: forall a b y z. (b ~ [z]). a -> y -> z -> Foo (Maybe a) b +-- @ +-- +-- Here, we can see that @a@ appears in the desugared return type (it is a +-- simple alpha-renaming of @x@), so it is universally quantified. On the other +-- hand, neither @y@ nor @z@ appear in the desugared return type, so they are +-- existentially quantified. +-- +-- This analysis would not have been possible without knowing what the original +-- data declaration's type was (in this case, @Foo (Maybe a) b@), which is why +-- we require it as an argument. Our algorithm for detecting existentially +-- quantified variables is not too different from what was described above: +-- we match the constructor's return type with the original data type, forming +-- a substitution, and check which quantified variables are not part of the +-- domain of the substitution. +-- +-- Be warned: this may overestimate which variables are existentially +-- quantified when kind variables are involved. For instance, consider this +-- example: +-- +-- @ +-- data S k (a :: k) +-- data T a where +-- MkT :: forall k (a :: k). { foo :: Proxy (a :: k), bar :: S k a } -> T a +-- @ +-- +-- Here, the kind variable @k@ does not appear syntactically in the return type +-- @T a@, so 'conExistentialTvbs' would mistakenly flag @k@ as existential. +-- +-- There are various tricks we could employ to improve this, but ultimately, +-- making this behave correctly with respect to @PolyKinds@ 100% of the time +-- would amount to performing kind inference in Template Haskell, which is +-- quite difficult. For the sake of simplicity, we have decided to stick with +-- a dumb-but-predictable syntactic check. +conExistentialTvbs :: DsMonad q + => DType -- ^ The type of the original data declaration + -> DCon + -> q [DTyVarBndr] +conExistentialTvbs data_ty (DCon tvbs _ _ _ ret_ty) = + -- Due to GHC Trac #13885, it's possible that the type variables bound by + -- a GADT constructor will shadow those that are bound by the data type. + -- This function assumes this isn't the case in certain parts (e.g., when + -- unifying types), so we do an alpha-renaming of the + -- constructor-bound variables before proceeding. + substTyVarBndrs M.empty tvbs $ \subst tvbs' -> do + renamed_ret_ty <- substTy subst ret_ty + data_ty' <- expandType data_ty + ret_ty' <- expandType renamed_ret_ty + case matchTy YesIgnore ret_ty' data_ty' of + Nothing -> fail $ showString "Unable to match type " + . showsPrec 11 ret_ty' + . showString " with " + . showsPrec 11 data_ty' + $ "" + Just gadtSubt -> return [ tvb + | tvb <- tvbs' + , M.notMember (dtvbName tvb) gadtSubt + ] diff --git a/Language/Haskell/TH/Desugar/AST.hs b/Language/Haskell/TH/Desugar/AST.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/TH/Desugar/AST.hs @@ -0,0 +1,305 @@ +{- Language/Haskell/TH/Desugar/AST.hs + +(c) Ryan Scott 2018 + +Defines the desugared Template Haskell AST. The desugared types and +constructors are prefixed with a D. +-} + +{-# LANGUAGE CPP, DeriveDataTypeable, DeriveGeneric #-} + +module Language.Haskell.TH.Desugar.AST where + +import Data.Data hiding (Fixity) +import GHC.Generics hiding (Fixity) +import Language.Haskell.TH + +-- | Corresponds to TH's @Exp@ type. Note that @DLamE@ takes names, not patterns. +data DExp = DVarE Name + | DConE Name + | DLitE Lit + | DAppE DExp DExp + | DAppTypeE DExp DType + | DLamE [Name] DExp + | DCaseE DExp [DMatch] + | DLetE [DLetDec] DExp + | DSigE DExp DType + | DStaticE DExp + deriving (Show, Typeable, Data, Generic) + + +-- | Corresponds to TH's @Pat@ type. +data DPat = DLitPa Lit + | DVarPa Name + | DConPa Name [DPat] + | DTildePa DPat + | DBangPa DPat + | DSigPa DPat DType + | DWildPa + deriving (Show, Typeable, Data, Generic) + +-- | Corresponds to TH's @Type@ type, used to represent +-- types and kinds. +data DType = DForallT [DTyVarBndr] DCxt DType + | DAppT DType DType + | DSigT DType DKind + | DVarT Name + | DConT Name + | DArrowT + | DLitT TyLit + | DWildCardT + deriving (Show, Typeable, Data, Generic) + +-- | Kinds are types. +type DKind = DType + +-- | Corresponds to TH's @Cxt@ +type DCxt = [DPred] + +-- | Corresponds to TH's @Pred@ +data DPred = DForallPr [DTyVarBndr] DCxt DPred + | DAppPr DPred DType + | DSigPr DPred DKind + | DVarPr Name + | DConPr Name + | DWildCardPr + deriving (Show, Typeable, Data, Generic) + +-- | Corresponds to TH's @TyVarBndr@ +data DTyVarBndr = DPlainTV Name + | DKindedTV Name DKind + deriving (Show, Typeable, Data, Generic) + +-- | Corresponds to TH's @Match@ type. +data DMatch = DMatch DPat DExp + deriving (Show, Typeable, Data, Generic) + +-- | Corresponds to TH's @Clause@ type. +data DClause = DClause [DPat] DExp + deriving (Show, Typeable, Data, Generic) + +-- | Declarations as used in a @let@ statement. +data DLetDec = DFunD Name [DClause] + | DValD DPat DExp + | DSigD Name DType + | DInfixD Fixity Name + | DPragmaD DPragma + deriving (Show, Typeable, Data, Generic) + +-- | Is it a @newtype@ or a @data@ type? +data NewOrData = Newtype + | Data + deriving (Eq, Show, Typeable, Data, Generic) + +-- | Corresponds to TH's @Dec@ type. +data DDec = DLetDec DLetDec + | DDataD NewOrData DCxt Name [DTyVarBndr] (Maybe DKind) [DCon] [DDerivClause] + | DTySynD Name [DTyVarBndr] DType + | DClassD DCxt Name [DTyVarBndr] [FunDep] [DDec] + | DInstanceD (Maybe Overlap) DCxt DType [DDec] + | DForeignD DForeign + | DOpenTypeFamilyD DTypeFamilyHead + | DClosedTypeFamilyD DTypeFamilyHead [DTySynEqn] + | DDataFamilyD Name [DTyVarBndr] (Maybe DKind) + | DDataInstD NewOrData DCxt Name [DType] (Maybe DKind) [DCon] [DDerivClause] + | DTySynInstD Name DTySynEqn + | DRoleAnnotD Name [Role] + | DStandaloneDerivD (Maybe DDerivStrategy) DCxt DType + | DDefaultSigD Name DType + | DPatSynD Name PatSynArgs DPatSynDir DPat + | DPatSynSigD Name DPatSynType + deriving (Show, Typeable, Data, Generic) + +#if __GLASGOW_HASKELL__ < 711 +data Overlap = Overlappable | Overlapping | Overlaps | Incoherent + deriving (Eq, Ord, Show, Typeable, Data, Generic) +#endif + +-- | Corresponds to TH's 'PatSynDir' type +data DPatSynDir = DUnidir -- ^ @pattern P x {<-} p@ + | DImplBidir -- ^ @pattern P x {=} p@ + | DExplBidir [DClause] -- ^ @pattern P x {<-} p where P x = e@ + deriving (Show, Typeable, Data, Generic) + +-- | Corresponds to TH's 'PatSynType' type +type DPatSynType = DType + +#if __GLASGOW_HASKELL__ < 801 +-- | Same as @PatSynArgs@ from TH; defined here for backwards compatibility. +data PatSynArgs + = PrefixPatSyn [Name] -- ^ @pattern P {x y z} = p@ + | InfixPatSyn Name Name -- ^ @pattern {x P y} = p@ + | RecordPatSyn [Name] -- ^ @pattern P { {x,y,z} } = p@ + deriving (Show, Typeable, Data, Generic) +#endif + +-- | Corresponds to TH's 'TypeFamilyHead' type +data DTypeFamilyHead = DTypeFamilyHead Name [DTyVarBndr] DFamilyResultSig + (Maybe InjectivityAnn) + deriving (Show, Typeable, Data, Generic) + +-- | Corresponds to TH's 'FamilyResultSig' type +data DFamilyResultSig = DNoSig + | DKindSig DKind + | DTyVarSig DTyVarBndr + deriving (Show, Typeable, Data, Generic) + +#if __GLASGOW_HASKELL__ <= 710 +data InjectivityAnn = InjectivityAnn Name [Name] + deriving (Eq, Ord, Show, Typeable, Data, Generic) +#endif + +-- | Corresponds to TH's 'Con' type. Unlike 'Con', all 'DCon's reflect GADT +-- syntax. This is beneficial for @th-desugar@'s since it means +-- that all data type declarations can support explicit return kinds, so +-- one does not need to represent them with something like @'Maybe' 'DKind'@, +-- since Haskell98-style data declaration syntax isn't used. Accordingly, +-- there are some differences between 'DCon' and 'Con' to keep in mind: +-- +-- * Unlike 'ForallC', where the meaning of the 'TyVarBndr's changes depending +-- on whether it's followed by 'GadtC'/'RecGadtC' or not, the meaning of the +-- 'DTyVarBndr's in a 'DCon' is always the same: it is the list of +-- universally /and/ existentially quantified type variables. Note that it is +-- not guaranteed that one set of type variables will appear before the +-- other. +-- +-- * A 'DCon' always has an explicit return type. +data DCon = DCon [DTyVarBndr] DCxt Name DConFields + DType -- ^ The GADT result type + deriving (Show, Typeable, Data, Generic) + +-- | A list of fields either for a standard data constructor or a record +-- data constructor. +data DConFields = DNormalC DDeclaredInfix [DBangType] + | DRecC [DVarBangType] + deriving (Show, Typeable, Data, Generic) + +-- | 'True' if a constructor is declared infix. For normal ADTs, this means +-- that is was written in infix style. For example, both of the constructors +-- below are declared infix. +-- +-- @ +-- data Infix = Int `Infix` Int | Int :*: Int +-- @ +-- +-- Whereas neither of these constructors are declared infix: +-- +-- @ +-- data Prefix = Prefix Int Int | (:+:) Int Int +-- @ +-- +-- For GADTs, detecting whether a constructor is declared infix is a bit +-- trickier, as one cannot write a GADT constructor "infix-style" like one +-- can for normal ADT constructors. GHC considers a GADT constructor to be +-- declared infix if it meets the following three criteria: +-- +-- 1. Its name uses operator syntax (e.g., @(:*:)@). +-- 2. It has exactly two fields (without record syntax). +-- 3. It has a programmer-specified fixity declaration. +-- +-- For example, in the following GADT: +-- +-- @ +-- infixl 5 :**:, :&&:, :^^:, `ActuallyPrefix` +-- data InfixGADT a where +-- (:**:) :: Int -> b -> InfixGADT (Maybe b) -- Only this one is infix +-- ActuallyPrefix :: Char -> Bool -> InfixGADT Double +-- (:&&:) :: { infixGADT1 :: b, infixGADT2 :: Int } -> InfixGADT [b] +-- (:^^:) :: Int -> Int -> Int -> InfixGADT Int +-- (:!!:) :: Char -> Char -> InfixGADT Char +-- @ +-- +-- Only the @(:**:)@ constructor is declared infix. The other constructors +-- are not declared infix, because: +-- +-- * @ActuallyPrefix@ does not use operator syntax (criterion 1). +-- * @(:&&:)@ uses record syntax (criterion 2). +-- * @(:^^:)@ does not have exactly two fields (criterion 2). +-- * @(:!!:)@ does not have a programmer-specified fixity declaration (criterion 3). +type DDeclaredInfix = Bool + +-- | Corresponds to TH's @BangType@ type. +type DBangType = (Bang, DType) + +-- | Corresponds to TH's @VarBangType@ type. +type DVarBangType = (Name, Bang, DType) + +#if __GLASGOW_HASKELL__ <= 710 +-- | Corresponds to TH's definition +data SourceUnpackedness = NoSourceUnpackedness + | SourceNoUnpack + | SourceUnpack + deriving (Eq, Ord, Show, Typeable, Data, Generic) + +-- | Corresponds to TH's definition +data SourceStrictness = NoSourceStrictness + | SourceLazy + | SourceStrict + deriving (Eq, Ord, Show, Typeable, Data, Generic) + +-- | Corresponds to TH's definition +data Bang = Bang SourceUnpackedness SourceStrictness + deriving (Eq, Ord, Show, Typeable, Data, Generic) +#endif + +-- | Corresponds to TH's @Foreign@ type. +data DForeign = DImportF Callconv Safety String Name DType + | DExportF Callconv String Name DType + deriving (Show, Typeable, Data, Generic) + +-- | Corresponds to TH's @Pragma@ type. +data DPragma = DInlineP Name Inline RuleMatch Phases + | DSpecialiseP Name DType (Maybe Inline) Phases + | DSpecialiseInstP DType + | DRuleP String [DRuleBndr] DExp DExp Phases + | DAnnP AnnTarget DExp + | DLineP Int String + | DCompleteP [Name] (Maybe Name) + deriving (Show, Typeable, Data, Generic) + +-- | Corresponds to TH's @RuleBndr@ type. +data DRuleBndr = DRuleVar Name + | DTypedRuleVar Name DType + deriving (Show, Typeable, Data, Generic) + +-- | Corresponds to TH's @TySynEqn@ type (to store type family equations). +data DTySynEqn = DTySynEqn [DType] DType + deriving (Show, Typeable, Data, Generic) + +#if __GLASGOW_HASKELL__ < 707 +-- | Same as @Role@ from TH; defined here for GHC 7.6.3 compatibility. +data Role = NominalR | RepresentationalR | PhantomR | InferR + deriving (Show, Typeable, Data, Generic) + +-- | Same as @AnnTarget@ from TH; defined here for GHC 7.6.3 compatibility. +data AnnTarget = ModuleAnnotation + | TypeAnnotation Name + | ValueAnnotation Name + deriving (Show, Typeable, Data, Generic) +#endif + +-- | Corresponds to TH's @Info@ type. +data DInfo = DTyConI DDec (Maybe [DInstanceDec]) + | DVarI Name DType (Maybe Name) + -- ^ The @Maybe Name@ stores the name of the enclosing definition + -- (datatype, for a data constructor; class, for a method), + -- if any + | DTyVarI Name DKind + | DPrimTyConI Name Int Bool + -- ^ The @Int@ is the arity; the @Bool@ is whether this tycon + -- is unlifted. + | DPatSynI Name DPatSynType + deriving (Show, Typeable, Data, Generic) + +type DInstanceDec = DDec -- ^ Guaranteed to be an instance declaration + +-- | Corresponds to TH's @DerivClause@ type. +data DDerivClause = DDerivClause (Maybe DDerivStrategy) DCxt + deriving (Show, Typeable, Data, Generic) + +-- | Corresponds to TH's @DerivStrategy@ type. +data DDerivStrategy = DStockStrategy -- ^ A \"standard\" derived instance + | DAnyclassStrategy -- ^ @-XDeriveAnyClass@ + | DNewtypeStrategy -- ^ @-XGeneralizedNewtypeDeriving@ + | DViaStrategy DType -- ^ @-XDerivingVia@ + deriving (Show, Typeable, Data, Generic) diff --git a/Language/Haskell/TH/Desugar/Core.hs b/Language/Haskell/TH/Desugar/Core.hs --- a/Language/Haskell/TH/Desugar/Core.hs +++ b/Language/Haskell/TH/Desugar/Core.hs @@ -7,8 +7,7 @@ processing. The desugared types and constructors are prefixed with a D. -} -{-# LANGUAGE TemplateHaskell, LambdaCase, CPP, DeriveDataTypeable, - DeriveGeneric, TupleSections #-} +{-# LANGUAGE TemplateHaskell, LambdaCase, CPP, ScopedTypeVariables, TupleSections #-} module Language.Haskell.TH.Desugar.Core where @@ -21,17 +20,23 @@ #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif -import Control.Monad hiding (mapM) +import Control.Monad hiding (forM_, mapM) import Control.Monad.Zip -import Control.Monad.Writer hiding (mapM) +import Control.Monad.Writer hiding (forM_, mapM) import Data.Foldable hiding (notElem) +import Data.Graph +import qualified Data.Map as Map +import Data.Map (Map) +import qualified Data.Set as Set import Data.Traversable -import Data.Data hiding (Fixity) #if __GLASGOW_HASKELL__ > 710 import Data.Maybe (isJust) #endif -import GHC.Generics hiding (Fixity) +#if __GLASGOW_HASKELL__ >= 800 +import qualified Control.Monad.Fail as MonadFail +#endif + #if __GLASGOW_HASKELL__ >= 803 import GHC.OverloadedLabels ( fromLabel ) #endif @@ -39,286 +44,10 @@ import qualified Data.Set as S import GHC.Exts +import Language.Haskell.TH.Desugar.AST import Language.Haskell.TH.Desugar.Util import Language.Haskell.TH.Desugar.Reify --- | Corresponds to TH's @Exp@ type. Note that @DLamE@ takes names, not patterns. -data DExp = DVarE Name - | DConE Name - | DLitE Lit - | DAppE DExp DExp - | DAppTypeE DExp DType - | DLamE [Name] DExp - | DCaseE DExp [DMatch] - | DLetE [DLetDec] DExp - | DSigE DExp DType - | DStaticE DExp - deriving (Show, Typeable, Data, Generic) - - --- | Corresponds to TH's @Pat@ type. -data DPat = DLitPa Lit - | DVarPa Name - | DConPa Name [DPat] - | DTildePa DPat - | DBangPa DPat - | DSigPa DPat DType - | DWildPa - deriving (Show, Typeable, Data, Generic) - --- | Corresponds to TH's @Type@ type, used to represent --- types and kinds. -data DType = DForallT [DTyVarBndr] DCxt DType - | DAppT DType DType - | DSigT DType DKind - | DVarT Name - | DConT Name - | DArrowT - | DLitT TyLit - | DWildCardT - | DStarT - deriving (Show, Typeable, Data, Generic) - --- | Kinds are types. -type DKind = DType - --- | Corresponds to TH's @Cxt@ -type DCxt = [DPred] - --- | Corresponds to TH's @Pred@ -data DPred = DAppPr DPred DType - | DSigPr DPred DKind - | DVarPr Name - | DConPr Name - | DWildCardPr - deriving (Show, Typeable, Data, Generic) - --- | Corresponds to TH's @TyVarBndr@ -data DTyVarBndr = DPlainTV Name - | DKindedTV Name DKind - deriving (Show, Typeable, Data, Generic) - --- | Corresponds to TH's @Match@ type. -data DMatch = DMatch DPat DExp - deriving (Show, Typeable, Data, Generic) - --- | Corresponds to TH's @Clause@ type. -data DClause = DClause [DPat] DExp - deriving (Show, Typeable, Data, Generic) - --- | Declarations as used in a @let@ statement. -data DLetDec = DFunD Name [DClause] - | DValD DPat DExp - | DSigD Name DType - | DInfixD Fixity Name - | DPragmaD DPragma - deriving (Show, Typeable, Data, Generic) - --- | Is it a @newtype@ or a @data@ type? -data NewOrData = Newtype - | Data - deriving (Eq, Show, Typeable, Data, Generic) - --- | Corresponds to TH's @Dec@ type. -data DDec = DLetDec DLetDec - | DDataD NewOrData DCxt Name [DTyVarBndr] [DCon] [DDerivClause] - | DTySynD Name [DTyVarBndr] DType - | DClassD DCxt Name [DTyVarBndr] [FunDep] [DDec] - | DInstanceD (Maybe Overlap) DCxt DType [DDec] - | DForeignD DForeign - | DOpenTypeFamilyD DTypeFamilyHead - | DClosedTypeFamilyD DTypeFamilyHead [DTySynEqn] - | DDataFamilyD Name [DTyVarBndr] - | DDataInstD NewOrData DCxt Name [DType] [DCon] [DDerivClause] - | DTySynInstD Name DTySynEqn - | DRoleAnnotD Name [Role] - | DStandaloneDerivD (Maybe DerivStrategy) DCxt DType - | DDefaultSigD Name DType - | DPatSynD Name PatSynArgs DPatSynDir DPat - | DPatSynSigD Name DPatSynType - deriving (Show, Typeable, Data, Generic) - -#if __GLASGOW_HASKELL__ < 711 -data Overlap = Overlappable | Overlapping | Overlaps | Incoherent - deriving (Eq, Ord, Show, Typeable, Data, Generic) -#endif - --- | Corresponds to TH's 'PatSynDir' type -data DPatSynDir = DUnidir -- ^ @pattern P x {<-} p@ - | DImplBidir -- ^ @pattern P x {=} p@ - | DExplBidir [DClause] -- ^ @pattern P x {<-} p where P x = e@ - deriving (Show, Typeable, Data, Generic) - --- | Corresponds to TH's 'PatSynType' type -type DPatSynType = DType - -#if __GLASGOW_HASKELL__ < 801 --- | Same as @PatSynArgs@ from TH; defined here for backwards compatibility. -data PatSynArgs - = PrefixPatSyn [Name] -- ^ @pattern P {x y z} = p@ - | InfixPatSyn Name Name -- ^ @pattern {x P y} = p@ - | RecordPatSyn [Name] -- ^ @pattern P { {x,y,z} } = p@ - deriving (Show, Typeable, Data, Generic) -#endif - --- | Corresponds to TH's 'TypeFamilyHead' type -data DTypeFamilyHead = DTypeFamilyHead Name [DTyVarBndr] DFamilyResultSig - (Maybe InjectivityAnn) - deriving (Show, Typeable, Data, Generic) - --- | Corresponds to TH's 'FamilyResultSig' type -data DFamilyResultSig = DNoSig - | DKindSig DKind - | DTyVarSig DTyVarBndr - deriving (Show, Typeable, Data, Generic) - -#if __GLASGOW_HASKELL__ <= 710 -data InjectivityAnn = InjectivityAnn Name [Name] - deriving (Eq, Ord, Show, Typeable, Data, Generic) -#endif - --- | Corresponds to TH's @Con@ type. -data DCon = DCon [DTyVarBndr] DCxt Name DConFields - (Maybe DType) -- ^ A GADT result type, if there is one - deriving (Show, Typeable, Data, Generic) - --- | A list of fields either for a standard data constructor or a record --- data constructor. -data DConFields = DNormalC DDeclaredInfix [DBangType] - | DRecC [DVarBangType] - deriving (Show, Typeable, Data, Generic) - --- | 'True' if a constructor is declared infix. For normal ADTs, this means --- that is was written in infix style. For example, both of the constructors --- below are declared infix. --- --- @ --- data Infix = Int `Infix` Int | Int :*: Int --- @ --- --- Whereas neither of these constructors are declared infix: --- --- @ --- data Prefix = Prefix Int Int | (:+:) Int Int --- @ --- --- For GADTs, detecting whether a constructor is declared infix is a bit --- trickier, as one cannot write a GADT constructor "infix-style" like one --- can for normal ADT constructors. GHC considers a GADT constructor to be --- declared infix if it meets the following three criteria: --- --- 1. Its name uses operator syntax (e.g., @(:*:)@). --- 2. It has exactly two fields (without record syntax). --- 3. It has a programmer-specified fixity declaration. --- --- For example, in the following GADT: --- --- @ --- infixl 5 :**:, :&&:, :^^:, `ActuallyPrefix` --- data InfixGADT a where --- (:**:) :: Int -> b -> InfixGADT (Maybe b) -- Only this one is infix --- ActuallyPrefix :: Char -> Bool -> InfixGADT Double --- (:&&:) :: { infixGADT1 :: b, infixGADT2 :: Int } -> InfixGADT [b] --- (:^^:) :: Int -> Int -> Int -> InfixGADT Int --- (:!!:) :: Char -> Char -> InfixGADT Char --- @ --- --- Only the @(:**:)@ constructor is declared infix. The other constructors --- are not declared infix, because: --- --- * @ActuallyPrefix@ does not use operator syntax (criterion 1). --- * @(:&&:)@ uses record syntax (criterion 2). --- * @(:^^:)@ does not have exactly two fields (criterion 2). --- * @(:!!:)@ does not have a programmer-specified fixity declaration (criterion 3). -type DDeclaredInfix = Bool - --- | Corresponds to TH's @BangType@ type. -type DBangType = (Bang, DType) - --- | Corresponds to TH's @VarBangType@ type. -type DVarBangType = (Name, Bang, DType) - -#if __GLASGOW_HASKELL__ <= 710 --- | Corresponds to TH's definition -data SourceUnpackedness = NoSourceUnpackedness - | SourceNoUnpack - | SourceUnpack - deriving (Eq, Ord, Show, Typeable, Data, Generic) - --- | Corresponds to TH's definition -data SourceStrictness = NoSourceStrictness - | SourceLazy - | SourceStrict - deriving (Eq, Ord, Show, Typeable, Data, Generic) - --- | Corresponds to TH's definition -data Bang = Bang SourceUnpackedness SourceStrictness - deriving (Eq, Ord, Show, Typeable, Data, Generic) -#endif - --- | Corresponds to TH's @Foreign@ type. -data DForeign = DImportF Callconv Safety String Name DType - | DExportF Callconv String Name DType - deriving (Show, Typeable, Data, Generic) - --- | Corresponds to TH's @Pragma@ type. -data DPragma = DInlineP Name Inline RuleMatch Phases - | DSpecialiseP Name DType (Maybe Inline) Phases - | DSpecialiseInstP DType - | DRuleP String [DRuleBndr] DExp DExp Phases - | DAnnP AnnTarget DExp - | DLineP Int String - | DCompleteP [Name] (Maybe Name) - deriving (Show, Typeable, Data, Generic) - --- | Corresponds to TH's @RuleBndr@ type. -data DRuleBndr = DRuleVar Name - | DTypedRuleVar Name DType - deriving (Show, Typeable, Data, Generic) - --- | Corresponds to TH's @TySynEqn@ type (to store type family equations). -data DTySynEqn = DTySynEqn [DType] DType - deriving (Show, Typeable, Data, Generic) - -#if __GLASGOW_HASKELL__ < 707 --- | Same as @Role@ from TH; defined here for GHC 7.6.3 compatibility. -data Role = NominalR | RepresentationalR | PhantomR | InferR - deriving (Show, Typeable, Data, Generic) - --- | Same as @AnnTarget@ from TH; defined here for GHC 7.6.3 compatibility. -data AnnTarget = ModuleAnnotation - | TypeAnnotation Name - | ValueAnnotation Name - deriving (Show, Typeable, Data, Generic) -#endif - --- | Corresponds to TH's @Info@ type. -data DInfo = DTyConI DDec (Maybe [DInstanceDec]) - | DVarI Name DType (Maybe Name) - -- ^ The @Maybe Name@ stores the name of the enclosing definition - -- (datatype, for a data constructor; class, for a method), - -- if any - | DTyVarI Name DKind - | DPrimTyConI Name Int Bool - -- ^ The @Int@ is the arity; the @Bool@ is whether this tycon - -- is unlifted. - | DPatSynI Name DPatSynType - deriving (Show, Typeable, Data, Generic) - -type DInstanceDec = DDec -- ^ Guaranteed to be an instance declaration - --- | Corresponds to TH's @DerivClause@ type. -data DDerivClause = DDerivClause (Maybe DerivStrategy) DCxt - deriving (Show, Typeable, Data, Generic) - -#if __GLASGOW_HASKELL__ < 801 --- | Same as @DerivStrategy@ from TH; defined here for backwards compatibility. -data DerivStrategy = StockStrategy -- ^ A \"standard\" derived instance - | AnyclassStrategy -- ^ @-XDeriveAnyClass@ - | NewtypeStrategy -- ^ @-XGeneralizedNewtypeDeriving@ - deriving (Show, Typeable, Data, Generic) -#endif - -- | Desugar an expression dsExp :: DsMonad q => Exp -> q DExp dsExp (VarE n) = return $ DVarE n @@ -395,7 +124,7 @@ RecGadtC _names fields _ret_ty -> reorder_fields fields #endif - reorder_fields fields = reorderFields fields field_exps + reorder_fields fields = reorderFields con_name fields field_exps (repeat $ DVarE 'undefined) non_record fields | null field_exps @@ -467,7 +196,7 @@ field_var_names <- mapM (newUniqueName . nameBase) con_field_names DMatch (DConPa con_name (map DVarPa field_var_names)) <$> (foldl DAppE (DConE con_name) <$> - (reorderFields args field_exps (map DVarE field_var_names))) + (reorderFields con_name args field_exps (map DVarE field_var_names))) con_to_dmatch :: DsMonad q => Con -> q DMatch con_to_dmatch (RecC con_name args) = rec_con_to_dmatch con_name args @@ -500,13 +229,36 @@ -- | Desugar a lambda expression, where the body has already been desugared dsLam :: DsMonad q => [Pat] -> DExp -> q DExp -dsLam pats exp - | Just names <- mapM stripVarP_maybe pats +dsLam = mkLam stripVarP_maybe dsPatsOverExp + +-- | Convert a list of 'DPat' arguments and a 'DExp' body into a 'DLamE'. This +-- is needed since 'DLamE' takes a list of 'Name's for its bound variables +-- instead of 'DPat's, so some reorganization is needed. +mkDLamEFromDPats :: DsMonad q => [DPat] -> DExp -> q DExp +mkDLamEFromDPats = mkLam stripDVarPa_maybe (\pats exp -> return (pats, exp)) + where + stripDVarPa_maybe :: DPat -> Maybe Name + stripDVarPa_maybe (DVarPa n) = Just n + stripDVarPa_maybe _ = Nothing + +-- | Generalizes 'dsLam' and 'mkDLamEFromDPats' to work over an arbitrary +-- pattern type. +mkLam :: DsMonad q + => (pat -> Maybe Name) -- ^ Should return @'Just' n@ if the argument is a + -- variable pattern, and 'Nothing' otherwise. + -> ([pat] -> DExp -> q ([DPat], DExp)) + -- ^ Should process a list of @pat@ arguments and + -- a 'DExp' body. (This might do some internal + -- reorganization if there are as-patterns, as + -- in the case of 'dsPatsOverExp'.) + -> [pat] -> DExp -> q DExp +mkLam mb_strip_var_pat process_pats_over_exp pats exp + | Just names <- mapM mb_strip_var_pat pats = return $ DLamE names exp | otherwise = do arg_names <- replicateM (length pats) (newUniqueName "arg") let scrutinee = mkTupleDExp (map DVarE arg_names) - (pats', exp') <- dsPatsOverExp pats exp + (pats', exp') <- process_pats_over_exp pats exp let match = DMatch (mkTupleDPat pats') exp' return $ DLamE arg_names (DCaseE scrutinee [match]) @@ -601,9 +353,8 @@ dsDoStmts [] = impossible "do-expression ended with something other than bare statement." dsDoStmts [NoBindS exp] = dsExp exp dsDoStmts (BindS pat exp : rest) = do - exp' <- dsExp exp rest' <- dsDoStmts rest - DAppE (DAppE (DVarE '(>>=)) exp') <$> dsLam [pat] rest' + dsBindS exp pat rest' "do expression" dsDoStmts (LetS decs : rest) = DLetE <$> dsLetDecs decs <*> dsDoStmts rest dsDoStmts (NoBindS exp : rest) = do exp' <- dsExp exp @@ -616,9 +367,8 @@ dsComp [] = impossible "List/monad comprehension ended with something other than a bare statement." dsComp [NoBindS exp] = DAppE (DVarE 'return) <$> dsExp exp dsComp (BindS pat exp : rest) = do - exp' <- dsExp exp rest' <- dsComp rest - DAppE (DAppE (DVarE '(>>=)) exp') <$> dsLam [pat] rest' + dsBindS exp pat rest' "monad comprehension" dsComp (LetS decs : rest) = DLetE <$> dsLetDecs decs <*> dsComp rest dsComp (NoBindS exp : rest) = do exp' <- dsExp exp @@ -629,6 +379,39 @@ rest' <- dsComp rest DAppE (DAppE (DVarE '(>>=)) exp) <$> dsLam [pat] rest' +-- Desugar a binding statement in a do- or list comprehension. +-- +-- In the event that the pattern in the statement is partial, the desugared +-- case expression will contain a catch-all case that calls 'fail' from either +-- 'MonadFail' or 'Monad', depending on whether the @MonadFailDesugaring@ +-- language extension is enabled or not. (On GHCs older than 8.0, 'fail' from +-- 'Monad' is always used.) +dsBindS :: forall q. DsMonad q => Exp -> Pat -> DExp -> String -> q DExp +dsBindS bind_arg_exp success_pat success_exp ctxt = do + bind_arg_exp' <- dsExp bind_arg_exp + (success_pat', success_exp') <- dsPatOverExp success_pat success_exp + is_univ_pat <- isUniversalPattern success_pat' + let bind_into = DAppE (DAppE (DVarE '(>>=)) bind_arg_exp') + if is_univ_pat + then bind_into <$> mkDLamEFromDPats [success_pat'] success_exp' + else do arg_name <- newUniqueName "arg" + fail_name <- mk_fail_name + return $ bind_into $ DLamE [arg_name] $ DCaseE (DVarE arg_name) + [ DMatch success_pat' success_exp' + , DMatch DWildPa $ + DVarE fail_name `DAppE` + DLitE (StringL $ "Pattern match failure in " ++ ctxt) + ] + where + mk_fail_name :: q Name +#if __GLASGOW_HASKELL__ >= 800 + mk_fail_name = do + mfd <- qIsExtEnabled MonadFailDesugaring + return $ if mfd then 'MonadFail.fail else 'Prelude.fail +#else + mk_fail_name = return 'Prelude.fail +#endif + -- | Desugar the contents of a parallel comprehension. -- Returns a @Pat@ containing a tuple of all bound variables and an expression -- to produce the values for those variables @@ -715,7 +498,7 @@ RecGadtC _names fields _ret_ty -> reorder_fields_pat fields #endif - reorder_fields_pat fields = reorderFieldsPat fields field_pats + reorder_fields_pat fields = reorderFieldsPat con_name fields field_pats non_record fields | null field_pats -- Special case: record patterns are allowed for any @@ -827,7 +610,7 @@ eqns' = map (fixBug8884ForEqn num_args) eqns frs' <- remove_arrows num_args frs return (DClosedTypeFamilyD (DTypeFamilyHead name tvbs frs' ann) eqns', num_args) -fixBug8884ForFamilies dec@(DDataFamilyD _ _) +fixBug8884ForFamilies dec@(DDataFamilyD _ _ _) = return (dec, 0) -- the num_args is ignored for data families fixBug8884ForFamilies dec = impossible $ "Reifying yielded a FamilyI with a non-family Dec: " ++ show dec @@ -872,25 +655,35 @@ dsDec d@(ValD {}) = (fmap . map) DLetDec $ dsLetDec d #if __GLASGOW_HASKELL__ > 710 dsDec (DataD cxt n tvbs mk cons derivings) = do - extra_tvbs <- mkExtraTvbs tvbs mk + tvbs' <- mapM dsTvb tvbs + all_tvbs <- nonFamilyDataTvbs tvbs' mk + let data_type = nonFamilyDataReturnType n all_tvbs (:[]) <$> (DDataD Data <$> dsCxt cxt <*> pure n - <*> ((++ extra_tvbs) <$> mapM dsTvb tvbs) - <*> concatMapM dsCon cons + <*> pure tvbs' <*> mapM dsType mk + <*> concatMapM (dsCon tvbs' data_type) cons <*> mapM dsDerivClause derivings) dsDec (NewtypeD cxt n tvbs mk con derivings) = do - extra_tvbs <- mkExtraTvbs tvbs mk + tvbs' <- mapM dsTvb tvbs + all_tvbs <- nonFamilyDataTvbs tvbs' mk + let data_type = nonFamilyDataReturnType n all_tvbs (:[]) <$> (DDataD Newtype <$> dsCxt cxt <*> pure n - <*> ((++ extra_tvbs) <$> mapM dsTvb tvbs) - <*> dsCon con + <*> pure tvbs' <*> mapM dsType mk + <*> dsCon tvbs' data_type con <*> mapM dsDerivClause derivings) #else -dsDec (DataD cxt n tvbs cons derivings) = +dsDec (DataD cxt n tvbs cons derivings) = do + tvbs' <- mapM dsTvb tvbs + let data_type = nonFamilyDataReturnType n tvbs' (:[]) <$> (DDataD Data <$> dsCxt cxt <*> pure n - <*> mapM dsTvb tvbs <*> concatMapM dsCon cons + <*> pure tvbs' <*> pure Nothing + <*> concatMapM (dsCon tvbs' data_type) cons <*> mapM dsDerivClause derivings) -dsDec (NewtypeD cxt n tvbs con derivings) = +dsDec (NewtypeD cxt n tvbs con derivings) = do + tvbs' <- mapM dsTvb tvbs + let data_type = nonFamilyDataReturnType n tvbs' (:[]) <$> (DDataD Newtype <$> dsCxt cxt <*> pure n - <*> mapM dsTvb tvbs <*> dsCon con + <*> pure tvbs' <*> pure Nothing + <*> dsCon tvbs' data_type con <*> mapM dsDerivClause derivings) #endif dsDec (TySynD n tvbs ty) = @@ -912,37 +705,50 @@ #if __GLASGOW_HASKELL__ > 710 dsDec (OpenTypeFamilyD tfHead) = (:[]) <$> (DOpenTypeFamilyD <$> dsTypeFamilyHead tfHead) -dsDec (DataFamilyD n tvbs m_k) = do - extra_tvbs <- mkExtraTvbs tvbs m_k - (:[]) <$> (DDataFamilyD n <$> ((++ extra_tvbs) <$> mapM dsTvb tvbs)) +dsDec (DataFamilyD n tvbs m_k) = + (:[]) <$> (DDataFamilyD n <$> mapM dsTvb tvbs <*> mapM dsType m_k) #else dsDec (FamilyD TypeFam n tvbs m_k) = do (:[]) <$> (DOpenTypeFamilyD <$> dsTypeFamilyHead n tvbs m_k) -dsDec (FamilyD DataFam n tvbs m_k) = do - extra_tvbs <- mkExtraTvbs tvbs m_k - (:[]) <$> (DDataFamilyD n <$> ((++ extra_tvbs) <$> mapM dsTvb tvbs)) +dsDec (FamilyD DataFam n tvbs m_k) = + (:[]) <$> (DDataFamilyD n <$> mapM dsTvb tvbs <*> mapM dsType m_k) #endif #if __GLASGOW_HASKELL__ > 710 dsDec (DataInstD cxt n tys mk cons derivings) = do - extra_tvbs <- map dTyVarBndrToDType <$> mkExtraTvbs [] mk + tys' <- mapM dsType tys + all_tys <- dataFamInstTypes tys' mk + let tvbs = dataFamInstTvbs all_tys + fam_inst_type = dataFamInstReturnType n all_tys (:[]) <$> (DDataInstD Data <$> dsCxt cxt <*> pure n - <*> ((++ extra_tvbs) <$> mapM dsType tys) - <*> concatMapM dsCon cons + <*> pure tys' <*> mapM dsType mk + <*> concatMapM (dsCon tvbs fam_inst_type) cons <*> mapM dsDerivClause derivings) dsDec (NewtypeInstD cxt n tys mk con derivings) = do - extra_tvbs <- map dTyVarBndrToDType <$> mkExtraTvbs [] mk + tys' <- mapM dsType tys + all_tys <- dataFamInstTypes tys' mk + let tvbs = dataFamInstTvbs all_tys + fam_inst_type = dataFamInstReturnType n all_tys (:[]) <$> (DDataInstD Newtype <$> dsCxt cxt <*> pure n - <*> ((++ extra_tvbs) <$> mapM dsType tys) - <*> dsCon con + <*> pure tys' <*> mapM dsType mk + <*> dsCon tvbs fam_inst_type con <*> mapM dsDerivClause derivings) #else dsDec (DataInstD cxt n tys cons derivings) = do - (:[]) <$> (DDataInstD Data <$> dsCxt cxt <*> pure n <*> mapM dsType tys - <*> concatMapM dsCon cons + tys' <- mapM dsType tys + let tvbs = dataFamInstTvbs tys' + fam_inst_type = dataFamInstReturnType n tys' + (:[]) <$> (DDataInstD Data <$> dsCxt cxt <*> pure n + <*> pure tys' <*> pure Nothing + <*> concatMapM (dsCon tvbs fam_inst_type) cons <*> mapM dsDerivClause derivings) dsDec (NewtypeInstD cxt n tys con derivings) = do - (:[]) <$> (DDataInstD Newtype <$> dsCxt cxt <*> pure n <*> mapM dsType tys - <*> dsCon con <*> mapM dsDerivClause derivings) + tys' <- mapM dsType tys + let tvbs = dataFamInstTvbs tys' + fam_inst_type = dataFamInstReturnType n tys' + (:[]) <$> (DDataInstD Newtype <$> dsCxt cxt <*> pure n + <*> pure tys' <*> pure Nothing + <*> dsCon tvbs fam_inst_type con + <*> mapM dsDerivClause derivings) #endif #if __GLASGOW_HASKELL__ < 707 dsDec (TySynInstD n lhs rhs) = (:[]) <$> (DTySynInstD n <$> @@ -971,7 +777,7 @@ return [DPatSynD n args dir' pat'] dsDec (PatSynSigD n ty) = (:[]) <$> (DPatSynSigD n <$> dsType ty) dsDec (StandaloneDerivD mds cxt ty) = - (:[]) <$> (DStandaloneDerivD mds <$> dsCxt cxt <*> dsType ty) + (:[]) <$> (DStandaloneDerivD <$> mapM dsDerivStrategy mds <*> dsCxt cxt <*> dsType ty) #else dsDec (StandaloneDerivD cxt ty) = (:[]) <$> (DStandaloneDerivD Nothing <$> dsCxt cxt <*> dsType ty) @@ -979,36 +785,16 @@ dsDec (DefaultSigD n ty) = (:[]) <$> (DDefaultSigD n <$> dsType ty) #endif -mkExtraTvbs :: DsMonad q => [TyVarBndr] -> Maybe Kind -> q [DTyVarBndr] -mkExtraTvbs _ Nothing = return [] -mkExtraTvbs orig_tvbs (Just k) = do - k' <- runQ (expandSyns k) -- just in case - dk <- dsType k' - let args = split_funs [] dk - -- christiaanb: I have no idea how GHC normally picks fresh - -- tyvars, this looks like something GHC might do. Though probably in a - -- nicer/safer way. - -- - -- RAE: It's actually not terribly far off from what GHC does. This is - -- terrible. But I don't see another way to do this. - -- - -- All of this is needed so that "dec test 9" passes. - orig_names = map (nameBase . tvbName) orig_tvbs - all_names = -#if __GLASGOW_HASKELL__ <= 708 - map ('$':) $ -#endif - take (length args + length orig_tvbs) - (map (:[]) ['a' .. 'z'] ++ - concatMap (zipWith (:) ['a' .. 'z'] . repeat . show) - [(0::Int)..]) - new_names = filter (`notElem` orig_names) all_names - names <- zipWithM (\n _ -> qNewName n) new_names args - return (zipWith DKindedTV names args) - where - split_funs args (DAppT (DAppT DArrowT arg) res) = split_funs (arg:args) res - split_funs args _other = reverse args +-- Like mkExtraDKindBinders, but accepts a Maybe Kind +-- argument instead of DKind. +mkExtraKindBinders :: DsMonad q => Maybe Kind -> q [DTyVarBndr] +mkExtraKindBinders = + maybe (pure (DConT typeKindName)) (runQ . expandSyns >=> dsType) >=> mkExtraDKindBinders' +-- | Like mkExtraDKindBinders, but assumes kind synonyms have been expanded. +mkExtraDKindBinders' :: Quasi q => DKind -> q [DTyVarBndr] +mkExtraDKindBinders' = mkExtraKindBindersGeneric unravel DKindedTV + #if __GLASGOW_HASKELL__ > 710 -- | Desugar a @FamilyResultSig@ dsFamilyResultSig :: DsMonad q => FamilyResultSig -> q DFamilyResultSig @@ -1060,24 +846,72 @@ dsLetDec _dec = impossible "Illegal declaration in let expression." -- | Desugar a single @Con@. +-- +-- Because we always desugar @Con@s to GADT syntax (see the documentation for +-- 'DCon'), it is not always possible to desugar with just a 'Con' alone. +-- For instance, we must desugar: +-- +-- @ +-- data Foo a = forall b. MkFoo b +-- @ +-- +-- To this: +-- +-- @ +-- data Foo a :: Type where +-- MkFoo :: forall a b. b -> Foo a +-- @ +-- +-- If our only argument was @forall b. MkFoo b@, it would be somewhat awkward +-- to figure out (1) what the set of universally quantified type variables +-- (@[a]@) was, and (2) what the return type (@Foo a@) was. For this reason, +-- we require passing these as arguments. (If we desugar an actual GADT +-- constructor, these arguments are ignored.) dsCon :: DsMonad q - => Con -> q [DCon] -dsCon (NormalC n stys) = - (:[]) <$> (DCon [] [] n <$> (DNormalC False <$> mapM dsBangType stys) <*> pure Nothing) -dsCon (RecC n vstys) = - (:[]) <$> (DCon [] [] n <$> (DRecC <$> mapM dsVarBangType vstys) <*> pure Nothing) -dsCon (InfixC sty1 n sty2) = do + => [DTyVarBndr] -- ^ The universally quantified type variables + -- (used if desugaring a non-GADT constructor). + -> DType -- ^ The original data declaration's type + -- (used if desugaring a non-GADT constructor). + -> Con -> q [DCon] +dsCon univ_dtvbs data_type con = do + dcons' <- dsCon' con + return $ flip map dcons' $ \(n, dtvbs, dcxt, fields, m_gadt_type) -> + case m_gadt_type of + Nothing -> + let ex_dtvbs = dtvbs in + DCon (univ_dtvbs ++ ex_dtvbs) dcxt n fields data_type + Just gadt_type -> + let univ_ex_dtvbs = dtvbs in + DCon univ_ex_dtvbs dcxt n fields gadt_type + +-- Desugar a Con in isolation. The meaning of the returned DTyVarBndrs changes +-- depending on what the returned Maybe DType value is: +-- +-- * If returning Just gadt_ty, then we've encountered a GadtC or RecGadtC, +-- so the returned DTyVarBndrs are both the universally and existentially +-- quantified tyvars. +-- * If returning Nothing, we're dealing with a non-GADT constructor, so +-- the returned DTyVarBndrs are the existentials only. +dsCon' :: DsMonad q + => Con -> q [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)] +dsCon' (NormalC n stys) = do + dtys <- mapM dsBangType stys + return [(n, [], [], DNormalC False dtys, Nothing)] +dsCon' (RecC n vstys) = do + vdtys <- mapM dsVarBangType vstys + return [(n, [], [], DRecC vdtys, Nothing)] +dsCon' (InfixC sty1 n sty2) = do dty1 <- dsBangType sty1 dty2 <- dsBangType sty2 - return $ [DCon [] [] n (DNormalC True [dty1, dty2]) Nothing] -dsCon (ForallC tvbs cxt con) = do + return [(n, [], [], DNormalC True [dty1, dty2], Nothing)] +dsCon' (ForallC tvbs cxt con) = do dtvbs <- mapM dsTvb tvbs dcxt <- dsCxt cxt - dcons <- dsCon con - return $ flip map dcons $ \(DCon dtvbs' dcxt' n fields m_kind) -> - DCon (dtvbs ++ dtvbs') (dcxt ++ dcxt') n fields m_kind + dcons' <- dsCon' con + return $ flip map dcons' $ \(n, dtvbs', dcxt', fields, m_gadt_type) -> + (n, dtvbs ++ dtvbs', dcxt ++ dcxt', fields, m_gadt_type) #if __GLASGOW_HASKELL__ > 710 -dsCon (GadtC nms btys rty) = do +dsCon' (GadtC nms btys rty) = do dbtys <- mapM dsBangType btys drty <- dsType rty sequence $ flip map nms $ \nm -> do @@ -1089,12 +923,12 @@ || length dbtys == 2 -- 2. It has exactly two fields || isJust mbFi -- 3. It has a programmer-specified -- fixity declaration - return $ DCon [] [] nm (DNormalC decInfix dbtys) (Just drty) -dsCon (RecGadtC nms vbtys rty) = do + return (nm, [], [], DNormalC decInfix dbtys, Just drty) +dsCon' (RecGadtC nms vbtys rty) = do dvbtys <- mapM dsVarBangType vbtys drty <- dsType rty return $ flip map nms $ \nm -> - DCon [] [] nm (DRecC dvbtys) (Just drty) + (nm, [], [], DRecC dvbtys, Just drty) #endif #if __GLASGOW_HASKELL__ > 710 @@ -1204,7 +1038,7 @@ dsType (PromotedTupleT n) = return $ DConT (tupleDataName n) dsType PromotedNilT = return $ DConT '[] dsType PromotedConsT = return $ DConT '(:) -dsType StarT = return DStarT +dsType StarT = return $ DConT typeKindName dsType ConstraintT = return $ DConT ''Constraint dsType (LitT lit) = return $ DLitT lit #if __GLASGOW_HASKELL__ >= 709 @@ -1232,7 +1066,8 @@ #if __GLASGOW_HASKELL__ >= 801 -- | Desugar a @DerivClause@. dsDerivClause :: DsMonad q => DerivClause -> q DDerivClause -dsDerivClause (DerivClause mds cxt) = DDerivClause mds <$> dsCxt cxt +dsDerivClause (DerivClause mds cxt) = + DDerivClause <$> mapM dsDerivStrategy mds <*> dsCxt cxt #elif __GLASGOW_HASKELL__ >= 711 dsDerivClause :: DsMonad q => Pred -> q DDerivClause dsDerivClause p = DDerivClause Nothing <$> dsPred p @@ -1242,6 +1077,17 @@ #endif #if __GLASGOW_HASKELL__ >= 801 +-- | Desugar a @DerivStrategy@. +dsDerivStrategy :: DsMonad q => DerivStrategy -> q DDerivStrategy +dsDerivStrategy StockStrategy = pure DStockStrategy +dsDerivStrategy AnyclassStrategy = pure DAnyclassStrategy +dsDerivStrategy NewtypeStrategy = pure DNewtypeStrategy +#if __GLASGOW_HASKELL__ >= 805 +dsDerivStrategy (ViaStrategy ty) = DViaStrategy <$> dsType ty +#endif +#endif + +#if __GLASGOW_HASKELL__ >= 801 -- | Desugar a @PatSynDir@. (Available only with GHC 8.2+) dsPatSynDir :: DsMonad q => Name -> PatSynDir -> q DPatSynDir dsPatSynDir _ Unidir = pure DUnidir @@ -1262,7 +1108,12 @@ dsPred t | Just ts <- splitTuple_maybe t = concatMapM dsPred ts -dsPred t@(ForallT _ _ _) = impossible $ "Forall seen in constraint: " ++ show t +dsPred (ForallT tvbs cxt p) = do + ps' <- dsPred p + case ps' of + [p'] -> (:[]) <$> (DForallPr <$> mapM dsTvb tvbs <*> dsCxt cxt <*> pure p') + _ -> fail "Cannot desugar constraint tuples in the body of a quantified constraint" + -- See Trac #15334. dsPred (AppT t1 t2) = do [p1] <- dsPred t1 -- tuples can't be applied! (:[]) <$> DAppPr p1 <$> dsType t2 @@ -1313,26 +1164,37 @@ -- but with the values as given in the second argument -- if a field is missing from the second argument, use the corresponding expression -- from the third argument -reorderFields :: DsMonad q => [VarStrictType] -> [FieldExp] -> [DExp] -> q [DExp] +reorderFields :: DsMonad q => Name -> [VarStrictType] -> [FieldExp] -> [DExp] -> q [DExp] reorderFields = reorderFields' dsExp -reorderFieldsPat :: DsMonad q => [VarStrictType] -> [FieldPat] -> PatM q [DPat] -reorderFieldsPat field_decs field_pats = - reorderFields' dsPat field_decs field_pats (repeat DWildPa) +reorderFieldsPat :: DsMonad q => Name -> [VarStrictType] -> [FieldPat] -> PatM q [DPat] +reorderFieldsPat con_name field_decs field_pats = + reorderFields' dsPat con_name field_decs field_pats (repeat DWildPa) reorderFields' :: (Applicative m, Monad m) => (a -> m da) + -> Name -- ^ The name of the constructor (used for error reporting) -> [VarStrictType] -> [(Name, a)] -> [da] -> m [da] -reorderFields' _ [] _ _ = return [] -reorderFields' ds_thing ((field_name, _, _) : rest) - field_things (deflt : rest_deflt) = do - rest' <- reorderFields' ds_thing rest field_things rest_deflt - case find (\(thing_name, _) -> thing_name == field_name) field_things of - Just (_, thing) -> (: rest') <$> ds_thing thing - Nothing -> return $ deflt : rest' -reorderFields' _ (_ : _) _ [] = error "Internal error in th-desugar." +reorderFields' ds_thing con_name field_names_types field_things deflts = + check_valid_fields >> reorder field_names deflts + where + field_names = map (\(a, _, _) -> a) field_names_types + check_valid_fields = + forM_ field_things $ \(thing_name, _) -> + unless (thing_name `elem` field_names) $ + fail $ "Constructor ‘" ++ nameBase con_name ++ "‘ does not have field ‘" + ++ nameBase thing_name ++ "‘" + + reorder [] _ = return [] + reorder (field_name : rest) (deflt : rest_deflt) = do + rest' <- reorder rest rest_deflt + case find (\(thing_name, _) -> thing_name == field_name) field_things of + Just (_, thing) -> (: rest') <$> ds_thing thing + Nothing -> return $ deflt : rest' + reorder (_ : _) [] = error "Internal error in th-desugar." + -- | Make a tuple 'DExp' from a list of 'DExp's. Avoids using a 1-tuple. mkTupleDExp :: [DExp] -> DExp mkTupleDExp [exp] = exp @@ -1394,9 +1256,10 @@ strictToBang = id #endif --- | Convert a 'DType' to a 'DPred' +-- | Convert a 'DType' to a 'DPred'. dTypeToDPred :: Monad q => DType -> q DPred -dTypeToDPred (DForallT _ _ _) = impossible "Forall-type used as constraint" +dTypeToDPred (DForallT tvbs cxt ty) + = DForallPr tvbs cxt `liftM` dTypeToDPred ty dTypeToDPred (DAppT t1 t2) = liftM2 DAppPr (dTypeToDPred t1) (return t2) dTypeToDPred (DSigT ty ki) = liftM2 DSigPr (dTypeToDPred ty) (return ki) dTypeToDPred (DVarT n) = return $ DVarPr n @@ -1404,4 +1267,150 @@ dTypeToDPred DArrowT = impossible "Arrow used as head of constraint" dTypeToDPred (DLitT _) = impossible "Type literal used as head of constraint" dTypeToDPred DWildCardT = return DWildCardPr -dTypeToDPred DStarT = impossible "Star used as head of constraint" + +-- | Convert a 'DPred' to 'DType'. +dPredToDType :: DPred -> DType +dPredToDType (DForallPr tvbs cxt p) = DForallT tvbs cxt (dPredToDType p) +dPredToDType (DAppPr p t) = DAppT (dPredToDType p) t +dPredToDType (DSigPr p k) = DSigT (dPredToDType p) k +dPredToDType (DVarPr n) = DVarT n +dPredToDType (DConPr n) = DConT n +dPredToDType DWildCardPr = DWildCardT + +-- Take a data type name (which does not belong to a data family) and +-- apply it to its type variable binders to form a DType. +nonFamilyDataReturnType :: Name -> [DTyVarBndr] -> DType +nonFamilyDataReturnType con_name = applyDType (DConT con_name) . map dTyVarBndrToDType + +-- Take a data family name and apply it to its argument types to form a +-- data family instance DType. +dataFamInstReturnType :: Name -> [DType] -> DType +dataFamInstReturnType fam_name = applyDType (DConT fam_name) + +-- Take a data type (which does not belong to a data family) of the form +-- @Foo a :: k -> Type -> Type@ and return @Foo a (b :: k) (c :: Type)@, where +-- @b@ and @c@ are fresh type variable names. +nonFamilyDataTvbs :: DsMonad q => [DTyVarBndr] -> Maybe Kind -> q [DTyVarBndr] +nonFamilyDataTvbs tvbs mk = do + extra_tvbs <- mkExtraKindBinders mk + pure $ tvbs ++ extra_tvbs + +-- Take a data family instance of the form @Foo a :: k -> Type -> Type@ and +-- return @Foo a (b :: k) (c :: Type)@, where @b@ and @c@ are fresh type +-- variable names. +dataFamInstTypes :: DsMonad q => [DType] -> Maybe Kind -> q [DType] +dataFamInstTypes tys mk = do + extra_tvbs <- mkExtraKindBinders mk + pure $ tys ++ map dTyVarBndrToDType extra_tvbs + +-- Unlike vanilla data types and data family declarations, data family +-- instance declarations do not come equipped with a list of bound type +-- variables (at least not yet—see Trac #14268). This means that we have +-- to reverse engineer this information ourselves from the list of type +-- patterns. We accomplish this by taking the free variables of the types +-- and performing a reverse topological sort on them to ensure that the +-- returned list is well scoped. +dataFamInstTvbs :: [DType] -> [DTyVarBndr] +dataFamInstTvbs = toposortTyVarsOf + +-- | Take a list of 'DType's, find their free variables, and sort them in +-- reverse topological order to ensure that they are well scoped. +-- +-- On older GHCs, this takes measures to avoid returning explicitly bound +-- kind variables, which was not possible before @TypeInType@. +toposortTyVarsOf :: [DType] -> [DTyVarBndr] +toposortTyVarsOf tys = + let fvs :: [Name] + fvs = Set.toList $ foldMap fvDType tys + + varKindSigs :: Map Name DKind + varKindSigs = foldMap go tys + where + go :: DType -> Map Name DKind + go (DForallT {}) = error "`forall` type used in type family pattern" + go (DAppT t1 t2) = go t1 `mappend` go t2 + go (DSigT t k) = + let kSigs = go k + in case t of + DVarT n -> Map.insert n k kSigs + _ -> go t `mappend` kSigs + go (DVarT {}) = mempty + go (DConT {}) = mempty + go DArrowT = mempty + go (DLitT {}) = mempty + go DWildCardT = mempty + + (g, gLookup, _) + = graphFromEdges [ (fv, fv, kindVars) + | fv <- fvs + , let kindVars = + case Map.lookup fv varKindSigs of + Nothing -> [] + Just ks -> Set.toList (fvDType ks) + ] + tg = reverse $ topSort g + + lookupVertex x = + case gLookup x of + (n, _, _) -> n + + ascribeWithKind n + | Just k <- Map.lookup n varKindSigs + = DKindedTV n k + | otherwise + = DPlainTV n + + -- An annoying wrinkle: GHCs before 8.0 don't support explicitly + -- quantifying kinds, so something like @forall k (a :: k)@ would be + -- rejected. To work around this, we filter out any binders whose names + -- also appear in a kind on old GHCs. + isKindBinderOnOldGHCs +#if __GLASGOW_HASKELL__ >= 800 + = const False +#else + = (`elem` kindVars) + where + kindVars = foldMap fvDType $ Map.elems varKindSigs +#endif + + in map ascribeWithKind $ + filter (not . isKindBinderOnOldGHCs) $ + map lookupVertex tg + +fvDType :: DType -> S.Set Name +fvDType = go_ty + where + go_ty :: DType -> S.Set Name + go_ty (DForallT tvbs cxt ty) = foldr go_tvb (foldMap go_pred cxt <> go_ty ty) tvbs + go_ty (DAppT t1 t2) = go_ty t1 <> go_ty t2 + go_ty (DSigT ty ki) = go_ty ty <> go_ty ki + go_ty (DVarT n) = S.singleton n + go_ty (DConT {}) = S.empty + go_ty DArrowT = S.empty + go_ty (DLitT {}) = S.empty + go_ty DWildCardT = S.empty + + go_pred :: DPred -> S.Set Name + go_pred (DAppPr pr ty) = go_pred pr <> go_ty ty + go_pred (DSigPr pr ki) = go_pred pr <> go_ty ki + go_pred (DVarPr n) = S.singleton n + go_pred _ = S.empty + + go_tvb :: DTyVarBndr -> S.Set Name -> S.Set Name + go_tvb (DPlainTV n) fvs = S.delete n fvs + go_tvb (DKindedTV n k) fvs = S.delete n fvs <> go_ty k + +dtvbName :: DTyVarBndr -> Name +dtvbName (DPlainTV n) = n +dtvbName (DKindedTV n _) = n + +-- | Decompose a function type into its type variables, its context, its +-- argument types, and its result type. +unravel :: DType -> ([DTyVarBndr], [DPred], [DType], DType) +unravel (DForallT tvbs cxt ty) = + let (tvbs', cxt', tys, res) = unravel ty in + (tvbs ++ tvbs', cxt ++ cxt', tys, res) +unravel (DAppT (DAppT DArrowT t1) t2) = + let (tvbs, cxt, tys, res) = unravel t2 in + (tvbs, cxt, t1 : tys, res) +unravel t = ([], [], [], t) diff --git a/Language/Haskell/TH/Desugar/Expand.hs b/Language/Haskell/TH/Desugar/Expand.hs --- a/Language/Haskell/TH/Desugar/Expand.hs +++ b/Language/Haskell/TH/Desugar/Expand.hs @@ -4,14 +4,14 @@ rae@cs.brynmawr.edu -} -{-# LANGUAGE CPP, NoMonomorphismRestriction #-} +{-# LANGUAGE CPP, NoMonomorphismRestriction, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.TH.Desugar.Expand -- Copyright : (C) 2014 Richard Eisenberg -- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) +-- Maintainer : Ryan Scott -- Stability : experimental -- Portability : non-portable -- @@ -40,6 +40,7 @@ import Data.Generics import qualified Data.Traversable as T +import Language.Haskell.TH.Desugar.AST import Language.Haskell.TH.Desugar.Core import Language.Haskell.TH.Desugar.Util import Language.Haskell.TH.Desugar.Sweeten @@ -54,11 +55,12 @@ expandType :: DsMonad q => DType -> q DType expandType = expand_type NoIgnore -expand_type :: DsMonad q => IgnoreKinds -> DType -> q DType +expand_type :: forall q. DsMonad q => IgnoreKinds -> DType -> q DType expand_type ign = go [] where + go :: [DType] -> DType -> q DType go [] (DForallT tvbs cxt ty) = - DForallT tvbs <$> mapM (expand_ ign) cxt <*> expand_type ign ty + DForallT tvbs <$> mapM (expand_pred ign) cxt <*> expand_type ign ty go _ (DForallT {}) = impossible "A forall type is applied to another type." go args (DAppT t1 t2) = do @@ -66,94 +68,124 @@ go (t2' : args) t1 go args (DSigT ty ki) = do ty' <- go [] ty - return $ foldl DAppT (DSigT ty' ki) args + ki' <- go [] ki + finish (DSigT ty' ki') args go args (DConT n) = expand_con ign n args - go args ty = return $ foldl DAppT ty args + go args ty@(DVarT _) = finish ty args + go args ty@DArrowT = finish ty args + go args ty@(DLitT _) = finish ty args + go args ty@DWildCardT = finish ty args + finish :: DType -> [DType] -> q DType + finish ty args = return $ applyDType ty args + -- | Expands all type synonyms in a desugared predicate. -expand_pred :: DsMonad q => IgnoreKinds -> DPred -> q DPred +expand_pred :: forall q. DsMonad q => IgnoreKinds -> DPred -> q DPred expand_pred ign = go [] where + go :: [DType] -> DPred -> q DPred + go [] (DForallPr tvbs cxt p) = + DForallPr tvbs <$> mapM (go []) cxt <*> expand_pred ign p + go _ (DForallPr {}) = + impossible "A quantified constraint is applied to another constraint." go args (DAppPr p t) = do t' <- expand_type ign t go (t' : args) p go args (DSigPr p k) = do p' <- go [] p - return $ foldl DAppPr (DSigPr p' k) args + k' <- expand_type ign k + finish (DSigPr p' k') args go args (DConPr n) = do ty <- expand_con ign n args dTypeToDPred ty - go args p = return $ foldl DAppPr p args + go args p@(DVarPr _) = finish p args + go args p@DWildCardPr = finish p args + finish :: DPred -> [DType] -> q DPred + finish p args = return $ foldl DAppPr p args + -- | Expand a constructor with given arguments -expand_con :: DsMonad q +expand_con :: forall q. + DsMonad q => IgnoreKinds -> Name -- ^ Tycon name -> [DType] -- ^ Arguments -> q DType -- ^ Expanded type expand_con ign n args = do info <- reifyWithLocals n - dinfo <- dsInfo info - args_ok <- allM no_tyvars_tyfams args - case dinfo of - DTyConI (DTySynD _n tvbs rhs) _ - | length args >= length tvbs -- this should always be true! - -> do - let (syn_args, rest_args) = splitAtList tvbs args - ty <- substTy (M.fromList $ zip (map extractDTvbName tvbs) syn_args) rhs - ty' <- expand_type ign ty - return $ foldl DAppT ty' rest_args + case info of + TyConI (TySynD _ _ StarT) + -- See Note [Don't expand synonyms for *] + -> return $ applyDType (DConT typeKindName) args + _ -> go info + where + go :: Info -> q DType + go info = do + dinfo <- dsInfo info + args_ok <- allM no_tyvars_tyfams args + case dinfo of + DTyConI (DTySynD _n tvbs rhs) _ + | length args >= length tvbs -- this should always be true! + -> do + let (syn_args, rest_args) = splitAtList tvbs args + ty <- substTy (M.fromList $ zip (map extractDTvbName tvbs) syn_args) rhs + ty' <- expand_type ign ty + return $ applyDType ty' rest_args - DTyConI (DOpenTypeFamilyD (DTypeFamilyHead _n tvbs _frs _ann)) _ - | length args >= length tvbs -- this should always be true! + DTyConI (DOpenTypeFamilyD (DTypeFamilyHead _n tvbs _frs _ann)) _ + | length args >= length tvbs -- this should always be true! #if __GLASGOW_HASKELL__ < 709 - , args_ok + , args_ok #endif - -> do - let (syn_args, rest_args) = splitAtList tvbs args - -- We need to get the correct instance. If we fail to reify anything - -- (e.g., if a type family is quasiquoted), then fall back by - -- pretending that there are no instances in scope. - insts <- qRecover (return []) $ - qReifyInstances n (map typeToTH syn_args) - dinsts <- dsDecs insts - case dinsts of - [DTySynInstD _n (DTySynEqn lhs rhs)] -> do - subst <- - expectJustM "Impossible: reification returned a bogus instance" $ - unionMaybeSubsts $ zipWith (matchTy ign) lhs syn_args - ty <- substTy subst rhs - ty' <- expand_type ign ty - return $ foldl DAppT ty' rest_args - _ -> return $ foldl DAppT (DConT n) args + -> do + let (syn_args, rest_args) = splitAtList tvbs args + -- We need to get the correct instance. If we fail to reify anything + -- (e.g., if a type family is quasiquoted), then fall back by + -- pretending that there are no instances in scope. + insts <- qRecover (return []) $ + qReifyInstances n (map typeToTH syn_args) + dinsts <- dsDecs insts + case dinsts of + [DTySynInstD _n (DTySynEqn lhs rhs)] + | Just subst <- + unionMaybeSubsts $ zipWith (matchTy ign) lhs syn_args + -> do ty <- substTy subst rhs + ty' <- expand_type ign ty + return $ applyDType ty' rest_args + _ -> give_up - DTyConI (DClosedTypeFamilyD (DTypeFamilyHead _n tvbs _frs _ann) eqns) _ - | length args >= length tvbs - , args_ok - -> do - let (syn_args, rest_args) = splitAtList tvbs args - rhss <- mapMaybeM (check_eqn syn_args) eqns - case rhss of - (rhs : _) -> do - rhs' <- expand_type ign rhs - return $ foldl DAppT rhs' rest_args - [] -> return $ foldl DAppT (DConT n) args + DTyConI (DClosedTypeFamilyD (DTypeFamilyHead _n tvbs _frs _ann) eqns) _ + | length args >= length tvbs + , args_ok + -> do + let (syn_args, rest_args) = splitAtList tvbs args + rhss <- mapMaybeM (check_eqn syn_args) eqns + case rhss of + (rhs : _) -> do + rhs' <- expand_type ign rhs + return $ applyDType rhs' rest_args + [] -> give_up - where - -- returns the substed rhs - check_eqn :: DsMonad q => [DType] -> DTySynEqn -> q (Maybe DType) - check_eqn arg_tys (DTySynEqn lhs rhs) = do - let m_subst = unionMaybeSubsts $ zipWith (matchTy ign) lhs arg_tys - T.mapM (flip substTy rhs) m_subst + where + -- returns the substed rhs + check_eqn :: [DType] -> DTySynEqn -> q (Maybe DType) + check_eqn arg_tys (DTySynEqn lhs rhs) = do + let m_subst = unionMaybeSubsts $ zipWith (matchTy ign) lhs arg_tys + T.mapM (flip substTy rhs) m_subst - _ -> return $ foldl DAppT (DConT n) args + _ -> give_up - where - no_tyvars_tyfams :: (DsMonad q, Data a) => a -> q Bool + -- Used when we can't proceed with type family instance expansion any more, + -- and must conservatively return the orignal type family applied to its + -- arguments. + give_up :: q DType + give_up = return $ applyDType (DConT n) args + + no_tyvars_tyfams :: Data a => a -> q Bool no_tyvars_tyfams = everything (liftM2 (&&)) (mkQ (return True) no_tyvar_tyfam) - no_tyvar_tyfam :: DsMonad q => DType -> q Bool + no_tyvar_tyfam :: DType -> q Bool no_tyvar_tyfam (DVarT _) = return False no_tyvar_tyfam (DConT con_name) = do m_info <- dsReify con_name @@ -167,6 +199,25 @@ allM :: Monad m => (a -> m Bool) -> [a] -> m Bool allM f = foldM (\b x -> (b &&) `liftM` f x) True + +{- +Note [Don't expand synonyms for *] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We deliberately avoid expanding type synonyms for * such as Type and ★. +Why? If you reify any such type synonym using Template Haskell, this is +what you'll get: + + TyConI (TySynD [] StarT) + +If you blindly charge ahead and recursively inspect the right-hand side of +this type synonym, you'll desugar StarT into (DConT ''Type), reify ''Type, +and get back another type synonym with StarT as its right-hand side. Then +you'll recursively inspect StarT and find yourself knee-deep in an infinite +loop. + +To prevent these sorts of shenanigans, we simply stop whenever we see a type +synonym with StarT as its right-hand side and return Type. +-} -- | Extract the name from a @TyVarBndr@ extractDTvbName :: DTyVarBndr -> Name diff --git a/Language/Haskell/TH/Desugar/Lift.hs b/Language/Haskell/TH/Desugar/Lift.hs --- a/Language/Haskell/TH/Desugar/Lift.hs +++ b/Language/Haskell/TH/Desugar/Lift.hs @@ -3,7 +3,7 @@ -- Module : Language.Haskell.TH.Desugar.Lift -- Copyright : (C) 2014 Richard Eisenberg -- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) +-- Maintainer : Ryan Scott -- Stability : experimental -- Portability : non-portable -- @@ -26,7 +26,7 @@ $(deriveLiftMany [ ''DExp, ''DPat, ''DType, ''DPred, ''DTyVarBndr , ''DMatch, ''DClause, ''DLetDec, ''DDec, ''DDerivClause, ''DCon , ''DConFields, ''DForeign, ''DPragma, ''DRuleBndr, ''DTySynEqn - , ''DPatSynDir , ''NewOrData + , ''DPatSynDir , ''NewOrData, ''DDerivStrategy #if __GLASGOW_HASKELL__ < 707 , ''AnnTarget, ''Role #endif @@ -36,6 +36,6 @@ , ''SourceStrictness, ''Overlap #endif #if __GLASGOW_HASKELL__ < 801 - , ''DerivStrategy, ''PatSynArgs + , ''PatSynArgs #endif ]) diff --git a/Language/Haskell/TH/Desugar/Match.hs b/Language/Haskell/TH/Desugar/Match.hs --- a/Language/Haskell/TH/Desugar/Match.hs +++ b/Language/Haskell/TH/Desugar/Match.hs @@ -32,6 +32,7 @@ import Language.Haskell.TH.Instances () import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Desugar.AST import Language.Haskell.TH.Desugar.Core import Language.Haskell.TH.Desugar.Util import Language.Haskell.TH.Desugar.Reify @@ -330,9 +331,9 @@ Just (DTyConI tycon_dec _) <- dsReify ty_name return $ S.fromList $ map get_con_name $ get_cons tycon_dec - get_cons (DDataD _ _ _ _ cons _) = cons - get_cons (DDataInstD _ _ _ _ cons _) = cons - get_cons _ = [] + get_cons (DDataD _ _ _ _ _ cons _) = cons + get_cons (DDataInstD _ _ _ _ _ cons _) = cons + get_cons _ = [] get_con_name (DCon _ _ n _ _) = n diff --git a/Language/Haskell/TH/Desugar/Reify.hs b/Language/Haskell/TH/Desugar/Reify.hs --- a/Language/Haskell/TH/Desugar/Reify.hs +++ b/Language/Haskell/TH/Desugar/Reify.hs @@ -44,6 +44,7 @@ import qualified Control.Monad as Fail #endif +import Language.Haskell.TH.ExpandSyns ( expandSyns ) import Language.Haskell.TH.Instances () import Language.Haskell.TH.Syntax hiding ( lift ) @@ -92,33 +93,40 @@ --------------------------------- -- | Extract the @TyVarBndr@s and constructors given the @Name@ of a type -getDataD :: Quasi q +getDataD :: DsMonad q => String -- ^ Print this out on failure -> Name -- ^ Name of the datatype (@data@ or @newtype@) of interest -> q ([TyVarBndr], [Con]) getDataD err name = do - info <- reifyWithWarning name + info <- reifyWithLocals name dec <- case info of TyConI dec -> return dec _ -> badDeclaration case dec of #if __GLASGOW_HASKELL__ > 710 - DataD _cxt _name tvbs _mk cons _derivings -> return (tvbs, cons) - NewtypeD _cxt _name tvbs _mk con _derivings -> return (tvbs, [con]) + DataD _cxt _name tvbs mk cons _derivings -> go tvbs mk cons + NewtypeD _cxt _name tvbs mk con _derivings -> go tvbs mk [con] #else - DataD _cxt _name tvbs cons _derivings -> return (tvbs, cons) - NewtypeD _cxt _name tvbs con _derivings -> return (tvbs, [con]) + DataD _cxt _name tvbs cons _derivings -> go tvbs Nothing cons + NewtypeD _cxt _name tvbs con _derivings -> go tvbs Nothing [con] #endif _ -> badDeclaration - where badDeclaration = + where + go tvbs mk cons = do + k <- maybe (pure (ConT typeKindName)) (runQ . expandSyns) mk + extra_tvbs <- mkExtraKindBindersGeneric unravelType KindedTV k + let all_tvbs = tvbs ++ extra_tvbs + return (all_tvbs, cons) + + badDeclaration = fail $ "The name (" ++ (show name) ++ ") refers to something " ++ "other than a datatype. " ++ err -- | From the name of a data constructor, retrive the datatype definition it -- is a part of. -dataConNameToDataName :: Quasi q => Name -> q Name +dataConNameToDataName :: DsMonad q => Name -> q Name dataConNameToDataName con_name = do - info <- reifyWithWarning con_name + info <- reifyWithLocals con_name case info of #if __GLASGOW_HASKELL__ > 710 DataConI _name _type parent_name -> return parent_name @@ -129,7 +137,7 @@ "a data constructor." -- | From the name of a data constructor, retrieve its definition as a @Con@ -dataConNameToCon :: Quasi q => Name -> q Con +dataConNameToCon :: DsMonad q => Name -> q Con dataConNameToCon con_name = do -- we need to get the field ordering from the constructor. We must reify -- the constructor to get the tycon, and then reify the tycon to get the `Con`s diff --git a/Language/Haskell/TH/Desugar/Subst.hs b/Language/Haskell/TH/Desugar/Subst.hs --- a/Language/Haskell/TH/Desugar/Subst.hs +++ b/Language/Haskell/TH/Desugar/Subst.hs @@ -5,7 +5,7 @@ -- Module : Language.Haskell.TH.Desugar.Subst -- Copyright : (C) 2018 Richard Eisenberg -- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) +-- Maintainer : Ryan Scott -- Stability : experimental -- Portability : non-portable -- @@ -17,7 +17,7 @@ DSubst, -- * Capture-avoiding substitution - substTy, unionSubsts, unionMaybeSubsts, + substTy, substTyVarBndrs, unionSubsts, unionMaybeSubsts, -- * Matching a type template against a type IgnoreKinds(..), matchTy @@ -29,6 +29,7 @@ import Data.Generics import Data.List +import Language.Haskell.TH.Desugar.AST import Language.Haskell.TH.Desugar.Core import Language.Haskell.TH.Syntax import Language.Haskell.TH.Desugar.Util @@ -56,11 +57,14 @@ = return ty | otherwise = return $ DVarT n -substTy _ ty = return ty +substTy _ ty@(DConT _) = return ty +substTy _ ty@DArrowT = return ty +substTy _ ty@(DLitT _) = return ty +substTy _ ty@DWildCardT = return ty substTyVarBndrs :: Quasi q => DSubst -> [DTyVarBndr] - -> (DSubst -> [DTyVarBndr] -> q DType) - -> q DType + -> (DSubst -> [DTyVarBndr] -> q a) + -> q a substTyVarBndrs vars tvbs thing = do (vars', tvbs') <- mapAccumLM substTvb vars tvbs thing vars' tvbs' @@ -76,6 +80,11 @@ return (M.insert n (DVarT new_n) vars, DKindedTV new_n k') substPred :: Quasi q => DSubst -> DPred -> q DPred +substPred vars (DForallPr tvbs cxt p) = + substTyVarBndrs vars tvbs $ \vars' tvbs' -> do + cxt' <- mapM (substPred vars') cxt + p' <- substPred vars' p + return $ DForallPr tvbs' cxt' p' substPred vars (DAppPr p t) = DAppPr <$> substPred vars p <*> substTy vars t substPred vars (DSigPr p k) = DSigPr <$> substPred vars p <*> substTy vars k substPred vars (DVarPr n) @@ -83,7 +92,8 @@ = dTypeToDPred ty | otherwise = return $ DVarPr n -substPred _ p = return p +substPred _ p@(DConPr {}) = return p +substPred _ p@DWildCardPr = return p -- | Computes the union of two substitutions. Fails if both subsitutions map -- the same variable to different types. diff --git a/Language/Haskell/TH/Desugar/Sweeten.hs b/Language/Haskell/TH/Desugar/Sweeten.hs --- a/Language/Haskell/TH/Desugar/Sweeten.hs +++ b/Language/Haskell/TH/Desugar/Sweeten.hs @@ -14,7 +14,7 @@ -- Module : Language.Haskell.TH.Desugar.Sweeten -- Copyright : (C) 2014 Richard Eisenberg -- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) +-- Maintainer : Ryan Scott -- Stability : experimental -- Portability : non-portable -- @@ -39,7 +39,7 @@ import Language.Haskell.TH hiding (cxt) -import Language.Haskell.TH.Desugar.Core +import Language.Haskell.TH.Desugar.AST import Language.Haskell.TH.Desugar.Util import Data.Maybe ( maybeToList, mapMaybe ) @@ -85,17 +85,17 @@ -- a one-to-one mapping between 'DDec' and @Dec@. decToTH :: DDec -> [Dec] decToTH (DLetDec d) = maybeToList (letDecToTH d) -decToTH (DDataD Data cxt n tvbs cons derivings) = +decToTH (DDataD Data cxt n tvbs _mk cons derivings) = #if __GLASGOW_HASKELL__ > 710 - [DataD (cxtToTH cxt) n (map tvbToTH tvbs) Nothing (map conToTH cons) + [DataD (cxtToTH cxt) n (map tvbToTH tvbs) (fmap typeToTH _mk) (map conToTH cons) (concatMap derivClauseToTH derivings)] #else [DataD (cxtToTH cxt) n (map tvbToTH tvbs) (map conToTH cons) (map derivingToTH derivings)] #endif -decToTH (DDataD Newtype cxt n tvbs [con] derivings) = +decToTH (DDataD Newtype cxt n tvbs _mk [con] derivings) = #if __GLASGOW_HASKELL__ > 710 - [NewtypeD (cxtToTH cxt) n (map tvbToTH tvbs) Nothing (conToTH con) + [NewtypeD (cxtToTH cxt) n (map tvbToTH tvbs) (fmap typeToTH _mk) (conToTH con) (concatMap derivClauseToTH derivings)] #else [NewtypeD (cxtToTH cxt) n (map tvbToTH tvbs) (conToTH con) @@ -119,23 +119,23 @@ decToTH (DOpenTypeFamilyD (DTypeFamilyHead n tvbs frs _ann)) = [FamilyD TypeFam n (map tvbToTH tvbs) (frsToTH frs)] #endif -decToTH (DDataFamilyD n tvbs) = +decToTH (DDataFamilyD n tvbs mk) = #if __GLASGOW_HASKELL__ > 710 - [DataFamilyD n (map tvbToTH tvbs) Nothing] + [DataFamilyD n (map tvbToTH tvbs) (fmap typeToTH mk)] #else - [FamilyD DataFam n (map tvbToTH tvbs) Nothing] + [FamilyD DataFam n (map tvbToTH tvbs) (fmap typeToTH mk)] #endif -decToTH (DDataInstD Data cxt n tys cons derivings) = +decToTH (DDataInstD Data cxt n tys _mk cons derivings) = #if __GLASGOW_HASKELL__ > 710 - [DataInstD (cxtToTH cxt) n (map typeToTH tys) Nothing (map conToTH cons) + [DataInstD (cxtToTH cxt) n (map typeToTH tys) (fmap typeToTH _mk) (map conToTH cons) (concatMap derivClauseToTH derivings)] #else [DataInstD (cxtToTH cxt) n (map typeToTH tys) (map conToTH cons) (map derivingToTH derivings)] #endif -decToTH (DDataInstD Newtype cxt n tys [con] derivings) = +decToTH (DDataInstD Newtype cxt n tys _mk [con] derivings) = #if __GLASGOW_HASKELL__ > 710 - [NewtypeInstD (cxtToTH cxt) n (map typeToTH tys) Nothing (conToTH con) + [NewtypeInstD (cxtToTH cxt) n (map typeToTH tys) (fmap typeToTH _mk) (conToTH con) (concatMap derivClauseToTH derivings)] #else [NewtypeInstD (cxtToTH cxt) n (map typeToTH tys) (conToTH con) @@ -169,7 +169,7 @@ decToTH (DStandaloneDerivD _mds cxt ty) = [StandaloneDerivD #if __GLASGOW_HASKELL__ >= 801 - _mds + (fmap derivStrategyToTH _mds) #endif (cxtToTH cxt) (typeToTH ty)] decToTH (DDefaultSigD n ty) = [DefaultSigD n (typeToTH ty)] @@ -217,35 +217,70 @@ conToTH :: DCon -> Con #if __GLASGOW_HASKELL__ > 710 -conToTH (DCon [] [] n (DNormalC _ stys) (Just rty)) = +conToTH (DCon [] [] n (DNormalC _ stys) rty) = GadtC [n] (map (second typeToTH) stys) (typeToTH rty) -conToTH (DCon [] [] n (DRecC vstys) (Just rty)) = +conToTH (DCon [] [] n (DRecC vstys) rty) = RecGadtC [n] (map (thirdOf3 typeToTH) vstys) (typeToTH rty) -#endif -conToTH (DCon [] [] n (DNormalC True [sty1, sty2]) _) = -#if __GLASGOW_HASKELL__ > 710 - InfixC (second typeToTH sty1) n (second typeToTH sty2) #else +conToTH (DCon [] [] n (DNormalC True [sty1, sty2]) _) = InfixC ((bangToStrict *** typeToTH) sty1) n ((bangToStrict *** typeToTH) sty2) -#endif -- Note: it's possible that someone could pass in a DNormalC value that -- erroneously claims that it's declared infix (e.g., if has more than two -- fields), but we will fall back on NormalC in such a scenario. conToTH (DCon [] [] n (DNormalC _ stys) _) = -#if __GLASGOW_HASKELL__ > 710 - NormalC n (map (second typeToTH) stys) -#else NormalC n (map (bangToStrict *** typeToTH) stys) -#endif conToTH (DCon [] [] n (DRecC vstys) _) = -#if __GLASGOW_HASKELL__ > 710 - RecC n (map (thirdOf3 typeToTH) vstys) -#else RecC n (map (\(v,b,t) -> (v,bangToStrict b,typeToTH t)) vstys) #endif +#if __GLASGOW_HASKELL__ > 710 +-- On GHC 8.0 or later, we sweeten every constructor to GADT syntax, so it is +-- perfectly OK to put all of the quantified type variables +-- (both universal and existential) in a ForallC. conToTH (DCon tvbs cxt n fields rty) = ForallC (map tvbToTH tvbs) (cxtToTH cxt) (conToTH $ DCon [] [] n fields rty) +#else +-- On GHCs earlier than 8.0, we must be careful, since the only time ForallC is +-- used is when there are either: +-- +-- 1. Any existentially quantified type variables +-- 2. A constructor context +-- +-- If neither of these conditions hold, then we needn't put a ForallC at the +-- front, since it would be completely pointless (you'd end up with things like +-- @data Foo = forall. MkFoo@!). +conToTH (DCon tvbs cxt n fields rty) + | null ex_tvbs && null cxt + = con' + | otherwise + = ForallC ex_tvbs (cxtToTH cxt) con' + where + -- Fortunately, on old GHCs, it's especially easy to distinguish between + -- universally and existentially quantified type variables. When desugaring + -- a ForallC, we just stick all of the universals (from the datatype + -- definition) at the front of the @forall@. Therefore, it suffices to + -- count the number of type variables in the return type and drop that many + -- variables from the @forall@ in the ForallC, leaving only the + -- existentials. + ex_tvbs :: [TyVarBndr] + ex_tvbs = map tvbToTH $ drop num_univ_tvs tvbs + num_univ_tvs :: Int + num_univ_tvs = go rty + where + go :: DType -> Int + go (DForallT {}) = error "`forall` type used in GADT return type" + go (DAppT t1 t2) = go t1 + go t2 + go (DSigT t _) = go t + go (DVarT {}) = 1 + go (DConT {}) = 0 + go DArrowT = 0 + go (DLitT {}) = 0 + go DWildCardT = 0 + + con' :: Con + con' = conToTH $ DCon [] [] n fields rty +#endif + foreignToTH :: DForeign -> Foreign foreignToTH (DImportF cc safety str n ty) = ImportF cc safety str n (typeToTH ty) @@ -305,7 +340,6 @@ #else typeToTH DWildCardT = error "Wildcards supported only in GHC 8.0+" #endif -typeToTH DStarT = StarT tvbToTH :: DTyVarBndr -> TyVarBndr tvbToTH (DPlainTV n) = PlainTV n @@ -316,13 +350,26 @@ #if __GLASGOW_HASKELL__ >= 801 derivClauseToTH :: DDerivClause -> [DerivClause] -derivClauseToTH (DDerivClause mds cxt) = [DerivClause mds (cxtToTH cxt)] +derivClauseToTH (DDerivClause mds cxt) = + [DerivClause (fmap derivStrategyToTH mds) (cxtToTH cxt)] #else derivClauseToTH :: DDerivClause -> Cxt derivClauseToTH (DDerivClause _ cxt) = cxtToTH cxt #endif #if __GLASGOW_HASKELL__ >= 801 +derivStrategyToTH :: DDerivStrategy -> DerivStrategy +derivStrategyToTH DStockStrategy = StockStrategy +derivStrategyToTH DAnyclassStrategy = AnyclassStrategy +derivStrategyToTH DNewtypeStrategy = NewtypeStrategy +#if __GLASGOW_HASKELL__ >= 805 +derivStrategyToTH (DViaStrategy ty) = ViaStrategy (typeToTH ty) +#else +derivStrategyToTH (DViaStrategy _) = error "DerivingVia supported only in GHC 8.6+" +#endif +#endif + +#if __GLASGOW_HASKELL__ >= 801 patSynDirToTH :: DPatSynDir -> PatSynDir patSynDirToTH DUnidir = Unidir patSynDirToTH DImplBidir = ImplBidir @@ -345,6 +392,8 @@ = ClassP n acc go _ DWildCardPr = error "Wildcards supported only in GHC 8.0+" + go _ (DForallPr {}) + = error "Quantified constraints supported only in GHC 8.6+" #else predToTH (DAppPr p t) = AppT (predToTH p) (typeToTH t) predToTH (DSigPr p k) = SigT (predToTH p) (typeToTH k) @@ -355,20 +404,36 @@ #else predToTH DWildCardPr = error "Wildcards supported only in GHC 8.0+" #endif +#if __GLASGOW_HASKELL__ >= 805 +predToTH (DForallPr tvbs cxt p) = + ForallT (map tvbToTH tvbs) (map predToTH cxt) (predToTH p) +#else +predToTH (DForallPr {}) = error "Quantified constraints supported only in GHC 8.6+" #endif +#endif tyconToTH :: Name -> Type tyconToTH n + | n == ''(->) = ArrowT -- Work around Trac #14888 | n == ''[] = ListT #if __GLASGOW_HASKELL__ >= 709 | n == ''(~) = EqualityT #endif | n == '[] = PromotedNilT | n == '(:) = PromotedConsT - | Just deg <- tupleNameDegree_maybe n = if isDataName n - then PromotedTupleT deg - else TupleT deg + | Just deg <- tupleNameDegree_maybe n + = if isDataName n +#if __GLASGOW_HASKELL__ >= 805 + then PromotedTupleT deg +#else + then PromotedT n -- Work around Trac #14843 +#endif + else TupleT deg | Just deg <- unboxedTupleNameDegree_maybe n = UnboxedTupleT deg +#if __GLASGOW_HASKELL__ == 706 + -- Work around Trac #7667 + | isTypeKindName n = StarT +#endif #if __GLASGOW_HASKELL__ >= 801 | Just deg <- unboxedSumNameDegree_maybe n = UnboxedSumT deg #endif diff --git a/Language/Haskell/TH/Desugar/Util.hs b/Language/Haskell/TH/Desugar/Util.hs --- a/Language/Haskell/TH/Desugar/Util.hs +++ b/Language/Haskell/TH/Desugar/Util.hs @@ -8,6 +8,10 @@ {-# LANGUAGE CPP, TupleSections #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE TemplateHaskellQuotes #-} +#endif + module Language.Haskell.TH.Desugar.Util ( newUniqueName, impossible, @@ -21,7 +25,9 @@ unboxedSumDegree_maybe, unboxedSumNameDegree_maybe, tupleDegree_maybe, tupleNameDegree_maybe, unboxedTupleDegree_maybe, unboxedTupleNameDegree_maybe, splitTuple_maybe, - topEverywhereM, isInfixDataCon + topEverywhereM, isInfixDataCon, + isTypeKindName, typeKindName, + mkExtraKindBindersGeneric, unravelType ) where import Prelude hiding (mapM, foldl, concatMap, any) @@ -29,12 +35,17 @@ import Language.Haskell.TH hiding ( cxt ) import Language.Haskell.TH.Syntax +import Control.Monad ( replicateM ) import qualified Data.Set as S import Data.Foldable import Data.Generics hiding ( Fixity ) import Data.Traversable import Data.Maybe +#if __GLASGOW_HASKELL__ >= 800 +import qualified Data.Kind as Kind +#endif + #if __GLASGOW_HASKELL__ < 804 import Data.Monoid #endif @@ -176,6 +187,29 @@ = Just args go _ _ = Nothing +-- | Like 'mkExtraDKindBinders', but parameterized to allow working over both +-- 'Kind'/'TyVarBndr' and 'DKind'/'DTyVarBndr'. +mkExtraKindBindersGeneric + :: Quasi q + => (kind -> ([tyVarBndr], [pred], [kind], kind)) + -> (Name -> kind -> tyVarBndr) + -> kind -> q [tyVarBndr] +mkExtraKindBindersGeneric unravel mkKindedTV k = do + let (_, _, args, _) = unravel k + names <- replicateM (length args) (qNewName "a") + return (zipWith mkKindedTV names args) + +-- | Decompose a function 'Type' into its type variables, its context, its +-- argument types, and its result type. +unravelType :: Type -> ([TyVarBndr], [Pred], [Type], Type) +unravelType (ForallT tvbs cxt ty) = + let (tvbs', cxt', tys, res) = unravelType ty in + (tvbs ++ tvbs', cxt ++ cxt', tys, res) +unravelType (AppT (AppT ArrowT t1) t2) = + let (tvbs, cxt, tys, res) = unravelType t2 in + (tvbs, cxt, t1 : tys, res) +unravelType t = ([], [], [], t) + ---------------------------------------- -- Free names, etc. ---------------------------------------- @@ -319,3 +353,44 @@ isInfixDataCon :: String -> Bool isInfixDataCon (':':_) = True isInfixDataCon _ = False + +-- | Returns 'True' if the argument 'Name' is that of 'Kind.Type' +-- (or @*@ or 'Kind.★', to support older GHCs). +isTypeKindName :: Name -> Bool +isTypeKindName n = n == typeKindName +#if __GLASGOW_HASKELL__ < 805 + || n == starKindName + || n == uniStarKindName +#endif + +-- | The 'Name' of: +-- +-- 1. The kind 'Kind.Type', on GHC 8.0 or later. +-- 2. The kind @*@ on older GHCs. +typeKindName :: Name +#if __GLASGOW_HASKELL__ >= 800 +typeKindName = ''Kind.Type +#else +typeKindName = starKindName +#endif + +#if __GLASGOW_HASKELL__ < 805 +-- | The 'Name' of the kind @*@. +starKindName :: Name +#if __GLASGOW_HASKELL__ >= 800 +starKindName = ''(Kind.*) +#else +starKindName = mkNameG_tc "ghc-prim" "GHC.Prim" "*" +#endif + +-- | The 'Name' of: +-- +-- 1. The kind 'Kind.★', on GHC 8.0 or later. +-- 2. The kind @*@ on older GHCs. +uniStarKindName :: Name +#if __GLASGOW_HASKELL__ >= 800 +uniStarKindName = ''(Kind.★) +#else +uniStarKindName = starKindName +#endif +#endif diff --git a/Test/DsDec.hs b/Test/DsDec.hs --- a/Test/DsDec.hs +++ b/Test/DsDec.hs @@ -75,7 +75,7 @@ #endif $(do decs <- S.rec_sel_test - [DDataD nd [] name [DPlainTV tvbName] cons []] <- dsDecs decs + [DDataD nd [] name [DPlainTV tvbName] k cons []] <- dsDecs decs let arg_ty = (DConT name) `DAppT` (DVarT tvbName) recsels <- getRecordSelectors arg_ty cons let num_sels = length recsels `div` 2 -- ignore type sigs @@ -89,5 +89,5 @@ fields' = zip stricts types in DCon tvbs cxt con_name (DNormalC False fields') rty - plaindata = [DDataD nd [] name [DPlainTV tvbName] (map unrecord cons) []] + plaindata = [DDataD nd [] name [DPlainTV tvbName] k (map unrecord cons) []] return (decsToTH plaindata ++ mapMaybe letDecToTH recsels)) diff --git a/Test/Run.hs b/Test/Run.hs --- a/Test/Run.hs +++ b/Test/Run.hs @@ -20,6 +20,11 @@ {-# OPTIONS_GHC -Wno-partial-type-signatures -Wno-redundant-constraints #-} #endif +#if __GLASGOW_HASKELL__ >= 805 +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE QuantifiedConstraints #-} +#endif + module Main where import Prelude hiding ( exp ) @@ -128,6 +133,10 @@ #if __GLASGOW_HASKELL__ >= 803 , "over_label" ~: $test46_overloaded_label @=? $(dsSplice test46_overloaded_label) #endif + , "do_partial_match" ~: $test47_do_partial_match @=? $(dsSplice test47_do_partial_match) +#if __GLASGOW_HASKELL__ >= 805 + , "quantified_constraints" ~: $test48_quantified_constraints @=? $(dsSplice test48_quantified_constraints) +#endif ] test35a = $test35_expand @@ -201,11 +210,13 @@ dinfo@(DTyConI (DOpenTypeFamilyD (DTypeFamilyHead _name _tvbs (DKindSig resK) _ann)) (Just [DTySynInstD _name2 (DTySynEqn lhs _rhs)])) <- dsInfo info - case (resK, lhs) of + let isTypeKind (DConT n) = isTypeKindName n + isTypeKind _ = False + case (isTypeKind resK, lhs) of #if __GLASGOW_HASKELL__ < 709 - (DStarT, [DVarT _]) -> [| True |] + (True, [DVarT _]) -> [| True |] #else - (DStarT, [DSigT (DVarT _) (DVarT _)]) -> [| True |] + (True, [DSigT (DVarT _) (DVarT _)]) -> [| True |] #endif _ -> do runIO $ do @@ -249,11 +260,58 @@ (expandType orig_ty) orig_ty `eqTHSplice` exp_ty) +test_stuck_tyfam_expansion :: Bool +test_stuck_tyfam_expansion = + $(do fam_name <- newName "F" + x <- newName "x" + k <- newName "k" + let orig_ty = DConT fam_name `DAppT` DConT '() -- F '() + exp_ty <- withLocalDeclarations + (decsToTH [ -- type family F (x :: k) :: k + DOpenTypeFamilyD + (DTypeFamilyHead fam_name + [DKindedTV x (DVarT k)] + (DKindSig (DVarT k)) + Nothing) + -- type instance F (x :: ()) = x + , DTySynInstD fam_name + (DTySynEqn [DSigT (DVarT x) (DConT ''())] (DVarT x)) + ]) + (expandType orig_ty) + orig_ty `eqTHSplice` exp_ty) + +test_t85 :: Bool +test_t85 = + $(do let orig_ty = + (DConT ''Constant `DAppT` DConT ''Int `DAppT` DConT 'True) + `DSigT` (DConT ''Constant `DAppT` DConT ''Char `DAppT` DConT ''Bool) + expected_ty = DConT 'True `DSigT` DConT ''Bool + expanded_ty <- expandType orig_ty + expected_ty `eqTHSplice` expanded_ty) + +test_getDataD_kind_sig :: Bool +test_getDataD_kind_sig = +#if __GLASGOW_HASKELL__ >= 800 + 3 == $(do data_name <- newName "TestData" + a <- newName "a" + let type_kind = DConT typeKindName + data_kind_sig = DArrowT `DAppT` type_kind `DAppT` + (DArrowT `DAppT` type_kind `DAppT` type_kind) + (tvbs, _) <- withLocalDeclarations + (decToTH (DDataD Data [] data_name [DPlainTV a] + (Just data_kind_sig) [] [])) + (getDataD "th-desugar: Impossible" data_name) + [| $(Syn.lift (length tvbs)) |]) +#else + True -- DataD didn't have the ability to store kind signatures prior to GHC 8.0 +#endif + test_kind_substitution :: [Bool] test_kind_substitution = $(do a <- newName "a" b <- newName "b" c <- newName "c" + k <- newName "k" let subst = M.singleton a (DVarT b) -- (Nothing :: Maybe a) @@ -262,19 +320,28 @@ ty2 = DForallT [DKindedTV c (DVarT a)] [] (DVarT c) -- forall a (c :: a). c ty3 = DForallT [DPlainTV a, DKindedTV c (DVarT a)] [] (DVarT c) + -- forall (a :: k) k (b :: k). Proxy b -> Proxy a + ty4 = DForallT [ DKindedTV a (DVarT k) + , DPlainTV k + , DKindedTV b (DVarT k) + ] [] (DArrowT `DAppT` (DConT ''Proxy `DAppT` DVarT b) + `DAppT` (DConT ''Proxy `DAppT` DVarT a)) substTy1 <- substTy subst ty1 substTy2 <- substTy subst ty2 substTy3 <- substTy subst ty3 + substTy4 <- substTy subst ty4 let freeVars1 = fvDType substTy1 freeVars2 = fvDType substTy2 freeVars3 = fvDType substTy3 + freeVars4 = fvDType substTy4 b1 = freeVars1 `eqTH` S.singleton b b2 = freeVars2 `eqTH` S.singleton b b3 = freeVars3 `eqTH` S.empty - [| [b1, b2, b3] |]) + b4 = freeVars4 `eqTH` S.singleton k + [| [b1, b2, b3, b4] |]) test_lookup_value_type_names :: [Bool] test_lookup_value_type_names = @@ -394,6 +461,12 @@ it "works with deriving strategies" $ test_deriving_strategies it "doesn't expand local type families" $ test_local_tyfam_expansion + + it "doesn't crash on a stuck type family application" $ test_stuck_tyfam_expansion + + it "expands type synonyms in kinds" $ test_t85 + + it "reifies data type return kinds accurately" $ test_getDataD_kind_sig -- Remove map pprints here after switch to th-orphans zipWithM (\t t' -> it ("can do Type->DType->Type of " ++ t) $ t == t') diff --git a/Test/Splices.hs b/Test/Splices.hs --- a/Test/Splices.hs +++ b/Test/Splices.hs @@ -26,6 +26,11 @@ {-# OPTIONS_GHC -Wno-orphans #-} -- IsLabel is an orphan #endif +#if __GLASGOW_HASKELL__ >= 805 +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE QuantifiedConstraints #-} +#endif + {-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-type-defaults -fno-warn-name-shadowing #-} @@ -105,31 +110,9 @@ then [| True |] else [| False |] --- Note [Annotating list elements] --- --- Type annotations on list elements are needed to satisfy GHC 8.0-rc1, otherwise --- we get errors like: --- --- Test/Run.hs:63:53: error: --- • Couldn't match type ‘Maybe Integer’ with ‘forall a. Maybe a’ --- Expected type: [forall a. Maybe a] --- Actual type: [Maybe Integer] --- • In the second argument of ‘(:)’, namely --- ‘(:) (Just 19) ((:) (Nothing :: Maybe Integer) [])’ --- In the second argument of ‘(:)’, namely --- ‘(:) Nothing ((:) (Just 19) ((:) (Nothing :: Maybe Integer) []))’ --- In the second argument of ‘map’, namely --- ‘(:) --- (Just 1) --- ((:) Nothing ((:) (Just 19) ((:) (Nothing :: Maybe Integer) [])))’ --- --- This is probably a bug in the GHC type checker, but I haven't been able to --- reduce it yet - test1_sections = [| map ((* 3) . (4 +) . (\x -> x * x)) [10, 11, 12] |] test2_lampats = [| (\(Just x) (Left z) -> x + z) (Just 5) (Left 10) |] --- See Note [Annotating list elements] -test3_lamcase = [| foldr (-) 0 (map (\case { Just x -> x ; Nothing -> (-3) }) [Just 1, Nothing :: Maybe Integer, Just 19, Nothing :: Maybe Integer]) |] +test3_lamcase = [| foldr (-) 0 (map (\case { Just x -> x ; Nothing -> (-3) }) [Just 1, Nothing, Just 19, Nothing]) |] test4_tuples = [| (\(a, _) (# b, _ #) -> a + b) (1,2) (# 3, 4 #) |] test5_ifs = [| if (5 > 7) then "foo" else if | Nothing <- Just "bar", True -> "blargh" | otherwise -> "bum" |] test6_ifs2 = [| if | Nothing <- Nothing, False -> 3 | Just _ <- Just "foo" -> 5 |] @@ -163,8 +146,7 @@ deriving (Show, Eq) test17_infixp = [| map (\(x :+: y) -> if y then x + 1 else x - 1) [5 :+: True, 10 :+: False] |] --- See Note [Annotating list elements] -test18_tildep = [| map (\ ~() -> Nothing :: Maybe Int) [undefined :: (), ()] |] +test18_tildep = [| map (\ ~() -> Nothing :: Maybe Int) [undefined, ()] |] test19_bangp = [| map (\ !() -> 5) [()] |] test20_asp = [| map (\ a@(b :+: c) -> (if c then b + 1 else b - 1, a)) [5 :+: True, 10 :+: False] |] test21_wildp = [| zipWith (\_ _ -> 10) [1,2,3] ['a','b','c'] |] @@ -173,19 +155,16 @@ test23_sigp = [| map (\ (a :: Int) -> a + a) [5, 10] |] #endif --- See Note [Annotating list elements] -test24_fun = [| let f :: Maybe (Maybe a) -> Maybe a - f (Just x) = x +test24_fun = [| let f (Just x) = x f Nothing = Nothing in f (Just (Just 10)) |] --- See Note [Annotating list elements] test25_fun2 = [| let f (Just x) | x > 0 = x | x < 0 = x + 10 f Nothing = 0 f _ = 18 in - map f [Just (-5), Just 5, Just 10, Nothing :: Maybe Integer, Just 0] |] + map f [Just (-5), Just 5, Just 10, Nothing, Just 0] |] test26_forall = [| let f :: Num a => a -> a f x = x + 10 in @@ -221,8 +200,8 @@ f = fst in f |] -type Const a b = b -test36_expand = [| let f :: Const Int (,) Bool Char -> Char +type Constant a b = b +test36_expand = [| let f :: Constant Int (,) Bool Char -> Char f = snd in f |] @@ -276,6 +255,15 @@ #x p - #y p |] #endif +test47_do_partial_match = [| do { Just () <- [Nothing]; return () } |] + +#if __GLASGOW_HASKELL__ >= 805 +test48_quantified_constraints = + [| let f :: forall f a. (forall x. Eq x => Eq (f x), Eq a) => f a -> f a -> Bool + f = (==) + in f (Proxy @Int) (Proxy @Int) |] +#endif + type family TFExpand x type instance TFExpand Int = Bool type instance TFExpand (Maybe a) = [a] @@ -338,14 +326,19 @@ dec_test_nums = [1..11] :: [Int] #endif -dectest1 = [d| data Dec1 = Foo | Bar Int |] -dectest2 = [d| data Dec2 a = forall b. (Show b, Eq a) => MkDec2 a b Bool |] -dectest3 = [d| data Dec3 a = forall b. MkDec3 { foo :: a, bar :: b } +dectest1 = [d| data Dec1 where + Foo :: Dec1 + Bar :: Int -> Dec1 |] +dectest2 = [d| data Dec2 a where + MkDec2 :: forall a b. (Show b, Eq a) => a -> b -> Bool -> Dec2 a |] +dectest3 = [d| data Dec3 a where + MkDec3 :: forall a b. { foo :: a, bar :: b } -> Dec3 a #if __GLASGOW_HASKELL__ >= 707 type role Dec3 nominal #endif |] -dectest4 = [d| newtype Dec4 a = MkDec4 (a, Int) |] +dectest4 = [d| newtype Dec4 a where + MkDec4 :: (a, Int) -> Dec4 a |] dectest5 = [d| type Dec5 a b = (a b, Maybe b) |] dectest6 = [d| class (Monad m1, Monad m2) => Dec6 (m1 :: * -> *) m2 | m1 -> m2 where lift :: forall a. m1 a -> m2 a @@ -353,16 +346,13 @@ dectest7 = [d| type family Dec7 a (b :: *) (c :: Bool) :: * -> * |] dectest8 = [d| type family Dec8 a |] dectest9 = [d| data family Dec9 a (b :: * -> *) :: * -> * |] - -- NB: dectest9 inexplicably fails when you don't recompile everything from - -- scratch. I (Richard) haven't explored why. The failure is benign (replacing the - -- decl above with one with three variables) so I'm not terribly bothered. #if __GLASGOW_HASKELL__ < 707 ds_dectest10 = DClosedTypeFamilyD (DTypeFamilyHead (mkName "Dec10") [DPlainTV (mkName "a")] - (DKindSig (DAppT (DAppT DArrowT DStarT) DStarT)) + (DKindSig (DAppT (DAppT DArrowT (DConT typeKindName)) (DConT typeKindName))) Nothing) [ DTySynEqn [DConT ''Int] (DConT ''Maybe) , DTySynEqn [DConT ''Bool] (DConT ''[]) ] @@ -421,8 +411,19 @@ type M2 Maybe = Either () |] data family Dec9 a (b :: * -> *) :: * -> * +#if __GLASGOW_HASKELL__ >= 800 +imp_inst_test2 = [d| data instance Dec9 Int Maybe a where + MkIMB :: [a] -> Dec9 Int Maybe a + MkIMB2 :: forall a b. b a -> Dec9 Int Maybe a |] +imp_inst_test3 = [d| newtype instance Dec9 Bool m x where + MkBMX :: m x -> Dec9 Bool m x |] +#else +-- TH-quoted data family instances with GADT syntax are horribly broken on GHC 7.10 +-- and older, so we opt to use non-GADT syntax on older GHCs so we can at least +-- test *something*. imp_inst_test2 = [d| data instance Dec9 Int Maybe a = MkIMB [a] | forall b. MkIMB2 (b a) |] imp_inst_test3 = [d| newtype instance Dec9 Bool m x = MkBMX (m x) |] +#endif type family Dec8 a imp_inst_test4 = [d| type instance Dec8 Int = Bool |] @@ -511,6 +512,11 @@ r22 :: a -> a r22 = id -- test #32 + data R23 a = MkR23 { getR23 :: a } + + r23Test :: R23 a -> a + r23Test (MkR23 { getR23 = x }) = x + #if __GLASGOW_HASKELL__ >= 801 pattern Point :: Int -> Int -> (Int, Int) pattern Point{x, y} = (x, y) @@ -541,6 +547,14 @@ llEx :: [a] -> Int llEx LLMeth = 5 +#endif + +#if __GLASGOW_HASKELL__ >= 805 + newtype Id a = MkId a + deriving stock Eq + + newtype R24 a = MkR24 [a] + deriving Eq via (Id [a]) #endif |] diff --git a/th-desugar.cabal b/th-desugar.cabal --- a/th-desugar.cabal +++ b/th-desugar.cabal @@ -1,20 +1,24 @@ name: th-desugar -version: 1.8 +version: 1.9 cabal-version: >= 1.10 synopsis: Functions to desugar Template Haskell homepage: https://github.com/goldfirere/th-desugar category: Template Haskell author: Richard Eisenberg -maintainer: Richard Eisenberg , Ryan Scott +maintainer: Ryan Scott bug-reports: https://github.com/goldfirere/th-desugar/issues stability: experimental extra-source-files: README.md, CHANGES.md license: BSD3 license-file: LICENSE build-type: Simple -tested-with: GHC == 7.6.3, GHC == 7.8.2, GHC == 7.8.3, GHC == 7.8.4, - GHC == 7.10.1, GHC == 7.10.2, GHC == 7.10.3, GHC == 8.0.1, - GHC == 8.0.2, GHC == 8.2.1, GHC == 8.2.2, GHC == 8.4.1 +tested-with: GHC == 7.6.3 + , GHC == 7.8.2, GHC == 7.8.3, GHC == 7.8.4 + , GHC == 7.10.1, GHC == 7.10.2, GHC == 7.10.3 + , GHC == 8.0.1, GHC == 8.0.2 + , GHC == 8.2.1, GHC == 8.2.2 + , GHC == 8.4.1, GHC == 8.4.2, GHC == 8.4.3 + , GHC == 8.6.1 description: This package provides the Language.Haskell.TH.Desugar module, which desugars Template Haskell's rich encoding of Haskell syntax into a simpler encoding. @@ -29,12 +33,17 @@ source-repository this type: git location: https://github.com/goldfirere/th-desugar.git - tag: v1.8 + tag: v1.9 +source-repository head + type: git + location: https://github.com/goldfirere/th-desugar.git + branch: master + library build-depends: base >= 4 && < 5, - template-haskell, + template-haskell >= 2.8 && < 2.15, containers >= 0.5, mtl >= 2.1, syb >= 0.4, @@ -47,7 +56,8 @@ Language.Haskell.TH.Desugar.Lift, Language.Haskell.TH.Desugar.Expand, Language.Haskell.TH.Desugar.Subst - other-modules: Language.Haskell.TH.Desugar.Core, + other-modules: Language.Haskell.TH.Desugar.AST, + Language.Haskell.TH.Desugar.Core, Language.Haskell.TH.Desugar.Match, Language.Haskell.TH.Desugar.Util, Language.Haskell.TH.Desugar.Reify