diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,84 @@ `th-desugar` release notes ========================== +Version 1.10 +------------ +* Support GHC 8.8. Drop support for GHC 7.6. +* Add support for visible kind application, type variable `foralls` in `RULES`, + and explicit `forall`s in type family instances. Correspondingly, + * There is now a `DAppKindT` constructor in `DType`. + * Previously, the `DDataInstD` constructor had fields of type `Name` and + `[DType]`. Those have been scrapped in favor of a single field of type + `DType`, representing the application of the data family name (which was + previously the `Name`) to its arguments (which was previously the + `[DType]`). + + `DDataInstD` also has a new field of type `Maybe [DTyVarBndr]` to represent + its explicitly quantified type variables (if present). + * Previously, the `DTySynEqn` constructor had a field of type `[DType]`. + That has been scrapped in favor of a field of type `DType`, representing + the application of the type family name (which `DTySynEqn` did not used to + contain!) to its arguments (which was previously the `[DType]`). + + `DTySynEqn` also has a new field of type `Maybe [DTyVarBndr]` to represent + its explicitly quantified type variables (if present). + * `DTySynInstD` no longer has a field of type `Name`, as that is redundant + now that each `DTySynEqn` contains the same `Name`. + * There is now a field of type `Maybe [DTyVarBndr]` in the `DRuleP` + constructor to represent bound type variables in `RULES` (if present). +* Add a field of type `Maybe [DTyVarBndr]` to `DInstanceD` and + `DStandaloneDerivD` for optionally quantifying type variables explicitly. + If supplied with a `Just`, this sweetens the instance type to use a `ForallT` + to represent the explicit quantification. This trick is not supported for + `InstanceD` on GHC 8.0 and for `StandaloneDerivD` on GHC 7.10 or 8.0, so be + aware of this limitation if you supply `Just` for this field. +* Add support for desugaring implicit params. This does not involve any changes + to the `th-desugar` AST, as: + * `(?x :: a) => ...` is desugared to `IP "x" a => ...`. + * `id ?x` is desugared to `id (ip @"x")`. + * `let ?x = 42 in ...` is desugared to + `let new_x_val = 42 in bindIP @"x" new_x_val ...` (where `bindIP` is a new + utility function exported by `Language.Haskell.TH.Desugar` on GHC 8.0 or + later). + + In order to support this desugaring, the type signatures of `dsLetDec` and + `dsLetDecs` now return `([DLetDec], DExp -> DExp)` instead of just + `[DLetDec]`, where `DExp -> DExp` is the expression which binds the values of + implicit params (e.g., `\z -> bindIP @"x" new_x_val z`) if any are bound. + (If none are bound, this is simply the `id` function.) +* Fix a bug in which `toposortTyVarsOf` would error at runtime if given types + containing `forall`s as arguments. +* Fix a bug in which `fvDType` would return incorrect results if given a type + containing quantified constraints. +* Fix a bug in which `expandType` would not expand type synonyms in the kinds + of type variable binders in `forall`s. +* Fix a bug in which `getRecordSelectors` would omit record selectors from + GADT constructors. +* Fix a bug in which `toposortTyVarsOf` would sometimes not preserve + the left-to-right ordering of `Name`s generated with `qNewName`. +* Locally reified class methods, data constructors, and record selectors now + quantify kind variables properly. +* Desugared ADT constructors now quantify kind variables properly. +* Remove `DPred`, as it has become too similar to `DType`. This also means + that the `DPat` constructors, which previously ended with the suffix `Pa`, + can now use the suffix `P`, mirroring TH. +* The type of `applyDType` has changed from `DType -> [DType] -> DType` to + `DType -> [DTypeArg] -> DType`, where `DTypeArg` is a new data type that + encodes whether an argument is a normal type argument (e.g., the `Int` in + `Maybe Int`) or a visible kind argument (e.g., the `@Type` in + `Proxy @Type Char`). A `TypeArg` data type (which is like `DTypeArg`, but + with `Type`s/`Kind`s instead of `DType`s/`DKind`s) is also provided. + + A handful of utility functions for manipulating `TypeArg`s and `DTypeArg`s + are also exported. +* `th-desugar` functions that compute free variables (e.g., `fvDType`) now + return an `OSet`, a variant of `Set` that remembers the order in which + elements were inserted. A consequence of this change is that it fixes a bug + that causes free variables to be computed in different orders depending on + which unique numbers GHC happened to generate internally. +* Substition and type synonym expansion are now more efficient by avoiding + the use of `syb` in inner loops. + Version 1.9 ----------- * Suppose GHC 8.6. 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 @@ -23,7 +23,7 @@ module Language.Haskell.TH.Desugar ( -- * Desugared data types - DExp(..), DLetDec(..), DPat(..), DType(..), DKind, DCxt, DPred(..), + DExp(..), DLetDec(..), DPat(..), DType(..), DKind, DCxt, DPred, DTyVarBndr(..), DMatch(..), DClause(..), DDec(..), DDerivClause(..), DDerivStrategy(..), DPatSynDir(..), DPatSynType, Overlap(..), PatSynArgs(..), NewOrData(..), @@ -44,7 +44,8 @@ dsCon, dsForeign, dsPragma, dsRuleBndr, -- ** Secondary desugaring functions - PatM, dsPred, dsPat, dsDec, dsDerivClause, dsLetDec, + PatM, dsPred, dsPat, dsDec, dsDataDec, dsDataInstDec, + DerivingClause, dsDerivClause, dsLetDec, dsMatches, dsBody, dsGuards, dsDoStmts, dsComp, dsClauses, dsBangType, dsVarBangType, #if __GLASGOW_HASKELL__ > 710 @@ -53,6 +54,7 @@ #if __GLASGOW_HASKELL__ >= 801 dsPatSynDir, #endif + dsTypeArg, -- * Converting desugared AST back to TH AST module Language.Haskell.TH.Desugar.Sweeten, @@ -78,36 +80,52 @@ -- * Capture-avoiding substitution and utilities module Language.Haskell.TH.Desugar.Subst, + -- * Free variable calculation + module Language.Haskell.TH.Desugar.FV, + -- * Utility functions - applyDExp, applyDType, + applyDExp, dPatToDExp, removeWilds, getDataD, dataConNameToDataName, dataConNameToCon, nameOccursIn, allNamesIn, flattenDValD, getRecordSelectors, mkTypeName, mkDataName, newUniqueName, mkTupleDExp, mkTupleDPat, maybeDLetE, maybeDCaseE, mkDLamEFromDPats, - fvDType, tupleDegree_maybe, tupleNameDegree_maybe, unboxedSumDegree_maybe, unboxedSumNameDegree_maybe, unboxedTupleDegree_maybe, unboxedTupleNameDegree_maybe, strictToBang, isTypeKindName, typeKindName, +#if __GLASGOW_HASKELL__ >= 800 + bindIP, +#endif unravel, conExistentialTvbs, mkExtraDKindBinders, dTyVarBndrToDType, toposortTyVarsOf, + -- ** 'TypeArg' + TypeArg(..), applyType, filterTANormals, unfoldType, + + -- ** 'DTypeArg' + DTypeArg(..), applyDType, filterDTANormals, unfoldDType, + -- ** 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 -import Language.Haskell.TH.Syntax -import Language.Haskell.TH.Desugar.Reify import Language.Haskell.TH.Desugar.Expand +import Language.Haskell.TH.Desugar.FV import Language.Haskell.TH.Desugar.Match +import qualified Language.Haskell.TH.Desugar.OSet as OS +import Language.Haskell.TH.Desugar.Reify import Language.Haskell.TH.Desugar.Subst +import Language.Haskell.TH.Desugar.Sweeten +import Language.Haskell.TH.Desugar.Util +import Language.Haskell.TH.Syntax import Control.Monad +import qualified Data.Foldable as F +import Data.Function +import Data.List import qualified Data.Map as M import qualified Data.Set as S import Prelude hiding ( exp ) @@ -140,6 +158,10 @@ desugar = dsDecs sweeten = decsToTH +instance Desugar TypeArg DTypeArg where + desugar = dsTypeArg + sweeten = typeArgToTH + -- | 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. @@ -147,11 +169,11 @@ -- less efficient than those that come in: they have many more pattern -- matches. flattenDValD :: Quasi q => DLetDec -> q [DLetDec] -flattenDValD dec@(DValD (DVarPa _) _) = return [dec] +flattenDValD dec@(DValD (DVarP _) _) = return [dec] flattenDValD (DValD pat exp) = do x <- newUniqueName "x" -- must use newUniqueName here because we might be top-level - let top_val_d = DValD (DVarPa x) exp - bound_names = S.elems $ extractBoundNamesDPat pat + let top_val_d = DValD (DVarP x) exp + bound_names = F.toList $ extractBoundNamesDPat pat other_val_ds <- mapM (mk_val_d x) bound_names return $ top_val_d : other_val_ds where @@ -160,19 +182,19 @@ let pat' = wildify name y pat match = DMatch pat' (DVarE y) cas = DCaseE (DVarE x) [match] - return $ DValD (DVarPa name) cas + return $ DValD (DVarP name) cas wildify name y p = case p of - DLitPa lit -> DLitPa lit - DVarPa n - | n == name -> DVarPa y - | otherwise -> DWildPa - DConPa con ps -> DConPa con (map (wildify name y) ps) - DTildePa pa -> DTildePa (wildify name y pa) - DBangPa pa -> DBangPa (wildify name y pa) - DSigPa pa ty -> DSigPa (wildify name y pa) ty - DWildPa -> DWildPa + DLitP lit -> DLitP lit + DVarP n + | n == name -> DVarP y + | otherwise -> DWildP + DConP con ps -> DConP con (map (wildify name y) ps) + DTildeP pa -> DTildeP (wildify name y pa) + DBangP pa -> DBangP (wildify name y pa) + DSigP pa ty -> DSigP (wildify name y pa) ty + DWildP -> DWildP flattenDValD other_dec = return [other_dec] @@ -191,8 +213,8 @@ -- -- @ -- [ DSigD y (DAppT (DAppT DArrowT (DConT X)) (DConT Symbol)) --- , DFunD y [ DClause [DConPa X1 [DVarPa field]] (DVarE field) --- , DClause [DConPa X2 [DVarPa field]] (DVarE field) ] ] +-- , DFunD y [ DClause [DConP X1 [DVarP field]] (DVarE field) +-- , DClause [DConP X2 [DVarP field]] (DVarE field) ] ] -- @ -- -- instead of returning one binding for @X1@ and another binding for @X2@. @@ -204,32 +226,36 @@ -- See https://github.com/goldfirere/singletons/issues/180 for an example where -- the latter behavior can bite you. -getRecordSelectors :: Quasi q +getRecordSelectors :: DsMonad q => DType -- ^ the type of the argument -> [DCon] -> q [DLetDec] getRecordSelectors arg_ty cons = merge_let_decs `fmap` concatMapM get_record_sels cons where - get_record_sels (DCon _ _ con_name con _) = case con of - DRecC fields -> go fields - _ -> return [] - where - go fields = do - varName <- qNewName "field" - let tvbs = fvDType arg_ty - forall' = DForallT (map DPlainTV $ S.toList tvbs) [] - num_pats = length fields - return $ concat - [ [ DSigD name (forall' $ DArrowT `DAppT` arg_ty `DAppT` res_ty) - , DFunD name [DClause [DConPa con_name (mk_field_pats n num_pats varName)] - (DVarE varName)] ] - | ((name, _strict, res_ty), n) <- zip fields [0..] - , fvDType res_ty `S.isSubsetOf` tvbs -- exclude "naughty" selectors - ] + get_record_sels con@(DCon con_tvbs _ con_name con_fields con_ret_ty) = + case con_fields of + DRecC fields -> go fields + DNormalC{} -> return [] + where + go fields = do + varName <- qNewName "field" + con_ex_tvbs <- conExistentialTvbs arg_ty con + let con_univ_tvbs = deleteFirstsBy ((==) `on` dtvbName) con_tvbs con_ex_tvbs + con_ex_tvb_set = OS.fromList $ map dtvbName con_ex_tvbs + forall' = DForallT con_univ_tvbs [] + num_pats = length fields + return $ concat + [ [ DSigD name (forall' $ DArrowT `DAppT` con_ret_ty `DAppT` field_ty) + , DFunD name [DClause [DConP con_name (mk_field_pats n num_pats varName)] + (DVarE varName)] ] + | ((name, _strict, field_ty), n) <- zip fields [0..] + , OS.null (fvDType field_ty `OS.intersection` con_ex_tvb_set) + -- exclude "naughty" selectors + ] mk_field_pats :: Int -> Int -> Name -> [DPat] - mk_field_pats 0 total name = DVarPa name : (replicate (total-1) DWildPa) - mk_field_pats n total name = DWildPa : mk_field_pats (n-1) (total-1) name + mk_field_pats 0 total name = DVarP name : (replicate (total-1) DWildP) + mk_field_pats n total name = DWildP : mk_field_pats (n-1) (total-1) name merge_let_decs :: [DLetDec] -> [DLetDec] merge_let_decs decs = @@ -366,23 +392,16 @@ => 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 - ] +conExistentialTvbs data_ty (DCon tvbs _ _ _ ret_ty) = do + data_ty' <- expandType data_ty + ret_ty' <- expandType 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 --- a/Language/Haskell/TH/Desugar/AST.hs +++ b/Language/Haskell/TH/Desugar/AST.hs @@ -25,58 +25,53 @@ | DLetE [DLetDec] DExp | DSigE DExp DType | DStaticE DExp - deriving (Show, Typeable, Data, Generic) + deriving (Eq, 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) +data DPat = DLitP Lit + | DVarP Name + | DConP Name [DPat] + | DTildeP DPat + | DBangP DPat + | DSigP DPat DType + | DWildP + deriving (Eq, 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 + | DAppKindT DType DKind | DSigT DType DKind | DVarT Name | DConT Name | DArrowT | DLitT TyLit | DWildCardT - deriving (Show, Typeable, Data, Generic) + deriving (Eq, Show, Typeable, Data, Generic) --- | Kinds are types. +-- | Kinds are types. Corresponds to TH's @Kind@ type DKind = DType +-- | Predicates are types. Corresponds to TH's @Pred@ +type DPred = 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) + deriving (Eq, Show, Typeable, Data, Generic) -- | Corresponds to TH's @Match@ type. data DMatch = DMatch DPat DExp - deriving (Show, Typeable, Data, Generic) + deriving (Eq, Show, Typeable, Data, Generic) -- | Corresponds to TH's @Clause@ type. data DClause = DClause [DPat] DExp - deriving (Show, Typeable, Data, Generic) + deriving (Eq, Show, Typeable, Data, Generic) -- | Declarations as used in a @let@ statement. data DLetDec = DFunD Name [DClause] @@ -84,7 +79,7 @@ | DSigD Name DType | DInfixD Fixity Name | DPragmaD DPragma - deriving (Show, Typeable, Data, Generic) + deriving (Eq, Show, Typeable, Data, Generic) -- | Is it a @newtype@ or a @data@ type? data NewOrData = Newtype @@ -96,19 +91,20 @@ | 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] + | DInstanceD (Maybe Overlap) (Maybe [DTyVarBndr]) 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 + | DDataInstD NewOrData DCxt (Maybe [DTyVarBndr]) DType (Maybe DKind) + [DCon] [DDerivClause] + | DTySynInstD DTySynEqn | DRoleAnnotD Name [Role] - | DStandaloneDerivD (Maybe DDerivStrategy) DCxt DType + | DStandaloneDerivD (Maybe DDerivStrategy) (Maybe [DTyVarBndr]) DCxt DType | DDefaultSigD Name DType | DPatSynD Name PatSynArgs DPatSynDir DPat | DPatSynSigD Name DPatSynType - deriving (Show, Typeable, Data, Generic) + deriving (Eq, Show, Typeable, Data, Generic) #if __GLASGOW_HASKELL__ < 711 data Overlap = Overlappable | Overlapping | Overlaps | Incoherent @@ -119,7 +115,7 @@ 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) + deriving (Eq, Show, Typeable, Data, Generic) -- | Corresponds to TH's 'PatSynType' type type DPatSynType = DType @@ -130,19 +126,19 @@ = 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) + deriving (Eq, Show, Typeable, Data, Generic) #endif -- | Corresponds to TH's 'TypeFamilyHead' type data DTypeFamilyHead = DTypeFamilyHead Name [DTyVarBndr] DFamilyResultSig (Maybe InjectivityAnn) - deriving (Show, Typeable, Data, Generic) + deriving (Eq, Show, Typeable, Data, Generic) -- | Corresponds to TH's 'FamilyResultSig' type data DFamilyResultSig = DNoSig | DKindSig DKind | DTyVarSig DTyVarBndr - deriving (Show, Typeable, Data, Generic) + deriving (Eq, Show, Typeable, Data, Generic) #if __GLASGOW_HASKELL__ <= 710 data InjectivityAnn = InjectivityAnn Name [Name] @@ -166,13 +162,13 @@ -- * 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) + deriving (Eq, 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) + deriving (Eq, 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 @@ -245,38 +241,26 @@ -- | Corresponds to TH's @Foreign@ type. data DForeign = DImportF Callconv Safety String Name DType | DExportF Callconv String Name DType - deriving (Show, Typeable, Data, Generic) + deriving (Eq, 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 + | DRuleP String (Maybe [DTyVarBndr]) [DRuleBndr] DExp DExp Phases | DAnnP AnnTarget DExp | DLineP Int String | DCompleteP [Name] (Maybe Name) - deriving (Show, Typeable, Data, Generic) + deriving (Eq, Show, Typeable, Data, Generic) -- | Corresponds to TH's @RuleBndr@ type. data DRuleBndr = DRuleVar Name | DTypedRuleVar Name DType - deriving (Show, Typeable, Data, Generic) + deriving (Eq, 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 +data DTySynEqn = DTySynEqn (Maybe [DTyVarBndr]) DType DType + deriving (Eq, Show, Typeable, Data, Generic) -- | Corresponds to TH's @Info@ type. data DInfo = DTyConI DDec (Maybe [DInstanceDec]) @@ -289,17 +273,17 @@ -- ^ The @Int@ is the arity; the @Bool@ is whether this tycon -- is unlifted. | DPatSynI Name DPatSynType - deriving (Show, Typeable, Data, Generic) + deriving (Eq, 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) + deriving (Eq, 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) + deriving (Eq, 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,7 +7,8 @@ processing. The desugared types and constructors are prefixed with a D. -} -{-# LANGUAGE TemplateHaskell, LambdaCase, CPP, ScopedTypeVariables, TupleSections #-} +{-# LANGUAGE TemplateHaskell, LambdaCase, CPP, ScopedTypeVariables, + TupleSections, DeriveDataTypeable, DeriveGeneric #-} module Language.Haskell.TH.Desugar.Core where @@ -15,19 +16,23 @@ import Language.Haskell.TH hiding (match, clause, cxt) import Language.Haskell.TH.Syntax hiding (lift) -import Language.Haskell.TH.ExpandSyns ( expandSyns ) +import Language.Haskell.TH.Datatype ( resolveTypeSynonyms ) #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import Control.Monad hiding (forM_, mapM) +import qualified Control.Monad.Fail as Fail import Control.Monad.Zip import Control.Monad.Writer hiding (forM_, mapM) -import Data.Foldable hiding (notElem) -import Data.Graph -import qualified Data.Map as Map +import Data.Data (Data, Typeable) +import Data.Either (lefts) +import Data.Foldable as F hiding (concat, notElem) +import qualified Data.Map as M import Data.Map (Map) -import qualified Data.Set as Set +import Data.Maybe (mapMaybe) +import qualified Data.Set as S +import Data.Set (Set) import Data.Traversable #if __GLASGOW_HASKELL__ > 710 import Data.Maybe (isJust) @@ -41,10 +46,17 @@ import GHC.OverloadedLabels ( fromLabel ) #endif -import qualified Data.Set as S +#if __GLASGOW_HASKELL__ >= 807 +import GHC.Classes (IP(..)) +#endif + import GHC.Exts +import GHC.Generics (Generic) import Language.Haskell.TH.Desugar.AST +import Language.Haskell.TH.Desugar.FV +import qualified Language.Haskell.TH.Desugar.OSet as OS +import Language.Haskell.TH.Desugar.OSet (OSet) import Language.Haskell.TH.Desugar.Util import Language.Haskell.TH.Desugar.Reify @@ -71,18 +83,18 @@ x <- newUniqueName "x" matches' <- dsMatches x matches return $ DLamE [x] (DCaseE (DVarE x) matches') -dsExp (TupE exps) = do - exps' <- mapM dsExp exps - return $ foldl DAppE (DConE $ tupleDataName (length exps)) exps' -dsExp (UnboxedTupE exps) = - foldl DAppE (DConE $ unboxedTupleDataName (length exps)) <$> mapM dsExp exps +dsExp (TupE exps) = dsTup tupleDataName exps +dsExp (UnboxedTupE exps) = dsTup unboxedTupleDataName exps dsExp (CondE e1 e2 e3) = dsExp (CaseE e1 [ Match (ConP 'True []) (NormalB e2) [] , Match (ConP 'False []) (NormalB e3) [] ]) dsExp (MultiIfE guarded_exps) = let failure = DAppE (DVarE 'error) (DLitE (StringL "Non-exhaustive guards in multi-way if")) in dsGuards guarded_exps failure -dsExp (LetE decs exp) = DLetE <$> dsLetDecs decs <*> dsExp exp +dsExp (LetE decs exp) = do + (decs', ip_binder) <- dsLetDecs decs + exp' <- dsExp exp + return $ DLetE decs' $ ip_binder exp' -- the following special case avoids creating a new "let" when it's not -- necessary. See #34. dsExp (CaseE (VarE scrutinee) matches) = do @@ -92,7 +104,7 @@ scrutinee <- newUniqueName "scrutinee" exp' <- dsExp exp matches' <- dsMatches scrutinee matches - return $ DLetE [DValD (DVarPa scrutinee) exp'] $ + return $ DLetE [DValD (DVarP scrutinee) exp'] $ DCaseE (DVarE scrutinee) matches' dsExp (DoE stmts) = dsDoStmts stmts dsExp (CompE stmts) = dsComp stmts @@ -194,7 +206,7 @@ rec_con_to_dmatch con_name args = do let con_field_names = map fst_of_3 args field_var_names <- mapM (newUniqueName . nameBase) con_field_names - DMatch (DConPa con_name (map DVarPa field_var_names)) <$> + DMatch (DConP con_name (map DVarP field_var_names)) <$> (foldl DAppE (DConE con_name) <$> (reorderFields con_name args field_exps (map DVarE field_var_names))) @@ -208,7 +220,7 @@ con_to_dmatch (ForallC _ _ c) = con_to_dmatch c con_to_dmatch _ = impossible "Internal error within th-desugar." - error_match = DMatch DWildPa (DAppE (DVarE 'error) + error_match = DMatch DWildP (DAppE (DVarE 'error) (DLitE (StringL "Non-exhaustive patterns in record update"))) fst_of_3 (x, _, _) = x @@ -226,7 +238,54 @@ #if __GLASGOW_HASKELL__ >= 803 dsExp (LabelE str) = return $ DVarE 'fromLabel `DAppTypeE` DLitT (StrTyLit str) #endif +#if __GLASGOW_HASKELL__ >= 807 +dsExp (ImplicitParamVarE n) = return $ DVarE 'ip `DAppTypeE` DLitT (StrTyLit n) +dsExp (MDoE {}) = fail "th-desugar currently does not support RecursiveDo" +#endif +#if __GLASGOW_HASKELL__ >= 809 +dsTup :: DsMonad q => (Int -> Name) -> [Maybe Exp] -> q DExp +dsTup = ds_tup +#else +dsTup :: DsMonad q => (Int -> Name) -> [Exp] -> q DExp +dsTup tuple_data_name = ds_tup tuple_data_name . map Just +#endif + +-- | Desugar a tuple (or tuple section) expression. +ds_tup :: forall q. DsMonad q + => (Int -> Name) -- ^ Compute the 'Name' of a tuple (boxed or unboxed) + -- data constructor from its arity. + -> [Maybe Exp] -- ^ The tuple's subexpressions. 'Nothing' entries + -- denote empty fields in a tuple section. + -> q DExp +ds_tup tuple_data_name mb_exps = do + section_exps <- mapM ds_section_exp mb_exps + let section_vars = lefts section_exps + tup_body = mk_tup_body section_exps + if null section_vars + then return tup_body -- If this isn't a tuple section, + -- don't create a lambda. + else dsLam (map VarP section_vars) tup_body + where + -- If dealing with an empty field in a tuple section (Nothing), create a + -- unique name and return Left. These names will be used to construct the + -- lambda expression that it desugars to. + -- (For example, `(,5)` desugars to `\ts -> (,) ts 5`.) + -- + -- If dealing with a tuple subexpression (Just), desugar it and return + -- Right. + ds_section_exp :: Maybe Exp -> q (Either Name DExp) + ds_section_exp = maybe (Left <$> qNewName "ts") (fmap Right . dsExp) + + mk_tup_body :: [Either Name DExp] -> DExp + mk_tup_body section_exps = + foldl' apply_tup_body (DConE $ tuple_data_name (length section_exps)) + section_exps + + apply_tup_body :: DExp -> Either Name DExp -> DExp + apply_tup_body f (Left n) = f `DAppE` DVarE n + apply_tup_body f (Right e) = f `DAppE` e + -- | Desugar a lambda expression, where the body has already been desugared dsLam :: DsMonad q => [Pat] -> DExp -> q DExp dsLam = mkLam stripVarP_maybe dsPatsOverExp @@ -235,11 +294,11 @@ -- 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)) +mkDLamEFromDPats = mkLam stripDVarP_maybe (\pats exp -> return (pats, exp)) where - stripDVarPa_maybe :: DPat -> Maybe Name - stripDVarPa_maybe (DVarPa n) = Just n - stripDVarPa_maybe _ = Nothing + stripDVarP_maybe :: DPat -> Maybe Name + stripDVarP_maybe (DVarP n) = Just n + stripDVarP_maybe _ = Nothing -- | Generalizes 'dsLam' and 'mkDLamEFromDPats' to work over an arbitrary -- pattern type. @@ -287,10 +346,14 @@ -> [Dec] -- ^ "where" declarations -> DExp -- ^ what to do if the guards don't match -> q DExp -dsBody (NormalB exp) decs _ = - maybeDLetE <$> dsLetDecs decs <*> dsExp exp -dsBody (GuardedB guarded_exps) decs failure = - maybeDLetE <$> dsLetDecs decs <*> dsGuards guarded_exps failure +dsBody (NormalB exp) decs _ = do + (decs', ip_binder) <- dsLetDecs decs + exp' <- dsExp exp + return $ maybeDLetE decs' $ ip_binder exp' +dsBody (GuardedB guarded_exps) decs failure = do + (decs', ip_binder) <- dsLetDecs decs + guarded_exp' <- dsGuards guarded_exps failure + return $ maybeDLetE decs' $ ip_binder guarded_exp' -- | If decs is non-empty, delcare them in a let: maybeDLetE :: [DLetDec] -> DExp -> DExp @@ -326,11 +389,11 @@ success' <- dsGuardStmts rest success failure (pat', success'') <- dsPatOverExp pat success' exp' <- dsExp exp - return $ DCaseE exp' [DMatch pat' success'', DMatch DWildPa failure] + return $ DCaseE exp' [DMatch pat' success'', DMatch DWildP failure] dsGuardStmts (LetS decs : rest) success failure = do - decs' <- dsLetDecs decs + (decs', ip_binder) <- dsLetDecs decs success' <- dsGuardStmts rest success failure - return $ DLetE decs' success' + return $ DLetE decs' $ ip_binder success' -- special-case a final pattern containing "otherwise" or "True" -- note that GHC does this special-casing, too, in DsGRHSs.isTrueLHsExpr dsGuardStmts [NoBindS exp] success _failure @@ -344,9 +407,12 @@ dsGuardStmts (NoBindS exp : rest) success failure = do exp' <- dsExp exp success' <- dsGuardStmts rest success failure - return $ DCaseE exp' [ DMatch (DConPa 'True []) success' - , DMatch (DConPa 'False []) failure ] + return $ DCaseE exp' [ DMatch (DConP 'True []) success' + , DMatch (DConP 'False []) failure ] dsGuardStmts (ParS _ : _) _ _ = impossible "Parallel comprehension in a pattern guard." +#if __GLASGOW_HASKELL__ >= 807 +dsGuardStmts (RecS {} : _) _ _ = fail "th-desugar currently does not support RecursiveDo" +#endif -- | Desugar the @Stmt@s in a @do@ expression dsDoStmts :: DsMonad q => [Stmt] -> q DExp @@ -355,12 +421,18 @@ dsDoStmts (BindS pat exp : rest) = do rest' <- dsDoStmts rest dsBindS exp pat rest' "do expression" -dsDoStmts (LetS decs : rest) = DLetE <$> dsLetDecs decs <*> dsDoStmts rest +dsDoStmts (LetS decs : rest) = do + (decs', ip_binder) <- dsLetDecs decs + rest' <- dsDoStmts rest + return $ DLetE decs' $ ip_binder rest' dsDoStmts (NoBindS exp : rest) = do exp' <- dsExp exp rest' <- dsDoStmts rest return $ DAppE (DAppE (DVarE '(>>)) exp') rest' dsDoStmts (ParS _ : _) = impossible "Parallel comprehension in a do-statement." +#if __GLASGOW_HASKELL__ >= 807 +dsDoStmts (RecS {} : _) = fail "th-desugar currently does not support RecursiveDo" +#endif -- | Desugar the @Stmt@s in a list or monad comprehension dsComp :: DsMonad q => [Stmt] -> q DExp @@ -369,7 +441,10 @@ dsComp (BindS pat exp : rest) = do rest' <- dsComp rest dsBindS exp pat rest' "monad comprehension" -dsComp (LetS decs : rest) = DLetE <$> dsLetDecs decs <*> dsComp rest +dsComp (LetS decs : rest) = do + (decs', ip_binder) <- dsLetDecs decs + rest' <- dsComp rest + return $ DLetE decs' $ ip_binder rest' dsComp (NoBindS exp : rest) = do exp' <- dsExp exp rest' <- dsComp rest @@ -378,6 +453,9 @@ (pat, exp) <- dsParComp stmtss rest' <- dsComp rest DAppE (DAppE (DVarE '(>>=)) exp) <$> dsLam [pat] rest' +#if __GLASGOW_HASKELL__ >= 807 +dsComp (RecS {} : _) = fail "th-desugar currently does not support RecursiveDo" +#endif -- Desugar a binding statement in a do- or list comprehension. -- @@ -398,13 +476,19 @@ fail_name <- mk_fail_name return $ bind_into $ DLamE [arg_name] $ DCaseE (DVarE arg_name) [ DMatch success_pat' success_exp' - , DMatch DWildPa $ + , DMatch DWildP $ DVarE fail_name `DAppE` DLitE (StringL $ "Pattern match failure in " ++ ctxt) ] where mk_fail_name :: q Name -#if __GLASGOW_HASKELL__ >= 800 +#if __GLASGOW_HASKELL__ >= 807 + -- GHC 8.8 deprecates the MonadFailDesugaring extension since its effects + -- are always enabled. Furthermore, MonadFailDesugaring is no longer + -- enabled by default, so simply use MonadFail.fail. (That happens to + -- be the same as Prelude.fail in 8.8+.) + mk_fail_name = return 'MonadFail.fail +#elif __GLASGOW_HASKELL__ >= 800 mk_fail_name = do mfd <- qIsExtEnabled MonadFailDesugaring return $ if mfd then 'MonadFail.fail else 'Prelude.fail @@ -429,28 +513,28 @@ return (ConP (tupleDataName 2) [mk_tuple_pat qv, rest_pat], zipped) -- helper function for dsParComp -mk_tuple_stmt :: S.Set Name -> Stmt +mk_tuple_stmt :: OSet Name -> Stmt mk_tuple_stmt name_set = - NoBindS (mkTupleExp (S.foldr ((:) . VarE) [] name_set)) + NoBindS (mkTupleExp (F.foldr ((:) . VarE) [] name_set)) -- helper function for dsParComp -mk_tuple_pat :: S.Set Name -> Pat +mk_tuple_pat :: OSet Name -> Pat mk_tuple_pat name_set = - mkTuplePat (S.foldr ((:) . VarP) [] name_set) + mkTuplePat (F.foldr ((:) . VarP) [] name_set) -- | Desugar a pattern, along with processing a (desugared) expression that -- is the entire scope of the variables bound in the pattern. dsPatOverExp :: DsMonad q => Pat -> DExp -> q (DPat, DExp) dsPatOverExp pat exp = do (pat', vars) <- runWriterT $ dsPat pat - let name_decs = uncurry (zipWith (DValD . DVarPa)) $ unzip vars + let name_decs = uncurry (zipWith (DValD . DVarP)) $ unzip vars return (pat', maybeDLetE name_decs exp) -- | Desugar multiple patterns. Like 'dsPatOverExp'. dsPatsOverExp :: DsMonad q => [Pat] -> DExp -> q ([DPat], DExp) dsPatsOverExp pats exp = do (pats', vars) <- runWriterT $ mapM dsPat pats - let name_decs = uncurry (zipWith (DValD . DVarPa)) $ unzip vars + let name_decs = uncurry (zipWith (DValD . DVarP)) $ unzip vars return (pats', maybeDLetE name_decs exp) -- | Desugar a pattern, returning a list of (Name, DExp) pairs of extra @@ -465,28 +549,28 @@ -- | Desugar a pattern. dsPat :: DsMonad q => Pat -> PatM q DPat -dsPat (LitP lit) = return $ DLitPa lit -dsPat (VarP n) = return $ DVarPa n -dsPat (TupP pats) = DConPa (tupleDataName (length pats)) <$> mapM dsPat pats -dsPat (UnboxedTupP pats) = DConPa (unboxedTupleDataName (length pats)) <$> +dsPat (LitP lit) = return $ DLitP lit +dsPat (VarP n) = return $ DVarP n +dsPat (TupP pats) = DConP (tupleDataName (length pats)) <$> mapM dsPat pats +dsPat (UnboxedTupP pats) = DConP (unboxedTupleDataName (length pats)) <$> mapM dsPat pats -dsPat (ConP name pats) = DConPa name <$> mapM dsPat pats -dsPat (InfixP p1 name p2) = DConPa name <$> mapM dsPat [p1, p2] +dsPat (ConP name pats) = DConP name <$> mapM dsPat pats +dsPat (InfixP p1 name p2) = DConP name <$> mapM dsPat [p1, p2] dsPat (UInfixP _ _ _) = fail "Cannot desugar unresolved infix operators." dsPat (ParensP pat) = dsPat pat -dsPat (TildeP pat) = DTildePa <$> dsPat pat -dsPat (BangP pat) = DBangPa <$> dsPat pat +dsPat (TildeP pat) = DTildeP <$> dsPat pat +dsPat (BangP pat) = DBangP <$> dsPat pat dsPat (AsP name pat) = do pat' <- dsPat pat pat'' <- lift $ removeWilds pat' tell [(name, dPatToDExp pat'')] return pat'' -dsPat WildP = return DWildPa +dsPat WildP = return DWildP dsPat (RecP con_name field_pats) = do con <- lift $ dataConNameToCon con_name reordered <- reorder con - return $ DConPa con_name reordered + return $ DConP con_name reordered where reorder con = case con of NormalC _name fields -> non_record fields @@ -507,54 +591,45 @@ -- no records are given in the pattern itself. (See #59). -- -- Con{} desugars down to Con _ ... _. - = return $ replicate (length fields) DWildPa + = return $ replicate (length fields) DWildP | otherwise = lift $ impossible $ "Record syntax used with non-record constructor " ++ (show con_name) ++ "." dsPat (ListP pats) = go pats - where go [] = return $ DConPa '[] [] + where go [] = return $ DConP '[] [] go (h : t) = do h' <- dsPat h t' <- go t - return $ DConPa '(:) [h', t'] -dsPat (SigP pat ty) = DSigPa <$> dsPat pat <*> dsType ty + return $ DConP '(:) [h', t'] +dsPat (SigP pat ty) = DSigP <$> dsPat pat <*> dsType ty #if __GLASGOW_HASKELL__ >= 801 dsPat (UnboxedSumP pat alt arity) = - DConPa (unboxedSumDataName alt arity) <$> ((:[]) <$> dsPat pat) + DConP (unboxedSumDataName alt arity) <$> ((:[]) <$> dsPat pat) #endif dsPat (ViewP _ _) = fail "View patterns are not supported in th-desugar. Use pattern guards instead." -- | Convert a 'DPat' to a 'DExp'. Fails on 'DWildP'. dPatToDExp :: DPat -> DExp -dPatToDExp (DLitPa lit) = DLitE lit -dPatToDExp (DVarPa name) = DVarE name -dPatToDExp (DConPa name pats) = foldl DAppE (DConE name) (map dPatToDExp pats) -dPatToDExp (DTildePa pat) = dPatToDExp pat -dPatToDExp (DBangPa pat) = dPatToDExp pat -dPatToDExp (DSigPa pat ty) = DSigE (dPatToDExp pat) ty -dPatToDExp DWildPa = error "Internal error in th-desugar: wildcard in rhs of as-pattern" +dPatToDExp (DLitP lit) = DLitE lit +dPatToDExp (DVarP name) = DVarE name +dPatToDExp (DConP name pats) = foldl DAppE (DConE name) (map dPatToDExp pats) +dPatToDExp (DTildeP pat) = dPatToDExp pat +dPatToDExp (DBangP pat) = dPatToDExp pat +dPatToDExp (DSigP pat ty) = DSigE (dPatToDExp pat) ty +dPatToDExp DWildP = error "Internal error in th-desugar: wildcard in rhs of as-pattern" -- | Remove all wildcards from a pattern, replacing any wildcard with a fresh -- variable removeWilds :: DsMonad q => DPat -> q DPat -removeWilds p@(DLitPa _) = return p -removeWilds p@(DVarPa _) = return p -removeWilds (DConPa con_name pats) = DConPa con_name <$> mapM removeWilds pats -removeWilds (DTildePa pat) = DTildePa <$> removeWilds pat -removeWilds (DBangPa pat) = DBangPa <$> removeWilds pat -removeWilds (DSigPa pat ty) = DSigPa <$> removeWilds pat <*> pure ty -removeWilds DWildPa = DVarPa <$> newUniqueName "wild" - -extractBoundNamesDPat :: DPat -> S.Set Name -extractBoundNamesDPat (DLitPa _) = S.empty -extractBoundNamesDPat (DVarPa n) = S.singleton n -extractBoundNamesDPat (DConPa _ pats) = S.unions (map extractBoundNamesDPat pats) -extractBoundNamesDPat (DTildePa p) = extractBoundNamesDPat p -extractBoundNamesDPat (DBangPa p) = extractBoundNamesDPat p -extractBoundNamesDPat (DSigPa p _) = extractBoundNamesDPat p -extractBoundNamesDPat DWildPa = S.empty +removeWilds p@(DLitP _) = return p +removeWilds p@(DVarP _) = return p +removeWilds (DConP con_name pats) = DConP con_name <$> mapM removeWilds pats +removeWilds (DTildeP pat) = DTildeP <$> removeWilds pat +removeWilds (DBangP pat) = DBangP <$> removeWilds pat +removeWilds (DSigP pat ty) = DSigP <$> removeWilds pat <*> pure ty +removeWilds DWildP = DVarP <$> newUniqueName "wild" -- | Desugar @Info@ dsInfo :: DsMonad q => Info -> q DInfo @@ -574,9 +649,7 @@ dsInfo (FamilyI dec instances) = do [ddec] <- dsDec dec dinstances <- dsDecs instances - (ddec', num_args) <- fixBug8884ForFamilies ddec - let dinstances' = map (fixBug8884ForInstances num_args) dinstances - return $ DTyConI ddec' (Just dinstances') + return $ DTyConI ddec (Just dinstances) dsInfo (PrimTyConI name arity unlifted) = return $ DPrimTyConI name arity unlifted #if __GLASGOW_HASKELL__ > 710 @@ -599,92 +672,24 @@ dsInfo (PatSynI name ty) = DPatSynI name <$> dsType ty #endif -fixBug8884ForFamilies :: DsMonad q => DDec -> q (DDec, Int) -#if __GLASGOW_HASKELL__ < 708 -fixBug8884ForFamilies (DOpenTypeFamilyD (DTypeFamilyHead name tvbs frs ann)) = do - let num_args = length tvbs - frs' <- remove_arrows num_args frs - return (DOpenTypeFamilyD (DTypeFamilyHead name tvbs frs' ann),num_args) -fixBug8884ForFamilies (DClosedTypeFamilyD (DTypeFamilyHead name tvbs frs ann) eqns) = do - let num_args = length tvbs - 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 _ _ _) - = 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 - -remove_arrows :: DsMonad q => Int -> DFamilyResultSig -> q DFamilyResultSig -remove_arrows n (DKindSig k) = DKindSig <$> remove_arrows_kind n k -remove_arrows n (DTyVarSig (DKindedTV nm k)) = - DTyVarSig <$> (DKindedTV nm <$> remove_arrows_kind n k) -remove_arrows _ frs = return frs - -remove_arrows_kind :: DsMonad q => Int -> DKind -> q DKind -remove_arrows_kind 0 k = return k -remove_arrows_kind n (DAppT (DAppT DArrowT _) k) = remove_arrows_kind (n-1) k -remove_arrows_kind _ _ = - impossible "Internal error: Fix for bug 8884 ran out of arrows." - -#else -fixBug8884ForFamilies dec = return (dec, 0) -- return value ignored -#endif - -fixBug8884ForInstances :: Int -> DDec -> DDec -fixBug8884ForInstances num_args (DTySynInstD name eqn) = - DTySynInstD name (fixBug8884ForEqn num_args eqn) -fixBug8884ForInstances _ dec = dec - -fixBug8884ForEqn :: Int -> DTySynEqn -> DTySynEqn -#if __GLASGOW_HASKELL__ < 708 -fixBug8884ForEqn num_args (DTySynEqn lhs rhs) = - let lhs' = drop (length lhs - num_args) lhs in - DTySynEqn lhs' rhs -#else -fixBug8884ForEqn _ = id -#endif - -- | Desugar arbitrary @Dec@s dsDecs :: DsMonad q => [Dec] -> q [DDec] dsDecs = concatMapM dsDec -- | Desugar a single @Dec@, perhaps producing multiple 'DDec's dsDec :: DsMonad q => Dec -> q [DDec] -dsDec d@(FunD {}) = (fmap . map) DLetDec $ dsLetDec d -dsDec d@(ValD {}) = (fmap . map) DLetDec $ dsLetDec d +dsDec d@(FunD {}) = dsTopLevelLetDec d +dsDec d@(ValD {}) = dsTopLevelLetDec d #if __GLASGOW_HASKELL__ > 710 -dsDec (DataD cxt n tvbs mk cons derivings) = do - tvbs' <- mapM dsTvb tvbs - all_tvbs <- nonFamilyDataTvbs tvbs' mk - let data_type = nonFamilyDataReturnType n all_tvbs - (:[]) <$> (DDataD Data <$> dsCxt cxt <*> pure n - <*> pure tvbs' <*> mapM dsType mk - <*> concatMapM (dsCon tvbs' data_type) cons - <*> mapM dsDerivClause derivings) -dsDec (NewtypeD cxt n tvbs mk con derivings) = do - tvbs' <- mapM dsTvb tvbs - all_tvbs <- nonFamilyDataTvbs tvbs' mk - let data_type = nonFamilyDataReturnType n all_tvbs - (:[]) <$> (DDataD Newtype <$> dsCxt cxt <*> pure n - <*> pure tvbs' <*> mapM dsType mk - <*> dsCon tvbs' data_type con - <*> mapM dsDerivClause derivings) +dsDec (DataD cxt n tvbs mk cons derivings) = + dsDataDec Data cxt n tvbs mk cons derivings +dsDec (NewtypeD cxt n tvbs mk con derivings) = + dsDataDec Newtype cxt n tvbs mk [con] derivings #else -dsDec (DataD cxt n tvbs cons derivings) = do - tvbs' <- mapM dsTvb tvbs - let data_type = nonFamilyDataReturnType n tvbs' - (:[]) <$> (DDataD Data <$> dsCxt cxt <*> pure n - <*> pure tvbs' <*> pure Nothing - <*> concatMapM (dsCon tvbs' data_type) cons - <*> mapM dsDerivClause 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 - <*> pure tvbs' <*> pure Nothing - <*> dsCon tvbs' data_type con - <*> mapM dsDerivClause derivings) +dsDec (DataD cxt n tvbs cons derivings) = + dsDataDec Data cxt n tvbs Nothing cons derivings +dsDec (NewtypeD cxt n tvbs con derivings) = + dsDataDec Newtype cxt n tvbs Nothing [con] derivings #endif dsDec (TySynD n tvbs ty) = (:[]) <$> (DTySynD n <$> mapM dsTvb tvbs <*> dsType ty) @@ -693,15 +698,15 @@ <*> pure fds <*> dsDecs decs) #if __GLASGOW_HASKELL__ >= 711 dsDec (InstanceD over cxt ty decs) = - (:[]) <$> (DInstanceD <$> pure over <*> dsCxt cxt <*> dsType ty <*> dsDecs decs) + (:[]) <$> (DInstanceD over Nothing <$> dsCxt cxt <*> dsType ty <*> dsDecs decs) #else dsDec (InstanceD cxt ty decs) = - (:[]) <$> (DInstanceD <$> pure Nothing <*> dsCxt cxt <*> dsType ty <*> dsDecs decs) + (:[]) <$> (DInstanceD Nothing Nothing <$> dsCxt cxt <*> dsType ty <*> dsDecs decs) #endif -dsDec d@(SigD {}) = (fmap . map) DLetDec $ dsLetDec d +dsDec d@(SigD {}) = dsTopLevelLetDec d dsDec (ForeignD f) = (:[]) <$> (DForeignD <$> dsForeign f) -dsDec d@(InfixD {}) = (fmap . map) DLetDec $ dsLetDec d -dsDec d@(PragmaD {}) = (fmap . map) DLetDec $ dsLetDec d +dsDec d@(InfixD {}) = dsTopLevelLetDec d +dsDec d@(PragmaD {}) = dsTopLevelLetDec d #if __GLASGOW_HASKELL__ > 710 dsDec (OpenTypeFamilyD tfHead) = (:[]) <$> (DOpenTypeFamilyD <$> dsTypeFamilyHead tfHead) @@ -713,60 +718,41 @@ 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 - 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 - <*> pure tys' <*> mapM dsType mk - <*> concatMapM (dsCon tvbs fam_inst_type) cons - <*> mapM dsDerivClause derivings) -dsDec (NewtypeInstD cxt n tys mk con derivings) = do - 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 - <*> pure tys' <*> mapM dsType mk - <*> dsCon tvbs fam_inst_type con - <*> mapM dsDerivClause derivings) +#if __GLASGOW_HASKELL__ >= 807 +dsDec (DataInstD cxt mtvbs lhs mk cons derivings) = + case unfoldType lhs of + (ConT n, tys) -> dsDataInstDec Data cxt n mtvbs tys mk cons derivings + (_, _) -> fail $ "Unexpected data instance LHS: " ++ pprint lhs +dsDec (NewtypeInstD cxt mtvbs lhs mk con derivings) = + case unfoldType lhs of + (ConT n, tys) -> dsDataInstDec Newtype cxt n mtvbs tys mk [con] derivings + (_, _) -> fail $ "Unexpected newtype instance LHS: " ++ pprint lhs +#elif __GLASGOW_HASKELL__ > 710 +dsDec (DataInstD cxt n tys mk cons derivings) = + dsDataInstDec Data cxt n Nothing (map TANormal tys) mk cons derivings +dsDec (NewtypeInstD cxt n tys mk con derivings) = + dsDataInstDec Newtype cxt n Nothing (map TANormal tys) mk [con] derivings #else -dsDec (DataInstD cxt n tys cons derivings) = do - 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 - 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) +dsDec (DataInstD cxt n tys cons derivings) = + dsDataInstDec Data cxt n Nothing (map TANormal tys) Nothing cons derivings +dsDec (NewtypeInstD cxt n tys con derivings) = + dsDataInstDec Newtype cxt n Nothing (map TANormal tys) Nothing [con] derivings #endif -#if __GLASGOW_HASKELL__ < 707 -dsDec (TySynInstD n lhs rhs) = (:[]) <$> (DTySynInstD n <$> - (DTySynEqn <$> mapM dsType lhs - <*> dsType rhs)) +#if __GLASGOW_HASKELL__ >= 807 +dsDec (TySynInstD eqn) = (:[]) <$> (DTySynInstD <$> dsTySynEqn unusedArgument eqn) #else -dsDec (TySynInstD n eqn) = (:[]) <$> (DTySynInstD n <$> dsTySynEqn eqn) +dsDec (TySynInstD n eqn) = (:[]) <$> (DTySynInstD <$> dsTySynEqn n eqn) +#endif #if __GLASGOW_HASKELL__ > 710 dsDec (ClosedTypeFamilyD tfHead eqns) = (:[]) <$> (DClosedTypeFamilyD <$> dsTypeFamilyHead tfHead - <*> mapM dsTySynEqn eqns) + <*> mapM (dsTySynEqn (typeFamilyHeadName tfHead)) eqns) #else dsDec (ClosedTypeFamilyD n tvbs m_k eqns) = do (:[]) <$> (DClosedTypeFamilyD <$> dsTypeFamilyHead n tvbs m_k - <*> mapM dsTySynEqn eqns) + <*> mapM (dsTySynEqn n) eqns) #endif dsDec (RoleAnnotD n roles) = return [DRoleAnnotD n roles] -#endif #if __GLASGOW_HASKELL__ >= 709 #if __GLASGOW_HASKELL__ >= 801 dsDec (PatSynD n args dir pat) = do @@ -777,19 +763,66 @@ return [DPatSynD n args dir' pat'] dsDec (PatSynSigD n ty) = (:[]) <$> (DPatSynSigD n <$> dsType ty) dsDec (StandaloneDerivD mds cxt ty) = - (:[]) <$> (DStandaloneDerivD <$> mapM dsDerivStrategy mds <*> dsCxt cxt <*> dsType ty) + (:[]) <$> (DStandaloneDerivD <$> mapM dsDerivStrategy mds + <*> pure Nothing <*> dsCxt cxt <*> dsType ty) #else dsDec (StandaloneDerivD cxt ty) = - (:[]) <$> (DStandaloneDerivD Nothing <$> dsCxt cxt <*> dsType ty) + (:[]) <$> (DStandaloneDerivD Nothing Nothing <$> dsCxt cxt <*> dsType ty) #endif dsDec (DefaultSigD n ty) = (:[]) <$> (DDefaultSigD n <$> dsType ty) #endif +#if __GLASGOW_HASKELL__ >= 807 +dsDec (ImplicitParamBindD {}) = impossible "Non-`let`-bound implicit param binding" +#endif +-- | Desugar a 'DataD' or 'NewtypeD'. +dsDataDec :: DsMonad q + => NewOrData -> Cxt -> Name -> [TyVarBndr] + -> Maybe Kind -> [Con] -> [DerivingClause] -> q [DDec] +dsDataDec nd cxt n tvbs mk cons derivings = do + tvbs' <- mapM dsTvb tvbs + let h98_tvbs = case mk of + -- If there's an explicit return kind, we're dealing with a + -- GADT, so this argument goes unused in dsCon. + Just {} -> unusedArgument + Nothing -> tvbs' + h98_return_type = nonFamilyDataReturnType n tvbs' + (:[]) <$> (DDataD nd <$> dsCxt cxt <*> pure n + <*> pure tvbs' <*> mapM dsType mk + <*> concatMapM (dsCon h98_tvbs h98_return_type) cons + <*> mapM dsDerivClause derivings) + +-- | Desugar a 'DataInstD' or a 'NewtypeInstD'. +dsDataInstDec :: DsMonad q + => NewOrData -> Cxt -> Name -> Maybe [TyVarBndr] -> [TypeArg] + -> Maybe Kind -> [Con] -> [DerivingClause] -> q [DDec] +dsDataInstDec nd cxt n mtvbs tys mk cons derivings = do + mtvbs' <- mapM (mapM dsTvb) mtvbs + tys' <- mapM dsTypeArg tys + let lhs' = applyDType (DConT n) tys' + h98_tvbs = + case (mk, mtvbs') of + -- If there's an explicit return kind, we're dealing with a + -- GADT, so this argument goes unused in dsCon. + (Just {}, _) -> unusedArgument + -- H98, and there is an explicit `forall` in front. Just reuse the + -- type variable binders from the `forall`. + (Nothing, Just tvbs') -> tvbs' + -- H98, and no explicit `forall`. Compute the bound variables + -- manually. + (Nothing, Nothing) -> dataFamInstTvbs tys' + h98_fam_inst_type = dataFamInstReturnType n tys' + (:[]) <$> (DDataInstD nd <$> dsCxt cxt <*> pure mtvbs' + <*> pure lhs' <*> mapM dsType mk + <*> concatMapM (dsCon h98_tvbs h98_fam_inst_type) cons + <*> mapM dsDerivClause derivings) + -- 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' + maybe (pure (DConT typeKindName)) (runQ . resolveTypeSynonyms >=> dsType) + >=> mkExtraDKindBinders' -- | Like mkExtraDKindBinders, but assumes kind synonyms have been expanded. mkExtraDKindBinders' :: Quasi q => DKind -> q [DTyVarBndr] @@ -808,6 +841,9 @@ = DTypeFamilyHead n <$> mapM dsTvb tvbs <*> dsFamilyResultSig result <*> pure inj + +typeFamilyHeadName :: TypeFamilyHead -> Name +typeFamilyHeadName (TypeFamilyHead n _ _ _) = n #else -- | Desugar bits and pieces into a 'DTypeFamilyHead' dsTypeFamilyHead :: DsMonad q @@ -821,30 +857,95 @@ <*> pure Nothing #endif --- | Desugar @Dec@s that can appear in a let expression -dsLetDecs :: DsMonad q => [Dec] -> q [DLetDec] -dsLetDecs = concatMapM dsLetDec +-- | Desugar @Dec@s that can appear in a @let@ expression. See the +-- documentation for 'dsLetDec' for an explanation of what the return type +-- represents. +dsLetDecs :: DsMonad q => [Dec] -> q ([DLetDec], DExp -> DExp) +dsLetDecs decs = do + (let_decss, ip_binders) <- mapAndUnzipM dsLetDec decs + let let_decs :: [DLetDec] + let_decs = concat let_decss --- | Desugar a single @Dec@, perhaps producing multiple 'DLetDec's -dsLetDec :: DsMonad q => Dec -> q [DLetDec] + ip_binder :: DExp -> DExp + ip_binder = foldr (.) id ip_binders + return (let_decs, ip_binder) + +-- | Desugar a single 'Dec' that can appear in a @let@ expression. +-- This produces the following output: +-- +-- * One or more 'DLetDec's (a single 'Dec' can produce multiple 'DLetDec's +-- in the event of a value declaration that binds multiple things by way +-- of pattern matching. +-- +-- * A function of type @'DExp' -> 'DExp'@, which should be applied to the +-- expression immediately following the 'DLetDec's. This function prepends +-- binding forms for any implicit params that were bound in the argument +-- 'Dec'. (If no implicit params are bound, this is simply the 'id' +-- function.) +-- +-- For instance, if the argument to 'dsLetDec' is the @?x = 42@ part of this +-- expression: +-- +-- @ +-- let { ?x = 42 } in ?x +-- @ +-- +-- Then the output is: +-- +-- * @let new_x_val = 42@ +-- +-- * @\\z -> 'bindIP' \@\"x\" new_x_val z@ +-- +-- This way, the expression +-- @let { new_x_val = 42 } in 'bindIP' \@"x" new_x_val ('ip' \@\"x\")@ can be +-- formed. The implicit param binders always come after all the other +-- 'DLetDec's to support parallel assignment of implicit params. +dsLetDec :: DsMonad q => Dec -> q ([DLetDec], DExp -> DExp) dsLetDec (FunD name clauses) = do clauses' <- dsClauses name clauses - return [DFunD name clauses'] + return ([DFunD name clauses'], id) dsLetDec (ValD pat body where_decs) = do (pat', vars) <- dsPatX pat body' <- dsBody body where_decs error_exp - let extras = uncurry (zipWith (DValD . DVarPa)) $ unzip vars - return $ DValD pat' body' : extras + let extras = uncurry (zipWith (DValD . DVarP)) $ unzip vars + return (DValD pat' body' : extras, id) where error_exp = DAppE (DVarE 'error) (DLitE (StringL $ "Non-exhaustive patterns for " ++ pprint pat)) dsLetDec (SigD name ty) = do ty' <- dsType ty - return [DSigD name ty'] -dsLetDec (InfixD fixity name) = return [DInfixD fixity name] -dsLetDec (PragmaD prag) = (:[]) <$> (DPragmaD <$> dsPragma prag) + return ([DSigD name ty'], id) +dsLetDec (InfixD fixity name) = return ([DInfixD fixity name], id) +dsLetDec (PragmaD prag) = do + prag' <- dsPragma prag + return ([DPragmaD prag'], id) +#if __GLASGOW_HASKELL__ >= 807 +dsLetDec (ImplicitParamBindD n e) = do + new_n_name <- qNewName $ "new_" ++ n ++ "_val" + e' <- dsExp e + let let_dec :: DLetDec + let_dec = DValD (DVarP new_n_name) e' + + ip_binder :: DExp -> DExp + ip_binder = (DVarE 'bindIP `DAppTypeE` + DLitT (StrTyLit n) `DAppE` + DVarE new_n_name `DAppE`) + return ([let_dec], ip_binder) +#endif dsLetDec _dec = impossible "Illegal declaration in let expression." +-- | Desugar a single 'Dec' corresponding to something that could appear after +-- the @let@ in a @let@ expression, but occurring at the top level. Because the +-- 'Dec' occurs at the top level, there is nothing that would correspond to the +-- @in ...@ part of the @let@ expression. As a consequence, this function does +-- not return a @'DExp' -> 'DExp'@ function corresonding to implicit param +-- binders (these cannot occur at the top level). +dsTopLevelLetDec :: DsMonad q => Dec -> q [DDec] +dsTopLevelLetDec = fmap (map DLetDec . fst) . dsLetDec + -- Note the use of fst above: we're silently throwing away any implicit param + -- binders that dsLetDec returns, since there is invariant that there will be + -- no implicit params in the first place. + -- | Desugar a single @Con@. -- -- Because we always desugar @Con@s to GADT syntax (see the documentation for @@ -878,8 +979,10 @@ 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 + let ex_dtvbs = dtvbs + expl_dtvbs = univ_dtvbs ++ ex_dtvbs + impl_dtvbs = toposortTyVarsOf $ mapMaybe extractTvbKind expl_dtvbs in + DCon (impl_dtvbs ++ expl_dtvbs) dcxt n fields data_type Just gadt_type -> let univ_ex_dtvbs = dtvbs in DCon univ_ex_dtvbs dcxt n fields gadt_type @@ -961,13 +1064,21 @@ <*> pure m_inl <*> pure phases dsPragma (SpecialiseInstP ty) = DSpecialiseInstP <$> dsType ty -dsPragma (RuleP str rbs lhs rhs phases) = DRuleP str <$> mapM dsRuleBndr rbs +#if __GLASGOW_HASKELL__ >= 807 +dsPragma (RuleP str mtvbs rbs lhs rhs phases) + = DRuleP str <$> mapM (mapM dsTvb) mtvbs + <*> mapM dsRuleBndr rbs <*> dsExp lhs <*> dsExp rhs <*> pure phases -#if __GLASGOW_HASKELL__ >= 707 -dsPragma (AnnP target exp) = DAnnP target <$> dsExp exp +#else +dsPragma (RuleP str rbs lhs rhs phases) = DRuleP str Nothing + <$> mapM dsRuleBndr rbs + <*> dsExp lhs + <*> dsExp rhs + <*> pure phases #endif +dsPragma (AnnP target exp) = DAnnP target <$> dsExp exp #if __GLASGOW_HASKELL__ >= 709 dsPragma (LineP n str) = return $ DLineP n str #endif @@ -980,10 +1091,21 @@ dsRuleBndr (RuleVar n) = return $ DRuleVar n dsRuleBndr (TypedRuleVar n ty) = DTypedRuleVar n <$> dsType ty -#if __GLASGOW_HASKELL__ >= 707 +#if __GLASGOW_HASKELL__ >= 807 -- | Desugar a @TySynEqn@. (Available only with GHC 7.8+) -dsTySynEqn :: DsMonad q => TySynEqn -> q DTySynEqn -dsTySynEqn (TySynEqn lhs rhs) = DTySynEqn <$> mapM dsType lhs <*> dsType rhs +-- +-- This requires a 'Name' as an argument since 'TySynEqn's did not have +-- this information prior to GHC 8.8. +dsTySynEqn :: DsMonad q => Name -> TySynEqn -> q DTySynEqn +dsTySynEqn _ (TySynEqn mtvbs lhs rhs) = + DTySynEqn <$> mapM (mapM dsTvb) mtvbs <*> dsType lhs <*> dsType rhs +#else +-- | Desugar a @TySynEqn@. (Available only with GHC 7.8+) +dsTySynEqn :: DsMonad q => Name -> TySynEqn -> q DTySynEqn +dsTySynEqn n (TySynEqn lhss rhs) = do + lhss' <- mapM dsType lhss + let lhs' = applyDType (DConT n) $ map DTANormal lhss' + DTySynEqn Nothing lhs' <$> dsType rhs #endif -- | Desugar clauses to a function definition @@ -996,14 +1118,14 @@ -- this case is necessary to maintain the roundtrip property. rest' <- dsClauses n rest exp' <- dsExp exp - where_decs' <- dsLetDecs where_decs - let exp_with_wheres = maybeDLetE where_decs' exp' + (where_decs', ip_binder) <- dsLetDecs where_decs + let exp_with_wheres = maybeDLetE where_decs' (ip_binder exp') (pats', exp'') <- dsPatsOverExp pats exp_with_wheres return $ DClause pats' exp'' : rest' dsClauses n clauses@(Clause outer_pats _ _ : _) = do arg_names <- replicateM (length outer_pats) (newUniqueName "arg") let scrutinee = mkTupleDExp (map DVarE arg_names) - clause <- DClause (map DVarPa arg_names) <$> + clause <- DClause (map DVarP arg_names) <$> (DCaseE scrutinee <$> foldrM (clause_to_dmatch scrutinee) [] clauses) return [clause] where @@ -1053,6 +1175,12 @@ #if __GLASGOW_HASKELL__ >= 801 dsType (UnboxedSumT arity) = return $ DConT (unboxedSumTypeName arity) #endif +#if __GLASGOW_HASKELL__ >= 807 +dsType (AppKindT t k) = DAppKindT <$> dsType t <*> dsType k +dsType (ImplicitParamT n t) = do + t' <- dsType t + return $ DConT ''IP `DAppT` DLitT (StrTyLit n) `DAppT` t' +#endif -- | Desugar a @TyVarBndr@ dsTvb :: DsMonad q => TyVarBndr -> q DTyVarBndr @@ -1064,16 +1192,25 @@ dsCxt = concatMapM dsPred #if __GLASGOW_HASKELL__ >= 801 --- | Desugar a @DerivClause@. -dsDerivClause :: DsMonad q => DerivClause -> q DDerivClause +-- | A backwards-compatible type synonym for the thing representing a single +-- derived class in a @deriving@ clause. (This is a @DerivClause@, @Pred@, or +-- @Name@ depending on the GHC version.) +type DerivingClause = DerivClause + +-- | Desugar a @DerivingClause@. +dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause dsDerivClause (DerivClause mds cxt) = DDerivClause <$> mapM dsDerivStrategy mds <*> dsCxt cxt #elif __GLASGOW_HASKELL__ >= 711 -dsDerivClause :: DsMonad q => Pred -> q DDerivClause +type DerivingClause = Pred + +dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause dsDerivClause p = DDerivClause Nothing <$> dsPred p #else -dsDerivClause :: DsMonad q => Name -> q DDerivClause -dsDerivClause n = pure $ DDerivClause Nothing [DConPr n] +type DerivingClause = Name + +dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause +dsDerivClause n = pure $ DDerivClause Nothing [DConT n] #endif #if __GLASGOW_HASKELL__ >= 801 @@ -1100,10 +1237,10 @@ #if __GLASGOW_HASKELL__ < 709 dsPred (ClassP n tys) = do ts' <- mapM dsType tys - return [foldl DAppPr (DConPr n) ts'] + return [foldl DAppT (DConT n) ts'] dsPred (EqualP t1 t2) = do ts' <- mapM dsType [t1, t2] - return [foldl DAppPr (DConPr ''(~)) ts'] + return [foldl DAppT (DConT ''(~)) ts'] #else dsPred t | Just ts <- splitTuple_maybe t @@ -1111,22 +1248,22 @@ dsPred (ForallT tvbs cxt p) = do ps' <- dsPred p case ps' of - [p'] -> (:[]) <$> (DForallPr <$> mapM dsTvb tvbs <*> dsCxt cxt <*> pure p') + [p'] -> (:[]) <$> (DForallT <$> 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 + (:[]) <$> DAppT p1 <$> dsType t2 dsPred (SigT ty ki) = do preds <- dsPred ty case preds of - [p] -> (:[]) <$> DSigPr p <$> dsType ki + [p] -> (:[]) <$> DSigT p <$> dsType ki other -> return other -- just drop the kind signature on a tuple. -dsPred (VarT n) = return [DVarPr n] -dsPred (ConT n) = return [DConPr n] +dsPred (VarT n) = return [DVarT n] +dsPred (ConT n) = return [DConT n] dsPred t@(PromotedT _) = impossible $ "Promoted type seen as head of constraint: " ++ show t -dsPred (TupleT 0) = return [DConPr (tupleTypeName 0)] +dsPred (TupleT 0) = return [DConT (tupleTypeName 0)] dsPred (TupleT _) = impossible "Internal error in th-desugar in detecting tuple constraints." dsPred t@(UnboxedTupleT _) = @@ -1142,18 +1279,26 @@ impossible "The kind `Constraint' seen as head of constraint." dsPred t@(LitT _) = impossible $ "Type literal seen as head of constraint: " ++ show t -dsPred EqualityT = return [DConPr ''(~)] +dsPred EqualityT = return [DConT ''(~)] #if __GLASGOW_HASKELL__ > 710 -dsPred (InfixT t1 n t2) = (:[]) <$> (DAppPr <$> (DAppPr (DConPr n) <$> dsType t1) <*> dsType t2) +dsPred (InfixT t1 n t2) = (:[]) <$> (DAppT <$> (DAppT (DConT n) <$> dsType t1) <*> dsType t2) dsPred (UInfixT _ _ _) = fail "Cannot desugar unresolved infix operators." dsPred (ParensT t) = dsPred t -dsPred WildCardT = return [DWildCardPr] +dsPred WildCardT = return [DWildCardT] #endif #if __GLASGOW_HASKELL__ >= 801 dsPred t@(UnboxedSumT {}) = impossible $ "Unboxed sum seen as head of constraint: " ++ show t #endif +#if __GLASGOW_HASKELL__ >= 807 +dsPred (AppKindT t k) = do + [p] <- dsPred t + (:[]) <$> (DAppKindT p <$> dsType k) +dsPred (ImplicitParamT n t) = do + t' <- dsType t + return [DConT ''IP `DAppT` DLitT (StrTyLit n) `DAppT` t'] #endif +#endif -- | Like 'reify', but safer and desugared. Uses local declarations where -- available. @@ -1169,9 +1314,9 @@ 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' dsPat con_name field_decs field_pats (repeat DWildP) -reorderFields' :: (Applicative m, Monad m) +reorderFields' :: (Applicative m, Fail.MonadFail m) => (a -> m da) -> Name -- ^ The name of the constructor (used for error reporting) -> [VarStrictType] -> [(Name, a)] @@ -1208,7 +1353,7 @@ -- | Make a tuple 'DPat' from a list of 'DPat's. Avoids using a 1-tuple. mkTupleDPat :: [DPat] -> DPat mkTupleDPat [pat] = pat -mkTupleDPat pats = DConPa (tupleDataName (length pats)) pats +mkTupleDPat pats = DConP (tupleDataName (length pats)) pats -- | Make a tuple 'Pat' from a list of 'Pat's. Avoids using a 1-tuple. mkTuplePat :: [Pat] -> Pat @@ -1217,32 +1362,66 @@ -- | Is this pattern guaranteed to match? isUniversalPattern :: DsMonad q => DPat -> q Bool -isUniversalPattern (DLitPa {}) = return False -isUniversalPattern (DVarPa {}) = return True -isUniversalPattern (DConPa con_name pats) = do +isUniversalPattern (DLitP {}) = return False +isUniversalPattern (DVarP {}) = return True +isUniversalPattern (DConP con_name pats) = do data_name <- dataConNameToDataName con_name (_tvbs, cons) <- getDataD "Internal error." data_name if length cons == 1 then fmap and $ mapM isUniversalPattern pats else return False -isUniversalPattern (DTildePa {}) = return True -isUniversalPattern (DBangPa pat) = isUniversalPattern pat -isUniversalPattern (DSigPa pat _) = isUniversalPattern pat -isUniversalPattern DWildPa = return True +isUniversalPattern (DTildeP {}) = return True +isUniversalPattern (DBangP pat) = isUniversalPattern pat +isUniversalPattern (DSigP pat _) = isUniversalPattern pat +isUniversalPattern DWildP = return True -- | Apply one 'DExp' to a list of arguments applyDExp :: DExp -> [DExp] -> DExp applyDExp = foldl DAppE -- | Apply one 'DType' to a list of arguments -applyDType :: DType -> [DType] -> DType -applyDType = foldl DAppT +applyDType :: DType -> [DTypeArg] -> DType +applyDType = foldl apply + where + apply :: DType -> DTypeArg -> DType + apply f (DTANormal x) = f `DAppT` x + apply f (DTyArg x) = f `DAppKindT` x +-- | An argument to a type, either a normal type ('DTANormal') or a visible +-- kind application ('DTyArg'). +-- +-- 'DTypeArg' does not appear directly in the @th-desugar@ AST, but it is +-- useful when decomposing an application of a 'DType' to its arguments. +data DTypeArg + = DTANormal DType + | DTyArg DKind + deriving (Eq, Show, Typeable, Data, Generic) + +-- | Desugar a 'TypeArg'. +dsTypeArg :: DsMonad q => TypeArg -> q DTypeArg +dsTypeArg (TANormal t) = DTANormal <$> dsType t +dsTypeArg (TyArg k) = DTyArg <$> dsType k + +-- | Filter the normal type arguments from a list of 'DTypeArg's. +filterDTANormals :: [DTypeArg] -> [DType] +filterDTANormals = mapMaybe getDTANormal + where + getDTANormal :: DTypeArg -> Maybe DType + getDTANormal (DTANormal t) = Just t + getDTANormal (DTyArg {}) = Nothing + -- | Convert a 'DTyVarBndr' into a 'DType' dTyVarBndrToDType :: DTyVarBndr -> DType dTyVarBndrToDType (DPlainTV a) = DVarT a dTyVarBndrToDType (DKindedTV a k) = DVarT a `DSigT` k +-- | Extract the underlying 'DType' or 'DKind' from a 'DTypeArg'. This forgets +-- information about whether a type is a normal argument or not, so use with +-- caution. +probablyWrongUnDTypeArg :: DTypeArg -> DType +probablyWrongUnDTypeArg (DTANormal t) = t +probablyWrongUnDTypeArg (DTyArg k) = k + -- | Convert a 'Strict' to a 'Bang' in GHCs 7.x. This is just -- the identity operation in GHC 8.x, which has no 'Strict'. -- (This is included in GHC 8.x only for good Haddocking.) @@ -1256,110 +1435,125 @@ strictToBang = id #endif --- | Convert a 'DType' to a 'DPred'. -dTypeToDPred :: Monad q => DType -> q DPred -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 -dTypeToDPred (DConT n) = return $ DConPr n -dTypeToDPred DArrowT = impossible "Arrow used as head of constraint" -dTypeToDPred (DLitT _) = impossible "Type literal used as head of constraint" -dTypeToDPred DWildCardT = return DWildCardPr - --- | 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 +nonFamilyDataReturnType con_name = + applyDType (DConT con_name) . map (DTANormal . 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 :: Name -> [DTypeArg] -> 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 +-- Data family instance declarations did not come equipped with a list of bound +-- type variables until GHC 8.8 (and even then, it's optional whether the user +-- provides them or not). This means that there are situations where we must +-- reverse engineer this information ourselves from the list of type +-- arguments. 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 +dataFamInstTvbs :: [DTypeArg] -> [DTyVarBndr] +dataFamInstTvbs = toposortTyVarsOf . map probablyWrongUnDTypeArg -- | Take a list of 'DType's, find their free variables, and sort them in --- reverse topological order to ensure that they are well scoped. +-- reverse topological order to ensure that they are well scoped. In other +-- words, the free variables are ordered such that: -- +-- 1. Whenever an explicit kind signature of the form @(A :: K)@ is +-- encountered, the free variables of @K@ will always appear to the left of +-- the free variables of @A@ in the returned result. +-- +-- 2. The constraint in (1) notwithstanding, free variables will appear in +-- left-to-right order of their original appearance. +-- -- 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 + let freeVars :: [Name] + freeVars = F.toList $ foldMap fvDType tys varKindSigs :: Map Name DKind - varKindSigs = foldMap go tys + varKindSigs = foldMap go_ty 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 + go_ty :: DType -> Map Name DKind + go_ty (DForallT tvbs ctxt t) = + go_tvbs tvbs (foldMap go_ty ctxt `mappend` go_ty t) + go_ty (DAppT t1 t2) = go_ty t1 `mappend` go_ty t2 + go_ty (DAppKindT t k) = go_ty t `mappend` go_ty k + go_ty (DSigT t k) = + let kSigs = go_ty 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 + DVarT n -> M.insert n k kSigs + _ -> go_ty t `mappend` kSigs + go_ty (DVarT {}) = mempty + go_ty (DConT {}) = mempty + go_ty DArrowT = mempty + go_ty (DLitT {}) = mempty + go_ty 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 + go_tvbs :: [DTyVarBndr] -> Map Name DKind -> Map Name DKind + go_tvbs tvbs m = foldr go_tvb m tvbs - lookupVertex x = - case gLookup x of - (n, _, _) -> n + go_tvb :: DTyVarBndr -> Map Name DKind -> Map Name DKind + go_tvb (DPlainTV n) m = M.delete n m + go_tvb (DKindedTV n k) m = M.delete n m `mappend` go_ty k - ascribeWithKind n - | Just k <- Map.lookup n varKindSigs - = DKindedTV n k + -- | Do a topological sort on a list of tyvars, + -- so that binders occur before occurrences + -- E.g. given [ a::k, k::*, b::k ] + -- it'll return a well-scoped list [ k::*, a::k, b::k ] + -- + -- This is a deterministic sorting operation + -- (that is, doesn't depend on Uniques). + -- + -- It is also meant to be stable: that is, variables should not + -- be reordered unnecessarily. + scopedSort :: [Name] -> [Name] + scopedSort = go [] [] + + go :: [Name] -- already sorted, in reverse order + -> [Set Name] -- each set contains all the variables which must be placed + -- before the tv corresponding to the set; they are accumulations + -- of the fvs in the sorted tvs' kinds + + -- This list is in 1-to-1 correspondence with the sorted tyvars + -- INVARIANT: + -- all (\tl -> all (`isSubsetOf` head tl) (tail tl)) (tails fv_list) + -- That is, each set in the list is a superset of all later sets. + -> [Name] -- yet to be sorted + -> [Name] + go acc _fv_list [] = reverse acc + go acc fv_list (tv:tvs) + = go acc' fv_list' tvs + where + (acc', fv_list') = insert tv acc fv_list + + insert :: Name -- var to insert + -> [Name] -- sorted list, in reverse order + -> [Set Name] -- list of fvs, as above + -> ([Name], [Set Name]) -- augmented lists + insert tv [] [] = ([tv], [kindFVSet tv]) + insert tv (a:as) (fvs:fvss) + | tv `S.member` fvs + , (as', fvss') <- insert tv as fvss + = (a:as', fvs `S.union` fv_tv : fvss') + | otherwise - = DPlainTV n + = (tv:a:as, fvs `S.union` fv_tv : fvs : fvss) + where + fv_tv = kindFVSet tv + -- lists not in correspondence + insert _ _ _ = error "scopedSort" + + kindFVSet n = + maybe S.empty (OS.toSet . fvDType) + (M.lookup n varKindSigs) + ascribeWithKind n = + maybe (DPlainTV n) (DKindedTV n) (M.lookup n varKindSigs) + -- 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 @@ -1370,35 +1564,12 @@ #else = (`elem` kindVars) where - kindVars = foldMap fvDType $ Map.elems varKindSigs + kindVars = foldMap fvDType $ M.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 + scopedSort freeVars dtvbName :: DTyVarBndr -> Name dtvbName (DPlainTV n) = n @@ -1414,3 +1585,38 @@ let (tvbs, cxt, tys, res) = unravel t2 in (tvbs, cxt, t1 : tys, res) unravel t = ([], [], [], t) + +-- | Decompose an applied type into its individual components. For example, this: +-- +-- @ +-- Proxy \@Type Char +-- @ +-- +-- would be unfolded to this: +-- +-- @ +-- ('DConT' ''Proxy, ['DTyArg' ('DConT' ''Type), 'DTANormal' ('DConT' ''Char)]) +-- @ +unfoldDType :: DType -> (DType, [DTypeArg]) +unfoldDType = go [] + where + go :: [DTypeArg] -> DType -> (DType, [DTypeArg]) + go acc (DForallT _ _ ty) = go acc ty + go acc (DAppT ty1 ty2) = go (DTANormal ty2:acc) ty1 + go acc (DAppKindT ty ki) = go (DTyArg ki:acc) ty + go acc (DSigT ty _) = go acc ty + go acc ty = (ty, acc) + +-- | Extract the kind from a 'TyVarBndr', if one is present. +extractTvbKind :: DTyVarBndr -> Maybe DKind +extractTvbKind (DPlainTV _) = Nothing +extractTvbKind (DKindedTV _ k) = Just k + +-- | Some functions in this module only use certain arguments on particular +-- versions of GHC. Other versions of GHC (that don't make use of those +-- arguments) might need to conjure up those arguments out of thin air at the +-- functions' call sites, so this function serves as a placeholder to use in +-- those situations. (In other words, this is a slightly more informative +-- version of 'undefined'.) +unusedArgument :: a +unusedArgument = error "Unused" 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 @@ -58,14 +58,19 @@ expand_type :: forall q. DsMonad q => IgnoreKinds -> DType -> q DType expand_type ign = go [] where - go :: [DType] -> DType -> q DType + go :: [DTypeArg] -> DType -> q DType go [] (DForallT tvbs cxt ty) = - DForallT tvbs <$> mapM (expand_pred ign) cxt <*> expand_type ign ty + DForallT <$> mapM (expand_tvb ign) tvbs + <*> mapM (expand_type ign) cxt + <*> expand_type ign ty go _ (DForallT {}) = impossible "A forall type is applied to another type." go args (DAppT t1 t2) = do t2' <- expand_type ign t2 - go (t2' : args) t1 + go (DTANormal t2' : args) t1 + go args (DAppKindT p k) = do + k' <- expand_type ign k + go (DTyArg k' : args) p go args (DSigT ty ki) = do ty' <- go [] ty ki' <- go [] ki @@ -76,41 +81,21 @@ go args ty@(DLitT _) = finish ty args go args ty@DWildCardT = finish ty args - finish :: DType -> [DType] -> q DType + finish :: DType -> [DTypeArg] -> q DType finish ty args = return $ applyDType ty args --- | Expands all type synonyms in a desugared predicate. -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 - 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@(DVarPr _) = finish p args - go args p@DWildCardPr = finish p args - - finish :: DPred -> [DType] -> q DPred - finish p args = return $ foldl DAppPr p args +-- | Expands all type synonyms in a type variable binder's kind. +expand_tvb :: DsMonad q => IgnoreKinds -> DTyVarBndr -> q DTyVarBndr +expand_tvb _ tvb@DPlainTV{} = pure tvb +expand_tvb ign (DKindedTV n k) = DKindedTV n <$> expand_type ign k -- | Expand a constructor with given arguments expand_con :: forall q. DsMonad q => IgnoreKinds - -> Name -- ^ Tycon name - -> [DType] -- ^ Arguments - -> q DType -- ^ Expanded type + -> Name -- ^ Tycon name + -> [DTypeArg] -- ^ Arguments + -> q DType -- ^ Expanded type expand_con ign n args = do info <- reifyWithLocals n case info of @@ -119,26 +104,32 @@ -> return $ applyDType (DConT typeKindName) args _ -> go info where + -- Only the normal (i.e., non-visibly applied) arguments. These are + -- important since we need to align these with the arguments of the type + -- synonym/family, and visible kind arguments can mess with this. + normal_args :: [DType] + normal_args = filterDTANormals args + go :: Info -> q DType go info = do dinfo <- dsInfo info - args_ok <- allM no_tyvars_tyfams args + args_ok <- allM no_tyvars_tyfams normal_args case dinfo of DTyConI (DTySynD _n tvbs rhs) _ - | length args >= length tvbs -- this should always be true! + | length normal_args >= length tvbs -- this should always be true! -> do - let (syn_args, rest_args) = splitAtList tvbs args + let (syn_args, rest_args) = splitAtList tvbs normal_args ty <- substTy (M.fromList $ zip (map extractDTvbName tvbs) syn_args) rhs ty' <- expand_type ign ty - return $ applyDType ty' rest_args + return $ applyDType ty' $ map DTANormal rest_args DTyConI (DOpenTypeFamilyD (DTypeFamilyHead _n tvbs _frs _ann)) _ - | length args >= length tvbs -- this should always be true! + | length normal_args >= length tvbs -- this should always be true! #if __GLASGOW_HASKELL__ < 709 , args_ok #endif -> do - let (syn_args, rest_args) = splitAtList tvbs args + let (syn_args, rest_args) = splitAtList tvbs normal_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. @@ -146,32 +137,36 @@ 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 + [DTySynInstD (DTySynEqn _ lhs rhs)] + | (_, lhs_args) <- unfoldDType lhs + , let lhs_normal_args = filterDTANormals lhs_args + , Just subst <- + unionMaybeSubsts $ zipWith (matchTy ign) lhs_normal_args syn_args -> do ty <- substTy subst rhs ty' <- expand_type ign ty - return $ applyDType ty' rest_args + return $ applyDType ty' $ map DTANormal rest_args _ -> give_up DTyConI (DClosedTypeFamilyD (DTypeFamilyHead _n tvbs _frs _ann) eqns) _ - | length args >= length tvbs + | length normal_args >= length tvbs , args_ok -> do - let (syn_args, rest_args) = splitAtList tvbs args + let (syn_args, rest_args) = splitAtList tvbs normal_args rhss <- mapMaybeM (check_eqn syn_args) eqns case rhss of (rhs : _) -> do rhs' <- expand_type ign rhs - return $ applyDType rhs' rest_args + return $ applyDType rhs' $ map DTANormal rest_args [] -> give_up 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 + check_eqn arg_tys (DTySynEqn _ lhs rhs) = do + let (_, lhs_args) = unfoldDType lhs + normal_lhs_args = filterDTANormals lhs_args + m_subst = unionMaybeSubsts $ zipWith (matchTy ign) normal_lhs_args arg_tys T.mapM (flip substTy rhs) m_subst _ -> give_up @@ -182,21 +177,39 @@ 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_tyvars_tyfams :: DType -> q Bool + no_tyvars_tyfams = go_ty + where + go_ty :: DType -> q Bool + -- Interesting cases + go_ty (DVarT _) = return False + go_ty (DConT con_name) = do + m_info <- dsReify con_name + return $ case m_info of + Nothing -> False -- we don't know anything. False is safe. + Just (DTyConI (DOpenTypeFamilyD {}) _) -> False + Just (DTyConI (DDataFamilyD {}) _) -> False + Just (DTyConI (DClosedTypeFamilyD {}) _) -> False + _ -> True - no_tyvar_tyfam :: DType -> q Bool - no_tyvar_tyfam (DVarT _) = return False - no_tyvar_tyfam (DConT con_name) = do - m_info <- dsReify con_name - return $ case m_info of - Nothing -> False -- we don't know anything. False is safe. - Just (DTyConI (DOpenTypeFamilyD {}) _) -> False - Just (DTyConI (DDataFamilyD {}) _) -> False - Just (DTyConI (DClosedTypeFamilyD {}) _) -> False - _ -> True - no_tyvar_tyfam t = gmapQl (liftM2 (&&)) (return True) no_tyvars_tyfams t + -- Recursive cases + go_ty (DForallT tvbs ctxt ty) = + liftM3 (\x y z -> x && y && z) + (allM go_tvb tvbs) (allM go_ty ctxt) (go_ty ty) + go_ty (DAppT t1 t2) = liftM2 (&&) (go_ty t1) (go_ty t2) + go_ty (DAppKindT t k) = liftM2 (&&) (go_ty t) (go_ty k) + go_ty (DSigT t k) = liftM2 (&&) (go_ty t) (go_ty k) + -- Default to True + go_ty DLitT{} = return True + go_ty DArrowT = return True + go_ty DWildCardT = return True + + -- These cases are uninteresting + go_tvb :: DTyVarBndr -> q Bool + go_tvb DPlainTV{} = return True + go_tvb (DKindedTV _ k) = go_ty k + allM :: Monad m => (a -> m Bool) -> [a] -> m Bool allM f = foldM (\b x -> (b &&) `liftM` f x) True @@ -251,4 +264,4 @@ -- | Generalization of 'expand' that either can or won't ignore kind annotations.sx expand_ :: (DsMonad q, Data a) => IgnoreKinds -> a -> q a -expand_ ign = everywhereM (mkM (expand_type ign) >=> mkM (expand_pred ign)) +expand_ ign = everywhereM (mkM (expand_type ign)) diff --git a/Language/Haskell/TH/Desugar/FV.hs b/Language/Haskell/TH/Desugar/FV.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/TH/Desugar/FV.hs @@ -0,0 +1,70 @@ +{- Language/Haskell/TH/Desugar/FV.hs + +(c) Ryan Scott 2018 + +Compute free variables of programs. +-} + +{-# LANGUAGE CPP #-} +module Language.Haskell.TH.Desugar.FV + ( fvDType + , extractBoundNamesDPat + ) where + +#if __GLASGOW_HASKELL__ < 710 +import Data.Foldable (foldMap) +#endif +#if __GLASGOW_HASKELL__ < 804 +import Data.Monoid ((<>)) +#endif +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Desugar.AST +import qualified Language.Haskell.TH.Desugar.OSet as OS +import Language.Haskell.TH.Desugar.OSet (OSet) + +-- | Compute the free variables of a 'DType'. +fvDType :: DType -> OSet Name +fvDType = go + where + go :: DType -> OSet Name + go (DForallT tvbs ctxt ty) = fv_dtvbs tvbs (foldMap fvDType ctxt <> go ty) + go (DAppT t1 t2) = go t1 <> go t2 + go (DAppKindT t k) = go t <> go k + go (DSigT ty ki) = go ty <> go ki + go (DVarT n) = OS.singleton n + go (DConT {}) = OS.empty + go DArrowT = OS.empty + go (DLitT {}) = OS.empty + go DWildCardT = OS.empty + +----- +-- Extracting bound term names +----- + +-- | Extract the term variables bound by a 'DPat'. +-- +-- This does /not/ extract any type variables bound by pattern signatures. +extractBoundNamesDPat :: DPat -> OSet Name +extractBoundNamesDPat = go + where + go :: DPat -> OSet Name + go (DLitP _) = OS.empty + go (DVarP n) = OS.singleton n + go (DConP _ pats) = foldMap go pats + go (DTildeP p) = go p + go (DBangP p) = go p + go (DSigP p _) = go p + go DWildP = OS.empty + +----- +-- Binding forms +----- + +-- | Adjust the free variables of something following 'DTyVarBndr's. +fv_dtvbs :: [DTyVarBndr] -> OSet Name -> OSet Name +fv_dtvbs tvbs fvs = foldr fv_dtvb fvs tvbs + +-- | Adjust the free variables of something following a 'DTyVarBndr'. +fv_dtvb :: DTyVarBndr -> OSet Name -> OSet Name +fv_dtvb (DPlainTV n) fvs = OS.delete n fvs +fv_dtvb (DKindedTV n k) fvs = OS.delete n fvs <> fvDType k 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 @@ -23,13 +23,10 @@ import Language.Haskell.TH.Instances () import Language.Haskell.TH.Lift -$(deriveLiftMany [ ''DExp, ''DPat, ''DType, ''DPred, ''DTyVarBndr +$(deriveLiftMany [ ''DExp, ''DPat, ''DType, ''DTyVarBndr , ''DMatch, ''DClause, ''DLetDec, ''DDec, ''DDerivClause, ''DCon , ''DConFields, ''DForeign, ''DPragma, ''DRuleBndr, ''DTySynEqn , ''DPatSynDir , ''NewOrData, ''DDerivStrategy -#if __GLASGOW_HASKELL__ < 707 - , ''AnnTarget, ''Role -#endif , ''DTypeFamilyHead, ''DFamilyResultSig #if __GLASGOW_HASKELL__ <= 710 , ''InjectivityAnn, ''Bang, ''SourceUnpackedness @@ -38,4 +35,6 @@ #if __GLASGOW_HASKELL__ < 801 , ''PatSynArgs #endif + + , ''TypeArg, ''DTypeArg ]) 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 @@ -11,11 +11,6 @@ {-# LANGUAGE CPP, TemplateHaskell #-} -#if __GLASGOW_HASKELL__ <= 708 -{-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- we need Ord Lit. argh. -#endif - module Language.Haskell.TH.Desugar.Match (scExp, scLetDec) where import Prelude hiding ( fail, exp ) @@ -26,6 +21,7 @@ import Control.Monad hiding ( fail ) import qualified Control.Monad as Monad import Data.Data +import qualified Data.Foldable as F import Data.Generics import qualified Data.Set as S import qualified Data.Map as Map @@ -34,6 +30,8 @@ import Language.Haskell.TH.Desugar.AST import Language.Haskell.TH.Desugar.Core +import Language.Haskell.TH.Desugar.FV +import qualified Language.Haskell.TH.Desugar.OSet as OS import Language.Haskell.TH.Desugar.Util import Language.Haskell.TH.Desugar.Reify @@ -50,7 +48,7 @@ | otherwise = do scrut_name <- newUniqueName "scrut" case_exp <- simplCaseExp [scrut_name] clauses - return $ DLetE [DValD (DVarPa scrut_name) scrut] case_exp + return $ DLetE [DValD (DVarP scrut_name) scrut] case_exp where clauses = map match_to_clause matches match_to_clause (DMatch pat exp) = DClause [pat] exp @@ -69,7 +67,7 @@ arg_names <- mapM (const (newUniqueName "_arg")) pats1 clauses' <- mapM sc_clause_rhs clauses case_exp <- simplCaseExp arg_names clauses' - return $ DFunD name [DClause (map DVarPa arg_names) case_exp] + return $ DFunD name [DClause (map DVarP arg_names) case_exp] where sc_clause_rhs (DClause pats exp) = DClause pats <$> scExp exp scLetDec (DValD pat exp) = DValD pat <$> scExp exp @@ -142,22 +140,22 @@ => Name -- the name of the variable that ... -> DPat -- ... this pattern is matching against -> q (DExp -> DExp, DPat) -- a wrapper and tidied pattern -tidy1 _ p@(DLitPa {}) = return (id, p) -tidy1 v (DVarPa var) = return (wrapBind var v, DWildPa) -tidy1 _ p@(DConPa {}) = return (id, p) -tidy1 v (DTildePa pat) = do +tidy1 _ p@(DLitP {}) = return (id, p) +tidy1 v (DVarP var) = return (wrapBind var v, DWildP) +tidy1 _ p@(DConP {}) = return (id, p) +tidy1 v (DTildeP pat) = do sel_decs <- mkSelectorDecs pat v - return (maybeDLetE sel_decs, DWildPa) -tidy1 v (DBangPa pat) = + return (maybeDLetE sel_decs, DWildP) +tidy1 v (DBangP pat) = case pat of - DLitPa _ -> tidy1 v pat -- already strict - DVarPa _ -> return (id, DBangPa pat) -- no change - DConPa _ _ -> tidy1 v pat -- already strict - DTildePa p -> tidy1 v (DBangPa p) -- discard ~ under ! - DBangPa p -> tidy1 v (DBangPa p) -- discard ! under ! - DSigPa p _ -> tidy1 v (DBangPa p) -- discard sig under ! - DWildPa -> return (id, DBangPa pat) -- no change -tidy1 v (DSigPa pat ty) + DLitP _ -> tidy1 v pat -- already strict + DVarP _ -> return (id, DBangP pat) -- no change + DConP _ _ -> tidy1 v pat -- already strict + DTildeP p -> tidy1 v (DBangP p) -- discard ~ under ! + DBangP p -> tidy1 v (DBangP p) -- discard ! under ! + DSigP p _ -> tidy1 v (DBangP p) -- discard sig under ! + DWildP -> return (id, DBangP pat) -- no change +tidy1 v (DSigP pat ty) | no_tyvars_ty ty = tidy1 v pat -- The match-flattener doesn't know how to deal with patterns that mention -- type variables properly, so we give up if we encounter one. @@ -172,29 +170,29 @@ no_tyvar_ty :: DType -> Bool no_tyvar_ty (DVarT{}) = False no_tyvar_ty t = gmapQl (&&) True no_tyvars_ty t -tidy1 _ DWildPa = return (id, DWildPa) +tidy1 _ DWildP = return (id, DWildP) wrapBind :: Name -> Name -> DExp -> DExp wrapBind new old | new == old = id - | otherwise = DLetE [DValD (DVarPa new) (DVarE old)] + | otherwise = DLetE [DValD (DVarP new) (DVarE old)] -- like GHC's mkSelectorBinds mkSelectorDecs :: DsMonad q => DPat -- pattern to deconstruct -> Name -- variable being matched against -> q [DLetDec] -mkSelectorDecs (DVarPa v) name = return [DValD (DVarPa v) (DVarE name)] +mkSelectorDecs (DVarP v) name = return [DValD (DVarP v) (DVarE name)] mkSelectorDecs pat name - | S.null binders + | OS.null binders = return [] - | S.size binders == 1 + | OS.size binders == 1 = do val_var <- newUniqueName "var" err_var <- newUniqueName "err" - bind <- mk_bind val_var err_var (head $ S.elems binders) - return [DValD (DVarPa val_var) (DVarE name), - DValD (DVarPa err_var) (DVarE 'error `DAppE` + bind <- mk_bind val_var err_var (head $ F.toList binders) + return [DValD (DVarP val_var) (DVarE name), + DValD (DVarP err_var) (DVarE 'error `DAppE` (DLitE $ StringL "Irrefutable match failed")), bind] @@ -202,12 +200,12 @@ = do tuple_expr <- simplCaseExp [name] [DClause [pat] local_tuple] tuple_var <- newUniqueName "tuple" projections <- mapM (mk_projection tuple_var) [0 .. tuple_size-1] - return (DValD (DVarPa tuple_var) tuple_expr : - zipWith DValD (map DVarPa binders_list) projections) + return (DValD (DVarP tuple_var) tuple_expr : + zipWith DValD (map DVarP binders_list) projections) where binders = extractBoundNamesDPat pat - binders_list = S.toAscList binders + binders_list = F.toList binders tuple_size = length binders_list local_tuple = mkTupleDExp (map DVarE binders_list) @@ -217,17 +215,17 @@ -> q DExp mk_projection tup_name i = do var_name <- newUniqueName "proj" - return $ DCaseE (DVarE tup_name) [DMatch (DConPa (tupleDataName tuple_size) (mk_tuple_pats var_name i)) + return $ DCaseE (DVarE tup_name) [DMatch (DConP (tupleDataName tuple_size) (mk_tuple_pats var_name i)) (DVarE var_name)] mk_tuple_pats :: Name -- of the projected element -> Int -- which element to get (0-indexed) -> [DPat] - mk_tuple_pats elt_name i = replicate i DWildPa ++ DVarPa elt_name : replicate (tuple_size - i - 1) DWildPa + mk_tuple_pats elt_name i = replicate i DWildP ++ DVarP elt_name : replicate (tuple_size - i - 1) DWildP mk_bind scrut_var err_var bndr_var = do rhs_mr <- simplCase [scrut_var] [EquationInfo [pat] (\_ -> DVarE bndr_var)] - return (DValD (DVarPa bndr_var) (rhs_mr (DVarE err_var))) + return (DValD (DVarP bndr_var) (rhs_mr (DVarE err_var))) data PatGroup = PgAny -- immediate match (wilds, vars, lazies) @@ -244,13 +242,13 @@ (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2 patGroup :: DPat -> PatGroup -patGroup (DLitPa l) = PgLit l -patGroup (DVarPa {}) = error "Internal error in th-desugar (patGroup DVarPa)" -patGroup (DConPa con _) = PgCon con -patGroup (DTildePa {}) = error "Internal error in th-desugar (patGroup DTildePa)" -patGroup (DBangPa {}) = PgBang -patGroup (DSigPa{}) = error "Internal error in th-desugar (patGroup DSigPa)" -patGroup DWildPa = PgAny +patGroup (DLitP l) = PgLit l +patGroup (DVarP {}) = error "Internal error in th-desugar (patGroup DVarP)" +patGroup (DConP con _) = PgCon con +patGroup (DTildeP {}) = error "Internal error in th-desugar (patGroup DTildeP)" +patGroup (DBangP {}) = PgBang +patGroup (DSigP{}) = error "Internal error in th-desugar (patGroup DSigP)" +patGroup DWildP = PgAny sameGroup :: PatGroup -> PatGroup -> Bool sameGroup PgAny PgAny = True @@ -294,17 +292,17 @@ where pat1 = firstPat eqn1 - pat_args (DConPa _ pats) = pats - pat_args _ = error "Internal error in th-desugar (pat_args)" + pat_args (DConP _ pats) = pats + pat_args _ = error "Internal error in th-desugar (pat_args)" - pat_con (DConPa con _) = con - pat_con _ = error "Internal error in th-desugar (pat_con)" + pat_con (DConP con _) = con + pat_con _ = error "Internal error in th-desugar (pat_con)" match_group :: DsMonad q => [Name] -> q MatchResult match_group arg_vars = simplCase (arg_vars ++ vars) (map shift eqns) - shift (EquationInfo (DConPa _ args : pats) exp) = EquationInfo (args ++ pats) exp + shift (EquationInfo (DConP _ args : pats) exp) = EquationInfo (args ++ pats) exp shift _ = error "Internal error in th-desugar (shift)" matchOneCon _ _ = error "Internal error in th-desugar (matchOneCon)" @@ -317,10 +315,10 @@ where mk_alt fail (CaseAlt con args body_fn) = let body = body_fn fail in - DMatch (DConPa con (map DVarPa args)) body + DMatch (DConP con (map DVarP args)) body mk_default all_ctors fail | exhaustive_case all_ctors = [] - | otherwise = [DMatch DWildPa fail] + | otherwise = [DMatch DWildP fail] mentioned_ctors = S.fromList $ map alt_con case_alts exhaustive_case all_ctors = all_ctors `S.isSubsetOf` mentioned_ctors @@ -340,7 +338,7 @@ matchEmpty :: DsMonad q => Name -> q [MatchResult] matchEmpty var = return [mk_seq] where - mk_seq fail = DCaseE (DVarE var) [DMatch DWildPa fail] + mk_seq fail = DCaseE (DVarE var) [DMatch DWildP fail] matchLiterals :: DsMonad q => [Name] -> [[EquationInfo]] -> q MatchResult matchLiterals (var:vars) sub_groups @@ -349,7 +347,7 @@ where match_group :: DsMonad q => [EquationInfo] -> q (Lit, MatchResult) match_group eqns - = do let DLitPa lit = firstPat (head eqns) + = do let DLitP lit = firstPat (head eqns) match_result <- simplCase vars (shiftEqns eqns) return (lit, match_result) matchLiterals [] _ = error "Internal error in th-desugar (matchLiterals)" @@ -360,9 +358,9 @@ mkCoPrimCaseMatchResult var match_alts = mk_case where mk_case fail = let alts = map (mk_alt fail) match_alts in - DCaseE (DVarE var) (alts ++ [DMatch DWildPa fail]) + DCaseE (DVarE var) (alts ++ [DMatch DWildP fail]) mk_alt fail (lit, body_fn) - = DMatch (DLitPa lit) (body_fn fail) + = DMatch (DLitP lit) (body_fn fail) matchBangs :: DsMonad q => [Name] -> [EquationInfo] -> q MatchResult matchBangs (var:vars) eqns @@ -377,8 +375,8 @@ decomposeFirstPat _ _ = error "Internal error in th-desugar (decomposeFirstPat)" getBangPat :: DPat -> DPat -getBangPat (DBangPa p) = p -getBangPat _ = error "Internal error in th-desugar (getBangPat)" +getBangPat (DBangP p) = p +getBangPat _ = error "Internal error in th-desugar (getBangPat)" mkEvalMatchResult :: Name -> MatchResult -> MatchResult mkEvalMatchResult var body_fn fail @@ -403,10 +401,10 @@ -- from DsUtils selectMatchVar :: DsMonad q => DPat -> q Name -selectMatchVar (DBangPa pat) = selectMatchVar pat -selectMatchVar (DTildePa pat) = selectMatchVar pat -selectMatchVar (DVarPa var) = newUniqueName ('_' : nameBase var) -selectMatchVar _ = newUniqueName "_pat" +selectMatchVar (DBangP pat) = selectMatchVar pat +selectMatchVar (DTildeP pat) = selectMatchVar pat +selectMatchVar (DVarP var) = newUniqueName ('_' : nameBase var) +selectMatchVar _ = newUniqueName "_pat" -- like GHC's runs runs :: (a -> a -> Bool) -> [a] -> [[a]] diff --git a/Language/Haskell/TH/Desugar/OMap.hs b/Language/Haskell/TH/Desugar/OMap.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/TH/Desugar/OMap.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Language.Haskell.TH.Desugar.OMap +-- Copyright : (C) 2016-2018 Daniel Wagner, 2019 Ryan Scott +-- License : BSD-style (see LICENSE) +-- Maintainer : Ryan Scott +-- Stability : experimental +-- Portability : non-portable +-- +-- An 'OMap' behaves much like a 'M.Map', with all the same asymptotics, but +-- also remembers the order that keys were inserted. +-- +-- This module offers a simplified version of the "Data.Map.Ordered" API +-- that assumes left-biased indices everywhere and uses a different 'Semigroup' +-- instance (the one in this module uses @('<>') = 'union'@) and 'Monoid' +-- instance (the one in this module uses @'mappend' = 'union'@). +-- +---------------------------------------------------------------------------- +module Language.Haskell.TH.Desugar.OMap + ( OMap(..) + -- * Trivial maps + , empty, singleton + -- * Insertion + , insertPre, insertPost, union, unionWithKey + -- * Deletion + , delete, filterWithKey, (\\), intersection, intersectionWithKey + -- * Query + , null, size, member, notMember, lookup + -- * Indexing + , Index, lookupIndex, lookupAt + -- * List conversions + , fromList, assocs, toAscList + -- * 'M.Map' conversion + , toMap + ) where + +import Data.Coerce +import Data.Data +import qualified Data.Map.Lazy as M (Map) +import Data.Map.Ordered (Bias(..), Index, L) +import qualified Data.Map.Ordered as OM +import Prelude hiding (filter, lookup, null) + +#if !(MIN_VERSION_base(4,8,0)) +import Data.Foldable (Foldable) +import Data.Monoid (Monoid(..)) +import Data.Traversable (Traversable) +#endif + +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup (Semigroup(..)) +#endif + +#if __GLASGOW_HASKELL__ < 710 +deriving instance Typeable L +#endif + +-- | An ordered map whose 'insertPre', 'insertPost', 'intersection', +-- 'intersectionWithKey', 'union', and 'unionWithKey' operations are biased +-- towards leftmost indices when when breaking ties between keys. +newtype OMap k v = OMap (Bias L (OM.OMap k v)) + deriving (Data, Foldable, Functor, Eq, Ord, Read, Show, Traversable, Typeable) + +instance Ord k => Semigroup (OMap k v) where + (<>) = union +instance Ord k => Monoid (OMap k v) where + mempty = empty +#if !(MIN_VERSION_base(4,11,0)) + mappend = (<>) +#endif + +empty :: forall k v. OMap k v +empty = coerce (OM.empty :: OM.OMap k v) + +singleton :: k -> v -> OMap k v +singleton k v = coerce (OM.singleton (k, v)) + +-- | The value's index will be lower than the indices of the values in the +-- 'OSet'. +insertPre :: Ord k => k -> v -> OMap k v -> OMap k v +insertPre k v = coerce ((k, v) OM.|<) + +-- | The value's index will be higher than the indices of the values in the +-- 'OSet'. +insertPost :: Ord k => OMap k v -> k -> v -> OMap k v +insertPost m k v = coerce (coerce m OM.|> (k, v)) + +union :: forall k v. Ord k => OMap k v -> OMap k v -> OMap k v +union = coerce ((OM.|<>) :: OM.OMap k v -> OM.OMap k v -> OM.OMap k v) + +unionWithKey :: Ord k => (k -> v -> v -> v) -> OMap k v -> OMap k v -> OMap k v +unionWithKey f = coerce (OM.unionWithL f) + +delete :: forall k v. Ord k => k -> OMap k v -> OMap k v +delete = coerce (OM.delete :: k -> OM.OMap k v -> OM.OMap k v) + +filterWithKey :: Ord k => (k -> v -> Bool) -> OMap k v -> OMap k v +filterWithKey f = coerce (OM.filter f) + +(\\) :: forall k v v'. Ord k => OMap k v -> OMap k v' -> OMap k v +(\\) = coerce ((OM.\\) :: OM.OMap k v -> OM.OMap k v' -> OM.OMap k v) + +intersection :: forall k v v'. Ord k => OMap k v -> OMap k v' -> OMap k v +intersection = coerce ((OM.|/\) :: OM.OMap k v -> OM.OMap k v' -> OM.OMap k v) + +intersectionWithKey :: Ord k => (k -> v -> v' -> v'') -> OMap k v -> OMap k v' -> OMap k v'' +intersectionWithKey f = coerce (OM.intersectionWith f) + +null :: forall k v. OMap k v -> Bool +null = coerce (OM.null :: OM.OMap k v -> Bool) + +size :: forall k v. OMap k v -> Int +size = coerce (OM.size :: OM.OMap k v -> Int) + +member :: forall k v. Ord k => k -> OMap k v -> Bool +member = coerce (OM.member :: k -> OM.OMap k v -> Bool) + +notMember :: forall k v. Ord k => k -> OMap k v -> Bool +notMember = coerce (OM.notMember :: k -> OM.OMap k v -> Bool) + +lookup :: forall k v. Ord k => k -> OMap k v -> Maybe v +lookup = coerce (OM.lookup :: k -> OM.OMap k v -> Maybe v) + +lookupIndex :: forall k v. Ord k => k -> OMap k v -> Maybe Index +lookupIndex = coerce (OM.findIndex :: k -> OM.OMap k v -> Maybe Index) + +lookupAt :: forall k v. Index -> OMap k v -> Maybe (k, v) +lookupAt i m = coerce (OM.elemAt (coerce m) i :: Maybe (k, v)) + +fromList :: Ord k => [(k, v)] -> OMap k v +fromList l = coerce (OM.fromList l) + +assocs :: forall k v. OMap k v -> [(k, v)] +assocs = coerce (OM.assocs :: OM.OMap k v -> [(k, v)]) + +toAscList :: forall k v. OMap k v -> [(k, v)] +toAscList = coerce (OM.toAscList :: OM.OMap k v -> [(k, v)]) + +toMap :: forall k v. OMap k v -> M.Map k v +toMap = coerce (OM.toMap :: OM.OMap k v -> M.Map k v) diff --git a/Language/Haskell/TH/Desugar/OMap/Strict.hs b/Language/Haskell/TH/Desugar/OMap/Strict.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/TH/Desugar/OMap/Strict.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Language.Haskell.TH.Desugar.OMap +-- Copyright : (C) 2016-2018 Daniel Wagner, 2019 Ryan Scott +-- License : BSD-style (see LICENSE) +-- Maintainer : Ryan Scott +-- Stability : experimental +-- Portability : non-portable +-- +-- An 'OMap' behaves much like a 'M.Map', with all the same asymptotics, but +-- also remembers the order that keys were inserted. +-- +-- This module offers a simplified version of the "Data.Map.Ordered.Strict" API +-- that assumes left-biased indices everywhere and uses a different 'Semigroup' +-- instance (the one in this module uses @('<>') = 'union'@) and 'Monoid' +-- instance (the one in this module uses @'mappend' = 'union'@). +-- +---------------------------------------------------------------------------- +module Language.Haskell.TH.Desugar.OMap.Strict + ( OMap(..) + -- * Trivial maps + , empty, singleton + -- * Insertion + , insertPre, insertPost, union, unionWithKey + -- * Deletion + , delete, filterWithKey, (\\), intersection, intersectionWithKey + -- * Query + , null, size, member, notMember, lookup + -- * Indexing + , Index, lookupIndex, lookupAt + -- * List conversions + , fromList, assocs, toAscList + -- * 'M.Map' conversion + , toMap + ) where + +import Data.Coerce +import qualified Data.Map.Strict as M (Map) +import Data.Map.Ordered.Strict (Index) +import qualified Data.Map.Ordered.Strict as OM +import Language.Haskell.TH.Desugar.OMap (OMap(..)) +import Prelude hiding (filter, lookup, null) + +empty :: forall k v. OMap k v +empty = coerce (OM.empty :: OM.OMap k v) + +singleton :: k -> v -> OMap k v +singleton k v = coerce (OM.singleton (k, v)) + +-- | The value's index will be lower than the indices of the values in the +-- 'OSet'. +insertPre :: Ord k => k -> v -> OMap k v -> OMap k v +insertPre k v = coerce ((k, v) OM.|<) + +-- | The value's index will be higher than the indices of the values in the +-- 'OSet'. +insertPost :: Ord k => OMap k v -> k -> v -> OMap k v +insertPost m k v = coerce (coerce m OM.|> (k, v)) + +union :: forall k v. Ord k => OMap k v -> OMap k v -> OMap k v +union = coerce ((OM.|<>) :: OM.OMap k v -> OM.OMap k v -> OM.OMap k v) + +unionWithKey :: Ord k => (k -> v -> v -> v) -> OMap k v -> OMap k v -> OMap k v +unionWithKey f = coerce (OM.unionWithL f) + +delete :: forall k v. Ord k => k -> OMap k v -> OMap k v +delete = coerce (OM.delete :: k -> OM.OMap k v -> OM.OMap k v) + +filterWithKey :: Ord k => (k -> v -> Bool) -> OMap k v -> OMap k v +filterWithKey f = coerce (OM.filter f) + +(\\) :: forall k v v'. Ord k => OMap k v -> OMap k v' -> OMap k v +(\\) = coerce ((OM.\\) :: OM.OMap k v -> OM.OMap k v' -> OM.OMap k v) + +intersection :: forall k v v'. Ord k => OMap k v -> OMap k v' -> OMap k v +intersection = coerce ((OM.|/\) :: OM.OMap k v -> OM.OMap k v' -> OM.OMap k v) + +intersectionWithKey :: Ord k => (k -> v -> v' -> v'') -> OMap k v -> OMap k v' -> OMap k v'' +intersectionWithKey f = coerce (OM.intersectionWith f) + +null :: forall k v. OMap k v -> Bool +null = coerce (OM.null :: OM.OMap k v -> Bool) + +size :: forall k v. OMap k v -> Int +size = coerce (OM.size :: OM.OMap k v -> Int) + +member :: forall k v. Ord k => k -> OMap k v -> Bool +member = coerce (OM.member :: k -> OM.OMap k v -> Bool) + +notMember :: forall k v. Ord k => k -> OMap k v -> Bool +notMember = coerce (OM.notMember :: k -> OM.OMap k v -> Bool) + +lookup :: forall k v. Ord k => k -> OMap k v -> Maybe v +lookup = coerce (OM.lookup :: k -> OM.OMap k v -> Maybe v) + +lookupIndex :: forall k v. Ord k => k -> OMap k v -> Maybe Index +lookupIndex = coerce (OM.findIndex :: k -> OM.OMap k v -> Maybe Index) + +lookupAt :: forall k v. Index -> OMap k v -> Maybe (k, v) +lookupAt i m = coerce (OM.elemAt (coerce m) i :: Maybe (k, v)) + +fromList :: Ord k => [(k, v)] -> OMap k v +fromList l = coerce (OM.fromList l) + +assocs :: forall k v. OMap k v -> [(k, v)] +assocs = coerce (OM.assocs :: OM.OMap k v -> [(k, v)]) + +toAscList :: forall k v. OMap k v -> [(k, v)] +toAscList = coerce (OM.toAscList :: OM.OMap k v -> [(k, v)]) + +toMap :: forall k v. OMap k v -> M.Map k v +toMap = coerce (OM.toMap :: OM.OMap k v -> M.Map k v) diff --git a/Language/Haskell/TH/Desugar/OSet.hs b/Language/Haskell/TH/Desugar/OSet.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/TH/Desugar/OSet.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Language.Haskell.TH.Desugar.OSet +-- Copyright : (C) 2016-2018 Daniel Wagner, 2019 Ryan Scott +-- License : BSD-style (see LICENSE) +-- Maintainer : Ryan Scott +-- Stability : experimental +-- Portability : non-portable +-- +-- An 'OSet' behaves much like a 'S.Set', with all the same asymptotics, but +-- also remembers the order that values were inserted. +-- +-- This module offers a simplified version of the "Data.Set.Ordered" API +-- that assumes left-biased indices everywhere. +-- +---------------------------------------------------------------------------- +module Language.Haskell.TH.Desugar.OSet + ( OSet + -- * Trivial sets + , empty, singleton + -- * Insertion + , insertPre, insertPost, union + -- * Query + , null, size, member, notMember + -- * Deletion + , delete, filter, (\\), intersection + -- * Indexing + , Index, lookupIndex, lookupAt + -- * List conversions + , fromList, toAscList + -- * 'Set' conversion + , toSet + ) where + +import Data.Coerce +import Data.Data +import qualified Data.Set as S (Set) +import Data.Set.Ordered (Bias(..), Index, L) +import qualified Data.Set.Ordered as OS +import Language.Haskell.TH.Desugar.OMap () +import Prelude hiding (filter, null) + +#if !(MIN_VERSION_base(4,8,0)) +import Data.Foldable (Foldable) +import Data.Monoid (Monoid) +#endif + +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup (Semigroup(..)) +#endif + +-- | An ordered set whose 'insertPre', 'insertPost', 'intersection', and 'union' +-- operations are biased towards leftmost indices when when breaking ties +-- between keys. +newtype OSet a = OSet (Bias L (OS.OSet a)) + deriving (Data, Foldable, Eq, Monoid, Ord, Read, Show, Typeable) + +instance Ord a => Semigroup (OSet a) where + (<>) = union + +empty :: forall a. OSet a +empty = coerce (OS.empty :: OS.OSet a) + +singleton :: a -> OSet a +singleton a = coerce (OS.singleton a) + +-- | The element's index will be lower than the indices of the elements in the +-- 'OSet'. +insertPre :: Ord a => a -> OSet a -> OSet a +insertPre a = coerce (a OS.|<) + +-- | The element's index will be higher than the indices of the elements in the +-- 'OSet'. +insertPost :: Ord a => OSet a -> a -> OSet a +insertPost s a = coerce (coerce s OS.|> a) + +union :: forall a. Ord a => OSet a -> OSet a -> OSet a +union = coerce ((OS.|<>) :: OS.OSet a -> OS.OSet a -> OS.OSet a) + +null :: forall a. OSet a -> Bool +null = coerce (OS.null :: OS.OSet a -> Bool) + +size :: forall a. OSet a -> Int +size = coerce (OS.size :: OS.OSet a -> Int) + +member, notMember :: Ord a => a -> OSet a -> Bool +member a = coerce (OS.member a) +notMember a = coerce (OS.notMember a) + +delete :: Ord a => a -> OSet a -> OSet a +delete a = coerce (OS.delete a) + +filter :: Ord a => (a -> Bool) -> OSet a -> OSet a +filter f = coerce (OS.filter f) + +(\\) :: forall a. Ord a => OSet a -> OSet a -> OSet a +(\\) = coerce ((OS.\\) :: OS.OSet a -> OS.OSet a -> OS.OSet a) + +intersection :: forall a. Ord a => OSet a -> OSet a -> OSet a +intersection = coerce ((OS.|/\) :: OS.OSet a -> OS.OSet a -> OS.OSet a) + +lookupIndex :: Ord a => a -> OSet a -> Maybe Index +lookupIndex a = coerce (OS.findIndex a) + +lookupAt :: forall a. Index -> OSet a -> Maybe a +lookupAt i s = coerce (OS.elemAt (coerce s) i :: Maybe a) + +fromList :: Ord a => [a] -> OSet a +fromList l = coerce (OS.fromList l) + +toAscList :: forall a. OSet a -> [a] +toAscList = coerce (OS.toAscList :: OS.OSet a -> [a]) + +toSet :: forall a. OSet a -> S.Set a +toSet = coerce (OS.toSet :: OS.OSet a -> S.Set a) 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 @@ -28,23 +28,21 @@ DsMonad(..), DsM, withLocalDeclarations ) where +import qualified Control.Monad.Fail as Fail import Control.Monad.Reader import Control.Monad.State import Control.Monad.Writer import Control.Monad.RWS +import Control.Monad.Trans.Instances () +import qualified Data.Foldable as F +import Data.Function (on) import Data.List import Data.Maybe #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif -import qualified Data.Set as S -#if __GLASGOW_HASKELL__ >= 800 -import qualified Control.Monad.Fail as Fail -#else -import qualified Control.Monad as Fail -#endif -import Language.Haskell.TH.ExpandSyns ( expandSyns ) +import Language.Haskell.TH.Datatype import Language.Haskell.TH.Instances () import Language.Haskell.TH.Syntax hiding ( lift ) @@ -72,15 +70,11 @@ -- | Reify a declaration, warning the user about splices if the reify fails. -- The warning says that reification can fail if you try to reify a type in -- the same splice as it is declared. -reifyWithWarning :: Quasi q => Name -> q Info +reifyWithWarning :: (Quasi q, Fail.MonadFail q) => Name -> q Info reifyWithWarning name = qRecover (reifyFail name) (qReify name) -- | Print out a warning about separating splices and fail. -#if __GLASGOW_HASKELL__ >= 800 reifyFail :: Fail.MonadFail m => Name -> m a -#else -reifyFail :: Monad m => Name -> m a -#endif reifyFail name = Fail.fail $ "Looking up " ++ (show name) ++ " in the list of available " ++ "declarations failed.\nThis lookup fails if the declaration " ++ @@ -113,7 +107,7 @@ _ -> badDeclaration where go tvbs mk cons = do - k <- maybe (pure (ConT typeKindName)) (runQ . expandSyns) mk + k <- maybe (pure (ConT typeKindName)) (runQ . resolveTypeSynonyms) mk extra_tvbs <- mkExtraKindBindersGeneric unravelType KindedTV k let all_tvbs = tvbs ++ extra_tvbs return (all_tvbs, cons) @@ -164,7 +158,7 @@ -- | A 'DsMonad' stores some list of declarations that should be considered -- in scope. 'DsM' is the prototypical inhabitant of 'DsMonad'. -class Quasi m => DsMonad m where +class (Quasi m, Fail.MonadFail m) => DsMonad m where -- | Produce a list of local declarations. localDeclarations :: m [Dec] @@ -176,16 +170,13 @@ -- | A convenient implementation of the 'DsMonad' class. Use by calling -- 'withLocalDeclarations'. newtype DsM q a = DsM (ReaderT [Dec] q a) - deriving ( Functor, Applicative, Monad, MonadTrans, Quasi -#if __GLASGOW_HASKELL__ >= 800 - , Fail.MonadFail -#endif + deriving ( Functor, Applicative, Monad, MonadTrans, Quasi, Fail.MonadFail #if __GLASGOW_HASKELL__ >= 803 , MonadIO #endif ) -instance Quasi q => DsMonad (DsM q) where +instance (Quasi q, Fail.MonadFail q) => DsMonad (DsM q) where localDeclarations = DsM ask instance DsMonad m => DsMonad (ReaderT r m) where @@ -228,7 +219,7 @@ reifyInDec :: Name -> [Dec] -> Dec -> Maybe (Named Info) reifyInDec n decs (FunD n' _) | n `nameMatches` n' = Just (n', mkVarI n decs) reifyInDec n decs (ValD pat _ _) - | Just n' <- find (nameMatches n) (S.elems (extractBoundNamesPat pat)) = Just (n', mkVarI n decs) + | Just n' <- find (nameMatches n) (F.toList (extractBoundNamesPat pat)) = Just (n', mkVarI n decs) #if __GLASGOW_HASKELL__ > 710 reifyInDec n _ dec@(DataD _ n' _ _ _ _) | n `nameMatches` n' = Just (n', TyConI dec) reifyInDec n _ dec@(NewtypeD _ n' _ _ _ _) | n `nameMatches` n' = Just (n', TyConI dec) @@ -238,26 +229,24 @@ #endif reifyInDec n _ dec@(TySynD n' _ _) | n `nameMatches` n' = Just (n', TyConI dec) reifyInDec n decs dec@(ClassD _ n' _ _ _) | n `nameMatches` n' - = Just (n', ClassI (stripClassDec dec) (findInstances n decs)) + = Just (n', ClassI (quantifyClassDecMethods dec) (findInstances n decs)) reifyInDec n decs (ForeignD (ImportF _ _ _ n' ty)) | n `nameMatches` n' = Just (n', mkVarITy n decs ty) reifyInDec n decs (ForeignD (ExportF _ _ n' ty)) | n `nameMatches` n' = Just (n', mkVarITy n decs ty) #if __GLASGOW_HASKELL__ > 710 reifyInDec n decs dec@(OpenTypeFamilyD (TypeFamilyHead n' _ _ _)) | n `nameMatches` n' - = Just (n', FamilyI (handleBug8884 dec) (findInstances n decs)) + = Just (n', FamilyI dec (findInstances n decs)) reifyInDec n decs dec@(DataFamilyD n' _ _) | n `nameMatches` n' - = Just (n', FamilyI (handleBug8884 dec) (findInstances n decs)) + = Just (n', FamilyI dec (findInstances n decs)) reifyInDec n _ dec@(ClosedTypeFamilyD (TypeFamilyHead n' _ _ _) _) | n `nameMatches` n' = Just (n', FamilyI dec []) #else reifyInDec n decs dec@(FamilyD _ n' _ _) | n `nameMatches` n' - = Just (n', FamilyI (handleBug8884 dec) (findInstances n decs)) -#if __GLASGOW_HASKELL__ >= 707 + = Just (n', FamilyI dec (findInstances n decs)) reifyInDec n _ dec@(ClosedTypeFamilyD n' _ _ _) | n `nameMatches` n' = Just (n', FamilyI dec []) #endif -#endif #if __GLASGOW_HASKELL__ >= 801 reifyInDec n decs (PatSynD n' _ _ _) | n `nameMatches` n' = Just (n', mkPatSynI n decs) @@ -265,27 +254,27 @@ #if __GLASGOW_HASKELL__ > 710 reifyInDec n decs (DataD _ ty_name tvbs _mk cons _) - | Just info <- maybeReifyCon n decs ty_name (map tvbToType tvbs) cons + | Just info <- maybeReifyCon n decs ty_name (map tvbToTANormalWithSig tvbs) cons = Just info reifyInDec n decs (NewtypeD _ ty_name tvbs _mk con _) - | Just info <- maybeReifyCon n decs ty_name (map tvbToType tvbs) [con] + | Just info <- maybeReifyCon n decs ty_name (map tvbToTANormalWithSig tvbs) [con] = Just info #else reifyInDec n decs (DataD _ ty_name tvbs cons _) - | Just info <- maybeReifyCon n decs ty_name (map tvbToType tvbs) cons + | Just info <- maybeReifyCon n decs ty_name (map tvbToTANormalWithSig tvbs) cons = Just info reifyInDec n decs (NewtypeD _ ty_name tvbs con _) - | Just info <- maybeReifyCon n decs ty_name (map tvbToType tvbs) [con] + | Just info <- maybeReifyCon n decs ty_name (map tvbToTANormalWithSig tvbs) [con] = Just info #endif #if __GLASGOW_HASKELL__ > 710 reifyInDec n _decs (ClassD _ ty_name tvbs _ sub_decs) | Just (n', ty) <- findType n sub_decs - = Just (n', ClassOpI n (addClassCxt ty_name tvbs ty) ty_name) + = Just (n', ClassOpI n (quantifyClassMethodType ty_name tvbs True ty) ty_name) #else reifyInDec n decs (ClassD _ ty_name tvbs _ sub_decs) | Just (n', ty) <- findType n sub_decs - = Just (n', ClassOpI n (addClassCxt ty_name tvbs ty) + = Just (n', ClassOpI n (quantifyClassMethodType ty_name tvbs True ty) ty_name (fromMaybe defaultFixity $ reifyFixityInDecs n $ sub_decs ++ decs)) #endif @@ -303,25 +292,34 @@ reify_in_instance dec@(DataInstD {}) = reifyInDec n (sub_decs ++ decs) dec reify_in_instance dec@(NewtypeInstD {}) = reifyInDec n (sub_decs ++ decs) dec reify_in_instance _ = Nothing -#if __GLASGOW_HASKELL__ > 710 +#if __GLASGOW_HASKELL__ >= 807 +reifyInDec n decs (DataInstD _ _ lhs _ cons _) + | (ConT ty_name, tys) <- unfoldType lhs + , Just info <- maybeReifyCon n decs ty_name tys cons + = Just info +reifyInDec n decs (NewtypeInstD _ _ lhs _ con _) + | (ConT ty_name, tys) <- unfoldType lhs + , Just info <- maybeReifyCon n decs ty_name tys [con] + = Just info +#elif __GLASGOW_HASKELL__ > 710 reifyInDec n decs (DataInstD _ ty_name tys _ cons _) - | Just info <- maybeReifyCon n decs ty_name tys cons + | Just info <- maybeReifyCon n decs ty_name (map TANormal tys) cons = Just info reifyInDec n decs (NewtypeInstD _ ty_name tys _ con _) - | Just info <- maybeReifyCon n decs ty_name tys [con] + | Just info <- maybeReifyCon n decs ty_name (map TANormal tys) [con] = Just info #else reifyInDec n decs (DataInstD _ ty_name tys cons _) - | Just info <- maybeReifyCon n decs ty_name tys cons + | Just info <- maybeReifyCon n decs ty_name (map TANormal tys) cons = Just info reifyInDec n decs (NewtypeInstD _ ty_name tys con _) - | Just info <- maybeReifyCon n decs ty_name tys [con] + | Just info <- maybeReifyCon n decs ty_name (map TANormal tys) [con] = Just info #endif reifyInDec _ _ _ = Nothing -maybeReifyCon :: Name -> [Dec] -> Name -> [Type] -> [Con] -> Maybe (Named Info) +maybeReifyCon :: Name -> [Dec] -> Name -> [TypeArg] -> [Con] -> Maybe (Named Info) #if __GLASGOW_HASKELL__ > 710 maybeReifyCon n _decs ty_name ty_args cons | Just (n', con) <- findCon n cons @@ -341,7 +339,17 @@ = Just (n', VarI n (maybeForallT tvbs [] $ mkArrows [result_ty] ty) Nothing fixity) #endif where - result_ty = foldl AppT (ConT ty_name) ty_args + result_ty = applyType (ConT ty_name) (map unSigTypeArg ty_args) + -- Make sure to call unSigTypeArg here. Otherwise, if you have this: + -- + -- data D (a :: k) = MkD { unD :: Proxy a } + -- + -- Then the type of unD will be reified as: + -- + -- unD :: forall k (a :: k). D (a :: k) -> Proxy a + -- + -- This is contrast to GHC's own reification, which will produce `D a` + -- (without the explicit kind signature) as the type of the first argument. con_to_type (NormalC _ stys) = mkArrows (map snd stys) result_ty con_to_type (RecC _ vstys) = mkArrows (map thdOf3 vstys) result_ty @@ -354,7 +362,7 @@ #if __GLASGOW_HASKELL__ < 711 fixity = fromMaybe defaultFixity $ reifyFixityInDecs n decs #endif - tvbs = map PlainTV $ S.elems $ freeNamesOfTypes ty_args + tvbs = freeVariablesWellScoped $ map probablyWrongUnTypeArg ty_args maybeReifyCon _ _ _ _ _ = Nothing mkVarI :: Name -> [Dec] -> Info @@ -399,17 +407,35 @@ #endif | ConT n' <- ty_head ty , n `nameMatches` n' = [d] -#if __GLASGOW_HASKELL__ > 710 +#if __GLASGOW_HASKELL__ >= 807 + match_instance (DataInstD ctxt _ lhs mk cons derivs) + | ConT n' <- ty_head lhs + , n `nameMatches` n' = [d] + where + mtvbs = rejig_data_inst_tvbs ctxt lhs mk + d = DataInstD ctxt mtvbs lhs mk cons derivs + match_instance (NewtypeInstD ctxt _ lhs mk con derivs) + | ConT n' <- ty_head lhs + , n `nameMatches` n' = [d] + where + mtvbs = rejig_data_inst_tvbs ctxt lhs mk + d = NewtypeInstD ctxt mtvbs lhs mk con derivs +#elif __GLASGOW_HASKELL__ > 710 match_instance d@(DataInstD _ n' _ _ _ _) | n `nameMatches` n' = [d] match_instance d@(NewtypeInstD _ n' _ _ _ _) | n `nameMatches` n' = [d] #else match_instance d@(DataInstD _ n' _ _ _) | n `nameMatches` n' = [d] match_instance d@(NewtypeInstD _ n' _ _ _) | n `nameMatches` n' = [d] #endif -#if __GLASGOW_HASKELL__ >= 707 - match_instance d@(TySynInstD n' _) | n `nameMatches` n' = [d] +#if __GLASGOW_HASKELL__ >= 807 + match_instance (TySynInstD (TySynEqn _ lhs rhs)) + | ConT n' <- ty_head lhs + , n `nameMatches` n' = [d] + where + mtvbs = rejig_tvbs [lhs, rhs] + d = TySynInstD (TySynEqn mtvbs lhs rhs) #else - match_instance d@(TySynInstD n' _ _) | n `nameMatches` n' = [d] + match_instance d@(TySynInstD n' _) | n `nameMatches` n' = [d] #endif #if __GLASGOW_HASKELL__ >= 711 @@ -420,33 +446,162 @@ = concatMap match_instance decs match_instance _ = [] - ty_head (ForallT _ _ ty) = ty_head ty - ty_head (AppT ty _) = ty_head ty - ty_head (SigT ty _) = ty_head ty - ty_head ty = ty +#if __GLASGOW_HASKELL__ >= 807 + -- See Note [Rejigging reified type family equations variable binders] + -- for why this is necessary. + rejig_tvbs :: [Type] -> Maybe [TyVarBndr] + rejig_tvbs ts = + let tvbs = freeVariablesWellScoped ts + in if null tvbs + then Nothing + else Just tvbs -stripClassDec :: Dec -> Dec -stripClassDec (ClassD cxt name tvbs fds sub_decs) - = ClassD cxt name tvbs fds sub_decs' + rejig_data_inst_tvbs :: Cxt -> Type -> Maybe Kind -> Maybe [TyVarBndr] + rejig_data_inst_tvbs cxt lhs mk = + rejig_tvbs $ cxt ++ [lhs] ++ maybeToList mk +#endif + + ty_head = fst . unfoldType + +{- +Note [Rejigging reified type family equations variable binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When reifying a type family instance (on GHC 8.8 or later), which quantified +type variables do you use? This might seem like a strange question to ask since +these instances already come equipped with a field of type `Maybe [TyVarBndr]`, +but it's not always the case that you want to use exactly that field. Here is +an example to better explain it: + + class C a where + type T b a + instance C (Maybe a) where + type forall b. T b (Maybe a) = a + +If the above instance were quoted, it would give you `Just [PlainTV b]`. But if +you were to reify ''T (and therefore retrieve the instance for T), you wouldn't +want to use that as your list of type variable binders! This is because +reifiying any type family always presents the information as though the type +family were top-level. Therefore, reifying T (in GHC, at least) would yield: + + type family T b a + type instance forall b a. T b (Maybe a) = a + +Note that we quantify over `b` *and* `a` here, not just `b`. To emulate this +GHC quirk, whenever we reify any type family instance, we just ignore the field +of type `Maybe [TyVarBndr]` and quantify over the instance afresh. It's a bit +tedious, but it gets the job done. (This is accomplished by the rejig_tvbs +function.) +-} + +-- Consider the following class declaration: +-- +-- [d| class C a where +-- method :: a -> b -> a |] +-- +-- When reifying C locally, quantifyClassDecMethods serves two purposes: +-- +-- 1. It quantifies the class method's local type variables. To illustrate this +-- point, this is how GHC would reify C: +-- +-- class C a where +-- method :: forall b. a -> b -> a +-- +-- Notice the presence of the explicit `forall b.`. quantifyClassDecMethods +-- performs this explicit quantification if necessary (as in the case in the +-- local C declaration, where `b` is implicitly quantified.) +-- 2. It emulates a quirk in the way old versions of GHC would reify class +-- declarations (Trac #15551). On versions of GHC older than 8.8, it would +-- reify C like so: +-- +-- class C a where +-- method :: forall a. C a => forall b. a -> b -> a +-- +-- Notice how GHC has added the (totally extraneous) `forall a. C a =>` +-- part! This is weird, but our primary goal in this module is to mimic +-- GHC's reification, so we play the part by adding the `forall`/class +-- context to each class method in quantifyClassDecMethods. +-- +-- Since Trac #15551 was fixed in GHC 8.8, this function doesn't perform +-- this step on 8.7 or later. +quantifyClassDecMethods :: Dec -> Dec +quantifyClassDecMethods (ClassD cxt cls_name cls_tvbs fds sub_decs) + = ClassD cxt cls_name cls_tvbs fds sub_decs' where sub_decs' = mapMaybe go sub_decs - go (SigD n ty) = Just $ SigD n $ addClassCxt name tvbs ty + go (SigD n ty) = + Just $ SigD n + $ quantifyClassMethodType cls_name cls_tvbs prepend_cls ty #if __GLASGOW_HASKELL__ > 710 go d@(OpenTypeFamilyD {}) = Just d go d@(DataFamilyD {}) = Just d #endif go _ = Nothing -stripClassDec dec = dec -addClassCxt :: Name -> [TyVarBndr] -> Type -> Type -addClassCxt class_name tvbs ty = ForallT tvbs class_cxt ty + -- See (2) in the comments for quantifyClassDecMethods. + prepend_cls :: Bool +#if __GLASGOW_HASKELL__ >= 807 + prepend_cls = False +#else + prepend_cls = True +#endif +quantifyClassDecMethods dec = dec + +-- Add explicit quantification to a class method's type if necessary. In this +-- example: +-- +-- [d| class C a where +-- method :: a -> b -> a |] +-- +-- If one invokes `quantifyClassMethodType C [a] prepend (a -> b -> a)`, then +-- the output will be: +-- +-- 1. `forall a. C a => forall b. a -> b -> a` (if `prepend` is True) +-- 2. `forall b. a -> b -> a` (if `prepend` is False) +-- +-- Whether you want `prepend` to be True or False depends on the situation. +-- When reifying an entire type class, like C, one does not need to prepend a +-- class context to each of the bundled method types (see the comments for +-- quantifyClassDecMethods), so False is appropriate. When one is only reifying +-- a single class method, like `method`, then one needs the class context to +-- appear in the reified type, so `True` is appropriate. +quantifyClassMethodType + :: Name -- ^ The class name. + -> [TyVarBndr] -- ^ The class's type variable binders. + -> Bool -- ^ If 'True', prepend a class predicate. + -> Type -- ^ The method type. + -> Type +quantifyClassMethodType cls_name cls_tvbs prepend meth_ty = + add_cls_cxt quantified_meth_ty where + add_cls_cxt :: Type -> Type + add_cls_cxt + | prepend = ForallT all_cls_tvbs cls_cxt + | otherwise = id + + cls_cxt :: Cxt #if __GLASGOW_HASKELL__ < 709 - class_cxt = [ClassP class_name (map tvbToType tvbs)] + cls_cxt = [ClassP cls_name (map tvbToType cls_tvbs)] #else - class_cxt = [foldl AppT (ConT class_name) (map tvbToType tvbs)] + cls_cxt = [foldl AppT (ConT cls_name) (map tvbToType cls_tvbs)] #endif + quantified_meth_ty :: Type + quantified_meth_ty + | null meth_tvbs + = meth_ty + | ForallT meth_tvbs' meth_ctxt meth_tau <- meth_ty + = ForallT (meth_tvbs ++ meth_tvbs') meth_ctxt meth_tau + | otherwise + = ForallT meth_tvbs [] meth_ty + + meth_tvbs :: [TyVarBndr] + meth_tvbs = deleteFirstsBy ((==) `on` tvName) + (freeVariablesWellScoped [meth_ty]) all_cls_tvbs + + -- Explicitly quantify any kind variables bound by the class, if any. + all_cls_tvbs :: [TyVarBndr] + all_cls_tvbs = freeVariablesWellScoped $ map tvbToTypeWithSig cls_tvbs + stripInstanceDec :: Dec -> Dec #if __GLASGOW_HASKELL__ >= 711 stripInstanceDec (InstanceD over cxt ty _) = InstanceD over cxt ty [] @@ -502,24 +657,6 @@ match_rec_sel (n', _, ty) | n `nameMatches` n' = Just (n', ty) match_rec_sel _ = Nothing - -handleBug8884 :: Dec -> Dec -#if __GLASGOW_HASKELL__ >= 707 -handleBug8884 = id -#else -handleBug8884 (FamilyD flav name tvbs m_kind) - = FamilyD flav name tvbs (Just stupid_kind) - where - kind_from_maybe = fromMaybe StarT - tvb_kind (PlainTV _) = Nothing - tvb_kind (KindedTV _ k) = Just k - - result_kind = kind_from_maybe m_kind - args_kinds = map (kind_from_maybe . tvb_kind) tvbs - - stupid_kind = mkArrows args_kinds result_kind -handleBug8884 dec = dec -#endif --------------------------------- -- Reifying fixities 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 @@ -23,14 +23,11 @@ IgnoreKinds(..), matchTy ) where +import Data.List import qualified Data.Map as M import qualified Data.Set as S -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 @@ -45,11 +42,13 @@ substTy :: Quasi q => DSubst -> DType -> q DType substTy vars (DForallT tvbs cxt ty) = substTyVarBndrs vars tvbs $ \vars' tvbs' -> do - cxt' <- mapM (substPred vars') cxt + cxt' <- mapM (substTy vars') cxt ty' <- substTy vars' ty return $ DForallT tvbs' cxt' ty' substTy vars (DAppT t1 t2) = DAppT <$> substTy vars t1 <*> substTy vars t2 +substTy vars (DAppKindT t k) = + DAppKindT <$> substTy vars t <*> substTy vars k substTy vars (DSigT ty ki) = DSigT <$> substTy vars ty <*> substTy vars ki substTy vars (DVarT n) @@ -79,28 +78,12 @@ k' <- substTy vars k 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) - | Just ty <- M.lookup n vars - = dTypeToDPred ty - | otherwise - = return $ DVarPr n -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. unionSubsts :: DSubst -> DSubst -> Maybe DSubst unionSubsts a b = let shared_key_set = M.keysSet a `S.intersection` M.keysSet b - matches_up = S.foldr (\name -> ((a M.! name) `geq` (b M.! name) &&)) + matches_up = S.foldr (\name -> ((a M.! name) == (b M.! name) &&)) True shared_key_set in if matches_up then return (a `M.union` b) else Nothing 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 @@ -30,8 +30,10 @@ conToTH, foreignToTH, pragmaToTH, ruleBndrToTH, clauseToTH, tvbToTH, cxtToTH, predToTH, derivClauseToTH, #if __GLASGOW_HASKELL__ >= 801 - patSynDirToTH + patSynDirToTH, #endif + + typeArgToTH ) where import Prelude hiding (exp) @@ -40,6 +42,7 @@ import Language.Haskell.TH hiding (cxt) import Language.Haskell.TH.Desugar.AST +import Language.Haskell.TH.Desugar.Core (DTypeArg(..)) import Language.Haskell.TH.Desugar.Util import Data.Maybe ( maybeToList, mapMaybe ) @@ -70,13 +73,13 @@ matchToTH (DMatch pat exp) = Match (patToTH pat) (NormalB (expToTH exp)) [] patToTH :: DPat -> Pat -patToTH (DLitPa lit) = LitP lit -patToTH (DVarPa n) = VarP n -patToTH (DConPa n pats) = ConP n (map patToTH pats) -patToTH (DTildePa pat) = TildeP (patToTH pat) -patToTH (DBangPa pat) = BangP (patToTH pat) -patToTH (DSigPa pat ty) = SigP (patToTH pat) (typeToTH ty) -patToTH DWildPa = WildP +patToTH (DLitP lit) = LitP lit +patToTH (DVarP n) = VarP n +patToTH (DConP n pats) = ConP n (map patToTH pats) +patToTH (DTildeP pat) = TildeP (patToTH pat) +patToTH (DBangP pat) = BangP (patToTH pat) +patToTH (DSigP pat ty) = SigP (patToTH pat) (typeToTH ty) +patToTH DWildP = WildP decsToTH :: [DDec] -> [Dec] decsToTH = concatMap decToTH @@ -104,12 +107,18 @@ decToTH (DTySynD n tvbs ty) = [TySynD n (map tvbToTH tvbs) (typeToTH ty)] decToTH (DClassD cxt n tvbs fds decs) = [ClassD (cxtToTH cxt) n (map tvbToTH tvbs) fds (decsToTH decs)] -#if __GLASGOW_HASKELL__ >= 711 -decToTH (DInstanceD over cxt ty decs) = - [InstanceD over (cxtToTH cxt) (typeToTH ty) (decsToTH decs)] +decToTH (DInstanceD over mtvbs _cxt _ty decs) = + [instanceDToTH over cxt' ty' decs] + where + (cxt', ty') = case mtvbs of + Nothing -> (_cxt, _ty) + Just _tvbs -> +#if __GLASGOW_HASKELL__ < 800 || __GLASGOW_HASKELL__ >= 802 + ([], DForallT _tvbs _cxt _ty) #else -decToTH (DInstanceD _ cxt ty decs) = - [InstanceD (cxtToTH cxt) (typeToTH ty) (decsToTH decs)] + -- See #117 + error $ "Explicit foralls in instance declarations " + ++ "are broken on GHC 8.0." #endif decToTH (DForeignD f) = [ForeignD (foreignToTH f)] #if __GLASGOW_HASKELL__ > 710 @@ -125,53 +134,46 @@ #else [FamilyD DataFam n (map tvbToTH tvbs) (fmap typeToTH mk)] #endif -decToTH (DDataInstD Data cxt n tys _mk cons derivings) = -#if __GLASGOW_HASKELL__ > 710 - [DataInstD (cxtToTH cxt) n (map typeToTH tys) (fmap typeToTH _mk) (map conToTH cons) - (concatMap derivClauseToTH derivings)] +decToTH (DDataInstD nd cxt mtvbs lhs mk cons derivings) = + let ndc = case (nd, cons) of + (Newtype, [con]) -> DNewtypeCon con + (Newtype, _) -> error "Newtype that doesn't have only one constructor" + (Data, _) -> DDataCons cons + in dataInstDecToTH ndc cxt mtvbs lhs mk derivings +#if __GLASGOW_HASKELL__ >= 807 +decToTH (DTySynInstD eqn) = [TySynInstD (snd $ tySynEqnToTH eqn)] #else - [DataInstD (cxtToTH cxt) n (map typeToTH tys) (map conToTH cons) - (map derivingToTH derivings)] +decToTH (DTySynInstD eqn) = + let (n, eqn') = tySynEqnToTH eqn in + [TySynInstD n eqn'] #endif -decToTH (DDataInstD Newtype cxt n tys _mk [con] derivings) = #if __GLASGOW_HASKELL__ > 710 - [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) - (map derivingToTH derivings)] -#endif -#if __GLASGOW_HASKELL__ < 707 -decToTH (DTySynInstD n eqn) = [tySynEqnToTHDec n eqn] -decToTH (DClosedTypeFamilyD (DTypeFamilyHead n tvbs frs _ann) eqns) = - (FamilyD TypeFam n (map tvbToTH tvbs) (frsToTH frs)) : - (map (tySynEqnToTHDec n) eqns) -decToTH (DRoleAnnotD {}) = [] -#else -decToTH (DTySynInstD n eqn) = [TySynInstD n (tySynEqnToTH eqn)] -#if __GLASGOW_HASKELL__ > 710 decToTH (DClosedTypeFamilyD (DTypeFamilyHead n tvbs frs ann) eqns) = [ClosedTypeFamilyD (TypeFamilyHead n (map tvbToTH tvbs) (frsToTH frs) ann) - (map tySynEqnToTH eqns) + (map (snd . tySynEqnToTH) eqns) ] #else decToTH (DClosedTypeFamilyD (DTypeFamilyHead n tvbs frs _ann) eqns) = - [ClosedTypeFamilyD n (map tvbToTH tvbs) (frsToTH frs) (map tySynEqnToTH eqns)] + [ClosedTypeFamilyD n (map tvbToTH tvbs) (frsToTH frs) (map (snd . tySynEqnToTH) eqns)] #endif decToTH (DRoleAnnotD n roles) = [RoleAnnotD n roles] +decToTH (DStandaloneDerivD mds mtvbs _cxt _ty) = + [standaloneDerivDToTH mds cxt' ty'] + where + (cxt', ty') = case mtvbs of + Nothing -> (_cxt, _ty) + Just _tvbs -> +#if __GLASGOW_HASKELL__ < 710 || __GLASGOW_HASKELL__ >= 802 + ([], DForallT _tvbs _cxt _ty) +#else + -- See #117 + error $ "Explicit foralls in standalone deriving declarations " + ++ "are broken on GHC 7.10 and 8.0." #endif #if __GLASGOW_HASKELL__ < 709 -decToTH (DStandaloneDerivD {}) = - error "Standalone deriving supported only in GHC 7.10+" decToTH (DDefaultSigD {}) = error "Default method signatures supported only in GHC 7.10+" #else -decToTH (DStandaloneDerivD _mds cxt ty) = - [StandaloneDerivD -#if __GLASGOW_HASKELL__ >= 801 - (fmap derivStrategyToTH _mds) -#endif - (cxtToTH cxt) (typeToTH ty)] decToTH (DDefaultSigD n ty) = [DefaultSigD n (typeToTH ty)] #endif #if __GLASGOW_HASKELL__ >= 801 @@ -186,6 +188,49 @@ #endif decToTH _ = error "Newtype declaration without exactly 1 constructor." +-- | Indicates whether something is a newtype or data type, bundling its +-- constructor(s) along with it. +data DNewOrDataCons + = DNewtypeCon DCon + | DDataCons [DCon] + +-- | Sweeten a 'DDataInstD'. +dataInstDecToTH :: DNewOrDataCons -> DCxt -> Maybe [DTyVarBndr] -> DType + -> Maybe DKind -> [DDerivClause] -> [Dec] +dataInstDecToTH ndc cxt _mtvbs lhs _mk derivings = + case ndc of + DNewtypeCon con -> +#if __GLASGOW_HASKELL__ >= 807 + [NewtypeInstD (cxtToTH cxt) (fmap (fmap tvbToTH) _mtvbs) (typeToTH lhs) + (fmap typeToTH _mk) (conToTH con) + (concatMap derivClauseToTH derivings)] +#elif __GLASGOW_HASKELL__ > 710 + [NewtypeInstD (cxtToTH cxt) _n _lhs_args (fmap typeToTH _mk) (conToTH con) + (concatMap derivClauseToTH derivings)] +#else + [NewtypeInstD (cxtToTH cxt) _n _lhs_args (conToTH con) + (map derivingToTH derivings)] +#endif + + DDataCons cons -> +#if __GLASGOW_HASKELL__ >= 807 + [DataInstD (cxtToTH cxt) (fmap (fmap tvbToTH) _mtvbs) (typeToTH lhs) + (fmap typeToTH _mk) (map conToTH cons) + (concatMap derivClauseToTH derivings)] +#elif __GLASGOW_HASKELL__ > 710 + [DataInstD (cxtToTH cxt) _n _lhs_args (fmap typeToTH _mk) (map conToTH cons) + (concatMap derivClauseToTH derivings)] +#else + [DataInstD (cxtToTH cxt) _n _lhs_args (map conToTH cons) + (map derivingToTH derivings)] +#endif + where + _lhs' = typeToTH lhs + (_n, _lhs_args) = + case unfoldType _lhs' of + (ConT n, lhs_args) -> (n, filterTANormals lhs_args) + (_, _) -> error $ "Illegal data instance LHS: " ++ pprint _lhs' + #if __GLASGOW_HASKELL__ > 710 frsToTH :: DFamilyResultSig -> FamilyResultSig frsToTH DNoSig = NoSig @@ -201,7 +246,7 @@ #if __GLASGOW_HASKELL__ <= 710 derivingToTH :: DDerivClause -> Name -derivingToTH (DDerivClause _ [DConPr nm]) = nm +derivingToTH (DDerivClause _ [DConT nm]) = nm derivingToTH p = error ("Template Haskell in GHC < 8.0 only allows simple derivings: " ++ show p) #endif @@ -268,19 +313,41 @@ 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 + -- These won't show up on pre-8.0 GHCs + go (DForallT {}) = error "`forall` type used in GADT return type" + go DWildCardT = 0 + go (DAppKindT {}) = 0 con' :: Con con' = conToTH $ DCon [] [] n fields rty #endif +instanceDToTH :: Maybe Overlap -> DCxt -> DType -> [DDec] -> Dec +instanceDToTH _over cxt ty decs = + InstanceD +#if __GLASGOW_HASKELL__ >= 800 + _over +#endif + (cxtToTH cxt) (typeToTH ty) (decsToTH decs) + +standaloneDerivDToTH :: Maybe DDerivStrategy -> DCxt -> DType -> Dec +#if __GLASGOW_HASKELL__ >= 710 +standaloneDerivDToTH _mds cxt ty = + StandaloneDerivD +#if __GLASGOW_HASKELL__ >= 802 + (fmap derivStrategyToTH _mds) +#endif + (cxtToTH cxt) (typeToTH ty) +#else +standaloneDerivDToTH _ _ _ = error "Standalone deriving supported only in GHC 7.10+" +#endif + foreignToTH :: DForeign -> Foreign foreignToTH (DImportF cc safety str n ty) = ImportF cc safety str n (typeToTH ty) @@ -291,13 +358,15 @@ pragmaToTH (DSpecialiseP n ty m_inl phases) = Just $ SpecialiseP n (typeToTH ty) m_inl phases pragmaToTH (DSpecialiseInstP ty) = Just $ SpecialiseInstP (typeToTH ty) -pragmaToTH (DRuleP str rbs lhs rhs phases) = - Just $ RuleP str (map ruleBndrToTH rbs) (expToTH lhs) (expToTH rhs) phases -#if __GLASGOW_HASKELL__ < 707 -pragmaToTH (DAnnP {}) = Nothing +#if __GLASGOW_HASKELL__ >= 807 +pragmaToTH (DRuleP str mtvbs rbs lhs rhs phases) = + Just $ RuleP str (fmap (fmap tvbToTH) mtvbs) (map ruleBndrToTH rbs) + (expToTH lhs) (expToTH rhs) phases #else -pragmaToTH (DAnnP target exp) = Just $ AnnP target (expToTH exp) +pragmaToTH (DRuleP str _ rbs lhs rhs phases) = + Just $ RuleP str (map ruleBndrToTH rbs) (expToTH lhs) (expToTH rhs) phases #endif +pragmaToTH (DAnnP target exp) = Just $ AnnP target (expToTH exp) #if __GLASGOW_HASKELL__ < 709 pragmaToTH (DLineP {}) = Nothing #else @@ -313,15 +382,22 @@ ruleBndrToTH (DRuleVar n) = RuleVar n ruleBndrToTH (DTypedRuleVar n ty) = TypedRuleVar n (typeToTH ty) -#if __GLASGOW_HASKELL__ < 707 --- | GHC 7.6.3 doesn't have TySynEqn, so we sweeten to a Dec in GHC 7.6.3; --- GHC 7.8+ does not use this function -tySynEqnToTHDec :: Name -> DTySynEqn -> Dec -tySynEqnToTHDec n (DTySynEqn lhs rhs) = - TySynInstD n (map typeToTH lhs) (typeToTH rhs) +#if __GLASGOW_HASKELL__ >= 807 +-- | It's convenient to also return a 'Name' here, since some call sites make +-- use of it. +tySynEqnToTH :: DTySynEqn -> (Name, TySynEqn) +tySynEqnToTH (DTySynEqn tvbs lhs rhs) = + let lhs' = typeToTH lhs in + case unfoldType lhs' of + (ConT n, _lhs_args) -> (n, TySynEqn (fmap (fmap tvbToTH) tvbs) lhs' (typeToTH rhs)) + (_, _) -> error $ "Illegal type instance LHS: " ++ pprint lhs' #else -tySynEqnToTH :: DTySynEqn -> TySynEqn -tySynEqnToTH (DTySynEqn lhs rhs) = TySynEqn (map typeToTH lhs) (typeToTH rhs) +tySynEqnToTH :: DTySynEqn -> (Name, TySynEqn) +tySynEqnToTH (DTySynEqn _ lhs rhs) = + let lhs' = typeToTH lhs in + case unfoldType lhs' of + (ConT n, lhs_args) -> (n, TySynEqn (filterTANormals lhs_args) (typeToTH rhs)) + (_, _) -> error $ "Illegal type instance LHS: " ++ pprint lhs' #endif clauseToTH :: DClause -> Clause @@ -340,6 +416,13 @@ #else typeToTH DWildCardT = error "Wildcards supported only in GHC 8.0+" #endif +#if __GLASGOW_HASKELL__ >= 807 +typeToTH (DAppKindT t k) = AppKindT (typeToTH t) (typeToTH k) +#else +-- In the event that we're on a version of Template Haskell without support for +-- kind applications, we will simply drop the applied kind. +typeToTH (DAppKindT t _) = typeToTH t +#endif tvbToTH :: DTyVarBndr -> TyVarBndr tvbToTH (DPlainTV n) = PlainTV n @@ -380,37 +463,53 @@ #if __GLASGOW_HASKELL__ < 709 predToTH = go [] where - go acc (DAppPr p t) = go (typeToTH t : acc) p - go acc (DSigPr p _) = go acc p -- this shouldn't happen. - go _ (DVarPr _) - = error "Template Haskell in GHC <= 7.8 does not support variable constraints." - go acc (DConPr n) + go acc (DAppT p t) = go (typeToTH t : acc) p + -- In the event that we're on a version of Template Haskell without support + -- for kind applications, we will simply drop the applied kind. + go acc (DAppKindT t _) = go acc t + go acc (DSigT p _) = go acc p -- this shouldn't happen. + go acc (DConT n) | nameBase n == "~" , [t1, t2] <- acc = EqualP t1 t2 | otherwise = ClassP n acc - go _ DWildCardPr + go _ (DVarT _) + = error "Template Haskell in GHC <= 7.8 does not support variable constraints." + go _ DWildCardT = error "Wildcards supported only in GHC 8.0+" - go _ (DForallPr {}) + go _ (DForallT {}) = error "Quantified constraints supported only in GHC 8.6+" + go _ DArrowT + = error "(->) spotted at head of a constraint" + go _ (DLitT {}) + = error "Type-level literal spotted at head of a constraint" #else -predToTH (DAppPr p t) = AppT (predToTH p) (typeToTH t) -predToTH (DSigPr p k) = SigT (predToTH p) (typeToTH k) -predToTH (DVarPr n) = VarT n -predToTH (DConPr n) = typeToTH (DConT n) +predToTH (DAppT p t) = AppT (predToTH p) (typeToTH t) +predToTH (DSigT p k) = SigT (predToTH p) (typeToTH k) +predToTH (DVarT n) = VarT n +predToTH (DConT n) = typeToTH (DConT n) +predToTH DArrowT = ArrowT +predToTH (DLitT lit) = LitT lit #if __GLASGOW_HASKELL__ > 710 -predToTH DWildCardPr = WildCardT +predToTH DWildCardT = WildCardT #else -predToTH DWildCardPr = error "Wildcards supported only in GHC 8.0+" +predToTH DWildCardT = error "Wildcards supported only in GHC 8.0+" #endif #if __GLASGOW_HASKELL__ >= 805 -predToTH (DForallPr tvbs cxt p) = +predToTH (DForallT tvbs cxt p) = ForallT (map tvbToTH tvbs) (map predToTH cxt) (predToTH p) #else -predToTH (DForallPr {}) = error "Quantified constraints supported only in GHC 8.6+" +predToTH (DForallT {}) = error "Quantified constraints supported only in GHC 8.6+" #endif +#if __GLASGOW_HASKELL__ >= 807 +predToTH (DAppKindT p k) = AppKindT (predToTH p) (typeToTH k) +#else +-- In the event that we're on a version of Template Haskell without support for +-- kind applications, we will simply drop the applied kind. +predToTH (DAppKindT p _) = predToTH p #endif +#endif tyconToTH :: Name -> Type tyconToTH n @@ -430,14 +529,14 @@ #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 | otherwise = ConT n + +typeArgToTH :: DTypeArg -> TypeArg +typeArgToTH (DTANormal t) = TANormal (typeToTH t) +typeArgToTH (DTyArg k) = TyArg (typeToTH k) #if __GLASGOW_HASKELL__ <= 710 -- | Convert a 'Bang' to a 'Strict' 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 @@ -6,10 +6,12 @@ Utility functions for th-desugar package. -} -{-# LANGUAGE CPP, TupleSections #-} +{-# LANGUAGE CPP, DeriveDataTypeable, RankNTypes, ScopedTypeVariables, TupleSections #-} #if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE TypeApplications #-} #endif module Language.Haskell.TH.Desugar.Util ( @@ -21,33 +23,43 @@ stripPlainTV_maybe, thirdOf3, splitAtList, extractBoundNamesDec, extractBoundNamesPat, - tvbName, tvbToType, nameMatches, freeNamesOfTypes, thdOf3, firstMatch, + tvbToType, tvbToTypeWithSig, tvbToTANormalWithSig, + nameMatches, thdOf3, firstMatch, unboxedSumDegree_maybe, unboxedSumNameDegree_maybe, tupleDegree_maybe, tupleNameDegree_maybe, unboxedTupleDegree_maybe, unboxedTupleNameDegree_maybe, splitTuple_maybe, topEverywhereM, isInfixDataCon, isTypeKindName, typeKindName, - mkExtraKindBindersGeneric, unravelType + mkExtraKindBindersGeneric, unravelType, unSigType, unfoldType, + TypeArg(..), applyType, filterTANormals, unSigTypeArg, probablyWrongUnTypeArg +#if __GLASGOW_HASKELL__ >= 800 + , bindIP +#endif ) where import Prelude hiding (mapM, foldl, concatMap, any) import Language.Haskell.TH hiding ( cxt ) +import Language.Haskell.TH.Datatype (tvName) +import qualified Language.Haskell.TH.Desugar.OSet as OS +import Language.Haskell.TH.Desugar.OSet (OSet) import Language.Haskell.TH.Syntax import Control.Monad ( replicateM ) -import qualified Data.Set as S +import qualified Control.Monad.Fail as Fail import Data.Foldable import Data.Generics hiding ( Fixity ) import Data.Traversable import Data.Maybe -#if __GLASGOW_HASKELL__ >= 800 -import qualified Data.Kind as Kind +#if __GLASGOW_HASKELL__ < 710 +import Data.Monoid #endif -#if __GLASGOW_HASKELL__ < 804 -import Data.Monoid +#if __GLASGOW_HASKELL__ >= 800 +import qualified Data.Kind as Kind +import GHC.Classes ( IP ) +import Unsafe.Coerce ( unsafeCoerce ) #endif ---------------------------------------- @@ -104,18 +116,25 @@ stripPlainTV_maybe _ = Nothing -- | Report that a certain TH construct is impossible -impossible :: Monad q => String -> q a -impossible err = fail (err ++ "\n This should not happen in Haskell.\n Please email rae@cs.brynmawr.edu with your code if you see this.") - --- | Extract a 'Name' from a 'TyVarBndr' -tvbName :: TyVarBndr -> Name -tvbName (PlainTV n) = n -tvbName (KindedTV n _) = n +impossible :: Fail.MonadFail q => String -> q a +impossible err = Fail.fail (err ++ "\n This should not happen in Haskell.\n Please email rae@cs.brynmawr.edu with your code if you see this.") --- | Convert a 'TyVarBndr' into a 'Type' +-- | Convert a 'TyVarBndr' into a 'Type', dropping the kind signature +-- (if it has one). tvbToType :: TyVarBndr -> Type -tvbToType = VarT . tvbName +tvbToType = VarT . tvName +-- | Convert a 'TyVarBndr' into a 'Type', preserving the kind signature +-- (if it has one). +tvbToTypeWithSig :: TyVarBndr -> Type +tvbToTypeWithSig (PlainTV n) = VarT n +tvbToTypeWithSig (KindedTV n k) = SigT (VarT n) k + +-- | Convert a 'TyVarBndr' into a 'TypeArg' (specifically, a 'TANormal'), +-- preserving the kind signature (if it has one). +tvbToTANormalWithSig :: TyVarBndr -> TypeArg +tvbToTANormalWithSig = TANormal . tvbToTypeWithSig + -- | Do two names name the same thing? nameMatches :: Name -> Name -> Bool nameMatches n1@(Name occ1 flav1) n2@(Name occ2 flav2) @@ -210,6 +229,103 @@ (tvbs, cxt, t1 : tys, res) unravelType t = ([], [], [], t) +-- | Remove all of the explicit kind signatures from a 'Type'. +unSigType :: Type -> Type +unSigType (SigT t _) = t +unSigType (AppT f x) = AppT (unSigType f) (unSigType x) +unSigType (ForallT tvbs ctxt t) = + ForallT tvbs (map unSigPred ctxt) (unSigType t) +#if __GLASGOW_HASKELL__ >= 800 +unSigType (InfixT t1 n t2) = InfixT (unSigType t1) n (unSigType t2) +unSigType (UInfixT t1 n t2) = UInfixT (unSigType t1) n (unSigType t2) +unSigType (ParensT t) = ParensT (unSigType t) +#endif +#if __GLASGOW_HASKELL__ >= 807 +unSigType (AppKindT t k) = AppKindT (unSigType t) (unSigType k) +unSigType (ImplicitParamT n t) = ImplicitParamT n (unSigType t) +#endif +unSigType t = t + +-- | Remove all of the explicit kind signatures from a 'Pred'. +unSigPred :: Pred -> Pred +#if __GLASGOW_HASKELL__ >= 710 +unSigPred = unSigType +#else +unSigPred (ClassP n tys) = ClassP n (map unSigType tys) +unSigPred (EqualP t1 t2) = EqualP (unSigType t1) (unSigType t2) +#endif + +-- | Decompose an applied type into its individual components. For example, this: +-- +-- @ +-- Proxy \@Type Char +-- @ +-- +-- would be unfolded to this: +-- +-- @ +-- ('ConT' ''Proxy, ['TyArg' ('ConT' ''Type), 'TANormal' ('ConT' ''Char)]) +-- @ +unfoldType :: Type -> (Type, [TypeArg]) +unfoldType = go [] + where + go :: [TypeArg] -> Type -> (Type, [TypeArg]) + go acc (ForallT _ _ ty) = go acc ty + go acc (AppT ty1 ty2) = go (TANormal ty2:acc) ty1 + go acc (SigT ty _) = go acc ty +#if __GLASGOW_HASKELL__ >= 800 + go acc (ParensT ty) = go acc ty +#endif +#if __GLASGOW_HASKELL__ >= 807 + go acc (AppKindT ty ki) = go (TyArg ki:acc) ty +#endif + go acc ty = (ty, acc) + +-- | An argument to a type, either a normal type ('TANormal') or a visible +-- kind application ('TyArg'). +-- +-- 'TypeArg' is useful when decomposing an application of a 'Type' to its +-- arguments (e.g., in 'unfoldType'). +data TypeArg + = TANormal Type + | TyArg Kind + deriving (Eq, Show, Typeable, Data) + +-- | Apply one 'Type' to a list of arguments. +applyType :: Type -> [TypeArg] -> Type +applyType = foldl apply + where + apply :: Type -> TypeArg -> Type + apply f (TANormal x) = f `AppT` x + apply f (TyArg _x) = +#if __GLASGOW_HASKELL__ >= 807 + f `AppKindT` _x +#else + -- VKA isn't supported, so + -- conservatively drop the argument + f +#endif + +-- | Filter the normal type arguments from a list of 'TypeArg's. +filterTANormals :: [TypeArg] -> [Type] +filterTANormals = mapMaybe getTANormal + where + getTANormal :: TypeArg -> Maybe Type + getTANormal (TANormal t) = Just t + getTANormal (TyArg {}) = Nothing + +-- | Remove all of the explicit kind signatures from a 'TypeArg'. +unSigTypeArg :: TypeArg -> TypeArg +unSigTypeArg (TANormal t) = TANormal (unSigType t) +unSigTypeArg (TyArg k) = TyArg (unSigType k) + +-- | Extract the underlying 'Type' or 'Kind' from a 'TypeArg'. This forgets +-- information about whether a type is a normal argument or not, so use with +-- caution. +probablyWrongUnTypeArg :: TypeArg -> Type +probablyWrongUnTypeArg (TANormal t) = t +probablyWrongUnTypeArg (TyArg k) = k + ---------------------------------------- -- Free names, etc. ---------------------------------------- @@ -223,34 +339,38 @@ allNamesIn = everything (++) $ mkQ [] (:[]) -- | Extract the names bound in a @Stmt@ -extractBoundNamesStmt :: Stmt -> S.Set Name +extractBoundNamesStmt :: Stmt -> OSet Name extractBoundNamesStmt (BindS pat _) = extractBoundNamesPat pat extractBoundNamesStmt (LetS decs) = foldMap extractBoundNamesDec decs -extractBoundNamesStmt (NoBindS _) = S.empty +extractBoundNamesStmt (NoBindS _) = OS.empty extractBoundNamesStmt (ParS stmtss) = foldMap (foldMap extractBoundNamesStmt) stmtss +#if __GLASGOW_HASKELL__ >= 807 +extractBoundNamesStmt (RecS stmtss) = foldMap extractBoundNamesStmt stmtss +#endif -- | Extract the names bound in a @Dec@ that could appear in a @let@ expression. -extractBoundNamesDec :: Dec -> S.Set Name -extractBoundNamesDec (FunD name _) = S.singleton name +extractBoundNamesDec :: Dec -> OSet Name +extractBoundNamesDec (FunD name _) = OS.singleton name extractBoundNamesDec (ValD pat _ _) = extractBoundNamesPat pat -extractBoundNamesDec _ = S.empty +extractBoundNamesDec _ = OS.empty -- | Extract the names bound in a @Pat@ -extractBoundNamesPat :: Pat -> S.Set Name -extractBoundNamesPat (LitP _) = S.empty -extractBoundNamesPat (VarP name) = S.singleton name +extractBoundNamesPat :: Pat -> OSet Name +extractBoundNamesPat (LitP _) = OS.empty +extractBoundNamesPat (VarP name) = OS.singleton name extractBoundNamesPat (TupP pats) = foldMap extractBoundNamesPat pats extractBoundNamesPat (UnboxedTupP pats) = foldMap extractBoundNamesPat pats extractBoundNamesPat (ConP _ pats) = foldMap extractBoundNamesPat pats -extractBoundNamesPat (InfixP p1 _ p2) = extractBoundNamesPat p1 `S.union` +extractBoundNamesPat (InfixP p1 _ p2) = extractBoundNamesPat p1 `OS.union` extractBoundNamesPat p2 -extractBoundNamesPat (UInfixP p1 _ p2) = extractBoundNamesPat p1 `S.union` +extractBoundNamesPat (UInfixP p1 _ p2) = extractBoundNamesPat p1 `OS.union` extractBoundNamesPat p2 extractBoundNamesPat (ParensP pat) = extractBoundNamesPat pat extractBoundNamesPat (TildeP pat) = extractBoundNamesPat pat extractBoundNamesPat (BangP pat) = extractBoundNamesPat pat -extractBoundNamesPat (AsP name pat) = S.singleton name `S.union` extractBoundNamesPat pat -extractBoundNamesPat WildP = S.empty +extractBoundNamesPat (AsP name pat) = OS.singleton name `OS.union` + extractBoundNamesPat pat +extractBoundNamesPat WildP = OS.empty extractBoundNamesPat (RecP _ field_pats) = let (_, pats) = unzip field_pats in foldMap extractBoundNamesPat pats extractBoundNamesPat (ListP pats) = foldMap extractBoundNamesPat pats @@ -260,30 +380,22 @@ extractBoundNamesPat (UnboxedSumP pat _ _) = extractBoundNamesPat pat #endif -freeNamesOfTypes :: [Type] -> S.Set Name -freeNamesOfTypes = foldMap go - where - go (ForallT tvbs cxt ty) = (foldMap go_tvb tvbs <> go ty <> foldMap go_pred cxt) - S.\\ S.fromList (map tvbName tvbs) - go (AppT t1 t2) = go t1 <> go t2 - go (SigT ty ki) = go ty <> go ki - go (VarT n) = S.singleton n - go _ = S.empty - -#if __GLASGOW_HASKELL__ >= 709 - go_pred = go -#else - go_pred (ClassP _ tys) = freeNamesOfTypes tys - go_pred (EqualP t1 t2) = go t1 <> go t2 -#endif - - go_tvb (PlainTV{}) = S.empty - go_tvb (KindedTV _ k) = go k - ---------------------------------------- -- General utility ---------------------------------------- +#if __GLASGOW_HASKELL__ >= 800 +-- dirty implementation of explicit-to-implicit conversion +newtype MagicIP name a r = MagicIP (IP name a => r) + +-- | Get an implicit param constraint (@IP name a@, which is the desugared +-- form of @(?name :: a)@) from an explicit value. +-- +-- This function is only available with GHC 8.0 or later. +bindIP :: forall name a r. a -> (IP name a => r) -> r +bindIP val k = (unsafeCoerce (MagicIP @name k) :: a -> r) val +#endif + -- like GHC's splitAtList :: [a] -> [b] -> ([b], [b]) splitAtList [] x = ([], x) @@ -330,9 +442,9 @@ Nothing -> ys Just z -> z : ys -expectJustM :: Monad m => String -> Maybe a -> m a +expectJustM :: Fail.MonadFail m => String -> Maybe a -> m a expectJustM _ (Just x) = return x -expectJustM err Nothing = fail err +expectJustM err Nothing = Fail.fail err firstMatch :: (a -> Maybe b) -> [a] -> Maybe b firstMatch f xs = listToMaybe $ mapMaybe f xs diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -23,3 +23,68 @@ possible. I will try to keep this package up-to-date with respect to changes in GHC. + +Known limitations +----------------- +`th-desugar` sometimes has to construct types for certain Haskell entities. +For instance, `th-desugar` desugars all Haskell98-style constructors to use +GADT syntax, so the following: + +```haskell +data T (a :: k) = MkT (Proxy a) +``` + +Will be desugared to something like this: + +```haskell +data T (a :: k) where + MkT :: forall k (a :: k). Proxy a -> T (a :: k) +``` + +Notice that `k` is explicitly quantified in the type of `MkT`. This is due to +an additional pass that `th-desugar` performs over the type variable binders +of `T` to extract all implicitly quantified variables and make them explicit. +This makes the desugared types forwards-compatible with a +[future version of GHC](https://github.com/goldfirere/ghc-proposals/blob/bbefbee6fc0cddb10bbacc85f79e66c2706ce13f/proposals/0000-no-kind-vars.rst) +that requires all kind variables in a top-level `forall` to be explicitly +quantified. + +This process of extracting all implicitly quantified kind variables is not +perfect, however. There are some obscure programs that will cause `th-desugar` +to produce type variable binders that are ill scoped. Here is one example: + +```haskell +data P k (a :: k) +data Foo (a :: Proxy j) (b :: k) c = MkFoo c (P k j) +``` + +If you squint hard at `MkFoo`, you'll notice that `j :: k`. However, this +relationship is not expressed _syntactically_, which means that `th-desugar` +will not be aware of it. Therefore, `th-desugar` will desugar `Foo` to: + +```haskell +data Foo (a :: Proxy j) (b :: k) c where + MkFoo :: forall j k (a :: Proxy j) (b :: k) c. + c -> P k j -> Foo (a :: Proxy j) (b :: k) c +``` + +This is incorrect since `k` must come before `j` in order to be well scoped. +There is a workaround to this issue, however: add more explicit kind +information. If you had instead written this: + +```haskell +data Foo (a :: Proxy (j :: k)) (b :: k) c = MkFoo c (P k j) +``` + +Then the fact that `j :: k` is expressed directly in the AST, so `th-desugar` +is able to pick up on it and pick `forall k j (a :: Proxy j) (b :: k) c. <...>` +as the telescope for the type of `MkFoo`. + +The following constructs are known to be susceptible to this issue: + +1. Desugared Haskell98-style constructors +2. Locally reified class methods +3. Locally reified record selectors +4. Locally reified data constructors +5. Locally reified type family instances (on GHC 8.8 and later, in which the + Template Haskell AST supports explicit `foralls` in type family equations) diff --git a/Test/Dec.hs b/Test/Dec.hs --- a/Test/Dec.hs +++ b/Test/Dec.hs @@ -8,9 +8,9 @@ MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, DataKinds, CPP, RankNTypes, StandaloneDeriving, DefaultSignatures, - ConstraintKinds #-} -#if __GLASGOW_HASKELL__ >= 707 -{-# LANGUAGE RoleAnnotations #-} + ConstraintKinds, RoleAnnotations #-} +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE DeriveAnyClass #-} #endif {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing #-} @@ -43,6 +43,13 @@ #if __GLASGOW_HASKELL__ >= 710 $(S.dectest15) +#endif + +#if __GLASGOW_HASKELL__ < 800 || __GLASGOW_HASKELL__ >= 802 +$(S.dectest16) +#endif +#if __GLASGOW_HASKELL__ >= 802 +$(S.dectest17) #endif $(fmap unqualify S.instance_test) diff --git a/Test/DsDec.hs b/Test/DsDec.hs --- a/Test/DsDec.hs +++ b/Test/DsDec.hs @@ -8,9 +8,9 @@ MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, DataKinds, CPP, RankNTypes, StandaloneDeriving, DefaultSignatures, - ConstraintKinds #-} -#if __GLASGOW_HASKELL__ >= 707 -{-# LANGUAGE RoleAnnotations #-} + ConstraintKinds, RoleAnnotations #-} +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE DeriveAnyClass #-} #endif #if __GLASGOW_HASKELL__ >= 801 {-# LANGUAGE DerivingStrategies #-} @@ -28,8 +28,8 @@ import qualified Splices as S import Splices ( dsDecSplice, unqualify ) -import Language.Haskell.TH ( reportError ) import Language.Haskell.TH.Desugar +import Language.Haskell.TH.Syntax ( qReport ) import Control.Monad import Data.Maybe( mapMaybe ) @@ -51,11 +51,7 @@ $(dsDecSplice (fmap unqualify S.imp_inst_test3)) $(dsDecSplice (fmap unqualify S.imp_inst_test4)) -#if __GLASGOW_HASKELL__ < 707 -$(return $ decsToTH [S.ds_dectest10]) -#else $(dsDecSplice S.dectest10) -#endif #if __GLASGOW_HASKELL__ >= 709 $(dsDecSplice S.dectest11) @@ -74,20 +70,28 @@ $(dsDecSplice S.dectest15) #endif +#if __GLASGOW_HASKELL__ < 800 || __GLASGOW_HASKELL__ >= 802 +$(return $ decsToTH [S.ds_dectest16]) +#endif +#if __GLASGOW_HASKELL__ >= 802 +$(return $ decsToTH [S.ds_dectest17]) +#endif + $(do decs <- S.rec_sel_test - [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 - when (num_sels /= S.rec_sel_test_num_sels) $ - reportError $ "Wrong number of record selectors extracted.\n" - ++ "Wanted " ++ show S.rec_sel_test_num_sels - ++ ", Got " ++ show num_sels - let unrecord c@(DCon _ _ _ (DNormalC {}) _) = c - unrecord (DCon tvbs cxt con_name (DRecC fields) rty) = - let (_names, stricts, types) = unzip3 fields - fields' = zip stricts types - in - DCon tvbs cxt con_name (DNormalC False fields') rty - plaindata = [DDataD nd [] name [DPlainTV tvbName] k (map unrecord cons) []] - return (decsToTH plaindata ++ mapMaybe letDecToTH recsels)) + withLocalDeclarations decs $ do + [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 + when (num_sels /= S.rec_sel_test_num_sels) $ + qReport True $ "Wrong number of record selectors extracted.\n" + ++ "Wanted " ++ show S.rec_sel_test_num_sels + ++ ", Got " ++ show num_sels + let unrecord c@(DCon _ _ _ (DNormalC {}) _) = c + unrecord (DCon tvbs cxt con_name (DRecC fields) rty) = + let (_names, stricts, types) = unzip3 fields + fields' = zip stricts types + in + DCon tvbs cxt con_name (DNormalC False fields') rty + 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 @@ -8,7 +8,7 @@ RankNTypes, TypeFamilies, DataKinds, ConstraintKinds, PolyKinds, MultiParamTypeClasses, FlexibleInstances, ExistentialQuantification, - ScopedTypeVariables, GADTs, ViewPatterns #-} + ScopedTypeVariables, GADTs, ViewPatterns, TupleSections #-} {-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns -fno-warn-unused-matches -fno-warn-type-defaults -fno-warn-missing-signatures -fno-warn-unused-do-bind @@ -17,6 +17,7 @@ #if __GLASGOW_HASKELL__ >= 711 {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-partial-type-signatures -Wno-redundant-constraints #-} #endif @@ -38,9 +39,8 @@ import qualified Dec import Dec ( RecordSel ) import Language.Haskell.TH.Desugar -#if __GLASGOW_HASKELL__ >= 707 +import qualified Language.Haskell.TH.Desugar.OSet as OS import Language.Haskell.TH.Desugar.Expand ( expandUnsoundly ) -#endif import Language.Haskell.TH import qualified Language.Haskell.TH.Syntax as Syn ( lift ) @@ -49,13 +49,9 @@ import Control.Applicative #endif -import Data.Generics ( geq ) import Data.Function ( on ) import qualified Data.Map as M -import qualified Data.Set as S -#if __GLASGOW_HASKELL__ >= 707 import Data.Proxy -#endif -- | -- Convert a HUnit test suite to a spec. This can be used to run existing @@ -86,10 +82,8 @@ , "case" ~: $test8_case @=? $(dsSplice test8_case) , "do" ~: $test9_do @=? $(dsSplice test9_do) , "comp" ~: $test10_comp @=? $(dsSplice test10_comp) -#if __GLASGOW_HASKELL__ >= 707 , "parcomp" ~: $test11_parcomp @=? $(dsSplice test11_parcomp) , "parcomp2" ~: $test12_parcomp2 @=? $(dsSplice test12_parcomp2) -#endif , "sig" ~: $test13_sig @=? $(dsSplice test13_sig) , "record" ~: $test14_record @=? $(dsSplice test14_record) , "litp" ~: $test15_litp @=? $(dsSplice test15_litp) @@ -137,6 +131,13 @@ #if __GLASGOW_HASKELL__ >= 805 , "quantified_constraints" ~: $test48_quantified_constraints @=? $(dsSplice test48_quantified_constraints) #endif +#if __GLASGOW_HASKELL__ >= 807 + , "implicit_params" ~: $test49_implicit_params @=? $(dsSplice test49_implicit_params) + , "vka" ~: $test50_vka @=? $(dsSplice test50_vka) +#endif +#if __GLASGOW_HASKELL__ >= 809 + , "tuple_sections" ~: $test51_tuple_sections @=? $(dsSplice test51_tuple_sections) +#endif ] test35a = $test35_expand @@ -147,7 +148,6 @@ test_e3b = $(test_expand3 >>= dsExp >>= expand >>= return . expToTH) test_e4a = $test_expand4 test_e4b = $(test_expand4 >>= dsExp >>= expand >>= return . expToTH) -#if __GLASGOW_HASKELL__ >= 707 test_e5a = $test_expand5 test_e5b = $(test_expand5 >>= dsExp >>= expand >>= return . expToTH) test_e6a = $test_expand6 @@ -161,7 +161,6 @@ -- closed type families. #endif test_e8b = $(test_expand8 >>= dsExp >>= expandUnsoundly >>= return . expToTH) -#endif #if __GLASGOW_HASKELL__ >= 709 test_e9a = $test_expand9 -- requires GHC #9262 test_e9b = $(test_expand9 >>= dsExp >>= expand >>= return . expToTH) @@ -175,7 +174,6 @@ , hasSameType test36a test36b , hasSameType test_e3a test_e3b , hasSameType test_e4a test_e4b -#if __GLASGOW_HASKELL__ >= 707 , hasSameType test_e5a test_e5b , hasSameType test_e6a test_e6b , hasSameType test_e7a test_e7b @@ -184,7 +182,6 @@ , hasSameType test_e8a test_e8a #endif , hasSameType test_e8b test_e8b -#endif #if __GLASGOW_HASKELL__ >= 709 , hasSameType test_e9a test_e9b #endif @@ -208,15 +205,15 @@ test_bug8884 :: Bool test_bug8884 = $(do info <- reify ''Poly dinfo@(DTyConI (DOpenTypeFamilyD (DTypeFamilyHead _name _tvbs (DKindSig resK) _ann)) - (Just [DTySynInstD _name2 (DTySynEqn lhs _rhs)])) + (Just [DTySynInstD (DTySynEqn _ lhs _rhs)])) <- dsInfo info let isTypeKind (DConT n) = isTypeKindName n isTypeKind _ = False case (isTypeKind resK, lhs) of #if __GLASGOW_HASKELL__ < 709 - (True, [DVarT _]) -> [| True |] + (True, _ `DAppT` DVarT _) -> [| True |] #else - (True, [DSigT (DVarT _) (DVarT _)]) -> [| True |] + (True, _ `DAppT` DSigT (DVarT _) (DVarT _)) -> [| True |] #endif _ -> do runIO $ do @@ -256,7 +253,8 @@ let orig_ty = DConT fam_name exp_ty <- withLocalDeclarations (decsToTH [ DOpenTypeFamilyD (DTypeFamilyHead fam_name [] DNoSig Nothing) - , DTySynInstD fam_name (DTySynEqn [] (DConT ''Int)) ]) + , DTySynInstD (DTySynEqn Nothing + (DConT fam_name) (DConT ''Int)) ]) (expandType orig_ty) orig_ty `eqTHSplice` exp_ty) @@ -274,8 +272,11 @@ (DKindSig (DVarT k)) Nothing) -- type instance F (x :: ()) = x - , DTySynInstD fam_name - (DTySynEqn [DSigT (DVarT x) (DConT ''())] (DVarT x)) + , DTySynInstD + (DTySynEqn Nothing + (DConT fam_name `DAppT` + DSigT (DVarT x) (DConT ''())) + (DVarT x)) ]) (expandType orig_ty) orig_ty `eqTHSplice` exp_ty) @@ -289,6 +290,24 @@ expanded_ty <- expandType orig_ty expected_ty `eqTHSplice` expanded_ty) +test_t92 :: Bool +test_t92 = + $(do a <- newName "a" + f <- newName "f" + let t = DForallT [DPlainTV f] [] (DVarT f `DAppT` DVarT a) + toposortTyVarsOf [t] `eqTHSplice` [DPlainTV a]) + +test_t97 :: Bool +test_t97 = + $(do a <- newName "a" + k <- newName "k" + let orig_ty = DForallT + [DKindedTV a (DConT ''Constant `DAppT` DConT ''Int `DAppT` DVarT k)] + [] (DVarT a) + expected_ty = DForallT [DKindedTV a (DVarT k)] [] (DVarT a) + expanded_ty <- expandType orig_ty + expected_ty `eqTHSplice` expanded_ty) + test_getDataD_kind_sig :: Bool test_getDataD_kind_sig = #if __GLASGOW_HASKELL__ >= 800 @@ -306,6 +325,62 @@ True -- DataD didn't have the ability to store kind signatures prior to GHC 8.0 #endif +test_t102 :: Bool +test_t102 = + $(do decs <- [d| data Foo x where MkFoo :: forall a. { unFoo :: a } -> Foo a |] + withLocalDeclarations decs $ do + [DDataD _ _ foo [DPlainTV x] _ cons _] <- dsDecs decs + recs <- getRecordSelectors (DConT foo `DAppT` DVarT x) cons + (length recs `div` 2) `eqTHSplice` 1) + +test_t103 :: Bool +test_t103 = +#if __GLASGOW_HASKELL__ >= 800 + $(do decs <- [d| data P (a :: k) = MkP |] + [DDataD _ _ _ _ _ [DCon tvbs _ _ _ _] _] <- dsDecs decs + case tvbs of + [DPlainTV k, DKindedTV a (DVarT k')] + | nameBase k == "k" + , nameBase a == "a" + , k == k' + -> [| True |] + | otherwise + -> [| False |]) +#else + True -- No explicit kind variable binders prior to GHC 8.0 +#endif + +test_t112 :: [Bool] +test_t112 = + $(do a <- newName "a" + b <- newName "b" + let [aVar, bVar] = map DVarT [a, b] + [aTvb, bTvb] = map DPlainTV [a, b] + let fvsABExpected = [aTvb, bTvb] + fvsABActual = toposortTyVarsOf [aVar, bVar] + + fvsBAExpected = [bTvb, aTvb] + fvsBAActual = toposortTyVarsOf [bVar, aVar] + + eqAB = fvsABExpected `eqTH` fvsABActual + eqBA = fvsBAExpected `eqTH` fvsBAActual + [| [eqAB, eqBA] |]) + +-- Unit tests for functions that compute free variables (e.g., fvDType) +test_fvs :: [Bool] +test_fvs = + $(do a <- newName "a" + + let -- (Show a => Show (Maybe a)) => String + ty1 = DForallT + [] + [DForallT [] [DConT ''Show `DAppT` DVarT a] + (DConT ''Show `DAppT` (DConT ''Maybe `DAppT` DVarT a))] + (DConT ''String) + b1 = fvDType ty1 `eqTH` OS.singleton a -- #93 + + [| [b1] |]) + test_kind_substitution :: [Bool] test_kind_substitution = $(do a <- newName "a" @@ -337,10 +412,10 @@ freeVars3 = fvDType substTy3 freeVars4 = fvDType substTy4 - b1 = freeVars1 `eqTH` S.singleton b - b2 = freeVars2 `eqTH` S.singleton b - b3 = freeVars3 `eqTH` S.empty - b4 = freeVars4 `eqTH` S.singleton k + b1 = freeVars1 `eqTH` OS.singleton b + b2 = freeVars2 `eqTH` OS.singleton b + b3 = freeVars3 `eqTH` OS.empty + b4 = freeVars4 `eqTH` OS.singleton k [| [b1, b2, b3, b4] |]) test_lookup_value_type_names :: [Bool] @@ -350,7 +425,7 @@ typeName <- newName nameStr let tyDec = DTySynD typeName [] (DConT ''Bool) decs = decsToTH [ DLetDec (DSigD valName (DConT ''Bool)) - , DLetDec (DValD (DVarPa valName) (DConE 'False)) + , DLetDec (DValD (DVarP valName) (DConE 'False)) , tyDec ] lookupReify lookup_fun = withLocalDeclarations decs $ do Just n <- lookup_fun nameStr @@ -369,6 +444,14 @@ let m_infos' = assumeStarT m_infos ListE <$> mapM (Syn.lift . show) (unqualify m_infos')) +type T123G = Either () () +type T123F = Either T123G T123G +type T123E = Either T123F T123F +type T123D = Either T123E T123E +type T123C = Either T123D T123D +type T123B = Either T123C T123C +type T123A = Either T123B T123B + $reifyDecs $(return []) -- somehow, this is necessary to get the staging correct for the @@ -428,8 +511,14 @@ -- GHC 7.6 uses containers-0.5.0.0 which doesn't have a good Data instance -- for Map. So we have to convert to lists before comparing. - eq = geq `on` fmap M.toList + eq = (==) `on` fmap M.toList +-- Test that type synonym expansion is efficient +test_t123 :: () +test_t123 = + $(do _ <- expand (DConT ''T123A) + [| () |]) + main :: IO () main = hspec $ do describe "th-desugar library" $ do @@ -444,10 +533,6 @@ [inst1, inst2] <- reifyInstances ''Show [ty] inst1 `eqTHSplice` inst2) -#if __GLASGOW_HASKELL__ < 707 - it "passes roles test" $ (decsToTH [ds_role_test]) `eqTH` role_test -#endif - it "makes type names" $ test_mkName it "fixes bug 8884" $ test_bug8884 @@ -466,7 +551,21 @@ it "expands type synonyms in kinds" $ test_t85 + it "toposorts free variables in polytypes" $ test_t92 + + it "expands type synonyms in type variable binders" $ test_t97 + + it "collects GADT record selectors correctly" $ test_t102 + + it "quantifies kind variables in desugared ADT constructors" $ test_t103 + it "reifies data type return kinds accurately" $ test_getDataD_kind_sig + + zipWithM (\b n -> it ("toposorts free variables deterministically " ++ show n) b) + test_t112 [1..] + + zipWithM (\b n -> it ("computes free variables correctly " ++ show n) b) + test_fvs [1..] -- 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 @@ -9,7 +9,8 @@ ScopedTypeVariables, RankNTypes, TypeFamilies, ImpredicativeTypes, DataKinds, PolyKinds, GADTs, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, StandaloneDeriving, - DefaultSignatures, ConstraintKinds, GADTs, ViewPatterns #-} + DefaultSignatures, ConstraintKinds, GADTs, ViewPatterns, + TupleSections #-} #if __GLASGOW_HASKELL__ >= 711 {-# LANGUAGE TypeApplications #-} @@ -31,6 +32,10 @@ {-# LANGUAGE QuantifiedConstraints #-} #endif +#if __GLASGOW_HASKELL__ >= 807 +{-# LANGUAGE ImplicitParams #-} +#endif + {-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-type-defaults -fno-warn-name-shadowing #-} @@ -43,16 +48,13 @@ import Language.Haskell.TH import Language.Haskell.TH.Desugar +import Language.Haskell.TH.Syntax (Quasi) import Data.Generics #if __GLASGOW_HASKELL__ >= 803 import GHC.OverloadedLabels ( IsLabel(..) ) #endif -#if __GLASGOW_HASKELL__ < 707 -data Proxy a = Proxy -#endif - dsSplice :: Q Exp -> Q Exp dsSplice expq = expq >>= dsExp >>= (return . expToTH) @@ -65,9 +67,6 @@ regName = mkName $ "Dec.Dec" ++ show n infoDs <- reify dsName infoReg <- reify regName -#if __GLASGOW_HASKELL__ < 707 - eqTHSplice infoDs infoReg -#else rolesDs <- reifyRoles dsName rolesReg <- reifyRoles regName #if __GLASGOW_HASKELL__ < 711 @@ -77,7 +76,6 @@ fixityReg <- reifyFixity regName eqTHSplice (infoDs, rolesDs, fixityDs) (infoReg, rolesReg, fixityReg) #endif -#endif unqualify :: Data a => a -> a unqualify = everywhere (mkT (mkName . nameBase)) @@ -104,8 +102,8 @@ eqTH :: (Data a, Show a) => a -> a -> Bool eqTH a b = show (unqualify a) == show (unqualify b) -eqTHSplice :: (Data a, Show a) => a -> a -> Q Exp -eqTHSplice a b = +eqTHSplice :: (Quasi q, Data a, Show a) => a -> a -> q Exp +eqTHSplice a b = runQ $ if a `eqTH` b then [| True |] else [| False |] @@ -124,10 +122,8 @@ ; x <- elemIndex 'l' fool ; return (x + 10) } |] test10_comp = [| [ (x, x+1) | x <- [1..10], x `mod` 2 == 0 ] |] -#if __GLASGOW_HASKELL__ >= 707 test11_parcomp = [| [ (x,y) | x <- [1..10], x `mod` 2 == 0 | y <- [2,5..20] ] |] test12_parcomp2 = [| [ (x,y,z) | x <- [1..10], z <- [3..100], x + z `mod` 2 == 0 | y <- [2,5..20] ] |] -#endif test13_sig = [| show (read "[10, 11, 12]" :: [Int]) |] data Record = MkRecord1 { field1 :: Bool, field2 :: Int } @@ -264,6 +260,32 @@ in f (Proxy @Int) (Proxy @Int) |] #endif +#if __GLASGOW_HASKELL__ >= 807 +test49_implicit_params = [| let f :: (?x :: Int, ?y :: Int) => (Int, Int) + f = + let ?x = ?y + ?y = ?x + in (?x, ?y) + in (let ?x = 42 + ?y = 27 + in f) |] + +test50_vka = [| let hrefl :: (:~~:) @Bool @Bool 'True 'True + hrefl = HRefl + in hrefl |] +#endif + +#if __GLASGOW_HASKELL__ >= 809 +test51_tuple_sections = + [| let f1 :: String -> Char -> (String, Int, Char) + f1 = (,5,) + + f2 :: String -> Char -> (# String, Int, Char #) + f2 = (#,5,#) + in case (#,#) (f1 "a" 'a') (f2 "b" 'b') of + (#,#) ((,,) _ a _) ((#,,#) _ b _) -> a + b |] +#endif + type family TFExpand x type instance TFExpand Int = Bool type instance TFExpand (Maybe a) = [a] @@ -274,7 +296,6 @@ f [True, False] = () in f |] -#if __GLASGOW_HASKELL__ >= 707 type family ClosedTF a where ClosedTF Int = Bool ClosedTF x = Char @@ -296,7 +317,6 @@ f True = () in f |] -#endif #if __GLASGOW_HASKELL__ >= 709 test_expand9 = [| let f :: TFExpand (Maybe (IO a)) -> IO () @@ -318,9 +338,7 @@ (f ()) |] #endif -#if __GLASGOW_HASKELL__ < 707 -dec_test_nums = [1..9] :: [Int] -#elif __GLASGOW_HASKELL__ < 709 +#if __GLASGOW_HASKELL__ < 709 dec_test_nums = [1..10] :: [Int] #else dec_test_nums = [1..11] :: [Int] @@ -333,9 +351,7 @@ 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 where MkDec4 :: (a, Int) -> Dec4 a |] @@ -346,27 +362,9 @@ dectest7 = [d| type family Dec7 a (b :: *) (c :: Bool) :: * -> * |] dectest8 = [d| type family Dec8 a |] dectest9 = [d| data family Dec9 a (b :: * -> *) :: * -> * |] - -#if __GLASGOW_HASKELL__ < 707 -ds_dectest10 = DClosedTypeFamilyD - (DTypeFamilyHead - (mkName "Dec10") - [DPlainTV (mkName "a")] - (DKindSig (DAppT (DAppT DArrowT (DConT typeKindName)) (DConT typeKindName))) - Nothing) - [ DTySynEqn [DConT ''Int] (DConT ''Maybe) - , DTySynEqn [DConT ''Bool] (DConT ''[]) ] -dectest10 = [d| type family Dec10 a :: * -> * - type instance Dec10 Int = Maybe - type instance Dec10 Bool = [] |] - -ds_role_test = DRoleAnnotD (mkName "Dec3") [NominalR] -role_test = [] -#else dectest10 = [d| type family Dec10 a :: * -> * where Dec10 Int = Maybe Dec10 Bool = [] |] -#endif data Blarggie a = MkBlarggie Int a #if __GLASGOW_HASKELL__ >= 709 @@ -401,6 +399,35 @@ (:^^:) :: Int -> Int -> Int -> InfixGADT Int (:!!:) :: Char -> Char -> InfixGADT Char |] +class ExCls a +data ExData1 a +data ExData2 a + +ds_dectest16 = DInstanceD Nothing (Just [DPlainTV (mkName "a")]) [] + (DConT ''ExCls `DAppT` + (DConT ''ExData1 `DAppT` DVarT (mkName "a"))) [] +dectest16 :: Q [Dec] +dectest16 = return [ InstanceD +#if __GLASGOW_HASKELL__ >= 800 + Nothing +#endif + [] (ForallT [PlainTV (mkName "a")] [] + (ConT ''ExCls `AppT` + (ConT ''ExData1 `AppT` VarT (mkName "a")))) [] ] +ds_dectest17 = DStandaloneDerivD Nothing (Just [DPlainTV (mkName "a")]) [] + (DConT ''ExCls `DAppT` + (DConT ''ExData2 `DAppT` DVarT (mkName "a"))) +#if __GLASGOW_HASKELL__ >= 710 +dectest17 :: Q [Dec] +dectest17 = return [ StandaloneDerivD +#if __GLASGOW_HASKELL__ >= 802 + Nothing +#endif + [] (ForallT [PlainTV (mkName "a")] [] + (ConT ''ExCls `AppT` + (ConT ''ExData2 `AppT` VarT (mkName "a")))) ] +#endif + instance_test = [d| instance (Show a, Show b) => Show (a -> b) where show _ = "function" |] @@ -498,16 +525,17 @@ newtype R18 = R19 Bool type R20 = Bool -#if __GLASGOW_HASKELL__ >= 707 type family R21 (a :: k) (b :: k) :: k where #if __GLASGOW_HASKELL__ >= 801 - R21 (a :: k) (b :: k) = b +#if __GLASGOW_HASKELL__ >= 807 + forall k (a :: k) (b :: k). +#endif + R21 (a :: k) (b :: k) = b #else -- Due to GHC Trac #12646, R21 will get reified without kind signatures on -- a and b on older GHCs, so we must reflect that here. R21 a b = b #endif -#endif class XXX a where r22 :: a -> a r22 = id -- test #32 @@ -556,6 +584,16 @@ newtype R24 a = MkR24 [a] deriving Eq via (Id [a]) #endif + +#if __GLASGOW_HASKELL__ >= 800 + class R25 (f :: k -> *) where + r26 :: forall (a :: k). f a + + data R27 (a :: k) = R28 { r29 :: Proxy a } +#endif + + class R30 a where + r31 :: a -> b -> a |] reifyDecsNames :: [Name] @@ -566,10 +604,12 @@ #endif , "R4", "R5", "R6", "R7", "r8", "r9", "R10", "r11" , "R12", "R13", "R14", "r15", "r16", "r17", "R18", "R19", "R20" -#if __GLASGOW_HASKELL__ >= 707 , "R21" -#endif , "r22" +#if __GLASGOW_HASKELL__ >= 800 + , "R25", "r26", "R28", "r29" +#endif + , "R30", "r31" ] simplCaseTests :: [Q Exp] @@ -605,10 +645,8 @@ , test8_case , test9_do , test10_comp -#if __GLASGOW_HASKELL__ >= 707 , test11_parcomp , test12_parcomp2 -#endif , test13_sig , test14_record , test15_litp @@ -647,5 +685,16 @@ , test45_empty_record_con #if __GLASGOW_HASKELL__ >= 803 , test46_overloaded_label +#endif + , test47_do_partial_match +#if __GLASGOW_HASKELL__ >= 805 + , test48_quantified_constraints +#endif +#if __GLASGOW_HASKELL__ >= 807 + , test49_implicit_params + , test50_vka +#endif +#if __GLASGOW_HASKELL__ >= 809 + , test51_tuple_sections #endif ] diff --git a/th-desugar.cabal b/th-desugar.cabal --- a/th-desugar.cabal +++ b/th-desugar.cabal @@ -1,5 +1,5 @@ name: th-desugar -version: 1.9 +version: 1.10 cabal-version: >= 1.10 synopsis: Functions to desugar Template Haskell homepage: https://github.com/goldfirere/th-desugar @@ -12,13 +12,13 @@ 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, GHC == 8.4.2, GHC == 8.4.3 - , GHC == 8.6.1 +tested-with: GHC == 7.8.4 + , GHC == 7.10.3 + , GHC == 8.0.2 + , GHC == 8.2.2 + , GHC == 8.4.4 + , GHC == 8.6.5 + , GHC == 8.8.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. @@ -33,7 +33,7 @@ source-repository this type: git location: https://github.com/goldfirere/th-desugar.git - tag: v1.9 + tag: v1.10 source-repository head type: git @@ -42,25 +42,34 @@ library build-depends: - base >= 4 && < 5, - template-haskell >= 2.8 && < 2.15, + base >= 4.7 && < 5, + ghc-prim, + template-haskell >= 2.9 && < 2.16, containers >= 0.5, + fail == 4.9.*, mtl >= 2.1, + ordered-containers >= 0.2.2, + semigroups >= 0.16, syb >= 0.4, + th-abstraction >= 0.2.11, th-lift >= 0.6.1, - th-orphans >= 0.9.1, - th-expand-syns >= 0.3.0.6 + th-orphans >= 0.13.7, + transformers-compat >= 0.6.3 default-extensions: TemplateHaskell - exposed-modules: Language.Haskell.TH.Desugar, - Language.Haskell.TH.Desugar.Sweeten, - Language.Haskell.TH.Desugar.Lift, - Language.Haskell.TH.Desugar.Expand, + exposed-modules: Language.Haskell.TH.Desugar + Language.Haskell.TH.Desugar.Expand + Language.Haskell.TH.Desugar.Lift + Language.Haskell.TH.Desugar.OMap + Language.Haskell.TH.Desugar.OMap.Strict + Language.Haskell.TH.Desugar.OSet Language.Haskell.TH.Desugar.Subst - 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.Sweeten + other-modules: Language.Haskell.TH.Desugar.AST + Language.Haskell.TH.Desugar.Core + Language.Haskell.TH.Desugar.FV + Language.Haskell.TH.Desugar.Match Language.Haskell.TH.Desugar.Reify + Language.Haskell.TH.Desugar.Util default-language: Haskell2010 ghc-options: -Wall