th-desugar 1.9 → 1.10
raw patch · 21 files changed
+2270/−953 lines, 21 filesdep +faildep +ghc-primdep +ordered-containersdep ~basedep ~template-haskelldep ~th-orphans
Dependencies added: fail, ghc-prim, ordered-containers, semigroups, th-abstraction, transformers-compat
Dependency ranges changed: base, template-haskell, th-orphans
Files
- CHANGES.md +78/−0
- Language/Haskell/TH/Desugar.hs +81/−62
- Language/Haskell/TH/Desugar/AST.hs +40/−56
- Language/Haskell/TH/Desugar/Core.hs +568/−362
- Language/Haskell/TH/Desugar/Expand.hs +73/−60
- Language/Haskell/TH/Desugar/FV.hs +70/−0
- Language/Haskell/TH/Desugar/Lift.hs +3/−4
- Language/Haskell/TH/Desugar/Match.hs +57/−59
- Language/Haskell/TH/Desugar/OMap.hs +151/−0
- Language/Haskell/TH/Desugar/OMap/Strict.hs +114/−0
- Language/Haskell/TH/Desugar/OSet.hs +121/−0
- Language/Haskell/TH/Desugar/Reify.hs +212/−75
- Language/Haskell/TH/Desugar/Subst.hs +5/−22
- Language/Haskell/TH/Desugar/Sweeten.hs +179/−80
- Language/Haskell/TH/Desugar/Util.hs +163/−51
- README.md +65/−0
- Test/Dec.hs +10/−3
- Test/DsDec.hs +28/−24
- Test/Run.hs +128/−29
- Test/Splices.hs +94/−45
- th-desugar.cabal +30/−21
CHANGES.md view
@@ -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.
Language/Haskell/TH/Desugar.hs view
@@ -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+ ]
Language/Haskell/TH/Desugar/AST.hs view
@@ -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)
Language/Haskell/TH/Desugar/Core.hs view
@@ -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"
Language/Haskell/TH/Desugar/Expand.hs view
@@ -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))
+ Language/Haskell/TH/Desugar/FV.hs view
@@ -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
Language/Haskell/TH/Desugar/Lift.hs view
@@ -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 ])
Language/Haskell/TH/Desugar/Match.hs view
@@ -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]]
+ Language/Haskell/TH/Desugar/OMap.hs view
@@ -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)
+ Language/Haskell/TH/Desugar/OMap/Strict.hs view
@@ -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)
+ Language/Haskell/TH/Desugar/OSet.hs view
@@ -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)
Language/Haskell/TH/Desugar/Reify.hs view
@@ -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
Language/Haskell/TH/Desugar/Subst.hs view
@@ -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
Language/Haskell/TH/Desugar/Sweeten.hs view
@@ -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'
Language/Haskell/TH/Desugar/Util.hs view
@@ -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
README.md view
@@ -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)
Test/Dec.hs view
@@ -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)
Test/DsDec.hs view
@@ -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))
Test/Run.hs view
@@ -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')
Test/Splices.hs view
@@ -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 ]
th-desugar.cabal view
@@ -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